[cig-commits] r20198 - in seismo/3D/SPECFEM3D/trunk/utils: . solver_classical_serial_Fortran_or_C_no_MPI solver_classical_serial_Fortran_or_C_no_MPI/DATABASES_FOR_SOLVER solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good
dkomati1 at geodynamics.org
dkomati1 at geodynamics.org
Sun May 20 06:57:14 PDT 2012
Author: dkomati1
Date: 2012-05-20 06:57:13 -0700 (Sun, 20 May 2012)
New Revision: 20198
Added:
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/DATABASES_FOR_SOLVER/
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/DATABASES_FOR_SOLVER/matrices.dat
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/constants.h
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/make_all_C.csh
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/make_all_Fortran_fastest.csh
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/make_all_Fortran_normal.csh
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/CMTSOLUTION
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_001GPUs_run_it_in_serial
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_004GPUs
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_016GPUs
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_64slices_validation_test_JCP_paper_multiGPU
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_OK_192GPUs_90percent_of_4GB
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/STATIONS
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/LICENSE
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/Makefile
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/OUTPUT_FILES/
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_missing_nodes.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_topography.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_topography_410_650.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_topography_cmb.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_topography_icb.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/anisotropic_inner_core_model.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/anisotropic_mantle_model.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/auto_ner.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/calc_jacobian.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/combine_AVS_DX.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/comp_source_spectrum.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/comp_source_time_function.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/compute_coordinates_grid.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/compute_element_properties.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/constants.h
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/count_number_of_sources.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/create_header_file.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/create_name_database.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/create_regions_mesh.F90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/create_serial_name_database.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/crustal_model.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/define_derivation_matrices.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/define_superbrick.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/euler_angles.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/exit_mpi.F90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_MPI_1D_buffers.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_MPI_cutplanes_eta.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_MPI_cutplanes_xi.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_absorb.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_backazimuth.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_cmt.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_ellipticity.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_global.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_jacobian_boundaries.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_jacobian_discontinuities.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_model.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_perm_color.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_shape2D.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_shape3D.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_value_parameters.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/gll_library.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/hex_nodes.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/intgrl.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/jp3d1994_model.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/lagrange_poly.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/lgndr.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/make_ellipticity.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/make_gravity.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/mantle_model.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/memory_eval.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/meshfem3D.F90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_1066a.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_ak135.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_iasp91.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_jp1d.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_prem.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_ref.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_sea1d.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/moho_stretching.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/netlib_specfun_erf.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/obj/
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/precision.h
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/read_compute_parameters.F90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/read_value_parameters.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/recompute_jacobian.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/reduce.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/rthetaphi_xyz.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/s362ani.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/save_arrays_solver.F90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/save_header_file.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/sea99_s_model.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/sort_array_coordinates.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/spline_routines.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/stretching_function.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/topo_bathy.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/write_AVS_DX_global_chunks_data.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/write_AVS_DX_global_data.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/write_AVS_DX_global_faces_data.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/write_AVS_DX_surface_data.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/plotall.gnu
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/read_arrays_solver.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_double.c
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_inlined_v03_is_the_fastest_no_more_function_calls.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_no_Deville.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_single_no_Deville.c
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_single_with_Deville.c
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/older_serial_specfem3D_inlined_v03_is_the_fastest_with_function_calls.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_22dec2008_NGLOB.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_22dec2008_NSPEC.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v01.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v02.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v04_is_slower.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v05_displx_y_z_3arrays.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v06_fac1_merged_not_faster.f90
seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/timings_comparing_all_versions.txt
Log:
committed utils/solver_classical_serial_Fortran_or_C_no_MPI, which was previously maintained on another SVN server in Pau, France
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/DATABASES_FOR_SOLVER/matrices.dat
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/DATABASES_FOR_SOLVER/matrices.dat (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/DATABASES_FOR_SOLVER/matrices.dat 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,125 @@
+ -5.00000000000000
+ -0.500000000000000
+ 1.000000000000000E-002
+ 1.000000000000000E-002
+ 1.000000000000000E-002
+ -1.24099025303098
+ -0.675650248872424
+ 5.444444444444444E-002
+ 5.444444444444444E-002
+ 5.444444444444444E-002
+ 0.375000000000000
+ 0.266666666666667
+ 7.111111111111111E-002
+ 7.111111111111111E-002
+ 7.111111111111111E-002
+ -0.259009746969017
+ -0.141016417794243
+ 5.444444444444444E-002
+ 5.444444444444444E-002
+ 5.444444444444444E-002
+ 0.500000000000000
+ 5.000000000000000E-002
+ 1.000000000000000E-002
+ 1.000000000000000E-002
+ 1.000000000000000E-002
+ 6.75650248872424
+ 0.675650248872424
+ 5.444444444444444E-002
+ 5.444444444444444E-002
+ 5.444444444444444E-002
+ 0.00000000000000
+ 0.00000000000000
+ 0.296419753086420
+ 0.296419753086420
+ 0.296419753086420
+ -1.33658457769545
+ -0.950460144138989
+ 0.387160493827160
+ 0.387160493827160
+ 0.387160493827160
+ 0.763762615825973
+ 0.415826313060808
+ 0.296419753086420
+ 0.296419753086420
+ 0.296419753086420
+ -1.41016417794243
+ -0.141016417794243
+ 5.444444444444444E-002
+ 5.444444444444444E-002
+ 5.444444444444444E-002
+ -2.66666666666667
+ -0.266666666666667
+ 7.111111111111111E-002
+ 7.111111111111111E-002
+ 7.111111111111111E-002
+ 1.74574312188794
+ 0.950460144138989
+ 0.387160493827160
+ 0.387160493827160
+ 0.387160493827160
+ 0.00000000000000
+ 0.00000000000000
+ 0.505679012345679
+ 0.505679012345679
+ 0.505679012345679
+ -1.74574312188794
+ -0.950460144138989
+ 0.387160493827160
+ 0.387160493827160
+ 0.387160493827160
+ 2.66666666666667
+ 0.266666666666667
+ 7.111111111111111E-002
+ 7.111111111111111E-002
+ 7.111111111111111E-002
+ 1.41016417794243
+ 0.141016417794243
+ 5.444444444444444E-002
+ 5.444444444444444E-002
+ 5.444444444444444E-002
+ -0.763762615825973
+ -0.415826313060808
+ 0.296419753086420
+ 0.296419753086420
+ 0.296419753086420
+ 1.33658457769545
+ 0.950460144138989
+ 0.387160493827160
+ 0.387160493827160
+ 0.387160493827160
+ 0.00000000000000
+ 0.00000000000000
+ 0.296419753086420
+ 0.296419753086420
+ 0.296419753086420
+ -6.75650248872424
+ -0.675650248872424
+ 5.444444444444444E-002
+ 5.444444444444444E-002
+ 5.444444444444444E-002
+ -0.500000000000000
+ -5.000000000000000E-002
+ 1.000000000000000E-002
+ 1.000000000000000E-002
+ 1.000000000000000E-002
+ 0.259009746969017
+ 0.141016417794243
+ 5.444444444444444E-002
+ 5.444444444444444E-002
+ 5.444444444444444E-002
+ -0.375000000000000
+ -0.266666666666667
+ 7.111111111111111E-002
+ 7.111111111111111E-002
+ 7.111111111111111E-002
+ 1.24099025303098
+ 0.675650248872424
+ 5.444444444444444E-002
+ 5.444444444444444E-002
+ 5.444444444444444E-002
+ 5.00000000000000
+ 0.500000000000000
+ 1.000000000000000E-002
+ 1.000000000000000E-002
+ 1.000000000000000E-002
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/constants.h
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/constants.h (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/constants.h 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,11 @@
+
+! number of GLL integration points in each direction of an element (degree plus one)
+ integer, parameter :: NGLLX = 5
+ integer, parameter :: NGLLY = NGLLX
+ integer, parameter :: NGLLZ = NGLLX
+
+ integer, parameter :: m1 = 5, m2 = 25
+
+! very large and very small values
+ double precision, parameter :: HUGEVAL = 1.d+30
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/make_all_C.csh
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/make_all_C.csh (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/make_all_C.csh 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,27 @@
+
+rm -f xspecfem3D* *.o
+
+# add -vec-report3 to get information about loops that are vectorized or not
+# do NOT suppress -ftz, which is critical for performance
+
+# on some machines -fast does NOT work when linking C with Fortran for some reason
+# in that case you can switch back to -O3 -xSSE4.1 .
+# Can add -ftrapuv -traceback to debug if needed.
+#icc -c -O3 -xSSE4.1 -ftz -funroll-loops -unroll5 -vec-report1 -std=c99 -x c -Wcheck serial_specfem3D_single_no_Deville.c
+#ifort -o xspecfem3D_C -O3 -xSSE4.1 -ftz -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nobounds serial_specfem3D_single_no_Deville.o read_arrays_solver.f90 -nofor_main
+
+icc -c -O3 -xSSE4.1 -ftz -funroll-loops -unroll5 -vec-report1 -std=c99 -x c -Wcheck serial_specfem3D_single_with_Deville.c
+ifort -o xspecfem3D_C -O3 -xSSE4.1 -ftz -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nobounds serial_specfem3D_single_with_Deville.o read_arrays_solver.f90 -nofor_main
+
+# GNU gcc (but I have found NO way of really turning flush-to-zero (FTZ) on i.e. turning
+# gradual underflow off, and as a result the code is twice slower than it should when using gcc!!!)
+#
+# gcc -c -fbounds-check -Wall -fno-trapping-math -fno-signaling-nans -std=gnu99 -O3 serial_specfem3D_single_with_Deville.c
+# gfortran -o xspecfem3D_C -O3 -std=f95 -fimplicit-none -frange-check -O3 -pedantic -pedantic-errors -Waliasing -Wampersand -Wline-truncation -Wsurprising -Wunderflow -fno-trapping-math serial_specfem3D_single_with_Deville.o read_arrays_solver.f90
+
+# g++ -fno-trapping-math -O3 -o xspecfem3D_C serial_specfem3D_single_with_Deville.c -lm
+
+# pgcc -fast -Mnobounds -Minline -Mneginfo -Knoieee -Minform=warn -fastsse -tp amd64e -o xspecfem3D_C serial_specfem3D_single_with_Deville.c -lm
+
+rm -f *.o
+
Property changes on: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/make_all_C.csh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/make_all_Fortran_fastest.csh
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/make_all_Fortran_fastest.csh (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/make_all_Fortran_fastest.csh 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,17 @@
+
+rm -f xspecfem3D* *.o
+
+# Intel ifort compiler
+# add -Winline to get information about routines that are inlined
+# add -vec-report3 to get information about loops that are vectorized or not
+# do NOT suppress -ftz, which is critical for performance
+ifort -O3 -xSSE4.2 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nobounds -align sequence -assume byterecl -ftz -o xspecfem3D_F90 serial_specfem3D_inlined_v03_is_the_fastest_no_more_function_calls.f90 read_arrays_solver.f90
+
+# other compilers
+
+#gfortran -std=gnu -fimplicit-none -O3 -fno-trapping-math -Wunused-labels -Waliasing -Wampersand -Wsurprising -Wline-truncation -Wunderflow -o xspecfem3D_F90 serial_specfem3D_inlined_v03_is_the_fastest_no_more_function_calls.f90 read_arrays_solver.f90
+
+#pgf90 -fast -Mnobounds -Minline -Mneginfo -Mdclchk -Knoieee -Minform=warn -Mstandard -fastsse -tp amd64e -o xspecfem3D_F90 serial_specfem3D_inlined_v03_is_the_fastest_no_more_function_calls.f90 read_arrays_solver.f90
+
+#xlf_r -O3 -qsave -qstrict -qtune=ppc970 -qarch=ppc64v -qcache=auto -qfree=f90 -Q -qflttrap=en:ov:zero:inv -o xspecfem3D_f90 serial_specfem3D_inlined_v03_is_the_fastest_no_more_function_calls.f90 read_arrays_solver.f90
+
Property changes on: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/make_all_Fortran_fastest.csh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/make_all_Fortran_normal.csh
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/make_all_Fortran_normal.csh (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/make_all_Fortran_normal.csh 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,17 @@
+
+rm -f xspecfem3D* *.o
+
+# Intel ifort compiler
+# add -Winline to get information about routines that are inlined
+# add -vec-report3 to get information about loops that are vectorized or not
+# do NOT suppress -ftz, which is critical for performance
+ifort -O3 -xSSE4.2 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nobounds -align sequence -assume byterecl -ftz -o xspecfem3D_F90 serial_specfem3D_no_Deville.f90 read_arrays_solver.f90
+
+# other compilers
+
+#gfortran -std=gnu -fimplicit-none -O3 -fno-trapping-math -Wunused-labels -Waliasing -Wampersand -Wsurprising -Wline-truncation -Wunderflow -o xspecfem3D_F90 serial_specfem3D_no_Deville.f90 read_arrays_solver.f90
+
+#pgf90 -fast -Mnobounds -Minline -Mneginfo -Mdclchk -Knoieee -Minform=warn -Mstandard -fastsse -tp amd64e -o xspecfem3D_F90 serial_specfem3D_no_Deville.f90 read_arrays_solver.f90
+
+#xlf_r -O3 -qsave -qstrict -qtune=ppc970 -qarch=ppc64v -qcache=auto -qfree=f90 -Q -qflttrap=en:ov:zero:inv -o xspecfem3D_f90 serial_specfem3D_no_Deville.f90 read_arrays_solver.f90
+
Property changes on: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/make_all_Fortran_normal.csh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/CMTSOLUTION
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/CMTSOLUTION (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/CMTSOLUTION 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,13 @@
+PDE 1994 6 9 0 33 16.40 -13.8300 -67.5600 637.0 6.9 6.8 NORTHERNBOLIVIA
+event name: 060994A
+time shift: 0.0000
+half duration: 35.0000
+latitude: -13.8200
+longitude: -67.2500
+depth: 647.1000
+Mrr: -7.600000e+27
+Mtt: 7.700000e+27
+Mpp: -2.000000e+26
+Mrt: -2.500000e+28
+Mrp: 4.000000e+26
+Mtp: -2.500000e+27
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,113 @@
+
+# forward or adjoint simulation
+SIMULATION_TYPE = 1
+SAVE_FORWARD = .false. # save last frame of forward simulation or not
+
+# number of chunks (1,2,3 or 6)
+NCHUNKS = 1
+
+# angular width of the first chunk (not used if full sphere with six chunks)
+ANGULAR_WIDTH_XI_IN_DEGREES = 90.d0 # angular size of a chunk
+ANGULAR_WIDTH_ETA_IN_DEGREES = 90.d0
+CENTER_LATITUDE_IN_DEGREES = 40.d0
+CENTER_LONGITUDE_IN_DEGREES = 10.d0
+GAMMA_ROTATION_AZIMUTH = 20.d0
+
+# number of elements at the surface along the two sides of the first chunk
+# (must be multiple of 16 and 8 * multiple of NPROC below)
+NEX_XI = 64
+NEX_ETA = 64
+
+# number of MPI processors along the two sides of the first chunk
+NPROC_XI = 4
+NPROC_ETA = 4
+
+# 1D models with real structure:
+# 1D_isotropic_prem, 1D_transversely_isotropic_prem, 1D_iasp91, 1D_1066a, 1D_ak135, 1D_ref, 1D_ref_iso, 1D_jp3d,1D_sea99
+#
+# 1D models with only one fictitious averaged crustal layer:
+# 1D_isotropic_prem_onecrust, 1D_transversely_isotropic_prem_onecrust, 1D_iasp91_onecrust, 1D_1066a_onecrust, 1D_ak135_onecrust
+#
+# fully 3D models:
+# transversely_isotropic_prem_plus_3D_crust_2.0, 3D_anisotropic, 3D_attenuation,
+# s20rts, s362ani, s362iso, s362wmani, s362ani_prem, s29ea, s29ea,sea99_jp3d1994,sea99,jp3d1994
+MODEL = 1D_isotropic_prem
+
+# parameters describing the Earth model
+OCEANS = .false.
+ELLIPTICITY = .false.
+TOPOGRAPHY = .false.
+GRAVITY = .false.
+ROTATION = .false.
+ATTENUATION = .false.
+
+# absorbing boundary conditions for a regional simulation
+ABSORBING_CONDITIONS = .false.
+
+# record length in minutes
+RECORD_LENGTH_IN_MINUTES = 20.0d0
+
+# save AVS or OpenDX movies
+#MOVIE_COARSE saves movie only at corners of elements (SURFACE OR VOLUME)
+#MOVIE_COARSE does not work with create_movie_AVS_DX
+MOVIE_SURFACE = .false.
+MOVIE_VOLUME = .false.
+MOVIE_COARSE = .false.
+NTSTEP_BETWEEN_FRAMES = 100
+HDUR_MOVIE = 0.d0
+
+# save movie in volume. Will save element if center of element is in prescribed volume
+# top/bottom: depth in KM, use MOVIE_TOP = -100 to make sure the surface is stored.
+# west/east: longitude, degrees East [-180/180] top/bottom: latitute, degrees North [-90/90]
+# start/stop: frames will be stored at MOVIE_START + i*NSTEP_BETWEEN_FRAMES, where i=(0,1,2..) and iNSTEP_BETWEEN_FRAMES <= MOVIE_STOP
+# movie_volume_type: 1=strain, 2=time integral of strain, 3=\mu*time integral of strain
+# type 4 saves the trace and deviatoric stress in the whole volume, 5=displacement, 6=velocity
+MOVIE_VOLUME_TYPE = 2
+MOVIE_TOP_KM = -100.0
+MOVIE_BOTTOM_KM = 1000.0
+MOVIE_WEST_DEG = -90.0
+MOVIE_EAST_DEG = 90.0
+MOVIE_NORTH_DEG = 90.0
+MOVIE_SOUTH_DEG = -90.0
+MOVIE_START = 0
+MOVIE_STOP = 40000
+
+# save mesh files to check the mesh
+SAVE_MESH_FILES = .false.
+
+# restart files (number of runs can be 1, 2 or 3, choose 1 for no restart files)
+NUMBER_OF_RUNS = 1
+NUMBER_OF_THIS_RUN = 1
+
+# path to store the local database files on each node
+LOCAL_PATH = ../DATABASES_FOR_SOLVER
+
+# interval at which we output time step info and max of norm of displacement
+NTSTEP_BETWEEN_OUTPUT_INFO = 100
+
+# interval in time steps for temporary writing of seismograms
+NTSTEP_BETWEEN_OUTPUT_SEISMOS = 5000000
+NTSTEP_BETWEEN_READ_ADJSRC = 1000
+
+# output format for the seismograms (one can use either or all of the three formats)
+OUTPUT_SEISMOS_ASCII_TEXT = .true.
+OUTPUT_SEISMOS_SAC_ALPHANUM = .false.
+OUTPUT_SEISMOS_SAC_BINARY = .false.
+
+# rotate seismograms to Radial-Transverse-Z or use default North-East-Z reference frame
+ROTATE_SEISMOGRAMS_RT = .false.
+
+# decide if master process writes all the seismograms or if all processes do it in parallel
+WRITE_SEISMOGRAMS_BY_MASTER = .true.
+
+# 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
+SAVE_ALL_SEISMOS_IN_ONE_FILE = .false.
+USE_BINARY_FOR_LARGE_FILE = .false.
+
+# flag to impose receivers at the surface or allow them to be buried
+RECEIVERS_CAN_BE_BURIED = .false.
+
+# print source time function
+PRINT_SOURCE_TIME_FUNCTION = .false.
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_001GPUs_run_it_in_serial
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_001GPUs_run_it_in_serial (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_001GPUs_run_it_in_serial 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,113 @@
+
+# forward or adjoint simulation
+SIMULATION_TYPE = 1
+SAVE_FORWARD = .false. # save last frame of forward simulation or not
+
+# number of chunks (1,2,3 or 6)
+NCHUNKS = 1
+
+# angular width of the first chunk (not used if full sphere with six chunks)
+ANGULAR_WIDTH_XI_IN_DEGREES = 90.d0 # angular size of a chunk
+ANGULAR_WIDTH_ETA_IN_DEGREES = 90.d0
+CENTER_LATITUDE_IN_DEGREES = 40.d0
+CENTER_LONGITUDE_IN_DEGREES = 10.d0
+GAMMA_ROTATION_AZIMUTH = 20.d0
+
+# number of elements at the surface along the two sides of the first chunk
+# (must be multiple of 16 and 8 * multiple of NPROC below)
+NEX_XI = 64
+NEX_ETA = 64
+
+# number of MPI processors along the two sides of the first chunk
+NPROC_XI = 4
+NPROC_ETA = 4
+
+# 1D models with real structure:
+# 1D_isotropic_prem, 1D_transversely_isotropic_prem, 1D_iasp91, 1D_1066a, 1D_ak135, 1D_ref, 1D_ref_iso, 1D_jp3d,1D_sea99
+#
+# 1D models with only one fictitious averaged crustal layer:
+# 1D_isotropic_prem_onecrust, 1D_transversely_isotropic_prem_onecrust, 1D_iasp91_onecrust, 1D_1066a_onecrust, 1D_ak135_onecrust
+#
+# fully 3D models:
+# transversely_isotropic_prem_plus_3D_crust_2.0, 3D_anisotropic, 3D_attenuation,
+# s20rts, s362ani, s362iso, s362wmani, s362ani_prem, s29ea, s29ea,sea99_jp3d1994,sea99,jp3d1994
+MODEL = 1D_isotropic_prem
+
+# parameters describing the Earth model
+OCEANS = .false.
+ELLIPTICITY = .false.
+TOPOGRAPHY = .false.
+GRAVITY = .false.
+ROTATION = .false.
+ATTENUATION = .false.
+
+# absorbing boundary conditions for a regional simulation
+ABSORBING_CONDITIONS = .false.
+
+# record length in minutes
+RECORD_LENGTH_IN_MINUTES = 20.0d0
+
+# save AVS or OpenDX movies
+#MOVIE_COARSE saves movie only at corners of elements (SURFACE OR VOLUME)
+#MOVIE_COARSE does not work with create_movie_AVS_DX
+MOVIE_SURFACE = .false.
+MOVIE_VOLUME = .false.
+MOVIE_COARSE = .false.
+NTSTEP_BETWEEN_FRAMES = 100
+HDUR_MOVIE = 0.d0
+
+# save movie in volume. Will save element if center of element is in prescribed volume
+# top/bottom: depth in KM, use MOVIE_TOP = -100 to make sure the surface is stored.
+# west/east: longitude, degrees East [-180/180] top/bottom: latitute, degrees North [-90/90]
+# start/stop: frames will be stored at MOVIE_START + i*NSTEP_BETWEEN_FRAMES, where i=(0,1,2..) and iNSTEP_BETWEEN_FRAMES <= MOVIE_STOP
+# movie_volume_type: 1=strain, 2=time integral of strain, 3=\mu*time integral of strain
+# type 4 saves the trace and deviatoric stress in the whole volume, 5=displacement, 6=velocity
+MOVIE_VOLUME_TYPE = 2
+MOVIE_TOP_KM = -100.0
+MOVIE_BOTTOM_KM = 1000.0
+MOVIE_WEST_DEG = -90.0
+MOVIE_EAST_DEG = 90.0
+MOVIE_NORTH_DEG = 90.0
+MOVIE_SOUTH_DEG = -90.0
+MOVIE_START = 0
+MOVIE_STOP = 40000
+
+# save mesh files to check the mesh
+SAVE_MESH_FILES = .false.
+
+# restart files (number of runs can be 1, 2 or 3, choose 1 for no restart files)
+NUMBER_OF_RUNS = 1
+NUMBER_OF_THIS_RUN = 1
+
+# path to store the local database files on each node
+LOCAL_PATH = ../DATABASES_FOR_SOLVER
+
+# interval at which we output time step info and max of norm of displacement
+NTSTEP_BETWEEN_OUTPUT_INFO = 100
+
+# interval in time steps for temporary writing of seismograms
+NTSTEP_BETWEEN_OUTPUT_SEISMOS = 5000000
+NTSTEP_BETWEEN_READ_ADJSRC = 1000
+
+# output format for the seismograms (one can use either or all of the three formats)
+OUTPUT_SEISMOS_ASCII_TEXT = .true.
+OUTPUT_SEISMOS_SAC_ALPHANUM = .false.
+OUTPUT_SEISMOS_SAC_BINARY = .false.
+
+# rotate seismograms to Radial-Transverse-Z or use default North-East-Z reference frame
+ROTATE_SEISMOGRAMS_RT = .false.
+
+# decide if master process writes all the seismograms or if all processes do it in parallel
+WRITE_SEISMOGRAMS_BY_MASTER = .true.
+
+# 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
+SAVE_ALL_SEISMOS_IN_ONE_FILE = .false.
+USE_BINARY_FOR_LARGE_FILE = .false.
+
+# flag to impose receivers at the surface or allow them to be buried
+RECEIVERS_CAN_BE_BURIED = .false.
+
+# print source time function
+PRINT_SOURCE_TIME_FUNCTION = .false.
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_004GPUs
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_004GPUs (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_004GPUs 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,113 @@
+
+# forward or adjoint simulation
+SIMULATION_TYPE = 1
+SAVE_FORWARD = .false. # save last frame of forward simulation or not
+
+# number of chunks (1,2,3 or 6)
+NCHUNKS = 1
+
+# angular width of the first chunk (not used if full sphere with six chunks)
+ANGULAR_WIDTH_XI_IN_DEGREES = 90.d0 # angular size of a chunk
+ANGULAR_WIDTH_ETA_IN_DEGREES = 90.d0
+CENTER_LATITUDE_IN_DEGREES = 40.d0
+CENTER_LONGITUDE_IN_DEGREES = 10.d0
+GAMMA_ROTATION_AZIMUTH = 20.d0
+
+# number of elements at the surface along the two sides of the first chunk
+# (must be multiple of 16 and 8 * multiple of NPROC below)
+NEX_XI = 64
+NEX_ETA = 64
+
+# number of MPI processors along the two sides of the first chunk
+NPROC_XI = 2
+NPROC_ETA = 2
+
+# 1D models with real structure:
+# 1D_isotropic_prem, 1D_transversely_isotropic_prem, 1D_iasp91, 1D_1066a, 1D_ak135, 1D_ref, 1D_ref_iso, 1D_jp3d,1D_sea99
+#
+# 1D models with only one fictitious averaged crustal layer:
+# 1D_isotropic_prem_onecrust, 1D_transversely_isotropic_prem_onecrust, 1D_iasp91_onecrust, 1D_1066a_onecrust, 1D_ak135_onecrust
+#
+# fully 3D models:
+# transversely_isotropic_prem_plus_3D_crust_2.0, 3D_anisotropic, 3D_attenuation,
+# s20rts, s362ani, s362iso, s362wmani, s362ani_prem, s29ea, s29ea,sea99_jp3d1994,sea99,jp3d1994
+MODEL = 1D_isotropic_prem
+
+# parameters describing the Earth model
+OCEANS = .false.
+ELLIPTICITY = .false.
+TOPOGRAPHY = .false.
+GRAVITY = .false.
+ROTATION = .false.
+ATTENUATION = .false.
+
+# absorbing boundary conditions for a regional simulation
+ABSORBING_CONDITIONS = .false.
+
+# record length in minutes
+RECORD_LENGTH_IN_MINUTES = 20.0d0
+
+# save AVS or OpenDX movies
+#MOVIE_COARSE saves movie only at corners of elements (SURFACE OR VOLUME)
+#MOVIE_COARSE does not work with create_movie_AVS_DX
+MOVIE_SURFACE = .false.
+MOVIE_VOLUME = .false.
+MOVIE_COARSE = .false.
+NTSTEP_BETWEEN_FRAMES = 100
+HDUR_MOVIE = 0.d0
+
+# save movie in volume. Will save element if center of element is in prescribed volume
+# top/bottom: depth in KM, use MOVIE_TOP = -100 to make sure the surface is stored.
+# west/east: longitude, degrees East [-180/180] top/bottom: latitute, degrees North [-90/90]
+# start/stop: frames will be stored at MOVIE_START + i*NSTEP_BETWEEN_FRAMES, where i=(0,1,2..) and iNSTEP_BETWEEN_FRAMES <= MOVIE_STOP
+# movie_volume_type: 1=strain, 2=time integral of strain, 3=\mu*time integral of strain
+# type 4 saves the trace and deviatoric stress in the whole volume, 5=displacement, 6=velocity
+MOVIE_VOLUME_TYPE = 2
+MOVIE_TOP_KM = -100.0
+MOVIE_BOTTOM_KM = 1000.0
+MOVIE_WEST_DEG = -90.0
+MOVIE_EAST_DEG = 90.0
+MOVIE_NORTH_DEG = 90.0
+MOVIE_SOUTH_DEG = -90.0
+MOVIE_START = 0
+MOVIE_STOP = 40000
+
+# save mesh files to check the mesh
+SAVE_MESH_FILES = .false.
+
+# restart files (number of runs can be 1, 2 or 3, choose 1 for no restart files)
+NUMBER_OF_RUNS = 1
+NUMBER_OF_THIS_RUN = 1
+
+# path to store the local database files on each node
+LOCAL_PATH = ../DATABASES_FOR_SOLVER
+
+# interval at which we output time step info and max of norm of displacement
+NTSTEP_BETWEEN_OUTPUT_INFO = 100
+
+# interval in time steps for temporary writing of seismograms
+NTSTEP_BETWEEN_OUTPUT_SEISMOS = 5000000
+NTSTEP_BETWEEN_READ_ADJSRC = 1000
+
+# output format for the seismograms (one can use either or all of the three formats)
+OUTPUT_SEISMOS_ASCII_TEXT = .true.
+OUTPUT_SEISMOS_SAC_ALPHANUM = .false.
+OUTPUT_SEISMOS_SAC_BINARY = .false.
+
+# rotate seismograms to Radial-Transverse-Z or use default North-East-Z reference frame
+ROTATE_SEISMOGRAMS_RT = .false.
+
+# decide if master process writes all the seismograms or if all processes do it in parallel
+WRITE_SEISMOGRAMS_BY_MASTER = .true.
+
+# 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
+SAVE_ALL_SEISMOS_IN_ONE_FILE = .false.
+USE_BINARY_FOR_LARGE_FILE = .false.
+
+# flag to impose receivers at the surface or allow them to be buried
+RECEIVERS_CAN_BE_BURIED = .false.
+
+# print source time function
+PRINT_SOURCE_TIME_FUNCTION = .false.
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_016GPUs
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_016GPUs (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_016GPUs 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,113 @@
+
+# forward or adjoint simulation
+SIMULATION_TYPE = 1
+SAVE_FORWARD = .false. # save last frame of forward simulation or not
+
+# number of chunks (1,2,3 or 6)
+NCHUNKS = 1
+
+# angular width of the first chunk (not used if full sphere with six chunks)
+ANGULAR_WIDTH_XI_IN_DEGREES = 90.d0 # angular size of a chunk
+ANGULAR_WIDTH_ETA_IN_DEGREES = 90.d0
+CENTER_LATITUDE_IN_DEGREES = 40.d0
+CENTER_LONGITUDE_IN_DEGREES = 10.d0
+GAMMA_ROTATION_AZIMUTH = 20.d0
+
+# number of elements at the surface along the two sides of the first chunk
+# (must be multiple of 16 and 8 * multiple of NPROC below)
+NEX_XI = 64
+NEX_ETA = 64
+
+# number of MPI processors along the two sides of the first chunk
+NPROC_XI = 4
+NPROC_ETA = 4
+
+# 1D models with real structure:
+# 1D_isotropic_prem, 1D_transversely_isotropic_prem, 1D_iasp91, 1D_1066a, 1D_ak135, 1D_ref, 1D_ref_iso, 1D_jp3d,1D_sea99
+#
+# 1D models with only one fictitious averaged crustal layer:
+# 1D_isotropic_prem_onecrust, 1D_transversely_isotropic_prem_onecrust, 1D_iasp91_onecrust, 1D_1066a_onecrust, 1D_ak135_onecrust
+#
+# fully 3D models:
+# transversely_isotropic_prem_plus_3D_crust_2.0, 3D_anisotropic, 3D_attenuation,
+# s20rts, s362ani, s362iso, s362wmani, s362ani_prem, s29ea, s29ea,sea99_jp3d1994,sea99,jp3d1994
+MODEL = 1D_isotropic_prem
+
+# parameters describing the Earth model
+OCEANS = .false.
+ELLIPTICITY = .false.
+TOPOGRAPHY = .false.
+GRAVITY = .false.
+ROTATION = .false.
+ATTENUATION = .false.
+
+# absorbing boundary conditions for a regional simulation
+ABSORBING_CONDITIONS = .false.
+
+# record length in minutes
+RECORD_LENGTH_IN_MINUTES = 20.0d0
+
+# save AVS or OpenDX movies
+#MOVIE_COARSE saves movie only at corners of elements (SURFACE OR VOLUME)
+#MOVIE_COARSE does not work with create_movie_AVS_DX
+MOVIE_SURFACE = .false.
+MOVIE_VOLUME = .false.
+MOVIE_COARSE = .false.
+NTSTEP_BETWEEN_FRAMES = 100
+HDUR_MOVIE = 0.d0
+
+# save movie in volume. Will save element if center of element is in prescribed volume
+# top/bottom: depth in KM, use MOVIE_TOP = -100 to make sure the surface is stored.
+# west/east: longitude, degrees East [-180/180] top/bottom: latitute, degrees North [-90/90]
+# start/stop: frames will be stored at MOVIE_START + i*NSTEP_BETWEEN_FRAMES, where i=(0,1,2..) and iNSTEP_BETWEEN_FRAMES <= MOVIE_STOP
+# movie_volume_type: 1=strain, 2=time integral of strain, 3=\mu*time integral of strain
+# type 4 saves the trace and deviatoric stress in the whole volume, 5=displacement, 6=velocity
+MOVIE_VOLUME_TYPE = 2
+MOVIE_TOP_KM = -100.0
+MOVIE_BOTTOM_KM = 1000.0
+MOVIE_WEST_DEG = -90.0
+MOVIE_EAST_DEG = 90.0
+MOVIE_NORTH_DEG = 90.0
+MOVIE_SOUTH_DEG = -90.0
+MOVIE_START = 0
+MOVIE_STOP = 40000
+
+# save mesh files to check the mesh
+SAVE_MESH_FILES = .false.
+
+# restart files (number of runs can be 1, 2 or 3, choose 1 for no restart files)
+NUMBER_OF_RUNS = 1
+NUMBER_OF_THIS_RUN = 1
+
+# path to store the local database files on each node
+LOCAL_PATH = ../DATABASES_FOR_SOLVER
+
+# interval at which we output time step info and max of norm of displacement
+NTSTEP_BETWEEN_OUTPUT_INFO = 100
+
+# interval in time steps for temporary writing of seismograms
+NTSTEP_BETWEEN_OUTPUT_SEISMOS = 5000000
+NTSTEP_BETWEEN_READ_ADJSRC = 1000
+
+# output format for the seismograms (one can use either or all of the three formats)
+OUTPUT_SEISMOS_ASCII_TEXT = .true.
+OUTPUT_SEISMOS_SAC_ALPHANUM = .false.
+OUTPUT_SEISMOS_SAC_BINARY = .false.
+
+# rotate seismograms to Radial-Transverse-Z or use default North-East-Z reference frame
+ROTATE_SEISMOGRAMS_RT = .false.
+
+# decide if master process writes all the seismograms or if all processes do it in parallel
+WRITE_SEISMOGRAMS_BY_MASTER = .true.
+
+# 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
+SAVE_ALL_SEISMOS_IN_ONE_FILE = .false.
+USE_BINARY_FOR_LARGE_FILE = .false.
+
+# flag to impose receivers at the surface or allow them to be buried
+RECEIVERS_CAN_BE_BURIED = .false.
+
+# print source time function
+PRINT_SOURCE_TIME_FUNCTION = .false.
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_64slices_validation_test_JCP_paper_multiGPU
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_64slices_validation_test_JCP_paper_multiGPU (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_64slices_validation_test_JCP_paper_multiGPU 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,113 @@
+
+# forward or adjoint simulation
+SIMULATION_TYPE = 1
+SAVE_FORWARD = .false. # save last frame of forward simulation or not
+
+# number of chunks (1,2,3 or 6)
+NCHUNKS = 1
+
+# angular width of the first chunk (not used if full sphere with six chunks)
+ANGULAR_WIDTH_XI_IN_DEGREES = 90.d0 # angular size of a chunk
+ANGULAR_WIDTH_ETA_IN_DEGREES = 90.d0
+CENTER_LATITUDE_IN_DEGREES = 90.d0
+CENTER_LONGITUDE_IN_DEGREES = 0.d0
+GAMMA_ROTATION_AZIMUTH = 0.d0
+
+# number of elements at the surface along the two sides of the first chunk
+# (must be a multiple of 16 and also 8 * a multiple of NPROC below)
+NEX_XI = 256 # 512 # 1280 # 1216 # 1152 # 1088 # 1024 # 960 # 896 # 832 # 768 # 384
+NEX_ETA = 256 # 512 # 1536 # DK DK do not change this 768 # 384
+
+# number of MPI processors along the two sides of the first chunk
+NPROC_XI = 8 # 2 # 4 # 12
+NPROC_ETA = 8 # 96 # 48 # 16
+
+# 1D models with real structure:
+# 1D_isotropic_prem, 1D_transversely_isotropic_prem, 1D_iasp91, 1D_1066a, 1D_ak135, 1D_ref, 1D_ref_iso, 1D_jp3d,1D_sea99
+#
+# 1D models with only one fictitious averaged crustal layer:
+# 1D_isotropic_prem_onecrust, 1D_transversely_isotropic_prem_onecrust, 1D_iasp91_onecrust, 1D_1066a_onecrust, 1D_ak135_onecrust
+#
+# fully 3D models:
+# transversely_isotropic_prem_plus_3D_crust_2.0, 3D_anisotropic, 3D_attenuation,
+# s20rts, s362ani, s362iso, s362wmani, s362ani_prem, s29ea, s29ea,sea99_jp3d1994,sea99,jp3d1994
+MODEL = 1D_isotropic_prem
+
+# parameters describing the Earth model
+OCEANS = .false.
+ELLIPTICITY = .false.
+TOPOGRAPHY = .false.
+GRAVITY = .false.
+ROTATION = .false.
+ATTENUATION = .false.
+
+# absorbing boundary conditions for a regional simulation
+ABSORBING_CONDITIONS = .false.
+
+# record length in minutes
+RECORD_LENGTH_IN_MINUTES = 33.0d0
+
+# save AVS or OpenDX movies
+#MOVIE_COARSE saves movie only at corners of elements (SURFACE OR VOLUME)
+#MOVIE_COARSE does not work with create_movie_AVS_DX
+MOVIE_SURFACE = .false.
+MOVIE_VOLUME = .false.
+MOVIE_COARSE = .false.
+NTSTEP_BETWEEN_FRAMES = 100
+HDUR_MOVIE = 0.d0
+
+# save movie in volume. Will save element if center of element is in prescribed volume
+# top/bottom: depth in KM, use MOVIE_TOP = -100 to make sure the surface is stored.
+# west/east: longitude, degrees East [-180/180] top/bottom: latitute, degrees North [-90/90]
+# start/stop: frames will be stored at MOVIE_START + i*NSTEP_BETWEEN_FRAMES, where i=(0,1,2..) and iNSTEP_BETWEEN_FRAMES <= MOVIE_STOP
+# movie_volume_type: 1=strain, 2=time integral of strain, 3=\mu*time integral of strain
+# type 4 saves the trace and deviatoric stress in the whole volume, 5=displacement, 6=velocity
+MOVIE_VOLUME_TYPE = 2
+MOVIE_TOP_KM = -100.0
+MOVIE_BOTTOM_KM = 1000.0
+MOVIE_WEST_DEG = -90.0
+MOVIE_EAST_DEG = 90.0
+MOVIE_NORTH_DEG = 90.0
+MOVIE_SOUTH_DEG = -90.0
+MOVIE_START = 0
+MOVIE_STOP = 40000
+
+# save mesh files to check the mesh
+SAVE_MESH_FILES = .false.
+
+# restart files (number of runs can be 1, 2 or 3, choose 1 for no restart files)
+NUMBER_OF_RUNS = 1
+NUMBER_OF_THIS_RUN = 1
+
+# path to store the local database files on each node
+LOCAL_PATH = ../DATABASES_FOR_SOLVER
+
+# interval at which we output time step info and max of norm of displacement
+NTSTEP_BETWEEN_OUTPUT_INFO = 100
+
+# interval in time steps for temporary writing of seismograms
+NTSTEP_BETWEEN_OUTPUT_SEISMOS = 5000000
+NTSTEP_BETWEEN_READ_ADJSRC = 1000
+
+# output format for the seismograms (one can use either or all of the three formats)
+OUTPUT_SEISMOS_ASCII_TEXT = .true.
+OUTPUT_SEISMOS_SAC_ALPHANUM = .false.
+OUTPUT_SEISMOS_SAC_BINARY = .false.
+
+# rotate seismograms to Radial-Transverse-Z or use default North-East-Z reference frame
+ROTATE_SEISMOGRAMS_RT = .false.
+
+# decide if master process writes all the seismograms or if all processes do it in parallel
+WRITE_SEISMOGRAMS_BY_MASTER = .true.
+
+# 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
+SAVE_ALL_SEISMOS_IN_ONE_FILE = .false.
+USE_BINARY_FOR_LARGE_FILE = .false.
+
+# flag to impose receivers at the surface or allow them to be buried
+RECEIVERS_CAN_BE_BURIED = .false.
+
+# print source time function
+PRINT_SOURCE_TIME_FUNCTION = .false.
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_OK_192GPUs_90percent_of_4GB
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_OK_192GPUs_90percent_of_4GB (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/Par_file_OK_192GPUs_90percent_of_4GB 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,113 @@
+
+# forward or adjoint simulation
+SIMULATION_TYPE = 1
+SAVE_FORWARD = .false. # save last frame of forward simulation or not
+
+# number of chunks (1,2,3 or 6)
+NCHUNKS = 1
+
+# angular width of the first chunk (not used if full sphere with six chunks)
+ANGULAR_WIDTH_XI_IN_DEGREES = 90.d0 # angular size of a chunk
+ANGULAR_WIDTH_ETA_IN_DEGREES = 90.d0
+CENTER_LATITUDE_IN_DEGREES = 40.d0
+CENTER_LONGITUDE_IN_DEGREES = 10.d0
+GAMMA_ROTATION_AZIMUTH = 20.d0
+
+# number of elements at the surface along the two sides of the first chunk
+# (must be a multiple of 16 and also 8 * a multiple of NPROC below)
+NEX_XI = 1280 # 1216 # 1152 # 1088 # 1024 # 960 # 896 # 832 # 768 # 384
+NEX_ETA = 1536 # DK DK do not change this 768 # 384
+
+# number of MPI processors along the two sides of the first chunk
+NPROC_XI = 2 # 4 # 12
+NPROC_ETA = 96 # 48 # 16
+
+# 1D models with real structure:
+# 1D_isotropic_prem, 1D_transversely_isotropic_prem, 1D_iasp91, 1D_1066a, 1D_ak135, 1D_ref, 1D_ref_iso, 1D_jp3d,1D_sea99
+#
+# 1D models with only one fictitious averaged crustal layer:
+# 1D_isotropic_prem_onecrust, 1D_transversely_isotropic_prem_onecrust, 1D_iasp91_onecrust, 1D_1066a_onecrust, 1D_ak135_onecrust
+#
+# fully 3D models:
+# transversely_isotropic_prem_plus_3D_crust_2.0, 3D_anisotropic, 3D_attenuation,
+# s20rts, s362ani, s362iso, s362wmani, s362ani_prem, s29ea, s29ea,sea99_jp3d1994,sea99,jp3d1994
+MODEL = 1D_isotropic_prem
+
+# parameters describing the Earth model
+OCEANS = .false.
+ELLIPTICITY = .false.
+TOPOGRAPHY = .false.
+GRAVITY = .false.
+ROTATION = .false.
+ATTENUATION = .false.
+
+# absorbing boundary conditions for a regional simulation
+ABSORBING_CONDITIONS = .false.
+
+# record length in minutes
+RECORD_LENGTH_IN_MINUTES = 20.0d0
+
+# save AVS or OpenDX movies
+#MOVIE_COARSE saves movie only at corners of elements (SURFACE OR VOLUME)
+#MOVIE_COARSE does not work with create_movie_AVS_DX
+MOVIE_SURFACE = .false.
+MOVIE_VOLUME = .false.
+MOVIE_COARSE = .false.
+NTSTEP_BETWEEN_FRAMES = 100
+HDUR_MOVIE = 0.d0
+
+# save movie in volume. Will save element if center of element is in prescribed volume
+# top/bottom: depth in KM, use MOVIE_TOP = -100 to make sure the surface is stored.
+# west/east: longitude, degrees East [-180/180] top/bottom: latitute, degrees North [-90/90]
+# start/stop: frames will be stored at MOVIE_START + i*NSTEP_BETWEEN_FRAMES, where i=(0,1,2..) and iNSTEP_BETWEEN_FRAMES <= MOVIE_STOP
+# movie_volume_type: 1=strain, 2=time integral of strain, 3=\mu*time integral of strain
+# type 4 saves the trace and deviatoric stress in the whole volume, 5=displacement, 6=velocity
+MOVIE_VOLUME_TYPE = 2
+MOVIE_TOP_KM = -100.0
+MOVIE_BOTTOM_KM = 1000.0
+MOVIE_WEST_DEG = -90.0
+MOVIE_EAST_DEG = 90.0
+MOVIE_NORTH_DEG = 90.0
+MOVIE_SOUTH_DEG = -90.0
+MOVIE_START = 0
+MOVIE_STOP = 40000
+
+# save mesh files to check the mesh
+SAVE_MESH_FILES = .false.
+
+# restart files (number of runs can be 1, 2 or 3, choose 1 for no restart files)
+NUMBER_OF_RUNS = 1
+NUMBER_OF_THIS_RUN = 1
+
+# path to store the local database files on each node
+LOCAL_PATH = ../DATABASES_FOR_SOLVER
+
+# interval at which we output time step info and max of norm of displacement
+NTSTEP_BETWEEN_OUTPUT_INFO = 100
+
+# interval in time steps for temporary writing of seismograms
+NTSTEP_BETWEEN_OUTPUT_SEISMOS = 5000000
+NTSTEP_BETWEEN_READ_ADJSRC = 1000
+
+# output format for the seismograms (one can use either or all of the three formats)
+OUTPUT_SEISMOS_ASCII_TEXT = .true.
+OUTPUT_SEISMOS_SAC_ALPHANUM = .false.
+OUTPUT_SEISMOS_SAC_BINARY = .false.
+
+# rotate seismograms to Radial-Transverse-Z or use default North-East-Z reference frame
+ROTATE_SEISMOGRAMS_RT = .false.
+
+# decide if master process writes all the seismograms or if all processes do it in parallel
+WRITE_SEISMOGRAMS_BY_MASTER = .true.
+
+# 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
+SAVE_ALL_SEISMOS_IN_ONE_FILE = .false.
+USE_BINARY_FOR_LARGE_FILE = .false.
+
+# flag to impose receivers at the surface or allow them to be buried
+RECEIVERS_CAN_BE_BURIED = .false.
+
+# print source time function
+PRINT_SOURCE_TIME_FUNCTION = .false.
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/STATIONS
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/STATIONS (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/DATA/STATIONS 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,758 @@
+MCK AK 63.7323 -148.9349 618.0 0.0
+CTAO AS -20.0882 146.2545 357.0 0.0
+KONO AS 59.6491 9.5982 216.0 0.0
+MAJO AS 36.5409 138.2083 431.0 0.0
+ZOBO AS -16.2700 -68.1250 4450.0 0.0
+ASBS AZ 33.6208 -116.4664 1400.0 0.0
+BZN AZ 33.4915 -116.6670 1301.0 0.0
+CRY AZ 33.5654 -116.7373 1128.0 0.0
+ELKS AZ 33.5813 -116.4496 1169.0 0.0
+FRD AZ 33.4947 -116.6022 1164.0 0.0
+GLA AZ 33.0512 -114.8270 579.0 0.0
+GLAC AZ 33.6014 -116.4781 1169.0 0.0
+KNW AZ 33.7141 -116.7119 1507.0 0.0
+LVA2 AZ 33.3516 -116.5615 1435.0 0.0
+MONP AZ 32.8927 -116.4225 1920.0 0.0
+PFO AZ 33.6117 -116.4594 1259.0 0.0
+RDM AZ 33.6300 -116.8478 1365.0 0.0
+SHUM AZ 33.6327 -116.4445 1195.0 0.0
+SMTC AZ 32.9449 -115.7999 100.0 0.0
+SND AZ 33.5519 -116.6129 1358.0 0.0
+SOL AZ 32.8410 -117.2480 245.0 0.0
+TRO AZ 33.5234 -116.4257 2628.0 0.0
+WMC AZ 33.5736 -116.6747 1271.0 0.0
+YAQ AZ 33.1666 -116.3539 430.0 0.0
+BFO BF 48.3319 8.3311 739.0 0.0
+CMB BK 38.0350 -120.3850 719.0 0.0
+BJI CD 40.0403 116.1750 43.0 0.0
+ENH CD 30.2718 109.4868 487.0 0.0
+HIA CD 49.2667 119.7417 610.0 0.0
+KMI CD 25.1233 102.7400 1975.0 0.0
+LSA CD 29.7000 91.1500 3789.0 0.0
+LZH CD 36.0867 103.8444 1560.0 0.0
+MDJ CD 44.6164 129.5919 250.0 0.0
+QIZ CD 19.0294 109.8433 230.0 0.0
+SSE CD 31.0956 121.1867 15.0 0.0
+WMQ CD 43.8211 87.6950 903.0 0.0
+DRLN CN 49.2560 -57.5042 238.0 0.0
+FRB CN 63.7467 -68.5467 18.0 0.0
+GAC CN 45.7033 -75.4783 62.0 0.0
+INK CN 68.3067 -133.5200 40.0 0.0
+LLLB CN 50.6090 -121.8815 700.0 0.0
+MBC CN 76.2417 -119.3600 15.0 0.0
+PMB CN 50.5188 -123.0765 400.0 0.0
+RES CN 74.6870 -94.9000 15.0 0.0
+SCHQ CN 54.8319 -66.8336 501.0 0.0
+WHY CN 60.6597 -134.8806 1292.0 0.0
+YKW1 CN 62.4931 -114.5086 204.9 0.0
+YKW3 CN 62.5608 -114.6164 200.0 0.0
+FERN CT 37.1526 -121.8123 518.0 0.0
+ICAN CT 37.5049 -121.3278 312.0 0.0
+SAVY CT 37.3889 -121.4956 600.0 0.0
+BTO CU 42.5060 -71.5580 180.0 0.0
+GUYA CU 42.5060 -71.5580 180.0 0.0
+NJ2 CU 42.5060 -71.5580 180.0 0.0
+TIA CU 42.5060 -71.5580 180.0 0.0
+TIL CU 42.5060 -71.5580 180.0 0.0
+TIY CU 42.5060 -71.5580 180.0 0.0
+DPC CZ 50.3583 16.4111 760.0 0.0
+AFI DW -13.9093 -171.7773 706.0 0.0
+BDF DW -15.6639 -47.9033 1260.0 0.0
+CMB DW 38.0350 -120.3850 719.0 0.0
+COL DW 64.9000 -147.7933 320.0 0.0
+GDH DW 69.2500 -53.5333 23.0 0.0
+HON DW 21.3217 -158.0083 2.0 0.0
+KEV DW 69.7553 27.0067 80.0 0.0
+LON DW 46.7500 -121.8100 854.0 0.0
+SCP DW 40.7949 -77.8650 352.0 0.0
+SLR DW -25.7349 28.2816 1348.0 0.0
+TAU DW -42.9099 147.3204 132.0 0.0
+TOL DW 39.8814 -4.0485 480.0 0.0
+APE GE 37.1454 25.5230 615.0 0.0
+APEZ GE 34.9777 24.8859 435.0 0.0
+BGIO GE 31.7219 35.0877 752.0 0.0
+BOA GE 12.4493 -85.6659 380.0 0.0
+BRNL GE 52.4278 13.3580 42.0 0.0
+CART GE 37.5868 -1.0012 65.0 0.0
+CSS GE 34.9611 33.3310 396.0 0.0
+DAG GE 76.7713 -18.6550 23.0 0.0
+DSB GE 53.2452 -6.3762 236.0 0.0
+EIL GE 29.6699 34.9512 210.0 0.0
+FODE GE 35.3797 24.9576 50.0 0.0
+GHAR GE 32.1220 13.0864 675.0 0.0
+GVD GE 34.8392 24.0873 180.0 0.0
+IBBN GE 52.3072 7.7566 140.0 0.0
+ISP GE 37.8433 30.5093 1100.0 0.0
+JER GE 31.7719 35.1972 770.0 0.0
+KBS GE 78.9256 11.9417 77.0 0.0
+KMBO GE -1.1268 37.2523 1960.0 0.0
+KRIS GE 35.1780 25.5030 850.0 0.0
+KWP GE 49.6305 22.7078 463.0 0.0
+LID GE 54.5481 13.3664 1.0 0.0
+LVC GE -22.6182 -68.9113 2915.0 0.0
+MAHO GE 39.8959 4.2665 15.0 0.0
+MALT GE 38.3134 38.4273 1120.0 0.0
+MAUI GE 20.7668 -156.2448 2060.0 0.0
+MELI GE 35.2900 -2.9380 20.0 0.0
+MHV GE 54.9595 37.7664 150.0 0.0
+MLR GE 45.4912 25.9456 1378.0 0.0
+MORC GE 49.7766 17.5428 740.0 0.0
+MRNI GE 33.1178 35.3920 918.0 0.0
+MTE GE 40.3997 -7.5442 815.0 0.0
+NAI GE -1.2739 36.8037 1692.0 0.0
+PMG GE -9.4092 147.1539 67.0 0.0
+PSZ GE 47.9190 19.8940 549.0 0.0
+PUL GE 59.7670 30.3170 65.0 0.0
+RGN GE 54.5477 13.3214 15.0 0.0
+RIOB GE -10.1501 -67.7470 0.0 0.0
+RUE GE 52.4759 13.7800 40.0 0.0
+SANT GE 36.3710 25.4590 540.0 0.0
+SELV GE 37.2383 -3.7277 650.0 0.0
+SFJ GE 66.9967 -50.6156 365.0 0.0
+SFS GE 36.4656 -6.2055 21.0 0.0
+SFUC GE 36.6370 -6.1750 88.0 0.0
+SKD GE 35.4120 23.9280 306.0 0.0
+SNAA GE -71.6707 -2.8379 846.0 0.0
+STU GE 48.7719 9.1950 360.0 0.0
+SUW GE 54.0125 23.1808 152.0 0.0
+TRTE GE 58.3786 26.7205 0.0 0.0
+UGM GE -7.9125 110.5231 350.0 0.0
+WLF GE 49.6646 6.1526 295.0 0.0
+GRA1 GR 49.6919 11.2217 499.5 0.0
+AIS G -37.7970 77.5690 35.0 0.0
+ATD G 11.5300 42.8470 610.0 0.0
+BNG G 4.4350 18.5470 378.0 0.0
+CAN G -35.3210 148.9990 650.0 0.0
+CRZF G -46.4300 51.8610 140.0 0.0
+DRV G -66.6650 140.0100 40.0 0.0
+ECH G 48.2160 7.1580 580.0 0.0
+EVO G 38.5320 -8.0130 0.0 0.0
+FDF G 14.7350 -61.1430 467.0 0.0
+HDC G 10.0000 -84.1120 1150.0 0.0
+HYB G 17.4170 78.5530 510.0 0.0
+INU G 35.3500 137.0290 132.0 0.0
+KIP G 21.4230 -158.0150 70.0 0.0
+KOG G 5.2070 -52.7320 10.0 0.0
+NOUC G -22.1010 166.3030 112.0 0.0
+PAF G -49.3510 70.2130 17.0 0.0
+PEL G -33.1460 -70.6750 660.0 0.0
+PPT G -17.5690 -149.5760 340.0 0.0
+PVC G -17.7400 168.3120 80.0 0.0
+RER G -21.1590 55.7460 834.0 0.0
+SCZ G 36.5980 -121.4030 261.0 0.0
+SEY G 62.9330 152.3730 206.0 0.0
+SPB G -23.5920 -47.4320 85.0 0.0
+SSB G 45.2790 4.5420 700.0 0.0
+SSB2 G 45.2790 4.5420 700.0 0.0
+SSB3 G 45.2790 4.5420 700.0 0.0
+TAM G 22.7910 5.5270 1377.0 0.0
+UNM G 19.3290 -99.1780 2280.0 0.0
+WUS G 41.1990 79.2180 1457.0 0.0
+BDFB GT -15.6418 -48.0148 1195.0 0.0
+BGCA GT 5.1764 18.4242 676.0 0.0
+BOSA GT -28.6141 25.2555 1280.0 0.0
+CPUP GT -26.3306 -57.3309 105.0 0.0
+DBIC GT 6.6702 -4.8566 125.0 0.0
+LBTB GT -25.0151 25.5967 1128.0 0.0
+LPAZ GT -16.2879 -68.1307 4769.0 0.0
+PLCA GT -40.7328 -70.5508 1050.0 0.0
+SBA GT -77.8491 166.7573 20.0 0.0
+VNDA GT -77.5172 161.8528 151.0 0.0
+H2O H2 27.8819 -141.9917 -4947.0 0.
+BJT IC 40.0183 116.1679 197.0 0.0
+ENH IC 30.2718 109.4868 487.0 0.0
+HIA IC 49.2667 119.7417 610.0 0.0
+KMI IC 25.1233 102.7400 1975.0 0.0
+LSA IC 29.7000 91.1500 3789.0 0.0
+MDJ IC 44.6164 129.5919 250.0 0.0
+QIZ IC 19.0294 109.8433 230.0 0.0
+SSE IC 31.0951 121.1859 15.0 0.0
+WMQ IC 43.8211 87.6950 903.0 0.0
+XAN IC 34.0313 108.9237 630.0 0.0
+AAK II 42.6390 74.4940 1645.0 0.0
+ABKT II 37.9304 58.1189 678.0 0.0
+ALE II 82.5033 -62.3500 60.0 0.0
+ARU II 56.4302 58.5625 250.0 0.0
+ASCN II -7.9327 -14.3601 173.0 0.0
+BFO II 48.3319 8.3311 589.0 0.0
+BORG II 64.7474 -21.3268 110.0 0.0
+BRVK II 53.0581 70.2828 330.0 0.0
+CMLA II 37.7637 -25.5243 429.0 0.0
+COCO II -12.1901 96.8349 1.0 0.0
+EFI II -51.6753 -58.0637 110.0 0.0
+ERM II 42.0150 143.1572 40.0 0.0
+ESK II 55.3167 -3.2050 242.0 0.0
+FFC II 54.7250 -101.9783 338.0 0.0
+GAR II 39.0000 70.3167 1300.0 0.0
+HOPE II -54.2836 -36.4879 20.0 0.0
+JTS II 10.2908 -84.9525 340.0 0.0
+KAPI II -5.0142 119.7517 30.0 0.0
+KDAK II 57.7828 -152.5835 152.0 0.0
+KIV II 43.9562 42.6888 1210.0 0.0
+KURK II 50.7154 78.6202 184.0 0.0
+KWAJ II 8.8019 167.6130 0.0 0.0
+LVZ II 67.8979 34.6514 630.0 0.0
+MBAR II -0.6019 30.7382 1390.0 0.0
+MSEY II -4.6737 55.4792 475.0 0.0
+MSVF II -17.7333 178.0500 783.0 0.0
+NIL II 33.6506 73.2686 629.0 0.0
+NNA II -11.9875 -76.8422 575.0 0.0
+NRIL II 69.5049 88.4414 92.0 0.0
+NVS II 54.8404 83.2346 150.0 0.0
+OBN II 55.1138 36.5687 160.0 0.0
+PALK II 7.2728 80.7022 460.0 0.0
+PFO II 33.6092 -116.4553 1280.0 0.0
+RAYN II 23.5225 45.5032 631.0 0.0
+RPN II -27.1267 -109.3344 110.0 0.0
+SACV II 14.9702 -23.6085 387.0 0.0
+SHEL II -15.9588 -5.7457 537.0 0.0
+SUR II -32.3797 20.8117 1770.0 0.0
+TAU II -42.9099 147.3204 132.0 0.0
+TLY II 51.6807 103.6438 579.0 0.0
+WRAB II -19.9336 134.3600 366.0 0.0
+XPF II 33.6092 -116.4533 1280.0 0.0
+ATTU IM 52.8821 173.1643 250.0 0.0
+IL31 IM 64.7714 -146.8866 419.0 0.0
+PD31 IM 42.7672 -109.5581 2219.0 0.0
+TX00 IM 29.3338 -103.6670 1013.0 0.0
+TX31 IM 29.3342 -103.6678 1025.0 0.0
+TX32 IM 29.3338 -103.6670 1013.0 0.0
+VNDA IM -77.5139 161.8456 98.0 0.0
+WCI IU 38.2290 -86.2940 638.0 0.0
+WVT IU 36.1300 -87.8300 157.0 0.0
+XMAS IU 2.0448 -157.4453 2.0 0.0
+YAK IU 62.0308 129.6812 105.0 0.0
+YSS IU 46.9583 142.7610 100.0 0.0
+BTDF MS 1.3608 103.7729 64.0 0.0
+TIXI IU 71.6490 128.8665 50.0 0.0
+SBA IU -77.8491 166.7573 20.0 0.0
+SDV IU 8.8790 -70.6330 1550.0 0.0
+SFJ IU 66.9967 -50.6156 365.0 0.0
+SJG IU 18.1117 -66.1500 457.0 0.0
+SNZO IU -41.3103 174.7046 62.0 0.0
+SPA IU -89.9954 115.0000 2927.0 0.0
+SSPA IU 40.6401 -77.8914 352.0 0.0
+TATO IU 24.9754 121.4881 53.0 0.0
+TBT IU 28.6794 -17.9145 180.0 0.0
+TEIG IU 20.2264 -88.2766 69.0 0.0
+TOL IU 39.8814 -4.0485 480.0 0.0
+TRQA IU -38.0567 -61.9795 602.0 0.0
+TSUM IU -19.2022 17.5838 1240.0 0.0
+TUC IU 32.3096 -110.7846 874.0 0.0
+ULN IU 47.8652 107.0528 1615.0 0.0
+WAKE IU 19.2833 166.6536 1.0 0.0
+MSKU IU -1.6557 13.6116 312.0 0.0
+HNR IU -9.4322 159.9471 72.0 0.0
+ANTO SR 39.8689 32.7936 883.0 0.0
+BCAO SR 4.4335 18.5354 336.0 0.0
+CHTO SR 18.7900 98.9769 316.0 0.0
+GUMO SR 13.5878 144.8662 14.0 0.0
+NWAO SR -32.9266 117.2333 265.0 0.0
+SNZO SR -41.3103 174.7046 62.0 0.0
+TATO SR 24.9754 121.4881 53.0 0.0
+BAR TS 32.6800 -116.6720 548.0 0.0
+CALB TS 34.1430 -118.6270 0.0 0.0
+CWC TS 36.4399 -118.0802 1553.0 0.0
+DGR TS 33.6500 -117.0090 700.0 0.0
+GLA TS 33.0520 -114.8270 627.0 0.0
+GPO TS 35.6494 -117.6619 735.0 0.0
+GSC TS 35.3028 -116.8083 990.0 0.0
+ISA TS 35.6630 -118.4733 835.0 0.0
+MLAC TS 37.6310 -118.8340 2170.0 0.0
+NEE TS 34.8230 -114.5960 139.0 0.0
+OSI TS 34.6145 -118.7235 706.0 0.0
+PAS TS 34.1483 -118.1717 295.0 0.0
+PFO TS 33.6092 -116.4553 1280.0 0.0
+RPV TS 33.7438 -118.4035 115.0 0.0
+SBC TS 34.4417 -119.7133 90.0 0.0
+SMTC TS 32.9490 -115.7200 -50.0 0.0
+SNCC TS 33.2480 -119.5240 227.0 0.0
+SVD TS 34.1045 -117.0970 600.0 0.0
+USC TS 34.0210 -118.2870 60.0 0.0
+VTV TS 34.5670 -117.3330 847.0 0.0
+GRFO SR 49.6919 11.2217 425.0 0.0
+AAE IU 9.0292 38.7656 2442.0 0.0
+ADK IU 51.8837 -176.6844 116.0 0.0
+AFI IU -13.9093 -171.7773 706.0 0.0
+ANMO IU 34.9462 -106.4567 1840.0 0.0
+ANTO IU 39.8689 32.7936 883.0 0.0
+BILL IU 68.0651 166.4524 299.0 0.0
+BOCO IU 4.5869 -74.0432 3160.0 0.0
+CASY IU -66.2792 110.5364 159.0 0.0
+CCM IU 38.0557 -91.2446 222.0 0.0
+CHTO IU 18.7900 98.9769 316.0 0.0
+COL IU 64.9000 -147.7933 320.0 0.0
+COLA IU 64.8738 -147.8511 194.0 0.0
+COR IU 44.5857 -123.3032 121.0 0.0
+CTAO IU -20.0882 146.2545 357.0 0.0
+DAV IU 7.0878 125.5747 85.0 0.0
+DWPF IU 28.1102 -81.4327 20.0 0.0
+FURI IU 8.9030 38.6883 2545.0 0.0
+GNI IU 40.1480 44.7410 1609.0 0.0
+GRFO IU 49.6919 11.2217 425.0 0.0
+GUMO IU 13.5878 144.8662 14.0 0.0
+HKT IU 29.9618 -95.8384 -413.0 0.0
+HRV IU 42.5060 -71.5580 180.0 0.0
+INCN IU 37.4833 126.6333 420.0 0.0
+JOHN IU 16.7329 -169.5292 2.0 0.0
+KBS IU 78.9256 11.9417 77.0 0.0
+KEV IU 69.7553 27.0067 80.0 0.0
+KIEV IU 50.6944 29.2083 163.0 0.0
+KIP IU 21.4233 -158.0150 70.0 0.0
+KMBO IU -1.1268 37.2523 1960.0 0.0
+KONO IU 59.6491 9.5982 216.0 0.0
+KOWA IU 14.4967 -4.0140 321.0 0.0
+LCO IU -29.0111 -70.7010 2299.0 0.0
+LSZ IU -15.2766 28.1882 1184.0 0.0
+LVC IU -22.6128 -68.9113 2195.0 0.0
+MA2 IU 59.5756 150.7700 339.0 0.0
+MAJO IU 36.5425 138.2073 405.0 0.0
+MAKZ IU 46.8080 81.9770 600.0 0.0
+MBWA IU -21.1590 119.7312 194.0 0.0
+MIDW IU 28.2157 -177.3697 18.0 0.0
+NAI IU -1.2739 36.8037 1692.0 0.0
+NWAO IU -32.9266 117.2333 265.0 0.0
+OTAV IU 0.2376 -78.4508 3507.0 0.0
+PAB IU 39.5458 -4.3483 925.0 0.0
+PAYG IU -0.6741 -90.2863 295.0 0.0
+PET IU 53.0235 158.6498 150.0 0.0
+PMG IU -9.4092 147.1539 67.0 0.0
+PMSA IU -64.7742 -64.0490 10.0 0.0
+POHA IU 19.7575 -155.5325 1967.0 0.0
+PTCN IU -25.0728 -130.0947 195.0 0.0
+PTGA IU -0.7308 -59.9666 237.0 0.0
+QSPA IU 34.9502 -106.4602 1839.0 0.0
+RAIO IU 46.0403 -122.8851 1.0 0.0
+RAR IU -21.2125 -159.7733 28.0 0.0
+RCBR IU -5.8275 -35.9014 409.0 0.0
+RSSD IU 44.1204 -104.0362 2060.0 0.0
+AAK KN 42.6333 74.4944 1680.0 0.0
+AML KN 42.1311 73.6941 3400.0 0.0
+BGK2 KN 42.6451 74.2274 1640.0 0.0
+CHM KN 42.9986 74.7513 655.0 0.0
+EKS2 KN 42.6615 73.7772 1360.0 0.0
+ERPT KN 42.6011 76.0735 3790.0 0.0
+KBK KN 42.6564 74.9478 1760.0 0.0
+KZA KN 42.0778 75.2496 3520.0 0.0
+NRPT KN 42.6011 76.0735 3790.0 0.0
+TKM KN 42.8601 75.3184 960.0 0.0
+TKM2 KN 42.9208 75.5966 2020.0 0.0
+UCH KN 42.2275 74.5134 3850.0 0.0
+ULHL KN 42.2456 76.2417 2040.0 0.0
+USP KN 43.2669 74.4997 740.0 0.0
+AKT KZ 50.4348 58.0167 360.0 0.0
+AKTK KZ 50.4348 58.0167 360.0 0.0
+BRVK KZ 53.0580 70.2828 315.0 0.0
+CHK KZ 53.6762 70.6152 240.0 0.0
+CHKZ KZ 53.6762 70.6152 120.0 0.0
+KUR KZ 50.7149 78.6208 240.0 0.0
+KURK KZ 50.7149 78.6208 240.0 0.0
+MAK KZ 46.8075 81.9774 600.0 0.0
+MAKZ KZ 46.8080 81.9770 600.0 0.0
+PDG KZ 43.3275 79.4850 1277.0 0.0
+TLG KZ 43.2330 77.2250 1120.0 0.0
+VOS KZ 52.7232 70.9797 450.0 0.0
+ZRN KZ 52.9510 69.0043 420.0 0.0
+ZRNK KZ 52.9510 69.0043 380.0 0.0
+BMN LB 40.4314 -117.2210 1500.0 0.0
+DAC LB 36.2770 -117.5937 1813.0 0.0
+LDS LB 37.2425 -113.3514 1101.0 0.0
+MVU LB 38.5037 -112.2123 2239.0 0.0
+TPH LB 38.0750 -117.2225 1883.0 0.0
+NCB LD 43.9734 -74.2229 469.0 0.0
+PAL LD 41.0057 -73.9071 91.0 0.0
+CDRO LX 38.6292 -28.6992 195.0 0.0
+AQU MN 42.3540 13.4050 710.0 0.0
+BGY MN 44.8026 20.5158 250.0 0.0
+BNI MN 45.0520 6.6780 1395.0 0.0
+CII MN 41.7230 14.3050 910.0 0.0
+CLTB MN 37.5780 13.2160 949.0 0.0
+GFA MN 34.3380 9.0730 250.0 0.0
+IDI MN 35.2880 24.8900 750.0 0.0
+ISP MN 37.8430 30.5090 1100.0 0.0
+KEG MN 29.9275 31.8292 460.0 0.0
+MDT MN 32.8170 -4.6140 1200.0 0.0
+MEB MN 36.3030 2.7300 500.0 0.0
+TIR MN 41.3477 19.8650 198.0 0.0
+TNV MN -74.7000 164.1200 40.0 0.0
+TRI MN 45.7090 13.7640 161.0 0.0
+TTE MN 45.6600 13.7900 92.0 0.0
+VLC MN 44.1594 10.3864 555.0 0.0
+VSL MN 39.4960 9.3780 370.0 0.0
+VTS MN 42.6180 23.2350 1490.0 0.0
+WDD MN 35.8670 14.5230 41.0 0.0
+HGN NL 50.7640 5.9317 135.0 0.0
+BLO NM 39.1719 -86.5222 246.0 0.0
+MPH NM 35.1230 -89.9320 93.0 0.0
+PLAL NM 34.9824 -88.0755 165.0 0.0
+SIUC NM 37.7148 -89.2174 120.0 0.0
+SLM NM 38.6361 -90.2364 186.0 0.0
+UALR NM 34.7753 -92.3436 138.0 0.0
+UTMT NM 36.3423 -88.6642 120.0 0.0
+BAG PS 16.4108 120.5797 1507.0 0.0
+MCSJ PS 24.2900 153.9780 10.0 0.0
+OGS PS 27.0570 142.2030 20.0 0.0
+PATS PS 6.8367 158.3152 10.0 0.0
+PSI PS 2.6938 98.9237 987.0 0.0
+SYO PS -69.0067 39.5850 20.0 0.0
+TGY PS 14.1000 120.9400 0.0 0.0
+TSK PS 36.2108 140.1097 350.0 0.0
+ANPB TW 25.1865 121.5202 825.0 0.0
+HWAB TW 23.9800 121.6000 0.0 0.0
+KMNB TW 24.4638 118.3884 43.0 0.0
+LYUB TW 22.0017 121.5840 40.0 0.0
+MATB TW 26.1515 119.9456 75.1 0.0
+NACB TW 24.1738 121.5947 130.0 0.0
+SSLB TW 23.7875 120.9540 450.0 0.0
+TATO TW 24.9754 121.4881 53.0 0.0
+TDCB TW 24.2574 121.2550 1280.0 0.0
+TPUB TW 23.3005 120.6296 370.0 0.0
+TWGB TW 22.8176 121.0799 195.0 0.0
+TWKB TW 21.9406 120.8125 90.0 0.0
+WFSB TW 25.0710 121.7810 100.0 0.0
+YULB TW 23.3924 121.2971 294.7 0.0
+DBO UO 43.1192 -123.2428 980.0 0.0
+EUO UO 44.0294 -123.0689 160.0 0.0
+PIN UO 43.8111 -120.8719 1860.0 0.0
+AAM US 42.3012 -83.6567 172.0 0.0
+ACSO US 40.2319 -82.9820 288.0 0.0
+AHID US 42.7654 -111.1004 1960.0 0.0
+BINY US 42.1993 -75.9861 498.0 0.0
+BLA US 37.2113 -80.4210 634.0 0.0
+BMN US 40.4315 -117.2218 1500.0 0.0
+BOZ US 45.6470 -111.6296 1589.0 0.0
+BW06 US 42.7667 -109.5583 2224.0 0.0
+CBKS US 38.8140 -99.7374 677.0 0.0
+CBM US 46.9325 -68.1208 250.0 0.0
+CEH US 35.8908 -79.0928 152.0 0.0
+DUG US 40.1950 -112.8133 1477.0 0.0
+ELK US 40.7448 -115.2388 2210.0 0.0
+EYMN US 47.9462 -91.4950 475.0 0.0
+GOGA US 33.4112 -83.4666 150.0 0.0
+GOL US 39.7003 -105.3711 2359.0 0.0
+GWDE US 38.8256 -75.6171 19.0 0.0
+HAWA US 46.3925 -119.5326 364.0 0.0
+HLID US 43.5625 -114.4138 1772.0 0.0
+HWUT US 41.6069 -111.5652 1830.0 0.0
+ISCO US 39.7997 -105.6134 2743.0 0.0
+JCT US 30.4794 -99.8022 591.0 0.0
+JFWS US 42.9143 -90.2481 335.0 0.0
+KNB US 37.0166 -112.8224 1715.0 0.0
+LBNH US 44.2401 -71.9259 367.0 0.0
+LKWY US 44.5652 -110.4000 2424.0 0.0
+LSCT US 41.6784 -73.2244 318.0 0.0
+LTX US 29.3339 -103.6669 1013.0 0.0
+MCWV US 39.6581 -79.8456 280.0 0.0
+MIAR US 34.5454 -93.5765 207.0 0.0
+MNV US 38.4328 -118.1531 1524.0 0.0
+MYNC US 35.0739 -84.1279 550.0 0.0
+NCB US 43.9708 -74.2236 500.0 0.0
+NEW US 48.2633 -117.1200 760.0 0.0
+NHSC US 33.1067 -80.1778 11.0 0.0
+OCWA US 47.7489 -124.1781 671.0 0.0
+OXF US 34.5118 -89.4092 101.0 0.0
+RSNY US 44.5483 -74.5300 396.0 0.0
+RSSD US 44.1204 -104.0362 2060.0 0.0
+TPNV US 36.9488 -116.2495 1600.0 0.0
+WMOK US 34.7379 -98.7810 486.0 0.0
+WUAZ US 35.5169 -111.3739 1592.0 0.0
+WVOR US 42.4340 -118.6367 1344.0 0.0
+YSNY US 42.4758 -78.5375 628.0 0.0
+CHE UW 45.3544 -122.9886 430.0 0.0
+DBO UW 43.1192 -123.2428 980.0 0.0
+GNW UW 47.5644 -122.8253 160.0 0.0
+HEBO UW 45.2137 -123.7542 100.0 0.0
+LON UW 46.7500 -121.8100 850.0 0.0
+LTY UW 47.2559 -120.6648 970.0 0.0
+MEGW UW 46.2659 -123.8773 100.0 0.0
+OFR UW 47.9333 -124.3947 150.0 0.0
+OPC UW 48.1003 -123.4116 90.0 0.0
+PIN UW 43.8111 -120.8719 1860.0 0.0
+RWW UW 46.9639 -123.5433 10.0 0.0
+SQM UW 48.0775 -123.0456 30.0 0.0
+SSW UW 46.9723 -123.4338 120.0 0.0
+TAKO UW 43.7433 -124.0822 100.0 0.0
+TOLO UW 44.6219 -123.9225 100.0 0.0
+TTW UW 47.6946 -121.6889 540.0 0.0
+AZ01 XA 37.0430 -113.1280 1514.8 0.0
+AZ02 XA 37.0370 -113.3130 1066.8 0.0
+AZ03 XA 37.0270 -113.5760 868.6 0.0
+AZ04 XA 37.0270 -113.8680 1060.7 0.0
+AZ05 XA 37.1800 -114.1320 1133.8 0.0
+AZ06 XA 37.0730 -114.3420 957.0 0.0
+AZ07 XA 37.1310 -114.7130 987.5 0.0
+AZ08 XA 37.0800 -114.8420 1072.8 0.0
+AZ09 XA 37.2390 -115.1980 1094.2 0.0
+AZ10 XA 37.3300 -115.3100 1889.7 0.0
+MM01 XA 42.3175 -72.7117 122.0 0.0
+MM02 XA 42.1660 -73.7187 134.0 0.0
+MM03 XA 42.0388 -74.8462 670.5 0.0
+MM04 XA 41.8530 -76.1980 473.0 0.0
+MM05 XA 41.6530 -76.9220 701.0 0.0
+MM06 XA 41.3915 -78.1262 647.0 0.0
+MM07 XA 41.2571 -79.1350 518.0 0.0
+MM08 XA 41.1095 -80.0682 381.0 0.0
+MM09 XA 40.7911 -81.2056 357.0 0.0
+MM10 XA 40.6147 -82.3031 346.0 0.0
+MM11 XA 40.2214 -83.1947 283.0 0.0
+MM12 XA 40.0439 -84.3725 305.0 0.0
+MM13 XA 39.8317 -85.3114 337.0 0.0
+MM14 XA 39.5494 -86.3948 290.0 0.0
+MM15 XA 39.2945 -87.3135 190.6 0.0
+MM16 XA 38.9219 -88.3046 165.0 0.0
+MM17 XA 38.6694 -89.3255 143.8 0.0
+MM18 XA 38.5287 -90.5686 185.6 0.0
+MO18 XA 38.5144 -90.5644 161.0 0.0
+SA01 XA -34.2945 19.2460 220.0 0.0
+SA02 XA -33.7351 20.2663 500.0 0.0
+SA03 XA -33.6619 21.3354 500.0 0.0
+SA04 XA -32.8505 19.6206 1200.0 0.0
+SA05 XA -32.6050 21.5346 800.0 0.0
+SA07 XA -31.9776 20.2262 1277.0 0.0
+SA08 XA -31.9103 22.0729 1387.0 0.0
+SA09 XA -30.9221 22.9861 1200.0 0.0
+SA10 XA -30.9724 23.9136 1400.0 0.0
+SA11 XA -29.9650 20.9466 1066.0 0.0
+SA12 XA -29.8486 22.2533 1125.0 0.0
+SA13 XA -29.9788 23.1396 1047.0 0.0
+SA139 XA -25.8519 26.2662 1600.0 0.0
+SA14 XA -29.8682 24.0226 1200.0 0.0
+SA15 XA -29.9038 25.0323 1400.0 0.0
+SA155 XA -22.8786 28.3402 900.0 0.0
+SA16 XA -28.9503 22.1951 1026.0 0.0
+SA169 XA -22.2623 29.2134 618.0 0.0
+SA17 XA -28.9321 23.2257 1249.0 0.0
+SA18 XA -28.6328 24.3056 1102.0 0.0
+SA19 XA -28.9056 24.8328 1200.0 0.0
+SA20 XA -29.0221 26.1953 1400.0 0.0
+SA22 XA -27.9662 22.0091 1076.0 0.0
+SA23 XA -27.9304 23.4046 1612.0 0.0
+SA24 XA -27.8833 24.2365 1244.0 0.0
+SA25 XA -27.8459 25.1259 1253.0 0.0
+SA26 XA -27.5456 26.1803 1300.0 0.0
+SA27 XA -27.8625 27.2943 1400.0 0.0
+SA28 XA -27.8982 28.0656 1600.0 0.0
+SA29 XA -26.9317 23.0349 1120.0 0.0
+SA30 XA -27.0715 24.1651 1361.0 0.0
+SA31 XA -26.9952 25.0209 1348.0 0.0
+SA32 XA -26.8655 26.2845 1380.0 0.0
+SA33 XA -26.8986 27.1793 1400.0 0.0
+SA34 XA -26.8000 28.1000 1500.0 0.0
+SA35 XA -27.0183 29.0883 1600.0 0.0
+SA36 XA -26.8771 30.1249 1600.0 0.0
+SA37 XA -25.9705 23.7212 1142.0 0.0
+SA38 XA -25.9334 25.0846 1219.0 0.0
+SA39 XA -25.8952 26.1514 1545.0 0.0
+SA40 XA -25.8981 27.1490 1512.0 0.0
+SA42 XA -25.6650 29.2223 1500.0 0.0
+SA43 XA -25.7868 30.0669 1800.0 0.0
+SA44 XA -26.0321 30.9022 1000.0 0.0
+SA45 XA -24.8792 26.1644 1015.0 0.0
+SA46 XA -24.8382 27.1092 1037.0 0.0
+SA47 XA -24.8469 28.1618 1153.0 0.0
+SA48 XA -24.8948 29.2163 1000.0 0.0
+SA49 XA -24.9597 30.3091 0.0 0.0
+SA50 XA -23.8722 27.1662 976.0 0.0
+SA51 XA -23.8628 28.1567 1233.0 0.0
+SA52 XA -23.7983 28.8975 1321.0 0.0
+SA53 XA -24.1134 29.3328 1300.0 0.0
+SA54 XA -23.7288 30.6680 500.0 0.0
+SA55 XA -22.9800 28.2981 918.0 0.0
+SA56 XA -23.0059 29.0743 909.0 0.0
+SA57 XA -22.9811 30.0202 787.0 0.0
+SA58 XA -23.5179 31.3973 356.0 0.0
+SA59 XA -24.8373 24.4640 1137.0 0.0
+SA60 XA -23.8519 24.9594 1043.0 0.0
+SA61 XA -23.9481 24.0220 1069.0 0.0
+SA62 XA -24.8505 25.1350 1214.0 0.0
+SA63 XA -23.6583 26.0820 1008.0 0.0
+SA64 XA -22.9694 26.2017 1151.0 0.0
+SA65 XA -22.8183 27.2218 907.0 0.0
+SA66 XA -21.9005 26.3727 1057.0 0.0
+SA67 XA -21.8859 27.2736 913.0 0.0
+SA68 XA -21.9504 28.1878 737.0 0.0
+SA69 XA -22.3048 29.2661 651.0 0.0
+SA70 XA -21.0883 26.3352 990.0 0.0
+SA71 XA -20.9258 27.1408 1072.0 0.0
+SA72 XA -20.1430 28.6113 1337.0 0.0
+SA73 XA -21.8537 30.2776 590.0 0.0
+SA74 XA -21.9230 30.9357 487.0 0.0
+SA75 XA -20.8601 28.9991 971.0 0.0
+SA76 XA -20.6361 29.8464 978.0 0.0
+SA77 XA -20.7557 30.9191 576.0 0.0
+SA78 XA -19.4671 30.7723 1401.0 0.0
+SA79 XA -20.0211 30.5173 1078.0 0.0
+SA80 XA -19.9593 31.3179 1064.0 0.0
+SA81 XA -30.9251 21.2681 1270.0 0.0
+SA82 XA -30.9771 22.2466 1452.0 0.0
+ADO CI 34.5505 -117.4339 0.0 0.0
+AGA CI 33.6384 -116.4011 0.0 0.0
+ALP CI 34.6871 -118.2995 0.0 0.0
+BAK CI 35.3441 -119.1043 0.0 0.0
+BAR CI 32.6800 -116.7220 0.0 0.0
+BBR CI 34.2623 -116.9208 0.0 0.0
+BBS CI 33.9214 -116.9809 0.0 0.0
+BC3 CI 33.6548 -115.4531 0.0 0.0
+BCC CI 33.5751 -117.2612 0.0 0.0
+BEL CI 34.0006 -115.9982 0.0 0.0
+BFS CI 34.2370 -117.6582 0.0 0.0
+BKR CI 35.2693 -116.0703 0.0 0.0
+BOR CI 33.2682 -116.4172 0.0 0.0
+BRE CI 33.8100 -117.9817 0.0 0.0
+BTC CI 33.0126 -115.2199 0.0 0.0
+BTP CI 34.6833 -118.5750 0.0 0.0
+CALA CI 34.1430 -118.6270 0.0 0.0
+CALB CI 34.1430 -118.6270 0.0 0.0
+CAP CI 33.3885 -117.1905 0.0 0.0
+CCC CI 35.5247 -117.3646 0.0 0.0
+CHF CI 34.3334 -118.0260 0.0 0.0
+CHN CI 33.9988 -117.6804 0.0 0.0
+CIA CI 33.4020 -118.4152 0.0 0.0
+CIU CI 33.4458 -118.4830 0.0 0.0
+CLC CI 35.8158 -117.5975 0.0 0.0
+CLT CI 34.0932 -117.3167 0.0 0.0
+COO CI 33.8960 -118.2164 0.0 0.0
+CPP CI 34.0602 -117.8090 0.0 0.0
+CTC CI 33.6546 -115.9899 0.0 0.0
+CWC CI 36.4400 -118.0800 0.0 0.0
+DAN CI 34.6371 -115.3805 0.0 0.0
+DEV CI 33.9350 -116.5770 0.0 0.0
+DGR CI 33.6500 -117.0090 0.0 0.0
+DJJ CI 34.1058 -118.4538 0.0 0.0
+DJJB CI 34.1058 -118.4538 0.0 0.0
+DLA CI 33.8482 -118.0962 0.0 0.0
+DPP CI 32.9986 -116.9415 0.0 0.0
+DRC CI 32.8054 -115.4465 0.0 0.0
+DVT CI 32.6591 -116.1006 0.0 0.0
+EDW CI 34.8830 -117.9911 0.0 0.0
+EML CI 32.8913 -116.8460 0.0 0.0
+ERR CI 33.1168 -115.8227 0.0 0.0
+FIG CI 34.7321 -119.9841 0.0 0.0
+FMP CI 33.7126 -118.2938 0.0 0.0
+FPC CI 35.0820 -117.5827 0.0 0.0
+FUR CI 36.4667 -116.8635 0.0 0.0
+GLA CI 33.0510 -114.8280 0.0 0.0
+GOR CI 33.1600 -117.2300 0.0 0.0
+GPO CI 35.6490 -117.6620 0.0 0.0
+GR2 CI 34.1183 -118.2994 0.0 0.0
+GRA CI 36.9833 -117.3592 0.0 0.0
+GSC CI 35.3020 -116.8050 0.0 0.0
+HEC CI 34.8294 -116.3350 0.0 0.0
+HLL CI 34.1764 -118.3598 0.0 0.0
+ISA CI 35.6630 -118.4730 0.0 0.0
+JCS CI 33.0859 -116.5959 0.0 0.0
+JRC CI 35.9825 -117.8081 0.0 0.0
+JVA CI 34.3662 -116.6127 0.0 0.0
+LAF CI 33.8693 -118.3311 0.0 0.0
+LCG CI 34.0003 -118.3779 0.0 0.0
+LDF CI 35.0781 -115.1096 0.0 0.0
+LFP CI 34.3050 -118.4879 0.0 0.0
+LGB CI 33.9756 -118.1491 0.0 0.0
+LGU CI 34.1082 -119.0659 0.0 0.0
+LKL CI 34.6160 -117.8245 0.0 0.0
+LLS CI 33.6847 -117.9429 0.0 0.0
+LRL CI 35.4794 -117.6821 0.0 0.0
+LTP CI 33.8811 -118.1757 0.0 0.0
+LUG CI 34.3661 -117.3658 0.0 0.0
+MAG CI 35.3616 -118.9228 0.0 0.0
+MCT CI 34.2264 -116.0408 0.0 0.0
+MGE CI 33.8184 -116.3687 0.0 0.0
+MIK CI 34.1370 -118.1260 0.0 0.0
+MLA CI 37.6310 -118.8340 0.0 0.0
+MLAC CI 37.6310 -118.8340 0.0 0.0
+MLS CI 34.0046 -117.5609 0.0 0.0
+MOP CI 34.2808 -118.9049 0.0 0.0
+MPM CI 36.0580 -117.4890 0.0 0.0
+MSJ CI 33.8084 -116.9680 0.0 0.0
+MTL CI 34.2688 -118.2374 0.0 0.0
+MTP CI 35.4848 -115.5533 0.0 0.0
+MWC CI 34.2233 -118.0583 0.0 0.0
+NEE CI 34.8230 -114.5960 0.0 0.0
+NSS CI 33.5561 -115.9465 0.0 0.0
+OLI CI 33.9455 -117.9237 0.0 0.0
+OLP CI 32.6077 -116.9304 0.0 0.0
+OSI CI 34.6150 -118.7240 0.0 0.0
+PAS CI 34.1484 -118.1711 295.0 0.0
+PDE CI 34.4421 -118.5823 0.0 0.0
+PDR CI 33.9627 -118.4370 0.0 0.0
+PDU CI 34.1208 -117.6379 0.0 0.0
+PFO CI 33.6120 -116.4590 0.0 0.0
+PHL CI 35.4082 -120.5455 0.0 0.0
+PLC CI 33.8243 -116.5121 0.0 0.0
+PLM CI 33.3537 -116.8627 0.0 0.0
+PLS CI 33.7953 -117.6091 0.0 0.0
+QUG CI 34.3959 -118.4985 0.0 0.0
+RCT CI 36.3052 -119.2438 0.0 0.0
+RIN CI 34.2820 -118.4792 0.0 0.0
+RIO CI 34.1047 -117.9796 0.0 0.0
+RPV CI 33.7440 -118.4030 0.0 0.0
+RRX CI 34.9000 -117.0300 0.0 0.0
+RSS CI 33.9733 -117.3267 0.0 0.0
+RUS CI 34.0505 -118.0799 0.0 0.0
+RVR CI 33.9935 -117.3755 0.0 0.0
+SAL CI 33.2799 -115.9862 0.0 0.0
+SBC CI 34.4420 -119.7130 0.0 0.0
+SBPX CI 34.2322 -117.2348 0.0 0.0
+SCI CI 32.9800 -118.5467 0.0 0.0
+SDD CI 33.5531 -117.6618 0.0 0.0
+SDR CI 32.6080 -116.9290 0.0 0.0
+SES CI 34.4367 -119.1382 0.0 0.0
+SHO CI 35.9000 -116.2760 0.0 0.0
+SLA CI 35.8908 -117.2834 0.0 0.0
+SMM CI 35.3142 -119.9958 0.0 0.0
+SMS CI 34.0147 -118.4562 0.0 0.0
+SMTC CI 32.9490 -115.7200 0.0 0.0
+SNCC CI 33.2480 -119.5240 0.0 0.0
+SOT CI 34.4165 -118.4493 0.0 0.0
+SPF CI 34.0593 -118.6461 0.0 0.0
+SPG CI 36.1356 -118.8112 0.0 0.0
+SRN CI 33.8284 -117.7894 0.0 0.0
+SSM CI 35.3142 -119.9958 0.0 0.0
+SSN CI 33.2480 -119.5240 0.0 0.0
+SSW CI 33.1766 -115.6024 0.0 0.0
+STC CI 34.3027 -119.1870 0.0 0.0
+STG CI 33.6640 -117.7686 0.0 0.0
+STS CI 33.7902 -118.1985 0.0 0.0
+SVD CI 34.1040 -117.0970 0.0 0.0
+SWS CI 32.9448 -115.8000 0.0 0.0
+SYP CI 34.5278 -119.9783 0.0 0.0
+TA2 CI 34.3820 -117.6781 0.0 0.0
+TEH CI 35.2913 -118.4208 0.0 0.0
+THX CI 33.6348 -116.1640 0.0 0.0
+TIN CI 37.0542 -118.2301 0.0 0.0
+TOV CI 34.1560 -118.8190 0.0 0.0
+USC CI 34.0190 -118.2850 0.0 0.0
+VCS CI 34.4900 -118.1180 0.0 0.0
+VES CI 35.8409 -119.0847 0.0 0.0
+VTV CI 34.5670 -117.3330 0.0 0.0
+WES CI 32.7590 -115.7315 0.0 0.0
+WGR CI 34.5108 -119.2741 0.0 0.0
+WLT CI 34.0097 -117.9508 0.0 0.0
+WNS CI 34.1150 -118.3800 0.0 0.0
+WSS CI 34.1717 -118.6497 0.0 0.0
+WTT CI 33.9490 -118.2553 0.0 0.0
+BCAO GB 4.4336 18.5355 0.0 0.0
+BDF GB -15.6639 -47.9033 0.0 0.0
+BGY GB 44.8026 20.5158 0.0 0.0
+BJI GB 40.0403 116.1750 0.0 0.0
+BNI GB 45.0520 6.6780 0.0 0.0
+BOCO GB 4.6167 -74.1167 0.0 0.0
+BTDF GB 1.3608 103.7729 0.0 0.0
+COL GB 64.8999 -147.7932 0.0 0.0
+DPC GB 50.3583 16.4111 0.0 0.0
+DSB GB 53.2452 -6.3762 0.0 0.0
+GDH GB 69.2500 -53.5333 0.0 0.0
+GFA GB 34.5000 8.5000 0.0 0.0
+HON GB 21.3217 -158.0083 0.0 0.0
+LON GB 46.7500 -121.8100 0.0 0.0
+MSKU GB -1.6557 13.6116 0.0 0.0
+NAI GB -1.2739 36.8037 0.0 0.0
+NOU GB -22.1010 166.3030 0.0 0.0
+PFOT GB 33.6090 -116.4553 0.0 0.0
+SCP GB 40.7950 -77.8650 0.0 0.0
+SLR GB -25.7349 28.2816 0.0 0.0
+TOL GB 39.8814 -4.0485 0.0 0.0
+ZOBO GB -16.2700 -68.1250 0.0 0.0
+DGAR II -7.4121 72.4525 1.0 2.0
+FUNA IU 8.5300 179.2000 -1.0 1.0
+TRIS IU -37.0578 -12.3159 -2.0 2.0
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/LICENSE
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/LICENSE (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/LICENSE 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,339 @@
+ GNU GENERAL PUBLIC LICENSE
+ Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.,
+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The licenses for most software are designed to take away your
+freedom to share and change it. By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it. (Some other Free Software Foundation software is covered by
+the GNU Lesser General Public License instead.) You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must show them these terms so they know their
+rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ Finally, any free program is threatened constantly by software
+patents. We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary. To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License. The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language. (Hereinafter, translation is included without limitation in
+the term "modification".) Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope. The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+ 1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+ 2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+ a) You must cause the modified files to carry prominent notices
+ stating that you changed the files and the date of any change.
+
+ b) You must cause any work that you distribute or publish, that in
+ whole or in part contains or is derived from the Program or any
+ part thereof, to be licensed as a whole at no charge to all third
+ parties under the terms of this License.
+
+ c) If the modified program normally reads commands interactively
+ when run, you must cause it, when started running for such
+ interactive use in the most ordinary way, to print or display an
+ announcement including an appropriate copyright notice and a
+ notice that there is no warranty (or else, saying that you provide
+ a warranty) and that users may redistribute the program under
+ these conditions, and telling the user how to view a copy of this
+ License. (Exception: if the Program itself is interactive but
+ does not normally print such an announcement, your work based on
+ the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole. If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works. But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+ 3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+ a) Accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of Sections
+ 1 and 2 above on a medium customarily used for software interchange; or,
+
+ b) Accompany it with a written offer, valid for at least three
+ years, to give any third party, for a charge no more than your
+ cost of physically performing source distribution, a complete
+ machine-readable copy of the corresponding source code, to be
+ distributed under the terms of Sections 1 and 2 above on a medium
+ customarily used for software interchange; or,
+
+ c) Accompany it with the information you received as to the offer
+ to distribute corresponding source code. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form with such
+ an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it. For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable. However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+ 4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License. Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+ 5. You are not required to accept this License, since you have not
+signed it. However, nothing else grants you permission to modify or
+distribute the Program or its derivative works. These actions are
+prohibited by law if you do not accept this License. Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions. You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+ 7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all. For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices. Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+ 8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded. In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+ 9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+ 10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with this program; if not, write to the Free Software Foundation, Inc.,
+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) year name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+ `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs. If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library. If this is what you want to do, use the GNU Lesser General
+Public License instead of this License.
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/Makefile
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/Makefile (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/Makefile 2012-05-20 13:57:13 UTC (rev 20198)
@@ -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 4 . 0
+# --------------------------------------------------
+#
+# Main authors: Dimitri Komatitsch and Jeroen Tromp
+# Seismological Laboratory, California Institute of Technology, USA
+# and University of Pau / CNRS / INRIA, France
+# (c) California Institute of Technology and University of Pau / CNRS / INRIA
+# February 2008
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+#
+#=====================================================================
+
+# GNU gfortran
+#FC = gfortran
+#MPIFC = gfortran
+#FLAGS_NO_CHECK = -std=gnu -fimplicit-none -frange-check -O3 -Waliasing -Wampersand -Wsurprising -Wline-truncation -Wunderflow -fno-trapping-math
+
+# Intel ifort
+FC = ifort
+MPIFC = ifort
+FLAGS_NO_CHECK = -O3 -xSSE4.2 -vec-report0 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -warn alignments -warn ignore_loc -warn usage -check nobounds -align sequence -fpe0 -ftz
+#FLAGS_NO_CHECK = -O1 -vec-report0 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -warn alignments -warn ignore_loc -warn usage -check all -traceback -align sequence -fpe0 -ftz
+
+FCFLAGS =
+MPILIBS =
+FLAGS_CHECK = $(FLAGS_NO_CHECK)
+FCFLAGS_f90 =
+
+FCCOMPILE_CHECK = ${FC} ${FCFLAGS} $(FLAGS_CHECK)
+FCCOMPILE_NO_CHECK = ${FC} ${FCFLAGS} $(FLAGS_NO_CHECK)
+MPIFCCOMPILE_CHECK = ${MPIFC} ${FCFLAGS} $(FLAGS_CHECK) $(MPIFLAGS)
+MPIFCCOMPILE_NO_CHECK = ${MPIFC} ${FCFLAGS} $(FLAGS_NO_CHECK) $(MPIFLAGS)
+
+CC = gcc
+CFLAGS = -g -O2
+CPPFLAGS = -I.
+
+AR = ar
+ARFLAGS = cru
+RANLIB = ranlib
+
+O = obj
+S = .
+
+libspecfem_a_OBJECTS = \
+ $O/add_missing_nodes.o \
+ $O/add_topography.o \
+ $O/add_topography_410_650.o \
+ $O/add_topography_cmb.o \
+ $O/add_topography_icb.o \
+ $O/anisotropic_inner_core_model.o \
+ $O/anisotropic_mantle_model.o \
+ $O/calc_jacobian.o \
+ $O/comp_source_spectrum.o \
+ $O/comp_source_time_function.o \
+ $O/compute_coordinates_grid.o \
+ $O/compute_element_properties.o \
+ $O/count_number_of_sources.o \
+ $O/create_header_file.o \
+ $O/create_name_database.o \
+ $O/create_regions_mesh.o \
+ $O/create_serial_name_database.o \
+ $O/crustal_model.o \
+ $O/define_derivation_matrices.o \
+ $O/define_superbrick.o \
+ $O/euler_angles.o \
+ $O/get_MPI_1D_buffers.o \
+ $O/get_MPI_cutplanes_eta.o \
+ $O/get_MPI_cutplanes_xi.o \
+ $O/get_absorb.o \
+ $O/get_backazimuth.o \
+ $O/get_cmt.o \
+ $O/get_ellipticity.o \
+ $O/get_global.o \
+ $O/get_jacobian_boundaries.o \
+ $O/get_jacobian_discontinuities.o \
+ $O/get_model.o \
+ $O/get_perm_color.o \
+ $O/get_shape2D.o \
+ $O/get_shape3D.o \
+ $O/get_value_parameters.o \
+ $O/gll_library.o \
+ $O/hex_nodes.o \
+ $O/intgrl.o \
+ $O/lagrange_poly.o \
+ $O/lgndr.o \
+ $O/make_ellipticity.o \
+ $O/make_gravity.o \
+ $O/mantle_model.o \
+ $O/jp3d1994_model.o \
+ $O/sea99_s_model.o \
+ $O/memory_eval.o \
+ $O/model_1066a.o \
+ $O/model_ak135.o \
+ $O/model_iasp91.o \
+ $O/model_prem.o \
+ $O/model_ref.o \
+ $O/model_jp1d.o \
+ $O/model_sea1d.o \
+ $O/moho_stretching.o \
+ $O/spline_routines.o \
+ $O/netlib_specfun_erf.o \
+ $O/read_compute_parameters.o \
+ $O/read_value_parameters.o \
+ $O/auto_ner.o \
+ $O/recompute_jacobian.o \
+ $O/reduce.o \
+ $O/rthetaphi_xyz.o \
+ $O/s362ani.o \
+ $O/save_arrays_solver.o \
+ $O/save_header_file.o \
+ $O/sort_array_coordinates.o \
+ $O/stretching_function.o \
+ $O/topo_bathy.o \
+ $O/write_AVS_DX_global_chunks_data.o \
+ $O/write_AVS_DX_global_data.o \
+ $O/write_AVS_DX_global_faces_data.o \
+ $O/write_AVS_DX_surface_data.o \
+ $(EMPTY_MACRO)
+
+LIBSPECFEM = $O/libspecfem.a
+
+
+####
+#### targets
+####
+
+# default targets
+DEFAULT = \
+ xcreate_header_file \
+ xcombine_AVS_DX \
+ xmeshfem3D \
+ $(EMPTY_MACRO)
+
+default: $(DEFAULT)
+
+all: clean default
+
+backup:
+ cp *f90 *h README_SPECFEM3D_GLOBE DATA/Par_file* Makefile go_mesher go_solver mymachines bak
+
+bak: backup
+
+
+####
+#### rules for executables
+####
+
+# rules for the main programs
+XMESHFEM_OBJECTS = $O/meshfem3D.o $O/exit_mpi.o $(LIBSPECFEM)
+xmeshfem3D: $(XMESHFEM_OBJECTS)
+## use MPI here
+ ${MPIFCCOMPILE_CHECK} -o xmeshfem3D $(XMESHFEM_OBJECTS) $(MPILIBS)
+
+xcreate_header_file: $O/create_header_file.o $(LIBSPECFEM)
+ ${FCCOMPILE_CHECK} -o xcreate_header_file $O/create_header_file.o $(LIBSPECFEM)
+
+xcombine_AVS_DX: $O/combine_AVS_DX.o $(LIBSPECFEM)
+ ${FCCOMPILE_CHECK} -o xcombine_AVS_DX $O/combine_AVS_DX.o $(LIBSPECFEM)
+
+clean:
+ rm -f $O/* *.o work.pc* *.mod xmeshfem3D xcreate_header_file PI* xcombine_AVS_DX
+
+
+###
+### rule for the archive library
+###
+
+$O/libspecfem.a: $(libspecfem_a_OBJECTS)
+ -rm -f $O/libspecfem.a
+ $(AR) $(ARFLAGS) $O/libspecfem.a $(libspecfem_a_OBJECTS)
+ $(RANLIB) $O/libspecfem.a
+
+####
+#### rule for each .o file below
+####
+
+$O/create_header_file.o: $S/create_header_file.f90
+ ${FCCOMPILE_CHECK} -c -o $O/create_header_file.o ${FCFLAGS_f90} $S/create_header_file.f90
+
+$O/comp_source_time_function.o: $S/comp_source_time_function.f90
+ ${FCCOMPILE_CHECK} -c -o $O/comp_source_time_function.o ${FCFLAGS_f90} $S/comp_source_time_function.f90
+
+$O/sort_array_coordinates.o: constants.h $S/sort_array_coordinates.f90
+ ${FCCOMPILE_CHECK} -c -o $O/sort_array_coordinates.o ${FCFLAGS_f90} $S/sort_array_coordinates.f90
+
+## use MPI here
+$O/exit_mpi.o: constants.h $S/exit_mpi.F90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/exit_mpi.o ${FCFLAGS_f90} $S/exit_mpi.F90
+
+$O/count_number_of_sources.o: constants.h $S/count_number_of_sources.f90
+ ${FCCOMPILE_CHECK} -c -o $O/count_number_of_sources.o ${FCFLAGS_f90} $S/count_number_of_sources.f90
+
+$O/read_value_parameters.o: constants.h $S/read_value_parameters.f90
+ ${FCCOMPILE_CHECK} -c -o $O/read_value_parameters.o ${FCFLAGS_f90} $S/read_value_parameters.f90
+
+$O/get_value_parameters.o: constants.h $S/get_value_parameters.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_value_parameters.o ${FCFLAGS_f90} $S/get_value_parameters.f90
+
+$O/topo_bathy.o: constants.h $S/topo_bathy.f90
+ ${FCCOMPILE_CHECK} -c -o $O/topo_bathy.o ${FCFLAGS_f90} $S/topo_bathy.f90
+
+$O/calc_jacobian.o: constants.h $S/calc_jacobian.f90
+ ${FCCOMPILE_CHECK} -c -o $O/calc_jacobian.o ${FCFLAGS_f90} $S/calc_jacobian.f90
+
+$O/crustal_model.o: constants.h $S/crustal_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/crustal_model.o ${FCFLAGS_f90} $S/crustal_model.f90
+
+$O/make_ellipticity.o: constants.h $S/make_ellipticity.f90
+ ${FCCOMPILE_CHECK} -c -o $O/make_ellipticity.o ${FCFLAGS_f90} $S/make_ellipticity.f90
+
+$O/get_jacobian_boundaries.o: constants.h $S/get_jacobian_boundaries.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_jacobian_boundaries.o ${FCFLAGS_f90} $S/get_jacobian_boundaries.f90
+
+$O/get_jacobian_discontinuities.o: constants.h $S/get_jacobian_discontinuities.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_jacobian_discontinuities.o ${FCFLAGS_f90} $S/get_jacobian_discontinuities.f90
+
+$O/get_MPI_cutplanes_xi.o: constants.h $S/get_MPI_cutplanes_xi.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_MPI_cutplanes_xi.o ${FCFLAGS_f90} $S/get_MPI_cutplanes_xi.f90
+
+$O/get_MPI_cutplanes_eta.o: constants.h $S/get_MPI_cutplanes_eta.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_MPI_cutplanes_eta.o ${FCFLAGS_f90} $S/get_MPI_cutplanes_eta.f90
+
+$O/get_MPI_1D_buffers.o: constants.h $S/get_MPI_1D_buffers.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_MPI_1D_buffers.o ${FCFLAGS_f90} $S/get_MPI_1D_buffers.f90
+
+$O/get_cmt.o: constants.h $S/get_cmt.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_cmt.o ${FCFLAGS_f90} $S/get_cmt.f90
+
+$O/get_ellipticity.o: constants.h $S/get_ellipticity.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_ellipticity.o ${FCFLAGS_f90} $S/get_ellipticity.f90
+
+$O/get_global.o: constants.h $S/get_global.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_global.o ${FCFLAGS_f90} $S/get_global.f90
+
+$O/make_gravity.o: constants.h $S/make_gravity.f90
+ ${FCCOMPILE_CHECK} -c -o $O/make_gravity.o ${FCFLAGS_f90} $S/make_gravity.f90
+
+$O/rthetaphi_xyz.o: constants.h $S/rthetaphi_xyz.f90
+ ${FCCOMPILE_CHECK} -c -o $O/rthetaphi_xyz.o ${FCFLAGS_f90} $S/rthetaphi_xyz.f90
+
+$O/get_model.o: constants.h $S/get_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_model.o ${FCFLAGS_f90} $S/get_model.f90
+
+$O/write_AVS_DX_global_faces_data.o: constants.h $S/write_AVS_DX_global_faces_data.f90
+ ${FCCOMPILE_CHECK} -c -o $O/write_AVS_DX_global_faces_data.o ${FCFLAGS_f90} $S/write_AVS_DX_global_faces_data.f90
+
+$O/write_AVS_DX_global_chunks_data.o: constants.h $S/write_AVS_DX_global_chunks_data.f90
+ ${FCCOMPILE_CHECK} -c -o $O/write_AVS_DX_global_chunks_data.o ${FCFLAGS_f90} $S/write_AVS_DX_global_chunks_data.f90
+
+$O/write_AVS_DX_surface_data.o: constants.h $S/write_AVS_DX_surface_data.f90
+ ${FCCOMPILE_CHECK} -c -o $O/write_AVS_DX_surface_data.o ${FCFLAGS_f90} $S/write_AVS_DX_surface_data.f90
+
+$O/write_AVS_DX_global_data.o: constants.h $S/write_AVS_DX_global_data.f90
+ ${FCCOMPILE_CHECK} -c -o $O/write_AVS_DX_global_data.o ${FCFLAGS_f90} $S/write_AVS_DX_global_data.f90
+
+$O/get_shape3D.o: constants.h $S/get_shape3D.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_shape3D.o ${FCFLAGS_f90} $S/get_shape3D.f90
+
+$O/get_shape2D.o: constants.h $S/get_shape2D.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_shape2D.o ${FCFLAGS_f90} $S/get_shape2D.f90
+
+$O/hex_nodes.o: constants.h $S/hex_nodes.f90
+ ${FCCOMPILE_CHECK} -c -o $O/hex_nodes.o ${FCFLAGS_f90} $S/hex_nodes.f90
+
+$O/intgrl.o: constants.h $S/intgrl.f90
+ ${FCCOMPILE_CHECK} -c -o $O/intgrl.o ${FCFLAGS_f90} $S/intgrl.f90
+
+$O/mantle_model.o: constants.h $S/mantle_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/mantle_model.o ${FCFLAGS_f90} $S/mantle_model.f90
+
+$O/jp3d1994_model.o: constants.h $S/jp3d1994_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/jp3d1994_model.o ${FCFLAGS_f90} $S/jp3d1994_model.f90
+
+$O/sea99_s_model.o: constants.h $S/sea99_s_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/sea99_s_model.o ${FCFLAGS_f90} $S/sea99_s_model.f90
+
+$O/get_absorb.o: constants.h $S/get_absorb.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_absorb.o ${FCFLAGS_f90} $S/get_absorb.f90
+
+$O/euler_angles.o: constants.h $S/euler_angles.f90
+ ${FCCOMPILE_CHECK} -c -o $O/euler_angles.o ${FCFLAGS_f90} $S/euler_angles.f90
+
+## use MPI here
+$O/meshfem3D.o: constants.h $S/meshfem3D.F90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/meshfem3D.o ${FCFLAGS_f90} $S/meshfem3D.F90
+
+$O/spline_routines.o: constants.h $S/spline_routines.f90
+ ${FCCOMPILE_CHECK} -c -o $O/spline_routines.o ${FCFLAGS_f90} $S/spline_routines.f90
+
+$O/netlib_specfun_erf.o: $S/netlib_specfun_erf.f90
+ ${FCCOMPILE_CHECK} -c -o $O/netlib_specfun_erf.o ${FCFLAGS_f90} $S/netlib_specfun_erf.f90
+
+$O/lgndr.o: constants.h $S/lgndr.f90
+ ${FCCOMPILE_CHECK} -c -o $O/lgndr.o ${FCFLAGS_f90} $S/lgndr.f90
+
+$O/model_prem.o: constants.h $S/model_prem.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_prem.o ${FCFLAGS_f90} $S/model_prem.f90
+
+$O/model_iasp91.o: constants.h $S/model_iasp91.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_iasp91.o ${FCFLAGS_f90} $S/model_iasp91.f90
+
+$O/model_1066a.o: constants.h $S/model_1066a.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_1066a.o ${FCFLAGS_f90} $S/model_1066a.f90
+
+$O/model_ak135.o: constants.h $S/model_ak135.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_ak135.o ${FCFLAGS_f90} $S/model_ak135.f90
+
+$O/model_ref.o: constants.h $S/model_ref.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_ref.o ${FCFLAGS_f90} $S/model_ref.f90
+
+$O/model_jp1d.o: constants.h $S/model_jp1d.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_jp1d.o ${FCFLAGS_f90} $S/model_jp1d.f90
+
+$O/model_sea1d.o: constants.h $S/model_sea1d.f90
+ ${FCCOMPILE_CHECK} -c -o $O/model_sea1d.o ${FCFLAGS_f90} $S/model_sea1d.f90
+
+$O/anisotropic_mantle_model.o: constants.h $S/anisotropic_mantle_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/anisotropic_mantle_model.o ${FCFLAGS_f90} $S/anisotropic_mantle_model.f90
+
+$O/anisotropic_inner_core_model.o: constants.h $S/anisotropic_inner_core_model.f90
+ ${FCCOMPILE_CHECK} -c -o $O/anisotropic_inner_core_model.o ${FCFLAGS_f90} $S/anisotropic_inner_core_model.f90
+
+$O/reduce.o: constants.h $S/reduce.f90
+ ${FCCOMPILE_CHECK} -c -o $O/reduce.o ${FCFLAGS_f90} $S/reduce.f90
+
+$O/save_arrays_solver.o: constants.h $S/save_arrays_solver.F90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/save_arrays_solver.o ${FCFLAGS_f90} $S/save_arrays_solver.F90
+
+$O/save_header_file.o: constants.h $S/save_header_file.f90
+ ${FCCOMPILE_CHECK} -c -o $O/save_header_file.o ${FCFLAGS_f90} $S/save_header_file.f90
+
+$O/comp_source_spectrum.o: constants.h $S/comp_source_spectrum.f90
+ ${FCCOMPILE_CHECK} -c -o $O/comp_source_spectrum.o ${FCFLAGS_f90} $S/comp_source_spectrum.f90
+
+$O/add_topography.o: constants.h $S/add_topography.f90
+ ${FCCOMPILE_CHECK} -c -o $O/add_topography.o ${FCFLAGS_f90} $S/add_topography.f90
+
+$O/moho_stretching.o: constants.h $S/moho_stretching.f90
+ ${FCCOMPILE_CHECK} -c -o $O/moho_stretching.o ${FCFLAGS_f90} $S/moho_stretching.f90
+
+$O/add_topography_410_650.o: constants.h $S/add_topography_410_650.f90
+ ${FCCOMPILE_CHECK} -c -o $O/add_topography_410_650.o ${FCFLAGS_f90} $S/add_topography_410_650.f90
+
+$O/add_topography_cmb.o: constants.h $S/add_topography_cmb.f90
+ ${FCCOMPILE_CHECK} -c -o $O/add_topography_cmb.o ${FCFLAGS_f90} $S/add_topography_cmb.f90
+
+$O/add_topography_icb.o: constants.h $S/add_topography_icb.f90
+ ${FCCOMPILE_CHECK} -c -o $O/add_topography_icb.o ${FCFLAGS_f90} $S/add_topography_icb.f90
+
+$O/lagrange_poly.o: constants.h $S/lagrange_poly.f90
+ ${FCCOMPILE_CHECK} -c -o $O/lagrange_poly.o ${FCFLAGS_f90} $S/lagrange_poly.f90
+
+$O/recompute_jacobian.o: constants.h $S/recompute_jacobian.f90
+ ${FCCOMPILE_CHECK} -c -o $O/recompute_jacobian.o ${FCFLAGS_f90} $S/recompute_jacobian.f90
+
+$O/combine_AVS_DX.o: constants.h $S/combine_AVS_DX.f90
+ ${FCCOMPILE_CHECK} -c -o $O/combine_AVS_DX.o ${FCFLAGS_f90} $S/combine_AVS_DX.f90
+
+$O/create_regions_mesh.o: constants.h $S/create_regions_mesh.F90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/create_regions_mesh.o ${FCFLAGS_f90} $S/create_regions_mesh.F90
+
+$O/create_name_database.o: constants.h $S/create_name_database.f90
+ ${FCCOMPILE_CHECK} -c -o $O/create_name_database.o ${FCFLAGS_f90} $S/create_name_database.f90
+
+$O/create_serial_name_database.o: constants.h $S/create_serial_name_database.f90
+ ${FCCOMPILE_CHECK} -c -o $O/create_serial_name_database.o ${FCFLAGS_f90} $S/create_serial_name_database.f90
+
+$O/get_perm_color.o: constants.h $S/get_perm_color.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_perm_color.o ${FCFLAGS_f90} $S/get_perm_color.f90
+
+$O/define_derivation_matrices.o: constants.h $S/define_derivation_matrices.f90
+ ${FCCOMPILE_CHECK} -c -o $O/define_derivation_matrices.o ${FCFLAGS_f90} $S/define_derivation_matrices.f90
+
+$O/gll_library.o: constants.h $S/gll_library.f90
+ ${FCCOMPILE_CHECK} -c -o $O/gll_library.o ${FCFLAGS_f90} $S/gll_library.f90
+
+$O/add_missing_nodes.o: constants.h $S/add_missing_nodes.f90
+ ${FCCOMPILE_CHECK} -c -o $O/add_missing_nodes.o ${FCFLAGS_f90} $S/add_missing_nodes.f90
+
+$O/compute_coordinates_grid.o: constants.h $S/compute_coordinates_grid.f90
+ ${FCCOMPILE_CHECK} -c -o $O/compute_coordinates_grid.o ${FCFLAGS_f90} $S/compute_coordinates_grid.f90
+
+$O/compute_element_properties.o: constants.h $S/compute_element_properties.f90
+ ${FCCOMPILE_CHECK} -c -o $O/compute_element_properties.o ${FCFLAGS_f90} $S/compute_element_properties.f90
+
+$O/define_superbrick.o: constants.h $S/define_superbrick.f90
+ ${FCCOMPILE_CHECK} -c -o $O/define_superbrick.o ${FCFLAGS_f90} $S/define_superbrick.f90
+
+$O/stretching_function.o: constants.h $S/stretching_function.f90
+ ${FCCOMPILE_CHECK} -c -o $O/stretching_function.o ${FCFLAGS_f90} $S/stretching_function.f90
+
+$O/read_compute_parameters.o: constants.h $S/read_compute_parameters.F90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/read_compute_parameters.o ${FCFLAGS_f90} $S/read_compute_parameters.F90
+
+$O/auto_ner.o: constants.h $S/auto_ner.f90
+ ${FCCOMPILE_CHECK} -c -o $O/auto_ner.o ${FCFLAGS_f90} $S/auto_ner.f90
+
+$O/memory_eval.o: constants.h $S/memory_eval.f90
+ ${FCCOMPILE_CHECK} -c -o $O/memory_eval.o ${FCFLAGS_f90} $S/memory_eval.f90
+
+$O/get_backazimuth.o: constants.h $S/get_backazimuth.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_backazimuth.o ${FCFLAGS_f90} $S/get_backazimuth.f90
+
+$O/s362ani.o: constants.h $S/s362ani.f90
+ ${FCCOMPILE_CHECK} -c -o $O/s362ani.o ${FCFLAGS_f90} $S/s362ani.f90
+
+###
+### rule for the header file
+###
+
+OUTPUT_FILES/values_from_mesher.h: xcreate_header_file
+ mkdir -p OUTPUT_FILES
+ ./xcreate_header_file
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_missing_nodes.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_missing_nodes.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_missing_nodes.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,165 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! compute the missing nodes of a 27-node element when only the 8 corners have been given
+
+! the topology of the nodes is described in file hex_nodes.f90 as well as in
+! UTILS/chunk_notes_scanned/numbering_convention_27_nodes.*
+
+ subroutine add_missing_nodes(offset_x,offset_y,offset_z)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision, dimension(NGNOD) :: offset_x,offset_y,offset_z
+
+! list of corners defining the edges and the faces
+ integer, parameter :: NEDGES = 12, NFACES = 6
+ integer, dimension(NEDGES,2) :: list_corners_edge
+ integer, dimension(NFACES,4) :: list_corners_face
+
+ integer :: iedge,iface,ignod
+
+! list of corners defining the edges
+! the edge number is sorted according to the numbering convention defined in file hex_nodes.f90
+! as well as in DATA/util/YYYYYYYYYYYYYYYYYYYYYYYYYYY DK DK UGLY YYYYYYYYYYYYYYYYYYY
+
+ list_corners_edge( 1,1) = 1
+ list_corners_edge( 1,2) = 2
+
+ list_corners_edge( 2,1) = 2
+ list_corners_edge( 2,2) = 3
+
+ list_corners_edge( 3,1) = 3
+ list_corners_edge( 3,2) = 4
+
+ list_corners_edge( 4,1) = 4
+ list_corners_edge( 4,2) = 1
+
+ list_corners_edge( 5,1) = 1
+ list_corners_edge( 5,2) = 5
+
+ list_corners_edge( 6,1) = 2
+ list_corners_edge( 6,2) = 6
+
+ list_corners_edge( 7,1) = 3
+ list_corners_edge( 7,2) = 7
+
+ list_corners_edge( 8,1) = 4
+ list_corners_edge( 8,2) = 8
+
+ list_corners_edge( 9,1) = 5
+ list_corners_edge( 9,2) = 6
+
+ list_corners_edge(10,1) = 6
+ list_corners_edge(10,2) = 7
+
+ list_corners_edge(11,1) = 7
+ list_corners_edge(11,2) = 8
+
+ list_corners_edge(12,1) = 8
+ list_corners_edge(12,2) = 5
+
+! list of corners defining the faces
+! the face number is sorted according to the numbering convention defined in file hex_nodes.f90
+! as well as in DATA/util/YYYYYYYYYYYYYYYYYYYYYYYYYYY DK DK UGLY YYYYYYYYYYYYYYYYYYY
+
+ list_corners_face(1,1) = 1
+ list_corners_face(1,2) = 2
+ list_corners_face(1,3) = 3
+ list_corners_face(1,4) = 4
+
+ list_corners_face(2,1) = 1
+ list_corners_face(2,2) = 2
+ list_corners_face(2,3) = 6
+ list_corners_face(2,4) = 5
+
+ list_corners_face(3,1) = 2
+ list_corners_face(3,2) = 3
+ list_corners_face(3,3) = 7
+ list_corners_face(3,4) = 6
+
+ list_corners_face(4,1) = 4
+ list_corners_face(4,2) = 3
+ list_corners_face(4,3) = 7
+ list_corners_face(4,4) = 8
+
+ list_corners_face(5,1) = 1
+ list_corners_face(5,2) = 4
+ list_corners_face(5,3) = 8
+ list_corners_face(5,4) = 5
+
+ list_corners_face(6,1) = 5
+ list_corners_face(6,2) = 6
+ list_corners_face(6,3) = 7
+ list_corners_face(6,4) = 8
+
+! midside nodes (nodes located in the middle of an edge)
+ do iedge = 1,NEDGES
+
+! node numbers for edge centers start at 9
+ ignod = (iedge - 1) + 9
+
+ offset_x(ignod) = (offset_x(list_corners_edge(iedge,1)) + offset_x(list_corners_edge(iedge,2))) / 2.d0
+
+ offset_y(ignod) = (offset_y(list_corners_edge(iedge,1)) + offset_y(list_corners_edge(iedge,2))) / 2.d0
+
+ offset_z(ignod) = (offset_z(list_corners_edge(iedge,1)) + offset_z(list_corners_edge(iedge,2))) / 2.d0
+
+ enddo
+
+! side center nodes (nodes located in the middle of a face)
+ do iface = 1,NFACES
+
+! node numbers for face centers start at 21
+ ignod = (iface - 1) + 21
+
+ offset_x(ignod) = (offset_x(list_corners_face(iface,1)) + &
+ offset_x(list_corners_face(iface,2)) + &
+ offset_x(list_corners_face(iface,3)) + &
+ offset_x(list_corners_face(iface,4))) / 4.d0
+
+ offset_y(ignod) = (offset_y(list_corners_face(iface,1)) + &
+ offset_y(list_corners_face(iface,2)) + &
+ offset_y(list_corners_face(iface,3)) + &
+ offset_y(list_corners_face(iface,4))) / 4.d0
+
+ offset_z(ignod) = (offset_z(list_corners_face(iface,1)) + &
+ offset_z(list_corners_face(iface,2)) + &
+ offset_z(list_corners_face(iface,3)) + &
+ offset_z(list_corners_face(iface,4))) / 4.d0
+
+ enddo
+
+! center node (barycenter of the eight corners)
+ offset_x(27) = sum(offset_x(1:NGNOD_EIGHT_CORNERS)) / dble(NGNOD_EIGHT_CORNERS)
+ offset_y(27) = sum(offset_y(1:NGNOD_EIGHT_CORNERS)) / dble(NGNOD_EIGHT_CORNERS)
+ offset_z(27) = sum(offset_z(1:NGNOD_EIGHT_CORNERS)) / dble(NGNOD_EIGHT_CORNERS)
+
+ end subroutine add_missing_nodes
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_topography.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_topography.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_topography.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,87 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine add_topography(myrank,xelm,yelm,zelm,ibathy_topo,R220)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+ integer myrank
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+ integer ia
+
+ double precision lat,lon,elevation,R220
+ double precision r,theta,phi,colat
+ double precision gamma
+
+! we loop on all the points of the element
+ do ia = 1,NGNOD
+
+! convert to r theta phi
+! slightly move points to avoid roundoff problem when exactly on the polar axis
+ call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
+ theta = theta + 0.0000001d0
+ phi = phi + 0.0000001d0
+ call reduce(theta,phi)
+
+! convert the geocentric colatitude to a geographic colatitude
+ colat = PI/2.0d0 - datan(1.006760466d0*dcos(theta)/dmax1(TINYVAL,dsin(theta)))
+
+! get geographic latitude and longitude in degrees
+ lat = 90.0d0 - colat*180.0d0/PI
+ lon = phi*180.0d0/PI
+ elevation = 0.d0
+
+! compute elevation at current point
+ call get_topo_bathy(lat,lon,elevation,ibathy_topo)
+
+! non-dimensionalize the elevation, which is in meters
+ elevation = elevation / R_EARTH
+
+! stretching topography between d220 and the surface
+ gamma = (r - R220/R_EARTH) / (R_UNIT_SPHERE - R220/R_EARTH)
+
+! add elevation to all the points of that element
+! also make sure gamma makes sense
+ if(gamma < -0.02 .or. gamma > 1.02) call exit_MPI(myrank,'incorrect value of gamma for topography')
+
+ xelm(ia) = xelm(ia)*(ONE + gamma * elevation / r)
+ yelm(ia) = yelm(ia)*(ONE + gamma * elevation / r)
+ zelm(ia) = zelm(ia)*(ONE + gamma * elevation / r)
+
+ enddo
+
+ end subroutine add_topography
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_topography_410_650.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_topography_410_650.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_topography_410_650.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,134 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine add_topography_410_650(myrank,xelm,yelm,zelm,R220,R400,R670,R771, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,ylmcof,wk1,wk2,wk3,varstr)
+
+ implicit none
+
+ include "constants.h"
+
+ integer myrank
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+ double precision R220,R400,R670,R771
+
+ integer ia
+
+ real(kind=4) xcolat,xlon
+ real(kind=4) topo410out,topo650out
+ double precision topo410,topo650
+
+ double precision r,theta,phi
+ double precision gamma
+
+ integer, parameter :: maxker=200
+ integer, parameter :: maxl=72
+ integer, parameter :: maxcoe=2000
+ integer, parameter :: maxver=1000
+ integer, parameter :: maxhpa=2
+
+ integer numker
+ integer numhpa,numcof
+ integer ihpa,lmax,nylm
+ integer lmxhpa(maxhpa)
+ integer itypehpa(maxhpa)
+ integer ihpakern(maxker)
+ integer numcoe(maxhpa)
+ integer ivarkern(maxker)
+
+ integer nconpt(maxhpa),iver
+ integer iconpt(maxver,maxhpa)
+ real(kind=4) conpt(maxver,maxhpa)
+
+ real(kind=4) xlaspl(maxcoe,maxhpa)
+ real(kind=4) xlospl(maxcoe,maxhpa)
+ real(kind=4) radspl(maxcoe,maxhpa)
+ real(kind=4) coe(maxcoe,maxker)
+
+ real(kind=4) ylmcof((maxl+1)**2,maxhpa)
+ real(kind=4) wk1(maxl+1)
+ real(kind=4) wk2(maxl+1)
+ real(kind=4) wk3(maxl+1)
+
+ character(len=40) varstr(maxker)
+
+! we loop on all the points of the element
+ do ia = 1,NGNOD
+
+! convert to r theta phi
+ call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
+ call reduce(theta,phi)
+
+! get colatitude and longitude in degrees
+ xcolat = sngl(theta*180.0d0/PI)
+ xlon = sngl(phi*180.0d0/PI)
+
+! compute topography on 410 and 650 at current point
+ call subtopo(xcolat,xlon,topo410out,topo650out, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,ylmcof,wk1,wk2,wk3,varstr)
+
+! non-dimensionalize the topography, which is in km
+! positive for a depression, so change the sign for a perturbation in radius
+ topo410 = -dble(topo410out) / R_EARTH_KM
+ topo650 = -dble(topo650out) / R_EARTH_KM
+
+ gamma = 0.d0
+ if(r >= R400/R_EARTH .and. r <= R220/R_EARTH) then
+! stretching between R220 and R400
+ gamma = (R220/R_EARTH - r) / (R220/R_EARTH - R400/R_EARTH)
+ xelm(ia) = xelm(ia)*(ONE + gamma * topo410 / r)
+ yelm(ia) = yelm(ia)*(ONE + gamma * topo410 / r)
+ zelm(ia) = zelm(ia)*(ONE + gamma * topo410 / r)
+ elseif(r>= R771/R_EARTH .and. r <= R670/R_EARTH) then
+! stretching between R771 and R670
+ gamma = (r - R771/R_EARTH) / (R670/R_EARTH - R771/R_EARTH)
+ xelm(ia) = xelm(ia)*(ONE + gamma * topo650 / r)
+ yelm(ia) = yelm(ia)*(ONE + gamma * topo650 / r)
+ zelm(ia) = zelm(ia)*(ONE + gamma * topo650 / r)
+ elseif(r > R670/R_EARTH .and. r < R400/R_EARTH) then
+! stretching between R670 and R400
+ gamma = (R400/R_EARTH - r) / (R400/R_EARTH - R670/R_EARTH)
+ xelm(ia) = xelm(ia)*(ONE + (topo410 + gamma * (topo650 - topo410)) / r)
+ yelm(ia) = yelm(ia)*(ONE + (topo410 + gamma * (topo650 - topo410)) / r)
+ zelm(ia) = zelm(ia)*(ONE + (topo410 + gamma * (topo650 - topo410)) / r)
+ endif
+ if(gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for 410-650 topography')
+
+ enddo
+
+ end subroutine add_topography_410_650
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_topography_cmb.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_topography_cmb.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_topography_cmb.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,84 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine add_topography_cmb(myrank,xelm,yelm,zelm,RTOPDDOUBLEPRIME,RCMB)
+
+ implicit none
+
+ include "constants.h"
+
+ integer myrank
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+ double precision RTOPDDOUBLEPRIME,RCMB
+
+ integer ia
+
+ double precision r_start,topocmb
+
+ double precision r,theta,phi
+ double precision gamma
+
+! we loop on all the points of the element
+ do ia = 1,NGNOD
+
+! convert to r theta phi
+ call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
+ call reduce(theta,phi)
+
+! compute topography on CMB; routine subtopo_cmb needs to be supplied by the user
+! call subtopo_cmb(theta,phi,topocmb)
+ topocmb = 0.0d0
+
+! non-dimensionalize the topography, which is in km
+! positive for a depression, so change the sign for a perturbation in radius
+ topocmb = -topocmb / R_EARTH_KM
+
+! start stretching a distance RTOPDDOUBLEPRIME - RCMB below the CMB
+! and finish at RTOPDDOUBLEPRIME (D'')
+ r_start = (RCMB - (RTOPDDOUBLEPRIME - RCMB))/R_EARTH
+ gamma = 0.0d0
+ if(r >= RCMB/R_EARTH .and. r <= RTOPDDOUBLEPRIME/R_EARTH) then
+! stretching between RCMB and RTOPDDOUBLEPRIME
+ gamma = (RTOPDDOUBLEPRIME/R_EARTH - r) / (RTOPDDOUBLEPRIME/R_EARTH - RCMB/R_EARTH)
+ elseif(r>= r_start .and. r <= RCMB/R_EARTH) then
+! stretching between r_start and RCMB
+ gamma = (r - r_start) / (RCMB/R_EARTH - r_start)
+ endif
+ if(gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for CMB topography')
+
+ xelm(ia) = xelm(ia)*(ONE + gamma * topocmb / r)
+ yelm(ia) = yelm(ia)*(ONE + gamma * topocmb / r)
+ zelm(ia) = zelm(ia)*(ONE + gamma * topocmb / r)
+
+ enddo
+
+ end subroutine add_topography_cmb
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_topography_icb.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_topography_icb.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/add_topography_icb.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,81 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine add_topography_icb(myrank,xelm,yelm,zelm,RICB,RCMB)
+
+ implicit none
+
+ include "constants.h"
+
+ integer myrank
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+ double precision RICB,RCMB
+
+ integer ia
+
+ double precision topoicb
+
+ double precision r,theta,phi
+ double precision gamma
+
+! we loop on all the points of the element
+ do ia = 1,NGNOD
+
+! convert to r theta phi
+ call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
+ call reduce(theta,phi)
+
+! compute topography on ICB; the routine subtopo_icb needs to be supplied by the user
+! call subtopo_icb(theta,phi,topoicb)
+ topoicb = 0.0d0
+
+! non-dimensionalize the topography, which is in km
+! positive for a depression, so change the sign for a perturbation in radius
+ topoicb = -topoicb / R_EARTH_KM
+
+ gamma = 0.0d0
+ if(r > 0.0d0 .and. r <= RICB/R_EARTH) then
+! stretching between center and RICB
+ gamma = r/(RICB/R_EARTH)
+ elseif(r>= RICB/R_EARTH .and. r <= RCMB/R_EARTH) then
+! stretching between RICB and RCMB
+ gamma = (r - RCMB/R_EARTH) / (RICB/R_EARTH - RCMB/R_EARTH)
+ endif
+ if(gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for CMB topography')
+
+ xelm(ia) = xelm(ia)*(ONE + gamma * topoicb / r)
+ yelm(ia) = yelm(ia)*(ONE + gamma * topoicb / r)
+ zelm(ia) = zelm(ia)*(ONE + gamma * topoicb / r)
+
+ enddo
+
+ end subroutine add_topography_icb
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/anisotropic_inner_core_model.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/anisotropic_inner_core_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/anisotropic_inner_core_model.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,146 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine read_aniso_inner_core_model
+
+ implicit none
+
+! one should add an MPI_BCAST in meshfem3D.f90 if one adds a read_aniso_inner_core_model subroutine
+
+ end subroutine read_aniso_inner_core_model
+
+!-----------------------------------
+
+ subroutine aniso_inner_core_model(x,c11,c33,c12,c13,c44,REFERENCE_1D_MODEL)
+
+ implicit none
+
+ include "constants.h"
+
+! given a normalized radius x, gives non-dimensionalized c11,c33,c12,c13,c44
+
+ integer REFERENCE_1D_MODEL
+
+ double precision x,c11,c33,c12,c13,c44
+
+ double precision vp,vs,rho
+ double precision vp0,vs0,rho0,A0
+ double precision c66
+ double precision scale_fac
+
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
+ vp=11.24094d0-4.09689d0*x*x
+ vs=3.56454d0-3.45241d0*x*x
+ rho=13.0885d0-8.8381d0*x*x
+
+! values at center
+ vp0=11.24094d0
+ vs0=3.56454d0
+ rho0=13.0885d0
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
+ vp=11.2622d0-6.3640d0*x*x
+ vs=3.6678d0-4.4475d0*x*x
+ rho=13.0885d0-8.8381d0*x*x
+
+! values at center
+ vp0=11.2622d0
+ vs0=3.6678d0
+ rho0=13.0885d0
+
+ else
+ stop 'unknown 1D reference Earth model in anisotropic inner core'
+ endif
+
+! elastic tensor for hexagonal symmetry in reduced notation:
+!
+! c11 c12 c13 0 0 0
+! c12 c11 c13 0 0 0
+! c13 c13 c33 0 0 0
+! 0 0 0 c44 0 0
+! 0 0 0 0 c44 0
+! 0 0 0 0 0 c66=(c11-c12)/2
+!
+! in terms of the A, C, L, N and F of Love (1927):
+!
+! c11 = A
+! c33 = C
+! c12 = A-2N
+! c13 = F
+! c44 = L
+! c66 = N
+!
+! isotropic equivalent:
+!
+! c11 = lambda+2mu
+! c33 = lambda+2mu
+! c12 = lambda
+! c13 = lambda
+! c44 = mu
+! c66 = mu
+
+! non-dimensionalization of elastic parameters
+ scale_fac=RHOAV*R_EARTH*R_EARTH*PI*GRAV*RHOAV
+
+! Ishii et al. (2002):
+!
+! alpha = 3.490 % = (C-A)/A0 = (c33-c11)/A0
+! beta = 0.988 % = (L-N)/A0 = (c44-c66)/A0
+! gamma = 0.881 % = (A-2N-F)/A0 = (c12-c13)/A0
+! where A0 is A at the Earth's center
+!
+! assume c11 = lamda+2mu
+! c66 = (c11-c12)/2 = mu
+!
+! then c33 = c11 + alpha*A0
+! c44 = c66 + beta*A0
+! c13 = c12 - gamma*A0
+!
+! Steinle-Neumann (2002):
+!
+! r T rho c11 c12 c13 c33 c44 KS mu
+! (km) (K) (Mg/m3) (GPa)
+! 0 5735 13.09 1693 1253 1364 1813 154 1457 184
+! 200 5729 13.08 1689 1251 1362 1809 154 1455 184
+! 400 5711 13.05 1676 1243 1353 1795 151 1444 181
+! 600 5682 13.01 1661 1232 1341 1779 150 1432 180
+! 800 5642 12.95 1638 1214 1321 1755 148 1411 178
+! 1000 5590 12.87 1606 1190 1295 1720 146 1383 175
+! 1200 5527 12.77 1559 1155 1257 1670 141 1343 169
+!
+
+ c11=rho*vp*vp*1.d9/scale_fac
+ c66=rho*vs*vs*1.d9/scale_fac
+
+ A0=rho0*vp0*vp0*1.d9/scale_fac
+ c33=c11+0.0349d0*A0
+ c44=c66+0.00988d0*A0
+ c12=c11-2.0d0*c66
+ c13=c12-0.00881d0*A0
+
+ end subroutine aniso_inner_core_model
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/anisotropic_mantle_model.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/anisotropic_mantle_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/anisotropic_mantle_model.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,864 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!=====================================================================
+!
+! Jean-Paul Montagner, January 2002
+! modified by Min Chen, Caltech, February 2002
+!
+! input is (r, theta, phi), output is the matrix cij(6x6)
+! 0 <= r <= 1, 0 <= theta <= pi, 0 <= phi <= 2 pi
+!
+! returns non-dimensionalized cij
+!
+! creates parameters p(i=1,14,r,theta,phi)
+! from model glob-prem3sm01 globpreman3sm01 (Montagner, 2002)
+!
+!======================================================================
+
+
+ subroutine aniso_mantle_model(r,theta,phi,rho, &
+ c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66,&
+ AMM_V)
+
+ implicit none
+
+ include "constants.h"
+
+! aniso_mantle_model_variables
+ type aniso_mantle_model_variables
+ sequence
+ double precision beta(14,34,37,73)
+ double precision pro(47)
+ integer npar1
+ end type aniso_mantle_model_variables
+
+ type (aniso_mantle_model_variables) AMM_V
+! aniso_mantle_model_variables
+
+ double precision r,theta,phi
+ double precision rho
+ double precision c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26, &
+ c33,c34,c35,c36,c44,c45,c46,c55,c56,c66
+
+ double precision d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26, &
+ d33,d34,d35,d36,d44,d45,d46,d55,d56,d66
+
+ double precision colat,lon
+
+ lon = phi / DEGREES_TO_RADIANS
+ colat = theta / DEGREES_TO_RADIANS
+
+! uncomment this line to suppress the anisotropic mantle model
+! call exit_MPI_without_rank('please provide an anisotropic mantle model for subroutine aniso_mantle_model')
+
+! assign the local (d_ij) or global (c_ij) anisotropic parameters.
+! The c_ij are the coefficients in the global
+! reference frame used in SPECFEM3D.
+ call build_cij(AMM_V%pro,AMM_V%npar1,rho,AMM_V%beta,r,colat,lon,&
+ d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26,d33,d34,d35,d36,&
+ d44,d45,d46,d55,d56,d66)
+
+ call rotate_aniso_tensor(theta,phi,d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26,&
+ d33,d34,d35,d36,d44,d45,d46,d55,d56,d66,&
+ c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
+ c33,c34,c35,c36,c44,c45,c46,c55,c56,c66)
+
+ end subroutine aniso_mantle_model
+
+!--------------------------------------------------------------------
+
+ subroutine build_cij(pro,npar1,rho,beta,r,theta,phi,&
+ d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26,d33,d34,d35,d36,&
+ d44,d45,d46,d55,d56,d66)
+
+ implicit none
+
+ include "constants.h"
+
+ integer npar1,ndepth,idep,ipar,itheta,ilon,icz0,nx0,ny0,nz0,&
+ ict0,ict1,icp0,icp1,icz1
+
+ double precision d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26, &
+ d33,d34,d35,d36,d44,d45,d46,d55,d56,d66
+ double precision r,theta,phi,rho,depth,tei,tet,ph,fi,x0,y0,pxy0
+ double precision d1,d2,d3,d4,sd,thickness,dprof1,dprof2,eps,pc1,pc2,pc3,pc4,&
+ dpr1,dpr2,param,scale_GPa,scaleval
+ double precision A,C,F,AL,AN,BC,BS,GC,GS,HC,HS,EC,ES,C1p,C1sv,C1sh,C3,S1p,S1sv,S1sh,S3
+ double precision beta(14,34,37,73),pro(47)
+ double precision anispara(14,2,4),elpar(14)
+
+ ndepth = npar1
+ pxy0 = 5.
+ x0 = 0.
+ y0 = 0.
+ nx0 = 37
+ ny0 = 73
+ nz0 = 34
+
+! avoid edge effects
+ if(theta==0.0d0) theta=0.000001d0
+ if(theta==180.d0) theta=0.999999d0*theta
+ if(phi==0.0d0) phi=0.000001d0
+ if(phi==360.d0) phi=0.999999d0*phi
+
+! dimensionalize
+ depth = R_EARTH_KM*(R_UNIT_SPHERE - r)
+ if(depth <= pro(nz0) .or. depth >= pro(1)) call exit_MPI_without_rank('r out of range in build_cij')
+ itheta = int(theta + pxy0)/pxy0
+ ilon = int(phi + pxy0)/pxy0
+ tet = theta
+ ph = phi
+
+ icz0 = 0
+ do idep = 1,ndepth
+ if(pro(idep) > depth) icz0 = icz0 + 1
+ enddo
+
+!
+! Interpolation for depth between dep1(iz0) and dep2(iz1)
+!
+! 1 (ict0,icp0) 2 (ict0,icp1)
+! 3 (ict1,icp0) 4 (ict1,icp1)
+!
+
+ ict0 = itheta
+ ict1 = ict0 + 1
+ icp0 = ilon
+ icp1 = icp0 + 1
+ icz1 = icz0 + 1
+
+! check that parameters make sense
+ if(ict0 < 1 .or. ict0 > nx0) call exit_MPI_without_rank('ict0 out of range')
+ if(ict1 < 1 .or. ict1 > nx0) call exit_MPI_without_rank('ict1 out of range')
+ if(icp0 < 1 .or. icp0 > ny0) call exit_MPI_without_rank('icp0 out of range')
+ if(icp1 < 1 .or. icp1 > ny0) call exit_MPI_without_rank('icp1 out of range')
+ if(icz0 < 1 .or. icz0 > nz0) call exit_MPI_without_rank('icz0 out of range')
+ if(icz1 < 1 .or. icz1 > nz0) call exit_MPI_without_rank('icz1 out of range')
+
+ do ipar = 1,14
+ anispara(ipar,1,1) = beta(ipar,icz0,ict0,icp0)
+ anispara(ipar,2,1) = beta(ipar,icz1,ict0,icp0)
+ anispara(ipar,1,2) = beta(ipar,icz0,ict0,icp1)
+ anispara(ipar,2,2) = beta(ipar,icz1,ict0,icp1)
+ anispara(ipar,1,3) = beta(ipar,icz0,ict1,icp0)
+ anispara(ipar,2,3) = beta(ipar,icz1,ict1,icp0)
+ anispara(ipar,1,4) = beta(ipar,icz0,ict1,icp1)
+ anispara(ipar,2,4) = beta(ipar,icz1,ict1,icp1)
+ enddo
+
+!
+! calculation of distances between the selected point and grid points
+!
+ tei = pxy0*ict0 + x0 - pxy0
+ fi = pxy0*icp0 + y0 - pxy0
+
+!*** d1=de(tet,ph,tei,fi)
+
+ d1 = dsqrt(((tei - tet)**2) + ((fi - ph)**2)*(dsin((tet + tei)*DEGREES_TO_RADIANS/2.)**2))
+
+!*** d2=de(tet,ph,tei+pxy0,fi)
+
+ d2 = dsqrt(((tei - tet + pxy0)**2) + ((fi - ph)**2)*(dsin((tet + tei + pxy0)*DEGREES_TO_RADIANS/2.)**2))
+
+!*** d3=de(tet,ph,tei,fi+pxy0)
+
+ d3 = dsqrt(((tei - tet)**2) + ((fi - ph + pxy0)**2)*(dsin((tet + tei)*DEGREES_TO_RADIANS/2.)**2))
+
+!*** d4=de(tet,ph,tei+pxy0,fi+pxy0)
+
+ d4 = dsqrt(((tei - tet + pxy0)**2) + ((fi - ph + pxy0)**2)*(dsin((tet + tei + pxy0)*DEGREES_TO_RADIANS/2.)**2))
+
+ sd = d2*d3*d4 + d1*d2*d4 + d1*d3*d4 + d1*d2*d3
+ thickness = pro(icz0) - pro(icz1)
+ dprof1 = pro(icz0) - depth
+ dprof2 = depth - pro(icz1)
+ eps = 0.01
+
+ do ipar = 1,14
+ if(thickness < eps)then
+ pc1 = anispara(ipar,1,1)
+ pc2 = anispara(ipar,1,2)
+ pc3 = anispara(ipar,1,3)
+ pc4 = anispara(ipar,1,4)
+ else
+ dpr1 = dprof1/thickness
+ dpr2 = dprof2/thickness
+ pc1 = anispara(ipar,1,1)*dpr2+anispara(ipar,2,1)*dpr1
+ pc2 = anispara(ipar,1,2)*dpr2+anispara(ipar,2,2)*dpr1
+ pc3 = anispara(ipar,1,3)*dpr2+anispara(ipar,2,3)*dpr1
+ pc4 = anispara(ipar,1,4)*dpr2+anispara(ipar,2,4)*dpr1
+ endif
+ param = pc1*d2*d3*d4 + pc2*d1*d3*d4 + pc3*d1*d2*d4 + pc4*d1*d2*d3
+ param = param/sd
+ elpar(ipar) = param
+ enddo
+
+ d11 = ZERO
+ d12 = ZERO
+ d13 = ZERO
+ d14 = ZERO
+ d15 = ZERO
+ d16 = ZERO
+ d22 = ZERO
+ d23 = ZERO
+ d24 = ZERO
+ d25 = ZERO
+ d26 = ZERO
+ d33 = ZERO
+ d34 = ZERO
+ d35 = ZERO
+ d36 = ZERO
+ d44 = ZERO
+ d45 = ZERO
+ d46 = ZERO
+ d55 = ZERO
+ d56 = ZERO
+ d66 = ZERO
+!
+! create dij
+!
+ rho = elpar(1)
+ A = elpar(2)
+ C = elpar(3)
+ F = elpar(4)
+ AL = elpar(5)
+ AN = elpar(6)
+ BC = elpar(7)
+ BS = elpar(8)
+ GC = elpar(9)
+ GS = elpar(10)
+ HC = elpar(11)
+ HS = elpar(12)
+ EC = elpar(13)
+ ES = elpar(14)
+ C1p = 0.0d0
+ S1p = 0.0d0
+ C1sv = 0.0d0
+ S1sv = 0.0d0
+ C1sh = 0.0d0
+ S1sh = 0.0d0
+ C3 = 0.0d0
+ S3 = 0.0d0
+
+ d11 = A + EC + BC
+ d12 = A - 2.*AN - EC
+ d13 = F + HC
+ d14 = S3 + 2.*S1sh + 2.*S1p
+ d15 = 2.*C1p + C3
+ d16 = -BS/2. - ES
+ d22 = A + EC - BC
+ d23 = F - HC
+ d24 = 2.*S1p - S3
+ d25 = 2.*C1p - 2.*C1sh - C3
+ d26 = -BS/2. + ES
+ d33 = C
+ d34 = 2.*(S1p - S1sv)
+ d35 = 2.*(C1p - C1sv)
+ d36 = -HS
+ d44 = AL - GC
+ d45 = -GS
+ d46 = C1sh - C3
+ d55 = AL + GC
+ d56 = S3 - S1sh
+ d66 = AN - EC
+
+! non-dimensionalize the elastic coefficients using
+! the scale of GPa--[g/cm^3][(km/s)^2]
+ scaleval = dsqrt(PI*GRAV*RHOAV)
+ scale_GPa =(RHOAV/1000.d0)*((R_EARTH*scaleval/1000.d0)**2)
+ d11 = d11/scale_GPa
+ d12 = d12/scale_GPa
+ d13 = d13/scale_GPa
+ d14 = d14/scale_GPa
+ d15 = d15/scale_GPa
+ d16 = d16/scale_GPa
+ d22 = d22/scale_GPa
+ d23 = d23/scale_GPa
+ d24 = d24/scale_GPa
+ d25 = d25/scale_GPa
+ d26 = d26/scale_GPa
+ d33 = d33/scale_GPa
+ d34 = d34/scale_GPa
+ d35 = d35/scale_GPa
+ d36 = d36/scale_GPa
+ d44 = d44/scale_GPa
+ d45 = d45/scale_GPa
+ d46 = d46/scale_GPa
+ d55 = d55/scale_GPa
+ d56 = d56/scale_GPa
+ d66 = d66/scale_GPa
+
+! non-dimensionalize
+ rho = rho*1000.d0/RHOAV
+
+ end subroutine build_cij
+
+!--------------------------------------------------------------
+
+ subroutine read_aniso_mantle_model(AMM_V)
+
+ implicit none
+
+ include "constants.h"
+
+! aniso_mantle_model_variables
+ type aniso_mantle_model_variables
+ sequence
+ double precision beta(14,34,37,73)
+ double precision pro(47)
+ integer npar1
+ end type aniso_mantle_model_variables
+
+ type (aniso_mantle_model_variables) AMM_V
+! aniso_mantle_model_variables
+
+ integer nx,ny,np1,np2,ipar,ipa1,ipa,ilat,ilon,il,idep,nfin,nfi0,nf,nri
+ double precision xinf,yinf,pxy,ppp,angle,A,A2L,AL,af
+ double precision ra(47),pari(14,47)
+ double precision bet2(14,34,37,73)
+ double precision alph(73,37),ph(73,37)
+ character(len=150) glob_prem3sm01, globpreman3sm01
+
+ np1 = 1
+ np2 = 34
+ AMM_V%npar1 = (np2 - np1 + 1)
+
+!
+! glob-prem3sm01: model with rho,A,L,xi-1,1-phi,eta
+!
+ call get_value_string(glob_prem3sm01, 'model.glob_prem3sm01', 'DATA/Montagner_model/glob-prem3sm01')
+ open(19,file=glob_prem3sm01,status='old',action='read')
+
+!
+! read the models
+!
+! reference model: PREM or ACY400
+!
+ call lecmod(nri,pari,ra)
+!
+! read tomographic model (equivalent T.I. model)
+!
+ ipa = 0
+ nfi0 = 6
+ nfin = 14
+ do nf = 1,nfi0
+ ipa = ipa + 1
+ do idep = 1,AMM_V%npar1
+ il = idep + np1 - 1
+ read(19,"(2f4.0,2i3,f4.0)",end = 88) xinf,yinf,nx,ny,pxy
+
+ ppp = 1.
+ read(19,"(f5.0,f8.4)",end = 88) AMM_V%pro(idep),ppp
+
+ if(nf == 1) pari(nf,il) = ppp
+ if(nf == 2) pari(nf,il) = ppp
+ if(nf == 3) pari(nf,il) = ppp
+ if(nf == 4) ppp = pari(nf,il)
+ if(nf == 5) ppp = pari(nf,il)
+ do ilat = 1,nx
+ read(19,"(17f7.2)",end = 88) (AMM_V%beta(ipa,idep,ilat,ilon),ilon = 1,ny)
+!
+! calculation of A,C,F,L,N
+!
+! bet2(1,...)=rho, bet2(2,...)=A,bet2(3,...)=L,bet2(4,...)=xi
+! bet2(5,...)=phi=C/A, bet2(6,...)=eta=F/A-2L
+! bet2(7,...)=Bc, bet2(8,...)=Bs,bet2(9,...)=Gc,bet2(10,...)=Gs
+! bet2(11,...)=Hc, bet2(12,...)=Hs,bet2(13,...)=Ec,bet2(14,...)=Es
+!
+ do ilon = 1,ny
+ if(nf <= 3 .or. nf >= 6)then
+ bet2(ipa,idep,ilat,ilon) = AMM_V%beta(ipa,idep,ilat,ilon)*0.01*ppp + ppp
+ else
+ if(nf == 4)bet2(ipa,idep,ilat,ilon) = AMM_V%beta(ipa,idep,ilat,ilon)*0.01 + 1.
+ if(nf == 5)bet2(ipa,idep,ilat,ilon) = - AMM_V%beta(ipa,idep,ilat,ilon)*0.01 + 1.
+ endif
+ enddo
+
+ enddo
+ enddo
+ enddo
+88 close(19)
+
+!
+! read anisotropic azimuthal parameters
+!
+
+!
+! beta(ipa,idep,ilat,ilon) are sorted in (amplitude, phase)
+! normalized, in percents: 100 G/L
+!
+ call get_value_string(globpreman3sm01, 'model.globpreman3sm01', 'DATA/Montagner_model/globpreman3sm01')
+ open(unit=15,file=globpreman3sm01,status='old',action='read')
+
+ do nf = 7,nfin,2
+ ipa = nf
+ ipa1 = ipa + 1
+ do idep = 1,AMM_V%npar1
+ il = idep + np1 - 1
+ read(15,"(2f4.0,2i3,f4.0)",end = 888) xinf,yinf,nx,ny,pxy
+ read(15,"(f5.0,f8.4)",end = 888) AMM_V%pro(idep),ppp
+ if(nf == 7) ppp = pari(2,il)
+ if(nf == 9) ppp = pari(3,il)
+ af = pari(6,il)*(pari(2,il) - 2.*pari(3,il))
+ if(nf == 11) ppp = af
+ if(nf == 13) ppp = (pari(4,il) + 1.)*pari(3,il)
+
+ do ilat = 1,nx
+ read(15,"(17f7.2)",end = 888) (alph(ilon,ilat),ilon = 1,ny)
+ enddo
+
+ do ilat=1,nx
+ read(15,"(17f7.2)",end = 888) (ph(ilon,ilat),ilon = 1,ny)
+ enddo
+
+ do ilat = 1,nx
+ do ilon = 1,ny
+ angle = 2.*DEGREES_TO_RADIANS*ph(ilon,ilat)
+ AMM_V%beta(ipa,idep,ilat,ilon) = alph(ilon,ilat)*ppp*0.01d0
+ AMM_V%beta(ipa1,idep,ilat,ilon) = ph(ilon,ilat)
+ bet2(ipa,idep,ilat,ilon) = alph(ilon,ilat)*dcos(angle)*ppp*0.01d0
+ bet2(ipa1,idep,ilat,ilon) = alph(ilon,ilat)*dsin(angle)*ppp*0.01d0
+ enddo
+ enddo
+
+ enddo
+ enddo
+
+888 close(15)
+
+ do idep = 1,AMM_V%npar1
+ do ilat = 1,nx
+ do ilon = 1,ny
+
+! rho
+ AMM_V%beta(1,idep,ilat,ilon) = bet2(1,idep,ilat,ilon)
+
+! A
+ AMM_V%beta(2,idep,ilat,ilon) = bet2(2,idep,ilat,ilon)
+ A=bet2(2,idep,ilat,ilon)
+
+! C
+ AMM_V%beta(3,idep,ilat,ilon) = bet2(5,idep,ilat,ilon)*A
+
+! F
+ A2L = A - 2.*bet2(3,idep,ilat,ilon)
+ AMM_V%beta(4,idep,ilat,ilon) = bet2(6,idep,ilat,ilon)*A2L
+
+! L
+ AMM_V%beta(5,idep,ilat,ilon) = bet2(3,idep,ilat,ilon)
+ AL = bet2(3,idep,ilat,ilon)
+
+! N
+ AMM_V%beta(6,idep,ilat,ilon) = bet2(4,idep,ilat,ilon)*AL
+
+! azimuthal terms
+ do ipar = 7,14
+ AMM_V%beta(ipar,idep,ilat,ilon) = bet2(ipar,idep,ilat,ilon)
+ enddo
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine read_aniso_mantle_model
+
+!--------------------------------------------------------------------
+
+ subroutine lecmod(nri,pari,ra)
+
+ implicit none
+
+! read the reference Earth model: rho, Vph, Vsv, XI, PHI, ETA
+! array par(i,nlayer)
+! output: array pari(ipar, nlayer): rho, A, L, xi-1, phi-1, eta-1
+
+ integer i,j,k,ip,ifanis,idum1,idum2,idum3,nlayer,nout,neff,&
+ nband,nri,minlay,moho,kiti
+ double precision pari(14,47),qkappa(47),qshear(47),par(6,47)
+ double precision epa(14,47),ra(47),dcori(47),ri(47)
+ double precision corpar(21,47)
+ double precision aa,an,al,af,ac,vpv,vph,vsv,vsh,rho,red,a2l
+ character(len=80) null
+ character(len=150) Adrem119
+
+ ifanis = 1
+ nri = 47
+
+ call get_value_string(Adrem119, 'model.Adrem119', 'DATA/Montagner_model/Adrem119')
+ open(unit=13,file=Adrem119,status='old',action='read')
+ read(13,*,end = 77) nlayer,minlay,moho,nout,neff,nband,kiti,null
+
+ if(kiti == 0) read(13,"(20a4)",end = 77) idum1
+ read(13,"(20a4)",end = 77) idum2
+ read(13,"(20a4)",end = 77) idum3
+
+ do i = 1,nlayer
+ read(13,"(4x,f11.1,8d12.5)",end = 77) ra(i),(par(k,i),k = 1,6),qshear(i),qkappa(i)
+ enddo
+
+ do i = 1,nlayer
+ ri(i) = 0.001*ra(i)
+ enddo
+
+ do i = 1,nlayer
+ rho = par(1,i)
+ pari(1,i) = rho
+! A : pari(2,i)
+ pari(2,i) = rho*(par(2,i)**2)
+ aa = pari(2,i)
+! L : pari(3,i)
+ pari(3,i) = rho*(par(3,i)**2)
+ al = pari(3,i)
+! Xi : pari(4,i)= (N-L)/L
+ an = al*par(4,i)
+ pari(4,i) = 0.
+ pari(4,i) = par(4,i) - 1.
+! Phi : pari(5,i)=(a-c)/a
+ pari(5,i) = - par(5,i) + 1.
+ ac = par(5,i)*aa
+! f : pari(4,i)
+ af = par(6,i)*(aa - 2.*al)
+ pari(6,i) = par(6,i)
+ do ip = 7,14
+ pari(ip,i) = 0.
+ enddo
+ vsv = 0.
+ vsh = 0.
+ if(al < 0.0001 .or. an < 0.0001) goto 12
+ vsv = dsqrt(al/rho)
+ vsh = dsqrt(an/rho)
+ 12 vpv = dsqrt(ac/rho)
+ vph = dsqrt(aa/rho)
+ enddo
+
+ red = 1.
+ do i = 1,nlayer
+ read(13,"(15x,6e12.5,f11.1)",end = 77) (epa(j,i),j = 1,6),dcori(i)
+ epa(7,i) = epa(2,i)
+ epa(8,i) = epa(2,i)
+ epa(9,i) = epa(3,i)
+ epa(10,i) = epa(3,i)
+
+ a2l = pari(2,i) - 2.*pari(3,i)
+ epa(11,i) = epa(6,i)*a2l
+ epa(12,i) = epa(6,i)*a2l
+ epa(13,i) = epa(3,i)
+ epa(14,i) = epa(3,i)
+
+ do j = 1,14
+ epa(j,i) = red*epa(j,i)
+ enddo
+
+ read(13,"(21f7.3)",end = 77) (corpar(j,i),j = 1,21)
+
+ enddo
+
+77 close(13)
+
+ end subroutine lecmod
+
+!--------------------------------------------------------------------
+
+ subroutine rotate_aniso_tensor(theta,phi,d11,d12,d13,d14,d15,d16,&
+ d22,d23,d24,d25,d26,&
+ d33,d34,d35,d36,d44,d45,d46,d55,d56,d66,&
+ c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
+ c33,c34,c35,c36,c44,c45,c46,c55,c56,c66)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision theta,phi
+ double precision c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26, &
+ c33,c34,c35,c36,c44,c45,c46,c55,c56,c66
+ double precision d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26, &
+ d33,d34,d35,d36,d44,d45,d46,d55,d56,d66
+ double precision costheta,sintheta,cosphi,sinphi
+ double precision costhetasq,sinthetasq,cosphisq,sinphisq
+ double precision costwotheta,sintwotheta,costwophi,sintwophi
+ double precision cosfourtheta,sinfourtheta
+ double precision costhetafour,sinthetafour,cosphifour,sinphifour
+ double precision sintwophisq,sintwothetasq
+
+ costheta = dcos(theta)
+ sintheta = dsin(theta)
+ cosphi = dcos(phi)
+ sinphi = dsin(phi)
+
+ costhetasq = costheta * costheta
+ sinthetasq = sintheta * sintheta
+ cosphisq = cosphi * cosphi
+ sinphisq = sinphi * sinphi
+
+ costhetafour = costhetasq * costhetasq
+ sinthetafour = sinthetasq * sinthetasq
+ cosphifour = cosphisq * cosphisq
+ sinphifour = sinphisq * sinphisq
+
+ costwotheta = dcos(2.d0*theta)
+ sintwotheta = dsin(2.d0*theta)
+ costwophi = dcos(2.d0*phi)
+ sintwophi = dsin(2.d0*phi)
+
+ cosfourtheta = dcos(4.d0*theta)
+ sinfourtheta = dsin(4.d0*theta)
+ sintwothetasq = sintwotheta * sintwotheta
+ sintwophisq = sintwophi * sintwophi
+
+! recompute 21 anisotropic coefficients for full anisotropoc model using Mathematica
+
+c11 = d22*sinphifour - 2.*sintwophi*sinphisq*(d26*costheta + d24*sintheta) - &
+ 2.*cosphisq*sintwophi*(d16*costhetasq*costheta + &
+ (d14 + 2*d56)*costhetasq*sintheta + &
+ (d36 + 2*d45)*costheta*sinthetasq + d34*sintheta*sinthetasq) + &
+ cosphifour*(d11*costhetafour + 2.*d15*costhetasq*sintwotheta + &
+ (d13 + 2.*d55)*sintwothetasq/2. + &
+ 2.*d35*sintwotheta*sinthetasq + d33*sinthetafour) + &
+ (sintwophisq/4.)*(d12 + d23 + 2.*(d44 + d66) + &
+ (d12 - d23 - 2.*d44 + 2.*d66)*costwotheta + &
+ 2.*(d25 + 2.*d46)*sintwotheta)
+
+c12 = -((sintwophi/2.)*sinphisq*((3.*d16 - 4.*d26 + d36 + 2.*d45)*costheta + &
+ (d16 - d36 - 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) + &
+ 2.*(d14 - 2.*d24 + d34 + 2.*d56 + &
+ (d14 - d34 + 2.*d56)*costwotheta)*sintheta))/2. + &
+ cosphisq*sintwophi*(d16*costhetasq*costheta - d24*sintheta + &
+ (d14 + 2.*d56)*costhetasq*sintheta + d34*sintheta*sinthetasq + &
+ costheta*(-d26 + (d36 + 2.*d45)*sinthetasq)) + &
+ (sintwophisq/4.)*(d22 + d11*costhetafour + &
+ 2.*d15*costhetasq*sintwotheta - 4.*d44*sinthetasq + &
+ d33*sinthetafour + costhetasq*(-4.*d66 + &
+ 2.*(d13 + 2.*d55)*sinthetasq) + &
+ costheta*(-8.*d46*sintheta + 4.*d35*sintheta*sinthetasq)) + &
+ (cosphifour + sinphifour)*(d12*costhetasq + &
+ d23*sinthetasq + d25*sintwotheta)
+
+c13 = sinphisq*(d23*costhetasq - d25*sintwotheta + d12*sinthetasq) - &
+ sintwophi*(d36*costhetasq*costheta + &
+ (d34 - 2.*d56)*costhetasq*sintheta + &
+ (d16 - 2.*d45)*costheta*sinthetasq + d14*sintheta*sinthetasq) + &
+ (cosphisq*(d11 + 6.*d13 + d33 - 4.*d55 - &
+ (d11 - 2.*d13 + d33 - 4.*d55)*cosfourtheta + &
+ 4.*(-d15 + d35)*sinfourtheta))/8.
+
+c14 = (-4.*cosphi*sinphisq*((-d14 - 2.*d24 + d34 + 2.*d56)*costheta + &
+ (d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) + &
+ 2.*(-d16 + d26 + d36 + (-d16 + d36 + 2.*d45)*costwotheta)*sintheta) + &
+ 8.*cosphisq*cosphi*(d14*costhetasq*costheta - &
+ (d16 - 2.*d45)*costhetasq*sintheta + &
+ (d34 - 2.*d56)*costheta*sinthetasq - d36*sintheta*sinthetasq) + &
+ 4.*sinphi*sinphisq*(2.*d25*costwotheta + (-d12 + d23)*sintwotheta) + &
+ cosphisq*sinphi*(4.*(d15 + d35 - 4*d46)*costwotheta + &
+ 4.*(d15 - d35)*cosfourtheta - &
+ 2.*(d11 - d33 + 4.*d44 - 4.*d66 + &
+ (d11 - 2.*d13 + d33 - 4.*d55)*costwotheta)*sintwotheta))/8.
+
+c15 = (8.*sinphi*sinphisq*(-(d24*costheta) + d26*sintheta) + &
+ 4.*cosphi*sinphisq*(2.*(d25 + 2.*d46)*costwotheta + &
+ (-d12 + d23 + 2.*d44 - 2.*d66)*sintwotheta) + &
+ cosphisq*cosphi*(4.*(d15 + d35)*costwotheta + &
+ 4.*(d15 - d35)*cosfourtheta - 2.*(d11 - d33 + &
+ (d11 - 2.*d13 + d33 - 4.*d55)*costwotheta)*sintwotheta) - &
+ 2.*cosphisq*sinphi*((d14 + 3.*d34 + 2.*d56)*costheta + &
+ 3.*(d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) - &
+ (3.*d16 + d36 + 2.*d45)*sintheta + &
+ 3.*(-d16 + d36 + 2.*d45)*(-4.*sinthetasq*sintheta + 3.*sintheta)))/8.
+
+c16 = -(sinphifour*(d26*costheta + d24*sintheta)) - &
+ (3.*(sintwophisq/4.)*((3.*d16 - 4.*d26 + d36 + 2.*d45)*costheta + &
+ (d16 - d36 - 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) + &
+ 2.*(d14 - 2.*d24 + d34 + 2.*d56 + &
+ (d14 - d34 + 2.*d56)*costwotheta)*sintheta))/4. + &
+ cosphifour*(d16*costhetasq*costheta + &
+ (d14 + 2.*d56)*costhetasq*sintheta + &
+ (d36 + 2.*d45)*costheta*sinthetasq + d34*sintheta*sinthetasq) + &
+ (sintwophi/2.)*sinphisq*(-d22 + (d12 + 2.*d66)*costhetasq + &
+ 2.*d46*sintwotheta + (d23 + 2.*d44)*sinthetasq + d25*sintwotheta) + &
+ cosphisq*(sintwophi/2.)*(d11*costhetafour + &
+ 2.*d15*costhetasq*sintwotheta - (d23 + 2.*d44)*sinthetasq + &
+ d33*sinthetafour - costhetasq*(d12 + &
+ 2.*d66 - 2.*(d13 + 2.*d55)*sinthetasq) - &
+ (d25 - d35 + 2.*d46 + d35*costwotheta)*sintwotheta)
+
+c22 = d22*cosphifour + 2.*cosphisq*sintwophi*(d26*costheta + d24*sintheta) + &
+ 2.*sintwophi*sinphisq*(d16*costhetasq*costheta + &
+ (d14 + 2.*d56)*costhetasq*sintheta + &
+ (d36 + 2.*d45)*costheta*sinthetasq + d34*sintheta*sinthetasq) + &
+ sinphifour*(d11*costhetafour + 2.*d15*costhetasq*sintwotheta + &
+ (d13 + 2.*d55)*sintwothetasq/2. + &
+ 2.*d35*sintwotheta*sinthetasq + d33*sinthetafour) + &
+ (sintwophisq/4.)*(d12 + d23 + 2.*(d44 + d66) + &
+ (d12 - d23 - 2.*d44 + 2.*d66)*costwotheta + &
+ 2.*(d25 + 2.*d46)*sintwotheta)
+
+c23 = d13*costhetafour*sinphisq + &
+ sintheta*sinthetasq*(d14*sintwophi + d13*sinphisq*sintheta) + &
+ costheta*sinthetasq*((d16 - 2.*d45)*sintwophi + &
+ 2.*(d15 - d35)*sinphisq*sintheta) + &
+ costhetasq*costheta*(d36*sintwophi + &
+ 2.*(-d15 + d35)*sinphisq*sintheta) + &
+ costhetasq*sintheta*((d34 - 2.*d56)*sintwophi + &
+ (d11 + d33 - 4.*d55)*sinphisq*sintheta) + &
+ cosphisq*(d23*costhetasq - d25*sintwotheta + d12*sinthetasq)
+
+c24 = (8.*cosphisq*cosphi*(d24*costheta - d26*sintheta) + &
+ 4.*cosphisq*sinphi*(2.*(d25 + 2.*d46)*costwotheta + &
+ (-d12 + d23 + 2.*d44 - 2.*d66)*sintwotheta) + &
+ sinphi*sinphisq*(4.*(d15 + d35)*costwotheta + &
+ 4.*(d15 - d35)*cosfourtheta - &
+ 2.*(d11 - d33 + (d11 - 2.*d13 + &
+ d33 - 4.*d55)*costwotheta)*sintwotheta) + &
+ 2.*cosphi*sinphisq*((d14 + 3.*d34 + 2.*d56)*costheta + &
+ 3.*(d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) - &
+ (3.*d16 + d36 + 2.*d45)*sintheta + &
+ 3.*(-d16 + d36 + 2.*d45)*(-4.*sinthetasq*sintheta + 3.*sintheta)))/8.
+
+c25 = (4.*cosphisq*sinphi*((-d14 - 2.*d24 + d34 + 2.*d56)*costheta + &
+ (d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) + &
+ 2.*(-d16 + d26 + d36 + (-d16 + d36 + 2.*d45)*costwotheta)*sintheta) - &
+ 8.*sinphi*sinphisq*(d14*costhetasq*costheta - &
+ (d16 - 2.*d45)*costhetasq*sintheta + &
+ (d34 - 2.*d56)*costheta*sinthetasq - d36*sintheta*sinthetasq) + &
+ 4.*cosphisq*cosphi*(2.*d25*costwotheta + (-d12 + d23)*sintwotheta) + &
+ cosphi*sinphisq*(4.*(d15 + d35 - 4.*d46)*costwotheta + &
+ 4.*(d15 - d35)*cosfourtheta - 2.*(d11 - d33 + 4.*d44 - 4.*d66 + &
+ (d11 - 2.*d13 + d33 - 4.*d55)*costwotheta)*sintwotheta))/8.
+
+c26 = cosphifour*(d26*costheta + d24*sintheta) + &
+ (3.*(sintwophisq/4.)*((3.*d16 - 4.*d26 + d36 + 2.*d45)*costheta + &
+ (d16 - d36 - 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) + &
+ 2.*(d14 - 2.*d24 + d34 + 2.*d56 + &
+ (d14 - d34 + 2.*d56)*costwotheta)*sintheta))/4. - &
+ sinphifour*(d16*costhetasq*costheta + &
+ (d14 + 2.*d56)*costhetasq*sintheta + &
+ (d36 + 2.*d45)*costheta*sinthetasq + d34*sintheta*sinthetasq) + &
+ cosphisq*(sintwophi/2.)*(-d22 + (d12 + 2.*d66)*costhetasq + &
+ 2.*d46*sintwotheta + (d23 + 2.*d44)*sinthetasq + &
+ d25*sintwotheta) + (sintwophi/2.)*sinphisq*(d11*costhetafour + &
+ 2.*d15*costhetasq*sintwotheta - (d23 + 2.*d44)*sinthetasq + &
+ d33*sinthetafour - costhetasq*(d12 + &
+ 2.*d66 - 2.*(d13 + 2.*d55)*sinthetasq) - &
+ (d25 - d35 + 2.*d46 + d35*costwotheta)*sintwotheta)
+
+c33 = d33*costhetafour - 2.*d35*costhetasq*sintwotheta + &
+ (d13 + 2.*d55)*sintwothetasq/2. - &
+ 2.*d15*sintwotheta*sinthetasq + d11*sinthetafour
+
+c34 = cosphi*(d34*costhetasq*costheta - (d36 + 2.*d45)*costhetasq*sintheta + &
+ (d14 + 2.*d56)*costheta*sinthetasq - d16*sintheta*sinthetasq) + &
+ (sinphi*(4.*(d15 + d35)*costwotheta + 4.*(-d15 + d35)*cosfourtheta + &
+ 2.*(-d11 + d33)*sintwotheta + &
+ (d11 - 2.*d13 + d33 - 4.*d55)*sinfourtheta))/8.
+
+c35 = sinphi*(-(d34*costhetasq*costheta) + &
+ (d36 + 2.*d45)*costhetasq*sintheta - &
+ (d14 + 2.*d56)*costheta*sinthetasq + d16*sintheta*sinthetasq) + &
+ (cosphi*(4.*(d15 + d35)*costwotheta + 4.*(-d15 + d35)*cosfourtheta + &
+ 2.*(-d11 + d33)*sintwotheta + &
+ (d11 - 2.*d13 + d33 - 4.*d55)*sinfourtheta))/8.
+
+c36 = (4.*costwophi*((d16 + 3.*d36 - 2.*d45)*costheta + &
+ (-d16 + d36 + 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) + &
+ (3.*d14 + d34 - 2.*d56)*sintheta + &
+ (-d14 + d34 - 2.*d56)*(-4.*sinthetasq*sintheta + 3.*sintheta)) + &
+ sintwophi*(d11 - 4.*d12 + 6.*d13 - 4.*d23 + d33 - 4.*d55 + &
+ 4.*(d12 - d23)*costwotheta - &
+ (d11 - 2.*d13 + d33 - 4.*d55)*cosfourtheta + &
+ 8.*d25*sintwotheta + 4.*(-d15 + d35)*sinfourtheta))/16.
+
+c44 = (d11 - 2.*d13 + d33 + 4.*(d44 + d55 + d66) - &
+ (d11 - 2.*d13 + d33 - 4.*(d44 - d55 + d66))*costwophi + &
+ 4.*sintwophi*((d16 - d36 + 2.*d45)*costheta + &
+ (-d16 + d36 + 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) - &
+ 2.*(d14 - d34 + (d14 - d34 + 2.*d56)*costwotheta)*sintheta) + &
+ 8.*cosphisq*((d44 - d66)*costwotheta - 2.*d46*sintwotheta) + &
+ 2.*sinphisq*(-((d11 - 2.*d13 + d33 - 4.*d55)*cosfourtheta) + &
+ 4.*(-d15 + d35)*sinfourtheta))/16.
+
+c45 = (4.*costwophi*((d16 - d36 + 2.*d45)*costheta + &
+ (-d16 + d36 + 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) - &
+ 2.*(d14 - d34 + (d14 - d34 + 2.*d56)*costwotheta)*sintheta) + &
+ sintwophi*(d11 - 2.*d13 + d33 - 4.*(d44 - d55 + d66) + &
+ 4.*(-d44 + d66)*costwotheta - &
+ (d11 - 2.*d13 + d33 - 4.*d55)*cosfourtheta + 8.*d46*sintwotheta + &
+ 4.*(-d15 + d35)*sinfourtheta))/16.
+
+c46 = (-2.*sinphi*sinphisq*((-d14 + d34 + 2.*d56)*costheta + &
+ (d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) + &
+ 2.*(-d16 + d36 + (-d16 + d36 + 2.*d45)*costwotheta)*sintheta) + &
+ 4.*cosphisq*cosphi*(2.*d46*costwotheta + (d44 - d66)*sintwotheta) + &
+ cosphi*sinphisq*(4.*(d15 - 2.*d25 + d35 - 2.*d46)*costwotheta + &
+ 4.*(d15 - d35)*cosfourtheta - &
+ 2.*(d11 - 2.*d12 + 2.*d23 - d33 + 2.*d44 - 2.*d66 + &
+ (d11 - 2.*d13 + d33 - 4.*d55)*costwotheta)*sintwotheta) + &
+ 4.*cosphisq*sinphi*((d14 - 2.*d24 + d34)*costheta + &
+ (d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) - &
+ (d16 - 2.*d26 + d36)*sintheta + &
+ (-d16 + d36 + 2.*d45)*(-4.*sinthetasq*sintheta + 3.*sintheta)))/8.
+
+c55 = d66*sinphisq*sinthetasq + (sintwotheta/2.)*(-2.*d46*sinphisq + &
+ (d36 + d45)*sintwophi*sintheta) + &
+ costhetasq*(d44*sinphisq + (d14 + d56)*sintwophi*sintheta) - &
+ sintwophi*(d45*costhetasq*costheta + d34*costhetasq*sintheta + &
+ d16*costheta*sinthetasq + d56*sintheta*sinthetasq) + &
+ (cosphisq*(d11 - 2.*d13 + d33 + 4.*d55 - &
+ (d11 - 2.*d13 + d33 - 4.*d55)*cosfourtheta + &
+ 4.*(-d15 + d35)*sinfourtheta))/8.
+
+c56 = (8.*cosphisq*cosphi*(d56*costhetasq*costheta - &
+ (d16 - d36 - d45)*costhetasq*sintheta - &
+ (d14 - d34 + d56)*costheta*sinthetasq - d45*sintheta*sinthetasq) + &
+ 4.*sinphi*sinphisq*(2.*d46*costwotheta + (d44 - d66)*sintwotheta) + &
+ cosphisq*sinphi*(4.*(d15 - 2.*d25 + d35 - 2.*d46)*costwotheta + &
+ 4.*(d15 - d35)*cosfourtheta - &
+ 2.*(d11 - 2.*d12 + 2.*d23 - d33 + 2.*d44 - 2.*d66 + &
+ (d11 - 2.*d13 + d33 - 4.*d55)*costwotheta)*sintwotheta) - &
+ 4.*cosphi*sinphisq*((d14 - 2.*d24 + d34)*costheta + &
+ (d14 - d34 + 2.*d56)*(4.*costhetasq*costheta - 3.*costheta) - &
+ (d16 - 2.*d26 + d36)*sintheta + &
+ (-d16 + d36 + 2.*d45)*(-4.*sinthetasq*sintheta + 3.*sintheta)))/8.
+
+c66 = -((sintwophi/2.)*sinphisq*((3.*d16 - 4.*d26 + d36 + 2.*d45)*costheta + &
+ (d16 - d36 - 2.*d45)*(4.*costhetasq*costheta - 3.*costheta) + &
+ 2.*(d14 - 2.*d24 + d34 + 2.*d56 + &
+ (d14 - d34 + 2.*d56)*costwotheta)*sintheta))/2. + &
+ cosphisq*sintwophi*(d16*costhetasq*costheta - d24*sintheta + &
+ (d14 + 2.*d56)*costhetasq*sintheta + d34*sintheta*sinthetasq + &
+ costheta*(-d26 + (d36 + 2.*d45)*sinthetasq)) + &
+ (sintwophisq/4.)*(d22 + d11*costhetafour + &
+ 2.*d15*costhetasq*sintwotheta - 2.*(d23 + d44)*sinthetasq + &
+ d33*sinthetafour - 2.*sintwotheta*(d25 + d46 - d35*sinthetasq) - &
+ 2.*costhetasq*(d12 + d66 - (d13 + 2.*d55)*sinthetasq)) + &
+ (cosphifour + sinphifour)*(d66*costhetasq + &
+ d44*sinthetasq + d46*sintwotheta)
+
+
+end subroutine rotate_aniso_tensor
+!--------------------------------------------------------------------
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/auto_ner.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/auto_ner.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/auto_ner.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,500 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+!
+! This portion of the SPECFEM3D Code was written by:
+! Brian Savage while at
+! California Institute of Technology
+! Department of Terrestrial Magnetism / Carnegie Institute of Washington
+! Univeristy of Rhode Island
+!
+! <savage at uri.edu>.
+! <savage13 at gps.caltech.edu>
+! <savage13 at dtm.ciw.edu>
+!
+! It is based partially upon formulation in:
+!
+! @ARTICLE{KoTr02a,
+! author={D. Komatitsch and J. Tromp},
+! year=2002,
+! title={Spectral-Element Simulations of Global Seismic Wave Propagation{-I. V}alidation},
+! journal={Geophys. J. Int.},
+! volume=149,
+! number=2,
+! pages={390-412},
+! doi={10.1046/j.1365-246X.2002.01653.x}}
+!
+! and the core determination was developed.
+!
+
+ subroutine auto_time_stepping(WIDTH, NEX_MAX, DT)
+ implicit none
+
+ include 'constants.h'
+
+ integer NEX_MAX
+ double precision DT, WIDTH
+ double precision RADIAL_LEN_RATIO_CENTRAL_CUBE
+ double precision RADIUS_INNER_CORE
+ double precision DOUBLING_INNER_CORE
+ double precision P_VELOCITY_MAX ! Located Near the inner Core Boundary
+ double precision MAXIMUM_STABILITY_CONDITION
+ double precision MIN_GLL_POINT_SPACING_5
+
+ RADIAL_LEN_RATIO_CENTRAL_CUBE = 0.40d0
+ MAXIMUM_STABILITY_CONDITION = 0.40d0
+ RADIUS_INNER_CORE = 1221.0d0
+ DOUBLING_INNER_CORE = 8.0d0
+ P_VELOCITY_MAX = 11.02827d0
+ MIN_GLL_POINT_SPACING_5 = 0.1730d0
+
+ DT = ( RADIAL_LEN_RATIO_CENTRAL_CUBE * ((WIDTH * (PI / 180.0d0)) * RADIUS_INNER_CORE) / &
+ ( dble(NEX_MAX) / DOUBLING_INNER_CORE ) / P_VELOCITY_MAX) * &
+ MIN_GLL_POINT_SPACING_5 * MAXIMUM_STABILITY_CONDITION
+
+ end subroutine auto_time_stepping
+
+ subroutine auto_attenuation_periods(WIDTH, NEX_MAX, MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD)
+ implicit none
+
+ include 'constants.h'
+
+ integer NEX_MAX, MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD
+ double precision WIDTH, TMP
+ double precision GLL_SPACING, PTS_PER_WAVELENGTH
+ double precision S_VELOCITY_MIN, DEG2KM
+ double precision THETA(5)
+
+ GLL_SPACING = 4.00d0
+ PTS_PER_WAVELENGTH = 4.00d0
+ S_VELOCITY_MIN = 2.25d0
+ DEG2KM = 111.00d0
+
+ ! THETA defines the width of the Attenation Range in Decades
+ ! The number defined here were determined by minimizing
+ ! the "flatness" of the absoption spectrum. Each THETA
+ ! is defined for a particular N_SLS (constants.h)
+ ! THETA(2) is for N_SLS = 2
+ THETA(1) = 0.00d0
+ THETA(2) = 0.75d0
+ THETA(3) = 1.75d0
+ THETA(4) = 2.25d0
+ THETA(5) = 2.85d0
+
+ ! Compute Min Attenuation Period
+ !
+ ! The Minimum attenuation period = (Grid Spacing in km) / V_min
+ ! Grid spacing in km = Width of an element in km * spacing for GLL point * points per wavelength
+ ! Width of element in km = (Angular width in degrees / NEX_MAX) * degrees to km
+
+ TMP = (WIDTH / ( GLL_SPACING * dble(NEX_MAX)) * DEG2KM * PTS_PER_WAVELENGTH ) / &
+ S_VELOCITY_MIN
+ MIN_ATTENUATION_PERIOD = TMP
+
+ if(N_SLS < 2 .OR. N_SLS > 5) then
+ call exit_MPI_without_rank('N_SLS must be greater than 1 or less than 6')
+ endif
+
+ ! Compute Max Attenuation Period
+ !
+ ! The max attenuation period for 3 SLS is optimally
+ ! 1.75 decades from the min attenuation period, see THETA above
+ TMP = TMP * 10.0d0**THETA(N_SLS)
+ MAX_ATTENUATION_PERIOD = TMP
+
+ end subroutine auto_attenuation_periods
+
+ subroutine auto_ner(WIDTH, NEX_MAX, &
+ NER_CRUST, NER_80_MOHO, NER_220_80, NER_400_220, NER_600_400, &
+ NER_670_600, NER_771_670, NER_TOPDDOUBLEPRIME_771, &
+ NER_CMB_TOPDDOUBLEPRIME, NER_OUTER_CORE, NER_TOP_CENTRAL_CUBE_ICB, &
+ R_CENTRAL_CUBE, CASE_3D)
+
+ implicit none
+
+ include 'constants.h'
+
+ double precision WIDTH
+ integer NEX_MAX
+ integer NER_CRUST, NER_80_MOHO, NER_220_80, NER_400_220, NER_600_400, &
+ NER_670_600, NER_771_670, NER_TOPDDOUBLEPRIME_771, &
+ NER_CMB_TOPDDOUBLEPRIME, NER_OUTER_CORE, NER_TOP_CENTRAL_CUBE_ICB
+ double precision R_CENTRAL_CUBE
+ logical CASE_3D
+
+ integer, parameter :: NUM_REGIONS = 14
+ integer, dimension(NUM_REGIONS) :: scaling
+ double precision, dimension(NUM_REGIONS) :: radius
+ double precision, dimension(NUM_REGIONS-1) :: ratio_top
+ double precision, dimension(NUM_REGIONS-1) :: ratio_bottom
+ integer, dimension(NUM_REGIONS-1) :: NER
+ integer NEX_ETA
+
+ ! This is PREM in Kilometers, well ... kinda, not really ....
+ radius(1) = 6371.00d0 ! Surface
+ radius(2) = 6346.60d0 ! Moho - 1st Mesh Doubling Interface
+ radius(3) = 6291.60d0 ! 80
+ radius(4) = 6151.00d0 ! 220
+ radius(5) = 5971.00d0 ! 400
+ radius(6) = 5771.00d0 ! 600
+ radius(7) = 5701.00d0 ! 670
+ radius(8) = 5600.00d0 ! 771
+ radius(9) = 4712.00d0 ! 1650 - 2nd Mesh Doubling: Geochemical Layering; Kellogg et al. 1999, Science
+ radius(10) = 3630.00d0 ! D''
+ radius(11) = 3480.00d0 ! CMB
+ radius(12) = 2511.00d0 ! 3860 - 3rd Mesh Doubling Interface
+ radius(13) = 1371.00d0 ! 5000 - 4th Mesh Doubling Interface
+ radius(14) = 982.00d0 ! Top Central Cube
+
+ call find_r_central_cube(NEX_MAX, radius(14), NEX_ETA)
+
+ ! Mesh Doubling
+ scaling(1) = 1 ! SURFACE TO MOHO
+ scaling(2:8) = 2 ! MOHO TO G'' (Geochemical Mantle 1650)
+ scaling(9:11) = 4 ! G'' TO MIC (Middle Inner Core)
+ scaling(12) = 8 ! MIC TO MIC-II
+ scaling(13:14) = 16 ! MIC-II TO Central Cube -> Center of the Earth
+
+ ! Minimum Number of Elements a Region must have
+ NER(:) = 1
+ NER(3:5) = 2
+ if(CASE_3D) then
+ NER(1) = 2
+ endif
+
+ ! Find the Number of Radial Elements in a region based upon
+ ! the aspect ratio of the elements
+ call auto_optimal_ner(NUM_REGIONS, WIDTH, NEX_MAX, radius, scaling, NER, ratio_top, ratio_bottom)
+
+ ! Set Output arguments
+ NER_CRUST = NER(1)
+ NER_80_MOHO = NER(2)
+ NER_220_80 = NER(3)
+ NER_400_220 = NER(4)
+ NER_600_400 = NER(5)
+ NER_670_600 = NER(6)
+ NER_771_670 = NER(7)
+ NER_TOPDDOUBLEPRIME_771 = NER(8) + NER(9)
+ NER_CMB_TOPDDOUBLEPRIME = NER(10)
+ NER_OUTER_CORE = NER(11) + NER(12)
+ NER_TOP_CENTRAL_CUBE_ICB = NER(13)
+ R_CENTRAL_CUBE = radius(14) * 1000.0d0
+
+ end subroutine auto_ner
+
+ subroutine auto_optimal_ner(NUM_REGIONS, width, NEX, r, scaling, NER, rt, rb)
+
+ implicit none
+
+ include 'constants.h'
+
+ integer NUM_REGIONS
+ integer NEX
+ double precision width ! Width of the Chunk in Degrees
+ integer, dimension(NUM_REGIONS-1) :: NER ! Elements per Region - IN-N-OUT - Yummy !
+ integer, dimension(NUM_REGIONS) :: scaling ! Element Doubling - INPUT
+ double precision, dimension(NUM_REGIONS) :: r ! Radius - INPUT
+ double precision, dimension(NUM_REGIONS-1) :: rt ! Ratio at Top - OUTPUT
+ double precision, dimension(NUM_REGIONS-1) :: rb ! Ratio at Bottom - OUTPUT
+
+ double precision dr, w, ratio, xi, ximin, wt, wb
+ integer ner_test
+ integer i
+
+ ! Find optimal elements per region
+ do i = 1,NUM_REGIONS-1
+ dr = r(i) - r(i+1) ! Radial Length of Ragion
+ wt = width * PI/180.0d0 * r(i) / (NEX*1.0d0 / scaling(i)*1.0d0) ! Element Width Top
+ wb = width * PI/180.0d0 * r(i+1) / (NEX*1.0d0 / scaling(i)*1.0d0) ! Element Width Bottom
+ w = (wt + wb) * 0.5d0 ! Average Width of Region
+ ner_test = NER(i) ! Initial solution
+ ratio = (dr / ner_test) / w ! Aspect Ratio of Element
+ xi = dabs(ratio - 1.0d0) ! Aspect Ratio should be near 1.0
+ ximin = 1e7 ! Initial Minimum
+
+ do while(xi <= ximin)
+ NER(i) = ner_test ! Found a better solution
+ ximin = xi !
+ ner_test = ner_test + 1 ! Increment ner_test and
+ ratio = (dr / ner_test) / w ! look for a better
+ xi = dabs(ratio - 1.0d0) ! solution
+ end do
+ rt(i) = dr / NER(i) / wt ! Find the Ratio of Top
+ rb(i) = dr / NER(i) / wb ! and Bottom for completeness
+ end do
+
+ end subroutine auto_optimal_ner
+
+ subroutine find_r_central_cube(nex_xi_in, rcube, nex_eta_in)
+ implicit none
+
+ integer, parameter :: NBNODE = 8
+ double precision, parameter :: alpha = 0.41d0
+
+ integer npts
+ integer nex_xi, nex_eta_in, nex_xi_in
+ integer nex_eta
+ double precision rcube, rcubestep, rcube_test, rcubemax
+ double precision xi, ximin
+ double precision , allocatable, dimension(:,:) :: points
+ double precision elem(NBNODE+1, 2)
+ integer nspec_cube, nspec_chunks, ispec, nspec
+ double precision edgemax, edgemin
+ double precision max_edgemax, min_edgemin
+ double precision aspect_ratio, max_aspect_ratio
+
+ nex_xi = nex_xi_in / 16
+
+
+ rcubestep = 1.0d0
+ rcube_test = 930.0d0
+ rcubemax = 1100.0d0
+ nex_eta_in = -1
+ ximin = 1e7
+ rcube = rcube_test
+
+ do while(rcube_test <= rcubemax)
+ max_edgemax = -1e7
+ min_edgemin = 1e7
+ max_aspect_ratio = 0.0d0
+ call compute_nex(nex_xi, rcube_test, alpha, nex_eta)
+ npts = (4 * nex_xi * nex_eta * NBNODE) + (nex_xi * nex_xi * NBNODE)
+ allocate(points(npts, 2))
+ call compute_IC_mesh(rcube_test, points, npts, nspec_cube, nspec_chunks, nex_xi, nex_eta)
+ nspec = nspec_cube + nspec_chunks
+ do ispec = 1,nspec
+ call get_element(points, ispec, npts, elem)
+ call get_size_min_max(elem, edgemax, edgemin)
+ aspect_ratio = edgemax / edgemin
+ max_edgemax = MAX(max_edgemax, edgemax)
+ min_edgemin = MIN(min_edgemin, edgemin)
+ max_aspect_ratio = MAX(max_aspect_ratio, aspect_ratio)
+ end do
+ xi = (max_edgemax / min_edgemin)
+! xi = abs(rcube_test - 981.0d0) / 45.0d0
+! write(*,'(a,5(f14.4,2x))')'rcube, xi, ximin:-',rcube_test, xi, min_edgemin,max_edgemax,max_aspect_ratio
+ deallocate(points)
+ if(xi < ximin) then
+ ximin = xi
+ rcube = rcube_test
+ nex_eta_in = nex_eta
+ endif
+ rcube_test = rcube_test + rcubestep
+ enddo
+
+ end subroutine find_r_central_cube
+
+ subroutine compute_nex(nex_xi, rcube, alpha, ner)
+ implicit none
+
+ double precision, parameter :: RICB_KM = 1221.0d0
+ double precision, parameter :: PI = 3.1415
+
+ integer nex_xi, ner
+ double precision rcube, alpha
+ integer ix
+ double precision ratio_x, factx, xi
+ double precision x, y
+ double precision surfx, surfy
+ double precision dist_cc_icb, somme, dist_moy
+
+ somme = 0.0d0
+
+ do ix = 0,nex_xi/2,1
+ ratio_x = (ix * 1.0d0) / ( nex_xi * 1.0d0)
+ factx = 2.0d0 * ratio_x - 1.0d0
+ xi = (PI / 2.0d0) * factx
+ x = (rcube / sqrt(2.0d0)) * factx
+ y = (rcube / sqrt(2.0d0)) * (1 + cos(xi) * alpha / (PI / 2.0d0))
+
+ surfx = RICB_KM * cos(3 * (PI/4.0d0) - ratio_x * (PI/2.0d0))
+ surfy = RICB_KM * sin(3 * (PI/4.0d0) - ratio_x * (PI/2.0d0))
+
+ dist_cc_icb = sqrt((surfx -x)**2 + (surfy - y)**2)
+ if(ix /= nex_xi/2) then
+ dist_cc_icb = dist_cc_icb * 2
+ endif
+ somme = somme + dist_cc_icb
+ end do
+ dist_moy = somme / (nex_xi + 1)
+ ner = nint(dist_moy / ((PI * RICB_KM) / (2*nex_xi)))
+ end subroutine compute_nex
+
+ subroutine get_element(points, ispec, npts, pts)
+ implicit none
+ integer npts, ispec
+ integer, parameter :: NBNODE = 8
+ double precision pts(NBNODE+1,2), points(npts,2)
+ pts(1:8,:) = points( ( (ispec-1) * NBNODE)+1 : ( (ispec) * NBNODE )+1, : )
+ pts(NBNODE+1,:) = pts(1,:) ! Use first point as the last point
+ end subroutine get_element
+
+ subroutine get_size_min_max(pts, edgemax, edgemin)
+ implicit none
+ integer ie, ix1,ix2,ix3
+ integer, parameter :: NBNODE = 8
+ double precision edgemax, edgemin, edge
+ double precision pts(NBNODE+1, 2)
+
+
+ edgemax = -1e7
+ edgemin = -edgemax
+ do ie = 1,NBNODE/2,1
+ ix1 = (ie * 2) - 1
+ ix2 = ix1 + 1
+ ix3 = ix1 + 2
+ edge = sqrt( (pts(ix1,1) - pts(ix2,1))**2 + (pts(ix1,2) - pts(ix2,2))**2 ) + &
+ sqrt( (pts(ix2,1) - pts(ix3,1))**2 + (pts(ix2,2) - pts(ix3,2))**2 )
+ edgemax = MAX(edgemax, edge)
+ edgemin = MIN(edgemin, edge)
+ end do
+ end subroutine get_size_min_max
+
+ subroutine compute_IC_mesh(rcube, points, npts, nspec_cube, nspec_chunks, nex_xi, nex_eta)
+ implicit none
+
+ integer, parameter :: NBNODE = 8
+ integer npts
+ integer nspec_chunks, nspec_cube
+
+ double precision rcube
+ double precision alpha
+ double precision points(npts, 2)
+ double precision x, y
+
+ integer nex_eta, nex_xi
+ integer ic, ix, iy, in
+ integer, parameter, dimension(NBNODE) :: iaddx(NBNODE) = (/0,1,2,2,2,1,0,0/)
+ integer, parameter, dimension(NBNODE) :: iaddy(NBNODE) = (/0,0,0,1,2,2,2,1/)
+ integer k
+
+ k = 1
+ alpha = 0.41d0
+ nspec_chunks = 0
+ do ic = 0,3
+ do ix = 0,(nex_xi-1)*2,2
+ do iy = 0,(nex_eta-1)*2,2
+ do in = 1,NBNODE
+ call compute_coordinate(ix+iaddx(in), iy+iaddy(in), nex_xi*2, nex_eta*2, rcube, ic, alpha, x,y)
+ points(k,1) = x
+ points(k,2) = y
+ k = k + 1
+ end do
+ nspec_chunks = nspec_chunks + 1
+ end do
+ end do
+ end do
+
+ nspec_cube = 0
+ do ix = 0,(nex_xi-1)*2,2
+ do iy = 0,(nex_xi-1)*2,2
+ do in = 1,NBNODE
+ call compute_coordinate_central_cube(ix+iaddx(in), iy+iaddy(in), nex_xi*2, nex_xi*2, rcube, alpha,x,y)
+ points(k,1) = x
+ points(k,2) = y
+ k = k + 1
+ end do
+ nspec_cube = nspec_cube + 1
+ end do
+ end do
+
+ end subroutine compute_IC_mesh
+
+ subroutine compute_coordinate_central_cube(ix,iy,nbx,nby,radius, alpha, x, y)
+ implicit none
+
+ double precision, parameter :: PI = 3.1415d0
+
+ integer ix, iy, nbx, nby
+ double precision radius, alpha
+ double precision x, y
+
+ double precision ratio_x, ratio_y
+ double precision factx, facty
+ double precision xi, eta
+
+ ratio_x = (ix * 1.0d0) / (nbx * 1.0d0)
+ ratio_y = (iy * 1.0d0) / (nby * 1.0d0)
+
+ factx = 2.0d0 * ratio_x - 1.0d0
+ facty = 2.0d0 * ratio_y - 1.0d0
+
+ xi = (PI / 2.0d0) * factx
+ eta = (PI / 2.0d0) * facty
+
+ x = (radius / sqrt(2.0d0)) * factx * ( 1 + cos(eta) * alpha / (PI / 2.0d0))
+ y = (radius / sqrt(2.0d0)) * facty * ( 1 + cos(xi) * alpha / (PI / 2.0d0))
+
+ end subroutine compute_coordinate_central_cube
+
+ subroutine compute_coordinate(ix,iy,nbx, nby, rcube, ic, alpha, x, y)
+ implicit none
+
+ double precision, parameter :: PI = 3.1415d0
+ double precision, parameter :: RICB_KM = 1221.0d0
+
+ integer ix, iy, nbx, nby, ic
+ double precision rcube, alpha
+ double precision x, y
+
+ double precision ratio_x, ratio_y
+ double precision factx, xi
+ double precision xcc, ycc
+ double precision xsurf, ysurf
+ double precision deltax, deltay
+ double precision temp
+
+ ratio_x = (ix * 1.0d0) / (nbx * 1.0d0)
+ ratio_y = (iy * 1.0d0) / (nby * 1.0d0)
+
+ factx = 2.0d0 * ratio_x - 1.0d0
+ xi = (PI/2.0d0) * factx
+
+ xcc = (rcube / sqrt(2.0d0)) * factx
+ ycc = (rcube / sqrt(2.0d0)) * (1 + cos(xi) * alpha / (PI/2.0d0))
+
+ xsurf = RICB_KM * cos(3.0d0 * (PI/4.0d0) - ratio_x * (PI/2.0d0))
+ ysurf = RICB_KM * sin(3.0d0 * (PI/4.0d0) - ratio_x * (PI/2.0d0))
+
+ deltax = xsurf - xcc
+ deltay = ysurf - ycc
+
+ x = xsurf - ratio_y * deltax
+ y = ysurf - ratio_y * deltay
+
+ if(ic == 1) then
+ temp = x
+ x = y
+ y = temp
+ else if (ic == 2) then
+ x = -x
+ y = -y
+ else if (ic == 3) then
+ temp = x
+ x = -y
+ y = temp
+ end if
+ end subroutine compute_coordinate
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/calc_jacobian.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/calc_jacobian.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/calc_jacobian.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,156 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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) * R_EARTH
+ xeta = xeta + dershape3D(2,ia,i,j,k)*xelm(ia) * R_EARTH
+ xgamma = xgamma + dershape3D(3,ia,i,j,k)*xelm(ia) * R_EARTH
+ yxi = yxi + dershape3D(1,ia,i,j,k)*yelm(ia) * R_EARTH
+ yeta = yeta + dershape3D(2,ia,i,j,k)*yelm(ia) * R_EARTH
+ ygamma = ygamma + dershape3D(3,ia,i,j,k)*yelm(ia) * R_EARTH
+ zxi = zxi + dershape3D(1,ia,i,j,k)*zelm(ia) * R_EARTH
+ zeta = zeta + dershape3D(2,ia,i,j,k)*zelm(ia) * R_EARTH
+ zgamma = zgamma + dershape3D(3,ia,i,j,k)*zelm(ia) * R_EARTH
+
+ xmesh = xmesh + shape3D(ia,i,j,k)*xelm(ia)
+ ymesh = ymesh + shape3D(ia,i,j,k)*yelm(ia)
+ zmesh = zmesh + shape3D(ia,i,j,k)*zelm(ia)
+ enddo
+
+ jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
+ xeta*(yxi*zgamma-ygamma*zxi) + &
+ xgamma*(yxi*zeta-yeta*zxi)
+
+ if(jacobian <= ZERO) call exit_MPI(myrank,'3D Jacobian undefined')
+
+! invert the relation (Fletcher p. 50 vol. 2)
+ xix = (yeta*zgamma-ygamma*zeta) / jacobian
+ xiy = (xgamma*zeta-xeta*zgamma) / jacobian
+ xiz = (xeta*ygamma-xgamma*yeta) / jacobian
+ etax = (ygamma*zxi-yxi*zgamma) / jacobian
+ etay = (xxi*zgamma-xgamma*zxi) / jacobian
+ etaz = (xgamma*yxi-xxi*ygamma) / jacobian
+ gammax = (yxi*zeta-yeta*zxi) / jacobian
+ gammay = (xeta*zxi-xxi*zeta) / jacobian
+ gammaz = (xxi*yeta-xeta*yxi) / jacobian
+
+! save the derivatives and the jacobian
+! distinguish between single and double precision for reals
+ if(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
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/combine_AVS_DX.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/combine_AVS_DX.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/combine_AVS_DX.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,994 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! 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 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 sec,t_cmt,hdur
+ double precision lat,long,depth
+ double precision moment_tensor(6)
+
+! 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 ichunk
+ 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,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
+
+ character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL
+
+! parameters deduced from parameters read from file
+ integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+
+! for all the regions
+ integer, dimension(MAX_NUM_REGIONS) :: &
+ 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,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.)
+
+
+ if(.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))
+
+!! DK DK modified for the GPU version
+! 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'
+!! DK DK added this: only one chunk for the GPU version for now
+ ichunk = 1
+!! DK DK added this: only one chunk for the GPU version for now
+ 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
+
+!! DK DK for GPU version: only one region
+ region_min = 1
+ region_max = 1
+!! DK DK for GPU version: only one region
+
+ 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,t_cmt,hdur,lat,long,depth,moment_tensor,DT,1)
+
+! 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')
+ 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')
+ 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*vmincoord(ipointnumber1_horiz)*dble(NGLL_current_horiz)/distance_horiz,gridmin)
+ gridmin = dmin1(scale_factor*hdur*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*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(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
+
+! ************* 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),' s used for points per wavelength'
+ print *
+
+ if(hdur < 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 *
+ endif
+
+ end program combine_AVS_DX
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/comp_source_spectrum.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/comp_source_spectrum.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/comp_source_spectrum.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,39 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ double precision function comp_source_spectrum(om,hdur)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision om,hdur
+
+ comp_source_spectrum = dexp(-0.25d0*(om*hdur/SOURCE_DECAY_MIMIC_TRIANGLE)**2)
+
+ end function comp_source_spectrum
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/comp_source_time_function.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/comp_source_time_function.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/comp_source_time_function.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,42 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ double precision function comp_source_time_function(t,hdur)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision t,hdur
+
+ double precision, external :: netlib_specfun_erf
+
+! quasi Heaviside
+ comp_source_time_function = 0.5d0*(1.0d0 + netlib_specfun_erf(t/hdur))
+
+ end function comp_source_time_function
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/compute_coordinates_grid.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/compute_coordinates_grid.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/compute_coordinates_grid.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,327 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine compute_coord_main_mesh(offset_x,offset_y,offset_z,xelm,yelm,zelm, &
+ ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
+ NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ r_top,r_bottom,ner,ilayer,ichunk,rotation_matrix,NCHUNKS,&
+ INCLUDE_CENTRAL_CUBE,NUMBER_OF_MESH_LAYERS)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision, dimension(NGNOD) :: xelm,yelm,zelm,offset_x,offset_y,offset_z
+
+! rotation matrix from Euler angles
+ double precision, dimension(NDIM,NDIM) :: rotation_matrix
+
+ integer, intent(in) :: iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA, &
+ NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ner,ilayer,ichunk,NCHUNKS
+
+ double precision :: ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,r_top,r_bottom
+
+ logical :: INCLUDE_CENTRAL_CUBE
+ integer :: NUMBER_OF_MESH_LAYERS
+
+! local variables
+ integer :: i,j,ignod
+
+ double precision :: xi,eta,gamma,x,y,x_,y_,z,rgb,rgt,rn
+ double precision :: x_bot,y_bot,z_bot
+ double precision :: x_top,y_top,z_top
+
+ double precision, dimension(NDIM) :: vector_ori,vector_rotated
+
+ double precision :: ratio_xi, ratio_eta, fact_xi, fact_eta, &
+ fact_xi_,fact_eta_
+
+ double precision, parameter :: PI_OVER_TWO = PI / 2.d0
+
+
+! this to avoid compilation warnings
+ x_=0
+ y_=0
+
+! loop on all the nodes in this element
+ do ignod = 1,NGNOD
+
+ if(ilayer == NUMBER_OF_MESH_LAYERS .and. INCLUDE_CENTRAL_CUBE) then
+! case of the inner core
+ ratio_xi = ((iproc_xi + offset_x(ignod)/dble(NEX_PER_PROC_XI))/dble(NPROC_XI))
+ fact_xi = 2.d0*ratio_xi-1.d0
+
+ ratio_eta = ((iproc_eta + offset_y(ignod)/dble(NEX_PER_PROC_ETA))/dble(NPROC_ETA))
+ fact_eta = 2.d0*ratio_eta-1.d0
+
+ fact_xi_ = tan((ANGULAR_WIDTH_XI_RAD/2.d0) * fact_xi)
+ fact_eta_ = tan((ANGULAR_WIDTH_ETA_RAD/2.d0) * fact_eta)
+
+! uncomment the following lines to have more regular surface mesh (better aspect ratio for each element)
+! uncomment the corresponding lines in the else condition of this if statement too.
+! note that the ratio bigger_edge_size/smaller_edge_size for the surface mesh is a bit higher (1.43 vs 1.41)
+
+! fact_xi_= (3.d0*fact_xi+4.d0*fact_xi_)/7.d0
+! fact_eta_= (3.d0*fact_eta+4.d0*fact_eta_)/7.d0
+
+ xi = PI_OVER_TWO*fact_xi
+ eta = PI_OVER_TWO*fact_eta
+
+ gamma = ONE / sqrt(ONE + fact_xi_**2 + fact_eta_**2)
+ rgt = (r_top / R_EARTH)*gamma
+
+! coordinates of the edge extremity on the central cube surface
+ x_bot = ((r_bottom / R_EARTH) / sqrt(3.d0))* fact_xi * (1 + cos(eta)*CENTRAL_CUBE_INFLATE_FACTOR / PI)
+ y_bot = ((r_bottom / R_EARTH) / sqrt(3.d0)) * fact_eta * (1 + cos(xi)*CENTRAL_CUBE_INFLATE_FACTOR / PI)
+ z_bot = ((r_bottom / R_EARTH) / sqrt(3.d0)) * (1 + (cos(xi) + cos(eta))*CENTRAL_CUBE_INFLATE_FACTOR / PI)
+
+! coordinates of the edge extremity on the ICB
+ x_top = fact_xi_*rgt
+ y_top = fact_eta_*rgt
+ z_top = rgt
+
+ rn = offset_z(ignod) / dble(ner)
+ x = x_top*rn + x_bot*(ONE-rn)
+ y = y_top*rn + y_bot*(ONE-rn)
+ z = z_top*rn + z_bot*(ONE-rn)
+
+ select case (ichunk)
+ case(CHUNK_AB)
+ xelm(ignod) = -y
+ yelm(ignod) = x
+ zelm(ignod) = z
+ case(CHUNK_AB_ANTIPODE)
+ xelm(ignod) = -y
+ yelm(ignod) = -x
+ zelm(ignod) = -z
+ case(CHUNK_AC)
+ xelm(ignod) = -y
+ yelm(ignod) = -z
+ zelm(ignod) = x
+ case(CHUNK_AC_ANTIPODE)
+ xelm(ignod) = -y
+ yelm(ignod) = z
+ zelm(ignod) = -x
+ case(CHUNK_BC)
+ xelm(ignod) = -z
+ yelm(ignod) = y
+ zelm(ignod) = x
+ case(CHUNK_BC_ANTIPODE)
+ xelm(ignod) = z
+ yelm(ignod) = -y
+ zelm(ignod) = x
+ case default
+ stop 'incorrect chunk number in compute_coord_main_mesh'
+ end select
+! write(IMAIN,*) x,' ',y,' ',z
+ else
+
+! uncomment the following lines to have more regular surface mesh (better aspect ratio for each element)
+! note that the ratio bigger_edge_size/smaller_edge_size for the surface mesh is a bit higher (1.43 vs 1.41)
+! ratio_xi = ((iproc_xi + offset_x(ignod)/dble(NEX_PER_PROC_XI))/dble(NPROC_XI))*tan(ANGULAR_WIDTH_XI_RAD/2.d0)
+! x_ = 2.d0*ratio_xi-tan(ANGULAR_WIDTH_XI_RAD/2.d0)
+! ratio_eta = ((iproc_eta + offset_y(ignod)/dble(NEX_PER_PROC_ETA))/dble(NPROC_ETA))*tan(ANGULAR_WIDTH_ETA_RAD/2.d0)
+! y_ = 2.d0*ratio_eta-tan(ANGULAR_WIDTH_ETA_RAD/2.d0)
+
+ ratio_xi = ((iproc_xi + offset_x(ignod)/dble(NEX_PER_PROC_XI))/dble(NPROC_XI))
+ x = 2.d0*ratio_xi-1
+
+ ratio_eta = ((iproc_eta + offset_y(ignod)/dble(NEX_PER_PROC_ETA))/dble(NPROC_ETA))
+ y = 2.d0*ratio_eta-1
+
+ x = tan((ANGULAR_WIDTH_XI_RAD/2.d0) * x)
+ y = tan((ANGULAR_WIDTH_ETA_RAD/2.d0) * y)
+
+! uncomment the following lines to have more regular surface mesh (better aspect ratio for each element)
+! note that the ratio bigger_edge_size/smaller_edge_size for the surface mesh is a bit higher (1.43 vs 1.41)
+! x= (3.d0*x_+4.d0*x)/7.d0
+! y= (3.d0*y_+4.d0*y)/7.d0
+
+ gamma = ONE / sqrt(ONE + x*x + y*y)
+
+ rgt = (r_top / R_EARTH)*gamma
+ rgb = (r_bottom / R_EARTH)*gamma
+
+ ! define the mesh points on the top and the bottom in the six regions of the cubed shpere
+ select case (ichunk)
+
+ case(CHUNK_AB)
+
+ x_top = -y*rgt
+ y_top = x*rgt
+ z_top = rgt
+
+ x_bot = -y*rgb
+ y_bot = x*rgb
+ z_bot = rgb
+
+ case(CHUNK_AB_ANTIPODE)
+
+ x_top = -y*rgt
+ y_top = -x*rgt
+ z_top = -rgt
+
+ x_bot = -y*rgb
+ y_bot = -x*rgb
+ z_bot = -rgb
+
+ case(CHUNK_AC)
+
+ x_top = -y*rgt
+ y_top = -rgt
+ z_top = x*rgt
+
+ x_bot = -y*rgb
+ y_bot = -rgb
+ z_bot = x*rgb
+
+ case(CHUNK_AC_ANTIPODE)
+
+ x_top = -y*rgt
+ y_top = rgt
+ z_top = -x*rgt
+
+ x_bot = -y*rgb
+ y_bot = rgb
+ z_bot = -x*rgb
+
+ case(CHUNK_BC)
+
+ x_top = -rgt
+ y_top = y*rgt
+ z_top = x*rgt
+
+ x_bot = -rgb
+ y_bot = y*rgb
+ z_bot = x*rgb
+
+ case(CHUNK_BC_ANTIPODE)
+
+ x_top = rgt
+ y_top = -y*rgt
+ z_top = x*rgt
+
+ x_bot = rgb
+ y_bot = -y*rgb
+ z_bot = x*rgb
+
+ case default
+ stop 'incorrect chunk number in compute_coord_main_mesh'
+
+ end select
+
+ ! rotate the chunk to the right location if we do not mesh the full Earth
+ if(NCHUNKS /= 6) then
+
+ ! rotate bottom
+ vector_ori(1) = x_bot
+ vector_ori(2) = y_bot
+ vector_ori(3) = z_bot
+ do i = 1,NDIM
+ vector_rotated(i) = ZERO
+ do j = 1,NDIM
+ vector_rotated(i) = vector_rotated(i) + rotation_matrix(i,j)*vector_ori(j)
+ enddo
+ enddo
+ x_bot = vector_rotated(1)
+ y_bot = vector_rotated(2)
+ z_bot = vector_rotated(3)
+
+ ! rotate top
+ vector_ori(1) = x_top
+ vector_ori(2) = y_top
+ vector_ori(3) = z_top
+ do i = 1,NDIM
+ vector_rotated(i) = ZERO
+ do j = 1,NDIM
+ vector_rotated(i) = vector_rotated(i) + rotation_matrix(i,j)*vector_ori(j)
+ enddo
+ enddo
+ x_top = vector_rotated(1)
+ y_top = vector_rotated(2)
+ z_top = vector_rotated(3)
+
+ endif
+
+ ! compute the position of the point
+ rn = offset_z(ignod) / dble(ner)
+ xelm(ignod) = x_top*rn + x_bot*(ONE-rn)
+ yelm(ignod) = y_top*rn + y_bot*(ONE-rn)
+ zelm(ignod) = z_top*rn + z_bot*(ONE-rn)
+
+ endif
+ enddo
+! if(ilayer == NUMBER_OF_MESH_LAYERS .and. INCLUDE_CENTRAL_CUBE) write(IMAIN,*)
+ end subroutine compute_coord_main_mesh
+
+!---------------------------------------------------------------------------
+
+!! DK DK create value of arrays xgrid ygrid and zgrid in the central cube without storing them
+
+ subroutine compute_coord_central_cube(ix,iy,iz, &
+ xgrid_central_cube,ygrid_central_cube,zgrid_central_cube, &
+ iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,nx_central_cube,ny_central_cube,nz_central_cube,radius_cube)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: ix,iy,iz,iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,nx_central_cube,ny_central_cube,nz_central_cube
+
+ double precision :: xgrid_central_cube,ygrid_central_cube,zgrid_central_cube,radius_cube
+
+! local variables
+ double precision :: ratio_x,ratio_y,ratio_z
+ double precision :: fact_x,fact_y,fact_z,xi,eta,gamma
+ double precision, parameter :: PI_OVER_TWO = PI / 2.d0
+
+! the slice extends to the entire cube along Z
+! but only to current block along X and Y
+ ratio_x = (dble(iproc_xi) + dble(ix)/dble(2*nx_central_cube)) / dble(NPROC_XI)
+ ratio_y = (dble(iproc_eta) + dble(iy)/dble(2*ny_central_cube)) / dble(NPROC_ETA)
+ ratio_z = dble(iz)/dble(2*nz_central_cube)
+
+ if(abs(ratio_x) > 1.001d0 .or. abs(ratio_y) > 1.001d0 .or. abs(ratio_z) > 1.001d0) stop 'wrong ratio in central cube'
+
+! use a "flat" cubed sphere to create the central cube
+
+! map ratio to [-1,1] and then map to real radius
+! then add deformation
+ fact_x = 2.d0*ratio_x-1.d0
+ fact_y = 2.d0*ratio_y-1.d0
+ fact_z = 2.d0*ratio_z-1.d0
+
+ xi = PI_OVER_TWO*fact_x;
+ eta = PI_OVER_TWO*fact_y;
+ gamma = PI_OVER_TWO*fact_z;
+
+ xgrid_central_cube = radius_cube * fact_x * (1 + (cos(eta)+cos(gamma))*CENTRAL_CUBE_INFLATE_FACTOR / PI);
+ ygrid_central_cube = radius_cube * fact_y * (1 + (cos(xi)+cos(gamma))*CENTRAL_CUBE_INFLATE_FACTOR / PI);
+ zgrid_central_cube = radius_cube * fact_z * (1 + (cos(xi)+cos(eta))*CENTRAL_CUBE_INFLATE_FACTOR / PI);
+
+ end subroutine compute_coord_central_cube
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/compute_element_properties.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/compute_element_properties.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/compute_element_properties.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,393 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! compute several rheological and geometrical properties for a given spectral element
+ subroutine compute_element_properties(ispec,iregion_code,idoubling, &
+ xstore,ystore,zstore,nspec, &
+ nspl,rspl,espl,espl2,ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ myrank,ibathy_topo,ATTENUATION,ATTENUATION_3D, &
+ ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xelm,yelm,zelm,shape3D,dershape3D,rmin,rmax,rhostore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ nspec_ani,nspec_stacey,Qmu_store,tau_e_store,rho_vp,rho_vs,&
+ AMM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ACTUALLY_STORE_ARRAYS)
+
+ implicit none
+
+ include "constants.h"
+
+! aniso_mantle_model_variables
+ type aniso_mantle_model_variables
+ sequence
+ double precision beta(14,34,37,73)
+ double precision pro(47)
+ integer npar1
+ end type aniso_mantle_model_variables
+
+ type (aniso_mantle_model_variables) AMM_V
+! aniso_mantle_model_variables
+
+! model_1066a_variables
+ type model_1066a_variables
+ sequence
+ double precision, dimension(NR_1066A) :: radius_1066a
+ double precision, dimension(NR_1066A) :: density_1066a
+ double precision, dimension(NR_1066A) :: vp_1066a
+ double precision, dimension(NR_1066A) :: vs_1066a
+ double precision, dimension(NR_1066A) :: Qkappa_1066a
+ double precision, dimension(NR_1066A) :: Qmu_1066a
+ end type model_1066a_variables
+
+ type (model_1066a_variables) M1066a_V
+! model_1066a_variables
+
+! model_ak135_variables
+ type model_ak135_variables
+ sequence
+ double precision, dimension(NR_AK135) :: radius_ak135
+ double precision, dimension(NR_AK135) :: density_ak135
+ double precision, dimension(NR_AK135) :: vp_ak135
+ double precision, dimension(NR_AK135) :: vs_ak135
+ double precision, dimension(NR_AK135) :: Qkappa_ak135
+ double precision, dimension(NR_AK135) :: Qmu_ak135
+ end type model_ak135_variables
+
+ type (model_ak135_variables) Mak135_V
+! model_ak135_variables
+
+! model_ref_variables
+ type model_ref_variables
+ sequence
+ double precision, dimension(NR_REF) :: radius_ref
+ double precision, dimension(NR_REF) :: density_ref
+ double precision, dimension(NR_REF) :: vpv_ref
+ double precision, dimension(NR_REF) :: vph_ref
+ double precision, dimension(NR_REF) :: vsv_ref
+ double precision, dimension(NR_REF) :: vsh_ref
+ double precision, dimension(NR_REF) :: eta_ref
+ double precision, dimension(NR_REF) :: Qkappa_ref
+ double precision, dimension(NR_REF) :: Qmu_ref
+ end type model_ref_variables
+
+ type (model_ref_variables) Mref_V
+! model_ref_variables
+
+! sea1d_model_variables
+ type sea1d_model_variables
+ sequence
+ double precision, dimension(NR_SEA1D) :: radius_sea1d
+ double precision, dimension(NR_SEA1D) :: density_sea1d
+ double precision, dimension(NR_SEA1D) :: vp_sea1d
+ double precision, dimension(NR_SEA1D) :: vs_sea1d
+ double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
+ double precision, dimension(NR_SEA1D) :: Qmu_sea1d
+ end type sea1d_model_variables
+
+ type (sea1d_model_variables) SEA1DM_V
+! sea1d_model_variables
+
+! three_d_mantle_model_variables
+ type three_d_mantle_model_variables
+ sequence
+ double precision dvs_a(0:NK,0:NS,0:NS)
+ double precision dvs_b(0:NK,0:NS,0:NS)
+ double precision dvp_a(0:NK,0:NS,0:NS)
+ double precision dvp_b(0:NK,0:NS,0:NS)
+ double precision spknt(NK+1)
+ double precision qq0(NK+1,NK+1)
+ double precision qq(3,NK+1,NK+1)
+ end type three_d_mantle_model_variables
+
+ type (three_d_mantle_model_variables) D3MM_V
+! three_d_mantle_model_variables
+
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+! sea99_s_model_variables
+ type sea99_s_model_variables
+ sequence
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ end type sea99_s_model_variables
+
+ type (sea99_s_model_variables) SEA99M_V
+! sea99_s_model_variables
+
+! crustal_model_variables
+ type crustal_model_variables
+ sequence
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
+ character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+ character(len=2) code(NKEYS_CRUST)
+ end type crustal_model_variables
+
+ type (crustal_model_variables) CM_V
+! crustal_model_variables
+
+! correct number of spectral elements in each block depending on chunk type
+ integer ispec,nspec,nspec_stacey
+
+ integer REFERENCE_1D_MODEL,THREE_D_MODEL
+
+ logical ELLIPTICITY,TOPOGRAPHY
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST
+
+ logical ATTENUATION,ATTENUATION_3D,ABSORBING_CONDITIONS,ACTUALLY_STORE_ARRAYS
+
+ double precision RICB,RCMB,R670,RMOHO, &
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+! arrays with the mesh in double precision
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! code for the four regions of the mesh
+ integer iregion_code
+
+! 3D shape functions and their derivatives
+ double precision, dimension(NGNOD,NGLLX,NGLLY,NGLLZ) :: shape3D
+ double precision, dimension(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ) :: dershape3D
+
+! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+ double precision, dimension(NGNOD) :: xelm,yelm,zelm
+
+! parameters needed to store the radii of the grid points
+! in the spherically symmetric Earth
+ integer idoubling(nspec)
+ double precision rmin,rmax
+
+! for model density and anisotropy
+ integer nspec_ani
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rhostore,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
+
+! arrays with mesh parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+
+! proc numbers for MPI
+ integer myrank
+
+! Stacey, indices for Clayton-Engquist absorbing conditions
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_stacey) :: rho_vp,rho_vs
+
+! attenuation
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: Qmu_store
+ double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,nspec) :: tau_e_store
+
+ integer, parameter :: maxker=200
+ integer, parameter :: maxl=72
+ integer, parameter :: maxcoe=2000
+ integer, parameter :: maxver=1000
+ integer, parameter :: maxhpa=2
+
+ integer numker
+ integer numhpa,numcof
+ integer ihpa,lmax,nylm
+ integer lmxhpa(maxhpa)
+ integer itypehpa(maxhpa)
+ integer ihpakern(maxker)
+ integer numcoe(maxhpa)
+ integer ivarkern(maxker)
+
+ integer nconpt(maxhpa),iver
+ integer iconpt(maxver,maxhpa)
+ real(kind=4) conpt(maxver,maxhpa)
+
+ real(kind=4) xlaspl(maxcoe,maxhpa)
+ real(kind=4) xlospl(maxcoe,maxhpa)
+ real(kind=4) radspl(maxcoe,maxhpa)
+ real(kind=4) coe(maxcoe,maxker)
+ real(kind=4) vercof(maxker)
+ real(kind=4) vercofd(maxker)
+
+ real(kind=4) ylmcof((maxl+1)**2,maxhpa)
+ real(kind=4) wk1(maxl+1)
+ real(kind=4) wk2(maxl+1)
+ real(kind=4) wk3(maxl+1)
+
+ character(len=80) kerstr
+ character(len=40) varstr(maxker)
+
+! **************
+! add topography on the Moho *before* adding the 3D crustal model so that the streched
+! mesh gets assigned the right model values
+ if(THREE_D_MODEL/=0 .and. (idoubling(ispec)==IFLAG_CRUST .or. idoubling(ispec)==IFLAG_220_80 &
+ .or. idoubling(ispec)==IFLAG_80_MOHO)) call moho_stretching(myrank,xelm,yelm,zelm,RMOHO,R220)
+
+! compute values for the Earth model
+ call get_model(myrank,iregion_code,nspec, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,rhostore,nspec_ani, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ xelm,yelm,zelm,shape3D,ispec, &
+ rmin,rmax,idoubling(ispec),rho_vp,rho_vs,nspec_stacey, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ ATTENUATION, ATTENUATION_3D, tau_e_store, Qmu_store, &
+ size(tau_e_store,2), size(tau_e_store,3), size(tau_e_store,4), size(tau_e_store,5), &
+ ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ RCMB,RICB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN,&
+ AMM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+
+! add topography without the crustal model
+ if(TOPOGRAPHY .and. (idoubling(ispec)==IFLAG_CRUST .or. idoubling(ispec)==IFLAG_220_80 &
+ .or. idoubling(ispec)==IFLAG_80_MOHO)) call add_topography(myrank,xelm,yelm,zelm,ibathy_topo,R220)
+
+! add topography on 410 km and 650 km discontinuity in model S362ANI
+ if(THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI &
+ .or. THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM .or. THREE_D_MODEL == THREE_D_MODEL_S29EA) &
+ call add_topography_410_650(myrank,xelm,yelm,zelm,R220,R400,R670,R771, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,ylmcof,wk1,wk2,wk3,varstr)
+
+! CMB topography
+! 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) call get_ellipticity(xelm,yelm,zelm,nspl,rspl,espl,espl2)
+
+! recompute coordinates and jacobian for real 3-D model
+ call calc_jacobian(myrank,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ xstore,ystore,zstore,xelm,yelm,zelm,shape3D,dershape3D,ispec,nspec,ACTUALLY_STORE_ARRAYS)
+
+ end subroutine compute_element_properties
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/constants.h
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/constants.h (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/constants.h 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,498 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! constants.h. Generated from constants.h.in by configure.
+
+!
+!--- user can modify parameters below
+!
+
+!
+! solver in single or double precision depending on the machine (4 or 8 bytes)
+!
+! ALSO CHANGE FILE precision.h ACCORDINGLY
+!
+ integer, parameter :: SIZE_REAL = 4, SIZE_DOUBLE = 8
+
+! usually the size of integer and logical variables is the same as regular single-precision real variable
+ integer, parameter :: SIZE_INTEGER = SIZE_REAL
+ integer, parameter :: SIZE_LOGICAL = SIZE_REAL
+
+! set to SIZE_REAL to run in single precision
+! set to SIZE_DOUBLE to run in double precision (increases memory size by 2)
+ integer, parameter :: CUSTOM_REAL = SIZE_REAL
+
+! 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 = .true.
+! logical, parameter :: LOCAL_PATH_IS_ALSO_GLOBAL = .false.
+
+! input, output and main MPI I/O files
+ integer, parameter :: ISTANDARD_OUTPUT = 6
+ integer, parameter :: IIN = 40,IOUT = 41,IOUT_SAC = 903
+! local file unit for output of buffers
+ integer, parameter :: IOUT_BUFFERS = 35
+! uncomment this to write messages to a text file
+! integer, parameter :: IMAIN = 42
+! uncomment this to write messages to the screen (slows down the code)
+ integer, parameter :: IMAIN = ISTANDARD_OUTPUT
+! 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'
+
+! maximum depth of the oceans in trenches and height of topo in mountains
+! to avoid taking into account spurious oscillations in global model ETOPO
+ logical, parameter :: USE_MAXIMUM_HEIGHT_TOPO = .false.
+ integer, parameter :: MAXIMUM_HEIGHT_TOPO = +20000
+ logical, parameter :: USE_MAXIMUM_DEPTH_OCEANS = .false.
+ integer, parameter :: MAXIMUM_DEPTH_OCEANS = -20000
+
+! minimum thickness in meters to include the effect of the oceans and topo
+ double precision, parameter :: MINIMUM_THICKNESS_3D_OCEANS = 100.d0
+
+! number of GLL points in each direction of an element (degree plus one)
+ integer, parameter :: NGLLX = 5
+ integer, parameter :: NGLLY = NGLLX
+ integer, parameter :: NGLLZ = NGLLX
+
+! flag to exclude elements that are too far from target in source detection
+ logical, parameter :: USE_DISTANCE_CRITERION = .true.
+
+! flag to display detailed information about location of stations
+ logical, parameter :: DISPLAY_DETAILS_STATIONS = .false.
+
+! maximum length of station and network name for receivers
+ integer, parameter :: MAX_LENGTH_STATION_NAME = 32
+ integer, parameter :: MAX_LENGTH_NETWORK_NAME = 8
+
+! we mimic a triangle of half duration equal to half_duration_triangle
+! using a Gaussian having a very close shape, as explained in Figure 4.2
+! of the manual. This source decay rate to mimic an equivalent triangle
+! was found by trial and error
+ double precision, parameter :: SOURCE_DECAY_MIMIC_TRIANGLE = 1.628d0
+
+! maximum number of sources to locate simultaneously
+ integer, parameter :: NSOURCES_SUBSET_MAX = 1000
+
+! distance threshold (in km) above which we consider that a receiver
+! is located outside the mesh and therefore excluded from the station list
+ double precision, parameter :: THRESHOLD_EXCLUDE_STATION = 50.d0
+
+! the first doubling is implemented right below the Moho
+! it seems optimal to implement the three other doublings at these depths
+! in the mantle
+ double precision, parameter :: DEPTH_SECOND_DOUBLING_OPTIMAL = 1650000.d0
+! in the outer core
+ double precision, parameter :: DEPTH_THIRD_DOUBLING_OPTIMAL = 3860000.d0
+! in the outer core
+ double precision, parameter :: DEPTH_FOURTH_DOUBLING_OPTIMAL = 5000000.d0
+
+! Boundary Mesh -- save Moho, 400, 670 km discontinuity topology files (in
+! the mesher) and use them for the computation of boundary kernel (in the solver)
+ logical, parameter :: SAVE_BOUNDARY_MESH = .false.
+
+! this parameter must be set to .true. to compute anisotropic kernels
+! in crust and mantle (related to the 21 Cij in geographical coordinates)
+! default is .false. to compute isotropic kernels (related to alpha and beta)
+ logical, parameter :: ANISOTROPIC_KL = .false.
+
+! print date and time estimate of end of run in another country,
+! in addition to local time.
+! For instance: the code runs at Caltech in California but the person
+! running the code is connected remotely from France, which has 9 hours more.
+! The time difference with that remote location can be positive or negative
+ logical, parameter :: ADD_TIME_ESTIMATE_ELSEWHERE = .false.
+ integer, parameter :: HOURS_TIME_DIFFERENCE = +9
+ integer, parameter :: MINUTES_TIME_DIFFERENCE = +0
+
+!
+!--- debugging flags
+!
+
+! flags to actually assemble with MPI or not
+! and to actually match fluid and solid regions of the Earth or not
+! should always be set to true except when debugging code
+ logical, parameter :: ACTUALLY_ASSEMBLE_MPI_SLICES = .true.
+ logical, parameter :: ACTUALLY_ASSEMBLE_MPI_CHUNKS = .true.
+ logical, parameter :: ACTUALLY_COUPLE_FLUID_CMB = .true.
+ logical, parameter :: ACTUALLY_COUPLE_FLUID_ICB = .true.
+
+!------------------------------------------------------
+!----------- do not modify anything below -------------
+!------------------------------------------------------
+
+! on some processors (e.g. Pentiums) it is necessary to suppress underflows
+! by using a small initial field instead of zero
+ logical, parameter :: FIX_UNDERFLOW_PROBLEM = .true.
+
+! some useful constants
+ double precision, parameter :: PI = 3.141592653589793d0
+ double precision, parameter :: TWO_PI = 2.d0 * PI
+ double precision, parameter :: PI_OVER_FOUR = PI / 4.d0
+
+! to convert angles from degrees to radians
+ double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0
+
+! 3-D simulation
+ integer, parameter :: NDIM = 3
+
+! dimension of the boundaries of the slices
+ integer, parameter :: NDIM2D = 2
+
+! number of nodes for 2D and 3D shape functions for hexahedra with 27 nodes
+ integer, parameter :: NGNOD = 27, NGNOD2D = 9
+
+! gravitational constant
+ double precision, parameter :: GRAV = 6.6723d-11
+
+! a few useful constants
+ double precision, parameter :: ZERO = 0.d0,ONE = 1.d0,TWO = 2.d0,HALF = 0.5d0
+
+ real(kind=CUSTOM_REAL), parameter :: &
+ ONE_THIRD = 1._CUSTOM_REAL/3._CUSTOM_REAL, &
+ TWO_THIRDS = 2._CUSTOM_REAL/3._CUSTOM_REAL, &
+ FOUR_THIRDS = 4._CUSTOM_REAL/3._CUSTOM_REAL
+
+! very large and very small values
+ double precision, parameter :: HUGEVAL = 1.d+30,TINYVAL = 1.d-9
+
+! very large real value declared independently of the machine
+ real(kind=CUSTOM_REAL), parameter :: HUGEVAL_SNGL = 1.e+30_CUSTOM_REAL
+
+! very large integer value
+ integer, parameter :: HUGEINT = 100000000
+
+! normalized radius of free surface
+ double precision, parameter :: R_UNIT_SPHERE = ONE
+
+! same radius in km
+ double precision, parameter :: R_EARTH_KM = R_EARTH / 1000.d0
+
+! fixed thickness of 3 km for PREM oceans
+ double precision, parameter :: THICKNESS_OCEANS_PREM = 3000.d0 / R_EARTH
+
+! shortest radius at which crust is implemented (80 km depth)
+! to be constistent with the D80 discontinuity, we impose the crust only above it
+ double precision, parameter :: R_DEEPEST_CRUST = (R_EARTH - 80000.d0) / R_EARTH
+
+! maximum number of chunks (full sphere)
+ integer, parameter :: NCHUNKS_MAX = 6
+
+! define block type based upon chunk number (between 1 and 6)
+! do not change this numbering, chunk AB must be number 1 for central cube
+ integer, parameter :: CHUNK_AB = 1
+ integer, parameter :: CHUNK_AC = 2
+ integer, parameter :: CHUNK_BC = 3
+ integer, parameter :: CHUNK_AC_ANTIPODE = 4
+ integer, parameter :: CHUNK_BC_ANTIPODE = 5
+ integer, parameter :: CHUNK_AB_ANTIPODE = 6
+
+! maximum number of regions in the mesh
+ integer, parameter :: MAX_NUM_REGIONS = 3
+
+! define flag for regions of the global Earth mesh
+ integer, parameter :: IREGION_CRUST_MANTLE = 1
+ integer, parameter :: IREGION_OUTER_CORE = 2
+ integer, parameter :: IREGION_INNER_CORE = 3
+
+! define flag for elements
+ integer, parameter :: IFLAG_CRUST = 1
+
+ integer, parameter :: IFLAG_80_MOHO = 2
+ integer, parameter :: IFLAG_220_80 = 3
+ integer, parameter :: IFLAG_670_220 = 4
+ integer, parameter :: IFLAG_MANTLE_NORMAL = 5
+
+ integer, parameter :: IFLAG_OUTER_CORE_NORMAL = 6
+
+ integer, parameter :: IFLAG_INNER_CORE_NORMAL = 7
+ integer, parameter :: IFLAG_MIDDLE_CENTRAL_CUBE = 8
+ integer, parameter :: IFLAG_BOTTOM_CENTRAL_CUBE = 9
+ integer, parameter :: IFLAG_TOP_CENTRAL_CUBE = 10
+ integer, parameter :: IFLAG_IN_FICTITIOUS_CUBE = 11
+
+ integer, parameter :: NSPEC2D_XI_SUPERBRICK = 8
+ integer, parameter :: NSPEC2D_ETA_SUPERBRICK = 8
+ integer, parameter :: NSPEC2D_XI_SUPERBRICK_1L = 6
+ integer, parameter :: NSPEC2D_ETA_SUPERBRICK_1L = 6
+
+! dummy flag used for mesh display purposes only
+ integer, parameter :: IFLAG_DUMMY = 100
+
+! max number of layers that are used in the radial direction to build the full mesh
+ integer, parameter :: MAX_NUMBER_OF_MESH_LAYERS = 15
+
+! define number of spectral elements and points in basic symmetric mesh doubling superbrick
+ integer, parameter :: NSPEC_DOUBLING_SUPERBRICK = 32
+ integer, parameter :: NGLOB_DOUBLING_SUPERBRICK = 67
+ integer, parameter :: NSPEC_SUPERBRICK_1L = 28
+ integer, parameter :: NGLOB_SUPERBRICK_1L = 58
+ integer, parameter :: NGNOD_EIGHT_CORNERS = 8
+
+! define flag for reference 1D Earth model
+ integer, parameter :: REFERENCE_MODEL_PREM = 1
+ integer, parameter :: REFERENCE_MODEL_IASP91 = 2
+ integer, parameter :: REFERENCE_MODEL_1066A = 3
+ integer, parameter :: REFERENCE_MODEL_AK135 = 4
+ integer, parameter :: REFERENCE_MODEL_REF = 5
+ integer, parameter :: REFERENCE_MODEL_JP1D = 6
+ integer, parameter :: REFERENCE_MODEL_SEA1D = 7
+
+! define flag for 3D Earth model
+ integer, parameter :: THREE_D_MODEL_S20RTS = 1
+ integer, parameter :: THREE_D_MODEL_S362ANI = 2
+ integer, parameter :: THREE_D_MODEL_S362WMANI = 3
+ integer, parameter :: THREE_D_MODEL_S362ANI_PREM = 4
+ integer, parameter :: THREE_D_MODEL_S29EA = 5
+ integer, parameter :: THREE_D_MODEL_SEA99_JP3D = 6
+ integer, parameter :: THREE_D_MODEL_SEA99 = 7
+ integer, parameter :: THREE_D_MODEL_JP3D = 8
+
+! define flag for regions of the global Earth for attenuation
+ integer, parameter :: NUM_REGIONS_ATTENUATION = 5
+
+ integer, parameter :: IREGION_ATTENUATION_INNER_CORE = 1
+ integer, parameter :: IREGION_ATTENUATION_CMB_670 = 2
+ integer, parameter :: IREGION_ATTENUATION_670_220 = 3
+ integer, parameter :: IREGION_ATTENUATION_220_80 = 4
+ integer, parameter :: IREGION_ATTENUATION_80_SURFACE = 5
+ integer, parameter :: IREGION_ATTENUATION_UNDEFINED = 6
+
+! number of standard linear solids for attenuation
+ integer, parameter :: N_SLS = 3
+
+! computation of standard linear solids in meshfem3D
+! ATTENUATION_COMP_RESOLUTION: Number of Digits after decimal
+! ATTENUATION_COMP_MAXIMUM: Maximum Q Value
+ integer, parameter :: ATTENUATION_COMP_RESOLUTION = 1
+ integer, parameter :: ATTENUATION_COMP_MAXIMUM = 5000
+
+! for lookup table for attenuation every 100 m in radial direction of Earth model
+ integer, parameter :: NRAD_ATTENUATION = 70000
+ double precision, parameter :: TABLE_ATTENUATION = R_EARTH_KM * 10.0d0
+
+! for determination of the attenuation period range
+! if this is set to .true. then the hardcoded values will be used
+! otherwise they are computed automatically from the Number of elements
+! This *may* be a useful parameter for Benchmarking against older versions
+ logical, parameter :: ATTENUATION_RANGE_PREDEFINED = .false.
+
+! flag for the four edges of each slice and for the bottom edge
+ integer, parameter :: XI_MIN = 1
+ integer, parameter :: XI_MAX = 2
+ integer, parameter :: ETA_MIN = 3
+ integer, parameter :: ETA_MAX = 4
+ integer, parameter :: BOTTOM = 5
+
+! flags to select the right corner in each slice
+ integer, parameter :: ILOWERLOWER = 1
+ integer, parameter :: ILOWERUPPER = 2
+ integer, parameter :: IUPPERLOWER = 3
+ integer, parameter :: IUPPERUPPER = 4
+
+! number of points in each AVS or OpenDX quadrangular cell for movies
+ integer, parameter :: NGNOD2D_AVS_DX = 4
+
+! number of faces a given slice can share with other slices
+! this is at most 2, except when there is only once slice per chunk
+! in which case it is 4
+ integer, parameter :: NUMFACES_SHARED = 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 = 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 = 144
+
+! number of layers in DATA/s362ani/REF
+ integer, parameter :: NR_REF = 750
+
+! number of layers in DATA/Lebedev_sea99 1D model
+ integer, parameter :: NR_SEA1D = 163
+
+! three_d_mantle_model_constants
+ integer, parameter :: NK = 20,NS = 20,ND = 1
+
+! Japan 3D model (Zhao, 1994) constants
+ integer, parameter :: MPA=42,MRA=48,MHA=21,MPB=42,MRB=48,MHB=18
+ integer, parameter :: MKA=2101,MKB=2101
+
+! The meaningful range of Zhao et al.'s model (1994) is as follows:
+! latitude : 32 - 45 N
+! longitude: 130-145 E
+! depth : 0 - 500 km
+! The deepest Moho beneath Japan is 40 km
+ double precision,parameter :: LAT_MAX = 45.d0
+ double precision,parameter :: LAT_MIN = 32.d0
+ double precision,parameter :: LON_MAX = 145.d0
+ double precision,parameter :: LON_MIN = 130.d0
+ double precision,parameter :: DEP_MAX = 500.d0
+
+! crustal_model_constants
+ ! crustal model parameters for crust2.0
+ integer, parameter :: NKEYS_CRUST = 359
+ integer, parameter :: NLAYERS_CRUST = 8
+ integer, parameter :: NCAP_CRUST = 180
+ ! use sedimentary layers of crust 2.0
+ logical, parameter :: INCLUDE_SEDIMENTS_CRUST = .true.
+!!!!!!!!!!!!!! end of parameters added for the thread-safe version of the code
+
+! to inflate the central cube (set to 0.d0 for a non-inflated cube)
+ double precision, parameter :: CENTRAL_CUBE_INFLATE_FACTOR = 0.41d0
+
+! for the stretching of crustal elements in the case of 3D models
+ double precision, parameter :: MAX_RATIO_CRUST_STRETCHING = 0.6d0
+
+! to suppress the crustal layers (replaced by an extension of the mantle: R_EARTH is not modified, but no more crustal doubling)
+ logical, parameter :: SUPPRESS_CRUSTAL_MESH = .false.
+
+! to add a fourth doubling at the bottom of the outer core
+ logical, parameter :: ADD_4TH_DOUBLING = .false.
+
+! parameters to cut the doubling brick
+
+! this to cut the superbrick: 3 possibilities, 4 cases max / possibility
+! three possibilities: (cut in xi and eta) or (cut in xi) or (cut in eta)
+! case 1: (ximin and etamin) or ximin or etamin
+! case 2: (ximin and etamax) or ximax or etamax
+! case 3: ximax and etamin
+! case 4: ximax and etamax
+ integer, parameter :: NB_CUT_CASE = 4
+
+! corner 1: ximin and etamin
+! corner 2: ximax and etamin
+! corner 3: ximax and etamax
+! corner 4: ximin and etamax
+ integer, parameter :: NB_SQUARE_CORNERS = 4
+
+! two possibilities: xi or eta
+! face 1: ximin or etamin
+! face 2: ximax or etamax
+ integer, parameter :: NB_SQUARE_EDGES_ONEDIR = 2
+
+! this for the geometry of the basic doubling brick
+ integer, parameter :: NSPEC_DOUBLING_BASICBRICK = 8
+ integer, parameter :: NGLOB_DOUBLING_BASICBRICK = 27
+
+! for mesh coloring and separation of inner and outer elements for the CUDA + MPI implementation
+! set USE_REGULAR_C_CPU_VERSION = .false. when running the mesher for the multiGPU code
+! and set USE_REGULAR_C_CPU_VERSION = .true. when running the mesher for the multiCPU code
+ logical, parameter :: USE_MESH_COLORING_INNER_OUTER = .false.
+!!!! DK DK not used any more
+!!!! logical, parameter :: USE_REGULAR_C_CPU_VERSION = .false. !! use inner_outer but not mesh colors if regular C version for a CPU
+ integer, parameter :: MAX_NUMBER_OF_COLORS = 10000
+ integer, parameter :: NGNOD_HEXAHEDRA = 8
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/count_number_of_sources.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/count_number_of_sources.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/count_number_of_sources.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,62 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine count_number_of_sources(NSOURCES)
+
+! count the total number of sources in the CMTSOLUTION file
+! there are NLINES_PER_CMTSOLUTION_SOURCE lines per source in that file
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(out) :: NSOURCES
+
+ integer ios,icounter
+
+ character(len=150) CMTSOLUTION,dummystring
+
+ call get_value_string(CMTSOLUTION, 'solver.CMTSOLUTION', 'DATA/CMTSOLUTION')
+
+ open(unit=1,file=CMTSOLUTION,iostat=ios,status='old',action='read')
+ if(ios /= 0) stop 'error opening CMTSOLUTION file'
+ icounter = 0
+ do while(ios == 0)
+ read(1,"(a)",iostat=ios) dummystring
+ if(ios == 0) icounter = icounter + 1
+ enddo
+ close(1)
+
+ if(mod(icounter,NLINES_PER_CMTSOLUTION_SOURCE) /= 0) &
+ stop 'total number of lines in CMTSOLUTION file should be a multiple of NLINES_PER_CMTSOLUTION_SOURCE'
+
+ NSOURCES = icounter / NLINES_PER_CMTSOLUTION_SOURCE
+
+ if(NSOURCES < 1) stop 'need at least one source in CMTSOLUTION file'
+
+ end subroutine count_number_of_sources
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/create_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/create_header_file.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/create_header_file.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,234 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! create file OUTPUT_FILES/values_from_mesher.h based upon DATA/Par_file
+! in order to compile the solver with the right array sizes
+
+ program xcreate_header_file
+
+ implicit none
+
+ include "constants.h"
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION,CASE_3D, &
+ ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
+
+ character(len=150) LOCAL_PATH,MODEL
+
+! parameters deduced from parameters read from file
+ integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+! this for all the regions
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ nglob
+
+ double precision :: static_memory_size
+ character(len=150) HEADER_FILE
+
+ integer :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION
+
+ integer :: iregion
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_CORNER
+ integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL_TEMP
+
+! ************** PROGRAM STARTS HERE **************
+
+ call get_value_string(HEADER_FILE, 'solver.HEADER_FILE', 'OUTPUT_FILES/values_from_mesher.h')
+ print *
+ print *,'creating file ', trim(HEADER_FILE), ' to compile solver with correct values'
+
+! read the parameter file and compute additional parameters
+ call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.)
+
+
+! count the total number of sources in the CMTSOLUTION file
+ call count_number_of_sources(NSOURCES)
+
+ do iregion=1,MAX_NUM_REGIONS
+ NGLOB1D_RADIAL_CORNER(iregion,:) = NGLOB1D_RADIAL(iregion)
+ enddo
+
+ if (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA) then
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + &
+ maxval(DIFF_NSPEC1D_RADIAL(:,:))*(NGLLZ-1)
+ endif
+
+! evaluate the amount of static memory needed by the solver
+ call memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MANTLE,&
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_INNER_CORE,ROTATION,&
+ ONE_CRUST,doubling_index,this_region_has_a_doubling,&
+ ner,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_sampling_array,&
+ NSPEC,nglob,SIMULATION_TYPE,MOVIE_VOLUME,SAVE_FORWARD, &
+ NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION,static_memory_size)
+
+ NGLOB1D_RADIAL_TEMP(:) = &
+ (/maxval(NGLOB1D_RADIAL_CORNER(1,:)),maxval(NGLOB1D_RADIAL_CORNER(2,:)),maxval(NGLOB1D_RADIAL_CORNER(3,:))/)
+
+! create include file for the solver
+ call save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ ELLIPTICITY,GRAVITY,ROTATION,ATTENUATION,ATTENUATION_3D, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,NCHUNKS, &
+ INCLUDE_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,NSOURCES,NSTEP,&
+ static_memory_size,&
+ NGLOB1D_RADIAL_TEMP,&
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NSPEC2D_TOP,NSPEC2D_BOTTOM, &
+ NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX, &
+ NPROC_XI,NPROC_ETA, &
+ NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION)
+
+ print *
+ print *,'edit file OUTPUT_FILES/values_from_mesher.h to see some statistics about the mesh'
+ print *
+
+ print *,'number of processors = ',NPROCTOT
+ print *
+ print *,'total elements per slice = ',NSPEC(IREGION_CRUST_MANTLE)
+ print *,'total points per slice = ',NGLOB(IREGION_CRUST_MANTLE)
+ print *
+ print *,'number of time steps = ',NSTEP
+ print *
+
+ print *,'approximate static memory needed by the solver:'
+ print *,'----------------------------------------------'
+ print *
+ print *,'size of static arrays per slice in MB = ',static_memory_size/1048576.d0,' (max size at CCRT/GPU in Paris is 4000 MB)'
+ print *,'size of static arrays per slice in GB = ',static_memory_size/1073741824.d0,' (max size at CCRT/GPU in Paris is 4 GB)'
+ print *,'i.e. ',sngl(100.d0*static_memory_size/1073741824.d0/4.d0),'% of the 4GB at CCRT/GPU in Paris'
+ print *
+! print *,' (should be below and typically equal to 80% of 1.5 GB = 1.2 GB on pangu'
+! print *,' at Caltech, and below and typically equal to 85% of 2 GB = 1.7 GB'
+! print *,' in Barcelona)'
+! print *,' (if significantly more, the job will not run by lack of memory)'
+! print *,' (if significantly less, you waste a significant amount of memory)'
+ print *
+ print *,'size of static arrays for all slices = ',static_memory_size*dble(NPROCTOT)/1073741824.d0,' GB'
+ print *,' = ',static_memory_size*dble(NPROCTOT)/1099511627776.d0,' TB'
+ print *
+
+ end program xcreate_header_file
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/create_name_database.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/create_name_database.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/create_name_database.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,46 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine create_name_database(prname,iproc,iregion_code,LOCAL_PATH)
+
+! create the name of the database for the mesher and the solver
+
+ implicit none
+
+ integer iproc,iregion_code
+
+! name of the database file
+ character(len=150) prname,procname,LOCAL_PATH
+
+! create the name for the database of the current slide and region
+ write(procname,"('/proc',i6.6,'_reg',i1,'_')") iproc,iregion_code
+
+! create full name with path
+ prname = trim(LOCAL_PATH) // procname
+
+ end subroutine create_name_database
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/create_regions_mesh.F90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/create_regions_mesh.F90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/create_regions_mesh.F90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,1907 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine create_regions_mesh(iregion_code,ibool,idoubling, &
+ xstore,ystore,zstore,rmins,rmaxs, &
+ iproc_xi,iproc_eta,ichunk,nspec,nspec_tiso, &
+ volume_local,nspl,rspl,espl,espl2, &
+ nglob_theor,npointot, &
+ NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE, &
+!!!! NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,NGLOB2DMAX_XY, &
+ NSPEC2D_ETA_FACE,NGLOB2DMAX_XY, &
+ myrank,LOCAL_PATH,OCEANS,ibathy_topo, &
+ rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,&
+ ATTENUATION,ATTENUATION_3D,SAVE_MESH_FILES, &
+ NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ ner,ratio_sampling_array,doubling_index,r_bottom,r_top,this_region_has_a_doubling,CASE_3D, &
+ AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ipass,ratio_divide_central_cube, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,offset_proc_xi,offset_proc_eta, &
+ NSTEP,DT,NPROCTOT,is_on_a_slice_edge)
+
+! create the different regions of the mesh
+
+ implicit none
+
+ include "constants.h"
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+ integer :: NSTEP
+ integer, save :: npoin2D_xi,npoin2D_eta
+ double precision :: DT
+
+! this to cut the doubling brick
+!!!! integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer :: step_mult,offset_proc_xi,offset_proc_eta
+ integer :: case_xi,case_eta,subblock_num
+
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+
+ integer :: ignod,ner_without_doubling,ispec_superbrick,ilayer,ilayer_loop,ix_elem,iy_elem,iz_elem, &
+ ifirst_region,ilast_region,ratio_divide_central_cube
+ integer, dimension(:), allocatable :: perm_layer
+
+! mesh doubling superbrick
+ integer, dimension(NGNOD_EIGHT_CORNERS,NSPEC_DOUBLING_SUPERBRICK) :: ibool_superbrick
+
+ double precision, dimension(NGLOB_DOUBLING_SUPERBRICK) :: x_superbrick,y_superbrick,z_superbrick
+
+! aniso_mantle_model_variables
+ type aniso_mantle_model_variables
+ sequence
+ double precision beta(14,34,37,73)
+ double precision pro(47)
+ integer npar1
+ end type aniso_mantle_model_variables
+
+ type (aniso_mantle_model_variables) AMM_V
+! aniso_mantle_model_variables
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+! model_1066a_variables
+ type model_1066a_variables
+ sequence
+ double precision, dimension(NR_1066A) :: radius_1066a
+ double precision, dimension(NR_1066A) :: density_1066a
+ double precision, dimension(NR_1066A) :: vp_1066a
+ double precision, dimension(NR_1066A) :: vs_1066a
+ double precision, dimension(NR_1066A) :: Qkappa_1066a
+ double precision, dimension(NR_1066A) :: Qmu_1066a
+ end type model_1066a_variables
+
+ type (model_1066a_variables) M1066a_V
+! model_1066a_variables
+
+! model_ak135_variables
+ type model_ak135_variables
+ sequence
+ double precision, dimension(NR_AK135) :: radius_ak135
+ double precision, dimension(NR_AK135) :: density_ak135
+ double precision, dimension(NR_AK135) :: vp_ak135
+ double precision, dimension(NR_AK135) :: vs_ak135
+ double precision, dimension(NR_AK135) :: Qkappa_ak135
+ double precision, dimension(NR_AK135) :: Qmu_ak135
+ end type model_ak135_variables
+
+ type (model_ak135_variables) Mak135_V
+! model_ak135_variables
+
+! model_ref_variables
+ type model_ref_variables
+ sequence
+ double precision, dimension(NR_REF) :: radius_ref
+ double precision, dimension(NR_REF) :: density_ref
+ double precision, dimension(NR_REF) :: vpv_ref
+ double precision, dimension(NR_REF) :: vph_ref
+ double precision, dimension(NR_REF) :: vsv_ref
+ double precision, dimension(NR_REF) :: vsh_ref
+ double precision, dimension(NR_REF) :: eta_ref
+ double precision, dimension(NR_REF) :: Qkappa_ref
+ double precision, dimension(NR_REF) :: Qmu_ref
+ end type model_ref_variables
+
+ type (model_ref_variables) Mref_V
+! model_ref_variables
+
+! sea1d_model_variables
+ type sea1d_model_variables
+ sequence
+ double precision, dimension(NR_SEA1D) :: radius_sea1d
+ double precision, dimension(NR_SEA1D) :: density_sea1d
+ double precision, dimension(NR_SEA1D) :: vp_sea1d
+ double precision, dimension(NR_SEA1D) :: vs_sea1d
+ double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
+ double precision, dimension(NR_SEA1D) :: Qmu_sea1d
+ end type sea1d_model_variables
+
+ type (sea1d_model_variables) SEA1DM_V
+! sea1d_model_variables
+
+! three_d_mantle_model_variables
+ type three_d_mantle_model_variables
+ sequence
+ double precision dvs_a(0:NK,0:NS,0:NS)
+ double precision dvs_b(0:NK,0:NS,0:NS)
+ double precision dvp_a(0:NK,0:NS,0:NS)
+ double precision dvp_b(0:NK,0:NS,0:NS)
+ double precision spknt(NK+1)
+ double precision qq0(NK+1,NK+1)
+ double precision qq(3,NK+1,NK+1)
+ end type three_d_mantle_model_variables
+
+ type (three_d_mantle_model_variables) D3MM_V
+! three_d_mantle_model_variables
+
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+! sea99_s_model_variables
+ type sea99_s_model_variables
+ sequence
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ end type sea99_s_model_variables
+
+ type (sea99_s_model_variables) SEA99M_V
+! sea99_s_model_variables
+
+! crustal_model_variables
+ type crustal_model_variables
+ sequence
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
+ character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+ character(len=2) code(NKEYS_CRUST)
+ end type crustal_model_variables
+
+ type (crustal_model_variables) CM_V
+! crustal_model_variables
+
+! correct number of spectral elements in each block depending on chunk type
+ integer nspec,nspec_tiso,nspec_stacey
+
+ integer NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NCHUNKS,REFERENCE_1D_MODEL,THREE_D_MODEL
+
+ integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP
+
+ integer NPROC_XI,NPROC_ETA,NPROCTOT
+
+ integer npointot
+
+ logical ELLIPTICITY,TOPOGRAPHY,SAVE_MESH_FILES
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST,OCEANS
+
+ logical ATTENUATION,ATTENUATION_3D,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS
+
+ double precision R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO, &
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
+
+ character(len=150) LOCAL_PATH,errmsg
+
+! use integer array to store values
+ integer ibathy_topo(NX_BATHY,NY_BATHY)
+
+! arrays with the mesh in double precision
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! meshing parameters
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+! to define the central cube in the inner core
+ integer nx_central_cube,ny_central_cube,nz_central_cube
+ double precision radius_cube
+ double precision :: xgrid_central_cube,ygrid_central_cube,zgrid_central_cube
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+! auxiliary variables to generate the mesh
+ integer ix,iy,iz
+
+! topology of the elements
+ integer, dimension(NGNOD) :: iaddx,iaddy,iaddz
+
+! code for the four regions of the mesh
+ integer iregion_code
+
+! Gauss-Lobatto-Legendre points and weights of integration
+ double precision, dimension(:), allocatable :: xigll,yigll,zigll,wxgll,wygll,wzgll
+
+! 3D shape functions and their derivatives
+ double precision, dimension(:,:,:,:), allocatable :: shape3D
+ double precision, dimension(:,:,:,:,:), allocatable :: dershape3D
+
+! 2D shape functions and their derivatives
+ double precision, dimension(:,:,:), allocatable :: shape2D_x,shape2D_y,shape2D_bottom,shape2D_top
+ double precision, dimension(:,:,:,:), allocatable :: dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top
+
+! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+ double precision, dimension(NGNOD) :: xelm,yelm,zelm,offset_x,offset_y,offset_z
+
+ integer idoubling(nspec)
+
+! parameters needed to store the radii of the grid points in the spherically symmetric Earth
+ double precision rmin,rmax
+
+! for model density and anisotropy
+ integer nspec_ani
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rhostore,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
+
+! the jacobian
+ real(kind=CUSTOM_REAL) jacobianl
+
+! 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
+
+ real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl
+
+! proc numbers for MPI
+ integer myrank
+
+! check area and volume of the final mesh
+ double precision weight
+ 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 ix_oceans,iy_oceans,iz_oceans,ispec_oceans
+ integer ispec2D_top_crust
+ integer nglob_oceans
+ double precision xval,yval,zval,rval,thetaval,phival
+ double precision lat,lon,colat
+ double precision elevation,height_oceans
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_ocean_load
+
+! mask to sort ibool
+ integer, dimension(:), allocatable :: mask_ibool
+ logical, dimension(:), allocatable :: mask_ibool2
+ integer, dimension(:,:,:,:), allocatable :: copy_ibool_ori
+ integer :: inumber
+
+! 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
+
+ integer i,j,k,ia,ispec,iglobnum,icolor
+ integer iproc_xi,iproc_eta,ichunk
+
+ double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
+
+! rotation matrix from Euler angles
+ double precision, dimension(NDIM,NDIM) :: rotation_matrix
+
+! attenuation
+ double precision, dimension(:,:,:,:), allocatable :: Qmu_store
+ double precision, dimension(:,:,:,:,:), allocatable :: tau_e_store
+ double precision, dimension(N_SLS) :: tau_s
+ double precision T_c_source
+
+! **************
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ logical, dimension(NSPEC_DOUBLING_SUPERBRICK,6) :: iboun_sb
+ logical :: USE_ONE_LAYER_SB,CASE_3D
+ integer :: nspec_sb
+
+ integer NUMBER_OF_MESH_LAYERS,layer_shift,first_layer_aniso,last_layer_aniso,FIRST_ELT_NON_ANISO
+ double precision, dimension(:,:), allocatable :: stretch_tab
+
+ integer :: NGLOB2DMAX_XY
+
+ integer :: nb_layer_above_aniso,FIRST_ELT_ABOVE_ANISO
+
+ integer, parameter :: maxker=200
+ integer, parameter :: maxl=72
+ integer, parameter :: maxcoe=2000
+ integer, parameter :: maxver=1000
+ integer, parameter :: maxhpa=2
+
+ integer numker
+ integer numhpa,numcof
+ integer ihpa,lmax,nylm
+ integer lmxhpa(maxhpa)
+ integer itypehpa(maxhpa)
+ integer ihpakern(maxker)
+ integer numcoe(maxhpa)
+ integer ivarkern(maxker)
+
+ integer nconpt(maxhpa),iver
+ integer iconpt(maxver,maxhpa)
+ real(kind=4) conpt(maxver,maxhpa)
+
+ real(kind=4) xlaspl(maxcoe,maxhpa)
+ real(kind=4) xlospl(maxcoe,maxhpa)
+ real(kind=4) radspl(maxcoe,maxhpa)
+ real(kind=4) coe(maxcoe,maxker)
+ real(kind=4) vercof(maxker)
+ real(kind=4) vercofd(maxker)
+
+ real(kind=4) ylmcof((maxl+1)**2,maxhpa)
+ real(kind=4) wk1(maxl+1)
+ real(kind=4) wk2(maxl+1)
+ real(kind=4) wk3(maxl+1)
+
+ character(len=80) kerstr
+ character(len=40) varstr(maxker)
+
+! now perform two passes in this part to be able to save memory
+ integer :: ipass
+
+ logical :: ACTUALLY_STORE_ARRAYS
+
+! added for color permutation
+ integer :: nb_colors_outer_elements,nb_colors_inner_elements,nspec_outer
+ integer, dimension(:), allocatable :: perm, first_elem_number_in_this_color,number_of_elements_in_this_color
+ integer, dimension(:,:,:,:), allocatable :: temp_array_int
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: temp_array_real
+ double precision, dimension(:,:,:,:), allocatable :: temp_array_dble
+ integer, dimension(:), allocatable :: temp_array_1D_int
+
+! added for inner elements/outer elements splitting of the mesh for the regular C version for a CPU
+!!!! DK DK integer :: inumber_in_new_list_after_perm,nspec_outer_min_global,nspec_outer_max_global
+ integer :: nspec_outer_min_global,nspec_outer_max_global
+
+! the height at which the central cube is cut
+ integer :: nz_inf_limit
+
+ logical, dimension(nspec) :: is_on_a_slice_edge
+
+! create the name for the database of the current slide and region
+ call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
+
+! Attenuation
+ if(ATTENUATION .and. ATTENUATION_3D) then
+ T_c_source = AM_V%QT_c_source
+ tau_s(:) = AM_V%Qtau_s(:)
+ allocate(Qmu_store(NGLLX,NGLLY,NGLLZ,nspec))
+ allocate(tau_e_store(N_SLS,NGLLX,NGLLY,NGLLZ,nspec))
+ else
+ allocate(Qmu_store(1,1,1,1))
+ allocate(tau_e_store(N_SLS,1,1,1,1))
+ Qmu_store(1,1,1,1) = 0.0d0
+ tau_e_store(:,1,1,1,1) = 0.0d0
+ endif
+
+! Gauss-Lobatto-Legendre points of integration
+ allocate(xigll(NGLLX))
+ 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))
+
+! 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
+ 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))
+
+ nspec_ani = 1
+ if((ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) .or. &
+ (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE)) nspec_ani = nspec
+
+ allocate(c11store(NGLLX,NGLLY,NGLLZ,nspec_ani))
+ 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))
+
+! set up coordinates of the Gauss-Lobatto-Legendre points
+ call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
+
+! if number of points is odd, the middle abscissa is exactly zero
+ if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO
+ if(mod(NGLLY,2) /= 0) yigll((NGLLY-1)/2+1) = ZERO
+ if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO
+
+! get the 3-D shape functions
+ call get_shape3D(myrank,shape3D,dershape3D,xigll,yigll,zigll)
+
+! get the 2-D shape functions
+ call get_shape2D(myrank,shape2D_x,dershape2D_x,yigll,zigll,NGLLY,NGLLZ)
+ call get_shape2D(myrank,shape2D_y,dershape2D_y,xigll,zigll,NGLLX,NGLLZ)
+ call get_shape2D(myrank,shape2D_bottom,dershape2D_bottom,xigll,yigll,NGLLX,NGLLY)
+ call get_shape2D(myrank,shape2D_top,dershape2D_top,xigll,yigll,NGLLX,NGLLY)
+
+! define models 1066a and ak135 and ref
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
+ call define_model_1066a(CRUSTAL, M1066a_V)
+ elseif(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
+ call define_model_ak135(CRUSTAL, Mak135_V)
+ elseif(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
+ call define_model_ref(Mref_V)
+ elseif(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
+ call define_model_sea1d(CRUSTAL, SEA1DM_V)
+ endif
+
+!------------------------------------------------------------------------
+
+! create the shape of the corner nodes of a regular mesh element
+ call hex_nodes(iaddx,iaddy,iaddz)
+
+! reference element has size one here, not two
+ iaddx(:) = iaddx(:) / 2
+ iaddy(:) = iaddy(:) / 2
+ iaddz(:) = iaddz(:) / 2
+
+ if (ONE_CRUST) then
+ NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS - 1
+ layer_shift = 0
+ else
+ NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS
+ layer_shift = 1
+ endif
+
+ if (.not. ADD_4TH_DOUBLING) NUMBER_OF_MESH_LAYERS = NUMBER_OF_MESH_LAYERS - 1
+
+! define the first and last layers that define this region
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+ ifirst_region = 1
+ ilast_region = 10 + layer_shift
+
+ else if(iregion_code == IREGION_OUTER_CORE) then
+ ifirst_region = 11 + layer_shift
+ ilast_region = NUMBER_OF_MESH_LAYERS - 1
+
+ else if(iregion_code == IREGION_INNER_CORE) then
+ ifirst_region = NUMBER_OF_MESH_LAYERS
+ ilast_region = NUMBER_OF_MESH_LAYERS
+
+ else
+ call exit_MPI(myrank,'incorrect region code detected')
+
+ endif
+
+! to consider anisotropic elements first and to build the mesh from the bottom to the top of the region
+ if (ONE_CRUST) then
+ first_layer_aniso=2
+ last_layer_aniso=3
+ nb_layer_above_aniso = 1
+ else
+ first_layer_aniso=3
+ last_layer_aniso=4
+ nb_layer_above_aniso = 2
+ endif
+ allocate (perm_layer(ifirst_region:ilast_region))
+ perm_layer = (/ (i, i=ilast_region,ifirst_region,-1) /)
+! if(iregion_code == IREGION_CRUST_MANTLE) then
+! cpt=3
+! perm_layer(1)=first_layer_aniso
+! perm_layer(2)=last_layer_aniso
+! do i = ilast_region,ifirst_region,-1
+! if (i/=first_layer_aniso .and. i/=last_layer_aniso) then
+! perm_layer(cpt) = i
+! cpt=cpt+1
+! endif
+! enddo
+! endif
+
+! initialize mesh arrays
+ 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.
+
+! 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.
+
+ allocate(xixstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(xiystore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(xizstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(etaxstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(etaystore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(etazstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(gammaxstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(gammaystore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(gammazstore(NGLLX,NGLLY,NGLLZ,1),stat=ier); if(ier /= 0) stop 'error in allocate'
+
+ else
+
+ ACTUALLY_STORE_ARRAYS = .true.
+
+ allocate(xixstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(xiystore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(xizstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(etaxstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(etaystore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(etazstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(gammaxstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(gammaystore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(gammazstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate'
+
+ endif
+
+ if (CASE_3D .and. iregion_code == IREGION_CRUST_MANTLE .and. .not. SUPPRESS_CRUSTAL_MESH) then
+ allocate(stretch_tab(2,ner(1)))
+ call stretching_function(r_top(1),r_bottom(1),ner(1),stretch_tab)
+ endif
+
+! generate and count all the elements in this region of the mesh
+ ispec = 0
+
+! loop on all the layers in this region of the mesh
+ do ilayer_loop = ifirst_region,ilast_region
+
+ ilayer = perm_layer(ilayer_loop)
+
+! determine the radii that define the shell
+ rmin = rmins(ilayer)
+ rmax = rmaxs(ilayer)
+
+ if(iregion_code == IREGION_CRUST_MANTLE .and. ilayer_loop==3) then
+ FIRST_ELT_NON_ANISO = ispec+1
+ endif
+ if(iregion_code == IREGION_CRUST_MANTLE .and. ilayer_loop==(ilast_region-nb_layer_above_aniso+1)) then
+ FIRST_ELT_ABOVE_ANISO = ispec+1
+ endif
+
+ ner_without_doubling = ner(ilayer)
+
+! if there is a doubling at the top of this region, we implement it in the last two layers of elements
+! and therefore we suppress two layers of regular elements here
+ USE_ONE_LAYER_SB = .false.
+ if(this_region_has_a_doubling(ilayer)) then
+ if (ner(ilayer) == 1) then
+ ner_without_doubling = ner_without_doubling - 1
+ USE_ONE_LAYER_SB = .true.
+ else
+ ner_without_doubling = ner_without_doubling - 2
+ USE_ONE_LAYER_SB = .false.
+ endif
+ endif
+
+!----
+!---- regular mesh elements
+!----
+
+! loop on all the elements
+ do ix_elem = 1,NEX_PER_PROC_XI,ratio_sampling_array(ilayer)
+ do iy_elem = 1,NEX_PER_PROC_ETA,ratio_sampling_array(ilayer)
+ do iz_elem = 1,ner_without_doubling
+! loop on all the corner nodes of this element
+ do ignod = 1,NGNOD_EIGHT_CORNERS
+! define topological coordinates of this mesh point
+ offset_x(ignod) = (ix_elem - 1) + iaddx(ignod) * ratio_sampling_array(ilayer)
+ offset_y(ignod) = (iy_elem - 1) + iaddy(ignod) * ratio_sampling_array(ilayer)
+ if (ilayer == 1 .and. CASE_3D) then
+ offset_z(ignod) = iaddz(ignod)
+ else
+ offset_z(ignod) = (iz_elem - 1) + iaddz(ignod)
+ endif
+ enddo
+ call add_missing_nodes(offset_x,offset_y,offset_z)
+
+! compute the actual position of all the grid points of that element
+ if (ilayer == 1 .and. CASE_3D .and. .not. SUPPRESS_CRUSTAL_MESH) then
+! crustal elements are stretched to be thinner in the upper crust than in lower crust in the 3D case
+! max ratio between size of upper crust elements and lower crust elements is given by the param MAX_RATIO_STRETCHING
+! to avoid stretching, set MAX_RATIO_STRETCHING = 1.0d in constants.h
+ call compute_coord_main_mesh(offset_x,offset_y,offset_z,xelm,yelm,zelm, &
+ ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
+ NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ stretch_tab(1,ner_without_doubling-iz_elem+1),&
+ stretch_tab(2,ner_without_doubling-iz_elem+1),1,ilayer,ichunk,rotation_matrix, &
+ NCHUNKS,INCLUDE_CENTRAL_CUBE,NUMBER_OF_MESH_LAYERS)
+ else
+ call compute_coord_main_mesh(offset_x,offset_y,offset_z,xelm,yelm,zelm, &
+ ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
+ NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ r_top(ilayer),r_bottom(ilayer),ner(ilayer),ilayer,ichunk,rotation_matrix, &
+ NCHUNKS,INCLUDE_CENTRAL_CUBE,NUMBER_OF_MESH_LAYERS)
+ endif
+! add one spectral element to the list
+ ispec = ispec + 1
+ if(ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in mesh creation')
+
+! new get_flag_boundaries
+! xmin & xmax
+ if (ix_elem == 1) then
+ iMPIcut_xi(1,ispec) = .true.
+ if (iproc_xi == 0) iboun(1,ispec)= .true.
+ endif
+ if (ix_elem == (NEX_PER_PROC_XI-ratio_sampling_array(ilayer)+1)) then
+ iMPIcut_xi(2,ispec) = .true.
+ if (iproc_xi == NPROC_XI-1) iboun(2,ispec)= .true.
+ endif
+! ymin & ymax
+ if (iy_elem == 1) then
+ iMPIcut_eta(1,ispec) = .true.
+ if (iproc_eta == 0) iboun(3,ispec)= .true.
+ endif
+ if (iy_elem == (NEX_PER_PROC_ETA-ratio_sampling_array(ilayer)+1)) then
+ iMPIcut_eta(2,ispec) = .true.
+ if (iproc_eta == NPROC_ETA-1) iboun(4,ispec)= .true.
+ endif
+! zmin & zmax
+ if (iz_elem == ner(ilayer) .and. ilayer == ifirst_region) then
+ iboun(6,ispec)= .true.
+ endif
+ if (iz_elem == 1 .and. ilayer == ilast_region) then ! defined if no doubling in this layer
+ iboun(5,ispec)= .true.
+ endif
+
+! define the doubling flag of this element
+ idoubling(ispec) = doubling_index(ilayer)
+
+! compute several rheological and geometrical properties for this spectral element
+ call compute_element_properties(ispec,iregion_code,idoubling, &
+ xstore,ystore,zstore,nspec, &
+ nspl,rspl,espl,espl2,ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ myrank,ibathy_topo,ATTENUATION,ATTENUATION_3D, &
+ ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xelm,yelm,zelm,shape3D,dershape3D,rmin,rmax,rhostore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ nspec_ani,nspec_stacey,Qmu_store,tau_e_store,rho_vp,rho_vs,&
+ AMM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ACTUALLY_STORE_ARRAYS)
+
+! end of loop on all the regular elements
+ enddo
+ enddo
+ enddo
+!----
+!---- mesh doubling elements
+!----
+! If there is a doubling at the top of this region, let us add these elements.
+! The superbrick implements a symmetric four-to-two doubling and therefore replaces
+! a basic regular block of 2 x 2 = 4 elements.
+! We have imposed that NEX be a multiple of 16 therefore we know that we can always create
+! these 2 x 2 blocks because NEX_PER_PROC_XI / ratio_sampling_array(ilayer) and
+! NEX_PER_PROC_ETA / ratio_sampling_array(ilayer) are always divisible by 2.
+ if(this_region_has_a_doubling(ilayer)) then
+ if (USE_ONE_LAYER_SB) then
+ call define_superbrick_one_layer(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb)
+ nspec_sb = NSPEC_SUPERBRICK_1L
+ iz_elem = ner(ilayer)
+ step_mult = 2
+ else
+ if(iregion_code==IREGION_OUTER_CORE .and. ilayer==ilast_region .and. (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA)) then
+ nspec_sb = NSPEC_DOUBLING_BASICBRICK
+ step_mult = 1
+ else
+ call define_superbrick(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb)
+ nspec_sb = NSPEC_DOUBLING_SUPERBRICK
+ step_mult = 2
+ endif
+! the doubling is implemented in the last two radial elements
+! therefore we start one element before the last one
+ iz_elem = ner(ilayer) - 1
+ endif
+
+! loop on all the elements in the 2 x 2 blocks
+ do ix_elem = 1,NEX_PER_PROC_XI,step_mult*ratio_sampling_array(ilayer)
+ do iy_elem = 1,NEX_PER_PROC_ETA,step_mult*ratio_sampling_array(ilayer)
+
+ if (step_mult == 1) then
+! for xi direction
+ if (.not. CUT_SUPERBRICK_XI) then
+ if (mod((ix_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))==0) then
+ case_xi = 1
+ else
+ case_xi = 2
+ endif
+ else
+ if (offset_proc_xi == 0) then
+ if (mod((ix_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))==0) then
+ case_xi = 1
+ else
+ case_xi = 2
+ endif
+ else
+ if (mod((ix_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))/=0) then
+ case_xi = 1
+ else
+ case_xi = 2
+ endif
+ endif
+ endif
+! for eta direction
+ if (.not. CUT_SUPERBRICK_ETA) then
+ if (mod((iy_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))==0) then
+ case_eta = 1
+ else
+ case_eta = 2
+ endif
+ else
+ if (offset_proc_eta == 0) then
+ if (mod((iy_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))==0) then
+ case_eta = 1
+ else
+ case_eta = 2
+ endif
+ else
+ if (mod((iy_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))/=0) then
+ case_eta = 1
+ else
+ case_eta = 2
+ endif
+ endif
+ endif
+! determine the current sub-block
+ if (case_xi == 1) then
+ if (case_eta == 1) then
+ subblock_num = 1
+ else
+ subblock_num = 2
+ endif
+ else
+ if (case_eta == 1) then
+ subblock_num = 3
+ else
+ subblock_num = 4
+ endif
+ endif
+! then define the geometry for this sub-block
+ call define_basic_doubling_brick(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb,subblock_num)
+ endif
+! loop on all the elements in the mesh doubling superbrick
+ do ispec_superbrick = 1,nspec_sb
+! loop on all the corner nodes of this element
+ do ignod = 1,NGNOD_EIGHT_CORNERS
+
+! define topological coordinates of this mesh point
+ offset_x(ignod) = (ix_elem - 1) + &
+ x_superbrick(ibool_superbrick(ignod,ispec_superbrick)) * ratio_sampling_array(ilayer)
+ offset_y(ignod) = (iy_elem - 1) + &
+ y_superbrick(ibool_superbrick(ignod,ispec_superbrick)) * ratio_sampling_array(ilayer)
+ offset_z(ignod) = (iz_elem - 1) + &
+ z_superbrick(ibool_superbrick(ignod,ispec_superbrick))
+
+ enddo
+! the rest of the 27 nodes are missing, therefore add them
+ call add_missing_nodes(offset_x,offset_y,offset_z)
+
+! compute the actual position of all the grid points of that element
+ call compute_coord_main_mesh(offset_x,offset_y,offset_z,xelm,yelm,zelm, &
+ ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
+ NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ r_top(ilayer),r_bottom(ilayer),ner(ilayer),ilayer,ichunk,rotation_matrix, &
+ NCHUNKS,INCLUDE_CENTRAL_CUBE,NUMBER_OF_MESH_LAYERS)
+
+! add one spectral element to the list
+ ispec = ispec + 1
+ if(ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in mesh creation')
+
+! new get_flag_boundaries
+! xmin & xmax
+ if (ix_elem == 1) then
+ iMPIcut_xi(1,ispec) = iboun_sb(ispec_superbrick,1)
+ if (iproc_xi == 0) iboun(1,ispec)= iboun_sb(ispec_superbrick,1)
+ endif
+ if (ix_elem == (NEX_PER_PROC_XI-step_mult*ratio_sampling_array(ilayer)+1)) then
+ iMPIcut_xi(2,ispec) = iboun_sb(ispec_superbrick,2)
+ if (iproc_xi == NPROC_XI-1) iboun(2,ispec)= iboun_sb(ispec_superbrick,2)
+ endif
+!! ymin & ymax
+ if (iy_elem == 1) then
+ iMPIcut_eta(1,ispec) = iboun_sb(ispec_superbrick,3)
+ if (iproc_eta == 0) iboun(3,ispec)= iboun_sb(ispec_superbrick,3)
+ endif
+ if (iy_elem == (NEX_PER_PROC_ETA-step_mult*ratio_sampling_array(ilayer)+1)) then
+ iMPIcut_eta(2,ispec) = iboun_sb(ispec_superbrick,4)
+ if (iproc_eta == NPROC_ETA-1) iboun(4,ispec)= iboun_sb(ispec_superbrick,4)
+ endif
+! zmax only
+ if (ilayer==ifirst_region) then
+ iboun(6,ispec)= iboun_sb(ispec_superbrick,6)
+ endif
+ if (ilayer==ilast_region .and. iz_elem==1) then
+ iboun(5,ispec)= iboun_sb(ispec_superbrick,5)
+ endif
+
+! define the doubling flag of this element
+ idoubling(ispec) = doubling_index(ilayer)
+
+! compute several rheological and geometrical properties for this spectral element
+ call compute_element_properties(ispec,iregion_code,idoubling, &
+ xstore,ystore,zstore,nspec, &
+ nspl,rspl,espl,espl2,ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ myrank,ibathy_topo,ATTENUATION,ATTENUATION_3D, &
+ ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xelm,yelm,zelm,shape3D,dershape3D,rmin,rmax,rhostore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ nspec_ani,nspec_stacey,Qmu_store,tau_e_store,rho_vp,rho_vs,&
+ AMM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ACTUALLY_STORE_ARRAYS)
+
+! end of loops on the mesh doubling elements
+ enddo
+ enddo
+ enddo
+ endif
+
+! end of loop on all the layers of the mesh
+ enddo
+
+ if (CASE_3D .and. iregion_code == IREGION_CRUST_MANTLE .and. .not. SUPPRESS_CRUSTAL_MESH) deallocate(stretch_tab)
+ deallocate (perm_layer)
+
+!---
+
+! define central cube in inner core
+
+ if(INCLUDE_CENTRAL_CUBE .and. iregion_code == IREGION_INNER_CORE) then
+
+! create the shape of a regular mesh element in the inner core
+ call hex_nodes(iaddx,iaddy,iaddz)
+
+! define vertical slice in central cube on current processor
+! we can assume that NEX_XI = NEX_ETA, otherwise central cube cannot be defined
+ nx_central_cube = NEX_PER_PROC_XI / ratio_divide_central_cube
+ ny_central_cube = NEX_PER_PROC_ETA / ratio_divide_central_cube
+ nz_central_cube = NEX_XI / ratio_divide_central_cube
+
+! size of the cube along cartesian axes before rotation
+ radius_cube = (R_CENTRAL_CUBE / R_EARTH) / sqrt(3.d0)
+
+! define spectral elements in central cube
+ do iz = 0,2*nz_central_cube-2,2
+ do iy = 0,2*ny_central_cube-2,2
+ do ix = 0,2*nx_central_cube-2,2
+
+! radii that define the shell, we know that we are in the central cube
+ rmin = 0.d0
+ rmax = R_CENTRAL_CUBE / R_EARTH
+
+! loop over the NGNOD nodes
+ do ia=1,NGNOD
+
+! flat cubed sphere with correct mapping
+ call compute_coord_central_cube(ix+iaddx(ia),iy+iaddy(ia),iz+iaddz(ia), &
+ xgrid_central_cube,ygrid_central_cube,zgrid_central_cube, &
+ iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,nx_central_cube,ny_central_cube,nz_central_cube,radius_cube)
+
+ if(ichunk == CHUNK_AB) then
+ xelm(ia) = - ygrid_central_cube
+ yelm(ia) = + xgrid_central_cube
+ zelm(ia) = + zgrid_central_cube
+
+ else if(ichunk == CHUNK_AB_ANTIPODE) then
+ xelm(ia) = - ygrid_central_cube
+ yelm(ia) = - xgrid_central_cube
+ zelm(ia) = - zgrid_central_cube
+
+ else if(ichunk == CHUNK_AC) then
+ xelm(ia) = - ygrid_central_cube
+ yelm(ia) = - zgrid_central_cube
+ zelm(ia) = + xgrid_central_cube
+
+ else if(ichunk == CHUNK_AC_ANTIPODE) then
+ xelm(ia) = - ygrid_central_cube
+ yelm(ia) = + zgrid_central_cube
+ zelm(ia) = - xgrid_central_cube
+
+ else if(ichunk == CHUNK_BC) then
+ xelm(ia) = - zgrid_central_cube
+ yelm(ia) = + ygrid_central_cube
+ zelm(ia) = + xgrid_central_cube
+
+ else if(ichunk == CHUNK_BC_ANTIPODE) then
+ xelm(ia) = + zgrid_central_cube
+ yelm(ia) = - ygrid_central_cube
+ zelm(ia) = + xgrid_central_cube
+
+ else
+ call exit_MPI(myrank,'wrong chunk number in flat cubed sphere definition')
+ endif
+
+ enddo
+
+! add one spectral element to the list
+ ispec = ispec + 1
+ if(ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in central cube creation')
+
+! new get_flag_boundaries
+! xmin & xmax
+ if (ix == 0) then
+ iMPIcut_xi(1,ispec) = .true.
+ if (iproc_xi == 0) iboun(1,ispec)= .true.
+ endif
+ if (ix == 2*nx_central_cube-2) then
+ iMPIcut_xi(2,ispec) = .true.
+ if (iproc_xi == NPROC_XI-1) iboun(2,ispec)= .true.
+ endif
+! ymin & ymax
+ if (iy == 0) then
+ iMPIcut_eta(1,ispec) = .true.
+ if (iproc_eta == 0) iboun(3,ispec)= .true.
+ endif
+ if (iy == 2*ny_central_cube-2) then
+ iMPIcut_eta(2,ispec) = .true.
+ if (iproc_eta == NPROC_ETA-1) iboun(4,ispec)= .true.
+ endif
+
+! define the doubling flag of this element
+! only two active central cubes, the four others are fictitious
+
+! determine where we cut the central cube to share it between CHUNK_AB & CHUNK_AB_ANTIPODE
+! in the case of mod(NPROC_XI,2)/=0, the cut is asymetric and the bigger part is for CHUNK_AB
+ if (mod(NPROC_XI,2)/=0) then
+ if (ichunk == CHUNK_AB) then
+ nz_inf_limit = ((nz_central_cube*2)/NPROC_XI)*floor(NPROC_XI/2.d0)
+ elseif (ichunk == CHUNK_AB_ANTIPODE) then
+ nz_inf_limit = ((nz_central_cube*2)/NPROC_XI)*ceiling(NPROC_XI/2.d0)
+ endif
+ else
+ nz_inf_limit = nz_central_cube
+ endif
+
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+ if(iz == nz_inf_limit) then
+ idoubling(ispec) = IFLAG_BOTTOM_CENTRAL_CUBE
+ else if(iz == 2*nz_central_cube-2) then
+ idoubling(ispec) = IFLAG_TOP_CENTRAL_CUBE
+ else if (iz > nz_inf_limit .and. iz < 2*nz_central_cube-2) then
+ idoubling(ispec) = IFLAG_MIDDLE_CENTRAL_CUBE
+ else
+ idoubling(ispec) = IFLAG_IN_FICTITIOUS_CUBE
+ endif
+ else
+ idoubling(ispec) = IFLAG_IN_FICTITIOUS_CUBE
+ endif
+
+
+! compute several rheological and geometrical properties for this spectral element
+ call compute_element_properties(ispec,iregion_code,idoubling, &
+ xstore,ystore,zstore,nspec, &
+ nspl,rspl,espl,espl2,ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ myrank,ibathy_topo,ATTENUATION,ATTENUATION_3D, &
+ ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xelm,yelm,zelm,shape3D,dershape3D,rmin,rmax,rhostore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ nspec_ani,nspec_stacey,Qmu_store,tau_e_store,rho_vp,rho_vs,&
+ AMM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ACTUALLY_STORE_ARRAYS)
+ enddo
+ enddo
+ enddo
+
+ endif ! end of definition of central cube in inner core
+
+!---
+
+! check total number of spectral elements created
+ if(ispec /= nspec) call exit_MPI(myrank,'ispec should equal nspec')
+
+! only create global addressing and the MPI buffers in the first pass
+ if(ipass == 1) then
+
+! allocate memory for arrays
+ allocate(locval(npointot),stat=ier); if(ier /= 0) 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')
+
+! create a new indirect addressing to reduce cache misses in memory access in the solver
+! this is *critical* to improve performance in the solver
+ allocate(copy_ibool_ori(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(mask_ibool(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+
+ mask_ibool(:) = -1
+ copy_ibool_ori(:,:,:,:) = ibool(:,:,:,:)
+
+ inumber = 0
+ do ispec=1,nspec
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if(mask_ibool(copy_ibool_ori(i,j,k,ispec)) == -1) then
+! create a new point
+ inumber = inumber + 1
+ ibool(i,j,k,ispec) = inumber
+ mask_ibool(copy_ibool_ori(i,j,k,ispec)) = inumber
+ else
+! use an existing point created previously
+ ibool(i,j,k,ispec) = mask_ibool(copy_ibool_ori(i,j,k,ispec))
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+ deallocate(copy_ibool_ori,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(mask_ibool,stat=ier); if(ier /= 0) stop 'error in deallocate'
+
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) call exit_MPI(myrank,'incorrect global numbering after sorting')
+
+ allocate(mask_ibool2(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+ mask_ibool2(:) = .false.
+! 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,NGLOB2DMAX_XY,mask_ibool2,npoin2D_xi)
+ call get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, &
+ xstore,ystore,zstore,ifseg,npointot, &
+ NSPEC2D_XI_FACE,iregion_code,NGLOB2DMAX_XY,mask_ibool2,npoin2D_eta)
+!! DK DK only one chunk in current MPI+GPU version
+! 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)
+
+! 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_ibool2(ibool(i,j,k,ispec))) then
+ is_on_a_slice_edge(ispec) = .true.
+ goto 888
+ endif
+ enddo
+ enddo
+ enddo
+ 888 continue
+ enddo
+
+! Stacey
+ if(NCHUNKS /= 6) &
+!!!!!!!! call get_absorb(myrank,prname,iboun,nspec,nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
+ call get_absorb(myrank,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)
+ 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,CRUSTAL,ONE_CRUST,REFERENCE_1D_MODEL, &
+ RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
+ RMIDDLE_CRUST,ROCEAN,M1066a_V,Mak135_V,Mref_V,SEA1DM_V)
+ call write_AVS_DX_surface_data(myrank,prname,nspec,iboun,ibool, &
+ idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
+ endif
+
+ deallocate(locval,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(ifseg,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(mask_ibool2,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)
+
+!!!! DM DM detection of the edges, coloring and permutation separately
+ allocate(perm(nspec))
+ if(USE_MESH_COLORING_INNER_OUTER) then
+
+ stop 'USE_MESH_COLORING_INNER_OUTER should not be used in the serial case'
+
+!! DK DK
+!! DK DK the idea below of a different (regular) sorting to reduce cache misses did not work,
+!! DK DK there is probably a small implementation problem somewhere in the mesher,
+!! DK DK therefore I commented it out for now.
+!! DK DK
+
+!! DK DK for regular C version for CPUs: do not use colors but nonetheless put all the outer elements
+!! DK DK first in order to be able to overlap non-blocking MPI communications with calculations
+! if(USE_REGULAR_C_CPU_VERSION) then
+
+! inumber_in_new_list_after_perm = 0
+
+! first detect and list all the outer elements
+! do ispec = 1,nspec
+! if(is_on_a_slice_edge(ispec)) then
+! inumber_in_new_list_after_perm = inumber_in_new_list_after_perm + 1
+! perm(ispec) = inumber_in_new_list_after_perm
+! endif
+! enddo
+
+! store the total number of outer elements found
+!#ifdef USE_MPI
+! call MPI_ALLREDUCE(inumber_in_new_list_after_perm,nspec_outer_min_global,1,MPI_INTEGER,MPI_MIN,MPI_COMM_WORLD,ier)
+! call MPI_ALLREDUCE(inumber_in_new_list_after_perm,nspec_outer_max_global,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+!#else
+! nspec_outer_min_global = inumber_in_new_list_after_perm
+! nspec_outer_max_global = inumber_in_new_list_after_perm
+!#endif
+! if(myrank == 0) then
+! open(unit=99,file='../DATABASES_FOR_SOLVER/values_from_mesher_nspec_outer.h',status='unknown')
+! write(99,*) '#define NSPEC_OUTER ',nspec_outer_max_global
+! write(99,*) '// NSPEC_OUTER_min = ',nspec_outer_min_global
+! write(99,*) '// NSPEC_OUTER_max = ',nspec_outer_max_global
+! close(99)
+! endif
+
+! just in case, test that we have detected outer elements
+! if(inumber_in_new_list_after_perm <= 0) stop 'fatal error: no outer elements detected!'
+
+! then detect and list all the inner elements
+! do ispec = 1,nspec
+! if(.not. is_on_a_slice_edge(ispec)) then
+! inumber_in_new_list_after_perm = inumber_in_new_list_after_perm + 1
+! perm(ispec) = inumber_in_new_list_after_perm
+! endif
+! enddo
+
+! test that all the elements have been used once and only once
+! if(inumber_in_new_list_after_perm /= nspec) stop 'fatal error: inumber_in_new_list_after_perm not equal to nspec'
+
+! else
+
+! Il y a une routine get_perm_color que l'on ne peut pas enlever :
+! c'est la routine de coloriage. Elle sert a grouper les elements en
+! ensembles d'elements non-jointifs (pas de points globaux communs) pour
+! garder accel() coherent lors de la somme des contributions en parallele sur la carte.
+!
+! De plus, a ce moment on separe aussi les elements externes des internes
+! pour pouvoir faire des comms non boquantes avec recouvrement.
+!
+! This call is a bit expensive because it needs to build the adjacency table
+! but it is necessary and cannot be removed.
+ allocate(first_elem_number_in_this_color(MAX_NUMBER_OF_COLORS + 1))
+ call get_perm_color(is_on_a_slice_edge,ibool,perm,nspec,nglob, &
+ nb_colors_outer_elements,nb_colors_inner_elements,nspec_outer,first_elem_number_in_this_color,myrank)
+
+! for the last color, the next color is fictitious and its first (fictitious) element number is nspec + 1
+ first_elem_number_in_this_color(nb_colors_outer_elements + nb_colors_inner_elements + 1) = nspec + 1
+
+ allocate(number_of_elements_in_this_color(nb_colors_outer_elements + nb_colors_inner_elements))
+
+! save mesh coloring
+ open(unit=99,file=prname(1:len_trim(prname))//'number_of_elements_in_this_color.dat',status='unknown')
+
+! number of colors for outer elements
+ write(99,*) nb_colors_outer_elements
+
+! number of colors for inner elements
+ write(99,*) nb_colors_inner_elements
+
+! number of elements in each color
+ do icolor = 1, nb_colors_outer_elements + nb_colors_inner_elements
+ number_of_elements_in_this_color(icolor) = first_elem_number_in_this_color(icolor+1) - first_elem_number_in_this_color(icolor)
+ write(99,*) number_of_elements_in_this_color(icolor)
+ enddo
+ close(99)
+
+! check that the sum of all the numbers of elements found in each color is equal
+! to the total number of elements in the mesh
+ if(sum(number_of_elements_in_this_color) /= nspec) then
+ print *,'nspec = ',nspec
+ print *,'total number of elements in all the colors of the mesh = ',sum(number_of_elements_in_this_color)
+ stop 'incorrect total number of elements in all the colors of the mesh'
+ endif
+
+! check that the sum of all the numbers of elements found in each color for the outer elements is equal
+! to the total number of outer elements found in the mesh
+ if(sum(number_of_elements_in_this_color(1:nb_colors_outer_elements)) /= nspec_outer) then
+ print *,'nspec_outer = ',nspec_outer
+ print *,'total number of elements in all the colors of the mesh for outer elements = ',sum(number_of_elements_in_this_color)
+ stop 'incorrect total number of elements in all the colors of the mesh for outer elements'
+ endif
+
+! store the total number of outer elements found
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(nspec_outer,nspec_outer_min_global,1,MPI_INTEGER,MPI_MIN,MPI_COMM_WORLD,ier)
+ call MPI_ALLREDUCE(nspec_outer,nspec_outer_max_global,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+#else
+ nspec_outer_min_global = nspec_outer
+ nspec_outer_max_global = nspec_outer
+#endif
+ if(myrank == 0) then
+ open(unit=99,file='../DATABASES_FOR_SOLVER/values_from_mesher_nspec_outer.h',status='unknown')
+ write(99,*) '#define NSPEC_OUTER ',nspec_outer_max_global
+ write(99,*) '// NSPEC_OUTER_min = ',nspec_outer_min_global
+ write(99,*) '// NSPEC_OUTER_max = ',nspec_outer_max_global
+ close(99)
+ endif
+
+ deallocate(first_elem_number_in_this_color)
+ deallocate(number_of_elements_in_this_color)
+
+! endif ! endif of the above section commented out because the idea did not work
+
+ else
+
+! print *,'be careful, USE_MESH_COLORING_INNER_OUTER must always been set to .true. even for the regular C version for CPUs!'
+! print *,'generating identity permutation'
+ do ispec = 1,nspec
+ perm(ispec) = ispec
+ enddo
+
+ endif
+
+ if (myrank == 0) then
+
+! write a header file for the Fortran version of the solver
+ open(unit=99,file='../DATABASES_FOR_SOLVER/values_from_mesher_f90.h',status='unknown')
+ write(99,*) 'integer, parameter :: NSPEC = ',nspec
+ write(99,*) 'integer, parameter :: NGLOB = ',nglob
+ write(99,*) 'integer, parameter :: NSTEP = ',nstep
+ write(99,*) 'real(kind=4), parameter :: deltat = ',DT
+ write(99,*)
+ write(99,*) '! element number of the source and of the station'
+ write(99,*) '! after permutation of the elements by mesh coloring'
+ write(99,*) '! and inner/outer set splitting in the mesher'
+ write(99,*) '! (before permutation they are 1000 and NSPEC - 1000)'
+ write(99,*) 'integer, parameter :: NSPEC_SOURCE = ',perm(1000)
+ write(99,*) 'integer, parameter :: NSPEC_STATION = ',perm(NSPEC - 1000)
+! save coordinates of the seismic source
+! write(99,*) xstore(2,2,2,10);
+! write(99,*) ystore(2,2,2,10);
+! write(99,*) zstore(2,2,2,10);
+
+! save coordinates of the seismic station
+! write(99,*) xstore(2,2,2,nspec-10);
+! write(99,*) ystore(2,2,2,nspec-10);
+! write(99,*) zstore(2,2,2,nspec-10);
+ close(99)
+
+! write a header file for the C version of the solver
+ open(unit=99,file='../DATABASES_FOR_SOLVER/values_from_mesher_C.h',status='unknown')
+ write(99,*) '#define NSPEC ',nspec
+ write(99,*) '#define NGLOB ',nglob
+ write(99,*) '#define NSTEP ',nstep
+!!!!!!! DK DK use 1000 time steps only for the scaling tests
+!!!!!!!!! write(99,*) '#define NSTEP 1000 // 5000 // ',nstep
+! put an "f" at the end to force single precision
+ write(99,"('#define deltat ',e18.10,'f')") DT
+ write(99,*) '#define NGLOB2DMAX_XMIN_XMAX ',npoin2D_xi
+ write(99,*) '#define NGLOB2DMAX_YMIN_YMAX ',npoin2D_eta
+ write(99,*) '#define NGLOB2DMAX_ALL ',max(npoin2D_xi,npoin2D_eta)
+ write(99,*) '#define NPROC_XI ',NPROC_XI
+ write(99,*) '#define NPROC_ETA ',NPROC_ETA
+ write(99,*)
+ write(99,*) '// element and MPI slice number of the source and the station'
+ write(99,*) '// after permutation of the elements by mesh coloring'
+ write(99,*) '// and inner/outer set splitting in the mesher'
+ write(99,*) '// (before permutation they are 1000 and NSPEC - 1000)'
+ write(99,*) '#define RANK_SOURCE 0'
+ write(99,*) '#define NSPEC_SOURCE ',perm(1000)
+ write(99,*)
+ write(99,*) '#define RANK_STATION (NPROC_XI*NPROC_ETA - 1)'
+ write(99,*) '#define NSPEC_STATION ',perm(NSPEC - 1000)
+ close(99)
+
+ endif
+
+ if (USE_MESH_COLORING_INNER_OUTER) then
+ allocate(temp_array_real(NGLLX,NGLLY,NGLLZ,nspec))
+ call permute_elements_real(xixstore,temp_array_real,perm,nspec)
+ call permute_elements_real(xiystore,temp_array_real,perm,nspec)
+ call permute_elements_real(xizstore,temp_array_real,perm,nspec)
+ call permute_elements_real(etaxstore,temp_array_real,perm,nspec)
+ call permute_elements_real(etaystore,temp_array_real,perm,nspec)
+ call permute_elements_real(etazstore,temp_array_real,perm,nspec)
+ call permute_elements_real(gammaxstore,temp_array_real,perm,nspec)
+ call permute_elements_real(gammaystore,temp_array_real,perm,nspec)
+ call permute_elements_real(gammazstore,temp_array_real,perm,nspec)
+ call permute_elements_real(kappavstore,temp_array_real,perm,nspec)
+ call permute_elements_real(muvstore,temp_array_real,perm,nspec)
+ call permute_elements_real(rhostore,temp_array_real,perm,nspec)
+ deallocate(temp_array_real)
+
+ allocate(temp_array_dble(NGLLX,NGLLY,NGLLZ,nspec))
+ call permute_elements_dble(xstore,temp_array_dble,perm,nspec)
+ call permute_elements_dble(ystore,temp_array_dble,perm,nspec)
+ call permute_elements_dble(zstore,temp_array_dble,perm,nspec)
+ deallocate(temp_array_dble)
+
+ ! permutation of ibool
+ allocate(temp_array_int(NGLLX,NGLLY,NGLLZ,nspec))
+ call permute_elements_integer(ibool,temp_array_int,perm,nspec)
+ deallocate(temp_array_int)
+
+ ! permutation of idoubling
+ allocate(temp_array_1D_int(nspec))
+ temp_array_1D_int(:) = idoubling(:)
+ do ispec = 1,nspec
+ idoubling(perm(ispec)) = temp_array_1D_int(ispec)
+ enddo
+ deallocate(temp_array_1D_int)
+
+ deallocate(perm)
+ endif
+!!!! DM DM coloring and permutation
+
+! call get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, &
+! dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+! ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+! nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+! jacobian2D_xmin,jacobian2D_xmax, &
+! jacobian2D_ymin,jacobian2D_ymax, &
+! jacobian2D_bottom,jacobian2D_top, &
+! normal_xmin,normal_xmax, &
+! normal_ymin,normal_ymax, &
+! normal_bottom,normal_top, &
+! NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+! NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX)
+
+! creating mass matrix in this slice (will be fully assembled in the solver)
+ allocate(rmass(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+
+ 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 the binary files
+! save ocean load mass matrix as well if oceans
+ if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) then
+
+! adding ocean load mass matrix at the top of the crust for oceans
+ nglob_oceans = nglob
+ allocate(rmass_ocean_load(nglob_oceans))
+
+! create ocean load mass matrix for degrees of freedom at ocean bottom
+ rmass_ocean_load(:) = 0._CUSTOM_REAL
+
+! add contribution of the oceans
+! for surface elements exactly at the top of the crust (ocean bottom)
+ do ispec2D_top_crust = 1,NSPEC2D_TOP
+
+ ispec_oceans = ibelm_top(ispec2D_top_crust)
+
+ iz_oceans = NGLLZ
+
+ do ix_oceans = 1,NGLLX
+ do iy_oceans = 1,NGLLY
+
+ iglobnum=ibool(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+
+! compute local height of oceans
+ if(ISOTROPIC_3D_MANTLE) then
+
+! get coordinates of current point
+ xval = xstore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+ yval = ystore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+ zval = zstore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+
+! map to latitude and longitude for bathymetry routine
+ call xyz_2_rthetaphi_dble(xval,yval,zval,rval,thetaval,phival)
+ call reduce(thetaval,phival)
+
+! convert the geocentric colatitude to a geographic colatitude
+ colat = PI/2.0d0 - datan(1.006760466d0*dcos(thetaval)/dmax1(TINYVAL,dsin(thetaval)))
+
+! get geographic latitude and longitude in degrees
+ lat = 90.0d0 - colat*180.0d0/PI
+ lon = phival*180.0d0/PI
+ elevation = 0.d0
+
+! compute elevation at current point
+ call get_topo_bathy(lat,lon,elevation,ibathy_topo)
+
+! non-dimensionalize the elevation, which is in meters
+! and suppress positive elevation, which means no oceans
+ if(elevation >= - MINIMUM_THICKNESS_3D_OCEANS) then
+ height_oceans = 0.d0
+ else
+ height_oceans = dabs(elevation) / R_EARTH
+ endif
+
+ else
+ height_oceans = THICKNESS_OCEANS_PREM
+ endif
+
+! take into account inertia of water column
+ weight = wxgll(ix_oceans)*wygll(iy_oceans)*dble(jacobian2D_top(ix_oceans,iy_oceans,ispec2D_top_crust)) &
+ * dble(RHO_OCEANS) * height_oceans
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + sngl(weight)
+ else
+ rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + weight
+ endif
+
+ enddo
+ enddo
+
+ enddo
+
+! add regular mass matrix to ocean load contribution
+ rmass_ocean_load(:) = rmass_ocean_load(:) + rmass(:)
+
+ else
+
+! allocate dummy array if no oceans
+ nglob_oceans = 1
+ allocate(rmass_ocean_load(nglob_oceans))
+
+ endif
+
+ call save_arrays_solver(prname,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore, &
+ kappavstore,muvstore,ibool,rmass,nspec,nglob,myrank,NPROCTOT,xstore,ystore,zstore)
+
+ deallocate(rmass,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(rmass_ocean_load,stat=ier); if(ier /= 0) stop 'error in deallocate'
+
+! compute volume, bottom and top area of that part of the slice
+ volume_local = 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
+
+ else
+ stop 'there cannot be more than two passes in mesh creation'
+
+ endif ! end of test if first or second pass
+
+! 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,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)
+
+ end subroutine create_regions_mesh
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/create_serial_name_database.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/create_serial_name_database.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/create_serial_name_database.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,84 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine 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
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/crustal_model.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/crustal_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/crustal_model.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,367 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!
+! read and smooth crust2.0 model
+! based on software routines provided with the crust2.0 model by Bassin et al.
+!
+
+ subroutine crustal_model(lat,lon,x,vp,vs,rho,moho,found_crust,CM_V)
+
+ implicit none
+ include "constants.h"
+
+! crustal_model_variables
+ type crustal_model_variables
+ sequence
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
+ character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+ character(len=2) code(NKEYS_CRUST)
+ end type crustal_model_variables
+
+ type (crustal_model_variables) CM_V
+! crustal_model_variables
+
+ double precision lat,lon,x,vp,vs,rho,moho
+ logical found_crust
+
+ double precision h_sed,h_uc
+ double precision x3,x4,x5,x6,x7,scaleval
+ double precision vps(NLAYERS_CRUST),vss(NLAYERS_CRUST),rhos(NLAYERS_CRUST),thicks(NLAYERS_CRUST)
+
+ call crust(lat,lon,vps,vss,rhos,thicks,CM_V%abbreviation,CM_V%code,CM_V%thlr,CM_V%velocp,CM_V%velocs,CM_V%dens)
+
+ x3 = (R_EARTH-thicks(3)*1000.0d0)/R_EARTH
+ h_sed = thicks(3) + thicks(4)
+ x4 = (R_EARTH-h_sed*1000.0d0)/R_EARTH
+ h_uc = h_sed + thicks(5)
+ x5 = (R_EARTH-h_uc*1000.0d0)/R_EARTH
+ x6 = (R_EARTH-(h_uc+thicks(6))*1000.0d0)/R_EARTH
+ x7 = (R_EARTH-(h_uc+thicks(6)+thicks(7))*1000.0d0)/R_EARTH
+
+ found_crust = .true.
+ if(x > x3 .and. INCLUDE_SEDIMENTS_CRUST) then
+ vp = vps(3)
+ vs = vss(3)
+ rho = rhos(3)
+ else if(x > x4 .and. INCLUDE_SEDIMENTS_CRUST) then
+ vp = vps(4)
+ vs = vss(4)
+ rho = rhos(4)
+ else if(x > x5) then
+ vp = vps(5)
+ vs = vss(5)
+ rho = rhos(5)
+ else if(x > x6) then
+ vp = vps(6)
+ vs = vss(6)
+ rho = rhos(6)
+ else if(x > x7) then
+ vp = vps(7)
+ vs = vss(7)
+ rho = rhos(7)
+ else
+ found_crust = .false.
+ endif
+
+ if (found_crust) then
+! non-dimensionalize
+ scaleval = dsqrt(PI*GRAV*RHOAV)
+ vp = vp*1000.0d0/(R_EARTH*scaleval)
+ vs = vs*1000.0d0/(R_EARTH*scaleval)
+ rho = rho*1000.0d0/RHOAV
+ moho = (h_uc+thicks(6)+thicks(7))*1000.0d0/R_EARTH
+ endif
+
+ end subroutine crustal_model
+
+!---------------------------
+
+ subroutine read_crustal_model(CM_V)
+
+ implicit none
+ include "constants.h"
+
+! crustal_model_variables
+ type crustal_model_variables
+ sequence
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
+ character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+ character(len=2) code(NKEYS_CRUST)
+ end type crustal_model_variables
+
+ type (crustal_model_variables) CM_V
+! crustal_model_variables
+
+! local variables
+ integer i
+ integer ila,icolat
+ integer ikey
+
+ double precision h_moho_min,h_moho_max
+
+ character(len=150) CNtype2, CNtype2_key_modif
+
+ call get_value_string(CNtype2, 'model.CNtype2', 'DATA/crust2.0/CNtype2.txt')
+ call get_value_string(CNtype2_key_modif, 'model.CNtype2_key_modif', 'DATA/crust2.0/CNtype2_key_modif.txt')
+
+ open(unit=1,file=CNtype2,status='old',action='read')
+ do ila=1,NCAP_CRUST/2
+ read(1,*) icolat,(CM_V%abbreviation(ila,i),i=1,NCAP_CRUST)
+ enddo
+ close(1)
+
+ open(unit=1,file=CNtype2_key_modif,status='old',action='read')
+ h_moho_min=HUGEVAL
+ h_moho_max=-HUGEVAL
+ do ikey=1,NKEYS_CRUST
+ read (1,"(a2)") CM_V%code(ikey)
+ read (1,*) (CM_V%velocp(ikey,i),i=1,NLAYERS_CRUST)
+ read (1,*) (CM_V%velocs(ikey,i),i=1,NLAYERS_CRUST)
+ read (1,*) (CM_V%dens(ikey,i),i=1,NLAYERS_CRUST)
+ read (1,*) (CM_V%thlr(ikey,i),i=1,NLAYERS_CRUST-1),CM_V%thlr(ikey,NLAYERS_CRUST)
+ if(CM_V%thlr(ikey,NLAYERS_CRUST) > h_moho_max) h_moho_max=CM_V%thlr(ikey,NLAYERS_CRUST)
+ if(CM_V%thlr(ikey,NLAYERS_CRUST) < h_moho_min) h_moho_min=CM_V%thlr(ikey,NLAYERS_CRUST)
+ enddo
+ close(1)
+
+ if(h_moho_min == HUGEVAL .or. h_moho_max == -HUGEVAL) &
+ stop 'incorrect moho depths in read_3D_crustal_model'
+
+ end subroutine read_crustal_model
+
+!---------------------------
+
+ subroutine crust(lat,lon,velp,vels,rho,thick,abbreviation,code,thlr,velocp,velocs,dens)
+
+! crustal vp and vs in km/s, layer thickness in km
+! crust2.0 is smoothed with a cap of size CAP using NTHETA points
+! in the theta direction and NPHI in the phi direction.
+! The cap is rotated to the North Pole.
+
+ implicit none
+ include "constants.h"
+
+ integer, parameter :: NTHETA = 2
+ integer, parameter :: NPHI = 10
+ double precision, parameter :: CAP = 2.0d0*PI/180.0d0
+
+! argument variables
+ double precision lat,lon
+ double precision rho(NLAYERS_CRUST),thick(NLAYERS_CRUST),velp(NLAYERS_CRUST),vels(NLAYERS_CRUST)
+ double precision thlr(NKEYS_CRUST,NLAYERS_CRUST),velocp(NKEYS_CRUST,NLAYERS_CRUST)
+ double precision velocs(NKEYS_CRUST,NLAYERS_CRUST),dens(NKEYS_CRUST,NLAYERS_CRUST)
+ character(len=2) code(NKEYS_CRUST),abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+
+! local variables
+ integer i,j,k,icolat,ilon,ierr
+ integer itheta,iphi,npoints
+ double precision theta,phi,sint,cost,sinp,cosp,dtheta,dphi,cap_area,wght,total
+ double precision r_rot,theta_rot,phi_rot
+ double precision rotation_matrix(3,3),x(3),xc(3)
+ double precision xlon(NTHETA*NPHI),xlat(NTHETA*NPHI),weight(NTHETA*NPHI)
+ double precision rhol(NLAYERS_CRUST),thickl(NLAYERS_CRUST),velpl(NLAYERS_CRUST),velsl(NLAYERS_CRUST)
+ character(len=2) crustaltype
+
+! get integer colatitude and longitude of crustal cap
+! -90<lat<90 -180<lon<180
+ if(lat > 90.0d0 .or. lat < -90.0d0 .or. lon > 180.0d0 .or. lon < -180.0d0) &
+ stop 'error in latitude/longitude range in crust'
+ if(lat==90.0d0) lat=89.9999d0
+ if(lat==-90.0d0) lat=-89.9999d0
+ if(lon==180.0d0) lon=179.9999d0
+ if(lon==-180.0d0) lon=-179.9999d0
+
+ call icolat_ilon(lat,lon,icolat,ilon)
+ crustaltype=abbreviation(icolat,ilon)
+ call get_crust_structure(crustaltype,velp,vels,rho,thick, &
+ code,thlr,velocp,velocs,dens,ierr)
+
+! uncomment the following line to use crust2.0 as is, without smoothing
+!
+! return
+
+ theta = (90.0-lat)*PI/180.0
+ phi = lon*PI/180.0
+
+ sint = sin(theta)
+ cost = cos(theta)
+ sinp = sin(phi)
+ cosp = cos(phi)
+
+! set up rotation matrix to go from cap at North pole
+! to cap around point of interest
+ rotation_matrix(1,1) = cosp*cost
+ rotation_matrix(1,2) = -sinp
+ rotation_matrix(1,3) = cosp*sint
+ rotation_matrix(2,1) = sinp*cost
+ rotation_matrix(2,2) = cosp
+ rotation_matrix(2,3) = sinp*sint
+ rotation_matrix(3,1) = -sint
+ rotation_matrix(3,2) = 0.0
+ rotation_matrix(3,3) = cost
+
+ dtheta = CAP/dble(NTHETA)
+ dphi = 2.0*PI/dble(NPHI)
+ cap_area = 2.0*PI*(1.0-cos(CAP))
+
+! integrate over a cap at the North pole
+ i = 0
+ total = 0.0
+ do itheta = 1,NTHETA
+
+ theta = 0.5*dble(2*itheta-1)*CAP/dble(NTHETA)
+ cost = cos(theta)
+ sint = sin(theta)
+ wght = sint*dtheta*dphi/cap_area
+
+ do iphi = 1,NPHI
+
+ i = i+1
+! get the weight associated with this integration point (same for all phi)
+ weight(i) = wght
+ total = total + weight(i)
+ phi = dble(2*iphi-1)*PI/dble(NPHI)
+ cosp = cos(phi)
+ sinp = sin(phi)
+! x,y,z coordinates of integration point in cap at North pole
+ xc(1) = sint*cosp
+ xc(2) = sint*sinp
+ xc(3) = cost
+! get x,y,z coordinates in cap around point of interest
+ do j=1,3
+ x(j) = 0.0
+ do k=1,3
+ x(j) = x(j)+rotation_matrix(j,k)*xc(k)
+ enddo
+ enddo
+! get latitude and longitude (degrees) of integration point
+ call xyz_2_rthetaphi_dble(x(1),x(2),x(3),r_rot,theta_rot,phi_rot)
+ call reduce(theta_rot,phi_rot)
+ xlat(i) = (PI/2.0-theta_rot)*180.0/PI
+ xlon(i) = phi_rot*180.0/PI
+ if(xlon(i) > 180.0) xlon(i) = xlon(i)-360.0
+
+ enddo
+
+ enddo
+
+ if(abs(total-1.0) > 0.001) stop 'error in cap integration for crust2.0'
+
+ npoints = i
+
+ do j=1,NLAYERS_CRUST
+ rho(j)=0.0d0
+ thick(j)=0.0d0
+ velp(j)=0.0d0
+ vels(j)=0.0d0
+ enddo
+
+ do i=1,npoints
+ call icolat_ilon(xlat(i),xlon(i),icolat,ilon)
+ crustaltype=abbreviation(icolat,ilon)
+ call get_crust_structure(crustaltype,velpl,velsl,rhol,thickl, &
+ code,thlr,velocp,velocs,dens,ierr)
+ if(ierr /= 0) stop 'error in routine get_crust_structure'
+ do j=1,NLAYERS_CRUST
+ rho(j)=rho(j)+weight(i)*rhol(j)
+ thick(j)=thick(j)+weight(i)*thickl(j)
+ velp(j)=velp(j)+weight(i)*velpl(j)
+ vels(j)=vels(j)+weight(i)*velsl(j)
+ enddo
+ enddo
+
+ end subroutine crust
+
+!------------------------------------------------------
+
+ subroutine icolat_ilon(xlat,xlon,icolat,ilon)
+
+ implicit none
+
+
+! argument variables
+ double precision xlat,xlon
+ integer icolat,ilon
+
+ if(xlat > 90.0d0 .or. xlat < -90.0d0 .or. xlon > 180.0d0 .or. xlon < -180.0d0) &
+ stop 'error in latitude/longitude range in icolat_ilon'
+ icolat=int(1+((90.d0-xlat)/2.d0))
+ if(icolat == 91) icolat=90
+ ilon=int(1+((180.d0+xlon)/2.d0))
+ if(ilon == 181) ilon=1
+
+ if(icolat>90 .or. icolat<1) stop 'error in routine icolat_ilon'
+ if(ilon<1 .or. ilon>180) stop 'error in routine icolat_ilon'
+
+ end subroutine icolat_ilon
+
+!---------------------------------------------------------------------
+
+ subroutine get_crust_structure(type,vptyp,vstyp,rhtyp,thtp, &
+ code,thlr,velocp,velocs,dens,ierr)
+
+ implicit none
+ include "constants.h"
+
+
+! argument variables
+ integer ierr
+ double precision rhtyp(NLAYERS_CRUST),thtp(NLAYERS_CRUST)
+ double precision vptyp(NLAYERS_CRUST),vstyp(NLAYERS_CRUST)
+ character(len=2) type,code(NKEYS_CRUST)
+ double precision thlr(NKEYS_CRUST,NLAYERS_CRUST),velocp(NKEYS_CRUST,NLAYERS_CRUST)
+ double precision velocs(NKEYS_CRUST,NLAYERS_CRUST),dens(NKEYS_CRUST,NLAYERS_CRUST)
+
+! local variables
+ integer i,ikey
+
+ ierr=1
+ do ikey=1,NKEYS_CRUST
+ if (code(ikey) == type) then
+ do i=1,NLAYERS_CRUST
+ vptyp(i)=velocp(ikey,i)
+ vstyp(i)=velocs(ikey,i)
+ rhtyp(i)=dens(ikey,i)
+ enddo
+ do i=1,NLAYERS_CRUST-1
+ thtp(i)=thlr(ikey,i)
+ enddo
+! get distance to Moho from the bottom of the ocean or the ice
+ thtp(NLAYERS_CRUST)=thlr(ikey,NLAYERS_CRUST)-thtp(1)-thtp(2)
+ ierr=0
+ endif
+ enddo
+
+ end subroutine get_crust_structure
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/define_derivation_matrices.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/define_derivation_matrices.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/define_derivation_matrices.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,178 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine define_derivation_matrices(xigll,yigll,zigll,wxgll,wygll,wzgll, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube)
+
+ implicit none
+
+ include "constants.h"
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll,wxgll
+ double precision, dimension(NGLLY) :: yigll,wygll
+ double precision, dimension(NGLLZ) :: zigll,wzgll
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+! array with all the weights in the cube
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
+
+! function for calculating derivatives of Lagrange polynomials
+ double precision, external :: lagrange_deriv_GLL
+
+ integer i,j,k,i1,i2,j1,j2,k1,k2
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! set up coordinates of the Gauss-Lobatto-Legendre points
+ call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
+
+! if number of points is odd, the middle abscissa is exactly ZERO
+ if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO
+ if(mod(NGLLY,2) /= 0) yigll((NGLLY-1)/2+1) = ZERO
+ if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+
+! calculate derivatives of the Lagrange polynomials
+! and precalculate some products in double precision
+! hprime(i,j) = h'_j(xigll_i) by definition of the derivation matrix
+ do i1=1,NGLLX
+ do i2=1,NGLLX
+ hprime_xx(i2,i1) = sngl(lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX))
+ hprimewgll_xx(i2,i1) = sngl(lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)*wxgll(i2))
+ enddo
+ enddo
+
+ do j1=1,NGLLY
+ do j2=1,NGLLY
+ hprime_yy(j2,j1) = sngl(lagrange_deriv_GLL(j1-1,j2-1,yigll,NGLLY))
+ hprimewgll_yy(j2,j1) = sngl(lagrange_deriv_GLL(j1-1,j2-1,yigll,NGLLY)*wygll(j2))
+ enddo
+ enddo
+
+ do k1=1,NGLLZ
+ do k2=1,NGLLZ
+ hprime_zz(k2,k1) = sngl(lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ))
+ hprimewgll_zz(k2,k1) = sngl(lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)*wzgll(k2))
+ enddo
+ enddo
+
+ do i=1,NGLLX
+ do j=1,NGLLY
+ wgllwgll_xy(i,j) = sngl(wxgll(i)*wygll(j))
+ enddo
+ enddo
+
+ do i=1,NGLLX
+ do k=1,NGLLZ
+ wgllwgll_xz(i,k) = sngl(wxgll(i)*wzgll(k))
+ enddo
+ enddo
+
+ do j=1,NGLLY
+ do k=1,NGLLZ
+ wgllwgll_yz(j,k) = sngl(wygll(j)*wzgll(k))
+ enddo
+ enddo
+
+ do i=1,NGLLX
+ do j=1,NGLLY
+ do k=1,NGLLZ
+ wgll_cube(i,j,k) = wxgll(i)*wygll(j)*wzgll(k)
+ enddo
+ enddo
+ enddo
+
+ else ! double precision version
+
+! calculate derivatives of the Lagrange polynomials
+! and precalculate some products in double precision
+! hprime(i,j) = h'_j(xigll_i) by definition of the derivation matrix
+ do i1=1,NGLLX
+ do i2=1,NGLLX
+ hprime_xx(i2,i1) = lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)
+ hprimewgll_xx(i2,i1) = lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)*wxgll(i2)
+ enddo
+ enddo
+
+ do j1=1,NGLLY
+ do j2=1,NGLLY
+ hprime_yy(j2,j1) = lagrange_deriv_GLL(j1-1,j2-1,yigll,NGLLY)
+ hprimewgll_yy(j2,j1) = lagrange_deriv_GLL(j1-1,j2-1,yigll,NGLLY)*wygll(j2)
+ enddo
+ enddo
+
+ do k1=1,NGLLZ
+ do k2=1,NGLLZ
+ hprime_zz(k2,k1) = lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)
+ hprimewgll_zz(k2,k1) = lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)*wzgll(k2)
+ enddo
+ enddo
+
+ do i=1,NGLLX
+ do j=1,NGLLY
+ wgllwgll_xy(i,j) = wxgll(i)*wygll(j)
+ enddo
+ enddo
+
+ do i=1,NGLLX
+ do k=1,NGLLZ
+ wgllwgll_xz(i,k) = wxgll(i)*wzgll(k)
+ enddo
+ enddo
+
+ do j=1,NGLLY
+ do k=1,NGLLZ
+ wgllwgll_yz(j,k) = wygll(j)*wzgll(k)
+ enddo
+ enddo
+
+ do i=1,NGLLX
+ do j=1,NGLLY
+ do k=1,NGLLZ
+ wgll_cube(i,j,k) = wxgll(i)*wygll(j)*wzgll(k)
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ end subroutine define_derivation_matrices
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/define_superbrick.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/define_superbrick.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/define_superbrick.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,2036 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! define the superbrick that implements the symmetric four-to-two mesh doubling.
+! Generated automatically by a script: UTILS/doubling_brick/define_superbrick.pl
+
+ subroutine define_superbrick(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, dimension(NGNOD_EIGHT_CORNERS,NSPEC_DOUBLING_SUPERBRICK) :: ibool_superbrick
+ double precision, dimension(NGLOB_DOUBLING_SUPERBRICK) :: x_superbrick,y_superbrick,z_superbrick
+ logical, dimension(NSPEC_DOUBLING_SUPERBRICK,6) :: iboun_sb
+
+ x_superbrick(1) = 3.d0 / 2.d0
+ y_superbrick(1) = 1.d0
+ z_superbrick(1) = 2.d0
+
+ x_superbrick(2) = 3.d0 / 2.d0
+ y_superbrick(2) = 1.d0
+ z_superbrick(2) = 3.d0 / 2.d0
+
+ x_superbrick(3) = 3.d0 / 2.d0
+ y_superbrick(3) = 3.d0 / 2.d0
+ z_superbrick(3) = 3.d0 / 2.d0
+
+ x_superbrick(4) = 3.d0 / 2.d0
+ y_superbrick(4) = 3.d0 / 2.d0
+ z_superbrick(4) = 2.d0
+
+ x_superbrick(5) = 2.d0
+ y_superbrick(5) = 1.d0
+ z_superbrick(5) = 2.d0
+
+ x_superbrick(6) = 2.d0
+ y_superbrick(6) = 1.d0
+ z_superbrick(6) = 1.d0
+
+ x_superbrick(7) = 2.d0
+ y_superbrick(7) = 3.d0 / 2.d0
+ z_superbrick(7) = 1.d0
+
+ x_superbrick(8) = 2.d0
+ y_superbrick(8) = 3.d0 / 2.d0
+ z_superbrick(8) = 2.d0
+
+ x_superbrick(9) = 3.d0 / 2.d0
+ y_superbrick(9) = 2.d0
+ z_superbrick(9) = 1.d0
+
+ x_superbrick(10) = 3.d0 / 2.d0
+ y_superbrick(10) = 2.d0
+ z_superbrick(10) = 2.d0
+
+ x_superbrick(11) = 2.d0
+ y_superbrick(11) = 2.d0
+ z_superbrick(11) = 1.d0 / 2.d0
+
+ x_superbrick(12) = 2.d0
+ y_superbrick(12) = 2.d0
+ z_superbrick(12) = 2.d0
+
+ x_superbrick(13) = 1.d0
+ y_superbrick(13) = 1.d0
+ z_superbrick(13) = 1.d0
+
+ x_superbrick(14) = 1.d0
+ y_superbrick(14) = 1.d0
+ z_superbrick(14) = 1.d0 / 2.d0
+
+ x_superbrick(15) = 1.d0
+ y_superbrick(15) = 2.d0
+ z_superbrick(15) = 1.d0 / 2.d0
+
+ x_superbrick(16) = 1.d0
+ y_superbrick(16) = 2.d0
+ z_superbrick(16) = 1.d0
+
+ x_superbrick(17) = 3.d0 / 2.d0
+ y_superbrick(17) = 1.d0
+ z_superbrick(17) = 1.d0
+
+ x_superbrick(18) = 2.d0
+ y_superbrick(18) = 1.d0
+ z_superbrick(18) = 1.d0 / 2.d0
+
+ x_superbrick(19) = 1.d0
+ y_superbrick(19) = 1.d0
+ z_superbrick(19) = 3.d0 / 2.d0
+
+ x_superbrick(20) = 1.d0
+ y_superbrick(20) = 1.d0
+ z_superbrick(20) = 2.d0
+
+ x_superbrick(21) = 1.d0
+ y_superbrick(21) = 3.d0 / 2.d0
+ z_superbrick(21) = 3.d0 / 2.d0
+
+ x_superbrick(22) = 1.d0
+ y_superbrick(22) = 3.d0 / 2.d0
+ z_superbrick(22) = 2.d0
+
+ x_superbrick(23) = 1.d0
+ y_superbrick(23) = 2.d0
+ z_superbrick(23) = 2.d0
+
+ x_superbrick(24) = 1.d0
+ y_superbrick(24) = 1.d0
+ z_superbrick(24) = 0.d0
+
+ x_superbrick(25) = 2.d0
+ y_superbrick(25) = 1.d0
+ z_superbrick(25) = 0.d0
+
+ x_superbrick(26) = 2.d0
+ y_superbrick(26) = 2.d0
+ z_superbrick(26) = 0.d0
+
+ x_superbrick(27) = 1.d0
+ y_superbrick(27) = 2.d0
+ z_superbrick(27) = 0.d0
+
+ x_superbrick(28) = 3.d0 / 2.d0
+ y_superbrick(28) = 1.d0 / 2.d0
+ z_superbrick(28) = 3.d0 / 2.d0
+
+ x_superbrick(29) = 3.d0 / 2.d0
+ y_superbrick(29) = 1.d0 / 2.d0
+ z_superbrick(29) = 2.d0
+
+ x_superbrick(30) = 2.d0
+ y_superbrick(30) = 1.d0 / 2.d0
+ z_superbrick(30) = 1.d0
+
+ x_superbrick(31) = 2.d0
+ y_superbrick(31) = 1.d0 / 2.d0
+ z_superbrick(31) = 2.d0
+
+ x_superbrick(32) = 3.d0 / 2.d0
+ y_superbrick(32) = 0.d0
+ z_superbrick(32) = 1.d0
+
+ x_superbrick(33) = 3.d0 / 2.d0
+ y_superbrick(33) = 0.d0
+ z_superbrick(33) = 2.d0
+
+ x_superbrick(34) = 2.d0
+ y_superbrick(34) = 0.d0
+ z_superbrick(34) = 1.d0 / 2.d0
+
+ x_superbrick(35) = 2.d0
+ y_superbrick(35) = 0.d0
+ z_superbrick(35) = 2.d0
+
+ x_superbrick(36) = 1.d0
+ y_superbrick(36) = 0.d0
+ z_superbrick(36) = 1.d0 / 2.d0
+
+ x_superbrick(37) = 1.d0
+ y_superbrick(37) = 0.d0
+ z_superbrick(37) = 1.d0
+
+ x_superbrick(38) = 1.d0
+ y_superbrick(38) = 1.d0 / 2.d0
+ z_superbrick(38) = 3.d0 / 2.d0
+
+ x_superbrick(39) = 1.d0
+ y_superbrick(39) = 1.d0 / 2.d0
+ z_superbrick(39) = 2.d0
+
+ x_superbrick(40) = 1.d0
+ y_superbrick(40) = 0.d0
+ z_superbrick(40) = 2.d0
+
+ x_superbrick(41) = 2.d0
+ y_superbrick(41) = 0.d0
+ z_superbrick(41) = 0.d0
+
+ x_superbrick(42) = 1.d0
+ y_superbrick(42) = 0.d0
+ z_superbrick(42) = 0.d0
+
+ x_superbrick(43) = 1.d0 / 2.d0
+ y_superbrick(43) = 1.d0
+ z_superbrick(43) = 2.d0
+
+ x_superbrick(44) = 1.d0 / 2.d0
+ y_superbrick(44) = 1.d0
+ z_superbrick(44) = 3.d0 / 2.d0
+
+ x_superbrick(45) = 1.d0 / 2.d0
+ y_superbrick(45) = 3.d0 / 2.d0
+ z_superbrick(45) = 3.d0 / 2.d0
+
+ x_superbrick(46) = 1.d0 / 2.d0
+ y_superbrick(46) = 3.d0 / 2.d0
+ z_superbrick(46) = 2.d0
+
+ x_superbrick(47) = 0.d0
+ y_superbrick(47) = 1.d0
+ z_superbrick(47) = 2.d0
+
+ x_superbrick(48) = 0.d0
+ y_superbrick(48) = 1.d0
+ z_superbrick(48) = 1.d0
+
+ x_superbrick(49) = 0.d0
+ y_superbrick(49) = 3.d0 / 2.d0
+ z_superbrick(49) = 1.d0
+
+ x_superbrick(50) = 0.d0
+ y_superbrick(50) = 3.d0 / 2.d0
+ z_superbrick(50) = 2.d0
+
+ x_superbrick(51) = 1.d0 / 2.d0
+ y_superbrick(51) = 2.d0
+ z_superbrick(51) = 1.d0
+
+ x_superbrick(52) = 1.d0 / 2.d0
+ y_superbrick(52) = 2.d0
+ z_superbrick(52) = 2.d0
+
+ x_superbrick(53) = 0.d0
+ y_superbrick(53) = 2.d0
+ z_superbrick(53) = 1.d0 / 2.d0
+
+ x_superbrick(54) = 0.d0
+ y_superbrick(54) = 2.d0
+ z_superbrick(54) = 2.d0
+
+ x_superbrick(55) = 1.d0 / 2.d0
+ y_superbrick(55) = 1.d0
+ z_superbrick(55) = 1.d0
+
+ x_superbrick(56) = 0.d0
+ y_superbrick(56) = 1.d0
+ z_superbrick(56) = 1.d0 / 2.d0
+
+ x_superbrick(57) = 0.d0
+ y_superbrick(57) = 1.d0
+ z_superbrick(57) = 0.d0
+
+ x_superbrick(58) = 0.d0
+ y_superbrick(58) = 2.d0
+ z_superbrick(58) = 0.d0
+
+ x_superbrick(59) = 1.d0 / 2.d0
+ y_superbrick(59) = 1.d0 / 2.d0
+ z_superbrick(59) = 3.d0 / 2.d0
+
+ x_superbrick(60) = 1.d0 / 2.d0
+ y_superbrick(60) = 1.d0 / 2.d0
+ z_superbrick(60) = 2.d0
+
+ x_superbrick(61) = 0.d0
+ y_superbrick(61) = 1.d0 / 2.d0
+ z_superbrick(61) = 1.d0
+
+ x_superbrick(62) = 0.d0
+ y_superbrick(62) = 1.d0 / 2.d0
+ z_superbrick(62) = 2.d0
+
+ x_superbrick(63) = 1.d0 / 2.d0
+ y_superbrick(63) = 0.d0
+ z_superbrick(63) = 1.d0
+
+ x_superbrick(64) = 1.d0 / 2.d0
+ y_superbrick(64) = 0.d0
+ z_superbrick(64) = 2.d0
+
+ x_superbrick(65) = 0.d0
+ y_superbrick(65) = 0.d0
+ z_superbrick(65) = 1.d0 / 2.d0
+
+ x_superbrick(66) = 0.d0
+ y_superbrick(66) = 0.d0
+ z_superbrick(66) = 2.d0
+
+ x_superbrick(67) = 0.d0
+ y_superbrick(67) = 0.d0
+ z_superbrick(67) = 0.d0
+
+ ibool_superbrick(1, 1) = 2
+ ibool_superbrick(2, 1) = 6
+ ibool_superbrick(3, 1) = 7
+ ibool_superbrick(4, 1) = 3
+ ibool_superbrick(5, 1) = 1
+ ibool_superbrick(6, 1) = 5
+ ibool_superbrick(7, 1) = 8
+ ibool_superbrick(8, 1) = 4
+
+ ibool_superbrick(1, 2) = 3
+ ibool_superbrick(2, 2) = 7
+ ibool_superbrick(3, 2) = 11
+ ibool_superbrick(4, 2) = 9
+ ibool_superbrick(5, 2) = 4
+ ibool_superbrick(6, 2) = 8
+ ibool_superbrick(7, 2) = 12
+ ibool_superbrick(8, 2) = 10
+
+ ibool_superbrick(1, 3) = 14
+ ibool_superbrick(2, 3) = 18
+ ibool_superbrick(3, 3) = 11
+ ibool_superbrick(4, 3) = 15
+ ibool_superbrick(5, 3) = 13
+ ibool_superbrick(6, 3) = 17
+ ibool_superbrick(7, 3) = 9
+ ibool_superbrick(8, 3) = 16
+
+ ibool_superbrick(1, 4) = 19
+ ibool_superbrick(2, 4) = 2
+ ibool_superbrick(3, 4) = 3
+ ibool_superbrick(4, 4) = 21
+ ibool_superbrick(5, 4) = 20
+ ibool_superbrick(6, 4) = 1
+ ibool_superbrick(7, 4) = 4
+ ibool_superbrick(8, 4) = 22
+
+ ibool_superbrick(1, 5) = 17
+ ibool_superbrick(2, 5) = 18
+ ibool_superbrick(3, 5) = 11
+ ibool_superbrick(4, 5) = 9
+ ibool_superbrick(5, 5) = 2
+ ibool_superbrick(6, 5) = 6
+ ibool_superbrick(7, 5) = 7
+ ibool_superbrick(8, 5) = 3
+
+ ibool_superbrick(1, 6) = 21
+ ibool_superbrick(2, 6) = 3
+ ibool_superbrick(3, 6) = 9
+ ibool_superbrick(4, 6) = 16
+ ibool_superbrick(5, 6) = 22
+ ibool_superbrick(6, 6) = 4
+ ibool_superbrick(7, 6) = 10
+ ibool_superbrick(8, 6) = 23
+
+ ibool_superbrick(1, 7) = 13
+ ibool_superbrick(2, 7) = 17
+ ibool_superbrick(3, 7) = 9
+ ibool_superbrick(4, 7) = 16
+ ibool_superbrick(5, 7) = 19
+ ibool_superbrick(6, 7) = 2
+ ibool_superbrick(7, 7) = 3
+ ibool_superbrick(8, 7) = 21
+
+ ibool_superbrick(1, 8) = 24
+ ibool_superbrick(2, 8) = 25
+ ibool_superbrick(3, 8) = 26
+ ibool_superbrick(4, 8) = 27
+ ibool_superbrick(5, 8) = 14
+ ibool_superbrick(6, 8) = 18
+ ibool_superbrick(7, 8) = 11
+ ibool_superbrick(8, 8) = 15
+
+ ibool_superbrick(1, 9) = 28
+ ibool_superbrick(2, 9) = 30
+ ibool_superbrick(3, 9) = 6
+ ibool_superbrick(4, 9) = 2
+ ibool_superbrick(5, 9) = 29
+ ibool_superbrick(6, 9) = 31
+ ibool_superbrick(7, 9) = 5
+ ibool_superbrick(8, 9) = 1
+
+ ibool_superbrick(1, 10) = 32
+ ibool_superbrick(2, 10) = 34
+ ibool_superbrick(3, 10) = 30
+ ibool_superbrick(4, 10) = 28
+ ibool_superbrick(5, 10) = 33
+ ibool_superbrick(6, 10) = 35
+ ibool_superbrick(7, 10) = 31
+ ibool_superbrick(8, 10) = 29
+
+ ibool_superbrick(1, 11) = 36
+ ibool_superbrick(2, 11) = 34
+ ibool_superbrick(3, 11) = 18
+ ibool_superbrick(4, 11) = 14
+ ibool_superbrick(5, 11) = 37
+ ibool_superbrick(6, 11) = 32
+ ibool_superbrick(7, 11) = 17
+ ibool_superbrick(8, 11) = 13
+
+ ibool_superbrick(1, 12) = 38
+ ibool_superbrick(2, 12) = 28
+ ibool_superbrick(3, 12) = 2
+ ibool_superbrick(4, 12) = 19
+ ibool_superbrick(5, 12) = 39
+ ibool_superbrick(6, 12) = 29
+ ibool_superbrick(7, 12) = 1
+ ibool_superbrick(8, 12) = 20
+
+ ibool_superbrick(1, 13) = 32
+ ibool_superbrick(2, 13) = 34
+ ibool_superbrick(3, 13) = 18
+ ibool_superbrick(4, 13) = 17
+ ibool_superbrick(5, 13) = 28
+ ibool_superbrick(6, 13) = 30
+ ibool_superbrick(7, 13) = 6
+ ibool_superbrick(8, 13) = 2
+
+ ibool_superbrick(1, 14) = 37
+ ibool_superbrick(2, 14) = 32
+ ibool_superbrick(3, 14) = 28
+ ibool_superbrick(4, 14) = 38
+ ibool_superbrick(5, 14) = 40
+ ibool_superbrick(6, 14) = 33
+ ibool_superbrick(7, 14) = 29
+ ibool_superbrick(8, 14) = 39
+
+ ibool_superbrick(1, 15) = 37
+ ibool_superbrick(2, 15) = 32
+ ibool_superbrick(3, 15) = 17
+ ibool_superbrick(4, 15) = 13
+ ibool_superbrick(5, 15) = 38
+ ibool_superbrick(6, 15) = 28
+ ibool_superbrick(7, 15) = 2
+ ibool_superbrick(8, 15) = 19
+
+ ibool_superbrick(1, 16) = 42
+ ibool_superbrick(2, 16) = 41
+ ibool_superbrick(3, 16) = 25
+ ibool_superbrick(4, 16) = 24
+ ibool_superbrick(5, 16) = 36
+ ibool_superbrick(6, 16) = 34
+ ibool_superbrick(7, 16) = 18
+ ibool_superbrick(8, 16) = 14
+
+ ibool_superbrick(1, 17) = 48
+ ibool_superbrick(2, 17) = 44
+ ibool_superbrick(3, 17) = 45
+ ibool_superbrick(4, 17) = 49
+ ibool_superbrick(5, 17) = 47
+ ibool_superbrick(6, 17) = 43
+ ibool_superbrick(7, 17) = 46
+ ibool_superbrick(8, 17) = 50
+
+ ibool_superbrick(1, 18) = 49
+ ibool_superbrick(2, 18) = 45
+ ibool_superbrick(3, 18) = 51
+ ibool_superbrick(4, 18) = 53
+ ibool_superbrick(5, 18) = 50
+ ibool_superbrick(6, 18) = 46
+ ibool_superbrick(7, 18) = 52
+ ibool_superbrick(8, 18) = 54
+
+ ibool_superbrick(1, 19) = 56
+ ibool_superbrick(2, 19) = 14
+ ibool_superbrick(3, 19) = 15
+ ibool_superbrick(4, 19) = 53
+ ibool_superbrick(5, 19) = 55
+ ibool_superbrick(6, 19) = 13
+ ibool_superbrick(7, 19) = 16
+ ibool_superbrick(8, 19) = 51
+
+ ibool_superbrick(1, 20) = 44
+ ibool_superbrick(2, 20) = 19
+ ibool_superbrick(3, 20) = 21
+ ibool_superbrick(4, 20) = 45
+ ibool_superbrick(5, 20) = 43
+ ibool_superbrick(6, 20) = 20
+ ibool_superbrick(7, 20) = 22
+ ibool_superbrick(8, 20) = 46
+
+ ibool_superbrick(1, 21) = 56
+ ibool_superbrick(2, 21) = 55
+ ibool_superbrick(3, 21) = 51
+ ibool_superbrick(4, 21) = 53
+ ibool_superbrick(5, 21) = 48
+ ibool_superbrick(6, 21) = 44
+ ibool_superbrick(7, 21) = 45
+ ibool_superbrick(8, 21) = 49
+
+ ibool_superbrick(1, 22) = 45
+ ibool_superbrick(2, 22) = 21
+ ibool_superbrick(3, 22) = 16
+ ibool_superbrick(4, 22) = 51
+ ibool_superbrick(5, 22) = 46
+ ibool_superbrick(6, 22) = 22
+ ibool_superbrick(7, 22) = 23
+ ibool_superbrick(8, 22) = 52
+
+ ibool_superbrick(1, 23) = 55
+ ibool_superbrick(2, 23) = 13
+ ibool_superbrick(3, 23) = 16
+ ibool_superbrick(4, 23) = 51
+ ibool_superbrick(5, 23) = 44
+ ibool_superbrick(6, 23) = 19
+ ibool_superbrick(7, 23) = 21
+ ibool_superbrick(8, 23) = 45
+
+ ibool_superbrick(1, 24) = 57
+ ibool_superbrick(2, 24) = 24
+ ibool_superbrick(3, 24) = 27
+ ibool_superbrick(4, 24) = 58
+ ibool_superbrick(5, 24) = 56
+ ibool_superbrick(6, 24) = 14
+ ibool_superbrick(7, 24) = 15
+ ibool_superbrick(8, 24) = 53
+
+ ibool_superbrick(1, 25) = 61
+ ibool_superbrick(2, 25) = 59
+ ibool_superbrick(3, 25) = 44
+ ibool_superbrick(4, 25) = 48
+ ibool_superbrick(5, 25) = 62
+ ibool_superbrick(6, 25) = 60
+ ibool_superbrick(7, 25) = 43
+ ibool_superbrick(8, 25) = 47
+
+ ibool_superbrick(1, 26) = 65
+ ibool_superbrick(2, 26) = 63
+ ibool_superbrick(3, 26) = 59
+ ibool_superbrick(4, 26) = 61
+ ibool_superbrick(5, 26) = 66
+ ibool_superbrick(6, 26) = 64
+ ibool_superbrick(7, 26) = 60
+ ibool_superbrick(8, 26) = 62
+
+ ibool_superbrick(1, 27) = 65
+ ibool_superbrick(2, 27) = 36
+ ibool_superbrick(3, 27) = 14
+ ibool_superbrick(4, 27) = 56
+ ibool_superbrick(5, 27) = 63
+ ibool_superbrick(6, 27) = 37
+ ibool_superbrick(7, 27) = 13
+ ibool_superbrick(8, 27) = 55
+
+ ibool_superbrick(1, 28) = 59
+ ibool_superbrick(2, 28) = 38
+ ibool_superbrick(3, 28) = 19
+ ibool_superbrick(4, 28) = 44
+ ibool_superbrick(5, 28) = 60
+ ibool_superbrick(6, 28) = 39
+ ibool_superbrick(7, 28) = 20
+ ibool_superbrick(8, 28) = 43
+
+ ibool_superbrick(1, 29) = 65
+ ibool_superbrick(2, 29) = 63
+ ibool_superbrick(3, 29) = 55
+ ibool_superbrick(4, 29) = 56
+ ibool_superbrick(5, 29) = 61
+ ibool_superbrick(6, 29) = 59
+ ibool_superbrick(7, 29) = 44
+ ibool_superbrick(8, 29) = 48
+
+ ibool_superbrick(1, 30) = 63
+ ibool_superbrick(2, 30) = 37
+ ibool_superbrick(3, 30) = 38
+ ibool_superbrick(4, 30) = 59
+ ibool_superbrick(5, 30) = 64
+ ibool_superbrick(6, 30) = 40
+ ibool_superbrick(7, 30) = 39
+ ibool_superbrick(8, 30) = 60
+
+ ibool_superbrick(1, 31) = 63
+ ibool_superbrick(2, 31) = 37
+ ibool_superbrick(3, 31) = 13
+ ibool_superbrick(4, 31) = 55
+ ibool_superbrick(5, 31) = 59
+ ibool_superbrick(6, 31) = 38
+ ibool_superbrick(7, 31) = 19
+ ibool_superbrick(8, 31) = 44
+
+ ibool_superbrick(1, 32) = 67
+ ibool_superbrick(2, 32) = 42
+ ibool_superbrick(3, 32) = 24
+ ibool_superbrick(4, 32) = 57
+ ibool_superbrick(5, 32) = 65
+ ibool_superbrick(6, 32) = 36
+ ibool_superbrick(7, 32) = 14
+ ibool_superbrick(8, 32) = 56
+
+
+ iboun_sb(:,:) = .false.
+
+ iboun_sb(1,2) = .true.
+ iboun_sb(1,6) = .true.
+ iboun_sb(2,2) = .true.
+ iboun_sb(2,4) = .true.
+ iboun_sb(2,6) = .true.
+ iboun_sb(3,4) = .true.
+ iboun_sb(4,6) = .true.
+ iboun_sb(5,2) = .true.
+ iboun_sb(6,4) = .true.
+ iboun_sb(6,6) = .true.
+ iboun_sb(8,2) = .true.
+ iboun_sb(8,4) = .true.
+ iboun_sb(8,5) = .true.
+ iboun_sb(9,2) = .true.
+ iboun_sb(9,6) = .true.
+ iboun_sb(10,2) = .true.
+ iboun_sb(10,3) = .true.
+ iboun_sb(10,6) = .true.
+ iboun_sb(11,3) = .true.
+ iboun_sb(12,6) = .true.
+ iboun_sb(13,2) = .true.
+ iboun_sb(14,3) = .true.
+ iboun_sb(14,6) = .true.
+ iboun_sb(16,2) = .true.
+ iboun_sb(16,3) = .true.
+ iboun_sb(16,5) = .true.
+ iboun_sb(17,1) = .true.
+ iboun_sb(17,6) = .true.
+ iboun_sb(18,1) = .true.
+ iboun_sb(18,4) = .true.
+ iboun_sb(18,6) = .true.
+ iboun_sb(19,4) = .true.
+ iboun_sb(20,6) = .true.
+ iboun_sb(21,1) = .true.
+ iboun_sb(22,4) = .true.
+ iboun_sb(22,6) = .true.
+ iboun_sb(24,1) = .true.
+ iboun_sb(24,4) = .true.
+ iboun_sb(24,5) = .true.
+ iboun_sb(25,1) = .true.
+ iboun_sb(25,6) = .true.
+ iboun_sb(26,1) = .true.
+ iboun_sb(26,3) = .true.
+ iboun_sb(26,6) = .true.
+ iboun_sb(27,3) = .true.
+ iboun_sb(28,6) = .true.
+ iboun_sb(29,1) = .true.
+ iboun_sb(30,3) = .true.
+ iboun_sb(30,6) = .true.
+ iboun_sb(32,1) = .true.
+ iboun_sb(32,3) = .true.
+ iboun_sb(32,5) = .true.
+
+ end subroutine define_superbrick
+
+
+ subroutine define_superbrick_one_layer(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, dimension(NGNOD_EIGHT_CORNERS,NSPEC_DOUBLING_SUPERBRICK) :: ibool_superbrick
+ double precision, dimension(NGLOB_DOUBLING_SUPERBRICK) :: x_superbrick,y_superbrick,z_superbrick
+ logical, dimension(NSPEC_DOUBLING_SUPERBRICK,6) :: iboun_sb
+
+x_superbrick(1) = 3.d0 / 2.d0
+y_superbrick(1) = 1.d0
+z_superbrick(1) = 1.d0
+
+x_superbrick(2) = 3.d0 / 2.d0
+y_superbrick(2) = 1.d0
+z_superbrick(2) = 2.d0 / 3.d0
+
+x_superbrick(3) = 3.d0 / 2.d0
+y_superbrick(3) = 3.d0 / 2.d0
+z_superbrick(3) = 2.d0 / 3.d0
+
+x_superbrick(4) = 3.d0 / 2.d0
+y_superbrick(4) = 3.d0 / 2.d0
+z_superbrick(4) = 1.d0
+
+x_superbrick(5) = 2.d0
+y_superbrick(5) = 1.d0
+z_superbrick(5) = 1.d0
+
+x_superbrick(6) = 2.d0
+y_superbrick(6) = 1.d0
+z_superbrick(6) = 1.d0 / 3.d0
+
+x_superbrick(7) = 2.d0
+y_superbrick(7) = 3.d0 / 2.d0
+z_superbrick(7) = 1.d0 / 3.d0
+
+x_superbrick(8) = 2.d0
+y_superbrick(8) = 3.d0 / 2.d0
+z_superbrick(8) = 1.d0
+
+x_superbrick(9) = 3.d0 / 2.d0
+y_superbrick(9) = 2.d0
+z_superbrick(9) = 1.d0 / 3.d0
+
+x_superbrick(10) = 3.d0 / 2.d0
+y_superbrick(10) = 2.d0
+z_superbrick(10) = 1.d0
+
+x_superbrick(11) = 2.d0
+y_superbrick(11) = 2.d0
+z_superbrick(11) = 0.d0
+
+x_superbrick(12) = 2.d0
+y_superbrick(12) = 2.d0
+z_superbrick(12) = 1.d0
+
+x_superbrick(13) = 1.d0
+y_superbrick(13) = 1.d0
+z_superbrick(13) = 1.d0 / 3.d0
+
+x_superbrick(14) = 1.d0
+y_superbrick(14) = 1.d0
+z_superbrick(14) = 0.d0
+
+x_superbrick(15) = 1.d0
+y_superbrick(15) = 2.d0
+z_superbrick(15) = 0.d0
+
+x_superbrick(16) = 1.d0
+y_superbrick(16) = 2.d0
+z_superbrick(16) = 1.d0 / 3.d0
+
+x_superbrick(17) = 3.d0 / 2.d0
+y_superbrick(17) = 1.d0
+z_superbrick(17) = 1.d0 / 3.d0
+
+x_superbrick(18) = 2.d0
+y_superbrick(18) = 1.d0
+z_superbrick(18) = 0.d0
+
+x_superbrick(19) = 1.d0
+y_superbrick(19) = 1.d0
+z_superbrick(19) = 2.d0 / 3.d0
+
+x_superbrick(20) = 1.d0
+y_superbrick(20) = 1.d0
+z_superbrick(20) = 1.d0
+
+x_superbrick(21) = 1.d0
+y_superbrick(21) = 3.d0 / 2.d0
+z_superbrick(21) = 2.d0 / 3.d0
+
+x_superbrick(22) = 1.d0
+y_superbrick(22) = 3.d0 / 2.d0
+z_superbrick(22) = 1.d0
+
+x_superbrick(23) = 1.d0
+y_superbrick(23) = 2.d0
+z_superbrick(23) = 1.d0
+
+x_superbrick(24) = 3.d0 / 2.d0
+y_superbrick(24) = 1.d0 / 2.d0
+z_superbrick(24) = 2.d0 / 3.d0
+
+x_superbrick(25) = 3.d0 / 2.d0
+y_superbrick(25) = 1.d0 / 2.d0
+z_superbrick(25) = 1.d0
+
+x_superbrick(26) = 2.d0
+y_superbrick(26) = 1.d0 / 2.d0
+z_superbrick(26) = 1.d0 / 3.d0
+
+x_superbrick(27) = 2.d0
+y_superbrick(27) = 1.d0 / 2.d0
+z_superbrick(27) = 1.d0
+
+x_superbrick(28) = 3.d0 / 2.d0
+y_superbrick(28) = 0.d0
+z_superbrick(28) = 1.d0 / 3.d0
+
+x_superbrick(29) = 3.d0 / 2.d0
+y_superbrick(29) = 0.d0
+z_superbrick(29) = 1.d0
+
+x_superbrick(30) = 2.d0
+y_superbrick(30) = 0.d0
+z_superbrick(30) = 0.d0
+
+x_superbrick(31) = 2.d0
+y_superbrick(31) = 0.d0
+z_superbrick(31) = 1.d0
+
+x_superbrick(32) = 1.d0
+y_superbrick(32) = 0.d0
+z_superbrick(32) = 0.d0
+
+x_superbrick(33) = 1.d0
+y_superbrick(33) = 0.d0
+z_superbrick(33) = 1.d0 / 3.d0
+
+x_superbrick(34) = 1.d0
+y_superbrick(34) = 1.d0 / 2.d0
+z_superbrick(34) = 2.d0 / 3.d0
+
+x_superbrick(35) = 1.d0
+y_superbrick(35) = 1.d0 / 2.d0
+z_superbrick(35) = 1.d0
+
+x_superbrick(36) = 1.d0
+y_superbrick(36) = 0.d0
+z_superbrick(36) = 1.d0
+
+x_superbrick(37) = 1.d0 / 2.d0
+y_superbrick(37) = 1.d0
+z_superbrick(37) = 1.d0
+
+x_superbrick(38) = 1.d0 / 2.d0
+y_superbrick(38) = 1.d0
+z_superbrick(38) = 2.d0 / 3.d0
+
+x_superbrick(39) = 1.d0 / 2.d0
+y_superbrick(39) = 3.d0 / 2.d0
+z_superbrick(39) = 2.d0 / 3.d0
+
+x_superbrick(40) = 1.d0 / 2.d0
+y_superbrick(40) = 3.d0 / 2.d0
+z_superbrick(40) = 1.d0
+
+x_superbrick(41) = 0.d0
+y_superbrick(41) = 1.d0
+z_superbrick(41) = 1.d0
+
+x_superbrick(42) = 0.d0
+y_superbrick(42) = 1.d0
+z_superbrick(42) = 1.d0 / 3.d0
+
+x_superbrick(43) = 0.d0
+y_superbrick(43) = 3.d0 / 2.d0
+z_superbrick(43) = 1.d0 / 3.d0
+
+x_superbrick(44) = 0.d0
+y_superbrick(44) = 3.d0 / 2.d0
+z_superbrick(44) = 1.d0
+
+x_superbrick(45) = 1.d0 / 2.d0
+y_superbrick(45) = 2.d0
+z_superbrick(45) = 1.d0 / 3.d0
+
+x_superbrick(46) = 1.d0 / 2.d0
+y_superbrick(46) = 2.d0
+z_superbrick(46) = 1.d0
+
+x_superbrick(47) = 0.d0
+y_superbrick(47) = 2.d0
+z_superbrick(47) = 0.d0
+
+x_superbrick(48) = 0.d0
+y_superbrick(48) = 2.d0
+z_superbrick(48) = 1.d0
+
+x_superbrick(49) = 1.d0 / 2.d0
+y_superbrick(49) = 1.d0
+z_superbrick(49) = 1.d0 / 3.d0
+
+x_superbrick(50) = 0.d0
+y_superbrick(50) = 1.d0
+z_superbrick(50) = 0.d0
+
+x_superbrick(51) = 1.d0 / 2.d0
+y_superbrick(51) = 1.d0 / 2.d0
+z_superbrick(51) = 2.d0 / 3.d0
+
+x_superbrick(52) = 1.d0 / 2.d0
+y_superbrick(52) = 1.d0 / 2.d0
+z_superbrick(52) = 1.d0
+
+x_superbrick(53) = 0.d0
+y_superbrick(53) = 1.d0 / 2.d0
+z_superbrick(53) = 1.d0 / 3.d0
+
+x_superbrick(54) = 0.d0
+y_superbrick(54) = 1.d0 / 2.d0
+z_superbrick(54) = 1.d0
+
+x_superbrick(55) = 1.d0 / 2.d0
+y_superbrick(55) = 0.d0
+z_superbrick(55) = 1.d0 / 3.d0
+
+x_superbrick(56) = 1.d0 / 2.d0
+y_superbrick(56) = 0.d0
+z_superbrick(56) = 1.d0
+
+x_superbrick(57) = 0.d0
+y_superbrick(57) = 0.d0
+z_superbrick(57) = 0.d0
+
+x_superbrick(58) = 0.d0
+y_superbrick(58) = 0.d0
+z_superbrick(58) = 1.d0
+
+ibool_superbrick(1, 1) = 2
+ibool_superbrick(2, 1) = 6
+ibool_superbrick(3, 1) = 7
+ibool_superbrick(4, 1) = 3
+ibool_superbrick(5, 1) = 1
+ibool_superbrick(6, 1) = 5
+ibool_superbrick(7, 1) = 8
+ibool_superbrick(8, 1) = 4
+
+ibool_superbrick(1, 2) = 3
+ibool_superbrick(2, 2) = 7
+ibool_superbrick(3, 2) = 11
+ibool_superbrick(4, 2) = 9
+ibool_superbrick(5, 2) = 4
+ibool_superbrick(6, 2) = 8
+ibool_superbrick(7, 2) = 12
+ibool_superbrick(8, 2) = 10
+
+ibool_superbrick(1, 3) = 14
+ibool_superbrick(2, 3) = 18
+ibool_superbrick(3, 3) = 11
+ibool_superbrick(4, 3) = 15
+ibool_superbrick(5, 3) = 13
+ibool_superbrick(6, 3) = 17
+ibool_superbrick(7, 3) = 9
+ibool_superbrick(8, 3) = 16
+
+ibool_superbrick(1, 4) = 19
+ibool_superbrick(2, 4) = 2
+ibool_superbrick(3, 4) = 3
+ibool_superbrick(4, 4) = 21
+ibool_superbrick(5, 4) = 20
+ibool_superbrick(6, 4) = 1
+ibool_superbrick(7, 4) = 4
+ibool_superbrick(8, 4) = 22
+
+ibool_superbrick(1, 5) = 17
+ibool_superbrick(2, 5) = 18
+ibool_superbrick(3, 5) = 11
+ibool_superbrick(4, 5) = 9
+ibool_superbrick(5, 5) = 2
+ibool_superbrick(6, 5) = 6
+ibool_superbrick(7, 5) = 7
+ibool_superbrick(8, 5) = 3
+
+ibool_superbrick(1, 6) = 21
+ibool_superbrick(2, 6) = 3
+ibool_superbrick(3, 6) = 9
+ibool_superbrick(4, 6) = 16
+ibool_superbrick(5, 6) = 22
+ibool_superbrick(6, 6) = 4
+ibool_superbrick(7, 6) = 10
+ibool_superbrick(8, 6) = 23
+
+ibool_superbrick(1, 7) = 13
+ibool_superbrick(2, 7) = 17
+ibool_superbrick(3, 7) = 9
+ibool_superbrick(4, 7) = 16
+ibool_superbrick(5, 7) = 19
+ibool_superbrick(6, 7) = 2
+ibool_superbrick(7, 7) = 3
+ibool_superbrick(8, 7) = 21
+
+ibool_superbrick(1, 8) = 24
+ibool_superbrick(2, 8) = 26
+ibool_superbrick(3, 8) = 6
+ibool_superbrick(4, 8) = 2
+ibool_superbrick(5, 8) = 25
+ibool_superbrick(6, 8) = 27
+ibool_superbrick(7, 8) = 5
+ibool_superbrick(8, 8) = 1
+
+ibool_superbrick(1, 9) = 28
+ibool_superbrick(2, 9) = 30
+ibool_superbrick(3, 9) = 26
+ibool_superbrick(4, 9) = 24
+ibool_superbrick(5, 9) = 29
+ibool_superbrick(6, 9) = 31
+ibool_superbrick(7, 9) = 27
+ibool_superbrick(8, 9) = 25
+
+ibool_superbrick(1, 10) = 32
+ibool_superbrick(2, 10) = 30
+ibool_superbrick(3, 10) = 18
+ibool_superbrick(4, 10) = 14
+ibool_superbrick(5, 10) = 33
+ibool_superbrick(6, 10) = 28
+ibool_superbrick(7, 10) = 17
+ibool_superbrick(8, 10) = 13
+
+ibool_superbrick(1, 11) = 34
+ibool_superbrick(2, 11) = 24
+ibool_superbrick(3, 11) = 2
+ibool_superbrick(4, 11) = 19
+ibool_superbrick(5, 11) = 35
+ibool_superbrick(6, 11) = 25
+ibool_superbrick(7, 11) = 1
+ibool_superbrick(8, 11) = 20
+
+ibool_superbrick(1, 12) = 28
+ibool_superbrick(2, 12) = 30
+ibool_superbrick(3, 12) = 18
+ibool_superbrick(4, 12) = 17
+ibool_superbrick(5, 12) = 24
+ibool_superbrick(6, 12) = 26
+ibool_superbrick(7, 12) = 6
+ibool_superbrick(8, 12) = 2
+
+ibool_superbrick(1, 13) = 33
+ibool_superbrick(2, 13) = 28
+ibool_superbrick(3, 13) = 24
+ibool_superbrick(4, 13) = 34
+ibool_superbrick(5, 13) = 36
+ibool_superbrick(6, 13) = 29
+ibool_superbrick(7, 13) = 25
+ibool_superbrick(8, 13) = 35
+
+ibool_superbrick(1, 14) = 33
+ibool_superbrick(2, 14) = 28
+ibool_superbrick(3, 14) = 17
+ibool_superbrick(4, 14) = 13
+ibool_superbrick(5, 14) = 34
+ibool_superbrick(6, 14) = 24
+ibool_superbrick(7, 14) = 2
+ibool_superbrick(8, 14) = 19
+
+ibool_superbrick(1, 15) = 42
+ibool_superbrick(2, 15) = 38
+ibool_superbrick(3, 15) = 39
+ibool_superbrick(4, 15) = 43
+ibool_superbrick(5, 15) = 41
+ibool_superbrick(6, 15) = 37
+ibool_superbrick(7, 15) = 40
+ibool_superbrick(8, 15) = 44
+
+ibool_superbrick(1, 16) = 43
+ibool_superbrick(2, 16) = 39
+ibool_superbrick(3, 16) = 45
+ibool_superbrick(4, 16) = 47
+ibool_superbrick(5, 16) = 44
+ibool_superbrick(6, 16) = 40
+ibool_superbrick(7, 16) = 46
+ibool_superbrick(8, 16) = 48
+
+ibool_superbrick(1, 17) = 50
+ibool_superbrick(2, 17) = 14
+ibool_superbrick(3, 17) = 15
+ibool_superbrick(4, 17) = 47
+ibool_superbrick(5, 17) = 49
+ibool_superbrick(6, 17) = 13
+ibool_superbrick(7, 17) = 16
+ibool_superbrick(8, 17) = 45
+
+ibool_superbrick(1, 18) = 38
+ibool_superbrick(2, 18) = 19
+ibool_superbrick(3, 18) = 21
+ibool_superbrick(4, 18) = 39
+ibool_superbrick(5, 18) = 37
+ibool_superbrick(6, 18) = 20
+ibool_superbrick(7, 18) = 22
+ibool_superbrick(8, 18) = 40
+
+ibool_superbrick(1, 19) = 50
+ibool_superbrick(2, 19) = 49
+ibool_superbrick(3, 19) = 45
+ibool_superbrick(4, 19) = 47
+ibool_superbrick(5, 19) = 42
+ibool_superbrick(6, 19) = 38
+ibool_superbrick(7, 19) = 39
+ibool_superbrick(8, 19) = 43
+
+ibool_superbrick(1, 20) = 39
+ibool_superbrick(2, 20) = 21
+ibool_superbrick(3, 20) = 16
+ibool_superbrick(4, 20) = 45
+ibool_superbrick(5, 20) = 40
+ibool_superbrick(6, 20) = 22
+ibool_superbrick(7, 20) = 23
+ibool_superbrick(8, 20) = 46
+
+ibool_superbrick(1, 21) = 49
+ibool_superbrick(2, 21) = 13
+ibool_superbrick(3, 21) = 16
+ibool_superbrick(4, 21) = 45
+ibool_superbrick(5, 21) = 38
+ibool_superbrick(6, 21) = 19
+ibool_superbrick(7, 21) = 21
+ibool_superbrick(8, 21) = 39
+
+ibool_superbrick(1, 22) = 53
+ibool_superbrick(2, 22) = 51
+ibool_superbrick(3, 22) = 38
+ibool_superbrick(4, 22) = 42
+ibool_superbrick(5, 22) = 54
+ibool_superbrick(6, 22) = 52
+ibool_superbrick(7, 22) = 37
+ibool_superbrick(8, 22) = 41
+
+ibool_superbrick(1, 23) = 57
+ibool_superbrick(2, 23) = 55
+ibool_superbrick(3, 23) = 51
+ibool_superbrick(4, 23) = 53
+ibool_superbrick(5, 23) = 58
+ibool_superbrick(6, 23) = 56
+ibool_superbrick(7, 23) = 52
+ibool_superbrick(8, 23) = 54
+
+ibool_superbrick(1, 24) = 57
+ibool_superbrick(2, 24) = 32
+ibool_superbrick(3, 24) = 14
+ibool_superbrick(4, 24) = 50
+ibool_superbrick(5, 24) = 55
+ibool_superbrick(6, 24) = 33
+ibool_superbrick(7, 24) = 13
+ibool_superbrick(8, 24) = 49
+
+ibool_superbrick(1, 25) = 51
+ibool_superbrick(2, 25) = 34
+ibool_superbrick(3, 25) = 19
+ibool_superbrick(4, 25) = 38
+ibool_superbrick(5, 25) = 52
+ibool_superbrick(6, 25) = 35
+ibool_superbrick(7, 25) = 20
+ibool_superbrick(8, 25) = 37
+
+ibool_superbrick(1, 26) = 57
+ibool_superbrick(2, 26) = 55
+ibool_superbrick(3, 26) = 49
+ibool_superbrick(4, 26) = 50
+ibool_superbrick(5, 26) = 53
+ibool_superbrick(6, 26) = 51
+ibool_superbrick(7, 26) = 38
+ibool_superbrick(8, 26) = 42
+
+ibool_superbrick(1, 27) = 55
+ibool_superbrick(2, 27) = 33
+ibool_superbrick(3, 27) = 34
+ibool_superbrick(4, 27) = 51
+ibool_superbrick(5, 27) = 56
+ibool_superbrick(6, 27) = 36
+ibool_superbrick(7, 27) = 35
+ibool_superbrick(8, 27) = 52
+
+ibool_superbrick(1, 28) = 55
+ibool_superbrick(2, 28) = 33
+ibool_superbrick(3, 28) = 13
+ibool_superbrick(4, 28) = 49
+ibool_superbrick(5, 28) = 51
+ibool_superbrick(6, 28) = 34
+ibool_superbrick(7, 28) = 19
+ibool_superbrick(8, 28) = 38
+
+iboun_sb(:,:) = .false.
+iboun_sb(1,2) = .true.
+iboun_sb(1,6) = .true.
+iboun_sb(2,2) = .true.
+iboun_sb(2,4) = .true.
+iboun_sb(2,6) = .true.
+iboun_sb(3,4) = .true.
+iboun_sb(3,5) = .true.
+iboun_sb(4,6) = .true.
+iboun_sb(5,2) = .true.
+iboun_sb(6,4) = .true.
+iboun_sb(6,6) = .true.
+iboun_sb(8,2) = .true.
+iboun_sb(8,6) = .true.
+iboun_sb(9,2) = .true.
+iboun_sb(9,3) = .true.
+iboun_sb(9,6) = .true.
+iboun_sb(10,3) = .true.
+iboun_sb(10,5) = .true.
+iboun_sb(11,6) = .true.
+iboun_sb(12,2) = .true.
+iboun_sb(13,3) = .true.
+iboun_sb(13,6) = .true.
+iboun_sb(15,1) = .true.
+iboun_sb(15,6) = .true.
+iboun_sb(16,1) = .true.
+iboun_sb(16,4) = .true.
+iboun_sb(16,6) = .true.
+iboun_sb(17,4) = .true.
+iboun_sb(17,5) = .true.
+iboun_sb(18,6) = .true.
+iboun_sb(19,1) = .true.
+iboun_sb(20,4) = .true.
+iboun_sb(20,6) = .true.
+iboun_sb(22,1) = .true.
+iboun_sb(22,6) = .true.
+iboun_sb(23,1) = .true.
+iboun_sb(23,3) = .true.
+iboun_sb(23,6) = .true.
+iboun_sb(24,3) = .true.
+iboun_sb(24,5) = .true.
+iboun_sb(25,6) = .true.
+iboun_sb(26,1) = .true.
+iboun_sb(27,3) = .true.
+iboun_sb(27,6) = .true.
+
+end subroutine define_superbrick_one_layer
+
+
+subroutine define_basic_doubling_brick(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb,case_num)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, dimension(NGNOD_EIGHT_CORNERS,NSPEC_DOUBLING_SUPERBRICK) :: ibool_superbrick
+ double precision, dimension(NGLOB_DOUBLING_SUPERBRICK) :: x_superbrick,y_superbrick,z_superbrick
+ logical, dimension(NSPEC_DOUBLING_SUPERBRICK,6) :: iboun_sb
+ integer :: case_num
+
+ SELECT CASE (case_num)
+ CASE (1)
+ x_superbrick(1) = 1.d0 / 2.d0
+ y_superbrick(1) = 1.d0
+ z_superbrick(1) = 2.d0
+
+ x_superbrick(2) = 1.d0 / 2.d0
+ y_superbrick(2) = 1.d0
+ z_superbrick(2) = 3.d0 / 2.d0
+
+ x_superbrick(3) = 1.d0 / 2.d0
+ y_superbrick(3) = 1.d0 / 2.d0
+ z_superbrick(3) = 3.d0 / 2.d0
+
+ x_superbrick(4) = 1.d0 / 2.d0
+ y_superbrick(4) = 1.d0 / 2.d0
+ z_superbrick(4) = 2.d0
+
+ x_superbrick(5) = 0.d0
+ y_superbrick(5) = 1.d0
+ z_superbrick(5) = 2.d0
+
+ x_superbrick(6) = 0.d0
+ y_superbrick(6) = 1.d0
+ z_superbrick(6) = 1.d0
+
+ x_superbrick(7) = 0.d0
+ y_superbrick(7) = 1.d0 / 2.d0
+ z_superbrick(7) = 1.d0
+
+ x_superbrick(8) = 0.d0
+ y_superbrick(8) = 1.d0 / 2.d0
+ z_superbrick(8) = 2.d0
+
+ x_superbrick(9) = 1.d0 / 2.d0
+ y_superbrick(9) = 0.d0
+ z_superbrick(9) = 1.d0
+
+ x_superbrick(10) = 1.d0 / 2.d0
+ y_superbrick(10) = 0.d0
+ z_superbrick(10) = 2.d0
+
+ x_superbrick(11) = 0.d0
+ y_superbrick(11) = 0.d0
+ z_superbrick(11) = 1.d0 / 2.d0
+
+ x_superbrick(12) = 0.d0
+ y_superbrick(12) = 0.d0
+ z_superbrick(12) = 2.d0
+
+ x_superbrick(13) = 1.d0
+ y_superbrick(13) = 1.d0
+ z_superbrick(13) = 1.d0
+
+ x_superbrick(14) = 1.d0
+ y_superbrick(14) = 1.d0
+ z_superbrick(14) = 1.d0 / 2.d0
+
+ x_superbrick(15) = 1.d0
+ y_superbrick(15) = 0.d0
+ z_superbrick(15) = 1.d0 / 2.d0
+
+ x_superbrick(16) = 1.d0
+ y_superbrick(16) = 0.d0
+ z_superbrick(16) = 1.d0
+
+ x_superbrick(17) = 1.d0 / 2.d0
+ y_superbrick(17) = 1.d0
+ z_superbrick(17) = 1.d0
+
+ x_superbrick(18) = 0.d0
+ y_superbrick(18) = 1.d0
+ z_superbrick(18) = 1.d0 / 2.d0
+
+ x_superbrick(19) = 1.d0
+ y_superbrick(19) = 1.d0
+ z_superbrick(19) = 3.d0 / 2.d0
+
+ x_superbrick(20) = 1.d0
+ y_superbrick(20) = 1.d0
+ z_superbrick(20) = 2.d0
+
+ x_superbrick(21) = 1.d0
+ y_superbrick(21) = 1.d0 / 2.d0
+ z_superbrick(21) = 3.d0 / 2.d0
+
+ x_superbrick(22) = 1.d0
+ y_superbrick(22) = 1.d0 / 2.d0
+ z_superbrick(22) = 2.d0
+
+ x_superbrick(23) = 1.d0
+ y_superbrick(23) = 0.d0
+ z_superbrick(23) = 2.d0
+
+ x_superbrick(24) = 1.d0
+ y_superbrick(24) = 1.d0
+ z_superbrick(24) = 0.d0
+
+ x_superbrick(25) = 0.d0
+ y_superbrick(25) = 1.d0
+ z_superbrick(25) = 0.d0
+
+ x_superbrick(26) = 0.d0
+ y_superbrick(26) = 0.d0
+ z_superbrick(26) = 0.d0
+
+ x_superbrick(27) = 1.d0
+ y_superbrick(27) = 0.d0
+ z_superbrick(27) = 0.d0
+
+ ibool_superbrick(1, 1) = 7
+ ibool_superbrick(2, 1) = 3
+ ibool_superbrick(3, 1) = 2
+ ibool_superbrick(4, 1) = 6
+ ibool_superbrick(5, 1) = 8
+ ibool_superbrick(6, 1) = 4
+ ibool_superbrick(7, 1) = 1
+ ibool_superbrick(8, 1) = 5
+
+ ibool_superbrick(1, 2) = 11
+ ibool_superbrick(2, 2) = 9
+ ibool_superbrick(3, 2) = 3
+ ibool_superbrick(4, 2) = 7
+ ibool_superbrick(5, 2) = 12
+ ibool_superbrick(6, 2) = 10
+ ibool_superbrick(7, 2) = 4
+ ibool_superbrick(8, 2) = 8
+
+ ibool_superbrick(1, 3) = 11
+ ibool_superbrick(2, 3) = 15
+ ibool_superbrick(3, 3) = 14
+ ibool_superbrick(4, 3) = 18
+ ibool_superbrick(5, 3) = 9
+ ibool_superbrick(6, 3) = 16
+ ibool_superbrick(7, 3) = 13
+ ibool_superbrick(8, 3) = 17
+
+ ibool_superbrick(1, 4) = 3
+ ibool_superbrick(2, 4) = 21
+ ibool_superbrick(3, 4) = 19
+ ibool_superbrick(4, 4) = 2
+ ibool_superbrick(5, 4) = 4
+ ibool_superbrick(6, 4) = 22
+ ibool_superbrick(7, 4) = 20
+ ibool_superbrick(8, 4) = 1
+
+ ibool_superbrick(1, 5) = 11
+ ibool_superbrick(2, 5) = 9
+ ibool_superbrick(3, 5) = 17
+ ibool_superbrick(4, 5) = 18
+ ibool_superbrick(5, 5) = 7
+ ibool_superbrick(6, 5) = 3
+ ibool_superbrick(7, 5) = 2
+ ibool_superbrick(8, 5) = 6
+
+ ibool_superbrick(1, 6) = 9
+ ibool_superbrick(2, 6) = 16
+ ibool_superbrick(3, 6) = 21
+ ibool_superbrick(4, 6) = 3
+ ibool_superbrick(5, 6) = 10
+ ibool_superbrick(6, 6) = 23
+ ibool_superbrick(7, 6) = 22
+ ibool_superbrick(8, 6) = 4
+
+ ibool_superbrick(1, 7) = 9
+ ibool_superbrick(2, 7) = 16
+ ibool_superbrick(3, 7) = 13
+ ibool_superbrick(4, 7) = 17
+ ibool_superbrick(5, 7) = 3
+ ibool_superbrick(6, 7) = 21
+ ibool_superbrick(7, 7) = 19
+ ibool_superbrick(8, 7) = 2
+
+ ibool_superbrick(1, 8) = 26
+ ibool_superbrick(2, 8) = 27
+ ibool_superbrick(3, 8) = 24
+ ibool_superbrick(4, 8) = 25
+ ibool_superbrick(5, 8) = 11
+ ibool_superbrick(6, 8) = 15
+ ibool_superbrick(7, 8) = 14
+ ibool_superbrick(8, 8) = 18
+
+ iboun_sb(:,:) = .false.
+ iboun_sb(1,1) = .true.
+ iboun_sb(1,4) = .true.
+ iboun_sb(1,6) = .true.
+ iboun_sb(2,1) = .true.
+ iboun_sb(2,3) = .true.
+ iboun_sb(2,6) = .true.
+ iboun_sb(3,2) = .true.
+ iboun_sb(3,3) = .true.
+ iboun_sb(3,4) = .true.
+ iboun_sb(4,2) = .true.
+ iboun_sb(4,4) = .true.
+ iboun_sb(4,6) = .true.
+ iboun_sb(5,1) = .true.
+ iboun_sb(5,4) = .true.
+ iboun_sb(6,2) = .true.
+ iboun_sb(6,3) = .true.
+ iboun_sb(6,6) = .true.
+ iboun_sb(7,2) = .true.
+ iboun_sb(7,4) = .true.
+ iboun_sb(8,1) = .true.
+ iboun_sb(8,2) = .true.
+ iboun_sb(8,3) = .true.
+ iboun_sb(8,4) = .true.
+ iboun_sb(8,5) = .true.
+ CASE (2)
+ x_superbrick(1) = 1.d0 / 2.d0
+ y_superbrick(1) = 0.d0
+ z_superbrick(1) = 2.d0
+
+ x_superbrick(2) = 1.d0 / 2.d0
+ y_superbrick(2) = 0.d0
+ z_superbrick(2) = 3.d0 / 2.d0
+
+ x_superbrick(3) = 1.d0 / 2.d0
+ y_superbrick(3) = 1.d0 / 2.d0
+ z_superbrick(3) = 3.d0 / 2.d0
+
+ x_superbrick(4) = 1.d0 / 2.d0
+ y_superbrick(4) = 1.d0 / 2.d0
+ z_superbrick(4) = 2.d0
+
+ x_superbrick(5) = 0.d0
+ y_superbrick(5) = 0.d0
+ z_superbrick(5) = 2.d0
+
+ x_superbrick(6) = 0.d0
+ y_superbrick(6) = 0.d0
+ z_superbrick(6) = 1.d0
+
+ x_superbrick(7) = 0.d0
+ y_superbrick(7) = 1.d0 / 2.d0
+ z_superbrick(7) = 1.d0
+
+ x_superbrick(8) = 0.d0
+ y_superbrick(8) = 1.d0 / 2.d0
+ z_superbrick(8) = 2.d0
+
+ x_superbrick(9) = 1.d0 / 2.d0
+ y_superbrick(9) = 1.d0
+ z_superbrick(9) = 1.d0
+
+ x_superbrick(10) = 1.d0 / 2.d0
+ y_superbrick(10) = 1.d0
+ z_superbrick(10) = 2.d0
+
+ x_superbrick(11) = 0.d0
+ y_superbrick(11) = 1.d0
+ z_superbrick(11) = 1.d0 / 2.d0
+
+ x_superbrick(12) = 0.d0
+ y_superbrick(12) = 1.d0
+ z_superbrick(12) = 2.d0
+
+ x_superbrick(13) = 1.d0
+ y_superbrick(13) = 0.d0
+ z_superbrick(13) = 1.d0
+
+ x_superbrick(14) = 1.d0
+ y_superbrick(14) = 0.d0
+ z_superbrick(14) = 1.d0 / 2.d0
+
+ x_superbrick(15) = 1.d0
+ y_superbrick(15) = 1.d0
+ z_superbrick(15) = 1.d0 / 2.d0
+
+ x_superbrick(16) = 1.d0
+ y_superbrick(16) = 1.d0
+ z_superbrick(16) = 1.d0
+
+ x_superbrick(17) = 1.d0 / 2.d0
+ y_superbrick(17) = 0.d0
+ z_superbrick(17) = 1.d0
+
+ x_superbrick(18) = 0.d0
+ y_superbrick(18) = 0.d0
+ z_superbrick(18) = 1.d0 / 2.d0
+
+ x_superbrick(19) = 1.d0
+ y_superbrick(19) = 0.d0
+ z_superbrick(19) = 3.d0 / 2.d0
+
+ x_superbrick(20) = 1.d0
+ y_superbrick(20) = 0.d0
+ z_superbrick(20) = 2.d0
+
+ x_superbrick(21) = 1.d0
+ y_superbrick(21) = 1.d0 / 2.d0
+ z_superbrick(21) = 3.d0 / 2.d0
+
+ x_superbrick(22) = 1.d0
+ y_superbrick(22) = 1.d0 / 2.d0
+ z_superbrick(22) = 2.d0
+
+ x_superbrick(23) = 1.d0
+ y_superbrick(23) = 1.d0
+ z_superbrick(23) = 2.d0
+
+ x_superbrick(24) = 1.d0
+ y_superbrick(24) = 0.d0
+ z_superbrick(24) = 0.d0
+
+ x_superbrick(25) = 0.d0
+ y_superbrick(25) = 0.d0
+ z_superbrick(25) = 0.d0
+
+ x_superbrick(26) = 0.d0
+ y_superbrick(26) = 1.d0
+ z_superbrick(26) = 0.d0
+
+ x_superbrick(27) = 1.d0
+ y_superbrick(27) = 1.d0
+ z_superbrick(27) = 0.d0
+
+ ibool_superbrick(1, 1) = 6
+ ibool_superbrick(2, 1) = 2
+ ibool_superbrick(3, 1) = 3
+ ibool_superbrick(4, 1) = 7
+ ibool_superbrick(5, 1) = 5
+ ibool_superbrick(6, 1) = 1
+ ibool_superbrick(7, 1) = 4
+ ibool_superbrick(8, 1) = 8
+
+ ibool_superbrick(1, 2) = 7
+ ibool_superbrick(2, 2) = 3
+ ibool_superbrick(3, 2) = 9
+ ibool_superbrick(4, 2) = 11
+ ibool_superbrick(5, 2) = 8
+ ibool_superbrick(6, 2) = 4
+ ibool_superbrick(7, 2) = 10
+ ibool_superbrick(8, 2) = 12
+
+ ibool_superbrick(1, 3) = 18
+ ibool_superbrick(2, 3) = 14
+ ibool_superbrick(3, 3) = 15
+ ibool_superbrick(4, 3) = 11
+ ibool_superbrick(5, 3) = 17
+ ibool_superbrick(6, 3) = 13
+ ibool_superbrick(7, 3) = 16
+ ibool_superbrick(8, 3) = 9
+
+ ibool_superbrick(1, 4) = 2
+ ibool_superbrick(2, 4) = 19
+ ibool_superbrick(3, 4) = 21
+ ibool_superbrick(4, 4) = 3
+ ibool_superbrick(5, 4) = 1
+ ibool_superbrick(6, 4) = 20
+ ibool_superbrick(7, 4) = 22
+ ibool_superbrick(8, 4) = 4
+
+ ibool_superbrick(1, 5) = 18
+ ibool_superbrick(2, 5) = 17
+ ibool_superbrick(3, 5) = 9
+ ibool_superbrick(4, 5) = 11
+ ibool_superbrick(5, 5) = 6
+ ibool_superbrick(6, 5) = 2
+ ibool_superbrick(7, 5) = 3
+ ibool_superbrick(8, 5) = 7
+
+ ibool_superbrick(1, 6) = 3
+ ibool_superbrick(2, 6) = 21
+ ibool_superbrick(3, 6) = 16
+ ibool_superbrick(4, 6) = 9
+ ibool_superbrick(5, 6) = 4
+ ibool_superbrick(6, 6) = 22
+ ibool_superbrick(7, 6) = 23
+ ibool_superbrick(8, 6) = 10
+
+ ibool_superbrick(1, 7) = 17
+ ibool_superbrick(2, 7) = 13
+ ibool_superbrick(3, 7) = 16
+ ibool_superbrick(4, 7) = 9
+ ibool_superbrick(5, 7) = 2
+ ibool_superbrick(6, 7) = 19
+ ibool_superbrick(7, 7) = 21
+ ibool_superbrick(8, 7) = 3
+
+ ibool_superbrick(1, 8) = 25
+ ibool_superbrick(2, 8) = 24
+ ibool_superbrick(3, 8) = 27
+ ibool_superbrick(4, 8) = 26
+ ibool_superbrick(5, 8) = 18
+ ibool_superbrick(6, 8) = 14
+ ibool_superbrick(7, 8) = 15
+ ibool_superbrick(8, 8) = 11
+
+ iboun_sb(:,:) = .false.
+ iboun_sb(1,1) = .true.
+ iboun_sb(1,3) = .true.
+ iboun_sb(1,6) = .true.
+ iboun_sb(2,1) = .true.
+ iboun_sb(2,4) = .true.
+ iboun_sb(2,6) = .true.
+ iboun_sb(3,2) = .true.
+ iboun_sb(3,3) = .true.
+ iboun_sb(3,4) = .true.
+ iboun_sb(4,2) = .true.
+ iboun_sb(4,3) = .true.
+ iboun_sb(4,6) = .true.
+ iboun_sb(5,1) = .true.
+ iboun_sb(5,3) = .true.
+ iboun_sb(6,2) = .true.
+ iboun_sb(6,4) = .true.
+ iboun_sb(6,6) = .true.
+ iboun_sb(7,2) = .true.
+ iboun_sb(7,3) = .true.
+ iboun_sb(8,1) = .true.
+ iboun_sb(8,2) = .true.
+ iboun_sb(8,3) = .true.
+ iboun_sb(8,4) = .true.
+ iboun_sb(8,5) = .true.
+ CASE (3)
+ x_superbrick(1) = 1.d0 / 2.d0
+ y_superbrick(1) = 1.d0
+ z_superbrick(1) = 2.d0
+
+ x_superbrick(2) = 1.d0 / 2.d0
+ y_superbrick(2) = 1.d0
+ z_superbrick(2) = 3.d0 / 2.d0
+
+ x_superbrick(3) = 1.d0 / 2.d0
+ y_superbrick(3) = 1.d0 / 2.d0
+ z_superbrick(3) = 3.d0 / 2.d0
+
+ x_superbrick(4) = 1.d0 / 2.d0
+ y_superbrick(4) = 1.d0 / 2.d0
+ z_superbrick(4) = 2.d0
+
+ x_superbrick(5) = 1.d0
+ y_superbrick(5) = 1.d0
+ z_superbrick(5) = 2.d0
+
+ x_superbrick(6) = 1.d0
+ y_superbrick(6) = 1.d0
+ z_superbrick(6) = 1.d0
+
+ x_superbrick(7) = 1.d0
+ y_superbrick(7) = 1.d0 / 2.d0
+ z_superbrick(7) = 1.d0
+
+ x_superbrick(8) = 1.d0
+ y_superbrick(8) = 1.d0 / 2.d0
+ z_superbrick(8) = 2.d0
+
+ x_superbrick(9) = 1.d0 / 2.d0
+ y_superbrick(9) = 0.d0
+ z_superbrick(9) = 1.d0
+
+ x_superbrick(10) = 1.d0 / 2.d0
+ y_superbrick(10) = 0.d0
+ z_superbrick(10) = 2.d0
+
+ x_superbrick(11) = 1.d0
+ y_superbrick(11) = 0.d0
+ z_superbrick(11) = 1.d0 / 2.d0
+
+ x_superbrick(12) = 1.d0
+ y_superbrick(12) = 0.d0
+ z_superbrick(12) = 2.d0
+
+ x_superbrick(13) = 0.d0
+ y_superbrick(13) = 1.d0
+ z_superbrick(13) = 1.d0
+
+ x_superbrick(14) = 0.d0
+ y_superbrick(14) = 1.d0
+ z_superbrick(14) = 1.d0 / 2.d0
+
+ x_superbrick(15) = 0.d0
+ y_superbrick(15) = 0.d0
+ z_superbrick(15) = 1.d0 / 2.d0
+
+ x_superbrick(16) = 0.d0
+ y_superbrick(16) = 0.d0
+ z_superbrick(16) = 1.d0
+
+ x_superbrick(17) = 1.d0 / 2.d0
+ y_superbrick(17) = 1.d0
+ z_superbrick(17) = 1.d0
+
+ x_superbrick(18) = 1.d0
+ y_superbrick(18) = 1.d0
+ z_superbrick(18) = 1.d0 / 2.d0
+
+ x_superbrick(19) = 0.d0
+ y_superbrick(19) = 1.d0
+ z_superbrick(19) = 3.d0 / 2.d0
+
+ x_superbrick(20) = 0.d0
+ y_superbrick(20) = 1.d0
+ z_superbrick(20) = 2.d0
+
+ x_superbrick(21) = 0.d0
+ y_superbrick(21) = 1.d0 / 2.d0
+ z_superbrick(21) = 3.d0 / 2.d0
+
+ x_superbrick(22) = 0.d0
+ y_superbrick(22) = 1.d0 / 2.d0
+ z_superbrick(22) = 2.d0
+
+ x_superbrick(23) = 0.d0
+ y_superbrick(23) = 0.d0
+ z_superbrick(23) = 2.d0
+
+ x_superbrick(24) = 0.d0
+ y_superbrick(24) = 1.d0
+ z_superbrick(24) = 0.d0
+
+ x_superbrick(25) = 1.d0
+ y_superbrick(25) = 1.d0
+ z_superbrick(25) = 0.d0
+
+ x_superbrick(26) = 1.d0
+ y_superbrick(26) = 0.d0
+ z_superbrick(26) = 0.d0
+
+ x_superbrick(27) = 0.d0
+ y_superbrick(27) = 0.d0
+ z_superbrick(27) = 0.d0
+
+ ibool_superbrick(1, 1) = 3
+ ibool_superbrick(2, 1) = 7
+ ibool_superbrick(3, 1) = 6
+ ibool_superbrick(4, 1) = 2
+ ibool_superbrick(5, 1) = 4
+ ibool_superbrick(6, 1) = 8
+ ibool_superbrick(7, 1) = 5
+ ibool_superbrick(8, 1) = 1
+
+ ibool_superbrick(1, 2) = 9
+ ibool_superbrick(2, 2) = 11
+ ibool_superbrick(3, 2) = 7
+ ibool_superbrick(4, 2) = 3
+ ibool_superbrick(5, 2) = 10
+ ibool_superbrick(6, 2) = 12
+ ibool_superbrick(7, 2) = 8
+ ibool_superbrick(8, 2) = 4
+
+ ibool_superbrick(1, 3) = 15
+ ibool_superbrick(2, 3) = 11
+ ibool_superbrick(3, 3) = 18
+ ibool_superbrick(4, 3) = 14
+ ibool_superbrick(5, 3) = 16
+ ibool_superbrick(6, 3) = 9
+ ibool_superbrick(7, 3) = 17
+ ibool_superbrick(8, 3) = 13
+
+ ibool_superbrick(1, 4) = 21
+ ibool_superbrick(2, 4) = 3
+ ibool_superbrick(3, 4) = 2
+ ibool_superbrick(4, 4) = 19
+ ibool_superbrick(5, 4) = 22
+ ibool_superbrick(6, 4) = 4
+ ibool_superbrick(7, 4) = 1
+ ibool_superbrick(8, 4) = 20
+
+ ibool_superbrick(1, 5) = 9
+ ibool_superbrick(2, 5) = 11
+ ibool_superbrick(3, 5) = 18
+ ibool_superbrick(4, 5) = 17
+ ibool_superbrick(5, 5) = 3
+ ibool_superbrick(6, 5) = 7
+ ibool_superbrick(7, 5) = 6
+ ibool_superbrick(8, 5) = 2
+
+ ibool_superbrick(1, 6) = 16
+ ibool_superbrick(2, 6) = 9
+ ibool_superbrick(3, 6) = 3
+ ibool_superbrick(4, 6) = 21
+ ibool_superbrick(5, 6) = 23
+ ibool_superbrick(6, 6) = 10
+ ibool_superbrick(7, 6) = 4
+ ibool_superbrick(8, 6) = 22
+
+ ibool_superbrick(1, 7) = 16
+ ibool_superbrick(2, 7) = 9
+ ibool_superbrick(3, 7) = 17
+ ibool_superbrick(4, 7) = 13
+ ibool_superbrick(5, 7) = 21
+ ibool_superbrick(6, 7) = 3
+ ibool_superbrick(7, 7) = 2
+ ibool_superbrick(8, 7) = 19
+
+ ibool_superbrick(1, 8) = 27
+ ibool_superbrick(2, 8) = 26
+ ibool_superbrick(3, 8) = 25
+ ibool_superbrick(4, 8) = 24
+ ibool_superbrick(5, 8) = 15
+ ibool_superbrick(6, 8) = 11
+ ibool_superbrick(7, 8) = 18
+ ibool_superbrick(8, 8) = 14
+
+ iboun_sb(:,:) = .false.
+ iboun_sb(1,2) = .true.
+ iboun_sb(1,4) = .true.
+ iboun_sb(1,6) = .true.
+ iboun_sb(2,2) = .true.
+ iboun_sb(2,3) = .true.
+ iboun_sb(2,6) = .true.
+ iboun_sb(3,1) = .true.
+ iboun_sb(3,3) = .true.
+ iboun_sb(3,4) = .true.
+ iboun_sb(4,1) = .true.
+ iboun_sb(4,4) = .true.
+ iboun_sb(4,6) = .true.
+ iboun_sb(5,2) = .true.
+ iboun_sb(5,4) = .true.
+ iboun_sb(6,1) = .true.
+ iboun_sb(6,3) = .true.
+ iboun_sb(6,6) = .true.
+ iboun_sb(7,1) = .true.
+ iboun_sb(7,4) = .true.
+ iboun_sb(8,1) = .true.
+ iboun_sb(8,2) = .true.
+ iboun_sb(8,3) = .true.
+ iboun_sb(8,4) = .true.
+ iboun_sb(8,5) = .true.
+ CASE (4)
+ x_superbrick(1) = 1.d0 / 2.d0
+ y_superbrick(1) = 0.d0
+ z_superbrick(1) = 2.d0
+
+ x_superbrick(2) = 1.d0 / 2.d0
+ y_superbrick(2) = 0.d0
+ z_superbrick(2) = 3.d0 / 2.d0
+
+ x_superbrick(3) = 1.d0 / 2.d0
+ y_superbrick(3) = 1.d0 / 2.d0
+ z_superbrick(3) = 3.d0 / 2.d0
+
+ x_superbrick(4) = 1.d0 / 2.d0
+ y_superbrick(4) = 1.d0 / 2.d0
+ z_superbrick(4) = 2.d0
+
+ x_superbrick(5) = 1.d0
+ y_superbrick(5) = 0.d0
+ z_superbrick(5) = 2.d0
+
+ x_superbrick(6) = 1.d0
+ y_superbrick(6) = 0.d0
+ z_superbrick(6) = 1.d0
+
+ x_superbrick(7) = 1.d0
+ y_superbrick(7) = 1.d0 / 2.d0
+ z_superbrick(7) = 1.d0
+
+ x_superbrick(8) = 1.d0
+ y_superbrick(8) = 1.d0 / 2.d0
+ z_superbrick(8) = 2.d0
+
+ x_superbrick(9) = 1.d0 / 2.d0
+ y_superbrick(9) = 1.d0
+ z_superbrick(9) = 1.d0
+
+ x_superbrick(10) = 1.d0 / 2.d0
+ y_superbrick(10) = 1.d0
+ z_superbrick(10) = 2.d0
+
+ x_superbrick(11) = 1.d0
+ y_superbrick(11) = 1.d0
+ z_superbrick(11) = 1.d0 / 2.d0
+
+ x_superbrick(12) = 1.d0
+ y_superbrick(12) = 1.d0
+ z_superbrick(12) = 2.d0
+
+ x_superbrick(13) = 0.d0
+ y_superbrick(13) = 0.d0
+ z_superbrick(13) = 1.d0
+
+ x_superbrick(14) = 0.d0
+ y_superbrick(14) = 0.d0
+ z_superbrick(14) = 1.d0 / 2.d0
+
+ x_superbrick(15) = 0.d0
+ y_superbrick(15) = 1.d0
+ z_superbrick(15) = 1.d0 / 2.d0
+
+ x_superbrick(16) = 0.d0
+ y_superbrick(16) = 1.d0
+ z_superbrick(16) = 1.d0
+
+ x_superbrick(17) = 1.d0 / 2.d0
+ y_superbrick(17) = 0.d0
+ z_superbrick(17) = 1.d0
+
+ x_superbrick(18) = 1.d0
+ y_superbrick(18) = 0.d0
+ z_superbrick(18) = 1.d0 / 2.d0
+
+ x_superbrick(19) = 0.d0
+ y_superbrick(19) = 0.d0
+ z_superbrick(19) = 3.d0 / 2.d0
+
+ x_superbrick(20) = 0.d0
+ y_superbrick(20) = 0.d0
+ z_superbrick(20) = 2.d0
+
+ x_superbrick(21) = 0.d0
+ y_superbrick(21) = 1.d0 / 2.d0
+ z_superbrick(21) = 3.d0 / 2.d0
+
+ x_superbrick(22) = 0.d0
+ y_superbrick(22) = 1.d0 / 2.d0
+ z_superbrick(22) = 2.d0
+
+ x_superbrick(23) = 0.d0
+ y_superbrick(23) = 1.d0
+ z_superbrick(23) = 2.d0
+
+ x_superbrick(24) = 0.d0
+ y_superbrick(24) = 0.d0
+ z_superbrick(24) = 0.d0
+
+ x_superbrick(25) = 1.d0
+ y_superbrick(25) = 0.d0
+ z_superbrick(25) = 0.d0
+
+ x_superbrick(26) = 1.d0
+ y_superbrick(26) = 1.d0
+ z_superbrick(26) = 0.d0
+
+ x_superbrick(27) = 0.d0
+ y_superbrick(27) = 1.d0
+ z_superbrick(27) = 0.d0
+
+ ibool_superbrick(1, 1) = 2
+ ibool_superbrick(2, 1) = 6
+ ibool_superbrick(3, 1) = 7
+ ibool_superbrick(4, 1) = 3
+ ibool_superbrick(5, 1) = 1
+ ibool_superbrick(6, 1) = 5
+ ibool_superbrick(7, 1) = 8
+ ibool_superbrick(8, 1) = 4
+
+ ibool_superbrick(1, 2) = 3
+ ibool_superbrick(2, 2) = 7
+ ibool_superbrick(3, 2) = 11
+ ibool_superbrick(4, 2) = 9
+ ibool_superbrick(5, 2) = 4
+ ibool_superbrick(6, 2) = 8
+ ibool_superbrick(7, 2) = 12
+ ibool_superbrick(8, 2) = 10
+
+ ibool_superbrick(1, 3) = 14
+ ibool_superbrick(2, 3) = 18
+ ibool_superbrick(3, 3) = 11
+ ibool_superbrick(4, 3) = 15
+ ibool_superbrick(5, 3) = 13
+ ibool_superbrick(6, 3) = 17
+ ibool_superbrick(7, 3) = 9
+ ibool_superbrick(8, 3) = 16
+
+ ibool_superbrick(1, 4) = 19
+ ibool_superbrick(2, 4) = 2
+ ibool_superbrick(3, 4) = 3
+ ibool_superbrick(4, 4) = 21
+ ibool_superbrick(5, 4) = 20
+ ibool_superbrick(6, 4) = 1
+ ibool_superbrick(7, 4) = 4
+ ibool_superbrick(8, 4) = 22
+
+ ibool_superbrick(1, 5) = 17
+ ibool_superbrick(2, 5) = 18
+ ibool_superbrick(3, 5) = 11
+ ibool_superbrick(4, 5) = 9
+ ibool_superbrick(5, 5) = 2
+ ibool_superbrick(6, 5) = 6
+ ibool_superbrick(7, 5) = 7
+ ibool_superbrick(8, 5) = 3
+
+ ibool_superbrick(1, 6) = 21
+ ibool_superbrick(2, 6) = 3
+ ibool_superbrick(3, 6) = 9
+ ibool_superbrick(4, 6) = 16
+ ibool_superbrick(5, 6) = 22
+ ibool_superbrick(6, 6) = 4
+ ibool_superbrick(7, 6) = 10
+ ibool_superbrick(8, 6) = 23
+
+ ibool_superbrick(1, 7) = 13
+ ibool_superbrick(2, 7) = 17
+ ibool_superbrick(3, 7) = 9
+ ibool_superbrick(4, 7) = 16
+ ibool_superbrick(5, 7) = 19
+ ibool_superbrick(6, 7) = 2
+ ibool_superbrick(7, 7) = 3
+ ibool_superbrick(8, 7) = 21
+
+ ibool_superbrick(1, 8) = 24
+ ibool_superbrick(2, 8) = 25
+ ibool_superbrick(3, 8) = 26
+ ibool_superbrick(4, 8) = 27
+ ibool_superbrick(5, 8) = 14
+ ibool_superbrick(6, 8) = 18
+ ibool_superbrick(7, 8) = 11
+ ibool_superbrick(8, 8) = 15
+
+ iboun_sb(:,:) = .false.
+ iboun_sb(1,2) = .true.
+ iboun_sb(1,3) = .true.
+ iboun_sb(1,6) = .true.
+ iboun_sb(2,2) = .true.
+ iboun_sb(2,4) = .true.
+ iboun_sb(2,6) = .true.
+ iboun_sb(3,1) = .true.
+ iboun_sb(3,3) = .true.
+ iboun_sb(3,4) = .true.
+ iboun_sb(4,1) = .true.
+ iboun_sb(4,3) = .true.
+ iboun_sb(4,6) = .true.
+ iboun_sb(5,2) = .true.
+ iboun_sb(5,3) = .true.
+ iboun_sb(6,1) = .true.
+ iboun_sb(6,4) = .true.
+ iboun_sb(6,6) = .true.
+ iboun_sb(7,1) = .true.
+ iboun_sb(7,3) = .true.
+ iboun_sb(8,1) = .true.
+ iboun_sb(8,2) = .true.
+ iboun_sb(8,3) = .true.
+ iboun_sb(8,4) = .true.
+ iboun_sb(8,5) = .true.
+ END SELECT
+end subroutine define_basic_doubling_brick
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/euler_angles.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/euler_angles.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/euler_angles.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,66 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! compute the Euler angles and the associated rotation matrix
+
+ subroutine euler_angles(rotation_matrix,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision rotation_matrix(3,3)
+ double precision CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH
+
+ double precision alpha,beta,gamma
+ double precision sina,cosa,sinb,cosb,sing,cosg
+
+! compute colatitude and longitude and convert to radians
+ alpha = CENTER_LONGITUDE_IN_DEGREES * DEGREES_TO_RADIANS
+ beta = (90.0d0 - CENTER_LATITUDE_IN_DEGREES) * DEGREES_TO_RADIANS
+ gamma = GAMMA_ROTATION_AZIMUTH * DEGREES_TO_RADIANS
+
+ sina = dsin(alpha)
+ cosa = dcos(alpha)
+ sinb = dsin(beta)
+ cosb = dcos(beta)
+ sing = dsin(gamma)
+ cosg = dcos(gamma)
+
+! define rotation matrix
+ rotation_matrix(1,1) = cosg*cosb*cosa-sing*sina
+ rotation_matrix(1,2) = -sing*cosb*cosa-cosg*sina
+ rotation_matrix(1,3) = sinb*cosa
+ rotation_matrix(2,1) = cosg*cosb*sina+sing*cosa
+ rotation_matrix(2,2) = -sing*cosb*sina+cosg*cosa
+ rotation_matrix(2,3) = sinb*sina
+ rotation_matrix(3,1) = -cosg*sinb
+ rotation_matrix(3,2) = sing*sinb
+ rotation_matrix(3,3) = cosb
+
+ end subroutine euler_angles
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/exit_mpi.F90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/exit_mpi.F90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/exit_mpi.F90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,110 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! end the simulation and exit MPI
+
+! version with rank number printed in the error message
+ subroutine exit_MPI(myrank,error_msg)
+
+ implicit none
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+ include "constants.h"
+
+! identifier for error message file
+ integer, parameter :: IERROR = 30
+
+ integer myrank
+ character(len=*) error_msg
+
+#ifdef USE_MPI
+ integer ier
+#endif
+ character(len=80) outputname
+ character(len=150) OUTPUT_FILES
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI... proc ',myrank
+
+! write error message to file
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+ write(outputname,"('/error_message',i6.6,'.txt')") myrank
+ open(unit=IERROR,file=trim(OUTPUT_FILES)//outputname,status='unknown')
+ write(IERROR,*) error_msg(1:len(error_msg))
+ write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
+ close(IERROR)
+
+! close output file
+ if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN)
+
+! stop all the MPI processes, and exit
+#ifdef USE_MPI
+ call MPI_ABORT(MPI_COMM_WORLD,30,ier)
+#endif
+ stop 'error, program ended in exit_MPI'
+
+ end subroutine exit_MPI
+
+!
+!----
+!
+
+! version without rank number printed in the error message
+ subroutine exit_MPI_without_rank(error_msg)
+
+ implicit none
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+ include "constants.h"
+
+ character(len=*) error_msg
+
+#ifdef USE_MPI
+ integer ier
+#endif
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI...'
+
+! stop all the MPI processes, and exit
+#ifdef USE_MPI
+ call MPI_ABORT(MPI_COMM_WORLD,30,ier)
+#endif
+ stop 'error, program ended in exit_MPI'
+
+ end subroutine exit_MPI_without_rank
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_MPI_1D_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_MPI_1D_buffers.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_MPI_1D_buffers.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -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 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_MPI_1D_buffers(myrank,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
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_MPI_cutplanes_eta.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_MPI_cutplanes_eta.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_MPI_cutplanes_eta.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,240 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, &
+ xstore,ystore,zstore,mask_ibool,npointot, &
+ NSPEC2D_XI_FACE,iregion,NGLOB2DMAX_XY,mask_ibool2,npoin2D_eta)
+
+! this routine detects cut planes along eta
+! In principle the left cut plane of the first slice
+! and the right cut plane of the last slice are not used
+! in the solver except if we want to have periodic conditions
+
+ implicit none
+
+ include "constants.h"
+
+ logical mask_ibool2(npointot)
+
+ integer nspec,myrank,nglob,ipoin2D,NGLOB2DMAX_XY,iregion
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE
+
+
+ logical iMPIcut_eta(2,nspec)
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! logical mask used to create arrays iboolleft_eta and iboolright_eta
+ integer npointot
+ logical mask_ibool(npointot)
+
+! global element numbering
+ integer ispec
+
+! MPI cut-plane element numbering
+ integer ispecc1,ispecc2,npoin2D_eta,ix,iy,iz
+ integer nspec2Dtheor
+
+! processor identification
+ character(len=150) prname
+
+! arrays for sorting routine
+ integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: work
+ integer, dimension(:), allocatable :: ibool_selected
+ double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
+
+
+! allocate arrays for message buffers with maximum size
+! define maximum size for message buffers
+ if (USE_MESH_COLORING_INNER_OUTER) then
+ allocate(ibool_selected(NGLOB2DMAX_XY))
+ allocate(xstore_selected(NGLOB2DMAX_XY))
+ allocate(ystore_selected(NGLOB2DMAX_XY))
+ allocate(zstore_selected(NGLOB2DMAX_XY))
+ allocate(ind(NGLOB2DMAX_XY))
+ allocate(ninseg(NGLOB2DMAX_XY))
+ allocate(iglob(NGLOB2DMAX_XY))
+ allocate(locval(NGLOB2DMAX_XY))
+ allocate(ifseg(NGLOB2DMAX_XY))
+ allocate(iwork(NGLOB2DMAX_XY))
+ allocate(work(NGLOB2DMAX_XY))
+ endif
+
+! theoretical number of surface elements in the buffers
+! cut planes along eta=constant correspond to XI faces
+ nspec2Dtheor = NSPEC2D_XI_FACE(iregion,1)
+
+! write the MPI buffers for the left and right edges of the slice
+! and the position of the points to check that the buffers are fine
+
+!
+! determine if the element falls on the left MPI cut plane
+!
+
+! global point number and coordinates left MPI cut-plane
+ 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
+ if (USE_MESH_COLORING_INNER_OUTER) then
+ ibool_selected(npoin2D_eta) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin2D_eta) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin2D_eta) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin2D_eta) = zstore(ix,iy,iz,ispec)
+ else
+ write(10,*) ibool(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+ if (USE_MESH_COLORING_INNER_OUTER) then
+ call sort_array_coordinates(npoin2D_eta,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+ do ipoin2D=1,npoin2D_eta
+ write(10,*) ibool_selected(ipoin2D)
+ mask_ibool2(ibool_selected(ipoin2D)) = .true.
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+ write(10,*) 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
+ if (USE_MESH_COLORING_INNER_OUTER) then
+ ibool_selected(npoin2D_eta) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin2D_eta) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin2D_eta) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin2D_eta) = zstore(ix,iy,iz,ispec)
+ else
+ write(10,*) ibool(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+ if (USE_MESH_COLORING_INNER_OUTER) then
+ call sort_array_coordinates(npoin2D_eta,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+ do ipoin2D=1,npoin2D_eta
+ write(10,*) ibool_selected(ipoin2D)
+ mask_ibool2(ibool_selected(ipoin2D)) = .true.
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+ write(10,*) 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')
+
+ if (USE_MESH_COLORING_INNER_OUTER) then
+ deallocate(ibool_selected)
+ deallocate(xstore_selected)
+ deallocate(ystore_selected)
+ deallocate(zstore_selected)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iglob)
+ deallocate(locval)
+ deallocate(ifseg)
+ deallocate(iwork)
+ deallocate(work)
+ endif
+
+ end subroutine get_MPI_cutplanes_eta
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_MPI_cutplanes_xi.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_MPI_cutplanes_xi.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_MPI_cutplanes_xi.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,245 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, &
+ xstore,ystore,zstore,mask_ibool,npointot, &
+ NSPEC2D_ETA_FACE,iregion,NGLOB2DMAX_XY,mask_ibool2,npoin2D_xi)
+
+! this routine detects cut planes along xi
+! In principle the left cut plane of the first slice
+! and the right cut plane of the last slice are not used
+! in the solver except if we want to have periodic conditions
+
+ implicit none
+
+ include "constants.h"
+
+ logical mask_ibool2(npointot)
+
+ integer nspec,myrank,nglob,ipoin2D,iregion
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_ETA_FACE
+
+ logical iMPIcut_xi(2,nspec)
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! logical mask used to create arrays iboolleft_xi and iboolright_xi
+ integer npointot
+ logical mask_ibool(npointot)
+
+! global element numbering
+ integer ispec
+
+! MPI cut-plane element numbering
+ integer ispecc1,ispecc2,npoin2D_xi,ix,iy,iz
+ integer nspec2Dtheor
+
+! processor identification
+ character(len=150) prname,errmsg
+
+! arrays for sorting routine
+ integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: work
+ integer NGLOB2DMAX_XY
+ integer, dimension(:), allocatable :: ibool_selected
+ double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
+
+! allocate arrays for message buffers with maximum size
+! define maximum size for message buffers
+ if (USE_MESH_COLORING_INNER_OUTER) then
+ allocate(ibool_selected(NGLOB2DMAX_XY))
+ allocate(xstore_selected(NGLOB2DMAX_XY))
+ allocate(ystore_selected(NGLOB2DMAX_XY))
+ allocate(zstore_selected(NGLOB2DMAX_XY))
+ allocate(ind(NGLOB2DMAX_XY))
+ allocate(ninseg(NGLOB2DMAX_XY))
+ allocate(iglob(NGLOB2DMAX_XY))
+ allocate(locval(NGLOB2DMAX_XY))
+ allocate(ifseg(NGLOB2DMAX_XY))
+ allocate(iwork(NGLOB2DMAX_XY))
+ allocate(work(NGLOB2DMAX_XY))
+ endif
+
+! theoretical number of surface elements in the buffers
+! cut planes along xi=constant correspond to ETA faces
+ nspec2Dtheor = NSPEC2D_ETA_FACE(iregion,1)
+! write the MPI buffers for the left and right edges of the slice
+! and the position of the points to check that the buffers are fine
+
+!
+! determine if the element falls on the left MPI cut plane
+!
+
+! global point number and coordinates left MPI cut-plane
+ open(unit=10,file=prname(1:len_trim(prname))//'iboolleft_xi.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin2D_xi = 0
+
+! nb of elements in this cut-plane
+ ispecc1=0
+
+ do ispec=1,nspec
+ if(iMPIcut_xi(1,ispec)) then
+ ispecc1=ispecc1+1
+ ! loop on all the points in that 2-D element, including edges
+ ix = 1
+ do iy=1,NGLLY
+ do iz=1,NGLLZ
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_xi = npoin2D_xi + 1
+ if (USE_MESH_COLORING_INNER_OUTER) then
+ ibool_selected(npoin2D_xi) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin2D_xi) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin2D_xi) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin2D_xi) = zstore(ix,iy,iz,ispec)
+ else
+ write(10,*) ibool(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+ if (USE_MESH_COLORING_INNER_OUTER) then
+ call sort_array_coordinates(npoin2D_xi,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+ do ipoin2D=1,npoin2D_xi
+ write(10,*) ibool_selected(ipoin2D)
+ mask_ibool2(ibool_selected(ipoin2D)) = .true.
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+ write(10,*) 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')
+
+! 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
+ if (USE_MESH_COLORING_INNER_OUTER) then
+ ibool_selected(npoin2D_xi) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin2D_xi) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin2D_xi) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin2D_xi) = zstore(ix,iy,iz,ispec)
+ else
+ write(10,*) ibool(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+ if (USE_MESH_COLORING_INNER_OUTER) then
+ call sort_array_coordinates(npoin2D_xi,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+ do ipoin2D=1,npoin2D_xi
+ write(10,*) ibool_selected(ipoin2D)
+ mask_ibool2(ibool_selected(ipoin2D)) = .true.
+ enddo
+ endif
+
+
+! put flag to indicate end of the list of points
+ write(10,*) 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
+
+ if (USE_MESH_COLORING_INNER_OUTER) then
+ deallocate(ibool_selected)
+ deallocate(xstore_selected)
+ deallocate(ystore_selected)
+ deallocate(zstore_selected)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iglob)
+ deallocate(locval)
+ deallocate(ifseg)
+ deallocate(iwork)
+ deallocate(work)
+ endif
+
+
+ end subroutine get_MPI_cutplanes_xi
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_absorb.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_absorb.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_absorb.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,145 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!!!!!!!!! subroutine get_absorb(myrank,prname,iboun,nspec, &
+ subroutine get_absorb(myrank,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')
+! 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
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_backazimuth.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_backazimuth.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_backazimuth.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -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 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! get 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
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_cmt.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_cmt.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_cmt.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,189 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,DT,NSOURCES)
+
+ implicit none
+
+ include "constants.h"
+
+!--- input or output arguments of the subroutine below
+
+ integer, intent(in) :: NSOURCES
+ double precision, intent(in) :: DT
+
+ integer, intent(out) :: yr,jda,ho,mi
+ double precision, intent(out) :: sec
+ double precision, dimension(NSOURCES), intent(out) :: t_cmt,hdur,lat,long,depth
+ double precision, dimension(6,NSOURCES), intent(out) :: moment_tensor
+
+!--- local variables below
+
+ integer mo,da,julian_day,isource
+ double precision scaleM
+ character(len=5) datasource
+ character(len=150) string, CMTSOLUTION
+
+!
+!---- read hypocenter info
+!
+ call get_value_string(CMTSOLUTION, 'solver.CMTSOLUTION', 'DATA/CMTSOLUTION')
+
+ open(unit=1,file=CMTSOLUTION,status='old',action='read')
+
+! read source number isource
+ do isource=1,NSOURCES
+
+! read header with event information
+ read(1,"(a4,i5,i3,i3,i3,i3,f6.2)") datasource,yr,mo,da,ho,mi,sec
+ jda=julian_day(yr,mo,da)
+
+! ignore line with event name
+ read(1,"(a)") string
+
+! read time shift
+ read(1,"(a)") string
+ read(string(12:len_trim(string)),*) t_cmt(isource)
+
+! read half duration
+ read(1,"(a)") string
+ read(string(15:len_trim(string)),*) hdur(isource)
+
+! read latitude
+ read(1,"(a)") string
+ read(string(10:len_trim(string)),*) lat(isource)
+
+! read longitude
+ read(1,"(a)") string
+ read(string(11:len_trim(string)),*) long(isource)
+
+! read depth
+ read(1,"(a)") string
+ read(string(7:len_trim(string)),*) depth(isource)
+
+! read Mrr
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(1,isource)
+
+! read Mtt
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(2,isource)
+
+! read Mpp
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(3,isource)
+
+! read Mrt
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(4,isource)
+
+! read Mrp
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(5,isource)
+
+! read Mtp
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(6,isource)
+
+! null half-duration indicates a Heaviside
+! replace with very short error function
+ if(hdur(isource) < 5. * DT) hdur(isource) = 5. * DT
+
+ enddo
+
+ close(1)
+
+!
+! scale and non-dimensionalize the moment tensor
+! CMTSOLUTION file values are in dyne.cm
+! 1 dyne is 1 gram * 1 cm / (1 second)^2
+! 1 Newton is 1 kg * 1 m / (1 second)^2
+! thus 1 Newton = 100,000 dynes
+! therefore 1 dyne.cm = 1e-7 Newton.m
+!
+ scaleM = 1.d7 * RHOAV * (R_EARTH**5) * PI*GRAV*RHOAV
+ moment_tensor(:,:) = moment_tensor(:,:) / scaleM
+
+ end subroutine get_cmt
+
+! ------------------------------------------------------------------
+
+ integer function julian_day(yr,mo,da)
+
+ implicit none
+
+ integer yr,mo,da
+
+ integer mon(12)
+ integer lpyr
+ data mon /0,31,59,90,120,151,181,212,243,273,304,334/
+
+ julian_day = da + mon(mo)
+ if(mo>2) julian_day = julian_day + lpyr(yr)
+
+ end function julian_day
+
+! ------------------------------------------------------------------
+
+ integer function lpyr(yr)
+
+ implicit none
+
+ integer yr
+!
+!---- returns 1 if leap year
+!
+ lpyr=0
+ if(mod(yr,400) == 0) then
+ lpyr=1
+ else if(mod(yr,4) == 0) then
+ lpyr=1
+ if(mod(yr,100) == 0) lpyr=0
+ endif
+
+ end function lpyr
+
+! ------------------------------------------------------------------
+
+! function to determine if year is a leap year
+ logical function is_leap_year(yr)
+
+ implicit none
+
+ integer yr
+
+ integer, external :: lpyr
+
+!---- function lpyr above returns 1 if leap year
+ if(lpyr(yr) == 1) then
+ is_leap_year = .true.
+ else
+ is_leap_year = .false.
+ endif
+
+ end function is_leap_year
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_ellipticity.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_ellipticity.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_ellipticity.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,65 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_ellipticity(xelm,yelm,zelm,nspl,rspl,espl,espl2)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspl
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+ integer ia
+
+ double precision ell
+ double precision r,theta,phi,factor
+ double precision cost,p20
+
+ do ia=1,NGNOD
+
+ call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
+
+ cost=dcos(theta)
+ p20=0.5d0*(3.0d0*cost*cost-1.0d0)
+
+! get ellipticity using spline evaluation
+ call spline_evaluation(rspl,espl,espl2,nspl,r,ell)
+
+ factor=ONE-(TWO/3.0d0)*ell*p20
+
+ xelm(ia)=xelm(ia)*factor
+ yelm(ia)=yelm(ia)*factor
+ zelm(ia)=zelm(ia)*factor
+
+ enddo
+
+ end subroutine get_ellipticity
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_global.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_global.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_global.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,234 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_global(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot)
+
+! this routine MUST be in double precision to avoid sensitivity
+! to roundoff errors in the coordinates of the points
+
+! non-structured global numbering software provided by Paul F. Fischer
+
+! leave sorting subroutines in same source file to allow for inlining
+
+ implicit none
+
+ include "constants.h"
+
+! parameters
+ integer, intent(in) :: npointot,nspec
+ double precision, intent(in) :: xp(npointot),yp(npointot),zp(npointot)
+
+ integer, intent(out) :: iglob(npointot),loc(npointot)
+ logical, intent(out) :: ifseg(npointot)
+ integer, intent(out) :: nglob
+
+! variables
+ integer ispec,i,j
+ integer ieoff,ilocnum,nseg,ioff,iseg,ig
+
+ integer, dimension(:), allocatable :: ind,ninseg,iwork
+ double precision, dimension(:), allocatable :: work
+
+! dynamically allocate arrays
+ allocate(ind(npointot))
+ allocate(ninseg(npointot))
+ allocate(iwork(npointot))
+ allocate(work(npointot))
+
+! establish initial pointers
+ do ispec=1,nspec
+ ieoff=NGLLX * NGLLY * NGLLZ * (ispec-1)
+ do ilocnum=1,NGLLX * NGLLY * NGLLZ
+ loc(ilocnum+ieoff)=ilocnum+ieoff
+ enddo
+ enddo
+
+ ifseg(:)=.false.
+
+ nseg=1
+ ifseg(1)=.true.
+ ninseg(1)=npointot
+
+do j=1,NDIM
+
+ ! sort within each segment
+ ioff=1
+ do iseg=1,nseg
+ if(j == 1) then
+ call rank(xp(ioff),ind,ninseg(iseg))
+ else if(j == 2) then
+ call rank(yp(ioff),ind,ninseg(iseg))
+ else
+ call rank(zp(ioff),ind,ninseg(iseg))
+ endif
+ call swap_all(loc(ioff),xp(ioff),yp(ioff),zp(ioff),iwork,work,ind,ninseg(iseg))
+ ioff=ioff+ninseg(iseg)
+ enddo
+
+! check for jumps in current coordinate
+! compare the coordinates of the points within a small tolerance
+ if(j == 1) then
+ do i=2,npointot
+ if(dabs(xp(i)-xp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
+ enddo
+ else if(j == 2) then
+ do i=2,npointot
+ if(dabs(yp(i)-yp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
+ enddo
+ else
+ do i=2,npointot
+ if(dabs(zp(i)-zp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
+ enddo
+ endif
+
+! count up number of different segments
+ nseg=0
+ do i=1,npointot
+ if(ifseg(i)) then
+ nseg=nseg+1
+ ninseg(nseg)=1
+ else
+ ninseg(nseg)=ninseg(nseg)+1
+ endif
+ enddo
+enddo
+
+! assign global node numbers (now sorted lexicographically)
+ ig=0
+ do i=1,npointot
+ if(ifseg(i)) ig=ig+1
+ iglob(loc(i))=ig
+ enddo
+
+ nglob=ig
+
+! deallocate arrays
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iwork)
+ deallocate(work)
+
+ end subroutine get_global
+
+! -----------------------------------
+
+! sorting routines put in same file to allow for inlining
+
+ subroutine rank(A,IND,N)
+!
+! Use Heap Sort (Numerical Recipes)
+!
+ implicit none
+
+ integer n
+ double precision A(n)
+ integer IND(n)
+
+ integer i,j,l,ir,indx
+ double precision q
+
+ do j=1,n
+ IND(j)=j
+ enddo
+
+ if (n == 1) return
+
+ L=n/2+1
+ ir=n
+ 100 CONTINUE
+ IF (l>1) THEN
+ l=l-1
+ indx=ind(l)
+ q=a(indx)
+ ELSE
+ indx=ind(ir)
+ q=a(indx)
+ ind(ir)=ind(1)
+ ir=ir-1
+ if (ir == 1) then
+ ind(1)=indx
+ return
+ endif
+ ENDIF
+ i=l
+ j=l+l
+ 200 CONTINUE
+ IF (J <= IR) THEN
+ IF (J<IR) THEN
+ IF ( A(IND(j))<A(IND(j+1)) ) j=j+1
+ ENDIF
+ IF (q<A(IND(j))) THEN
+ IND(I)=IND(J)
+ I=J
+ J=J+J
+ ELSE
+ J=IR+1
+ ENDIF
+ goto 200
+ ENDIF
+ IND(I)=INDX
+ goto 100
+ end subroutine rank
+
+! ------------------------------------------------------------------
+
+ subroutine swap_all(IA,A,B,C,IW,W,ind,n)
+!
+! swap arrays IA, A, B and C according to addressing in array IND
+!
+ implicit none
+
+ integer n
+
+ integer IND(n)
+ integer IA(n),IW(n)
+ double precision A(n),B(n),C(n),W(n)
+
+ integer i
+
+ IW(:) = IA(:)
+ W(:) = A(:)
+
+ do i=1,n
+ IA(i)=IW(ind(i))
+ A(i)=W(ind(i))
+ enddo
+
+ W(:) = B(:)
+
+ do i=1,n
+ B(i)=W(ind(i))
+ enddo
+
+ W(:) = C(:)
+
+ do i=1,n
+ C(i)=W(ind(i))
+ enddo
+
+ end subroutine swap_all
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_jacobian_boundaries.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_jacobian_boundaries.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_jacobian_boundaries.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -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 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ jacobian2D_xmin,jacobian2D_xmax, &
+ jacobian2D_ymin,jacobian2D_ymax, &
+ jacobian2D_bottom,jacobian2D_top, &
+ normal_xmin,normal_xmax, &
+ normal_ymin,normal_ymax, &
+ normal_bottom,normal_top, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank
+ integer NSPEC2D_BOTTOM,NSPEC2D_TOP,NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
+
+ integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
+ integer ibelm_xmin(NSPEC2DMAX_XMIN_XMAX),ibelm_xmax(NSPEC2DMAX_XMIN_XMAX)
+ integer ibelm_ymin(NSPEC2DMAX_YMIN_YMAX),ibelm_ymax(NSPEC2DMAX_YMIN_YMAX)
+ integer ibelm_bottom(NSPEC2D_BOTTOM),ibelm_top(NSPEC2D_TOP)
+
+ logical iboun(6,nspec)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+ real(kind=CUSTOM_REAL) jacobian2D_xmin(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ real(kind=CUSTOM_REAL) jacobian2D_xmax(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ real(kind=CUSTOM_REAL) jacobian2D_ymin(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ real(kind=CUSTOM_REAL) jacobian2D_ymax(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ real(kind=CUSTOM_REAL) jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM)
+ real(kind=CUSTOM_REAL) jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP)
+
+ real(kind=CUSTOM_REAL) normal_xmin(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ real(kind=CUSTOM_REAL) normal_xmax(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ real(kind=CUSTOM_REAL) normal_ymin(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ real(kind=CUSTOM_REAL) normal_ymax(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ real(kind=CUSTOM_REAL) normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM)
+ real(kind=CUSTOM_REAL) normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP)
+
+ double precision dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ)
+ double precision dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ)
+ double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY)
+ double precision dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY)
+
+! global element numbering
+ integer ispec
+
+! counters to keep track of number of elements on each of the boundaries
+ integer ispecb1,ispecb2,ispecb3,ispecb4,ispecb5,ispecb6
+
+ double precision xelm(NGNOD2D),yelm(NGNOD2D),zelm(NGNOD2D)
+
+! check that the parameter file is correct
+ if(NGNOD /= 27) call exit_MPI(myrank,'elements should have 27 control nodes')
+ if(NGNOD2D /= 9) call exit_MPI(myrank,'surface elements should have 9 control nodes')
+
+ ispecb1 = 0
+ ispecb2 = 0
+ ispecb3 = 0
+ ispecb4 = 0
+ ispecb5 = 0
+ ispecb6 = 0
+
+ do ispec=1,nspec
+
+! determine if the element falls on a boundary
+
+! on boundary: xmin
+
+ if(iboun(1,ispec)) then
+
+ ispecb1=ispecb1+1
+ ibelm_xmin(ispecb1)=ispec
+
+! specify the 9 nodes for the 2-D boundary element
+ xelm(1)=xstore(1,1,1,ispec)
+ yelm(1)=ystore(1,1,1,ispec)
+ zelm(1)=zstore(1,1,1,ispec)
+ xelm(2)=xstore(1,NGLLY,1,ispec)
+ yelm(2)=ystore(1,NGLLY,1,ispec)
+ zelm(2)=zstore(1,NGLLY,1,ispec)
+ xelm(3)=xstore(1,NGLLY,NGLLZ,ispec)
+ yelm(3)=ystore(1,NGLLY,NGLLZ,ispec)
+ zelm(3)=zstore(1,NGLLY,NGLLZ,ispec)
+ xelm(4)=xstore(1,1,NGLLZ,ispec)
+ yelm(4)=ystore(1,1,NGLLZ,ispec)
+ zelm(4)=zstore(1,1,NGLLZ,ispec)
+ xelm(5)=xstore(1,(NGLLY+1)/2,1,ispec)
+ yelm(5)=ystore(1,(NGLLY+1)/2,1,ispec)
+ zelm(5)=zstore(1,(NGLLY+1)/2,1,ispec)
+ xelm(6)=xstore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ yelm(6)=ystore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ zelm(6)=zstore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ xelm(7)=xstore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ yelm(7)=ystore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ zelm(7)=zstore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ xelm(8)=xstore(1,1,(NGLLZ+1)/2,ispec)
+ yelm(8)=ystore(1,1,(NGLLZ+1)/2,ispec)
+ zelm(8)=zstore(1,1,(NGLLZ+1)/2,ispec)
+ xelm(9)=xstore(1,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+ yelm(9)=ystore(1,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+ zelm(9)=zstore(1,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb1,xelm,yelm,zelm,dershape2D_x, &
+ jacobian2D_xmin,normal_xmin,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+
+ endif
+
+! on boundary: xmax
+
+ if(iboun(2,ispec)) then
+
+ ispecb2=ispecb2+1
+ ibelm_xmax(ispecb2)=ispec
+
+! specify the 9 nodes for the 2-D boundary element
+ xelm(1)=xstore(NGLLX,1,1,ispec)
+ yelm(1)=ystore(NGLLX,1,1,ispec)
+ zelm(1)=zstore(NGLLX,1,1,ispec)
+ xelm(2)=xstore(NGLLX,NGLLY,1,ispec)
+ yelm(2)=ystore(NGLLX,NGLLY,1,ispec)
+ zelm(2)=zstore(NGLLX,NGLLY,1,ispec)
+ xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
+ yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
+ zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
+ xelm(4)=xstore(NGLLX,1,NGLLZ,ispec)
+ yelm(4)=ystore(NGLLX,1,NGLLZ,ispec)
+ zelm(4)=zstore(NGLLX,1,NGLLZ,ispec)
+ xelm(5)=xstore(NGLLX,(NGLLY+1)/2,1,ispec)
+ yelm(5)=ystore(NGLLX,(NGLLY+1)/2,1,ispec)
+ zelm(5)=zstore(NGLLX,(NGLLY+1)/2,1,ispec)
+ xelm(6)=xstore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ yelm(6)=ystore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ zelm(6)=zstore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ xelm(7)=xstore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ yelm(7)=ystore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ zelm(7)=zstore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ xelm(8)=xstore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ yelm(8)=ystore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ zelm(8)=zstore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ xelm(9)=xstore(NGLLX,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+ yelm(9)=ystore(NGLLX,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+ zelm(9)=zstore(NGLLX,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb2,xelm,yelm,zelm,dershape2D_x, &
+ jacobian2D_xmax,normal_xmax,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+
+ endif
+
+! on boundary: ymin
+
+ if(iboun(3,ispec)) then
+
+ ispecb3=ispecb3+1
+ ibelm_ymin(ispecb3)=ispec
+
+! specify the 9 nodes for the 2-D boundary element
+ xelm(1)=xstore(1,1,1,ispec)
+ yelm(1)=ystore(1,1,1,ispec)
+ zelm(1)=zstore(1,1,1,ispec)
+ xelm(2)=xstore(NGLLX,1,1,ispec)
+ yelm(2)=ystore(NGLLX,1,1,ispec)
+ zelm(2)=zstore(NGLLX,1,1,ispec)
+ xelm(3)=xstore(NGLLX,1,NGLLZ,ispec)
+ yelm(3)=ystore(NGLLX,1,NGLLZ,ispec)
+ zelm(3)=zstore(NGLLX,1,NGLLZ,ispec)
+ xelm(4)=xstore(1,1,NGLLZ,ispec)
+ yelm(4)=ystore(1,1,NGLLZ,ispec)
+ zelm(4)=zstore(1,1,NGLLZ,ispec)
+ xelm(5)=xstore((NGLLX+1)/2,1,1,ispec)
+ yelm(5)=ystore((NGLLX+1)/2,1,1,ispec)
+ zelm(5)=zstore((NGLLX+1)/2,1,1,ispec)
+ xelm(6)=xstore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ yelm(6)=ystore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ zelm(6)=zstore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ xelm(7)=xstore((NGLLX+1)/2,1,NGLLZ,ispec)
+ yelm(7)=ystore((NGLLX+1)/2,1,NGLLZ,ispec)
+ zelm(7)=zstore((NGLLX+1)/2,1,NGLLZ,ispec)
+ xelm(8)=xstore(1,1,(NGLLZ+1)/2,ispec)
+ yelm(8)=ystore(1,1,(NGLLZ+1)/2,ispec)
+ zelm(8)=zstore(1,1,(NGLLZ+1)/2,ispec)
+ xelm(9)=xstore((NGLLX+1)/2,1,(NGLLZ+1)/2,ispec)
+ yelm(9)=ystore((NGLLX+1)/2,1,(NGLLZ+1)/2,ispec)
+ zelm(9)=zstore((NGLLX+1)/2,1,(NGLLZ+1)/2,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb3,xelm,yelm,zelm,dershape2D_y, &
+ jacobian2D_ymin,normal_ymin,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+
+ endif
+
+! on boundary: ymax
+
+ if(iboun(4,ispec)) then
+
+ ispecb4=ispecb4+1
+ ibelm_ymax(ispecb4)=ispec
+
+! specify the 9 nodes for the 2-D boundary element
+ xelm(1)=xstore(1,NGLLY,1,ispec)
+ yelm(1)=ystore(1,NGLLY,1,ispec)
+ zelm(1)=zstore(1,NGLLY,1,ispec)
+ xelm(2)=xstore(NGLLX,NGLLY,1,ispec)
+ yelm(2)=ystore(NGLLX,NGLLY,1,ispec)
+ zelm(2)=zstore(NGLLX,NGLLY,1,ispec)
+ xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
+ yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
+ zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
+ xelm(4)=xstore(1,NGLLY,NGLLZ,ispec)
+ yelm(4)=ystore(1,NGLLY,NGLLZ,ispec)
+ zelm(4)=zstore(1,NGLLY,NGLLZ,ispec)
+ xelm(5)=xstore((NGLLX+1)/2,NGLLY,1,ispec)
+ yelm(5)=ystore((NGLLX+1)/2,NGLLY,1,ispec)
+ zelm(5)=zstore((NGLLX+1)/2,NGLLY,1,ispec)
+ xelm(6)=xstore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ yelm(6)=ystore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ zelm(6)=zstore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ xelm(7)=xstore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ yelm(7)=ystore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ zelm(7)=zstore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ xelm(8)=xstore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ yelm(8)=ystore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ zelm(8)=zstore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ xelm(9)=xstore((NGLLX+1)/2,NGLLY,(NGLLZ+1)/2,ispec)
+ yelm(9)=ystore((NGLLX+1)/2,NGLLY,(NGLLZ+1)/2,ispec)
+ zelm(9)=zstore((NGLLX+1)/2,NGLLY,(NGLLZ+1)/2,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb4,xelm,yelm,zelm,dershape2D_y, &
+ jacobian2D_ymax,normal_ymax,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+
+ endif
+
+! on boundary: bottom
+
+ if(iboun(5,ispec)) then
+
+ ispecb5=ispecb5+1
+ ibelm_bottom(ispecb5)=ispec
+
+ xelm(1)=xstore(1,1,1,ispec)
+ yelm(1)=ystore(1,1,1,ispec)
+ zelm(1)=zstore(1,1,1,ispec)
+ xelm(2)=xstore(NGLLX,1,1,ispec)
+ yelm(2)=ystore(NGLLX,1,1,ispec)
+ zelm(2)=zstore(NGLLX,1,1,ispec)
+ xelm(3)=xstore(NGLLX,NGLLY,1,ispec)
+ yelm(3)=ystore(NGLLX,NGLLY,1,ispec)
+ zelm(3)=zstore(NGLLX,NGLLY,1,ispec)
+ xelm(4)=xstore(1,NGLLY,1,ispec)
+ yelm(4)=ystore(1,NGLLY,1,ispec)
+ zelm(4)=zstore(1,NGLLY,1,ispec)
+ xelm(5)=xstore((NGLLX+1)/2,1,1,ispec)
+ yelm(5)=ystore((NGLLX+1)/2,1,1,ispec)
+ zelm(5)=zstore((NGLLX+1)/2,1,1,ispec)
+ xelm(6)=xstore(NGLLX,(NGLLY+1)/2,1,ispec)
+ yelm(6)=ystore(NGLLX,(NGLLY+1)/2,1,ispec)
+ zelm(6)=zstore(NGLLX,(NGLLY+1)/2,1,ispec)
+ xelm(7)=xstore((NGLLX+1)/2,NGLLY,1,ispec)
+ yelm(7)=ystore((NGLLX+1)/2,NGLLY,1,ispec)
+ zelm(7)=zstore((NGLLX+1)/2,NGLLY,1,ispec)
+ xelm(8)=xstore(1,(NGLLY+1)/2,1,ispec)
+ yelm(8)=ystore(1,(NGLLY+1)/2,1,ispec)
+ zelm(8)=zstore(1,(NGLLY+1)/2,1,ispec)
+ xelm(9)=xstore((NGLLX+1)/2,(NGLLY+1)/2,1,ispec)
+ yelm(9)=ystore((NGLLX+1)/2,(NGLLY+1)/2,1,ispec)
+ zelm(9)=zstore((NGLLX+1)/2,(NGLLY+1)/2,1,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb5,xelm,yelm,zelm,dershape2D_bottom, &
+ jacobian2D_bottom,normal_bottom,NGLLX,NGLLY,NSPEC2D_BOTTOM)
+
+ endif
+
+! on boundary: top
+
+ if(iboun(6,ispec)) then
+
+ ispecb6=ispecb6+1
+ ibelm_top(ispecb6)=ispec
+
+ xelm(1)=xstore(1,1,NGLLZ,ispec)
+ yelm(1)=ystore(1,1,NGLLZ,ispec)
+ zelm(1)=zstore(1,1,NGLLZ,ispec)
+ xelm(2)=xstore(NGLLX,1,NGLLZ,ispec)
+ yelm(2)=ystore(NGLLX,1,NGLLZ,ispec)
+ zelm(2)=zstore(NGLLX,1,NGLLZ,ispec)
+ xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
+ yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
+ zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
+ xelm(4)=xstore(1,NGLLY,NGLLZ,ispec)
+ yelm(4)=ystore(1,NGLLY,NGLLZ,ispec)
+ zelm(4)=zstore(1,NGLLY,NGLLZ,ispec)
+ xelm(5)=xstore((NGLLX+1)/2,1,NGLLZ,ispec)
+ yelm(5)=ystore((NGLLX+1)/2,1,NGLLZ,ispec)
+ zelm(5)=zstore((NGLLX+1)/2,1,NGLLZ,ispec)
+ xelm(6)=xstore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ yelm(6)=ystore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ zelm(6)=zstore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ xelm(7)=xstore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ yelm(7)=ystore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ zelm(7)=zstore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ xelm(8)=xstore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ yelm(8)=ystore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ zelm(8)=zstore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ xelm(9)=xstore((NGLLX+1)/2,(NGLLY+1)/2,NGLLZ,ispec)
+ yelm(9)=ystore((NGLLX+1)/2,(NGLLY+1)/2,NGLLZ,ispec)
+ zelm(9)=zstore((NGLLX+1)/2,(NGLLY+1)/2,NGLLZ,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb6,xelm,yelm,zelm,dershape2D_top, &
+ jacobian2D_top,normal_top,NGLLX,NGLLY,NSPEC2D_TOP)
+
+ endif
+
+ enddo
+
+
+! check theoretical value of elements at the bottom
+ if(ispecb5 /= NSPEC2D_BOTTOM) then
+ call exit_MPI(myrank,'ispecb5 should equal NSPEC2D_BOTTOM')
+ endif
+
+! check theoretical value of elements at the top
+ if(ispecb6 /= NSPEC2D_TOP) call exit_MPI(myrank,'ispecb6 should equal NSPEC2D_TOP')
+
+ nspec2D_xmin = ispecb1
+ nspec2D_xmax = ispecb2
+ nspec2D_ymin = ispecb3
+ nspec2D_ymax = ispecb4
+
+ end subroutine get_jacobian_boundaries
+
+! -------------------------------------------------------
+
+ subroutine compute_jacobian_2D(myrank,ispecb,xelm,yelm,zelm,dershape2D,jacobian2D,normal,NGLLA,NGLLB,NSPEC2DMAX_AB)
+
+ implicit none
+
+ include "constants.h"
+
+! generic routine that accepts any polynomial degree in each direction
+
+ integer ispecb,NGLLA,NGLLB,NSPEC2DMAX_AB,myrank
+
+ double precision xelm(NGNOD2D),yelm(NGNOD2D),zelm(NGNOD2D)
+ double precision dershape2D(NDIM2D,NGNOD2D,NGLLA,NGLLB)
+
+ real(kind=CUSTOM_REAL) jacobian2D(NGLLA,NGLLB,NSPEC2DMAX_AB)
+ real(kind=CUSTOM_REAL) normal(3,NGLLA,NGLLB,NSPEC2DMAX_AB)
+
+ integer i,j,ia
+ double precision xxi,xeta,yxi,yeta,zxi,zeta
+ double precision unx,uny,unz,jacobian
+
+ do j=1,NGLLB
+ do i=1,NGLLA
+
+ xxi=ZERO
+ xeta=ZERO
+ yxi=ZERO
+ yeta=ZERO
+ zxi=ZERO
+ zeta=ZERO
+ do ia=1,NGNOD2D
+ xxi=xxi+dershape2D(1,ia,i,j)*xelm(ia)
+ xeta=xeta+dershape2D(2,ia,i,j)*xelm(ia)
+ yxi=yxi+dershape2D(1,ia,i,j)*yelm(ia)
+ yeta=yeta+dershape2D(2,ia,i,j)*yelm(ia)
+ zxi=zxi+dershape2D(1,ia,i,j)*zelm(ia)
+ zeta=zeta+dershape2D(2,ia,i,j)*zelm(ia)
+ enddo
+
+! calculate the unnormalized normal to the boundary
+ unx=yxi*zeta-yeta*zxi
+ uny=zxi*xeta-zeta*xxi
+ unz=xxi*yeta-xeta*yxi
+ jacobian=dsqrt(unx**2+uny**2+unz**2)
+ if(jacobian == ZERO) call exit_MPI(myrank,'2D Jacobian undefined')
+
+! normalize normal vector and store surface jacobian
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ jacobian2D(i,j,ispecb)=sngl(jacobian)
+ normal(1,i,j,ispecb)=sngl(unx/jacobian)
+ normal(2,i,j,ispecb)=sngl(uny/jacobian)
+ normal(3,i,j,ispecb)=sngl(unz/jacobian)
+ else
+ jacobian2D(i,j,ispecb)=jacobian
+ normal(1,i,j,ispecb)=unx/jacobian
+ normal(2,i,j,ispecb)=uny/jacobian
+ normal(3,i,j,ispecb)=unz/jacobian
+ endif
+
+ enddo
+ enddo
+
+ end subroutine compute_jacobian_2D
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_jacobian_discontinuities.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_jacobian_discontinuities.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_jacobian_discontinuities.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -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 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+subroutine get_jacobian_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
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_model.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_model.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,919 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_model(myrank,iregion_code,nspec, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,rhostore, &
+ nspec_ani, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ xelm,yelm,zelm,shape3D,ispec, &
+ rmin,rmax,idoubling, &
+ rho_vp,rho_vs,nspec_stacey, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE, &
+ CRUSTAL,ONE_CRUST,ATTENUATION,ATTENUATION_3D,tau_e_store,Qmu_store,vx,vy,vz,vnspec, &
+ ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ RCMB,RICB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN,&
+ AMM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+
+ implicit none
+
+ include "constants.h"
+
+! aniso_mantle_model_variables
+ type aniso_mantle_model_variables
+ sequence
+ double precision beta(14,34,37,73)
+ double precision pro(47)
+ integer npar1
+ end type aniso_mantle_model_variables
+
+ type (aniso_mantle_model_variables) AMM_V
+! aniso_mantle_model_variables
+
+! model_1066a_variables
+ type model_1066a_variables
+ sequence
+ double precision, dimension(NR_1066A) :: radius_1066a
+ double precision, dimension(NR_1066A) :: density_1066a
+ double precision, dimension(NR_1066A) :: vp_1066a
+ double precision, dimension(NR_1066A) :: vs_1066a
+ double precision, dimension(NR_1066A) :: Qkappa_1066a
+ double precision, dimension(NR_1066A) :: Qmu_1066a
+ end type model_1066a_variables
+
+ type (model_1066a_variables) M1066a_V
+! model_1066a_variables
+
+! model_ak135_variables
+ type model_ak135_variables
+ sequence
+ double precision, dimension(NR_AK135) :: radius_ak135
+ double precision, dimension(NR_AK135) :: density_ak135
+ double precision, dimension(NR_AK135) :: vp_ak135
+ double precision, dimension(NR_AK135) :: vs_ak135
+ double precision, dimension(NR_AK135) :: Qkappa_ak135
+ double precision, dimension(NR_AK135) :: Qmu_ak135
+ end type model_ak135_variables
+
+ type (model_ak135_variables) Mak135_V
+! model_ak135_variables
+
+! model_ref_variables
+ type model_ref_variables
+ sequence
+ double precision, dimension(NR_REF) :: radius_ref
+ double precision, dimension(NR_REF) :: density_ref
+ double precision, dimension(NR_REF) :: vpv_ref
+ double precision, dimension(NR_REF) :: vph_ref
+ double precision, dimension(NR_REF) :: vsv_ref
+ double precision, dimension(NR_REF) :: vsh_ref
+ double precision, dimension(NR_REF) :: eta_ref
+ double precision, dimension(NR_REF) :: Qkappa_ref
+ double precision, dimension(NR_REF) :: Qmu_ref
+ end type model_ref_variables
+
+ type (model_ref_variables) Mref_V
+! model_ref_variables
+
+! sea1d_model_variables
+ type sea1d_model_variables
+ sequence
+ double precision, dimension(NR_SEA1D) :: radius_sea1d
+ double precision, dimension(NR_SEA1D) :: density_sea1d
+ double precision, dimension(NR_SEA1D) :: vp_sea1d
+ double precision, dimension(NR_SEA1D) :: vs_sea1d
+ double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
+ double precision, dimension(NR_SEA1D) :: Qmu_sea1d
+ end type sea1d_model_variables
+
+ type (sea1d_model_variables) SEA1DM_V
+! sea1d_model_variables
+
+! three_d_mantle_model_variables
+
+! three_d_mantle_model_variables
+ type three_d_mantle_model_variables
+ sequence
+ double precision dvs_a(0:NK,0:NS,0:NS)
+ double precision dvs_b(0:NK,0:NS,0:NS)
+ double precision dvp_a(0:NK,0:NS,0:NS)
+ double precision dvp_b(0:NK,0:NS,0:NS)
+ double precision spknt(NK+1)
+ double precision qq0(NK+1,NK+1)
+ double precision qq(3,NK+1,NK+1)
+ end type three_d_mantle_model_variables
+
+ type (three_d_mantle_model_variables) D3MM_V
+! three_d_mantle_model_variables
+
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+! sea99_s_model_variables
+ type sea99_s_model_variables
+ sequence
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ end type sea99_s_model_variables
+
+ type (sea99_s_model_variables) SEA99M_V
+! sea99_s_model_variables
+
+! crustal_model_variables
+ type crustal_model_variables
+ sequence
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
+ character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+ character(len=2) code(NKEYS_CRUST)
+ end type crustal_model_variables
+
+ type (crustal_model_variables) CM_V
+! crustal_model_variables
+
+ integer ispec,nspec,idoubling,iregion_code,myrank,nspec_stacey
+ integer REFERENCE_1D_MODEL,THREE_D_MODEL
+
+ logical ATTENUATION,ATTENUATION_3D,ABSORBING_CONDITIONS
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST
+
+ double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+ double precision rmin,rmax,RCMB,RICB,R670,RMOHO, &
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
+
+ real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) kappahstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) muhstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) eta_anisostore(NGLLX,NGLLY,NGLLZ,nspec)
+
+ real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey),rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey)
+
+ real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer nspec_ani
+
+! the 21 coefficients for an anisotropic medium in reduced notation
+ double precision c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,c33, &
+ c34,c35,c36,c44,c45,c46,c55,c56,c66
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_ani) :: &
+ c11store,c12store,c13store,c14store,c15store,c16store, &
+ c22store,c23store,c24store,c25store,c26store, &
+ c33store,c34store,c35store,c36store, &
+ c44store,c45store,c46store,c55store,c56store,c66store
+
+ double precision xmesh,ymesh,zmesh
+
+ integer i,j,k,ia
+ double precision rho,drhodr,vp,vs,Qkappa,Qmu
+ double precision vpv,vph,vsv,vsh,eta_aniso
+ double precision dvp,dvs,drho
+ real(kind=4) xcolat,xlon,xrad,dvpv,dvph,dvsv,dvsh
+ double precision xstore(NGLLX,NGLLY,NGLLZ)
+ double precision ystore(NGLLX,NGLLY,NGLLZ)
+ double precision zstore(NGLLX,NGLLY,NGLLZ)
+ double precision r,r_prem,r_moho,r_dummy,theta,phi
+ double precision lat,lon
+ double precision vpc,vsc,rhoc,moho
+
+! attenuation values
+ integer vx, vy, vz, vnspec
+ double precision, dimension(N_SLS) :: tau_e
+ double precision, dimension(vx, vy, vz, vnspec) :: Qmu_store
+ double precision, dimension(N_SLS, vx, vy, vz, vnspec) :: tau_e_store
+
+ logical found_crust
+
+ integer, parameter :: maxker=200
+ integer, parameter :: maxl=72
+ integer, parameter :: maxcoe=2000
+ integer, parameter :: maxver=1000
+ integer, parameter :: maxhpa=2
+
+ integer numker
+ integer numhpa,numcof
+ integer ihpa,lmax,nylm
+ integer lmxhpa(maxhpa)
+ integer itypehpa(maxhpa)
+ integer ihpakern(maxker)
+ integer numcoe(maxhpa)
+ integer ivarkern(maxker)
+
+ integer nconpt(maxhpa),iver
+ integer iconpt(maxver,maxhpa)
+ real(kind=4) conpt(maxver,maxhpa)
+
+ real(kind=4) xlaspl(maxcoe,maxhpa)
+ real(kind=4) xlospl(maxcoe,maxhpa)
+ real(kind=4) radspl(maxcoe,maxhpa)
+ real(kind=4) coe(maxcoe,maxker)
+ real(kind=4) vercof(maxker)
+ real(kind=4) vercofd(maxker)
+
+ real(kind=4) ylmcof((maxl+1)**2,maxhpa)
+ real(kind=4) wk1(maxl+1)
+ real(kind=4) wk2(maxl+1)
+ real(kind=4) wk3(maxl+1)
+
+ character(len=80) kerstr
+ character(len=40) varstr(maxker)
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ xmesh = ZERO
+ ymesh = ZERO
+ zmesh = ZERO
+ do ia=1,NGNOD
+ xmesh = xmesh + shape3D(ia,i,j,k)*xelm(ia)
+ ymesh = ymesh + shape3D(ia,i,j,k)*yelm(ia)
+ zmesh = zmesh + shape3D(ia,i,j,k)*zelm(ia)
+ enddo
+ r = dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*zmesh)
+
+ xstore(i,j,k) = xmesh
+ ystore(i,j,k) = ymesh
+ zstore(i,j,k) = zmesh
+
+! make sure we are within the right shell in PREM to honor discontinuities
+! use small geometrical tolerance
+ r_prem = r
+ if(r <= rmin*1.000001d0) r_prem = rmin*1.000001d0
+ if(r >= rmax*0.999999d0) r_prem = rmax*0.999999d0
+
+! get the anisotropic PREM parameters
+ if(TRANSVERSE_ISOTROPY) then
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
+ call prem_aniso(myrank,r_prem,rho,vpv,vph,vsv,vsh,eta_aniso, &
+ Qkappa,Qmu,idoubling,CRUSTAL,ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
+ call model_ref(r_prem,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V)
+
+ else
+ stop 'unknown 1D transversely isotropic reference Earth model in get_model'
+ endif
+
+ else
+
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
+ call model_iasp91(myrank,r_prem,rho,vp,vs,Qkappa,Qmu,idoubling, &
+ ONE_CRUST,.true.,RICB,RCMB,RTOPDDOUBLEPRIME,R771,R670,R400,R220,R120,RMOHO,RMIDDLE_CRUST)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
+ call prem_iso(myrank,r_prem,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, &
+ ONE_CRUST,.true.,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
+ call model_1066a(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,M1066a_V)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
+ call model_ak135(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,Mak135_V)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
+ call model_ref(r_prem,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V)
+ if(.not. ISOTROPIC_3D_MANTLE) then
+ vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
+ endif
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then
+ call model_jp1d(myrank,r_prem,rho,vp,vs,Qkappa,Qmu,idoubling, &
+ .true.,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST)
+ vpv = vp
+ vph = vp
+ vsv = vs
+ vsh = vs
+ eta_aniso = 1.d0
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
+ call model_sea1d(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,SEA1DM_V)
+ vpv = vp
+ vph = vp
+ vsv = vs
+ vsh = vs
+ eta_aniso = 1.d0
+ else
+ stop 'unknown 1D reference Earth model in get_model'
+ endif
+
+ ! in the case of s362iso we want to save the anisotropic constants for the Voight average
+ if(.not. (REFERENCE_1D_MODEL == REFERENCE_MODEL_REF .and. ISOTROPIC_3D_MANTLE)) then
+ vpv = vp
+ vph = vp
+ vsv = vs
+ vsh = vs
+ eta_aniso = 1.d0
+ endif
+ endif
+
+! get the 3-D model parameters
+ if(ISOTROPIC_3D_MANTLE) then
+ if(r_prem > RCMB/R_EARTH .and. r_prem < RMOHO/R_EARTH) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+ if(THREE_D_MODEL == THREE_D_MODEL_S20RTS) then
+! s20rts
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call mantle_model(r,theta,phi,dvs,dvp,drho,D3MM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then
+! sea99 + jp3d1994
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call sea99_s_model(r,theta,phi,dvs,SEA99M_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+! use Lebedev model as background and add vp & vs perturbation from Zhao 1994 model
+ if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
+ .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
+ if(r_prem > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
+ call iso3d_dpzhao_model(r,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ endif
+ endif
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99) then
+! sea99
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call sea99_s_model(r,theta,phi,dvs,SEA99M_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+ elseif(THREE_D_MODEL == THREE_D_MODEL_JP3D) then
+! jp3d1994
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
+ .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
+ if(r_prem > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
+ call iso3d_dpzhao_model(r,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ endif
+ endif
+ elseif(THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI &
+ .or. THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM .or. THREE_D_MODEL == THREE_D_MODEL_S29EA) then
+! 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
+ dvpv = 0.
+ dvph = 0.
+ dvsv = 0.
+ dvsh = 0.
+ xcolat = sngl(theta*180.0d0/PI)
+ xlon = sngl(phi*180.0d0/PI)
+ xrad = sngl(r*R_EARTH_KM)
+ call subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+ if(TRANSVERSE_ISOTROPY) then
+ vpv=vpv*(1.0d0+dble(dvpv))
+ vph=vph*(1.0d0+dble(dvph))
+ vsv=vsv*(1.0d0+dble(dvsv))
+ vsh=vsh*(1.0d0+dble(dvsh))
+ else
+ vpv=vpv+dvpv
+ vph=vph+dvph
+ vsv=vsv+dvsv
+ vsh=vsh+dvsh
+ vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vpv=vp
+ vph=vp
+ vsv=vs
+ vsh=vs
+ eta_aniso=1.0d0
+ endif
+ else
+ stop 'unknown 3D Earth model in get_model'
+ endif
+
+! extend 3-D mantle model above the Moho to the surface before adding the crust
+ else if(r_prem >= RMOHO/R_EARTH) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+ r_moho = 0.999999d0*RMOHO/R_EARTH
+ if(THREE_D_MODEL == THREE_D_MODEL_S20RTS) then
+! s20rts
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call mantle_model(r_moho,theta,phi,dvs,dvp,drho,D3MM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then
+! sea99 + jp3d1994
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call sea99_s_model(r_moho,theta,phi,dvs,SEA99M_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+! use Lebedev's model as background and add vp & vs perturbation from Zhao's 1994 model
+ if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
+ .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
+ call iso3d_dpzhao_model(r_moho,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ endif
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99) then
+! sea99
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call sea99_s_model(r_moho,theta,phi,dvs,SEA99M_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+ elseif(THREE_D_MODEL == THREE_D_MODEL_JP3D) then
+! jp3d1994
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
+ .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
+ call iso3d_dpzhao_model(r_moho,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ endif
+ elseif(THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI &
+ .or. THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM .or. THREE_D_MODEL == THREE_D_MODEL_S29EA) then
+! 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
+ dvpv = 0.
+ dvph = 0.
+ dvsv = 0.
+ dvsh = 0.
+ xcolat = sngl(theta*180.0d0/PI)
+ xlon = sngl(phi*180.0d0/PI)
+ xrad = sngl(r_moho*R_EARTH_KM)
+ call subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+ if(TRANSVERSE_ISOTROPY) then
+ vpv=vpv*(1.0d0+dble(dvpv))
+ vph=vph*(1.0d0+dble(dvph))
+ vsv=vsv*(1.0d0+dble(dvsv))
+ vsh=vsh*(1.0d0+dble(dvsh))
+ else
+ vpv=vpv+dvpv
+ vph=vph+dvph
+ vsv=vsv+dvsv
+ vsh=vsh+dvsh
+ vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vpv=vp
+ vph=vp
+ vsv=vs
+ vsh=vs
+ eta_aniso=1.0d0
+ endif
+ else
+ stop 'unknown 3D Earth model in get_model'
+ endif
+
+ endif
+ endif
+
+ if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) &
+ call aniso_inner_core_model(r_prem,c11,c33,c12,c13,c44,REFERENCE_1D_MODEL)
+
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+
+! anisotropic model between the Moho and 670 km (change to CMB if desired)
+ if(r_prem < RMOHO/R_EARTH .and. r_prem > R670/R_EARTH) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+ call aniso_mantle_model(r_prem,theta,phi,rho,c11,c12,c13,c14,c15,c16, &
+ c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66,AMM_V)
+! extend 3-D mantle model above the Moho to the surface before adding the crust
+ elseif(r_prem >= RMOHO/R_EARTH) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+ r_moho = RMOHO/R_EARTH
+ call aniso_mantle_model(r_moho,theta,phi,rho,c11,c12,c13,c14,c15,c16, &
+ c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66,AMM_V)
+! fill the rest of the mantle with the isotropic model
+ else
+ c11 = rho*vpv*vpv
+ c12 = rho*(vpv*vpv-2.*vsv*vsv)
+ c13 = c12
+ c14 = 0.
+ c15 = 0.
+ c16 = 0.
+ c22 = c11
+ c23 = c12
+ c24 = 0.
+ c25 = 0.
+ c26 = 0.
+ c33 = c11
+ c34 = 0.
+ c35 = 0.
+ c36 = 0.
+ c44 = rho*vsv*vsv
+ c45 = 0.
+ c46 = 0.
+ c55 = c44
+ c56 = 0.
+ c66 = c44
+ endif
+ endif
+
+! This is here to identify how and where to include 3D attenuation
+ if(ATTENUATION .and. ATTENUATION_3D) then
+ tau_e(:) = 0.0d0
+ ! Get the value of Qmu (Attenuation) dependedent on
+ ! the radius (r_prem) and idoubling flag
+!! DK DK removed attenuation for MPI + GPU version call attenuation_model_1D_PREM(r_prem, Qmu, idoubling)
+ ! Get tau_e from tau_s and Qmu
+!! DK DK removed attenuation for MPI + GPU version
+!! DK DK call attenuation_conversion(Qmu, T_c_source, tau_s, tau_e, AM_V, AM_S, AS_V)
+ endif
+
+! get the 3-D crustal model
+ if(CRUSTAL) then
+ if(r > R_DEEPEST_CRUST) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+
+ if(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D .or. THREE_D_MODEL == THREE_D_MODEL_JP3D) then
+ if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
+ .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
+ if(r > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
+ call iso3d_dpzhao_model(r,theta,phi,vpc,vsc,dvp,dvs,rhoc,found_crust,JP3DM_V)
+ if(found_crust) then
+ vpv=vpc
+ vph=vpc
+ vsv=vsc
+ vsh=vsc
+! rho=rhoc
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+ c11 = rho*vpv*vpv
+ c12 = rho*(vpv*vpv-2.*vsv*vsv)
+ c13 = c12
+ c14 = 0.
+ c15 = 0.
+ c16 = 0.
+ c22 = c11
+ c23 = c12
+ c24 = 0.
+ c25 = 0.
+ c26 = 0.
+ c33 = c11
+ c34 = 0.
+ c35 = 0.
+ c36 = 0.
+ c44 = rho*vsv*vsv
+ c45 = 0.
+ c46 = 0.
+ c55 = c44
+ c56 = 0.
+ c66 = c44
+ endif
+ endif
+ endif
+ else
+ lat=(PI/2.0d0-theta)*180.0d0/PI
+ lon=phi*180.0d0/PI
+ if(lon>180.0d0) lon=lon-360.0d0
+ call crustal_model(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,CM_V)
+ if (found_crust) then
+ vpv=vpc
+ vph=vpc
+ vsv=vsc
+ vsh=vsc
+ rho=rhoc
+ eta_aniso=1.0d0
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+ c11 = rho*vpv*vpv
+ c12 = rho*(vpv*vpv-2.*vsv*vsv)
+ c13 = c12
+ c14 = 0.
+ c15 = 0.
+ c16 = 0.
+ c22 = c11
+ c23 = c12
+ c24 = 0.
+ c25 = 0.
+ c26 = 0.
+ c33 = c11
+ c34 = 0.
+ c35 = 0.
+ c36 = 0.
+ c44 = rho*vsv*vsv
+ c45 = 0.
+ c46 = 0.
+ c55 = c44
+ c56 = 0.
+ c66 = c44
+ endif
+ endif
+ endif
+ else
+ lat=(PI/2.0d0-theta)*180.0d0/PI
+ lon=phi*180.0d0/PI
+ if(lon>180.0d0) lon=lon-360.0d0
+ call crustal_model(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,CM_V)
+ if (found_crust) then
+ vpv=vpc
+ vph=vpc
+ vsv=vsc
+ vsh=vsc
+ rho=rhoc
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+ c11 = rho*vpv*vpv
+ c12 = rho*(vpv*vpv-2.*vsv*vsv)
+ c13 = c12
+ c14 = 0.
+ c15 = 0.
+ c16 = 0.
+ c22 = c11
+ c23 = c12
+ c24 = 0.
+ c25 = 0.
+ c26 = 0.
+ c33 = c11
+ c34 = 0.
+ c35 = 0.
+ c36 = 0.
+ c44 = rho*vsv*vsv
+ c45 = 0.
+ c46 = 0.
+ c55 = c44
+ c56 = 0.
+ c66 = c44
+ endif
+ endif
+ endif
+ endif
+ endif
+
+! define elastic parameters in the model
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+
+ 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(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
+
+
+ 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(ABSORBING_CONDITIONS) then
+ if(iregion_code == IREGION_OUTER_CORE) then
+! we need just vp in the outer core for Stacey conditions
+ rho_vp(i,j,k,ispec) = vph
+ rho_vs(i,j,k,ispec) = 0.d0
+ else
+ rho_vp(i,j,k,ispec) = rho*vph
+ rho_vs(i,j,k,ispec) = rho*vsh
+ endif
+ endif
+
+ if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then
+ c11store(i,j,k,ispec) = c11
+ c33store(i,j,k,ispec) = c33
+ c12store(i,j,k,ispec) = c12
+ c13store(i,j,k,ispec) = c13
+ c44store(i,j,k,ispec) = c44
+ endif
+
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+ c11store(i,j,k,ispec) = c11
+ c12store(i,j,k,ispec) = c12
+ c13store(i,j,k,ispec) = c13
+ c14store(i,j,k,ispec) = c14
+ c15store(i,j,k,ispec) = c15
+ c16store(i,j,k,ispec) = c16
+ c22store(i,j,k,ispec) = c22
+ c23store(i,j,k,ispec) = c23
+ c24store(i,j,k,ispec) = c24
+ c25store(i,j,k,ispec) = c25
+ c26store(i,j,k,ispec) = c26
+ c33store(i,j,k,ispec) = c33
+ c34store(i,j,k,ispec) = c34
+ c35store(i,j,k,ispec) = c35
+ c36store(i,j,k,ispec) = c36
+ c44store(i,j,k,ispec) = c44
+ c45store(i,j,k,ispec) = c45
+ c46store(i,j,k,ispec) = c46
+ c55store(i,j,k,ispec) = c55
+ c56store(i,j,k,ispec) = c56
+ c66store(i,j,k,ispec) = c66
+ endif
+
+ endif
+
+ if(ATTENUATION .and. ATTENUATION_3D) then
+ tau_e_store(:,i,j,k,ispec) = tau_e(:)
+ Qmu_store(i,j,k,ispec) = Qmu
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine get_model
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_perm_color.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_perm_color.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_perm_color.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,567 @@
+
+! define sets of colors that contain disconnected elements for the CUDA solver.
+! also split the elements into two subsets: inner and outer elements, in order
+! to be able to compute the outer elements first in the solver and then
+! start non-blocking MPI calls and overlap them with the calculation of the inner elements
+! (which works fine because there are always far more inner elements than outer elements)
+
+ subroutine get_perm_color(is_on_a_slice_edge,ibool,perm,nspec,nglob, &
+ nb_colors_outer_elements,nb_colors_inner_elements,nspec_outer,first_elem_number_in_this_color,myrank)
+
+ implicit none
+
+ include "constants.h"
+
+ logical, dimension(nspec) :: is_on_a_slice_edge
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ integer, dimension(nspec) :: perm
+ integer, dimension(nspec) :: color
+ integer, dimension(MAX_NUMBER_OF_COLORS) :: first_elem_number_in_this_color
+ integer :: nb_colors_outer_elements,nb_colors_inner_elements,nspec_outer,myrank
+
+! local variables
+ integer nspec,nglob_GLL_full
+
+! a neighbor of a hexahedral node is a hexahedron that shares a face with it -> max degree of a node = 6
+ integer, parameter :: MAX_NUMBER_OF_NEIGHBORS = 100
+
+! global corner numbers that need to be created
+ integer, dimension(nglob) :: global_corner_number
+
+ integer mn(nspec*NGNOD_HEXAHEDRA),mp(nspec+1)
+ integer, dimension(:), allocatable :: ne,np,adj
+ integer xadj(nspec+1)
+
+ logical maskel(nspec)
+
+ integer i,istart,istop,number_of_neighbors
+
+ integer nglob_eight_corners_only,nglob
+
+! only count the total size of the array that will be created, or actually create it
+ logical count_only
+ integer total_size_ne,total_size_adj
+
+!
+!-----------------------------------------------------------------------
+!
+
+! total number of points in the mesh
+ nglob_GLL_full = nglob
+
+!---- call Charbel Farhat's routines
+ if(myrank == 0) &
+ write(IMAIN,*) 'calling form_elt_connectivity_foelco to perform mesh coloring and inner/outer element splitting'
+ call form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number,nglob_GLL_full,ibool,nglob_eight_corners_only)
+ do i=1,nspec
+ istart = mp(i)
+ istop = mp(i+1) - 1
+ enddo
+
+! count only, to determine the size needed for the array
+ allocate(np(nglob_eight_corners_only+1))
+ count_only = .true.
+ total_size_ne = 1
+ if(myrank == 0) write(IMAIN,*) 'calling form_node_connectivity_fonoco to determine the size of the table'
+ allocate(ne(total_size_ne))
+ call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_eight_corners_only,nspec,count_only,total_size_ne)
+ deallocate(ne)
+
+! allocate the array with the right size
+ allocate(ne(total_size_ne))
+
+! now actually generate the array
+ count_only = .false.
+ if(myrank == 0) write(IMAIN,*) 'calling form_node_connectivity_fonoco to actually create the table'
+ call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_eight_corners_only,nspec,count_only,total_size_ne)
+ do i=1,nglob_eight_corners_only
+ istart = np(i)
+ istop = np(i+1) - 1
+ enddo
+
+! count only, to determine the size needed for the array
+ count_only = .true.
+ total_size_adj = 1
+ if(myrank == 0) write(IMAIN,*) 'calling create_adjacency_table_adjncy to determine the size of the table'
+ allocate(adj(total_size_adj))
+ call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_eight_corners_only,&
+ count_only,total_size_ne,total_size_adj,.false.)
+ deallocate(adj)
+
+! allocate the array with the right size
+ allocate(adj(total_size_adj))
+
+! now actually generate the array
+ count_only = .false.
+ if(myrank == 0) write(IMAIN,*) 'calling create_adjacency_table_adjncy again to actually create the table'
+ call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_eight_corners_only,&
+ count_only,total_size_ne,total_size_adj,.false.)
+
+ do i=1,nspec
+ istart = xadj(i)
+ istop = xadj(i+1) - 1
+ number_of_neighbors = istop-istart+1
+ if(number_of_neighbors < 1 .or. number_of_neighbors > MAX_NUMBER_OF_NEIGHBORS) stop 'incorrect number of neighbors'
+ enddo
+
+ deallocate(ne,np)
+
+ call get_color(adj,xadj,color,nspec,total_size_adj,is_on_a_slice_edge, &
+ nb_colors_outer_elements,nb_colors_inner_elements,nspec_outer)
+
+ if(myrank == 0) then
+ write(IMAIN,*) 'number of colors of the graph for inner elements = ',nb_colors_inner_elements
+ write(IMAIN,*) 'number of colors of the graph for outer elements = ',nb_colors_outer_elements
+ write(IMAIN,*) 'total number of colors of the graph (sum of both) = ', &
+ nb_colors_inner_elements + nb_colors_outer_elements
+ write(IMAIN,*) 'number of elements of the graph for outer elements = ',nspec_outer
+ endif
+
+ deallocate(adj)
+
+ if(myrank == 0) write(IMAIN,*) 'generating the final colors'
+ first_elem_number_in_this_color(:) = -1
+ call get_final_perm(color,perm,first_elem_number_in_this_color,nspec,nb_colors_inner_elements+nb_colors_outer_elements)
+
+ if(myrank == 0) write(IMAIN,*) 'done with mesh coloring and inner/outer element splitting'
+
+ end subroutine get_perm_color
+
+!------------------------------------------------------------------
+
+subroutine get_final_perm(color,perm,first_elem_number_in_this_color,nspec,nb_color)
+
+ integer, intent(in) :: nspec,nb_color
+ integer, intent(in) :: color(nspec)
+ integer, intent(inout) :: perm(nspec)
+ integer, intent(inout) :: first_elem_number_in_this_color(nb_color)
+ integer :: ielem,icolor,counter
+
+ counter = 1
+ do icolor = 1, nb_color
+ first_elem_number_in_this_color(icolor) = counter
+ do ielem = 1, nspec
+ if(color(ielem) == icolor) then
+ perm(ielem) = counter
+ counter = counter + 1
+ endif
+ enddo
+ enddo
+
+end subroutine get_final_perm
+
+!------------------------------------------------------------------
+
+subroutine get_color(adj,xadj,color,nspec,total_size_adj,is_on_a_slice_edge, &
+ nb_colors_outer_elements,nb_colors_inner_elements,nspec_outer)
+
+ integer, intent(in) :: nspec,total_size_adj
+ integer, intent(in) :: adj(total_size_adj),xadj(nspec+1)
+ integer :: color(nspec)
+ integer :: this_color,nb_already_colored,ispec,ixadj,ok
+ logical, dimension(nspec) :: is_on_a_slice_edge
+ integer :: nb_colors_outer_elements,nb_colors_inner_elements,nspec_outer
+ logical :: is_outer_element(nspec)
+
+ nspec_outer = 0
+
+ is_outer_element(:) = .false.
+
+ do ispec=1,nspec
+ if (is_on_a_slice_edge(ispec)) then
+ is_outer_element(ispec) = .true.
+ nspec_outer=nspec_outer+1
+ endif
+ enddo
+
+! outer elements
+ color(:) = 0
+ this_color = 0
+ nb_already_colored = 0
+ do while(nb_already_colored<nspec_outer)
+ this_color = this_color + 1
+ do ispec = 1, nspec
+ if (is_outer_element(ispec)) then
+ if (color(ispec) == 0) then
+ ok = 1
+ do ixadj = xadj(ispec), (xadj(ispec+1)-1)
+ if (is_outer_element(adj(ixadj)) .and. color(adj(ixadj)) == this_color) ok = 0
+ enddo
+ if (ok /= 0) then
+ color(ispec) = this_color
+ nb_already_colored = nb_already_colored + 1
+ endif
+ endif
+ endif
+ enddo
+ enddo
+ nb_colors_outer_elements = this_color
+
+! inner elements
+ do while(nb_already_colored<nspec)
+ this_color = this_color + 1
+ do ispec = 1, nspec
+ if (.not. is_outer_element(ispec)) then
+ if (color(ispec) == 0) then
+ ok = 1
+ do ixadj = xadj(ispec), (xadj(ispec+1)-1)
+ if (.not. is_outer_element(adj(ixadj)) .and. color(adj(ixadj)) == this_color) ok = 0
+ enddo
+ if (ok /= 0) then
+ color(ispec) = this_color
+ nb_already_colored = nb_already_colored + 1
+ endif
+ endif
+ endif
+ enddo
+ enddo
+
+ nb_colors_inner_elements = this_color - nb_colors_outer_elements
+
+end subroutine get_color
+
+!------------------------------------------------------------------
+
+!=======================================================================
+!
+! Charbel Farhat's FEM topology routines
+!
+! Dimitri Komatitsch, February 1996 - Code based on Farhat's original version from 1987
+!
+! modified and adapted by Dimitri Komatitsch, May 2006
+!
+!=======================================================================
+
+ subroutine form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number,&
+nglob_GLL_full,ibool,nglob_eight_corners_only)
+
+!-----------------------------------------------------------------------
+!
+! Forms the MN and MP arrays
+!
+! Input :
+! -------
+! ibool Array needed to build the element connectivity table
+! nspec Number of elements in the domain
+! NGNOD_HEXAHEDRA number of nodes per hexahedron (brick with 8 corners)
+!
+! Output :
+! --------
+! MN, MP This is the element connectivity array pair.
+! Array MN contains the list of the element
+! connectivity, that is, the nodes contained in each
+! element. They are stored in a stacked fashion.
+!
+! Pointer array MP stores the location of each
+! element list. Its length is equal to the number
+! of elements plus one.
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,nglob_GLL_full
+
+! arrays with mesh parameters per slice
+ integer, intent(in), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+! global corner numbers that need to be created
+ integer, intent(out), dimension(nglob_GLL_full) :: global_corner_number
+ integer, intent(out) :: mn(nspec*NGNOD_HEXAHEDRA),mp(nspec+1)
+ integer, intent(out) :: nglob_eight_corners_only
+
+ integer ninter,nsum,ispec,node,k,inumcorner,ix,iy,iz
+
+ ninter = 1
+ nsum = 1
+ mp(1) = 1
+
+!---- define topology of the elements in the mesh
+!---- we need to define adjacent numbers from the sub-mesh consisting of the corners only
+ nglob_eight_corners_only = 0
+ global_corner_number(:) = -1
+
+ do ispec=1,nspec
+
+ inumcorner = 0
+ do iz = 1,NGLLZ,NGLLZ-1
+ do iy = 1,NGLLY,NGLLY-1
+ do ix = 1,NGLLX,NGLLX-1
+
+ inumcorner = inumcorner + 1
+ if(inumcorner > NGNOD_HEXAHEDRA) stop 'corner number too large'
+
+! check if this point was already assigned a number previously, otherwise create one and store it
+ if(global_corner_number(ibool(ix,iy,iz,ispec)) == -1) then
+ nglob_eight_corners_only = nglob_eight_corners_only + 1
+ global_corner_number(ibool(ix,iy,iz,ispec)) = nglob_eight_corners_only
+ endif
+
+ node = global_corner_number(ibool(ix,iy,iz,ispec))
+ do k=nsum,ninter-1
+ if(node == mn(k)) goto 200
+ enddo
+
+ mn(ninter) = node
+ ninter = ninter + 1
+ 200 continue
+
+ enddo
+ enddo
+ enddo
+
+ nsum = ninter
+ mp(ispec + 1) = nsum
+
+ enddo
+
+ end subroutine form_elt_connectivity_foelco
+
+!
+!----------------------------------------------------
+!
+
+ subroutine form_node_connectivity_fonoco(mn,mp,ne,np,nglob_eight_corners_only,&
+nspec,count_only,total_size_ne)
+
+!-----------------------------------------------------------------------
+!
+! Forms the NE and NP arrays
+!
+! Input :
+! -------
+! MN, MP, nspec
+! nglob_eight_corners_only Number of nodes in the domain
+!
+! Output :
+! --------
+! NE, NP This is the node-connected element array pair.
+! Integer array NE contains a list of the
+! elements connected to each node, stored in stacked fashion.
+!
+! Array NP is the pointer array for the
+! location of a node's element list in the NE array.
+! Its length is equal to the number of points plus one.
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+
+ include "constants.h"
+
+! only count the total size of the array that will be created, or actually create it
+ logical count_only
+ integer total_size_ne
+
+ integer nglob_eight_corners_only,nspec
+
+ integer, intent(in) :: mn(nspec*NGNOD_HEXAHEDRA),mp(nspec+1)
+
+ integer, intent(out) :: ne(total_size_ne),np(nglob_eight_corners_only+1)
+
+ integer nsum,inode,ispec,j
+
+ nsum = 1
+ np(1) = 1
+
+ do inode=1,nglob_eight_corners_only
+ do 200 ispec=1,nspec
+
+ do j=mp(ispec),mp(ispec + 1) - 1
+ if (mn(j) == inode) then
+ if(count_only) then
+ total_size_ne = nsum
+ else
+ ne(nsum) = ispec
+ endif
+ nsum = nsum + 1
+ goto 200
+ endif
+ enddo
+ 200 continue
+
+ np(inode + 1) = nsum
+
+ enddo
+
+ end subroutine form_node_connectivity_fonoco
+
+!
+!----------------------------------------------------
+!
+
+ subroutine create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_eight_corners_only,&
+ count_only,total_size_ne,total_size_adj,face)
+
+!-----------------------------------------------------------------------
+!
+! Establishes the element adjacency information of the mesh
+! Two elements are considered adjacent if they share a face.
+!
+! Input :
+! -------
+! MN, MP, NE, NP, nspec
+! MASKEL logical mask (length = nspec)
+!
+! Output :
+! --------
+! ADJ, XADJ This is the element adjacency array pair. Array
+! ADJ contains the list of the elements adjacent to
+! element i. They are stored in a stacked fashion.
+! Pointer array XADJ stores the location of each element list.
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+
+ include "constants.h"
+
+! only count the total size of the array that will be created, or actually create it
+ logical count_only,face
+ integer total_size_ne,total_size_adj
+
+ integer nglob_eight_corners_only
+
+ integer, intent(in) :: mn(nspec*NGNOD_HEXAHEDRA),mp(nspec+1),ne(total_size_ne),np(nglob_eight_corners_only+1)
+
+ integer, intent(out) :: adj(total_size_adj),xadj(nspec+1)
+
+ logical maskel(nspec)
+ integer countel(nspec)
+
+ integer nspec,iad,ispec,istart,istop,ino,node,jstart,jstop,nelem,jel
+
+ xadj(1) = 1
+ iad = 1
+
+ do ispec=1,nspec
+
+! reset mask
+ maskel(:) = .false.
+
+! mask current element
+ maskel(ispec) = .true.
+ if (face) countel(:) = 0
+
+ istart = mp(ispec)
+ istop = mp(ispec+1) - 1
+ do ino=istart,istop
+ node = mn(ino)
+ jstart = np(node)
+ jstop = np(node + 1) - 1
+ do 120 jel=jstart,jstop
+ nelem = ne(jel)
+ if(maskel(nelem)) goto 120
+ if (face) then
+ ! if 2 elements share at least 3 corners, therefore they share a face
+ countel(nelem) = countel(nelem) + 1
+ if (countel(nelem)>=3) then
+ if(count_only) then
+ total_size_adj = iad
+ else
+ adj(iad) = nelem
+ endif
+ maskel(nelem) = .true.
+ iad = iad + 1
+ endif
+ else
+ if(count_only) then
+ total_size_adj = iad
+ else
+ adj(iad) = nelem
+ endif
+ maskel(nelem) = .true.
+ iad = iad + 1
+ endif
+ 120 continue
+ enddo
+
+ xadj(ispec+1) = iad
+
+ enddo
+
+ end subroutine create_adjacency_table_adjncy
+
+
+ subroutine permute_elements_real(array_to_permute,temp_array,perm,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nspec
+ integer, intent(in), dimension(nspec) :: perm
+
+ real(kind=CUSTOM_REAL), intent(inout), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: array_to_permute,temp_array
+
+ integer old_ispec,new_ispec
+
+! copy the original array
+ temp_array(:,:,:,:) = array_to_permute(:,:,:,:)
+
+ do old_ispec = 1,nspec
+ new_ispec = perm(old_ispec)
+ array_to_permute(:,:,:,new_ispec) = temp_array(:,:,:,old_ispec)
+ enddo
+
+ end subroutine permute_elements_real
+
+!
+!-----------------------------------------------------------------------
+!
+
+! implement permutation of elements for arrays of integer type
+ subroutine permute_elements_integer(array_to_permute,temp_array,perm,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nspec
+ integer, intent(in), dimension(nspec) :: perm
+
+ integer, intent(inout), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: array_to_permute,temp_array
+
+ integer old_ispec,new_ispec
+
+! copy the original array
+ temp_array(:,:,:,:) = array_to_permute(:,:,:,:)
+
+ do old_ispec = 1,nspec
+ new_ispec = perm(old_ispec)
+ array_to_permute(:,:,:,new_ispec) = temp_array(:,:,:,old_ispec)
+ enddo
+
+ end subroutine permute_elements_integer
+
+!
+!-----------------------------------------------------------------------
+!
+
+! implement permutation of elements for arrays of double precision type
+ subroutine permute_elements_dble(array_to_permute,temp_array,perm,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nspec
+ integer, intent(in), dimension(nspec) :: perm
+
+ double precision, intent(inout), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: array_to_permute,temp_array
+
+ integer old_ispec,new_ispec
+
+! copy the original array
+ temp_array(:,:,:,:) = array_to_permute(:,:,:,:)
+
+ do old_ispec = 1,nspec
+ new_ispec = perm(old_ispec)
+ array_to_permute(:,:,:,new_ispec) = temp_array(:,:,:,old_ispec)
+ enddo
+
+ end subroutine permute_elements_dble
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_shape2D.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_shape2D.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_shape2D.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,160 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_shape2D(myrank,shape2D,dershape2D,xigll,yigll,NGLLA,NGLLB)
+
+ implicit none
+
+ include "constants.h"
+
+! generic routine that accepts any polynomial degree in each direction
+
+ integer NGLLA,NGLLB,myrank
+
+ double precision xigll(NGLLA)
+ double precision yigll(NGLLB)
+
+! 2D shape functions and their derivatives
+ double precision shape2D(NGNOD2D,NGLLA,NGLLB)
+ double precision dershape2D(NDIM2D,NGNOD2D,NGLLA,NGLLB)
+
+ integer i,j,ia
+
+! location of the nodes of the 2D quadrilateral elements
+ double precision xi,eta
+ double precision l1xi,l2xi,l3xi,l1eta,l2eta,l3eta
+ double precision l1pxi,l2pxi,l3pxi,l1peta,l2peta,l3peta
+
+! for checking the 2D shape functions
+ double precision sumshape,sumdershapexi,sumdershapeeta
+
+! check that the parameter file is correct
+ if(NGNOD /= 27) call exit_MPI(myrank,'elements should have 27 control nodes')
+ if(NGNOD2D /= 9) call exit_MPI(myrank,'surface elements should have 9 control nodes')
+
+! generate the 2D shape functions and their derivatives (9 nodes)
+ do i=1,NGLLA
+
+ xi=xigll(i)
+
+ l1xi=HALF*xi*(xi-ONE)
+ l2xi=ONE-xi**2
+ l3xi=HALF*xi*(xi+ONE)
+
+ l1pxi=xi-HALF
+ l2pxi=-TWO*xi
+ l3pxi=xi+HALF
+
+ do j=1,NGLLB
+
+ eta=yigll(j)
+
+ l1eta=HALF*eta*(eta-ONE)
+ l2eta=ONE-eta**2
+ l3eta=HALF*eta*(eta+ONE)
+
+ l1peta=eta-HALF
+ l2peta=-TWO*eta
+ l3peta=eta+HALF
+
+! corner nodes
+
+ shape2D(1,i,j)=l1xi*l1eta
+ shape2D(2,i,j)=l3xi*l1eta
+ shape2D(3,i,j)=l3xi*l3eta
+ shape2D(4,i,j)=l1xi*l3eta
+
+ dershape2D(1,1,i,j)=l1pxi*l1eta
+ dershape2D(1,2,i,j)=l3pxi*l1eta
+ dershape2D(1,3,i,j)=l3pxi*l3eta
+ dershape2D(1,4,i,j)=l1pxi*l3eta
+
+ dershape2D(2,1,i,j)=l1xi*l1peta
+ dershape2D(2,2,i,j)=l3xi*l1peta
+ dershape2D(2,3,i,j)=l3xi*l3peta
+ dershape2D(2,4,i,j)=l1xi*l3peta
+
+! midside nodes
+
+ shape2D(5,i,j)=l2xi*l1eta
+ shape2D(6,i,j)=l3xi*l2eta
+ shape2D(7,i,j)=l2xi*l3eta
+ shape2D(8,i,j)=l1xi*l2eta
+
+ dershape2D(1,5,i,j)=l2pxi*l1eta
+ dershape2D(1,6,i,j)=l3pxi*l2eta
+ dershape2D(1,7,i,j)=l2pxi*l3eta
+ dershape2D(1,8,i,j)=l1pxi*l2eta
+
+ dershape2D(2,5,i,j)=l2xi*l1peta
+ dershape2D(2,6,i,j)=l3xi*l2peta
+ dershape2D(2,7,i,j)=l2xi*l3peta
+ dershape2D(2,8,i,j)=l1xi*l2peta
+
+! center node
+
+ shape2D(9,i,j)=l2xi*l2eta
+
+ dershape2D(1,9,i,j)=l2pxi*l2eta
+ dershape2D(2,9,i,j)=l2xi*l2peta
+
+ enddo
+ enddo
+
+! check the 2D shape functions
+ do i=1,NGLLA
+ do j=1,NGLLB
+
+ sumshape=ZERO
+
+ sumdershapexi=ZERO
+ sumdershapeeta=ZERO
+
+ do ia=1,NGNOD2D
+
+ sumshape=sumshape+shape2D(ia,i,j)
+
+ sumdershapexi=sumdershapexi+dershape2D(1,ia,i,j)
+ sumdershapeeta=sumdershapeeta+dershape2D(2,ia,i,j)
+
+ enddo
+
+! the sum of the shape functions should be 1
+ if(abs(sumshape-ONE)>TINYVAL) call exit_MPI(myrank,'error in 2D shape functions')
+
+! the sum of the derivatives of the shape functions should be 0
+ if(abs(sumdershapexi)>TINYVAL) &
+ call exit_MPI(myrank,'error in xi derivatives of 2D shape function')
+
+ if(abs(sumdershapeeta)>TINYVAL) &
+ call exit_MPI(myrank,'error in eta derivatives of 2D shape function')
+
+ enddo
+ enddo
+
+ end subroutine get_shape2D
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_shape3D.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_shape3D.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_shape3D.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,268 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_shape3D(myrank,shape3D,dershape3D,xigll,yigll,zigll)
+
+ implicit none
+
+ include "constants.h"
+
+ integer myrank
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision xigll(NGLLX)
+ double precision yigll(NGLLY)
+ double precision zigll(NGLLZ)
+
+! 3D shape functions and their derivatives
+ double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
+ double precision dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ)
+
+ integer i,j,k,ia
+
+! location of the nodes of the 3D quadrilateral elements
+ double precision xi,eta,gamma
+ double precision l1xi,l2xi,l3xi,l1eta,l2eta,l3eta,l1gamma,l2gamma,l3gamma
+ double precision l1pxi,l2pxi,l3pxi,l1peta,l2peta,l3peta,l1pgamma,l2pgamma,l3pgamma
+
+! for checking the 3D shape functions
+ double precision sumshape,sumdershapexi,sumdershapeeta,sumdershapegamma
+
+! check that the parameter file is correct
+ if(NGNOD /= 27) call exit_MPI(myrank,'elements should have 27 control nodes')
+
+! generate the 3D shape functions and their derivatives (27 nodes)
+ do i=1,NGLLX
+
+ xi=xigll(i)
+
+ l1xi=HALF*xi*(xi-ONE)
+ l2xi=ONE-xi**2
+ l3xi=HALF*xi*(xi+ONE)
+
+ l1pxi=xi-HALF
+ l2pxi=-TWO*xi
+ l3pxi=xi+HALF
+
+ do j=1,NGLLY
+
+ eta=yigll(j)
+
+ l1eta=HALF*eta*(eta-ONE)
+ l2eta=ONE-eta**2
+ l3eta=HALF*eta*(eta+ONE)
+
+ l1peta=eta-HALF
+ l2peta=-TWO*eta
+ l3peta=eta+HALF
+
+ do k=1,NGLLZ
+
+ gamma=zigll(k)
+
+ l1gamma=HALF*gamma*(gamma-ONE)
+ l2gamma=ONE-gamma**2
+ l3gamma=HALF*gamma*(gamma+ONE)
+
+ l1pgamma=gamma-HALF
+ l2pgamma=-TWO*gamma
+ l3pgamma=gamma+HALF
+
+! corner nodes
+
+ shape3D(1,i,j,k)=l1xi*l1eta*l1gamma
+ shape3D(2,i,j,k)=l3xi*l1eta*l1gamma
+ shape3D(3,i,j,k)=l3xi*l3eta*l1gamma
+ shape3D(4,i,j,k)=l1xi*l3eta*l1gamma
+ shape3D(5,i,j,k)=l1xi*l1eta*l3gamma
+ shape3D(6,i,j,k)=l3xi*l1eta*l3gamma
+ shape3D(7,i,j,k)=l3xi*l3eta*l3gamma
+ shape3D(8,i,j,k)=l1xi*l3eta*l3gamma
+
+ dershape3D(1,1,i,j,k)=l1pxi*l1eta*l1gamma
+ dershape3D(1,2,i,j,k)=l3pxi*l1eta*l1gamma
+ dershape3D(1,3,i,j,k)=l3pxi*l3eta*l1gamma
+ dershape3D(1,4,i,j,k)=l1pxi*l3eta*l1gamma
+ dershape3D(1,5,i,j,k)=l1pxi*l1eta*l3gamma
+ dershape3D(1,6,i,j,k)=l3pxi*l1eta*l3gamma
+ dershape3D(1,7,i,j,k)=l3pxi*l3eta*l3gamma
+ dershape3D(1,8,i,j,k)=l1pxi*l3eta*l3gamma
+
+ dershape3D(2,1,i,j,k)=l1xi*l1peta*l1gamma
+ dershape3D(2,2,i,j,k)=l3xi*l1peta*l1gamma
+ dershape3D(2,3,i,j,k)=l3xi*l3peta*l1gamma
+ dershape3D(2,4,i,j,k)=l1xi*l3peta*l1gamma
+ dershape3D(2,5,i,j,k)=l1xi*l1peta*l3gamma
+ dershape3D(2,6,i,j,k)=l3xi*l1peta*l3gamma
+ dershape3D(2,7,i,j,k)=l3xi*l3peta*l3gamma
+ dershape3D(2,8,i,j,k)=l1xi*l3peta*l3gamma
+
+ dershape3D(3,1,i,j,k)=l1xi*l1eta*l1pgamma
+ dershape3D(3,2,i,j,k)=l3xi*l1eta*l1pgamma
+ dershape3D(3,3,i,j,k)=l3xi*l3eta*l1pgamma
+ dershape3D(3,4,i,j,k)=l1xi*l3eta*l1pgamma
+ dershape3D(3,5,i,j,k)=l1xi*l1eta*l3pgamma
+ dershape3D(3,6,i,j,k)=l3xi*l1eta*l3pgamma
+ dershape3D(3,7,i,j,k)=l3xi*l3eta*l3pgamma
+ dershape3D(3,8,i,j,k)=l1xi*l3eta*l3pgamma
+
+! midside nodes
+
+ shape3D(9,i,j,k)=l2xi*l1eta*l1gamma
+ shape3D(10,i,j,k)=l3xi*l2eta*l1gamma
+ shape3D(11,i,j,k)=l2xi*l3eta*l1gamma
+ shape3D(12,i,j,k)=l1xi*l2eta*l1gamma
+ shape3D(13,i,j,k)=l1xi*l1eta*l2gamma
+ shape3D(14,i,j,k)=l3xi*l1eta*l2gamma
+ shape3D(15,i,j,k)=l3xi*l3eta*l2gamma
+ shape3D(16,i,j,k)=l1xi*l3eta*l2gamma
+ shape3D(17,i,j,k)=l2xi*l1eta*l3gamma
+ shape3D(18,i,j,k)=l3xi*l2eta*l3gamma
+ shape3D(19,i,j,k)=l2xi*l3eta*l3gamma
+ shape3D(20,i,j,k)=l1xi*l2eta*l3gamma
+
+ dershape3D(1,9,i,j,k)=l2pxi*l1eta*l1gamma
+ dershape3D(1,10,i,j,k)=l3pxi*l2eta*l1gamma
+ dershape3D(1,11,i,j,k)=l2pxi*l3eta*l1gamma
+ dershape3D(1,12,i,j,k)=l1pxi*l2eta*l1gamma
+ dershape3D(1,13,i,j,k)=l1pxi*l1eta*l2gamma
+ dershape3D(1,14,i,j,k)=l3pxi*l1eta*l2gamma
+ dershape3D(1,15,i,j,k)=l3pxi*l3eta*l2gamma
+ dershape3D(1,16,i,j,k)=l1pxi*l3eta*l2gamma
+ dershape3D(1,17,i,j,k)=l2pxi*l1eta*l3gamma
+ dershape3D(1,18,i,j,k)=l3pxi*l2eta*l3gamma
+ dershape3D(1,19,i,j,k)=l2pxi*l3eta*l3gamma
+ dershape3D(1,20,i,j,k)=l1pxi*l2eta*l3gamma
+
+ dershape3D(2,9,i,j,k)=l2xi*l1peta*l1gamma
+ dershape3D(2,10,i,j,k)=l3xi*l2peta*l1gamma
+ dershape3D(2,11,i,j,k)=l2xi*l3peta*l1gamma
+ dershape3D(2,12,i,j,k)=l1xi*l2peta*l1gamma
+ dershape3D(2,13,i,j,k)=l1xi*l1peta*l2gamma
+ dershape3D(2,14,i,j,k)=l3xi*l1peta*l2gamma
+ dershape3D(2,15,i,j,k)=l3xi*l3peta*l2gamma
+ dershape3D(2,16,i,j,k)=l1xi*l3peta*l2gamma
+ dershape3D(2,17,i,j,k)=l2xi*l1peta*l3gamma
+ dershape3D(2,18,i,j,k)=l3xi*l2peta*l3gamma
+ dershape3D(2,19,i,j,k)=l2xi*l3peta*l3gamma
+ dershape3D(2,20,i,j,k)=l1xi*l2peta*l3gamma
+
+ dershape3D(3,9,i,j,k)=l2xi*l1eta*l1pgamma
+ dershape3D(3,10,i,j,k)=l3xi*l2eta*l1pgamma
+ dershape3D(3,11,i,j,k)=l2xi*l3eta*l1pgamma
+ dershape3D(3,12,i,j,k)=l1xi*l2eta*l1pgamma
+ dershape3D(3,13,i,j,k)=l1xi*l1eta*l2pgamma
+ dershape3D(3,14,i,j,k)=l3xi*l1eta*l2pgamma
+ dershape3D(3,15,i,j,k)=l3xi*l3eta*l2pgamma
+ dershape3D(3,16,i,j,k)=l1xi*l3eta*l2pgamma
+ dershape3D(3,17,i,j,k)=l2xi*l1eta*l3pgamma
+ dershape3D(3,18,i,j,k)=l3xi*l2eta*l3pgamma
+ dershape3D(3,19,i,j,k)=l2xi*l3eta*l3pgamma
+ dershape3D(3,20,i,j,k)=l1xi*l2eta*l3pgamma
+
+! side center nodes
+
+ shape3D(21,i,j,k)=l2xi*l2eta*l1gamma
+ shape3D(22,i,j,k)=l2xi*l1eta*l2gamma
+ shape3D(23,i,j,k)=l3xi*l2eta*l2gamma
+ shape3D(24,i,j,k)=l2xi*l3eta*l2gamma
+ shape3D(25,i,j,k)=l1xi*l2eta*l2gamma
+ shape3D(26,i,j,k)=l2xi*l2eta*l3gamma
+
+ dershape3D(1,21,i,j,k)=l2pxi*l2eta*l1gamma
+ dershape3D(1,22,i,j,k)=l2pxi*l1eta*l2gamma
+ dershape3D(1,23,i,j,k)=l3pxi*l2eta*l2gamma
+ dershape3D(1,24,i,j,k)=l2pxi*l3eta*l2gamma
+ dershape3D(1,25,i,j,k)=l1pxi*l2eta*l2gamma
+ dershape3D(1,26,i,j,k)=l2pxi*l2eta*l3gamma
+
+ dershape3D(2,21,i,j,k)=l2xi*l2peta*l1gamma
+ dershape3D(2,22,i,j,k)=l2xi*l1peta*l2gamma
+ dershape3D(2,23,i,j,k)=l3xi*l2peta*l2gamma
+ dershape3D(2,24,i,j,k)=l2xi*l3peta*l2gamma
+ dershape3D(2,25,i,j,k)=l1xi*l2peta*l2gamma
+ dershape3D(2,26,i,j,k)=l2xi*l2peta*l3gamma
+
+ dershape3D(3,21,i,j,k)=l2xi*l2eta*l1pgamma
+ dershape3D(3,22,i,j,k)=l2xi*l1eta*l2pgamma
+ dershape3D(3,23,i,j,k)=l3xi*l2eta*l2pgamma
+ dershape3D(3,24,i,j,k)=l2xi*l3eta*l2pgamma
+ dershape3D(3,25,i,j,k)=l1xi*l2eta*l2pgamma
+ dershape3D(3,26,i,j,k)=l2xi*l2eta*l3pgamma
+
+! center node
+
+ shape3D(27,i,j,k)=l2xi*l2eta*l2gamma
+
+ dershape3D(1,27,i,j,k)=l2pxi*l2eta*l2gamma
+ dershape3D(2,27,i,j,k)=l2xi*l2peta*l2gamma
+ dershape3D(3,27,i,j,k)=l2xi*l2eta*l2pgamma
+
+ enddo
+ enddo
+ enddo
+
+! check the shape functions
+ do i=1,NGLLX
+ do j=1,NGLLY
+ do k=1,NGLLZ
+
+ sumshape=ZERO
+
+ sumdershapexi=ZERO
+ sumdershapeeta=ZERO
+ sumdershapegamma=ZERO
+
+ do ia=1,NGNOD
+
+ sumshape=sumshape+shape3D(ia,i,j,k)
+
+ sumdershapexi=sumdershapexi+dershape3D(1,ia,i,j,k)
+ sumdershapeeta=sumdershapeeta+dershape3D(2,ia,i,j,k)
+ sumdershapegamma=sumdershapegamma+dershape3D(3,ia,i,j,k)
+
+ enddo
+
+! the sum of the shape functions should be 1
+ if(abs(sumshape-ONE) > TINYVAL) call exit_MPI(myrank,'error in 3D shape functions')
+
+! the sum of the derivatives of the shape functions should be 0
+ if(abs(sumdershapexi) > TINYVAL) &
+ call exit_MPI(myrank,'error in xi derivatives of 3D shape function')
+
+ if(abs(sumdershapeeta) > TINYVAL) &
+ call exit_MPI(myrank,'error in eta derivatives of 3D shape function')
+
+ if(abs(sumdershapegamma) > TINYVAL) &
+ call exit_MPI(myrank,'error in gamma derivatives of 3D shape function')
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine get_shape3D
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_value_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_value_parameters.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/get_value_parameters.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,84 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_value_integer(value_to_get, name, default_value)
+
+ implicit none
+
+ integer value_to_get, default_value
+ character(len=*) name
+
+ call unused_string(name)
+
+ value_to_get = default_value
+
+ end subroutine get_value_integer
+
+!--------------------
+
+ subroutine get_value_double_precision(value_to_get, name, default_value)
+
+ implicit none
+
+ double precision value_to_get, default_value
+ character(len=*) name
+
+ call unused_string(name)
+
+ value_to_get = default_value
+
+ end subroutine get_value_double_precision
+
+!--------------------
+
+ subroutine get_value_logical(value_to_get, name, default_value)
+
+ implicit none
+
+ logical value_to_get, default_value
+ character(len=*) name
+
+ call unused_string(name)
+
+ value_to_get = default_value
+
+ end subroutine get_value_logical
+
+!--------------------
+
+ subroutine get_value_string(value_to_get, name, default_value)
+
+ implicit none
+
+ character(len=*) value_to_get, default_value
+ character(len=*) name
+
+ call unused_string(name)
+
+ value_to_get = default_value
+
+ end subroutine get_value_string
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/gll_library.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/gll_library.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/gll_library.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -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
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/hex_nodes.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/hex_nodes.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/hex_nodes.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,160 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine hex_nodes(iaddx,iaddy,iaddz)
+
+ implicit none
+
+ include "constants.h"
+
+! topology of the elements
+ integer, dimension(NGNOD) :: iaddx,iaddy,iaddz
+
+! define the topology of the hexahedral elements
+
+! the topology of the nodes is described in UTILS/chunk_notes_scanned/numbering_convention_27_nodes.tif
+
+ if(NGNOD /= 27) stop 'elements should have 27 control nodes'
+
+! corner nodes
+
+ iaddx(1) = 0
+ iaddy(1) = 0
+ iaddz(1) = 0
+
+ iaddx(2) = 2
+ iaddy(2) = 0
+ iaddz(2) = 0
+
+ iaddx(3) = 2
+ iaddy(3) = 2
+ iaddz(3) = 0
+
+ iaddx(4) = 0
+ iaddy(4) = 2
+ iaddz(4) = 0
+
+ iaddx(5) = 0
+ iaddy(5) = 0
+ iaddz(5) = 2
+
+ iaddx(6) = 2
+ iaddy(6) = 0
+ iaddz(6) = 2
+
+ iaddx(7) = 2
+ iaddy(7) = 2
+ iaddz(7) = 2
+
+ iaddx(8) = 0
+ iaddy(8) = 2
+ iaddz(8) = 2
+
+! midside nodes (nodes located in the middle of an edge)
+
+ iaddx(9) = 1
+ iaddy(9) = 0
+ iaddz(9) = 0
+
+ iaddx(10) = 2
+ iaddy(10) = 1
+ iaddz(10) = 0
+
+ iaddx(11) = 1
+ iaddy(11) = 2
+ iaddz(11) = 0
+
+ iaddx(12) = 0
+ iaddy(12) = 1
+ iaddz(12) = 0
+
+ iaddx(13) = 0
+ iaddy(13) = 0
+ iaddz(13) = 1
+
+ iaddx(14) = 2
+ iaddy(14) = 0
+ iaddz(14) = 1
+
+ iaddx(15) = 2
+ iaddy(15) = 2
+ iaddz(15) = 1
+
+ iaddx(16) = 0
+ iaddy(16) = 2
+ iaddz(16) = 1
+
+ iaddx(17) = 1
+ iaddy(17) = 0
+ iaddz(17) = 2
+
+ iaddx(18) = 2
+ iaddy(18) = 1
+ iaddz(18) = 2
+
+ iaddx(19) = 1
+ iaddy(19) = 2
+ iaddz(19) = 2
+
+ iaddx(20) = 0
+ iaddy(20) = 1
+ iaddz(20) = 2
+
+! side center nodes (nodes located in the middle of a face)
+
+ iaddx(21) = 1
+ iaddy(21) = 1
+ iaddz(21) = 0
+
+ iaddx(22) = 1
+ iaddy(22) = 0
+ iaddz(22) = 1
+
+ iaddx(23) = 2
+ iaddy(23) = 1
+ iaddz(23) = 1
+
+ iaddx(24) = 1
+ iaddy(24) = 2
+ iaddz(24) = 1
+
+ iaddx(25) = 0
+ iaddy(25) = 1
+ iaddz(25) = 1
+
+ iaddx(26) = 1
+ iaddy(26) = 1
+ iaddz(26) = 2
+
+! center node (barycenter of the eight corners)
+
+ iaddx(27) = 1
+ iaddy(27) = 1
+ iaddz(27) = 1
+
+ end subroutine hex_nodes
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/intgrl.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/intgrl.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/intgrl.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,185 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine intgrl(sum,r,nir,ner,f,s1,s2,s3)
+
+! Computes the integral of f[i]*r[i]*r[i] from i=nir to i=ner for
+! radii values as in model PREM_an640
+
+ implicit none
+
+! Argument variables
+ integer ner,nir
+ double precision f(640),r(640),s1(640),s2(640)
+ double precision s3(640),sum
+
+! Local variables
+ integer i,j,n,kdis(28)
+ integer ndis,nir1
+ double precision rji,yprime(640)
+
+ double precision, parameter :: third = 1.0d0/3.0d0
+ double precision, parameter :: fifth = 1.0d0/5.0d0
+ double precision, parameter :: sixth = 1.0d0/6.0d0
+
+ data kdis/163,323,336,517,530,540,565,590,609,619,626,633,16*0/
+
+ ndis = 12
+ n = 640
+
+ call deriv(f,yprime,n,r,ndis,kdis,s1,s2,s3)
+ nir1 = nir + 1
+ sum = 0.0d0
+ do i=nir1,ner
+ j = i-1
+ rji = r(i) - r(j)
+ sum=sum+r(j)*r(j)*rji*(f(j)+rji*(.50d0*s1(j)+rji*(third*s2(j)+rji* &
+ .250d0*s3(j))))+2.0d0*r(j)*rji*rji*(.50d0*f(j)+rji*(third*s1(j)+rji* &
+ (.250d0*s2(j)+rji*fifth*s3(j))))+rji*rji*rji*(third*f(j)+rji* &
+ (.250d0*s1(j)+rji*(fifth*s2(j)+rji*sixth*s3(j))))
+ enddo
+
+ end subroutine intgrl
+
+! -------------------------------
+
+ subroutine deriv(y,yprime,n,r,ndis,kdis,s1,s2,s3)
+
+ implicit none
+
+! Argument variables
+ integer kdis(28),n,ndis
+ double precision r(n),s1(n),s2(n),s3(n)
+ double precision y(n),yprime(n)
+
+! Local variables
+ integer i,j,j1,j2
+ integer k,nd,ndp
+ double precision a0,b0,b1
+ double precision f(3,1000),h,h2,h2a
+ double precision h2b,h3a,ha,s13
+ double precision s21,s32,yy(3)
+
+ yy(1) = 0.d0
+ yy(2) = 0.d0
+ yy(3) = 0.d0
+
+ ndp=ndis+1
+ do 3 nd=1,ndp
+ if(nd == 1) goto 4
+ if(nd == ndp) goto 5
+ j1=kdis(nd-1)+1
+ j2=kdis(nd)-2
+ goto 6
+ 4 j1=1
+ j2=kdis(1)-2
+ goto 6
+ 5 j1=kdis(ndis)+1
+ j2=n-2
+ 6 if((j2+1-j1)>0) goto 11
+ j2=j2+2
+ yy(1)=(y(j2)-y(j1))/(r(j2)-r(j1))
+ s1(j1)=yy(1)
+ s1(j2)=yy(1)
+ s2(j1)=yy(2)
+ s2(j2)=yy(2)
+ s3(j1)=yy(3)
+ s3(j2)=yy(3)
+ goto 3
+ 11 a0=0.0d0
+ if(j1 == 1) goto 7
+ h=r(j1+1)-r(j1)
+ h2=r(j1+2)-r(j1)
+ yy(1)=h*h2*(h2-h)
+ h=h*h
+ h2=h2*h2
+ b0=(y(j1)*(h-h2)+y(j1+1)*h2-y(j1+2)*h)/yy(1)
+ goto 8
+ 7 b0=0.0d0
+ 8 b1=b0
+
+ if(j2 > 1000) stop 'error in subroutine deriv for j2'
+
+ do i=j1,j2
+ h=r(i+1)-r(i)
+ yy(1)=y(i+1)-y(i)
+ h2=h*h
+ ha=h-a0
+ h2a=h-2.0d0*a0
+ h3a=2.0d0*h-3.0d0*a0
+ h2b=h2*b0
+ s1(i)=h2/ha
+ s2(i)=-ha/(h2a*h2)
+ s3(i)=-h*h2a/h3a
+ f(1,i)=(yy(1)-h*b0)/(h*ha)
+ f(2,i)=(h2b-yy(1)*(2.0d0*h-a0))/(h*h2*h2a)
+ f(3,i)=-(h2b-3.0d0*yy(1)*ha)/(h*h3a)
+ a0=s3(i)
+ b0=f(3,i)
+ enddo
+
+ i=j2+1
+ h=r(i+1)-r(i)
+ yy(1)=y(i+1)-y(i)
+ h2=h*h
+ ha=h-a0
+ h2a=h*ha
+ h2b=h2*b0-yy(1)*(2.d0*h-a0)
+ s1(i)=h2/ha
+ f(1,i)=(yy(1)-h*b0)/h2a
+ ha=r(j2)-r(i+1)
+ yy(1)=-h*ha*(ha+h)
+ ha=ha*ha
+ yy(1)=(y(i+1)*(h2-ha)+y(i)*ha-y(j2)*h2)/yy(1)
+ s3(i)=(yy(1)*h2a+h2b)/(h*h2*(h-2.0d0*a0))
+ s13=s1(i)*s3(i)
+ s2(i)=f(1,i)-s13
+
+ do j=j1,j2
+ k=i-1
+ s32=s3(k)*s2(i)
+ s1(i)=f(3,k)-s32
+ s21=s2(k)*s1(i)
+ s3(k)=f(2,k)-s21
+ s13=s1(k)*s3(k)
+ s2(k)=f(1,k)-s13
+ i=k
+ enddo
+
+ s1(i)=b1
+ j2=j2+2
+ s1(j2)=yy(1)
+ s2(j2)=yy(2)
+ s3(j2)=yy(3)
+ 3 continue
+
+ do i=1,n
+ yprime(i)=s1(i)
+ enddo
+
+ end subroutine deriv
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/jp3d1994_model.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/jp3d1994_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/jp3d1994_model.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,1265 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+
+!=====================================================================
+!
+! Last Time Modified by Min Chen, Caltech, 03/14/2008
+!
+! Program ----- veljp3d.f -----
+!
+! This program is used to calculate 3-D P-wave velocity
+! distribution beneath the Japan Islands which is obtained
+! by a simultaneous inversion of arrival time data from local,
+! regional and teleseismic events. For details, see "Deep
+! structure of the Japan subduction zone as derived from local,
+! regional, and teleseismic events" by Zhao, Hasegawa & Kanamori,
+! JGR, 99, 22313-22329, 1994.
+!
+! The meaningful range of this model is as follows:
+! latitude : 32 - 45 N
+! longitude: 130-145 E
+! depth : 0 - 500 km
+!
+! Dapeng Zhao
+! Dept. of Earth & Planet. Sci
+! Washington University
+! St. Louis, MO 63130
+! U.S.A.
+! dapeng at izu.wustl.edu
+!=========================================================================
+subroutine read_iso3d_dpzhao_model(JP3DM_V)
+
+ implicit none
+
+ include "constants.h"
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+ OPEN(2,FILE="DATA/Zhao_JP_model/m3d1341")
+ OPEN(3,FILE="DATA/Zhao_JP_model/datadis")
+
+ CALL INPUTJP(JP3DM_V)
+ CALL INPUT1(JP3DM_V)
+ CALL INPUT2(JP3DM_V)
+
+end subroutine read_iso3d_dpzhao_model
+!==========================================================================
+subroutine iso3d_dpzhao_model(radius,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ implicit none
+
+ include "constants.h"
+
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+ logical found_crust
+ double precision :: radius,theta,phi,vp,vs,dvs,dvp,rho
+ double precision :: PE,RE,HE,H1,H2,H3,scaleval
+ integer :: LAY
+
+
+ found_crust = .false.
+
+ PE = theta
+ RE = phi
+ HE = (ONE - radius)*R_EARTH_KM
+! calculate depths of the Conrad, the Moho and
+! the plate boundary beneath the location (PHI,RAM)
+ CALL HLAY(PE,RE,H1,1,JP3DM_V)
+ CALL HLAY(PE,RE,H2,2,JP3DM_V)
+ CALL HLAY(PE,RE,H3,3,JP3DM_V)
+! when LAY = 1, the focus is in the upper crust;
+! when LAY = 2, the focus is in the lower crust;
+! when LAY = 3, the focus is in the mantle wedge;
+! when LAY = 4, the focus is beneath the plate boundary.
+ IF(HE.LE.H1) THEN
+ LAY = 1
+ found_crust = .true.
+ ELSE IF(HE.GT.H1.AND.HE.LE.H2) THEN
+ LAY = 2
+ found_crust = .true.
+ ELSE IF(HE.GT.H2.AND.HE.LE.H3) THEN
+ LAY = 3
+ ELSE
+ LAY = 4
+ END IF
+ CALL VEL1D(HE,vp,LAY,1,JP3DM_V)
+ CALL VEL1D(HE,vs,LAY,2,JP3DM_V)
+
+ CALL VEL3(PE,RE,HE,dvp,LAY,JP3DM_V)
+ dvp = 0.01d0*dvp
+ dvs = 1.5d0*dvp
+ vp = vp*(1.0d0+dvp)
+ vs = vs*(1.0d0+dvs)
+
+! determine rho
+ if(LAY .eq. 1) then
+ rho=2.6
+ endif
+ if(LAY .eq. 2) then
+ rho=2.9
+ endif
+ if(LAY .GT. 2) then
+ rho=3.3+(vs-4.4)*0.66667
+ endif
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ rho=rho*1000.0d0/RHOAV
+ vp=vp*1000.0d0/(R_EARTH*scaleval)
+ vs=vs*1000.0d0/(R_EARTH*scaleval)
+END subroutine iso3d_dpzhao_model
+
+!---------------------------------------------------------------
+
+ SUBROUTINE INPUT1(JP3DM_V)
+ implicit none
+
+ include "constants.h"
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+100 FORMAT(3I3)
+ READ(2,100) JP3DM_V%NPA,JP3DM_V%NRA,JP3DM_V%NHA
+ CALL PUT1(JP3DM_V%NPA,JP3DM_V%NRA,JP3DM_V%NHA,JP3DM_V%PNA,JP3DM_V%RNA,JP3DM_V%HNA,JP3DM_V%VELAP)
+ READ(2,100) JP3DM_V%NPB,JP3DM_V%NRB,JP3DM_V%NHB
+ CALL PUT1(JP3DM_V%NPB,JP3DM_V%NRB,JP3DM_V%NHB,JP3DM_V%PNB,JP3DM_V%RNB,JP3DM_V%HNB,JP3DM_V%VELBP)
+ CALL BLDMAP(JP3DM_V)
+ RETURN
+ END SUBROUTINE INPUT1
+
+ SUBROUTINE PUT1(NPX,NRX,NHX,PNX,RNX,HNX,VELXP)
+ integer :: NPX,NRX,NHX,K,I,J
+ double precision :: VELXP(NPX,NRX,NHX), &
+ PNX(NPX),RNX(NRX),HNX(NHX)
+ READ(2,110) (PNX(I),I=1,NPX)
+ READ(2,110) (RNX(I),I=1,NRX)
+ READ(2,120) (HNX(I),I=1,NHX)
+ DO K = 1,NHX
+ DO I = 1,NPX
+ READ(2,140) (VELXP(I,J,K),J=1,NRX)
+110 FORMAT(6(9F7.2/))
+120 FORMAT(3(8F7.2/))
+140 FORMAT(4(14F5.2/))
+ enddo
+ enddo
+ END SUBROUTINE PUT1
+
+ SUBROUTINE INPUT2(JP3DM_V)
+ implicit none
+
+ include "constants.h"
+
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+ integer :: NP,NNR,I,J
+ READ(3,100) NP,NNR
+ READ(3,110) (JP3DM_V%PN(I),I=1,NP)
+ READ(3,120) (JP3DM_V%RRN(I),I=1,NNR)
+ DO 1 I = NP,1,-1
+ READ(3,130) (JP3DM_V%DEPA(I,J),J=1,NNR)
+1 CONTINUE
+ DO 2 I = NP,1,-1
+ READ(3,130) (JP3DM_V%DEPB(I,J),J=1,NNR)
+2 CONTINUE
+ DO 3 I = NP,1,-1
+ READ(3,130) (JP3DM_V%DEPC(I,J),J=1,NNR)
+3 CONTINUE
+100 FORMAT(2I6)
+110 FORMAT(5(10F7.2/),F7.2)
+120 FORMAT(6(10F7.2/),3F7.2)
+130 FORMAT(6(10F7.1/),3F7.1)
+ RETURN
+ END
+
+ SUBROUTINE BLDMAP(JP3DM_V)
+ implicit none
+
+ include "constants.h"
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+ CALL LOCX(JP3DM_V%PNA,JP3DM_V%RNA,JP3DM_V%HNA,JP3DM_V%NPA,JP3DM_V%NRA,JP3DM_V%NHA,MKA, &
+ JP3DM_V%PLA,JP3DM_V%RLA,JP3DM_V%HLA,JP3DM_V%IPLOCA,JP3DM_V%IRLOCA,JP3DM_V%IHLOCA)
+ CALL LOCX(JP3DM_V%PNB,JP3DM_V%RNB,JP3DM_V%HNB,JP3DM_V%NPB,JP3DM_V%NRB,JP3DM_V%NHB,MKB, &
+ JP3DM_V%PLB,JP3DM_V%RLB,JP3DM_V%HLB,JP3DM_V%IPLOCB,JP3DM_V%IRLOCB,JP3DM_V%IHLOCB)
+ RETURN
+ END
+
+ SUBROUTINE LOCX(PNX,RNX,HNX,NPX,NRX,NHX,MKX, &
+ PLX,RLX,HLX,IPLOCX,IRLOCX,IHLOCX)
+ integer :: NPX,NRX,NHX,MKX,IPLOCX(MKX),IRLOCX(MKX),IHLOCX(MKX)
+ integer :: IPMAX,IP,IP1,IRMAX,IR,IR1,IH1,IH,IHMAX,I
+ double precision :: PNX(NPX),RNX(NRX),HNX(NHX)
+ double precision :: PLX,RLX,HLX,PNOW,RNOW,HNOW
+ PLX = 1.0-PNX(1)*100.0
+ IPMAX = IDNINT(PNX(NPX)*100.0+PLX)
+ IP = 1
+ DO 10 I = 1,IPMAX
+ IP1 = IP+1
+ PNOW = (FLOAT(I)-PLX)/100.0
+ IF(PNOW.GE.PNX(IP1)) IP = IP1
+ IPLOCX(I)= IP
+10 CONTINUE
+ RLX = 1.0-RNX(1)*100.0
+ IRMAX = IDNINT(RNX(NRX)*100.0+RLX)
+ IR = 1
+ DO 20 I = 1,IRMAX
+ IR1 = IR+1
+ RNOW = (FLOAT(I)-RLX)/100.0
+ IF(RNOW.GE.RNX(IR1)) IR = IR1
+ IRLOCX(I)= IR
+20 CONTINUE
+ HLX = 1.0-HNX(1)
+ IHMAX = IDNINT(HNX(NHX)+HLX)
+ IH = 1
+ DO 30 I = 1,IHMAX
+ IH1 = IH+1
+ HNOW = FLOAT(I)-HLX
+ IF(HNOW.GE.HNX(IH1)) IH = IH1
+ IHLOCX(I)= IH
+30 CONTINUE
+ RETURN
+ END
+
+ SUBROUTINE VEL3(PE,RE,HE,V,LAY,JP3DM_V)
+ implicit none
+
+ include "constants.h"
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+ double precision :: PE,RE,HE,V
+
+ integer :: LAY
+
+ JP3DM_V%P = 90.0-PE/DEGREES_TO_RADIANS
+ JP3DM_V%R = RE/DEGREES_TO_RADIANS
+ JP3DM_V%H = HE
+ IF(LAY.LE.3) THEN
+ CALL PRHF(JP3DM_V%IPLOCA,JP3DM_V%IRLOCA,JP3DM_V%IHLOCA,JP3DM_V%PLA,JP3DM_V%RLA,JP3DM_V%HLA, &
+ JP3DM_V%PNA,JP3DM_V%RNA,JP3DM_V%HNA,MPA,MRA,MHA,MKA,JP3DM_V)
+ ELSE IF(LAY.EQ.4) THEN
+ CALL PRHF(JP3DM_V%IPLOCB,JP3DM_V%IRLOCB,JP3DM_V%IHLOCB,JP3DM_V%PLB,JP3DM_V%RLB,JP3DM_V%HLB, &
+ JP3DM_V%PNB,JP3DM_V%RNB,JP3DM_V%HNB,MPB,MRB,MHB,MKB,JP3DM_V)
+ ELSE
+ END IF
+ JP3DM_V%WV(1) = JP3DM_V%PF1*JP3DM_V%RF1*JP3DM_V%HF1
+ JP3DM_V%WV(2) = JP3DM_V%PF*JP3DM_V%RF1*JP3DM_V%HF1
+ JP3DM_V%WV(3) = JP3DM_V%PF1*JP3DM_V%RF*JP3DM_V%HF1
+ JP3DM_V%WV(4) = JP3DM_V%PF*JP3DM_V%RF*JP3DM_V%HF1
+ JP3DM_V%WV(5) = JP3DM_V%PF1*JP3DM_V%RF1*JP3DM_V%HF
+ JP3DM_V%WV(6) = JP3DM_V%PF*JP3DM_V%RF1*JP3DM_V%HF
+ JP3DM_V%WV(7) = JP3DM_V%PF1*JP3DM_V%RF*JP3DM_V%HF
+ JP3DM_V%WV(8) = JP3DM_V%PF*JP3DM_V%RF*JP3DM_V%HF
+ ! calculate velocity
+ IF(LAY.LE.3) THEN
+ CALL VABPS(MPA,MRA,MHA,JP3DM_V%VELAP,V,JP3DM_V)
+ ELSE IF(LAY.EQ.4) THEN
+ CALL VABPS(MPB,MRB,MHB,JP3DM_V%VELBP,V,JP3DM_V)
+ ELSE
+ END IF
+
+ RETURN
+ END SUBROUTINE VEL3
+
+ SUBROUTINE VABPS(MP,MR,MH,V,VEL,JP3DM_V)
+ implicit none
+
+ include "constants.h"
+
+
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+ double precision :: VEL
+ integer :: MP,MR,MH
+ double precision :: V(MP,MR,MH)
+ VEL = JP3DM_V%WV(1)*V(JP3DM_V%IP,JP3DM_V%JP,JP3DM_V%KP) + JP3DM_V%WV(2)*V(JP3DM_V%IP1,JP3DM_V%JP,JP3DM_V%KP) &
+ + JP3DM_V%WV(3)*V(JP3DM_V%IP,JP3DM_V%JP1,JP3DM_V%KP) + JP3DM_V%WV(4)*V(JP3DM_V%IP1,JP3DM_V%JP1,JP3DM_V%KP) &
+ + JP3DM_V%WV(5)*V(JP3DM_V%IP,JP3DM_V%JP,JP3DM_V%KP1) + JP3DM_V%WV(6)*V(JP3DM_V%IP1,JP3DM_V%JP,JP3DM_V%KP1) &
+ + JP3DM_V%WV(7)*V(JP3DM_V%IP,JP3DM_V%JP1,JP3DM_V%KP1)+ JP3DM_V%WV(8)*V(JP3DM_V%IP1,JP3DM_V%JP1,JP3DM_V%KP1)
+ RETURN
+ END
+
+ SUBROUTINE INTMAP(R,IRLOC,NNR,RL,IR)
+ integer :: NNR,IRLOC(NNR),IS,IR
+ double precision :: R,RL
+ IS = IDNINT(R+RL)
+ IR = IRLOC(IS)
+ RETURN
+ END
+
+ SUBROUTINE PRHF(IPLOCX,IRLOCX,IHLOCX,PLX,RLX,HLX, &
+ PNX,RNX,HNX,MPX,MRX,MHX,MKX,JP3DM_V)
+ implicit none
+
+ include "constants.h"
+
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+ integer :: MPX,MRX,MHX,MKX
+ integer :: IPLOCX(MKX),IRLOCX(MKX),IHLOCX(MKX)
+ double precision :: PNX(MPX),RNX(MRX),HNX(MHX)
+ double precision :: PLX,RLX,HLX
+ CALL LIMIT(PNX(1),PNX(MPX),JP3DM_V%P)
+ CALL LIMIT(RNX(1),RNX(MRX),JP3DM_V%R)
+ CALL LIMIT(HNX(1),HNX(MHX),JP3DM_V%H)
+ CALL INTMAP(JP3DM_V%P*100.0,IPLOCX,MKX,PLX,JP3DM_V%IP)
+ CALL INTMAP(JP3DM_V%R*100.0,IRLOCX,MKX,RLX,JP3DM_V%JP)
+ CALL INTMAP(JP3DM_V%H,IHLOCX,MKX,HLX,JP3DM_V%KP)
+ JP3DM_V%IP1 = JP3DM_V%IP+1
+ JP3DM_V%JP1 = JP3DM_V%JP+1
+ JP3DM_V%KP1 = JP3DM_V%KP+1
+ JP3DM_V%PD = PNX(JP3DM_V%IP1)-PNX(JP3DM_V%IP)
+ JP3DM_V%RD = RNX(JP3DM_V%JP1)-RNX(JP3DM_V%JP)
+ JP3DM_V%HD = HNX(JP3DM_V%KP1)-HNX(JP3DM_V%KP)
+ JP3DM_V%PF = (JP3DM_V%P-PNX(JP3DM_V%IP))/JP3DM_V%PD
+ JP3DM_V%RF = (JP3DM_V%R-RNX(JP3DM_V%JP))/JP3DM_V%RD
+ JP3DM_V%HF = (JP3DM_V%H-HNX(JP3DM_V%KP))/JP3DM_V%HD
+ JP3DM_V%PF1 = 1.0-JP3DM_V%PF
+ JP3DM_V%RF1 = 1.0-JP3DM_V%RF
+ JP3DM_V%HF1 = 1.0-JP3DM_V%HF
+ RETURN
+ END
+
+ SUBROUTINE HLAY(PE,RE,HE,IJK,JP3DM_V)
+ implicit none
+
+ include "constants.h"
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+ double precision :: PE,RE,HE,WV1,WV2,WV3,WV4,P,R,PF,RF,PF1,RF1
+ integer :: IJK,J,J1,I,I1
+ P = 90.0-PE/DEGREES_TO_RADIANS
+ R = RE/DEGREES_TO_RADIANS
+ CALL LIMIT(JP3DM_V%PN(1),JP3DM_V%PN(51),P)
+ CALL LIMIT(JP3DM_V%RRN(1),JP3DM_V%RRN(63),R)
+ DO 1 I = 1,50
+ I1 = I+1
+ IF(P.GE.JP3DM_V%PN(I).AND.P.LT.JP3DM_V%PN(I1)) GO TO 11
+1 CONTINUE
+11 CONTINUE
+ DO 2 J = 1,62
+ J1 = J+1
+ IF(R.GE.JP3DM_V%RRN(J).AND.R.LT.JP3DM_V%RRN(J1)) GO TO 22
+2 CONTINUE
+22 CONTINUE
+ PF = (P-JP3DM_V%PN(I))/(JP3DM_V%PN(I1)-JP3DM_V%PN(I))
+ RF = (R-JP3DM_V%RRN(J))/(JP3DM_V%RRN(J1)-JP3DM_V%RRN(J))
+ PF1 = 1.0-PF
+ RF1 = 1.0-RF
+ WV1 = PF1*RF1
+ WV2 = PF*RF1
+ WV3 = PF1*RF
+ WV4 = PF*RF
+ IF(IJK.EQ.1) THEN
+ HE = WV1*JP3DM_V%DEPA(I,J) + WV2*JP3DM_V%DEPA(I1,J) &
+ + WV3*JP3DM_V%DEPA(I,J1) + WV4*JP3DM_V%DEPA(I1,J1)
+ ELSE IF(IJK.EQ.2) THEN
+ HE = WV1*JP3DM_V%DEPB(I,J) + WV2*JP3DM_V%DEPB(I1,J) &
+ + WV3*JP3DM_V%DEPB(I,J1) + WV4*JP3DM_V%DEPB(I1,J1)
+ ELSE IF(IJK.EQ.3) THEN
+ HE = WV1*JP3DM_V%DEPC(I,J) + WV2*JP3DM_V%DEPC(I1,J) &
+ + WV3*JP3DM_V%DEPC(I,J1) + WV4*JP3DM_V%DEPC(I1,J1)
+ ELSE
+ END IF
+ RETURN
+ END SUBROUTINE HLAY
+
+ SUBROUTINE LIMIT(C1,C2,C)
+ double precision :: A1,A2,C1,C2,C
+ A1 = dmin1(C1,C2)
+ A2 = dmax1(C1,C2)
+ IF(C.LT.A1) C = A1
+ IF(C.GT.A2) C = A2
+ END SUBROUTINE LIMIT
+
+ SUBROUTINE VEL1D(HE,V,LAY,IPS,JP3DM_V)
+ implicit none
+
+ include "constants.h"
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+ integer :: IPS,LAY
+ double precision :: HE,V,VM,HM
+ IF(LAY.EQ.1) THEN
+ V = 6.0
+ IF(IPS.EQ.2) V = 3.5
+ ELSE IF(LAY.EQ.2) THEN
+ V = 6.7
+ IF(IPS.EQ.2) V = 3.8
+ ELSE IF(LAY.GE.3) THEN
+ HM = 40.0
+ IF(HE.LT.HM) THEN
+ CALL JPMODEL(IPS,HM,VM,JP3DM_V)
+ V = VM-(HM-HE)*0.003
+ ELSE
+ CALL JPMODEL(IPS,HE,V,JP3DM_V)
+ END IF
+ ELSE
+ END IF
+ RETURN
+ END
+
+ SUBROUTINE INPUTJP(JP3DM_V)
+ implicit none
+
+ include "constants.h"
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+ double precision :: VP1(29),VS1(29),RA1(29)
+ integer :: L
+ DATA VP1/7.75, 7.94, 8.13, 8.33, 8.54, 8.75, 8.97, &
+ 9.50, 9.91,10.26,10.55,10.99,11.29,11.50, &
+ 11.67,11.85,12.03,12.20,12.37,12.54,12.71, &
+ 12.87,13.02,13.16,13.32,13.46,13.60,13.64,13.64/
+ DATA VS1/4.353,4.444,4.539,4.638,4.741,4.850,4.962, &
+ 5.227,5.463,5.670,5.850,6.125,6.295,6.395, &
+ 6.483,6.564,6.637,6.706,6.770,6.833,6.893, &
+ 6.953,7.012,7.074,7.137,7.199,7.258,7.314,7.304/
+ DATA RA1/1.00,0.99,0.98,0.97,0.96,0.95,0.94,0.93, &
+ 0.92,0.91,0.90,0.88,0.86,0.84,0.82,0.80, &
+ 0.78,0.76,0.74,0.72,0.70,0.68,0.66,0.64, &
+ 0.62,0.60,0.58,0.56,0.55/
+ DO 1 L = 1,29
+ JP3DM_V%VP(L) = VP1(L)
+ JP3DM_V%VS(L) = VS1(L)
+ JP3DM_V%RA(L) = RA1(L)
+ JP3DM_V%DEPJ(L) = 40.0+6325.59*(1.0-RA1(L))
+1 CONTINUE
+ RETURN
+ END
+
+ SUBROUTINE JPMODEL(IPS,H,V,JP3DM_V)
+ implicit none
+
+ include "constants.h"
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+ integer :: IPS,K,K1
+ double precision :: H1,H2,H12,H,V
+ DO 2 K = 1,28
+ K1 = K+1
+ H1 = JP3DM_V%DEPJ(K)
+ H2 = JP3DM_V%DEPJ(K1)
+ IF(H.GE.H1.AND.H.LT.H2) GO TO 3
+2 CONTINUE
+3 CONTINUE
+ H12 = (H-H1)/(H2-H1)
+ IF(IPS.EQ.1) THEN
+ V = (JP3DM_V%VP(K1)-JP3DM_V%VP(K))*H12+JP3DM_V%VP(K)
+ ELSE
+ V = (JP3DM_V%VS(K1)-JP3DM_V%VS(K))*H12+JP3DM_V%VS(K)
+ END IF
+ RETURN
+ END
+
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/lagrange_poly.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/lagrange_poly.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/lagrange_poly.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,110 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine lagrange_any(xi,NGLL,xigll,h,hprime)
+
+! subroutine to compute the Lagrange interpolants based upon the GLL points
+! and their first derivatives at any point xi in [-1,1]
+
+ implicit none
+
+ integer NGLL
+ double precision xi,xigll(NGLL),h(NGLL),hprime(NGLL)
+
+ integer dgr,i,j
+ double precision prod1,prod2
+
+ do dgr=1,NGLL
+
+ prod1 = 1.0d0
+ prod2 = 1.0d0
+ do i=1,NGLL
+ if(i /= dgr) then
+ prod1 = prod1*(xi-xigll(i))
+ prod2 = prod2*(xigll(dgr)-xigll(i))
+ endif
+ enddo
+ h(dgr)=prod1/prod2
+
+ hprime(dgr)=0.0d0
+ do i=1,NGLL
+ if(i /= dgr) then
+ prod1=1.0d0
+ do j=1,NGLL
+ if(j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j))
+ enddo
+ hprime(dgr) = hprime(dgr)+prod1
+ endif
+ enddo
+ hprime(dgr) = hprime(dgr)/prod2
+
+ enddo
+
+ end subroutine lagrange_any
+
+!
+!=====================================================================
+!
+
+! subroutine to compute the derivative of the Lagrange interpolants
+! at the GLL points at any given GLL point
+
+ double precision function lagrange_deriv_GLL(I,j,ZGLL,NZ)
+
+!------------------------------------------------------------------------
+!
+! Compute the value of the derivative of the I-th
+! Lagrange interpolant through the
+! NZ Gauss-Lobatto Legendre points ZGLL at point ZGLL(j)
+!
+!------------------------------------------------------------------------
+
+ implicit none
+
+ integer i,j,nz
+ double precision zgll(0:nz-1)
+
+ integer degpoly
+
+ double precision, external :: pnleg,pndleg
+
+ degpoly = nz - 1
+ if (i == 0 .and. j == 0) then
+ lagrange_deriv_GLL = - dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
+ else if (i == degpoly .and. j == degpoly) then
+ lagrange_deriv_GLL = dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
+ else if (i == j) then
+ lagrange_deriv_GLL = 0.d0
+ else
+ lagrange_deriv_GLL = pnleg(zgll(j),degpoly) / &
+ (pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))) &
+ + (1.d0-zgll(j)*zgll(j))*pndleg(zgll(j),degpoly) / (dble(degpoly)* &
+ (dble(degpoly)+1.d0)*pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))*(zgll(j)-zgll(i)))
+ endif
+
+ end function lagrange_deriv_GLL
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/lgndr.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/lgndr.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/lgndr.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,152 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine lgndr(l,c,s,x,dx)
+
+! computes Legendre function x(l,m,theta)
+! theta=colatitude,c=cos(theta),s=sin(theta),l=angular order,
+! sin(theta) restricted so that sin(theta) > 1.e-7
+! x(1) contains m=0, x(2) contains m=1, x(k+1) contains m=k
+! m=azimuthal (longitudinal) order 0 <= m <= l
+! dx=dx/dtheta
+!
+! subroutine originally came from Physics Dept. Princeton through
+! Peter Davis, modified by Jeffrey Park
+
+ implicit none
+
+! argument variables
+ integer l
+ double precision x(2*l+1),dx(2*l+1)
+ double precision c,s
+
+! local variables
+ integer i,lp1,lpsafe,lsave
+ integer m,maxsin,mmm,mp1
+
+ double precision sqroot2over2,c1,c2,cot
+ double precision ct,d,f1,f2
+ double precision f3,fac,g1,g2
+ double precision g3,rfpi,sqroot3,sos
+ double precision ss,stom,t,tol
+ double precision v,y
+
+ tol = 1.d-05
+ rfpi = 0.282094791773880d0
+ sqroot3 = 1.73205080756890d0
+ sqroot2over2 = 0.707106781186550d0
+
+ if(s >= 1.0d0-tol) s=1.0d0-tol
+ lsave=l
+ if(l<0) l=-1-l
+ if(l>0) goto 1
+ x(1)=rfpi
+ dx(1)=0.0d0
+ l=lsave
+ return
+ 1 if(l /= 1) goto 2
+ c1=sqroot3*rfpi
+ c2=sqroot2over2*c1
+ x(1)=c1*c
+ x(2)=-c2*s
+ dx(1)=-c1*s
+ dx(2)=-c2*c
+ l=lsave
+ return
+ 2 sos=s
+ if(s<tol) s=tol
+ cot=c/s
+ ct=2.0d0*c
+ ss=s*s
+ lp1=l+1
+ g3=0.0d0
+ g2=1.0d0
+ f3=0.0d0
+
+! evaluate m=l value, sans (sin(theta))**l
+ do i=1,l
+ g2=g2*(1.0d0-1.0d0/(2.0d0*i))
+ enddo
+ g2=rfpi*dsqrt((2*l+1)*g2)
+ f2=l*cot*g2
+ x(lp1)=g2
+ dx(lp1)=f2
+ v=1.0d0
+ y=2.0d0*l
+ d=dsqrt(v*y)
+ t=0.0d0
+ mp1=l
+ m=l-1
+
+! these recursions are similar to ordinary m-recursions, but since we
+! have taken the s**m factor out of the xlm's, the recursion has the powers
+! of sin(theta) instead
+ 3 g1=-(ct*mp1*g2+ss*t*g3)/d
+ f1=(mp1*(2.0d0*s*g2-ct*f2)-t*ss*(f3+cot*g3))/d-cot*g1
+ x(mp1)=g1
+ dx(mp1)=f1
+ if(m == 0) goto 4
+ mp1=m
+ m=m-1
+ v=v+1.0d0
+ y=y-1.0d0
+ t=d
+ d=dsqrt(v*y)
+ g3=g2
+ g2=g1
+ f3=f2
+ f2=f1
+ goto 3
+! explicit conversion to integer added
+ 4 maxsin=int(-72.0d0/log10(s))
+
+! maxsin is the max exponent of sin(theta) without underflow
+ lpsafe=min0(lp1,maxsin)
+ stom=1.0d0
+ fac=sign(1.0d0,dble((l/2)*2-l) + 0.50d0)
+
+! multiply xlm by sin**m
+ do m=1,lpsafe
+ x(m)=fac*x(m)*stom
+ dx(m)=fac*dx(m)*stom
+ stom=stom*s
+ enddo
+
+! set any remaining xlm to zero
+ if(maxsin <= l) then
+ mmm=maxsin+1
+ do m=mmm,lp1
+ x(m)=0.0d0
+ dx(m)=0.0d0
+ enddo
+ endif
+
+ s=sos
+ l=lsave
+
+ end subroutine lgndr
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/make_ellipticity.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/make_ellipticity.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/make_ellipticity.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,175 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
+
+! creates a spline for the ellipticity profile in PREM
+! radius and density are non-dimensional
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspl
+
+ logical ONE_CRUST
+
+! radius of the Earth for gravity calculation
+ double precision, parameter :: R_EARTH_ELLIPTICITY = 6371000.d0
+! radius of the ocean floor for gravity calculation
+ double precision, parameter :: ROCEAN_ELLIPTICITY = 6368000.d0
+
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+ integer i
+ double precision ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R220,R400,R600,R670, &
+ R771,RTOPDDOUBLEPRIME,RCMB,RICB
+ double precision r_icb,r_cmb,r_topddoubleprime,r_771,r_670,r_600
+ double precision r_400,r_220,r_80,r_moho,r_middle_crust,r_ocean,r_0
+ double precision r(NR),rho(NR),epsilonval(NR),eta(NR)
+ double precision radau(NR),z,k(NR),g_a,bom,exponentval,i_rho,i_radau
+ double precision s1(NR),s2(NR),s3(NR)
+ double precision yp1,ypn
+
+! PREM
+ ROCEAN = 6368000.d0
+ RMIDDLE_CRUST = 6356000.d0
+ RMOHO = 6346600.d0
+ R80 = 6291000.d0
+ R220 = 6151000.d0
+ R400 = 5971000.d0
+ R600 = 5771000.d0
+ R670 = 5701000.d0
+ R771 = 5600000.d0
+ RTOPDDOUBLEPRIME = 3630000.d0
+ RCMB = 3480000.d0
+ RICB = 1221000.d0
+
+! non-dimensionalize
+ r_icb = RICB/R_EARTH_ELLIPTICITY
+ r_cmb = RCMB/R_EARTH_ELLIPTICITY
+ r_topddoubleprime = RTOPDDOUBLEPRIME/R_EARTH_ELLIPTICITY
+ r_771 = R771/R_EARTH_ELLIPTICITY
+ r_670 = R670/R_EARTH_ELLIPTICITY
+ r_600 = R600/R_EARTH_ELLIPTICITY
+ r_400 = R400/R_EARTH_ELLIPTICITY
+ r_220 = R220/R_EARTH_ELLIPTICITY
+ r_80 = R80/R_EARTH_ELLIPTICITY
+ r_moho = RMOHO/R_EARTH_ELLIPTICITY
+ r_middle_crust = RMIDDLE_CRUST/R_EARTH_ELLIPTICITY
+ r_ocean = ROCEAN_ELLIPTICITY/R_EARTH_ELLIPTICITY
+ r_0 = 1.d0
+
+ do i=1,163
+ r(i) = r_icb*dble(i-1)/dble(162)
+ enddo
+ do i=164,323
+ r(i) = r_icb+(r_cmb-r_icb)*dble(i-164)/dble(159)
+ enddo
+ do i=324,336
+ r(i) = r_cmb+(r_topddoubleprime-r_cmb)*dble(i-324)/dble(12)
+ enddo
+ do i=337,517
+ r(i) = r_topddoubleprime+(r_771-r_topddoubleprime)*dble(i-337)/dble(180)
+ enddo
+ do i=518,530
+ r(i) = r_771+(r_670-r_771)*dble(i-518)/dble(12)
+ enddo
+ do i=531,540
+ r(i) = r_670+(r_600-r_670)*dble(i-531)/dble(9)
+ enddo
+ do i=541,565
+ r(i) = r_600+(r_400-r_600)*dble(i-541)/dble(24)
+ enddo
+ do i=566,590
+ r(i) = r_400+(r_220-r_400)*dble(i-566)/dble(24)
+ enddo
+ do i=591,609
+ r(i) = r_220+(r_80-r_220)*dble(i-591)/dble(18)
+ enddo
+ do i=610,619
+ r(i) = r_80+(r_moho-r_80)*dble(i-610)/dble(9)
+ enddo
+ do i=620,626
+ r(i) = r_moho+(r_middle_crust-r_moho)*dble(i-620)/dble(6)
+ enddo
+ do i=627,633
+ r(i) = r_middle_crust+(r_ocean-r_middle_crust)*dble(i-627)/dble(6)
+ enddo
+ do i=634,NR
+ r(i) = r_ocean+(r_0-r_ocean)*dble(i-634)/dble(6)
+ enddo
+
+
+! use PREM to get the density profile for ellipticity (fine for other 1D reference models)
+ do i=1,NR
+ call prem_density(r(i),rho(i),ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+ radau(i)=rho(i)*r(i)*r(i)
+ enddo
+
+ eta(1)=0.0d0
+
+ k(1)=0.0d0
+
+ do i=2,NR
+ call intgrl(i_rho,r,1,i,rho,s1,s2,s3)
+ call intgrl(i_radau,r,1,i,radau,s1,s2,s3)
+ z=(2.0d0/3.0d0)*i_radau/(i_rho*r(i)*r(i))
+ eta(i)=(25.0d0/4.0d0)*((1.0d0-(3.0d0/2.0d0)*z)**2.0d0)-1.0d0
+ k(i)=eta(i)/(r(i)**3.0d0)
+ enddo
+
+ g_a=4.0D0*i_rho
+ bom=TWO_PI/(24.0d0*3600.0d0)
+ bom=bom/sqrt(PI*GRAV*RHOAV)
+ epsilonval(NR)=15.0d0*(bom**2.0d0)/(24.0d0*i_rho*(eta(NR)+2.0d0))
+
+ do i=1,NR-1
+ call intgrl(exponentval,r,i,NR,k,s1,s2,s3)
+ epsilonval(i)=epsilonval(NR)*exp(-exponentval)
+ enddo
+
+! get ready to spline epsilonval
+ nspl=1
+ rspl(1)=r(1)
+ espl(1)=epsilonval(1)
+ do i=2,NR
+ if(r(i) /= r(i-1)) then
+ nspl=nspl+1
+ rspl(nspl)=r(i)
+ espl(nspl)=epsilonval(i)
+ endif
+ enddo
+
+! spline epsilonval
+ yp1=0.0d0
+ ypn=(5.0d0/2.0d0)*(bom**2)/g_a-2.0d0*epsilonval(NR)
+ call spline_construction(rspl,espl,nspl,yp1,ypn,espl2)
+
+ end subroutine make_ellipticity
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/make_gravity.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/make_gravity.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/make_gravity.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,156 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine make_gravity(nspl,rspl,gspl,gspl2,ONE_CRUST)
+
+! creates a spline for the gravity profile in PREM
+! radius and density are non-dimensional
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspl
+
+ logical ONE_CRUST
+
+! radius of the Earth for gravity calculation
+ double precision, parameter :: R_EARTH_GRAVITY = 6371000.d0
+! radius of the ocean floor for gravity calculation
+ double precision, parameter :: ROCEAN_GRAVITY = 6368000.d0
+
+ double precision rspl(NR),gspl(NR),gspl2(NR)
+
+ integer i
+ double precision ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R220,R400,R600,R670, &
+ R771,RTOPDDOUBLEPRIME,RCMB,RICB
+ double precision r_icb,r_cmb,r_topddoubleprime,r_771,r_670,r_600
+ double precision r_400,r_220,r_80,r_moho,r_middle_crust,r_ocean,r_0
+ double precision r(NR),rho(NR),g(NR),i_rho
+ double precision s1(NR),s2(NR),s3(NR)
+ double precision yp1,ypn
+
+! PREM
+ ROCEAN = 6368000.d0
+ RMIDDLE_CRUST = 6356000.d0
+ RMOHO = 6346600.d0
+ R80 = 6291000.d0
+ R220 = 6151000.d0
+ R400 = 5971000.d0
+ R600 = 5771000.d0
+ R670 = 5701000.d0
+ R771 = 5600000.d0
+ RTOPDDOUBLEPRIME = 3630000.d0
+ RCMB = 3480000.d0
+ RICB = 1221000.d0
+
+! non-dimensionalize
+ r_icb = RICB/R_EARTH_GRAVITY
+ r_cmb = RCMB/R_EARTH_GRAVITY
+ r_topddoubleprime = RTOPDDOUBLEPRIME/R_EARTH_GRAVITY
+ r_771 = R771/R_EARTH_GRAVITY
+ r_670 = R670/R_EARTH_GRAVITY
+ r_600 = R600/R_EARTH_GRAVITY
+ r_400 = R400/R_EARTH_GRAVITY
+ r_220 = R220/R_EARTH_GRAVITY
+ r_80 = R80/R_EARTH_GRAVITY
+ r_moho = RMOHO/R_EARTH_GRAVITY
+ r_middle_crust = RMIDDLE_CRUST/R_EARTH_GRAVITY
+ r_ocean = ROCEAN_GRAVITY/R_EARTH_GRAVITY
+ r_0 = 1.d0
+
+ do i=1,163
+ r(i) = r_icb*dble(i-1)/dble(162)
+ enddo
+ do i=164,323
+ r(i) = r_icb+(r_cmb-r_icb)*dble(i-164)/dble(159)
+ enddo
+ do i=324,336
+ r(i) = r_cmb+(r_topddoubleprime-r_cmb)*dble(i-324)/dble(12)
+ enddo
+ do i=337,517
+ r(i) = r_topddoubleprime+(r_771-r_topddoubleprime)*dble(i-337)/dble(180)
+ enddo
+ do i=518,530
+ r(i) = r_771+(r_670-r_771)*dble(i-518)/dble(12)
+ enddo
+ do i=531,540
+ r(i) = r_670+(r_600-r_670)*dble(i-531)/dble(9)
+ enddo
+ do i=541,565
+ r(i) = r_600+(r_400-r_600)*dble(i-541)/dble(24)
+ enddo
+ do i=566,590
+ r(i) = r_400+(r_220-r_400)*dble(i-566)/dble(24)
+ enddo
+ do i=591,609
+ r(i) = r_220+(r_80-r_220)*dble(i-591)/dble(18)
+ enddo
+ do i=610,619
+ r(i) = r_80+(r_moho-r_80)*dble(i-610)/dble(9)
+ enddo
+ do i=620,626
+ r(i) = r_moho+(r_middle_crust-r_moho)*dble(i-620)/dble(6)
+ enddo
+ do i=627,633
+ r(i) = r_middle_crust+(r_ocean-r_middle_crust)*dble(i-627)/dble(6)
+ enddo
+ do i=634,NR
+ r(i) = r_ocean+(r_0-r_ocean)*dble(i-634)/dble(6)
+ enddo
+
+! use PREM to get the density profile for ellipticity (fine for other 1D reference models)
+ do i=1,NR
+ call prem_density(r(i),rho(i),ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN_GRAVITY)
+ enddo
+
+ g(1)=0.0d0
+ do i=2,NR
+ call intgrl(i_rho,r,1,i,rho,s1,s2,s3)
+ g(i)=4.0d0*i_rho/(r(i)*r(i))
+ enddo
+
+!
+! get ready to spline g
+!
+ nspl=1
+ rspl(1)=r(1)
+ gspl(1)=g(1)
+ do i=2,NR
+ if(r(i)/=r(i-1)) then
+ nspl=nspl+1
+ rspl(nspl)=r(i)
+ gspl(nspl)=g(i)
+ endif
+ enddo
+ yp1=(4.0d0/3.0d0)*rho(1)
+ ypn=4.0d0*rho(NR)-2.0d0*g(NR)/r(NR)
+ call spline_construction(rspl,gspl,nspl,yp1,ypn,gspl2)
+
+ end subroutine make_gravity
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/mantle_model.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/mantle_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/mantle_model.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,457 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine read_mantle_model(D3MM_V)
+
+ implicit none
+
+ include "constants.h"
+
+! three_d_mantle_model_variables
+ type three_d_mantle_model_variables
+ sequence
+ double precision dvs_a(0:NK,0:NS,0:NS)
+ double precision dvs_b(0:NK,0:NS,0:NS)
+ double precision dvp_a(0:NK,0:NS,0:NS)
+ double precision dvp_b(0:NK,0:NS,0:NS)
+ double precision spknt(NK+1)
+ double precision qq0(NK+1,NK+1)
+ double precision qq(3,NK+1,NK+1)
+ end type three_d_mantle_model_variables
+
+ type (three_d_mantle_model_variables) D3MM_V
+! three_d_mantle_model_variables
+
+ integer k,l,m
+
+ character(len=150) S20RTS, P12
+
+ call get_value_string(S20RTS, 'model.S20RTS', 'DATA/s20rts/S20RTS.dat')
+ call get_value_string(P12, 'model.P12', 'DATA/s20rts/P12.dat')
+
+! S20RTS degree 20 S model from Ritsema
+ open(unit=10,file=S20RTS,status='old',action='read')
+ do k=0,NK
+ do l=0,NS
+ read(10,*) D3MM_V%dvs_a(k,l,0),(D3MM_V%dvs_a(k,l,m),D3MM_V%dvs_b(k,l,m),m=1,l)
+ enddo
+ enddo
+ close(10)
+
+! P12 degree 12 P model from Ritsema
+ open(unit=10,file=P12,status='old',action='read')
+ do k=0,NK
+ do l=0,12
+ read(10,*) D3MM_V%dvp_a(k,l,0),(D3MM_V%dvp_a(k,l,m),D3MM_V%dvp_b(k,l,m),m=1,l)
+ enddo
+ do l=13,NS
+ D3MM_V%dvp_a(k,l,0) = 0.0d0
+ do m=1,l
+ D3MM_V%dvp_a(k,l,m) = 0.0d0
+ D3MM_V%dvp_b(k,l,m) = 0.0d0
+ enddo
+ enddo
+ enddo
+ close(10)
+
+! set up the splines used as radial basis functions by Ritsema
+ call splhsetup(D3MM_V)
+
+ end subroutine read_mantle_model
+
+!---------------------------
+
+ subroutine mantle_model(radius,theta,phi,dvs,dvp,drho,D3MM_V)
+
+ implicit none
+
+ include "constants.h"
+
+! three_d_mantle_model_variables
+ type three_d_mantle_model_variables
+ sequence
+ double precision dvs_a(0:NK,0:NS,0:NS)
+ double precision dvs_b(0:NK,0:NS,0:NS)
+ double precision dvp_a(0:NK,0:NS,0:NS)
+ double precision dvp_b(0:NK,0:NS,0:NS)
+ double precision spknt(NK+1)
+ double precision qq0(NK+1,NK+1)
+ double precision qq(3,NK+1,NK+1)
+ end type three_d_mantle_model_variables
+
+ type (three_d_mantle_model_variables) D3MM_V
+! three_d_mantle_model_variables
+
+! factor to convert perturbations in shear speed to perturbations in density
+ double precision, parameter :: SCALE_RHO = 0.40d0
+
+ double precision radius,theta,phi,dvs,dvp,drho
+
+ double precision, parameter :: RMOHO_ = 6346600.d0
+ double precision, parameter :: RCMB_ = 3480000.d0
+ double precision, parameter :: R_EARTH_ = 6371000.d0
+ double precision, parameter :: ZERO_ = 0.d0
+
+ integer l,m,k
+ double precision r_moho,r_cmb,xr
+ double precision dvs_alm,dvs_blm
+ double precision dvp_alm,dvp_blm
+ double precision rsple,radial_basis(0:NK)
+ double precision sint,cost,x(2*NS+1),dx(2*NS+1)
+
+ dvs = ZERO_
+ dvp = ZERO_
+ drho = ZERO_
+
+ r_moho = RMOHO_ / R_EARTH_
+ r_cmb = RCMB_ / R_EARTH_
+ if(radius>=r_moho .or. radius <= r_cmb) return
+
+ xr=-1.0d0+2.0d0*(radius-r_cmb)/(r_moho-r_cmb)
+ do k=0,NK
+ radial_basis(k)=rsple(1,NK+1,D3MM_V%spknt(1),D3MM_V%qq0(1,NK+1-k),D3MM_V%qq(1,1,NK+1-k),xr)
+ enddo
+
+ do l=0,NS
+ sint=dsin(theta)
+ cost=dcos(theta)
+ call lgndr(l,cost,sint,x,dx)
+ dvs_alm=0.0d0
+ dvp_alm=0.0d0
+ do k=0,NK
+ dvs_alm=dvs_alm+radial_basis(k)*D3MM_V%dvs_a(k,l,0)
+ dvp_alm=dvp_alm+radial_basis(k)*D3MM_V%dvp_a(k,l,0)
+ enddo
+ dvs=dvs+dvs_alm*x(1)
+ dvp=dvp+dvp_alm*x(1)
+ do m=1,l
+ dvs_alm=0.0d0
+ dvp_alm=0.0d0
+ dvs_blm=0.0d0
+ dvp_blm=0.0d0
+ do k=0,NK
+ dvs_alm=dvs_alm+radial_basis(k)*D3MM_V%dvs_a(k,l,m)
+ dvp_alm=dvp_alm+radial_basis(k)*D3MM_V%dvp_a(k,l,m)
+ dvs_blm=dvs_blm+radial_basis(k)*D3MM_V%dvs_b(k,l,m)
+ dvp_blm=dvp_blm+radial_basis(k)*D3MM_V%dvp_b(k,l,m)
+ enddo
+ dvs=dvs+(dvs_alm*dcos(dble(m)*phi)+dvs_blm*dsin(dble(m)*phi))*x(m+1)
+ dvp=dvp+(dvp_alm*dcos(dble(m)*phi)+dvp_blm*dsin(dble(m)*phi))*x(m+1)
+ enddo
+ enddo
+
+ drho = SCALE_RHO*dvs
+
+ end subroutine mantle_model
+
+!----------------------------------
+
+ subroutine splhsetup(D3MM_V)!!!!!!!!!!!!!!(spknt,qq0,qq)
+
+ implicit none
+ include "constants.h"
+
+!!!!!!!!!!!!!!!!!!! double precision spknt(NK+1),qq0(NK+1,NK+1),qq(3,NK+1,NK+1)
+
+! three_d_mantle_model_variables
+ type three_d_mantle_model_variables
+ sequence
+ double precision dvs_a(0:NK,0:NS,0:NS)
+ double precision dvs_b(0:NK,0:NS,0:NS)
+ double precision dvp_a(0:NK,0:NS,0:NS)
+ double precision dvp_b(0:NK,0:NS,0:NS)
+ double precision spknt(NK+1)
+ double precision qq0(NK+1,NK+1)
+ double precision qq(3,NK+1,NK+1)
+ end type three_d_mantle_model_variables
+
+ type (three_d_mantle_model_variables) D3MM_V
+! three_d_mantle_model_variables
+
+
+ integer i,j
+ double precision qqwk(3,NK+1)
+
+ D3MM_V%spknt(1) = -1.00000d0
+ D3MM_V%spknt(2) = -0.78631d0
+ D3MM_V%spknt(3) = -0.59207d0
+ D3MM_V%spknt(4) = -0.41550d0
+ D3MM_V%spknt(5) = -0.25499d0
+ D3MM_V%spknt(6) = -0.10909d0
+ D3MM_V%spknt(7) = 0.02353d0
+ D3MM_V%spknt(8) = 0.14409d0
+ D3MM_V%spknt(9) = 0.25367d0
+ D3MM_V%spknt(10) = 0.35329d0
+ D3MM_V%spknt(11) = 0.44384d0
+ D3MM_V%spknt(12) = 0.52615d0
+ D3MM_V%spknt(13) = 0.60097d0
+ D3MM_V%spknt(14) = 0.66899d0
+ D3MM_V%spknt(15) = 0.73081d0
+ D3MM_V%spknt(16) = 0.78701d0
+ D3MM_V%spknt(17) = 0.83810d0
+ D3MM_V%spknt(18) = 0.88454d0
+ D3MM_V%spknt(19) = 0.92675d0
+ D3MM_V%spknt(20) = 0.96512d0
+ D3MM_V%spknt(21) = 1.00000d0
+
+ do i=1,NK+1
+ do j=1,NK+1
+ if(i == j) then
+ D3MM_V%qq0(j,i)=1.0d0
+ else
+ D3MM_V%qq0(j,i)=0.0d0
+ endif
+ enddo
+ enddo
+ do i=1,NK+1
+ call rspln(1,NK+1,D3MM_V%spknt(1),D3MM_V%qq0(1,i),D3MM_V%qq(1,1,i),qqwk(1,1))
+ enddo
+
+ end subroutine splhsetup
+
+!----------------------------------
+
+! changed the obsolecent f77 features in the two routines below
+! now still awful Fortran, but at least conforms to f90 standard
+
+ double precision function rsple(I1,I2,X,Y,Q,S)
+
+ implicit none
+
+! rsple returns the value of the function y(x) evaluated at point S
+! using the cubic spline coefficients computed by rspln and saved in Q.
+! If S is outside the interval (x(i1),x(i2)) rsple extrapolates
+! using the first or last interpolation polynomial. The arrays must
+! be dimensioned at least - x(i2), y(i2), and q(3,i2).
+
+ integer i1,i2
+ double precision X(*),Y(*),Q(3,*),s
+
+ integer i,ii
+ double precision h
+
+ i = 1
+ II=I2-1
+
+! GUARANTEE I WITHIN BOUNDS.
+ I=MAX0(I,I1)
+ I=MIN0(I,II)
+
+! SEE IF X IS INCREASING OR DECREASING.
+ IF(X(I2)-X(I1) < 0) goto 1
+ IF(X(I2)-X(I1) >= 0) goto 2
+
+! X IS DECREASING. CHANGE I AS NECESSARY.
+ 1 IF(S-X(I) <= 0) goto 3
+ IF(S-X(I) > 0) goto 4
+
+ 4 I=I-1
+
+ IF(I-I1 < 0) goto 11
+ IF(I-I1 == 0) goto 6
+ IF(I-I1 > 0) goto 1
+
+ 3 IF(S-X(I+1) < 0) goto 5
+ IF(S-X(I+1) >= 0) goto 6
+
+ 5 I=I+1
+
+ IF(I-II < 0) goto 3
+ IF(I-II == 0) goto 6
+ IF(I-II > 0) goto 7
+
+! X IS INCREASING. CHANGE I AS NECESSARY.
+ 2 IF(S-X(I+1) <= 0) goto 8
+ IF(S-X(I+1) > 0) goto 9
+
+ 9 I=I+1
+
+ IF(I-II < 0) goto 2
+ IF(I-II == 0) goto 6
+ IF(I-II > 0) goto 7
+
+ 8 IF(S-X(I) < 0) goto 10
+ IF(S-X(I) >= 0) goto 6
+
+ 10 I=I-1
+ IF(I-I1 < 0) goto 11
+ IF(I-I1 == 0) goto 6
+ IF(I-I1 > 0) goto 8
+
+ 7 I=II
+ GOTO 6
+ 11 I=I1
+
+! CALCULATE RSPLE USING SPLINE COEFFICIENTS IN Y AND Q.
+ 6 H=S-X(I)
+ RSPLE=Y(I)+H*(Q(1,I)+H*(Q(2,I)+H*Q(3,I)))
+
+ end function rsple
+
+!----------------------------------
+
+ subroutine rspln(I1,I2,X,Y,Q,F)
+
+ implicit none
+
+! Subroutine rspln computes cubic spline interpolation coefficients
+! for y(x) between grid points i1 and i2 saving them in q.The
+! interpolation is continuous with continuous first and second
+! derivatives. It agrees exactly with y at grid points and with the
+! three point first derivatives at both end points (i1 and i2).
+! X must be monotonic but if two successive values of x are equal
+! a discontinuity is assumed and separate interpolation is done on
+! each strictly monotonic segment. The arrays must be dimensioned at
+! least - x(i2), y(i2), q(3,i2), and f(3,i2).
+! F is working storage for rspln.
+
+ integer i1,i2
+ double precision X(*),Y(*),Q(3,*),F(3,*)
+
+ integer i,j,k,j1,j2
+ double precision y0,a0,b0,b1,h,h2,ha,h2a,h3a,h2b
+ double precision YY(3),small
+ equivalence (YY(1),Y0)
+ data SMALL/1.0d-08/,YY/0.0d0,0.0d0,0.0d0/
+
+ J1=I1+1
+ Y0=0.0d0
+
+! BAIL OUT IF THERE ARE LESS THAN TWO POINTS TOTAL
+ IF(I2-I1 < 0) return
+ IF(I2-I1 == 0) goto 17
+ IF(I2-I1 > 0) goto 8
+
+ 8 A0=X(J1-1)
+! SEARCH FOR DISCONTINUITIES.
+ DO 3 I=J1,I2
+ B0=A0
+ A0=X(I)
+ IF(DABS((A0-B0)/DMAX1(A0,B0)) < SMALL) GOTO 4
+ 3 CONTINUE
+ 17 J1=J1-1
+ J2=I2-2
+ GOTO 5
+ 4 J1=J1-1
+ J2=I-3
+! SEE IF THERE ARE ENOUGH POINTS TO INTERPOLATE (AT LEAST THREE).
+ 5 IF(J2+1-J1 < 0) goto 9
+ IF(J2+1-J1 == 0) goto 10
+ IF(J2+1-J1 > 0) goto 11
+
+! ONLY TWO POINTS. USE LINEAR INTERPOLATION.
+ 10 J2=J2+2
+ Y0=(Y(J2)-Y(J1))/(X(J2)-X(J1))
+ DO J=1,3
+ Q(J,J1)=YY(J)
+ Q(J,J2)=YY(J)
+ enddo
+ GOTO 12
+
+! MORE THAN TWO POINTS. DO SPLINE INTERPOLATION.
+ 11 A0=0.
+ H=X(J1+1)-X(J1)
+ H2=X(J1+2)-X(J1)
+ Y0=H*H2*(H2-H)
+ H=H*H
+ H2=H2*H2
+! CALCULATE DERIVITIVE AT NEAR END.
+ B0=(Y(J1)*(H-H2)+Y(J1+1)*H2-Y(J1+2)*H)/Y0
+ B1=B0
+
+! EXPLICITLY REDUCE BANDED MATRIX TO AN UPPER BANDED MATRIX.
+ DO I=J1,J2
+ H=X(I+1)-X(I)
+ Y0=Y(I+1)-Y(I)
+ H2=H*H
+ HA=H-A0
+ H2A=H-2.0d0*A0
+ H3A=2.0d0*H-3.0d0*A0
+ H2B=H2*B0
+ Q(1,I)=H2/HA
+ Q(2,I)=-HA/(H2A*H2)
+ Q(3,I)=-H*H2A/H3A
+ F(1,I)=(Y0-H*B0)/(H*HA)
+ F(2,I)=(H2B-Y0*(2.0d0*H-A0))/(H*H2*H2A)
+ F(3,I)=-(H2B-3.0d0*Y0*HA)/(H*H3A)
+ A0=Q(3,I)
+ B0=F(3,I)
+ enddo
+
+! TAKE CARE OF LAST TWO ROWS.
+ I=J2+1
+ H=X(I+1)-X(I)
+ Y0=Y(I+1)-Y(I)
+ H2=H*H
+ HA=H-A0
+ H2A=H*HA
+ H2B=H2*B0-Y0*(2.0d0*H-A0)
+ Q(1,I)=H2/HA
+ F(1,I)=(Y0-H*B0)/H2A
+ HA=X(J2)-X(I+1)
+ Y0=-H*HA*(HA+H)
+ HA=HA*HA
+
+! CALCULATE DERIVATIVE AT FAR END.
+ Y0=(Y(I+1)*(H2-HA)+Y(I)*HA-Y(J2)*H2)/Y0
+ Q(3,I)=(Y0*H2A+H2B)/(H*H2*(H-2.0d0*A0))
+ Q(2,I)=F(1,I)-Q(1,I)*Q(3,I)
+
+! SOLVE UPPER BANDED MATRIX BY REVERSE ITERATION.
+ DO J=J1,J2
+ K=I-1
+ Q(1,I)=F(3,K)-Q(3,K)*Q(2,I)
+ Q(3,K)=F(2,K)-Q(2,K)*Q(1,I)
+ Q(2,K)=F(1,K)-Q(1,K)*Q(3,K)
+ I=K
+ enddo
+ Q(1,I)=B1
+! FILL IN THE LAST POINT WITH A LINEAR EXTRAPOLATION.
+ 9 J2=J2+2
+ DO J=1,3
+ Q(J,J2)=YY(J)
+ enddo
+
+! SEE IF THIS DISCONTINUITY IS THE LAST.
+ 12 IF(J2-I2 < 0) then
+ goto 6
+ else
+ return
+ endif
+
+! NO. GO BACK FOR MORE.
+ 6 J1=J2+2
+ IF(J1-I2 <= 0) goto 8
+ IF(J1-I2 > 0) goto 7
+
+! THERE IS ONLY ONE POINT LEFT AFTER THE LATEST DISCONTINUITY.
+ 7 DO J=1,3
+ Q(J,I2)=YY(J)
+ enddo
+
+ end subroutine rspln
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/memory_eval.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/memory_eval.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/memory_eval.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,358 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! compute the approximate amount of static memory needed to run the solver
+
+ subroutine memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MANTLE,&
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_INNER_CORE,ROTATION,&
+ ONE_CRUST,doubling_index,this_region_has_a_doubling,&
+ ner,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_sampling_array,&
+ NSPEC,nglob,SIMULATION_TYPE,MOVIE_VOLUME,SAVE_FORWARD, &
+ NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION,static_memory_size)
+
+ implicit none
+
+ include "constants.h"
+
+! input
+ logical, intent(in) :: TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ ROTATION,ATTENUATION,ONE_CRUST,OCEANS,ABSORBING_CONDITIONS,MOVIE_VOLUME,SAVE_FORWARD
+ integer, dimension(MAX_NUM_REGIONS), intent(in) :: NSPEC, nglob
+ integer, intent(in) :: NEX_PER_PROC_XI,NEX_PER_PROC_ETA,SIMULATION_TYPE
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS), intent(in) :: doubling_index
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS), intent(in) :: this_region_has_a_doubling
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS), intent(in) :: ner,ratio_sampling_array
+
+! output
+ double precision, intent(out) :: static_memory_size
+
+! variables
+ integer :: ilayer,NUMBER_OF_MESH_LAYERS,ner_without_doubling,ispec_aniso
+
+ integer, intent(out) :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION
+
+! generate the elements in all the regions of the mesh
+ ispec_aniso = 0
+
+ if (ONE_CRUST) then
+ NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS - 1
+ else
+ NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS
+ endif
+
+! count anisotropic elements
+ do ilayer = 1, NUMBER_OF_MESH_LAYERS
+ if(doubling_index(ilayer) == IFLAG_220_80 .or. doubling_index(ilayer) == IFLAG_80_MOHO) then
+ ner_without_doubling = ner(ilayer)
+ if(this_region_has_a_doubling(ilayer)) then
+ ner_without_doubling = ner_without_doubling - 2
+ ispec_aniso = ispec_aniso + &
+ (NSPEC_DOUBLING_SUPERBRICK*(NEX_PER_PROC_XI/ratio_sampling_array(ilayer)/2)* &
+ (NEX_PER_PROC_ETA/ratio_sampling_array(ilayer)/2))
+ endif
+ ispec_aniso = ispec_aniso + &
+ ((NEX_PER_PROC_XI/ratio_sampling_array(ilayer))*(NEX_PER_PROC_ETA/ratio_sampling_array(ilayer))*ner_without_doubling)
+ endif
+ enddo
+
+! define static size of the arrays whose size depends on logical tests
+
+ if(ANISOTROPIC_INNER_CORE) then
+ NSPECMAX_ANISO_IC = NSPEC(IREGION_INNER_CORE)
+ else
+ NSPECMAX_ANISO_IC = 1
+ endif
+
+ if(ANISOTROPIC_3D_MANTLE) then
+ NSPECMAX_ISO_MANTLE = 1
+ NSPECMAX_TISO_MANTLE = 1
+ NSPECMAX_ANISO_MANTLE = NSPEC(IREGION_CRUST_MANTLE)
+ else
+
+ NSPECMAX_ISO_MANTLE = NSPEC(IREGION_CRUST_MANTLE)
+ if(TRANSVERSE_ISOTROPY) then
+ NSPECMAX_TISO_MANTLE = ispec_aniso
+ else
+ NSPECMAX_TISO_MANTLE = 1
+ endif
+
+ NSPECMAX_ANISO_MANTLE = 1
+ endif
+
+! if attenuation is off, set dummy size of arrays to one
+ if(ATTENUATION) then
+ NSPEC_CRUST_MANTLE_ATTENUAT = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_INNER_CORE_ATTENUATION = NSPEC(IREGION_INNER_CORE)
+ else
+ NSPEC_CRUST_MANTLE_ATTENUAT = 1
+ NSPEC_INNER_CORE_ATTENUATION = 1
+ endif
+
+ if(ATTENUATION .or. SIMULATION_TYPE /= 1 .or. SAVE_FORWARD .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then
+ NSPEC_CRUST_MANTLE_STR_OR_ATT = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_INNER_CORE_STR_OR_ATT = NSPEC(IREGION_INNER_CORE)
+ else
+ NSPEC_CRUST_MANTLE_STR_OR_ATT = 1
+ NSPEC_INNER_CORE_STR_OR_ATT = 1
+ endif
+
+ if(ATTENUATION .and. SIMULATION_TYPE == 3) then
+ NSPEC_CRUST_MANTLE_STR_AND_ATT = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_INNER_CORE_STR_AND_ATT = NSPEC(IREGION_INNER_CORE)
+ else
+ NSPEC_CRUST_MANTLE_STR_AND_ATT = 1
+ NSPEC_INNER_CORE_STR_AND_ATT = 1
+ endif
+
+
+ if(SIMULATION_TYPE /= 1 .or. SAVE_FORWARD .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_INNER_CORE_STRAIN_ONLY = NSPEC(IREGION_INNER_CORE)
+ else
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY = 1
+ NSPEC_INNER_CORE_STRAIN_ONLY = 1
+ endif
+
+ if ((SIMULATION_TYPE == 1 .and. SAVE_FORWARD) .or. SIMULATION_TYPE == 3) then
+ NSPEC_CRUST_MANTLE_ADJOINT = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_OUTER_CORE_ADJOINT = NSPEC(IREGION_OUTER_CORE)
+ NSPEC_INNER_CORE_ADJOINT = NSPEC(IREGION_INNER_CORE)
+
+ NGLOB_CRUST_MANTLE_ADJOINT = NGLOB(IREGION_CRUST_MANTLE)
+ NGLOB_OUTER_CORE_ADJOINT = NGLOB(IREGION_OUTER_CORE)
+ NGLOB_INNER_CORE_ADJOINT = NGLOB(IREGION_INNER_CORE)
+
+ if(ROTATION) then
+ NSPEC_OUTER_CORE_ROT_ADJOINT = NSPEC(IREGION_OUTER_CORE)
+ else
+ NSPEC_OUTER_CORE_ROT_ADJOINT = 1
+ endif
+ else
+ NSPEC_CRUST_MANTLE_ADJOINT = 1
+ NSPEC_OUTER_CORE_ADJOINT = 1
+ NSPEC_INNER_CORE_ADJOINT = 1
+
+ NGLOB_CRUST_MANTLE_ADJOINT = 1
+ NGLOB_OUTER_CORE_ADJOINT = 1
+ NGLOB_INNER_CORE_ADJOINT = 1
+
+ NSPEC_OUTER_CORE_ROT_ADJOINT = 1
+ endif
+
+! if absorbing conditions are off, set dummy size of arrays to one
+ if(ABSORBING_CONDITIONS) then
+ NSPEC_CRUST_MANTLE_STACEY = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_OUTER_CORE_STACEY = NSPEC(IREGION_OUTER_CORE)
+ else
+ NSPEC_CRUST_MANTLE_STACEY = 1
+ NSPEC_OUTER_CORE_STACEY = 1
+ endif
+
+! if oceans are off, set dummy size of arrays to one
+ if(OCEANS) then
+ NGLOB_CRUST_MANTLE_OCEANS = NGLOB(IREGION_CRUST_MANTLE)
+ else
+ NGLOB_CRUST_MANTLE_OCEANS = 1
+ endif
+
+ if(ROTATION) then
+ NSPEC_OUTER_CORE_ROTATION = NSPEC(IREGION_OUTER_CORE)
+ else
+ NSPEC_OUTER_CORE_ROTATION = 1
+ endif
+
+! add size of each set of static arrays multiplied by the number of such arrays
+
+ static_memory_size = 0.d0
+
+! R_memory_crust_mantle
+! static_memory_size = static_memory_size + 5.d0*dble(N_SLS)*dble(NGLLX)* &
+! dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_ATTENUAT*dble(CUSTOM_REAL)
+
+! R_memory_inner_core
+! static_memory_size = static_memory_size + 5.d0*dble(N_SLS)*dble(NGLLX)* &
+! dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_ATTENUATION*dble(CUSTOM_REAL)
+
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_CRUST_MANTLE)*9.d0*dble(CUSTOM_REAL)
+
+! ibool_crust_mantle
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_CRUST_MANTLE)*dble(SIZE_INTEGER)
+
+! xix_outer_core,xiy_outer_core,xiz_outer_core,
+! etax_outer_core,etay_outer_core,etaz_outer_core,
+! gammax_outer_core,gammay_outer_core,gammaz_outer_core
+! 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)
+! rmass_crust_mantle
+ static_memory_size = static_memory_size + NGLOB(IREGION_CRUST_MANTLE)*1.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)
+! kappavstore_crust_mantle,muvstore_crust_mantle
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPECMAX_ISO_MANTLE*2.d0*dble(CUSTOM_REAL)
+
+! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle
+! static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPECMAX_TISO_MANTLE*3.d0*dble(CUSTOM_REAL)
+
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,
+! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle,
+! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle,
+! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle,
+! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle,
+! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle,
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle
+! static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPECMAX_ANISO_MANTLE*21.d0*dble(CUSTOM_REAL)
+
+! displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle
+ static_memory_size = static_memory_size + dble(NDIM)*NGLOB(IREGION_CRUST_MANTLE)*3.d0*dble(CUSTOM_REAL)
+
+! xstore_outer_core, ystore_outer_core, zstore_outer_core, rmass_outer_core, displ_outer_core, veloc_outer_core, accel_outer_core
+! static_memory_size = static_memory_size + NGLOB(IREGION_OUTER_CORE)*7.d0*dble(CUSTOM_REAL)
+
+! ibool_inner_core
+! static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_INNER_CORE)*dble(SIZE_INTEGER)
+
+! xix_inner_core,xiy_inner_core,xiz_inner_core,
+! etax_inner_core,etay_inner_core,etaz_inner_core,
+! gammax_inner_core,gammay_inner_core,gammaz_inner_core,
+! 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
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/meshfem3D.F90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/meshfem3D.F90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/meshfem3D.F90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,1546 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+!
+! United States Government Sponsorship Acknowledged.
+
+ program xmeshfem3D
+
+ implicit none
+
+! standard include of the MPI library
+#ifdef USE_MPI
+ include 'mpif.h'
+#endif
+
+ include "constants.h"
+#ifdef USE_MPI
+ include "precision.h"
+#endif
+
+!=====================================================================!
+! !
+! meshfem3D produces a spectral element grid for the Earth. !
+! This is accomplished based upon a mapping of the face of a cube !
+! to a portion of the sphere (Ronchi et al., The Cubed Sphere). !
+! Grid density is decreased by a factor of two !
+! three times in the radial direction. !
+! !
+!=====================================================================!
+!
+! If you use this code for your own research, please cite some of these articles:
+!
+! @ARTICLE{KoRiTr02,
+! author={D. Komatitsch and J. Ritsema and J. Tromp},
+! year=2002,
+! title={The Spectral-Element Method, {B}eowulf Computing, and Global Seismology},
+! journal={Science},
+! volume=298,
+! number=5599,
+! pages={1737-1742},
+! doi={10.1126/science.1076024}}
+!
+! @ARTICLE{KoTr02a,
+! author={D. Komatitsch and J. Tromp},
+! year=2002,
+! title={Spectral-Element Simulations of Global Seismic Wave Propagation{-I. V}alidation},
+! journal={Geophys. J. Int.},
+! volume=149,
+! number=2,
+! pages={390-412},
+! doi={10.1046/j.1365-246X.2002.01653.x}}
+!
+! @ARTICLE{KoTr02b,
+! author={D. Komatitsch and J. Tromp},
+! year=2002,
+! title={Spectral-Element Simulations of Global Seismic Wave Propagation{-II. 3-D} Models, Oceans, Rotation, and Self-Gravitation},
+! journal={Geophys. J. Int.},
+! volume=150,
+! pages={303-318},
+! number=1,
+! doi={10.1046/j.1365-246X.2002.01716.x}}
+!
+! @ARTICLE{KoTr99,
+! author={D. Komatitsch and J. Tromp},
+! year=1999,
+! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
+! journal={Geophys. J. Int.},
+! volume=139,
+! number=3,
+! pages={806-822},
+! doi={10.1046/j.1365-246x.1999.00967.x}}
+!
+! @ARTICLE{KoVi98,
+! author={D. Komatitsch and J. P. Vilotte},
+! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
+! journal={Bull. Seismol. Soc. Am.},
+! year=1998,
+! volume=88,
+! number=2,
+! pages={368-392}}
+!
+! If you use the kernel capabilities of the code, please cite
+!
+! @ARTICLE{LiTr06,
+! author={Qinya Liu and Jeroen Tromp},
+! title={Finite-frequency kernels based on adjoint methods},
+! journal={Bull. Seismol. Soc. Am.},
+! year=2006,
+! volume=96,
+! number=6,
+! pages={2383-2397},
+! doi={10.1785/0120060041}}
+!
+! If you use 3-D model S20RTS, please cite
+!
+! @ARTICLE{RiVa00,
+! author={J. Ritsema and H. J. {Van Heijst}},
+! year=2000,
+! title={Seismic imaging of structural heterogeneity in {E}arth's mantle: Evidence for large-scale mantle flow},
+! journal={Science Progress},
+! volume=83,
+! pages={243-259}}
+!
+! Reference frame - convention:
+! ----------------------------
+!
+! The code uses the following convention for the reference frame:
+!
+! - X axis is East
+! - Y axis is North
+! - Z axis is up
+!
+! Note that this convention is different from both the Aki-Richards convention
+! and the Harvard CMT convention.
+!
+! Let us recall that the Aki-Richards convention is:
+!
+! - X axis is North
+! - Y axis is East
+! - Z axis is down
+!
+! and that the Harvard CMT convention is:
+!
+! - X axis is South
+! - Y axis is East
+! - Z axis is up
+!
+! To report bugs or suggest improvements to the code, please send an email
+! to Jeroen Tromp <jtromp AT caltech.edu> and/or use our online
+! bug tracking system at http://www.geodynamics.org/roundup .
+!
+
+! aniso_mantle_model_variables
+ type aniso_mantle_model_variables
+ sequence
+ double precision beta(14,34,37,73)
+ double precision pro(47)
+ integer npar1
+ end type aniso_mantle_model_variables
+
+ type (aniso_mantle_model_variables) AMM_V
+! aniso_mantle_model_variables
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: Qs ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+! model_1066a_variables
+ type model_1066a_variables
+ sequence
+ double precision, dimension(NR_1066A) :: radius_1066a
+ double precision, dimension(NR_1066A) :: density_1066a
+ double precision, dimension(NR_1066A) :: vp_1066a
+ double precision, dimension(NR_1066A) :: vs_1066a
+ double precision, dimension(NR_1066A) :: Qkappa_1066a
+ double precision, dimension(NR_1066A) :: Qmu_1066a
+ end type model_1066a_variables
+
+ type (model_1066a_variables) M1066a_V
+! model_1066a_variables
+
+! model_ak135_variables
+ type model_ak135_variables
+ sequence
+ double precision, dimension(NR_AK135) :: radius_ak135
+ double precision, dimension(NR_AK135) :: density_ak135
+ double precision, dimension(NR_AK135) :: vp_ak135
+ double precision, dimension(NR_AK135) :: vs_ak135
+ double precision, dimension(NR_AK135) :: Qkappa_ak135
+ double precision, dimension(NR_AK135) :: Qmu_ak135
+ end type model_ak135_variables
+
+ type (model_ak135_variables) Mak135_V
+! model_ak135_variables
+
+! three_d_mantle_model_variables
+ type three_d_mantle_model_variables
+ sequence
+ double precision dvs_a(0:NK,0:NS,0:NS)
+ double precision dvs_b(0:NK,0:NS,0:NS)
+ double precision dvp_a(0:NK,0:NS,0:NS)
+ double precision dvp_b(0:NK,0:NS,0:NS)
+ double precision spknt(NK+1)
+ double precision qq0(NK+1,NK+1)
+ double precision qq(3,NK+1,NK+1)
+ end type three_d_mantle_model_variables
+
+! model_ref_variables
+ type model_ref_variables
+ sequence
+ double precision, dimension(NR_REF) :: radius_ref
+ double precision, dimension(NR_REF) :: density_ref
+ double precision, dimension(NR_REF) :: vpv_ref
+ double precision, dimension(NR_REF) :: vph_ref
+ double precision, dimension(NR_REF) :: vsv_ref
+ double precision, dimension(NR_REF) :: vsh_ref
+ double precision, dimension(NR_REF) :: eta_ref
+ double precision, dimension(NR_REF) :: Qkappa_ref
+ double precision, dimension(NR_REF) :: Qmu_ref
+ end type model_ref_variables
+
+ type (model_ref_variables) Mref_V
+! model_ref_variables
+
+ type (three_d_mantle_model_variables) D3MM_V
+! three_d_mantle_model_variables
+
+! sea1d_model_variables
+ type sea1d_model_variables
+ sequence
+ double precision, dimension(NR_SEA1D) :: radius_sea1d
+ double precision, dimension(NR_SEA1D) :: density_sea1d
+ double precision, dimension(NR_SEA1D) :: vp_sea1d
+ double precision, dimension(NR_SEA1D) :: vs_sea1d
+ double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
+ double precision, dimension(NR_SEA1D) :: Qmu_sea1d
+ end type sea1d_model_variables
+
+ type (sea1d_model_variables) SEA1DM_V
+! sea1d_model_variables
+
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+! sea99_s_model_variables
+ type sea99_s_model_variables
+ sequence
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ end type sea99_s_model_variables
+
+ type (sea99_s_model_variables) SEA99M_V
+! sea99_s_model_variables
+
+! crustal_model_variables
+ type crustal_model_variables
+ sequence
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
+ character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+ character(len=2) code(NKEYS_CRUST)
+ end type crustal_model_variables
+
+ type (crustal_model_variables) CM_V
+! crustal_model_variables
+
+! 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
+
+ logical, dimension(:), allocatable :: is_on_a_slice_edge
+
+! arrays with the mesh in double precision
+ double precision, dimension(:,:,:,:), allocatable :: xstore,ystore,zstore
+
+! proc numbers for MPI
+ integer myrank,sizeprocs
+#ifdef USE_MPI
+ integer ier
+#endif
+
+! check area and volume of the final mesh
+ double precision volume_local,volume_total,volume_total_region
+
+ integer iprocnum
+
+! for loop on all the slices
+ integer iregion_code,iregion
+ integer iproc_xi,iproc_eta,ichunk
+
+! rotation matrix from Euler angles
+ double precision, dimension(NDIM,NDIM) :: rotation_matrix
+
+ double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+! for some statistics for the mesh
+ integer numelem_crust_mantle,numelem_outer_core,numelem_inner_core
+ integer numelem_total
+
+! timer MPI
+ double precision time_start,tCPU
+
+! addressing for all the slices
+ integer, dimension(:), allocatable :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
+ integer, dimension(:,:,:), allocatable :: addressing
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH
+
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
+
+ character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL
+
+! parameters deduced from parameters read from file
+ integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+
+ integer, external :: err_occurred
+
+! this for all the regions
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ nglob
+
+! computed in read_compute_parameters
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+! memory size of all the static arrays
+ double precision :: static_memory_size
+
+! arrays for BCAST
+ integer, dimension(38) :: bcast_integer
+ double precision, dimension(30) :: bcast_double_precision
+ logical, dimension(26) :: bcast_logical
+
+ integer, parameter :: maxker=200
+ integer, parameter :: maxl=72
+ integer, parameter :: maxcoe=2000
+ integer, parameter :: maxver=1000
+ integer, parameter :: maxhpa=2
+
+ integer numker
+ integer numhpa,numcof
+ integer ihpa,lmax,nylm
+ integer lmxhpa(maxhpa)
+ integer itypehpa(maxhpa)
+ integer ihpakern(maxker)
+ integer numcoe(maxhpa)
+ integer ivarkern(maxker)
+ integer itpspl(maxcoe,maxhpa)
+
+ integer nconpt(maxhpa),iver
+ integer iconpt(maxver,maxhpa)
+ real(kind=4) conpt(maxver,maxhpa)
+
+ real(kind=4) xlaspl(maxcoe,maxhpa)
+ real(kind=4) xlospl(maxcoe,maxhpa)
+ real(kind=4) radspl(maxcoe,maxhpa)
+ real(kind=4) coe(maxcoe,maxker)
+ character(len=80) hsplfl(maxhpa)
+ character(len=40) dskker(maxker)
+ real(kind=4) vercof(maxker)
+ real(kind=4) vercofd(maxker)
+
+ real(kind=4) ylmcof((maxl+1)**2,maxhpa)
+ real(kind=4) wk1(maxl+1)
+ real(kind=4) wk2(maxl+1)
+ real(kind=4) wk3(maxl+1)
+
+ character(len=80) kerstr
+ character(len=80) refmdl
+ character(len=40) varstr(maxker)
+
+ integer :: ipass
+
+ 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
+
+! ************** PROGRAM STARTS HERE **************
+
+! initialize the MPI communicator and start the NPROCTOT MPI processes.
+#ifdef USE_MPI
+ 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)
+#else
+ sizeprocs = 1
+ myrank = 0
+#endif
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! open main output file, only written to by process 0
+ if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) &
+ open(unit=IMAIN,file=trim(OUTPUT_FILES)//'/output_mesher.txt',status='unknown')
+
+! get MPI starting time
+#ifdef USE_MPI
+ time_start = MPI_WTIME()
+#else
+ time_start = 0
+#endif
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '****************************'
+ write(IMAIN,*) '*** Specfem3D MPI Mesher ***'
+ write(IMAIN,*) '****************************'
+ write(IMAIN,*)
+ endif
+
+ if (myrank==0) then
+! read the parameter file and compute additional parameters
+ call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.)
+
+ if(err_occurred() /= 0) then
+ call exit_MPI(myrank,'an error occurred while reading the parameter file')
+ endif
+
+! count the total number of sources in the CMTSOLUTION file
+ call count_number_of_sources(NSOURCES)
+
+ bcast_integer = (/MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,&
+ SIMULATION_TYPE,REFERENCE_1D_MODEL,THREE_D_MODEL,NPROC,NPROCTOT, &
+ NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube,&
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP/)
+
+ bcast_logical = (/TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD,CASE_3D,&
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,SAVE_ALL_SEISMOS_IN_ONE_FILE/)
+
+ bcast_double_precision = (/DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH/)
+
+ endif
+
+! broadcast the information read on the master to the nodes
+#ifdef USE_MPI
+ call MPI_BCAST(NSOURCES,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(bcast_integer,38,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(bcast_double_precision,30,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(bcast_logical,25,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(LOCAL_PATH,150,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(MODEL,150,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(ner,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ratio_sampling_array,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(doubling_index,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(r_bottom,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(r_top,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(rmins,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(rmaxs,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(rmaxs,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(this_region_has_a_doubling,MAX_NUMBER_OF_MESH_LAYERS,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(NSPEC,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_XI,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_ETA,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2DMAX_XMIN_XMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2DMAX_YMIN_YMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_BOTTOM,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_TOP,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC1D_RADIAL,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB1D_RADIAL,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB2DMAX_XMIN_XMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB2DMAX_YMIN_YMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(DIFF_NSPEC1D_RADIAL,NB_SQUARE_CORNERS*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(DIFF_NSPEC2D_ETA,NB_SQUARE_EDGES_ONEDIR*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(DIFF_NSPEC2D_XI,NB_SQUARE_EDGES_ONEDIR*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+#endif
+
+ if (myrank /=0) then
+
+ MIN_ATTENUATION_PERIOD = bcast_integer(1)
+ MAX_ATTENUATION_PERIOD = bcast_integer(2)
+ NER_CRUST = bcast_integer(3)
+ NER_80_MOHO = bcast_integer(4)
+ NER_220_80 = bcast_integer(5)
+ NER_400_220 = bcast_integer(6)
+ NER_600_400 = bcast_integer(7)
+ NER_670_600 = bcast_integer(8)
+ NER_771_670 = bcast_integer(9)
+ NER_TOPDDOUBLEPRIME_771 = bcast_integer(10)
+ NER_CMB_TOPDDOUBLEPRIME = bcast_integer(11)
+ NER_OUTER_CORE = bcast_integer(12)
+ NER_TOP_CENTRAL_CUBE_ICB = bcast_integer(13)
+ NEX_XI = bcast_integer(14)
+ NEX_ETA = bcast_integer(15)
+ RMOHO_FICTITIOUS_IN_MESHER = bcast_integer(16)
+ NPROC_XI = bcast_integer(17)
+ NPROC_ETA = bcast_integer(18)
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS = bcast_integer(19)
+ NTSTEP_BETWEEN_READ_ADJSRC = bcast_integer(20)
+ NSTEP = bcast_integer(21)
+ NSOURCES = bcast_integer(22)
+ NTSTEP_BETWEEN_FRAMES = bcast_integer(23)
+ NTSTEP_BETWEEN_OUTPUT_INFO = bcast_integer(24)
+ NUMBER_OF_RUNS = bcast_integer(25)
+ NUMBER_OF_THIS_RUN = bcast_integer(26)
+ NCHUNKS = bcast_integer(27)
+ SIMULATION_TYPE = bcast_integer(28)
+ REFERENCE_1D_MODEL = bcast_integer(29)
+ THREE_D_MODEL = bcast_integer(30)
+ NPROC = bcast_integer(31)
+ NPROCTOT = bcast_integer(32)
+ NEX_PER_PROC_XI = bcast_integer(33)
+ NEX_PER_PROC_ETA = bcast_integer(34)
+ ratio_divide_central_cube = bcast_integer(35)
+ MOVIE_VOLUME_TYPE = bcast_integer(36)
+ MOVIE_START = bcast_integer(37)
+ MOVIE_STOP = bcast_integer(38)
+
+ TRANSVERSE_ISOTROPY = bcast_logical(1)
+ ANISOTROPIC_3D_MANTLE = bcast_logical(2)
+ ANISOTROPIC_INNER_CORE = bcast_logical(3)
+ CRUSTAL = bcast_logical(4)
+ ELLIPTICITY = bcast_logical(5)
+ GRAVITY = bcast_logical(6)
+ ONE_CRUST = bcast_logical(7)
+ ROTATION = bcast_logical(8)
+ ISOTROPIC_3D_MANTLE = bcast_logical(9)
+ TOPOGRAPHY = bcast_logical(10)
+ OCEANS = bcast_logical(11)
+ MOVIE_SURFACE = bcast_logical(12)
+ MOVIE_VOLUME = bcast_logical(13)
+ ATTENUATION_3D = bcast_logical(14)
+ RECEIVERS_CAN_BE_BURIED = bcast_logical(15)
+ PRINT_SOURCE_TIME_FUNCTION = bcast_logical(16)
+ SAVE_MESH_FILES = bcast_logical(17)
+ ATTENUATION = bcast_logical(18)
+ ABSORBING_CONDITIONS = bcast_logical(19)
+ INCLUDE_CENTRAL_CUBE = bcast_logical(20)
+ INFLATE_CENTRAL_CUBE = bcast_logical(21)
+ SAVE_FORWARD = bcast_logical(22)
+ CASE_3D = bcast_logical(23)
+ CUT_SUPERBRICK_XI = bcast_logical(24)
+ CUT_SUPERBRICK_ETA = bcast_logical(25)
+ SAVE_ALL_SEISMOS_IN_ONE_FILE = bcast_logical(26)
+
+ DT = bcast_double_precision(1)
+ ANGULAR_WIDTH_XI_IN_DEGREES = bcast_double_precision(2)
+ ANGULAR_WIDTH_ETA_IN_DEGREES = bcast_double_precision(3)
+ CENTER_LONGITUDE_IN_DEGREES = bcast_double_precision(4)
+ CENTER_LATITUDE_IN_DEGREES = bcast_double_precision(5)
+ GAMMA_ROTATION_AZIMUTH = bcast_double_precision(6)
+ ROCEAN = bcast_double_precision(7)
+ RMIDDLE_CRUST = bcast_double_precision(8)
+ RMOHO = bcast_double_precision(9)
+ R80 = bcast_double_precision(10)
+ R120 = bcast_double_precision(11)
+ R220 = bcast_double_precision(12)
+ R400 = bcast_double_precision(13)
+ R600 = bcast_double_precision(14)
+ R670 = bcast_double_precision(15)
+ R771 = bcast_double_precision(16)
+ RTOPDDOUBLEPRIME = bcast_double_precision(17)
+ RCMB = bcast_double_precision(18)
+ RICB = bcast_double_precision(19)
+ R_CENTRAL_CUBE = bcast_double_precision(20)
+ RHO_TOP_OC = bcast_double_precision(21)
+ RHO_BOTTOM_OC = bcast_double_precision(22)
+ RHO_OCEANS = bcast_double_precision(23)
+ HDUR_MOVIE = bcast_double_precision(24)
+ MOVIE_TOP = bcast_double_precision(25)
+ MOVIE_BOTTOM = bcast_double_precision(26)
+ MOVIE_WEST = bcast_double_precision(27)
+ MOVIE_EAST = bcast_double_precision(28)
+ MOVIE_NORTH = bcast_double_precision(29)
+ MOVIE_SOUTH = bcast_double_precision(30)
+
+ endif
+
+! check that the code is running with the requested number of processes
+#ifdef USE_MPI
+ if(sizeprocs /= NPROCTOT) then
+ print *,'myrank,sizeprocs,NPROCTOT = ',myrank,sizeprocs,NPROCTOT
+ call exit_MPI(myrank,'wrong number of MPI processes')
+ endif
+#endif
+
+! 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))
+
+ 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='../DATABASES_FOR_SOLVER/addressing.txt',status='unknown')
+ write(IMAIN,*) 'creating global slice addressing'
+ write(IMAIN,*)
+ endif
+ do ichunk = 1,NCHUNKS
+ do iproc_eta=0,NPROC_ETA-1
+ do iproc_xi=0,NPROC_XI-1
+ iprocnum = (ichunk-1)*NPROC + iproc_eta * NPROC_XI + iproc_xi
+ addressing(ichunk,iproc_xi,iproc_eta) = iprocnum
+ ichunk_slice(iprocnum) = ichunk
+ iproc_xi_slice(iprocnum) = iproc_xi
+ iproc_eta_slice(iprocnum) = iproc_eta
+ if(myrank == 0) write(IOUT,*) iprocnum
+ if(myrank == 0) write(IOUT,*) iproc_xi
+ if(myrank == 0) write(IOUT,*) iproc_eta
+ enddo
+ enddo
+ enddo
+ if(myrank == 0) close(IOUT)
+
+! this for the different counters (which are now different if the superbrick is cut in the outer core)
+ do iregion=1,MAX_NUM_REGIONS
+ NSPEC1D_RADIAL_CORNER(iregion,:) = NSPEC1D_RADIAL(iregion)
+ NSPEC2D_XI_FACE(iregion,:) = NSPEC2D_XI(iregion)
+ NSPEC2D_ETA_FACE(iregion,:) = NSPEC2D_ETA(iregion)
+ NGLOB1D_RADIAL_CORNER(iregion,:) = NGLOB1D_RADIAL(iregion)
+ enddo
+
+ if (CUT_SUPERBRICK_XI) then
+ if (CUT_SUPERBRICK_ETA) then
+ if (mod(iproc_xi_slice(myrank),2) == 0) then
+ if (mod(iproc_eta_slice(myrank),2) == 0) then
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ else
+ if (mod(iproc_eta_slice(myrank),2) == 0) then
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,3)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,3)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,3)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,3)*(NGLLZ-1))
+ else
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,4)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,4)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,4)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,4)*(NGLLZ-1))
+ endif
+ endif
+ else
+ if (mod(iproc_xi_slice(myrank),2) == 0) then
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ endif
+ else
+ if (CUT_SUPERBRICK_ETA) then
+ if (mod(iproc_eta_slice(myrank),2) == 0) then
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ endif
+ endif
+
+ if(myrank == 0) then
+ write(IMAIN,*) 'This is process ',myrank
+ write(IMAIN,*) 'There are ',sizeprocs,' MPI processes'
+ write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',NEX_XI,' elements along xi in each chunk'
+ write(IMAIN,*) 'There are ',NEX_ETA,' elements along eta in each chunk'
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',NPROC_XI,' slices along xi in each chunk'
+ write(IMAIN,*) 'There are ',NPROC_ETA,' slices along eta in each chunk'
+ write(IMAIN,*) 'There is a total of ',NPROC,' slices in each chunk'
+ write(IMAIN,*) 'There are ',NCHUNKS,' chunks in the global mesh'
+ write(IMAIN,*) 'There is a total of ',NPROCTOT,' slices in the global mesh'
+ write(IMAIN,*)
+ write(IMAIN,*) 'NGLLX = ',NGLLX
+ write(IMAIN,*) 'NGLLY = ',NGLLY
+ write(IMAIN,*) 'NGLLZ = ',NGLLZ
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'Shape functions defined by NGNOD = ',NGNOD,' control nodes'
+ write(IMAIN,*) 'Surface shape functions defined by NGNOD2D = ',NGNOD2D,' control nodes'
+ write(IMAIN,*)
+ write(IMAIN,*)
+ endif
+
+ if(myrank == 0) then
+
+ write(IMAIN,*)
+ if(ELLIPTICITY) then
+ write(IMAIN,*) 'incorporating ellipticity'
+ else
+ write(IMAIN,*) 'no ellipticity'
+ endif
+
+ write(IMAIN,*)
+ if(TOPOGRAPHY) then
+ write(IMAIN,*) 'incorporating surface topography'
+ else
+ write(IMAIN,*) 'no surface topography'
+ endif
+
+ write(IMAIN,*)
+ if(ISOTROPIC_3D_MANTLE) then
+ write(IMAIN,*) 'incorporating 3-D lateral variations'
+ else
+ write(IMAIN,*) 'no 3-D lateral variations'
+ endif
+
+ write(IMAIN,*)
+ if(CRUSTAL) then
+ write(IMAIN,*) 'incorporating crustal variations'
+ else
+ write(IMAIN,*) 'no crustal variations'
+ endif
+
+ write(IMAIN,*)
+ if(ONE_CRUST) then
+ write(IMAIN,*) 'using one layer only in PREM crust'
+ else
+ write(IMAIN,*) 'using unmodified 1D crustal model with two layers'
+ endif
+
+ write(IMAIN,*)
+ if(GRAVITY) then
+ write(IMAIN,*) 'incorporating self-gravitation (Cowling approximation)'
+ else
+ write(IMAIN,*) 'no self-gravitation'
+ endif
+
+ write(IMAIN,*)
+ if(ROTATION) then
+ write(IMAIN,*) 'incorporating rotation'
+ else
+ write(IMAIN,*) 'no rotation'
+ endif
+
+ write(IMAIN,*)
+ if(TRANSVERSE_ISOTROPY) then
+ write(IMAIN,*) 'incorporating anisotropy'
+ else
+ write(IMAIN,*) 'no anisotropy'
+ endif
+
+ write(IMAIN,*)
+ if(ATTENUATION) then
+ write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids'
+ if(ATTENUATION_3D) write(IMAIN,*)'using 3D attenuation'
+ else
+ write(IMAIN,*) 'no attenuation'
+ endif
+
+ write(IMAIN,*)
+ if(OCEANS) then
+ write(IMAIN,*) 'incorporating the oceans using equivalent load'
+ else
+ write(IMAIN,*) 'no oceans'
+ endif
+
+ write(IMAIN,*)
+
+ endif
+ if(ELLIPTICITY) call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
+
+ if(ISOTROPIC_3D_MANTLE) then
+ if(THREE_D_MODEL /= 0) call read_smooth_moho
+ if(THREE_D_MODEL == THREE_D_MODEL_S20RTS) then
+! the variables read are declared and stored in structure D3MM_V
+ if(myrank == 0) call read_mantle_model(D3MM_V)
+! broadcast the information read on the master to the nodes
+#ifdef USE_MPI
+ call MPI_BCAST(D3MM_V%dvs_a,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%dvs_b,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%dvp_a,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%dvp_b,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%spknt,NK+1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%qq0,(NK+1)*(NK+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%qq,3*(NK+1)*(NK+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+#endif
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then
+! the variables read are declared and stored in structure SEA99M_V and JP3DM_V
+ if(myrank == 0) then
+ call read_sea99_s_model(SEA99M_V)
+ call read_iso3d_dpzhao_model(JP3DM_V)
+ endif
+! broadcast the information read on the master to the nodes
+! SEA99M_V
+#ifdef USE_MPI
+ call MPI_BCAST(SEA99M_V%sea99_ndep,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_nlat,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_nlon,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_ddeg,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alatmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alatmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alonmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alonmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_vs,100*100*100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_depth,100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+! JP3DM_V
+ call MPI_BCAST(JP3DM_V%NPA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NRA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NHA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NPB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NRB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NHB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PNA,MPA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RNA,MRA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HNA,MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PNB,MPB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RNB,MRB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HNB,MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VELAP,MPA*MRA*MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VELBP,MPB*MRB*MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PN,51,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RRN,63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPA,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPB,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPC,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IPLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IRLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IHLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IPLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IRLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IHLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%JP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%KP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%JP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%KP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%WV,8,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%P,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%R,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%H,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VP,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VS,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RA,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPJ,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+#endif
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99) then
+! the variables read are declared and stored in structure SEA99M_V
+ if(myrank == 0) call read_sea99_s_model(SEA99M_V)
+! broadcast the information read on the master to the nodes
+! SEA99M_V
+#ifdef USE_MPI
+ call MPI_BCAST(SEA99M_V%sea99_ndep,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_nlat,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_nlon,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_ddeg,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alatmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alatmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alonmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alonmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_vs,100*100*100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_depth,100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+#endif
+ elseif(THREE_D_MODEL == THREE_D_MODEL_JP3D) then
+! the variables read are declared and stored in structure JP3DM_V
+ if(myrank == 0) call read_iso3d_dpzhao_model(JP3DM_V)
+! JP3DM_V
+#ifdef USE_MPI
+ call MPI_BCAST(JP3DM_V%NPA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NRA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NHA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NPB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NRB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NHB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PNA,MPA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RNA,MRA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HNA,MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PNB,MPB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RNB,MRB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HNB,MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VELAP,MPA*MRA*MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VELBP,MPB*MRB*MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PN,51,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RRN,63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPA,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPB,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPC,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IPLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IRLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IHLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IPLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IRLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IHLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%JP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%KP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%JP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%KP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%WV,8,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%P,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%R,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%H,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VP,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VS,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RA,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPJ,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+#endif
+ elseif(THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI &
+ .or. THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM .or. THREE_D_MODEL == THREE_D_MODEL_S29EA) then
+ if(myrank == 0) call read_model_s362ani(THREE_D_MODEL,THREE_D_MODEL_S362ANI,THREE_D_MODEL_S362WMANI, &
+ THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA, &
+ numker,numhpa,ihpa,lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,itpspl, &
+ xlaspl,xlospl,radspl,coe,hsplfl,dskker,kerstr,varstr,refmdl)
+#ifdef USE_MPI
+ call MPI_BCAST(numker,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(numhpa,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ihpa,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(lmxhpa,maxhpa,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(itypehpa,maxhpa,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ihpakern,maxker,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(numcoe,maxhpa,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ivarkern,maxker,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(itpspl,maxcoe*maxhpa,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(xlaspl,maxcoe*maxhpa,MPI_REAL,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(xlospl,maxcoe*maxhpa,MPI_REAL,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(radspl,maxcoe*maxhpa,MPI_REAL,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(coe,maxcoe*maxker,MPI_REAL,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(hsplfl,80*maxhpa,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(dskker,40*maxker,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(kerstr,80,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(refmdl,80,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(varstr,40*maxker,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+#endif
+
+ else
+ call exit_MPI(myrank,'3D model not defined')
+ endif
+ endif
+
+ if(ANISOTROPIC_3D_MANTLE) then
+! the variables read are declared and stored in structure AMM_V
+ if(myrank == 0) call read_aniso_mantle_model(AMM_V)
+! broadcast the information read on the master to the nodes
+#ifdef USE_MPI
+ call MPI_BCAST(AMM_V%npar1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(AMM_V%beta,14*34*37*73,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(AMM_V%pro,47,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+#endif
+ endif
+
+ if(CRUSTAL) then
+! the variables read are declared and stored in structure CM_V
+ if(myrank == 0) call read_crustal_model(CM_V)
+! broadcast the information read on the master to the nodes
+#ifdef USE_MPI
+ call MPI_BCAST(CM_V%thlr,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(CM_V%velocp,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(CM_V%velocs,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(CM_V%dens,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(CM_V%abbreviation,NCAP_CRUST*NCAP_CRUST,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(CM_V%code,2*NKEYS_CRUST,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+#endif
+ endif
+
+ if(ANISOTROPIC_INNER_CORE) then
+ if(myrank == 0) call read_aniso_inner_core_model
+! one should add an MPI_BCAST here if one adds a read_aniso_inner_core_model subroutine
+ endif
+
+ if(ATTENUATION .and. ATTENUATION_3D) then
+!! DK DK removed attenuation for MPI + GPU version
+!! DK DK 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))
+#ifdef USE_MPI
+ call MPI_BCAST(AM_V%min_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%max_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%QT_c_source, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%Qtau_s(1), 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%Qtau_s(2), 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%Qtau_s(3), 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+#endif
+ endif
+
+ if(ATTENUATION .and. .not. ATTENUATION_3D) then
+
+!! DK DK removed attenuation for MPI + GPU version
+!! DK DK if(myrank == 0) call read_attenuation_model(MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD, AM_V)
+
+#ifdef USE_MPI
+ call MPI_BCAST(AM_V%min_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%max_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+#endif
+
+!! DK DK removed attenuation for MPI + GPU version
+!! DK DK call attenuation_model_setup(REFERENCE_1D_MODEL, RICB, RCMB, R670, &
+!! DK DK R220, R80,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,AM_S,AS_V)
+ endif
+
+! read topography and bathymetry file
+ if(TOPOGRAPHY .or. OCEANS) then
+ if(myrank == 0) call read_topo_bathy_file(ibathy_topo)
+! broadcast the information read on the master to the nodes
+#ifdef USE_MPI
+ call MPI_BCAST(ibathy_topo,NX_BATHY*NY_BATHY,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+#endif
+ endif
+
+! get addressing for this process
+ ichunk = ichunk_slice(myrank)
+ iproc_xi = iproc_xi_slice(myrank)
+ iproc_eta = iproc_eta_slice(myrank)
+
+ if(myrank == 0) then
+ write(IMAIN,*) 'Reference radius of the Earth used is ',R_EARTH_KM,' km'
+ write(IMAIN,*)
+ write(IMAIN,*) 'Central cube is at a radius of ',R_CENTRAL_CUBE/1000.d0,' km'
+ endif
+
+! compute rotation matrix from Euler angles
+ ANGULAR_WIDTH_XI_RAD = ANGULAR_WIDTH_XI_IN_DEGREES * PI / 180.d0
+ ANGULAR_WIDTH_ETA_RAD = ANGULAR_WIDTH_ETA_IN_DEGREES * PI / 180.d0
+ if(NCHUNKS /= 6) call euler_angles(rotation_matrix,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH)
+
+! volume of the slice
+ volume_total = ZERO
+
+! make sure everybody is synchronized
+#ifdef USE_MPI
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+#endif
+
+!----
+!---- loop on all the regions of the mesh
+!----
+
+! number of regions in full Earth
+! do iregion_code = 1,MAX_NUM_REGIONS
+!! DK DK use only the crust_mantle region for the GPU + MPI code
+ do iregion_code = 1,1
+
+ 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)))
+ 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, &
+ xstore,ystore,zstore,rmins,rmaxs, &
+ iproc_xi,iproc_eta,ichunk,NSPEC(iregion_code),nspec_aniso, &
+ volume_local,nspl,rspl,espl,espl2, &
+ nglob(iregion_code),npointot, &
+ NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC2DMAX_XMIN_XMAX(iregion_code), &
+ NSPEC2DMAX_YMIN_YMAX(iregion_code),NSPEC2D_BOTTOM(iregion_code),NSPEC2D_TOP(iregion_code), &
+ ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE, &
+!!! DK DK only one chunk in the current MPI+GPU version
+!!! NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
+ NSPEC2D_ETA_FACE, &
+ max(NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code)), &
+ myrank,LOCAL_PATH,OCEANS,ibathy_topo, &
+ rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD, &
+ ATTENUATION,ATTENUATION_3D,SAVE_MESH_FILES, &
+ NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ ner,ratio_sampling_array,doubling_index,r_bottom, r_top,this_region_has_a_doubling,CASE_3D, &
+ AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ipass,ratio_divide_central_cube, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,mod(iproc_xi_slice(myrank),2),mod(iproc_eta_slice(myrank),2),NSTEP,DT,NPROCTOT,is_on_a_slice_edge)
+ 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')
+
+! use MPI reduction to compute total area and volume
+ volume_total_region = ZERO
+#ifdef USE_MPI
+ call MPI_REDUCE(volume_local,volume_total_region,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
+ MPI_COMM_WORLD,ier)
+#else
+ volume_total_region = volume_local
+#endif
+
+! sum volume over all the regions
+ if(myrank == 0) volume_total = volume_total + volume_total_region
+
+! deallocate arrays used for that region
+ deallocate(idoubling)
+ deallocate(ibool)
+ deallocate(xstore)
+ deallocate(ystore)
+ deallocate(zstore)
+ deallocate(is_on_a_slice_edge)
+
+! make sure everybody is synchronized
+#ifdef USE_MPI
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+#endif
+
+! end of loop on all the regions
+ enddo
+
+ if(myrank == 0) then
+! check volume of chunk
+ write(IMAIN,*)
+ write(IMAIN,*) 'calculated volume: ',volume_total
+ if(.not. TOPOGRAPHY) then
+! take the central cube into account
+! it is counted 6 times because of the fictitious elements
+! if(INCLUDE_CENTRAL_CUBE) then
+! write(IMAIN,*) ' exact volume: ', &
+! dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)+5.*(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0
+! else
+! write(IMAIN,*) ' exact volume: ', &
+! dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)-(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0
+! endif
+!! DK DK for the MPI+GPU version we use the first region only (crust_mantle)
+!! DK DK and the real physical size of the Earth, not a unit sphere of radius one
+ write(IMAIN,*) ' exact volume: ', &
+ dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_EARTH**3) - (4.0d0/3.0d0)*PI*(RCMB**3))/6.d0
+ 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 ../DATABASES_FOR_SOLVER/values_from_mesher*.h'
+ write(IMAIN,*)
+
+! load balancing
+ write(IMAIN,*) 'Load balancing = 100 % by definition'
+ write(IMAIN,*)
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'the time step in the solver will be: ',DT
+ write(IMAIN,*) 'total number of time steps in the solver will be: ',NSTEP
+ 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,ATTENUATION,ATTENUATION_3D, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,NCHUNKS, &
+ INCLUDE_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,NSOURCES,NSTEP, &
+ static_memory_size,NGLOB1D_RADIAL_TEMP, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NSPEC2D_TOP,NSPEC2D_BOTTOM, &
+ NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX, &
+ NPROC_XI,NPROC_ETA, &
+ NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION)
+
+ endif ! end of section executed by main process only
+
+! deallocate arrays used for mesh generation
+ deallocate(addressing)
+ deallocate(ichunk_slice)
+ deallocate(iproc_xi_slice)
+ deallocate(iproc_eta_slice)
+
+! elapsed time since beginning of mesh generation
+ if(myrank == 0) then
+#ifdef USE_MPI
+ tCPU = MPI_WTIME() - time_start
+#else
+ tCPU = 0
+#endif
+ 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
+#ifdef USE_MPI
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+! stop all the MPI processes, and exit
+ call MPI_FINALIZE(ier)
+#endif
+
+ end program xmeshfem3D
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_1066a.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_1066a.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_1066a.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,1131 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+
+ subroutine model_1066a(x,rho,vp,vs,Qkappa,Qmu,iregion_code,M1066a_V)
+
+ implicit none
+
+ include "constants.h"
+
+! model_1066a_variables
+ type model_1066a_variables
+ sequence
+ double precision, dimension(NR_1066A) :: radius_1066a
+ double precision, dimension(NR_1066A) :: density_1066a
+ double precision, dimension(NR_1066A) :: vp_1066a
+ double precision, dimension(NR_1066A) :: vs_1066a
+ double precision, dimension(NR_1066A) :: Qkappa_1066a
+ double precision, dimension(NR_1066A) :: Qmu_1066a
+ end type model_1066a_variables
+
+ type (model_1066a_variables) M1066a_V
+! model_1066a_variables
+
+! input:
+! radius r: meters
+
+! output:
+! density rho: kg/m^3
+! compressional wave speed vp: km/s
+! shear wave speed vs: km/s
+
+ integer iregion_code
+
+ double precision x,rho,vp,vs,Qmu,Qkappa
+
+ integer i
+
+ double precision r,frac,scaleval
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+ i = 1
+ do while(r >= M1066a_V%radius_1066a(i) .and. i /= NR_1066A)
+ i = i + 1
+ enddo
+
+! make sure we stay in the right region and never take a point above
+! and a point below the ICB or the CMB and interpolate between them,
+! which would lead to a wrong value (keeping in mind that we interpolate
+! between points i-1 and i below)
+ if(iregion_code == IREGION_INNER_CORE .and. i > 33) i = 33
+
+ if(iregion_code == IREGION_OUTER_CORE .and. i < 35) i = 35
+ if(iregion_code == IREGION_OUTER_CORE .and. i > 66) i = 66
+
+ if(iregion_code == IREGION_CRUST_MANTLE .and. i < 68) i = 68
+
+ if(i == 1) then
+ rho = M1066a_V%density_1066a(i)
+ vp = M1066a_V%vp_1066a(i)
+ vs = M1066a_V%vs_1066a(i)
+ Qmu = M1066a_V%Qmu_1066a(i)
+ Qkappa = M1066a_V%Qkappa_1066a(i)
+ else
+
+! interpolate from radius_1066a(i-1) to r using the values at i-1 and i
+ frac = (r-M1066a_V%radius_1066a(i-1))/(M1066a_V%radius_1066a(i)-M1066a_V%radius_1066a(i-1))
+
+ rho = M1066a_V%density_1066a(i-1) + frac * (M1066a_V%density_1066a(i)-M1066a_V%density_1066a(i-1))
+ vp = M1066a_V%vp_1066a(i-1) + frac * (M1066a_V%vp_1066a(i)-M1066a_V%vp_1066a(i-1))
+ vs = M1066a_V%vs_1066a(i-1) + frac * (M1066a_V%vs_1066a(i)-M1066a_V%vs_1066a(i-1))
+ Qmu = M1066a_V%Qmu_1066a(i-1) + frac * (M1066a_V%Qmu_1066a(i)-M1066a_V%Qmu_1066a(i-1))
+ Qkappa = M1066a_V%Qkappa_1066a(i-1) + frac * (M1066a_V%Qkappa_1066a(i)-M1066a_V%Qkappa_1066a(i-1))
+
+ endif
+
+! make sure Vs is zero in the outer core even if roundoff errors on depth
+! also set fictitious attenuation to a very high value (attenuation is not used in the fluid)
+ if(iregion_code == IREGION_OUTER_CORE) then
+ vs = 0.d0
+ Qkappa = 3000.d0
+ Qmu = 3000.d0
+ endif
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ rho=rho*1000.0d0/RHOAV
+ vp=vp*1000.0d0/(R_EARTH*scaleval)
+ vs=vs*1000.0d0/(R_EARTH*scaleval)
+
+ end subroutine model_1066a
+
+!-------------------
+
+ subroutine define_model_1066a(USE_EXTERNAL_CRUSTAL_MODEL,M1066a_V)
+
+ implicit none
+ include "constants.h"
+
+! model_1066a_variables
+ type model_1066a_variables
+ sequence
+ double precision, dimension(NR_1066A) :: radius_1066a
+ double precision, dimension(NR_1066A) :: density_1066a
+ double precision, dimension(NR_1066A) :: vp_1066a
+ double precision, dimension(NR_1066A) :: vs_1066a
+ double precision, dimension(NR_1066A) :: Qkappa_1066a
+ double precision, dimension(NR_1066A) :: Qmu_1066a
+ end type model_1066a_variables
+
+ type (model_1066a_variables) M1066a_V
+! model_1066a_variables
+
+ logical USE_EXTERNAL_CRUSTAL_MODEL
+
+ integer i
+
+! define all the values in the model
+
+ M1066a_V%radius_1066a( 1) = 0.000000000000000
+ M1066a_V%radius_1066a( 2) = 38400.0000000000
+ M1066a_V%radius_1066a( 3) = 76810.0000000000
+ M1066a_V%radius_1066a( 4) = 115210.000000000
+ M1066a_V%radius_1066a( 5) = 153610.000000000
+ M1066a_V%radius_1066a( 6) = 192020.000000000
+ M1066a_V%radius_1066a( 7) = 230420.000000000
+ M1066a_V%radius_1066a( 8) = 268820.000000000
+ M1066a_V%radius_1066a( 9) = 307220.000000000
+ M1066a_V%radius_1066a( 10) = 345630.000000000
+ M1066a_V%radius_1066a( 11) = 384030.000000000
+ M1066a_V%radius_1066a( 12) = 422430.000000000
+ M1066a_V%radius_1066a( 13) = 460840.000000000
+ M1066a_V%radius_1066a( 14) = 499240.000000000
+ M1066a_V%radius_1066a( 15) = 537640.000000000
+ M1066a_V%radius_1066a( 16) = 576050.000000000
+ M1066a_V%radius_1066a( 17) = 614450.000000000
+ M1066a_V%radius_1066a( 18) = 652850.000000000
+ M1066a_V%radius_1066a( 19) = 691260.000000000
+ M1066a_V%radius_1066a( 20) = 729660.000000000
+ M1066a_V%radius_1066a( 21) = 768060.000000000
+ M1066a_V%radius_1066a( 22) = 806460.000000000
+ M1066a_V%radius_1066a( 23) = 844870.000000000
+ M1066a_V%radius_1066a( 24) = 883270.000000000
+ M1066a_V%radius_1066a( 25) = 921670.000000000
+ M1066a_V%radius_1066a( 26) = 960080.000000000
+ M1066a_V%radius_1066a( 27) = 998480.000000000
+ M1066a_V%radius_1066a( 28) = 1036880.00000000
+ M1066a_V%radius_1066a( 29) = 1075290.00000000
+ M1066a_V%radius_1066a( 30) = 1113690.00000000
+ M1066a_V%radius_1066a( 31) = 1152090.00000000
+ M1066a_V%radius_1066a( 32) = 1190500.00000000
+ M1066a_V%radius_1066a( 33) = 1229480.00000000
+ M1066a_V%radius_1066a( 34) = 1229480.00000000
+ M1066a_V%radius_1066a( 35) = 1299360.00000000
+ M1066a_V%radius_1066a( 36) = 1369820.00000000
+ M1066a_V%radius_1066a( 37) = 1440280.00000000
+ M1066a_V%radius_1066a( 38) = 1510740.00000000
+ M1066a_V%radius_1066a( 39) = 1581190.00000000
+ M1066a_V%radius_1066a( 40) = 1651650.00000000
+ M1066a_V%radius_1066a( 41) = 1722110.00000000
+ M1066a_V%radius_1066a( 42) = 1792570.00000000
+ M1066a_V%radius_1066a( 43) = 1863030.00000000
+ M1066a_V%radius_1066a( 44) = 1933490.00000000
+ M1066a_V%radius_1066a( 45) = 2003950.00000000
+ M1066a_V%radius_1066a( 46) = 2074410.00000000
+ M1066a_V%radius_1066a( 47) = 2144870.00000000
+ M1066a_V%radius_1066a( 48) = 2215330.00000000
+ M1066a_V%radius_1066a( 49) = 2285790.00000000
+ M1066a_V%radius_1066a( 50) = 2356240.00000000
+ M1066a_V%radius_1066a( 51) = 2426700.00000000
+ M1066a_V%radius_1066a( 52) = 2497160.00000000
+ M1066a_V%radius_1066a( 53) = 2567620.00000000
+ M1066a_V%radius_1066a( 54) = 2638080.00000000
+ M1066a_V%radius_1066a( 55) = 2708540.00000000
+ M1066a_V%radius_1066a( 56) = 2779000.00000000
+ M1066a_V%radius_1066a( 57) = 2849460.00000000
+ M1066a_V%radius_1066a( 58) = 2919920.00000000
+ M1066a_V%radius_1066a( 59) = 2990380.00000000
+ M1066a_V%radius_1066a( 60) = 3060840.00000000
+ M1066a_V%radius_1066a( 61) = 3131300.00000000
+ M1066a_V%radius_1066a( 62) = 3201750.00000000
+ M1066a_V%radius_1066a( 63) = 3272210.00000000
+ M1066a_V%radius_1066a( 64) = 3342670.00000000
+ M1066a_V%radius_1066a( 65) = 3413130.00000000
+ M1066a_V%radius_1066a( 66) = 3484300.00000000
+ M1066a_V%radius_1066a( 67) = 3484300.00000000
+ M1066a_V%radius_1066a( 68) = 3518220.00000000
+ M1066a_V%radius_1066a( 69) = 3552850.00000000
+ M1066a_V%radius_1066a( 70) = 3587490.00000000
+ M1066a_V%radius_1066a( 71) = 3622120.00000000
+ M1066a_V%radius_1066a( 72) = 3656750.00000000
+ M1066a_V%radius_1066a( 73) = 3691380.00000000
+ M1066a_V%radius_1066a( 74) = 3726010.00000000
+ M1066a_V%radius_1066a( 75) = 3760640.00000000
+ M1066a_V%radius_1066a( 76) = 3795270.00000000
+ M1066a_V%radius_1066a( 77) = 3829910.00000000
+ M1066a_V%radius_1066a( 78) = 3864540.00000000
+ M1066a_V%radius_1066a( 79) = 3899170.00000000
+ M1066a_V%radius_1066a( 80) = 3933800.00000000
+ M1066a_V%radius_1066a( 81) = 3968430.00000000
+ M1066a_V%radius_1066a( 82) = 4003060.00000000
+ M1066a_V%radius_1066a( 83) = 4037690.00000000
+ M1066a_V%radius_1066a( 84) = 4072330.00000000
+ M1066a_V%radius_1066a( 85) = 4106960.00000000
+ M1066a_V%radius_1066a( 86) = 4141590.00000000
+ M1066a_V%radius_1066a( 87) = 4176220.00000000
+ M1066a_V%radius_1066a( 88) = 4210850.00000000
+ M1066a_V%radius_1066a( 89) = 4245480.00000000
+ M1066a_V%radius_1066a( 90) = 4280110.00000000
+ M1066a_V%radius_1066a( 91) = 4314740.00000000
+ M1066a_V%radius_1066a( 92) = 4349380.00000000
+ M1066a_V%radius_1066a( 93) = 4384010.00000000
+ M1066a_V%radius_1066a( 94) = 4418640.00000000
+ M1066a_V%radius_1066a( 95) = 4453270.00000000
+ M1066a_V%radius_1066a( 96) = 4487900.00000000
+ M1066a_V%radius_1066a( 97) = 4522530.00000000
+ M1066a_V%radius_1066a( 98) = 4557160.00000000
+ M1066a_V%radius_1066a( 99) = 4591800.00000000
+ M1066a_V%radius_1066a(100) = 4626430.00000000
+ M1066a_V%radius_1066a(101) = 4661060.00000000
+ M1066a_V%radius_1066a(102) = 4695690.00000000
+ M1066a_V%radius_1066a(103) = 4730320.00000000
+ M1066a_V%radius_1066a(104) = 4764950.00000000
+ M1066a_V%radius_1066a(105) = 4799580.00000000
+ M1066a_V%radius_1066a(106) = 4834220.00000000
+ M1066a_V%radius_1066a(107) = 4868850.00000000
+ M1066a_V%radius_1066a(108) = 4903480.00000000
+ M1066a_V%radius_1066a(109) = 4938110.00000000
+ M1066a_V%radius_1066a(110) = 4972740.00000000
+ M1066a_V%radius_1066a(111) = 5007370.00000000
+ M1066a_V%radius_1066a(112) = 5042000.00000000
+ M1066a_V%radius_1066a(113) = 5076640.00000000
+ M1066a_V%radius_1066a(114) = 5111270.00000000
+ M1066a_V%radius_1066a(115) = 5145900.00000000
+ M1066a_V%radius_1066a(116) = 5180530.00000000
+ M1066a_V%radius_1066a(117) = 5215160.00000000
+ M1066a_V%radius_1066a(118) = 5249790.00000000
+ M1066a_V%radius_1066a(119) = 5284420.00000000
+ M1066a_V%radius_1066a(120) = 5319060.00000000
+ M1066a_V%radius_1066a(121) = 5353690.00000000
+ M1066a_V%radius_1066a(122) = 5388320.00000000
+ M1066a_V%radius_1066a(123) = 5422950.00000000
+ M1066a_V%radius_1066a(124) = 5457580.00000000
+ M1066a_V%radius_1066a(125) = 5492210.00000000
+ M1066a_V%radius_1066a(126) = 5526840.00000000
+ M1066a_V%radius_1066a(127) = 5561470.00000000
+ M1066a_V%radius_1066a(128) = 5596110.00000000
+ M1066a_V%radius_1066a(129) = 5630740.00000000
+ M1066a_V%radius_1066a(130) = 5665370.00000000
+ M1066a_V%radius_1066a(131) = 5700000.00000000
+ M1066a_V%radius_1066a(132) = 5700000.00000000
+ M1066a_V%radius_1066a(133) = 5731250.00000000
+ M1066a_V%radius_1066a(134) = 5762500.00000000
+ M1066a_V%radius_1066a(135) = 5793750.00000000
+ M1066a_V%radius_1066a(136) = 5825000.00000000
+ M1066a_V%radius_1066a(137) = 5856250.00000000
+ M1066a_V%radius_1066a(138) = 5887500.00000000
+ M1066a_V%radius_1066a(139) = 5918750.00000000
+ M1066a_V%radius_1066a(140) = 5950000.00000000
+ M1066a_V%radius_1066a(141) = 5950000.00000000
+ M1066a_V%radius_1066a(142) = 5975630.00000000
+ M1066a_V%radius_1066a(143) = 6001250.00000000
+ M1066a_V%radius_1066a(144) = 6026880.00000000
+ M1066a_V%radius_1066a(145) = 6052500.00000000
+ M1066a_V%radius_1066a(146) = 6078130.00000000
+ M1066a_V%radius_1066a(147) = 6103750.00000000
+ M1066a_V%radius_1066a(148) = 6129380.00000000
+ M1066a_V%radius_1066a(149) = 6155000.00000000
+ M1066a_V%radius_1066a(150) = 6180630.00000000
+ M1066a_V%radius_1066a(151) = 6206250.00000000
+ M1066a_V%radius_1066a(152) = 6231880.00000000
+ M1066a_V%radius_1066a(153) = 6257500.00000000
+ M1066a_V%radius_1066a(154) = 6283130.00000000
+ M1066a_V%radius_1066a(155) = 6308750.00000000
+ M1066a_V%radius_1066a(156) = 6334380.00000000
+ M1066a_V%radius_1066a(157) = 6360000.00000000
+ M1066a_V%radius_1066a(158) = 6360000.00000000
+ M1066a_V%radius_1066a(159) = 6365500.00000000
+ M1066a_V%radius_1066a(160) = 6371000.00000000
+
+ M1066a_V%density_1066a( 1) = 13.4290300000000
+ M1066a_V%density_1066a( 2) = 13.4256300000000
+ M1066a_V%density_1066a( 3) = 13.4191300000000
+ M1066a_V%density_1066a( 4) = 13.4135300000000
+ M1066a_V%density_1066a( 5) = 13.4072300000000
+ M1066a_V%density_1066a( 6) = 13.4003200000000
+ M1066a_V%density_1066a( 7) = 13.3929200000000
+ M1066a_V%density_1066a( 8) = 13.3847100000000
+ M1066a_V%density_1066a( 9) = 13.3754000000000
+ M1066a_V%density_1066a( 10) = 13.3649000000000
+ M1066a_V%density_1066a( 11) = 13.3527900000000
+ M1066a_V%density_1066a( 12) = 13.3389800000000
+ M1066a_V%density_1066a( 13) = 13.3238700000000
+ M1066a_V%density_1066a( 14) = 13.3078500000000
+ M1066a_V%density_1066a( 15) = 13.2914400000000
+ M1066a_V%density_1066a( 16) = 13.2750300000000
+ M1066a_V%density_1066a( 17) = 13.2589100000000
+ M1066a_V%density_1066a( 18) = 13.2431000000000
+ M1066a_V%density_1066a( 19) = 13.2275800000000
+ M1066a_V%density_1066a( 20) = 13.2123600000000
+ M1066a_V%density_1066a( 21) = 13.1972500000000
+ M1066a_V%density_1066a( 22) = 13.1823300000000
+ M1066a_V%density_1066a( 23) = 13.1675100000000
+ M1066a_V%density_1066a( 24) = 13.1527800000000
+ M1066a_V%density_1066a( 25) = 13.1382600000000
+ M1066a_V%density_1066a( 26) = 13.1239400000000
+ M1066a_V%density_1066a( 27) = 13.1095200000000
+ M1066a_V%density_1066a( 28) = 13.0953900000000
+ M1066a_V%density_1066a( 29) = 13.0811600000000
+ M1066a_V%density_1066a( 30) = 13.0670400000000
+ M1066a_V%density_1066a( 31) = 13.0525100000000
+ M1066a_V%density_1066a( 32) = 13.0385800000000
+ M1066a_V%density_1066a( 33) = 13.0287500000000
+ M1066a_V%density_1066a( 34) = 12.1606500000000
+ M1066a_V%density_1066a( 35) = 12.1169900000000
+ M1066a_V%density_1066a( 36) = 12.0748300000000
+ M1066a_V%density_1066a( 37) = 12.0330700000000
+ M1066a_V%density_1066a( 38) = 11.9916000000000
+ M1066a_V%density_1066a( 39) = 11.9507300000000
+ M1066a_V%density_1066a( 40) = 11.9104600000000
+ M1066a_V%density_1066a( 41) = 11.8693800000000
+ M1066a_V%density_1066a( 42) = 11.8248100000000
+ M1066a_V%density_1066a( 43) = 11.7753200000000
+ M1066a_V%density_1066a( 44) = 11.7220400000000
+ M1066a_V%density_1066a( 45) = 11.6665500000000
+ M1066a_V%density_1066a( 46) = 11.6085600000000
+ M1066a_V%density_1066a( 47) = 11.5469600000000
+ M1066a_V%density_1066a( 48) = 11.4809600000000
+ M1066a_V%density_1066a( 49) = 11.4116600000000
+ M1066a_V%density_1066a( 50) = 11.3411600000000
+ M1066a_V%density_1066a( 51) = 11.2705500000000
+ M1066a_V%density_1066a( 52) = 11.1982400000000
+ M1066a_V%density_1066a( 53) = 11.1214200000000
+ M1066a_V%density_1066a( 54) = 11.0384100000000
+ M1066a_V%density_1066a( 55) = 10.9511900000000
+ M1066a_V%density_1066a( 56) = 10.8631600000000
+ M1066a_V%density_1066a( 57) = 10.7770300000000
+ M1066a_V%density_1066a( 58) = 10.6925000000000
+ M1066a_V%density_1066a( 59) = 10.6076700000000
+ M1066a_V%density_1066a( 60) = 10.5207300000000
+ M1066a_V%density_1066a( 61) = 10.4312000000000
+ M1066a_V%density_1066a( 62) = 10.3377500000000
+ M1066a_V%density_1066a( 63) = 10.2396100000000
+ M1066a_V%density_1066a( 64) = 10.1378600000000
+ M1066a_V%density_1066a( 65) = 10.0323000000000
+ M1066a_V%density_1066a( 66) = 9.91745000000000
+ M1066a_V%density_1066a( 67) = 5.53205000000000
+ M1066a_V%density_1066a( 68) = 5.52147000000000
+ M1066a_V%density_1066a( 69) = 5.50959000000000
+ M1066a_V%density_1066a( 70) = 5.49821000000000
+ M1066a_V%density_1066a( 71) = 5.48673000000000
+ M1066a_V%density_1066a( 72) = 5.47495000000000
+ M1066a_V%density_1066a( 73) = 5.46297000000000
+ M1066a_V%density_1066a( 74) = 5.45049000000000
+ M1066a_V%density_1066a( 75) = 5.43741000000000
+ M1066a_V%density_1066a( 76) = 5.42382000000000
+ M1066a_V%density_1066a( 77) = 5.40934000000000
+ M1066a_V%density_1066a( 78) = 5.39375000000000
+ M1066a_V%density_1066a( 79) = 5.37717000000000
+ M1066a_V%density_1066a( 80) = 5.35958000000000
+ M1066a_V%density_1066a( 81) = 5.34079000000000
+ M1066a_V%density_1066a( 82) = 5.32100000000000
+ M1066a_V%density_1066a( 83) = 5.30031000000000
+ M1066a_V%density_1066a( 84) = 5.27902000000000
+ M1066a_V%density_1066a( 85) = 5.25733000000000
+ M1066a_V%density_1066a( 86) = 5.23554000000000
+ M1066a_V%density_1066a( 87) = 5.21375000000000
+ M1066a_V%density_1066a( 88) = 5.19196000000000
+ M1066a_V%density_1066a( 89) = 5.17056000000000
+ M1066a_V%density_1066a( 90) = 5.14937000000000
+ M1066a_V%density_1066a( 91) = 5.12827000000000
+ M1066a_V%density_1066a( 92) = 5.10758000000000
+ M1066a_V%density_1066a( 93) = 5.08728000000000
+ M1066a_V%density_1066a( 94) = 5.06738000000000
+ M1066a_V%density_1066a( 95) = 5.04769000000000
+ M1066a_V%density_1066a( 96) = 5.02809000000000
+ M1066a_V%density_1066a( 97) = 5.00869000000000
+ M1066a_V%density_1066a( 98) = 4.98929000000000
+ M1066a_V%density_1066a( 99) = 4.96968000000000
+ M1066a_V%density_1066a(100) = 4.95008000000000
+ M1066a_V%density_1066a(101) = 4.93048000000000
+ M1066a_V%density_1066a(102) = 4.91128000000000
+ M1066a_V%density_1066a(103) = 4.89257000000000
+ M1066a_V%density_1066a(104) = 4.87447000000000
+ M1066a_V%density_1066a(105) = 4.85716000000000
+ M1066a_V%density_1066a(106) = 4.84095000000000
+ M1066a_V%density_1066a(107) = 4.82554000000000
+ M1066a_V%density_1066a(108) = 4.81084000000000
+ M1066a_V%density_1066a(109) = 4.79683000000000
+ M1066a_V%density_1066a(110) = 4.78312000000000
+ M1066a_V%density_1066a(111) = 4.76951000000000
+ M1066a_V%density_1066a(112) = 4.75530000000000
+ M1066a_V%density_1066a(113) = 4.74008000000000
+ M1066a_V%density_1066a(114) = 4.72317000000000
+ M1066a_V%density_1066a(115) = 4.70426000000000
+ M1066a_V%density_1066a(116) = 4.68264000000000
+ M1066a_V%density_1066a(117) = 4.65863000000000
+ M1066a_V%density_1066a(118) = 4.63351000000000
+ M1066a_V%density_1066a(119) = 4.60859000000000
+ M1066a_V%density_1066a(120) = 4.58538000000000
+ M1066a_V%density_1066a(121) = 4.56536000000000
+ M1066a_V%density_1066a(122) = 4.55044000000000
+ M1066a_V%density_1066a(123) = 4.54072000000000
+ M1066a_V%density_1066a(124) = 4.53480000000000
+ M1066a_V%density_1066a(125) = 4.53478000000000
+ M1066a_V%density_1066a(126) = 4.53275000000000
+ M1066a_V%density_1066a(127) = 4.50893000000000
+ M1066a_V%density_1066a(128) = 4.46541000000000
+ M1066a_V%density_1066a(129) = 4.40098000000000
+ M1066a_V%density_1066a(130) = 4.31686000000000
+ M1066a_V%density_1066a(131) = 4.20553000000000
+ M1066a_V%density_1066a(132) = 4.20553000000000
+ M1066a_V%density_1066a(133) = 4.10272000000000
+ M1066a_V%density_1066a(134) = 4.02250000000000
+ M1066a_V%density_1066a(135) = 3.95789000000000
+ M1066a_V%density_1066a(136) = 3.89997000000000
+ M1066a_V%density_1066a(137) = 3.84675000000000
+ M1066a_V%density_1066a(138) = 3.80144000000000
+ M1066a_V%density_1066a(139) = 3.76072000000000
+ M1066a_V%density_1066a(140) = 3.70840000000000
+ M1066a_V%density_1066a(141) = 3.70840000000000
+ M1066a_V%density_1066a(142) = 3.65370000000000
+ M1066a_V%density_1066a(143) = 3.59640000000000
+ M1066a_V%density_1066a(144) = 3.54731000000000
+ M1066a_V%density_1066a(145) = 3.50511000000000
+ M1066a_V%density_1066a(146) = 3.46861000000000
+ M1066a_V%density_1066a(147) = 3.43851000000000
+ M1066a_V%density_1066a(148) = 3.41471000000000
+ M1066a_V%density_1066a(149) = 3.39751000000000
+ M1066a_V%density_1066a(150) = 3.38820000000000
+ M1066a_V%density_1066a(151) = 3.38200000000000
+ M1066a_V%density_1066a(152) = 3.37450000000000
+ M1066a_V%density_1066a(153) = 3.36710000000000
+ M1066a_V%density_1066a(154) = 3.35980000000000
+ M1066a_V%density_1066a(155) = 3.35259000000000
+ M1066a_V%density_1066a(156) = 3.34549000000000
+ M1066a_V%density_1066a(157) = 3.33828000000000
+ M1066a_V%density_1066a(158) = 2.17798000000000
+ M1066a_V%density_1066a(159) = 2.17766000000000
+ M1066a_V%density_1066a(160) = 2.17734000000000
+
+ M1066a_V%vp_1066a( 1) = 11.3383000000000
+ M1066a_V%vp_1066a( 2) = 11.3374000000000
+ M1066a_V%vp_1066a( 3) = 11.3347000000000
+ M1066a_V%vp_1066a( 4) = 11.3301000000000
+ M1066a_V%vp_1066a( 5) = 11.3237000000000
+ M1066a_V%vp_1066a( 6) = 11.3155000000000
+ M1066a_V%vp_1066a( 7) = 11.3056000000000
+ M1066a_V%vp_1066a( 8) = 11.2940000000000
+ M1066a_V%vp_1066a( 9) = 11.2810000000000
+ M1066a_V%vp_1066a( 10) = 11.2666000000000
+ M1066a_V%vp_1066a( 11) = 11.2512000000000
+ M1066a_V%vp_1066a( 12) = 11.2349000000000
+ M1066a_V%vp_1066a( 13) = 11.2181000000000
+ M1066a_V%vp_1066a( 14) = 11.2010000000000
+ M1066a_V%vp_1066a( 15) = 11.1840000000000
+ M1066a_V%vp_1066a( 16) = 11.1672000000000
+ M1066a_V%vp_1066a( 17) = 11.1508000000000
+ M1066a_V%vp_1066a( 18) = 11.1351000000000
+ M1066a_V%vp_1066a( 19) = 11.1201000000000
+ M1066a_V%vp_1066a( 20) = 11.1059000000000
+ M1066a_V%vp_1066a( 21) = 11.0924000000000
+ M1066a_V%vp_1066a( 22) = 11.0798000000000
+ M1066a_V%vp_1066a( 23) = 11.0678000000000
+ M1066a_V%vp_1066a( 24) = 11.0564000000000
+ M1066a_V%vp_1066a( 25) = 11.0455000000000
+ M1066a_V%vp_1066a( 26) = 11.0350000000000
+ M1066a_V%vp_1066a( 27) = 11.0248000000000
+ M1066a_V%vp_1066a( 28) = 11.0149000000000
+ M1066a_V%vp_1066a( 29) = 11.0051000000000
+ M1066a_V%vp_1066a( 30) = 10.9953000000000
+ M1066a_V%vp_1066a( 31) = 10.9857000000000
+ M1066a_V%vp_1066a( 32) = 10.9756000000000
+ M1066a_V%vp_1066a( 33) = 10.9687000000000
+ M1066a_V%vp_1066a( 34) = 10.4140000000000
+ M1066a_V%vp_1066a( 35) = 10.3518000000000
+ M1066a_V%vp_1066a( 36) = 10.2922000000000
+ M1066a_V%vp_1066a( 37) = 10.2351000000000
+ M1066a_V%vp_1066a( 38) = 10.1808000000000
+ M1066a_V%vp_1066a( 39) = 10.1297000000000
+ M1066a_V%vp_1066a( 40) = 10.0788000000000
+ M1066a_V%vp_1066a( 41) = 10.0284000000000
+ M1066a_V%vp_1066a( 42) = 9.97880000000000
+ M1066a_V%vp_1066a( 43) = 9.93070000000000
+ M1066a_V%vp_1066a( 44) = 9.88360000000000
+ M1066a_V%vp_1066a( 45) = 9.83530000000000
+ M1066a_V%vp_1066a( 46) = 9.78250000000000
+ M1066a_V%vp_1066a( 47) = 9.72110000000000
+ M1066a_V%vp_1066a( 48) = 9.65210000000000
+ M1066a_V%vp_1066a( 49) = 9.58060000000000
+ M1066a_V%vp_1066a( 50) = 9.51150000000000
+ M1066a_V%vp_1066a( 51) = 9.44650000000000
+ M1066a_V%vp_1066a( 52) = 9.38280000000000
+ M1066a_V%vp_1066a( 53) = 9.31660000000000
+ M1066a_V%vp_1066a( 54) = 9.24420000000000
+ M1066a_V%vp_1066a( 55) = 9.16580000000000
+ M1066a_V%vp_1066a( 56) = 9.08330000000000
+ M1066a_V%vp_1066a( 57) = 8.99870000000000
+ M1066a_V%vp_1066a( 58) = 8.91160000000000
+ M1066a_V%vp_1066a( 59) = 8.82010000000000
+ M1066a_V%vp_1066a( 60) = 8.72230000000000
+ M1066a_V%vp_1066a( 61) = 8.61710000000000
+ M1066a_V%vp_1066a( 62) = 8.50300000000000
+ M1066a_V%vp_1066a( 63) = 8.38070000000000
+ M1066a_V%vp_1066a( 64) = 8.25560000000000
+ M1066a_V%vp_1066a( 65) = 8.13180000000000
+ M1066a_V%vp_1066a( 66) = 8.01120000000000
+ M1066a_V%vp_1066a( 67) = 13.7172000000000
+ M1066a_V%vp_1066a( 68) = 13.7134000000000
+ M1066a_V%vp_1066a( 69) = 13.7089000000000
+ M1066a_V%vp_1066a( 70) = 13.6806000000000
+ M1066a_V%vp_1066a( 71) = 13.6517000000000
+ M1066a_V%vp_1066a( 72) = 13.6251000000000
+ M1066a_V%vp_1066a( 73) = 13.5916000000000
+ M1066a_V%vp_1066a( 74) = 13.5564000000000
+ M1066a_V%vp_1066a( 75) = 13.5165000000000
+ M1066a_V%vp_1066a( 76) = 13.4725000000000
+ M1066a_V%vp_1066a( 77) = 13.4248000000000
+ M1066a_V%vp_1066a( 78) = 13.3742000000000
+ M1066a_V%vp_1066a( 79) = 13.3216000000000
+ M1066a_V%vp_1066a( 80) = 13.2679000000000
+ M1066a_V%vp_1066a( 81) = 13.2142000000000
+ M1066a_V%vp_1066a( 82) = 13.1619000000000
+ M1066a_V%vp_1066a( 83) = 13.1114000000000
+ M1066a_V%vp_1066a( 84) = 13.0631000000000
+ M1066a_V%vp_1066a( 85) = 13.0174000000000
+ M1066a_V%vp_1066a( 86) = 12.9745000000000
+ M1066a_V%vp_1066a( 87) = 12.9346000000000
+ M1066a_V%vp_1066a( 88) = 12.8977000000000
+ M1066a_V%vp_1066a( 89) = 12.8635000000000
+ M1066a_V%vp_1066a( 90) = 12.8318000000000
+ M1066a_V%vp_1066a( 91) = 12.8022000000000
+ M1066a_V%vp_1066a( 92) = 12.7739000000000
+ M1066a_V%vp_1066a( 93) = 12.7463000000000
+ M1066a_V%vp_1066a( 94) = 12.7186000000000
+ M1066a_V%vp_1066a( 95) = 12.6903000000000
+ M1066a_V%vp_1066a( 96) = 12.6610000000000
+ M1066a_V%vp_1066a( 97) = 12.6302000000000
+ M1066a_V%vp_1066a( 98) = 12.5978000000000
+ M1066a_V%vp_1066a( 99) = 12.5637000000000
+ M1066a_V%vp_1066a(100) = 12.5276000000000
+ M1066a_V%vp_1066a(101) = 12.4893000000000
+ M1066a_V%vp_1066a(102) = 12.4485000000000
+ M1066a_V%vp_1066a(103) = 12.4052000000000
+ M1066a_V%vp_1066a(104) = 12.3592000000000
+ M1066a_V%vp_1066a(105) = 12.3105000000000
+ M1066a_V%vp_1066a(106) = 12.2596000000000
+ M1066a_V%vp_1066a(107) = 12.2072000000000
+ M1066a_V%vp_1066a(108) = 12.1538000000000
+ M1066a_V%vp_1066a(109) = 12.0998000000000
+ M1066a_V%vp_1066a(110) = 12.0458000000000
+ M1066a_V%vp_1066a(111) = 11.9920000000000
+ M1066a_V%vp_1066a(112) = 11.9373000000000
+ M1066a_V%vp_1066a(113) = 11.8804000000000
+ M1066a_V%vp_1066a(114) = 11.8200000000000
+ M1066a_V%vp_1066a(115) = 11.7554000000000
+ M1066a_V%vp_1066a(116) = 11.6844000000000
+ M1066a_V%vp_1066a(117) = 11.6079000000000
+ M1066a_V%vp_1066a(118) = 11.5308000000000
+ M1066a_V%vp_1066a(119) = 11.4579000000000
+ M1066a_V%vp_1066a(120) = 11.3935000000000
+ M1066a_V%vp_1066a(121) = 11.3418000000000
+ M1066a_V%vp_1066a(122) = 11.3085000000000
+ M1066a_V%vp_1066a(123) = 11.2938000000000
+ M1066a_V%vp_1066a(124) = 11.2915000000000
+ M1066a_V%vp_1066a(125) = 11.3049000000000
+ M1066a_V%vp_1066a(126) = 11.3123000000000
+ M1066a_V%vp_1066a(127) = 11.2643000000000
+ M1066a_V%vp_1066a(128) = 11.1635000000000
+ M1066a_V%vp_1066a(129) = 11.0063000000000
+ M1066a_V%vp_1066a(130) = 10.7959000000000
+ M1066a_V%vp_1066a(131) = 10.5143000000000
+ M1066a_V%vp_1066a(132) = 10.5143000000000
+ M1066a_V%vp_1066a(133) = 10.2513000000000
+ M1066a_V%vp_1066a(134) = 10.0402000000000
+ M1066a_V%vp_1066a(135) = 9.86480000000000
+ M1066a_V%vp_1066a(136) = 9.70860000000000
+ M1066a_V%vp_1066a(137) = 9.56810000000000
+ M1066a_V%vp_1066a(138) = 9.45120000000000
+ M1066a_V%vp_1066a(139) = 9.35100000000000
+ M1066a_V%vp_1066a(140) = 9.22830000000000
+ M1066a_V%vp_1066a(141) = 9.22830000000000
+ M1066a_V%vp_1066a(142) = 9.10870000000000
+ M1066a_V%vp_1066a(143) = 8.98230000000000
+ M1066a_V%vp_1066a(144) = 8.85920000000000
+ M1066a_V%vp_1066a(145) = 8.73860000000000
+ M1066a_V%vp_1066a(146) = 8.61930000000000
+ M1066a_V%vp_1066a(147) = 8.50180000000000
+ M1066a_V%vp_1066a(148) = 8.38710000000000
+ M1066a_V%vp_1066a(149) = 8.27360000000000
+ M1066a_V%vp_1066a(150) = 8.15850000000000
+ M1066a_V%vp_1066a(151) = 8.05400000000000
+ M1066a_V%vp_1066a(152) = 7.96520000000000
+ M1066a_V%vp_1066a(153) = 7.87340000000000
+ M1066a_V%vp_1066a(154) = 7.79720000000000
+ M1066a_V%vp_1066a(155) = 7.73910000000000
+ M1066a_V%vp_1066a(156) = 7.71340000000000
+ M1066a_V%vp_1066a(157) = 7.70460000000000
+ M1066a_V%vp_1066a(158) = 4.70220000000000
+ M1066a_V%vp_1066a(159) = 4.70010000000000
+ M1066a_V%vp_1066a(160) = 4.69790000000000
+
+ M1066a_V%vs_1066a( 1) = 3.62980000000000
+ M1066a_V%vs_1066a( 2) = 3.62970000000000
+ M1066a_V%vs_1066a( 3) = 3.62940000000000
+ M1066a_V%vs_1066a( 4) = 3.62880000000000
+ M1066a_V%vs_1066a( 5) = 3.62810000000000
+ M1066a_V%vs_1066a( 6) = 3.62710000000000
+ M1066a_V%vs_1066a( 7) = 3.62590000000000
+ M1066a_V%vs_1066a( 8) = 3.62440000000000
+ M1066a_V%vs_1066a( 9) = 3.62280000000000
+ M1066a_V%vs_1066a( 10) = 3.62090000000000
+ M1066a_V%vs_1066a( 11) = 3.61870000000000
+ M1066a_V%vs_1066a( 12) = 3.61630000000000
+ M1066a_V%vs_1066a( 13) = 3.61370000000000
+ M1066a_V%vs_1066a( 14) = 3.61080000000000
+ M1066a_V%vs_1066a( 15) = 3.60760000000000
+ M1066a_V%vs_1066a( 16) = 3.60420000000000
+ M1066a_V%vs_1066a( 17) = 3.60040000000000
+ M1066a_V%vs_1066a( 18) = 3.59650000000000
+ M1066a_V%vs_1066a( 19) = 3.59220000000000
+ M1066a_V%vs_1066a( 20) = 3.58760000000000
+ M1066a_V%vs_1066a( 21) = 3.58280000000000
+ M1066a_V%vs_1066a( 22) = 3.57770000000000
+ M1066a_V%vs_1066a( 23) = 3.57240000000000
+ M1066a_V%vs_1066a( 24) = 3.56680000000000
+ M1066a_V%vs_1066a( 25) = 3.56100000000000
+ M1066a_V%vs_1066a( 26) = 3.55510000000000
+ M1066a_V%vs_1066a( 27) = 3.54900000000000
+ M1066a_V%vs_1066a( 28) = 3.54280000000000
+ M1066a_V%vs_1066a( 29) = 3.53650000000000
+ M1066a_V%vs_1066a( 30) = 3.53010000000000
+ M1066a_V%vs_1066a( 31) = 3.52380000000000
+ M1066a_V%vs_1066a( 32) = 3.51720000000000
+ M1066a_V%vs_1066a( 33) = 3.51180000000000
+ M1066a_V%vs_1066a( 34) = 0.000000000000000
+ M1066a_V%vs_1066a( 35) = 0.000000000000000
+ M1066a_V%vs_1066a( 36) = 0.000000000000000
+ M1066a_V%vs_1066a( 37) = 0.000000000000000
+ M1066a_V%vs_1066a( 38) = 0.000000000000000
+ M1066a_V%vs_1066a( 39) = 0.000000000000000
+ M1066a_V%vs_1066a( 40) = 0.000000000000000
+ M1066a_V%vs_1066a( 41) = 0.000000000000000
+ M1066a_V%vs_1066a( 42) = 0.000000000000000
+ M1066a_V%vs_1066a( 43) = 0.000000000000000
+ M1066a_V%vs_1066a( 44) = 0.000000000000000
+ M1066a_V%vs_1066a( 45) = 0.000000000000000
+ M1066a_V%vs_1066a( 46) = 0.000000000000000
+ M1066a_V%vs_1066a( 47) = 0.000000000000000
+ M1066a_V%vs_1066a( 48) = 0.000000000000000
+ M1066a_V%vs_1066a( 49) = 0.000000000000000
+ M1066a_V%vs_1066a( 50) = 0.000000000000000
+ M1066a_V%vs_1066a( 51) = 0.000000000000000
+ M1066a_V%vs_1066a( 52) = 0.000000000000000
+ M1066a_V%vs_1066a( 53) = 0.000000000000000
+ M1066a_V%vs_1066a( 54) = 0.000000000000000
+ M1066a_V%vs_1066a( 55) = 0.000000000000000
+ M1066a_V%vs_1066a( 56) = 0.000000000000000
+ M1066a_V%vs_1066a( 57) = 0.000000000000000
+ M1066a_V%vs_1066a( 58) = 0.000000000000000
+ M1066a_V%vs_1066a( 59) = 0.000000000000000
+ M1066a_V%vs_1066a( 60) = 0.000000000000000
+ M1066a_V%vs_1066a( 61) = 0.000000000000000
+ M1066a_V%vs_1066a( 62) = 0.000000000000000
+ M1066a_V%vs_1066a( 63) = 0.000000000000000
+ M1066a_V%vs_1066a( 64) = 0.000000000000000
+ M1066a_V%vs_1066a( 65) = 0.000000000000000
+ M1066a_V%vs_1066a( 66) = 0.000000000000000
+ M1066a_V%vs_1066a( 67) = 7.24980000000000
+ M1066a_V%vs_1066a( 68) = 7.23760000000000
+ M1066a_V%vs_1066a( 69) = 7.22390000000000
+ M1066a_V%vs_1066a( 70) = 7.21000000000000
+ M1066a_V%vs_1066a( 71) = 7.19640000000000
+ M1066a_V%vs_1066a( 72) = 7.18300000000000
+ M1066a_V%vs_1066a( 73) = 7.16990000000000
+ M1066a_V%vs_1066a( 74) = 7.15710000000000
+ M1066a_V%vs_1066a( 75) = 7.14450000000000
+ M1066a_V%vs_1066a( 76) = 7.13200000000000
+ M1066a_V%vs_1066a( 77) = 7.11960000000000
+ M1066a_V%vs_1066a( 78) = 7.10740000000000
+ M1066a_V%vs_1066a( 79) = 7.09530000000000
+ M1066a_V%vs_1066a( 80) = 7.08320000000000
+ M1066a_V%vs_1066a( 81) = 7.07120000000000
+ M1066a_V%vs_1066a( 82) = 7.05920000000000
+ M1066a_V%vs_1066a( 83) = 7.04710000000000
+ M1066a_V%vs_1066a( 84) = 7.03470000000000
+ M1066a_V%vs_1066a( 85) = 7.02190000000000
+ M1066a_V%vs_1066a( 86) = 7.00860000000000
+ M1066a_V%vs_1066a( 87) = 6.99470000000000
+ M1066a_V%vs_1066a( 88) = 6.98030000000000
+ M1066a_V%vs_1066a( 89) = 6.96510000000000
+ M1066a_V%vs_1066a( 90) = 6.94930000000000
+ M1066a_V%vs_1066a( 91) = 6.93290000000000
+ M1066a_V%vs_1066a( 92) = 6.91620000000000
+ M1066a_V%vs_1066a( 93) = 6.89910000000000
+ M1066a_V%vs_1066a( 94) = 6.88200000000000
+ M1066a_V%vs_1066a( 95) = 6.86520000000000
+ M1066a_V%vs_1066a( 96) = 6.84900000000000
+ M1066a_V%vs_1066a( 97) = 6.83340000000000
+ M1066a_V%vs_1066a( 98) = 6.81820000000000
+ M1066a_V%vs_1066a( 99) = 6.80360000000000
+ M1066a_V%vs_1066a(100) = 6.78910000000000
+ M1066a_V%vs_1066a(101) = 6.77440000000000
+ M1066a_V%vs_1066a(102) = 6.75890000000000
+ M1066a_V%vs_1066a(103) = 6.74270000000000
+ M1066a_V%vs_1066a(104) = 6.72550000000000
+ M1066a_V%vs_1066a(105) = 6.70730000000000
+ M1066a_V%vs_1066a(106) = 6.68810000000000
+ M1066a_V%vs_1066a(107) = 6.66840000000000
+ M1066a_V%vs_1066a(108) = 6.64850000000000
+ M1066a_V%vs_1066a(109) = 6.62880000000000
+ M1066a_V%vs_1066a(110) = 6.60950000000000
+ M1066a_V%vs_1066a(111) = 6.59110000000000
+ M1066a_V%vs_1066a(112) = 6.57310000000000
+ M1066a_V%vs_1066a(113) = 6.55480000000000
+ M1066a_V%vs_1066a(114) = 6.53510000000000
+ M1066a_V%vs_1066a(115) = 6.51330000000000
+ M1066a_V%vs_1066a(116) = 6.48810000000000
+ M1066a_V%vs_1066a(117) = 6.45940000000000
+ M1066a_V%vs_1066a(118) = 6.42860000000000
+ M1066a_V%vs_1066a(119) = 6.39760000000000
+ M1066a_V%vs_1066a(120) = 6.36840000000000
+ M1066a_V%vs_1066a(121) = 6.34280000000000
+ M1066a_V%vs_1066a(122) = 6.32350000000000
+ M1066a_V%vs_1066a(123) = 6.31140000000000
+ M1066a_V%vs_1066a(124) = 6.30410000000000
+ M1066a_V%vs_1066a(125) = 6.30520000000000
+ M1066a_V%vs_1066a(126) = 6.30210000000000
+ M1066a_V%vs_1066a(127) = 6.26430000000000
+ M1066a_V%vs_1066a(128) = 6.19470000000000
+ M1066a_V%vs_1066a(129) = 6.09120000000000
+ M1066a_V%vs_1066a(130) = 5.95550000000000
+ M1066a_V%vs_1066a(131) = 5.77550000000000
+ M1066a_V%vs_1066a(132) = 5.77550000000000
+ M1066a_V%vs_1066a(133) = 5.60830000000000
+ M1066a_V%vs_1066a(134) = 5.47520000000000
+ M1066a_V%vs_1066a(135) = 5.36530000000000
+ M1066a_V%vs_1066a(136) = 5.26650000000000
+ M1066a_V%vs_1066a(137) = 5.17620000000000
+ M1066a_V%vs_1066a(138) = 5.09960000000000
+ M1066a_V%vs_1066a(139) = 5.03220000000000
+ M1066a_V%vs_1066a(140) = 4.94880000000000
+ M1066a_V%vs_1066a(141) = 4.94880000000000
+ M1066a_V%vs_1066a(142) = 4.86670000000000
+ M1066a_V%vs_1066a(143) = 4.78060000000000
+ M1066a_V%vs_1066a(144) = 4.69950000000000
+ M1066a_V%vs_1066a(145) = 4.62110000000000
+ M1066a_V%vs_1066a(146) = 4.54790000000000
+ M1066a_V%vs_1066a(147) = 4.48820000000000
+ M1066a_V%vs_1066a(148) = 4.44210000000000
+ M1066a_V%vs_1066a(149) = 4.40840000000000
+ M1066a_V%vs_1066a(150) = 4.38740000000000
+ M1066a_V%vs_1066a(151) = 4.37950000000000
+ M1066a_V%vs_1066a(152) = 4.39040000000000
+ M1066a_V%vs_1066a(153) = 4.43310000000000
+ M1066a_V%vs_1066a(154) = 4.48300000000000
+ M1066a_V%vs_1066a(155) = 4.53890000000000
+ M1066a_V%vs_1066a(156) = 4.60400000000000
+ M1066a_V%vs_1066a(157) = 4.64870000000000
+ M1066a_V%vs_1066a(158) = 2.58060000000000
+ M1066a_V%vs_1066a(159) = 2.58140000000000
+ M1066a_V%vs_1066a(160) = 2.58220000000000
+
+ if (SUPPRESS_CRUSTAL_MESH) then
+ M1066a_V%vp_1066a(158:160) = M1066a_V%vp_1066a(157)
+ M1066a_V%vs_1066a(158:160) = M1066a_V%vs_1066a(157)
+ M1066a_V%density_1066a(158:160) = M1066a_V%density_1066a(157)
+ endif
+
+ M1066a_V%Qkappa_1066a( 1) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 2) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 3) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 4) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 5) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 6) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 7) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 8) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 9) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 10) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 11) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 12) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 13) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 14) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 15) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 16) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 17) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 18) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 19) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 20) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 21) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 22) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 23) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 24) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 25) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 26) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 27) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 28) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 29) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 30) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 31) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 32) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 33) = 156900.000000000
+ M1066a_V%Qkappa_1066a( 34) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 35) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 36) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 37) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 38) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 39) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 40) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 41) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 42) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 43) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 44) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 45) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 46) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 47) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 48) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 49) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 50) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 51) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 52) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 53) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 54) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 55) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 56) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 57) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 58) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 59) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 60) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 61) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 62) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 63) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 64) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 65) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 66) = 0.000000000000000
+ M1066a_V%Qkappa_1066a( 67) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 68) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 69) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 70) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 71) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 72) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 73) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 74) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 75) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 76) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 77) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 78) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 79) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 80) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 81) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 82) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 83) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 84) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 85) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 86) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 87) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 88) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 89) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 90) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 91) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 92) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 93) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 94) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 95) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 96) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 97) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 98) = 16600.0000000000
+ M1066a_V%Qkappa_1066a( 99) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(100) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(101) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(102) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(103) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(104) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(105) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(106) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(107) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(108) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(109) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(110) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(111) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(112) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(113) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(114) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(115) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(116) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(117) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(118) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(119) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(120) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(121) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(122) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(123) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(124) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(125) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(126) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(127) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(128) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(129) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(130) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(131) = 16600.0000000000
+ M1066a_V%Qkappa_1066a(132) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(133) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(134) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(135) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(136) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(137) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(138) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(139) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(140) = 13840.0000000000
+ M1066a_V%Qkappa_1066a(141) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(142) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(143) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(144) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(145) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(146) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(147) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(148) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(149) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(150) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(151) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(152) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(153) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(154) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(155) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(156) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(157) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(158) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(159) = 5893.00000000000
+ M1066a_V%Qkappa_1066a(160) = 5893.00000000000
+
+ M1066a_V%Qmu_1066a( 1) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 2) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 3) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 4) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 5) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 6) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 7) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 8) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 9) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 10) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 11) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 12) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 13) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 14) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 15) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 16) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 17) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 18) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 19) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 20) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 21) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 22) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 23) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 24) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 25) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 26) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 27) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 28) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 29) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 30) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 31) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 32) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 33) = 3138.00000000000
+ M1066a_V%Qmu_1066a( 34) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 35) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 36) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 37) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 38) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 39) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 40) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 41) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 42) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 43) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 44) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 45) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 46) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 47) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 48) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 49) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 50) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 51) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 52) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 53) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 54) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 55) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 56) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 57) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 58) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 59) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 60) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 61) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 62) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 63) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 64) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 65) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 66) = 0.000000000000000
+ M1066a_V%Qmu_1066a( 67) = 332.000000000000
+ M1066a_V%Qmu_1066a( 68) = 332.000000000000
+ M1066a_V%Qmu_1066a( 69) = 332.000000000000
+ M1066a_V%Qmu_1066a( 70) = 332.000000000000
+ M1066a_V%Qmu_1066a( 71) = 332.000000000000
+ M1066a_V%Qmu_1066a( 72) = 332.000000000000
+ M1066a_V%Qmu_1066a( 73) = 332.000000000000
+ M1066a_V%Qmu_1066a( 74) = 332.000000000000
+ M1066a_V%Qmu_1066a( 75) = 332.000000000000
+ M1066a_V%Qmu_1066a( 76) = 332.000000000000
+ M1066a_V%Qmu_1066a( 77) = 332.000000000000
+ M1066a_V%Qmu_1066a( 78) = 332.000000000000
+ M1066a_V%Qmu_1066a( 79) = 332.000000000000
+ M1066a_V%Qmu_1066a( 80) = 332.000000000000
+ M1066a_V%Qmu_1066a( 81) = 332.000000000000
+ M1066a_V%Qmu_1066a( 82) = 332.000000000000
+ M1066a_V%Qmu_1066a( 83) = 332.000000000000
+ M1066a_V%Qmu_1066a( 84) = 332.000000000000
+ M1066a_V%Qmu_1066a( 85) = 332.000000000000
+ M1066a_V%Qmu_1066a( 86) = 332.000000000000
+ M1066a_V%Qmu_1066a( 87) = 332.000000000000
+ M1066a_V%Qmu_1066a( 88) = 332.000000000000
+ M1066a_V%Qmu_1066a( 89) = 332.000000000000
+ M1066a_V%Qmu_1066a( 90) = 332.000000000000
+ M1066a_V%Qmu_1066a( 91) = 332.000000000000
+ M1066a_V%Qmu_1066a( 92) = 332.000000000000
+ M1066a_V%Qmu_1066a( 93) = 332.000000000000
+ M1066a_V%Qmu_1066a( 94) = 332.000000000000
+ M1066a_V%Qmu_1066a( 95) = 332.000000000000
+ M1066a_V%Qmu_1066a( 96) = 332.000000000000
+ M1066a_V%Qmu_1066a( 97) = 332.000000000000
+ M1066a_V%Qmu_1066a( 98) = 332.000000000000
+ M1066a_V%Qmu_1066a( 99) = 332.000000000000
+ M1066a_V%Qmu_1066a(100) = 332.000000000000
+ M1066a_V%Qmu_1066a(101) = 332.000000000000
+ M1066a_V%Qmu_1066a(102) = 332.000000000000
+ M1066a_V%Qmu_1066a(103) = 332.000000000000
+ M1066a_V%Qmu_1066a(104) = 332.000000000000
+ M1066a_V%Qmu_1066a(105) = 332.000000000000
+ M1066a_V%Qmu_1066a(106) = 332.000000000000
+ M1066a_V%Qmu_1066a(107) = 332.000000000000
+ M1066a_V%Qmu_1066a(108) = 332.000000000000
+ M1066a_V%Qmu_1066a(109) = 332.000000000000
+ M1066a_V%Qmu_1066a(110) = 332.000000000000
+ M1066a_V%Qmu_1066a(111) = 332.000000000000
+ M1066a_V%Qmu_1066a(112) = 332.000000000000
+ M1066a_V%Qmu_1066a(113) = 332.000000000000
+ M1066a_V%Qmu_1066a(114) = 332.000000000000
+ M1066a_V%Qmu_1066a(115) = 332.000000000000
+ M1066a_V%Qmu_1066a(116) = 332.000000000000
+ M1066a_V%Qmu_1066a(117) = 332.000000000000
+ M1066a_V%Qmu_1066a(118) = 332.000000000000
+ M1066a_V%Qmu_1066a(119) = 332.000000000000
+ M1066a_V%Qmu_1066a(120) = 332.000000000000
+ M1066a_V%Qmu_1066a(121) = 332.000000000000
+ M1066a_V%Qmu_1066a(122) = 332.000000000000
+ M1066a_V%Qmu_1066a(123) = 332.000000000000
+ M1066a_V%Qmu_1066a(124) = 332.000000000000
+ M1066a_V%Qmu_1066a(125) = 332.000000000000
+ M1066a_V%Qmu_1066a(126) = 332.000000000000
+ M1066a_V%Qmu_1066a(127) = 332.000000000000
+ M1066a_V%Qmu_1066a(128) = 332.000000000000
+ M1066a_V%Qmu_1066a(129) = 332.000000000000
+ M1066a_V%Qmu_1066a(130) = 332.000000000000
+ M1066a_V%Qmu_1066a(131) = 332.000000000000
+ M1066a_V%Qmu_1066a(132) = 276.800000000000
+ M1066a_V%Qmu_1066a(133) = 276.800000000000
+ M1066a_V%Qmu_1066a(134) = 276.800000000000
+ M1066a_V%Qmu_1066a(135) = 276.800000000000
+ M1066a_V%Qmu_1066a(136) = 276.800000000000
+ M1066a_V%Qmu_1066a(137) = 276.800000000000
+ M1066a_V%Qmu_1066a(138) = 276.800000000000
+ M1066a_V%Qmu_1066a(139) = 276.800000000000
+ M1066a_V%Qmu_1066a(140) = 276.800000000000
+ M1066a_V%Qmu_1066a(141) = 117.900000000000
+ M1066a_V%Qmu_1066a(142) = 117.900000000000
+ M1066a_V%Qmu_1066a(143) = 117.900000000000
+ M1066a_V%Qmu_1066a(144) = 117.900000000000
+ M1066a_V%Qmu_1066a(145) = 117.900000000000
+ M1066a_V%Qmu_1066a(146) = 117.900000000000
+ M1066a_V%Qmu_1066a(147) = 117.900000000000
+ M1066a_V%Qmu_1066a(148) = 117.900000000000
+ M1066a_V%Qmu_1066a(149) = 117.900000000000
+ M1066a_V%Qmu_1066a(150) = 117.900000000000
+ M1066a_V%Qmu_1066a(151) = 117.900000000000
+ M1066a_V%Qmu_1066a(152) = 117.900000000000
+ M1066a_V%Qmu_1066a(153) = 117.900000000000
+ M1066a_V%Qmu_1066a(154) = 117.900000000000
+ M1066a_V%Qmu_1066a(155) = 117.900000000000
+ M1066a_V%Qmu_1066a(156) = 117.900000000000
+ M1066a_V%Qmu_1066a(157) = 117.900000000000
+ M1066a_V%Qmu_1066a(158) = 117.900000000000
+ M1066a_V%Qmu_1066a(159) = 117.900000000000
+ M1066a_V%Qmu_1066a(160) = 117.900000000000
+
+! strip the crust and replace it by mantle if we use an external crustal model
+ if(USE_EXTERNAL_CRUSTAL_MODEL) then
+ do i=NR_1066A-3,NR_1066A
+ M1066a_V%density_1066a(i) = M1066a_V%density_1066a(NR_1066A-4)
+ M1066a_V%vp_1066a(i) = M1066a_V%vp_1066a(NR_1066A-4)
+ M1066a_V%vs_1066a(i) = M1066a_V%vs_1066a(NR_1066A-4)
+ M1066a_V%Qkappa_1066a(i) = M1066a_V%Qkappa_1066a(NR_1066A-4)
+ M1066a_V%Qmu_1066a(i) = M1066a_V%Qmu_1066a(NR_1066A-4)
+ enddo
+ endif
+
+ end subroutine define_model_1066a
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_ak135.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_ak135.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_ak135.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,1038 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine model_ak135(x,rho,vp,vs,Qkappa,Qmu,iregion_code,Mak135_V)
+
+ implicit none
+
+ include "constants.h"
+
+! model_ak135_variables
+ type model_ak135_variables
+ sequence
+ double precision, dimension(NR_AK135) :: radius_ak135
+ double precision, dimension(NR_AK135) :: density_ak135
+ double precision, dimension(NR_AK135) :: vp_ak135
+ double precision, dimension(NR_AK135) :: vs_ak135
+ double precision, dimension(NR_AK135) :: Qkappa_ak135
+ double precision, dimension(NR_AK135) :: Qmu_ak135
+ end type model_ak135_variables
+
+ type (model_ak135_variables) Mak135_V
+! model_ak135_variables
+
+! input:
+! radius r: meters
+
+! output:
+! density rho: kg/m^3
+! compressional wave speed vp: km/s
+! shear wave speed vs: km/s
+
+ integer iregion_code
+
+ double precision x,rho,vp,vs,Qmu,Qkappa
+
+ integer i
+
+ double precision r,frac,scaleval
+
+!! DK DK UGLY implementation of model ak135 below and its radii in
+!! DK DK UGLY subroutine read_parameter_file.f90 has not been thoroughly
+!! DK DK UGLY checked yet
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+ i = 1
+ do while(r >= Mak135_V%radius_ak135(i) .and. i /= NR_AK135)
+ i = i + 1
+ enddo
+
+! make sure we stay in the right region and never take a point above
+! and a point below the ICB or the CMB and interpolate between them,
+! which would lead to a wrong value (keeping in mind that we interpolate
+! between points i-1 and i below)
+ if(iregion_code == IREGION_INNER_CORE .and. i > 25) i = 25
+
+ if(iregion_code == IREGION_OUTER_CORE .and. i < 27) i = 27
+ if(iregion_code == IREGION_OUTER_CORE .and. i > 71) i = 71
+
+ if(iregion_code == IREGION_CRUST_MANTLE .and. i < 73) i = 73
+
+ if(i == 1) then
+ rho = Mak135_V%density_ak135(i)
+ vp = Mak135_V%vp_ak135(i)
+ vs = Mak135_V%vs_ak135(i)
+ Qmu = Mak135_V%Qmu_ak135(i)
+ Qkappa = Mak135_V%Qkappa_ak135(i)
+ else
+
+! interpolate from radius_ak135(i-1) to r using the values at i-1 and i
+ frac = (r-Mak135_V%radius_ak135(i-1))/(Mak135_V%radius_ak135(i)-Mak135_V%radius_ak135(i-1))
+
+ rho = Mak135_V%density_ak135(i-1) + frac * (Mak135_V%density_ak135(i)-Mak135_V%density_ak135(i-1))
+ vp = Mak135_V%vp_ak135(i-1) + frac * (Mak135_V%vp_ak135(i)-Mak135_V%vp_ak135(i-1))
+ vs = Mak135_V%vs_ak135(i-1) + frac * (Mak135_V%vs_ak135(i)-Mak135_V%vs_ak135(i-1))
+ Qmu = Mak135_V%Qmu_ak135(i-1) + frac * (Mak135_V%Qmu_ak135(i)-Mak135_V%Qmu_ak135(i-1))
+ Qkappa = Mak135_V%Qkappa_ak135(i-1) + frac * (Mak135_V%Qkappa_ak135(i)-Mak135_V%Qkappa_ak135(i-1))
+
+ endif
+
+! make sure Vs is zero in the outer core even if roundoff errors on depth
+! also set fictitious attenuation to a very high value (attenuation is not used in the fluid)
+ if(iregion_code == IREGION_OUTER_CORE) then
+ vs = 0.d0
+ Qkappa = 3000.d0
+ Qmu = 3000.d0
+ endif
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ rho=rho*1000.0d0/RHOAV
+ vp=vp*1000.0d0/(R_EARTH*scaleval)
+ vs=vs*1000.0d0/(R_EARTH*scaleval)
+
+ end subroutine model_ak135
+
+!-------------------
+
+ subroutine define_model_ak135(USE_EXTERNAL_CRUSTAL_MODEL,Mak135_V)
+
+ implicit none
+ include "constants.h"
+
+! model_ak135_variables
+ type model_ak135_variables
+ sequence
+ double precision, dimension(NR_AK135) :: radius_ak135
+ double precision, dimension(NR_AK135) :: density_ak135
+ double precision, dimension(NR_AK135) :: vp_ak135
+ double precision, dimension(NR_AK135) :: vs_ak135
+ double precision, dimension(NR_AK135) :: Qkappa_ak135
+ double precision, dimension(NR_AK135) :: Qmu_ak135
+ end type model_ak135_variables
+
+ type (model_ak135_variables) Mak135_V
+! model_ak135_variables
+
+ logical USE_EXTERNAL_CRUSTAL_MODEL
+
+ integer i
+
+! define all the values in the model
+
+ Mak135_V%radius_ak135( 1) = 0.000000000000000
+ Mak135_V%radius_ak135( 2) = 50710.0000000000
+ Mak135_V%radius_ak135( 3) = 101430.000000000
+ Mak135_V%radius_ak135( 4) = 152140.000000000
+ Mak135_V%radius_ak135( 5) = 202850.000000000
+ Mak135_V%radius_ak135( 6) = 253560.000000000
+ Mak135_V%radius_ak135( 7) = 304280.000000000
+ Mak135_V%radius_ak135( 8) = 354990.000000000
+ Mak135_V%radius_ak135( 9) = 405700.000000000
+ Mak135_V%radius_ak135( 10) = 456410.000000000
+ Mak135_V%radius_ak135( 11) = 507130.000000000
+ Mak135_V%radius_ak135( 12) = 557840.000000000
+ Mak135_V%radius_ak135( 13) = 608550.000000000
+ Mak135_V%radius_ak135( 14) = 659260.000000000
+ Mak135_V%radius_ak135( 15) = 709980.000000000
+ Mak135_V%radius_ak135( 16) = 760690.000000000
+ Mak135_V%radius_ak135( 17) = 811400.000000000
+ Mak135_V%radius_ak135( 18) = 862110.000000000
+ Mak135_V%radius_ak135( 19) = 912830.000000000
+ Mak135_V%radius_ak135( 20) = 963540.000000000
+ Mak135_V%radius_ak135( 21) = 1014250.00000000
+ Mak135_V%radius_ak135( 22) = 1064960.00000000
+ Mak135_V%radius_ak135( 23) = 1115680.00000000
+ Mak135_V%radius_ak135( 24) = 1166390.00000000
+ Mak135_V%radius_ak135( 25) = 1217500.00000000
+ Mak135_V%radius_ak135( 26) = 1217500.00000000
+ Mak135_V%radius_ak135( 27) = 1267430.00000000
+ Mak135_V%radius_ak135( 28) = 1317760.00000000
+ Mak135_V%radius_ak135( 29) = 1368090.00000000
+ Mak135_V%radius_ak135( 30) = 1418420.00000000
+ Mak135_V%radius_ak135( 31) = 1468760.00000000
+ Mak135_V%radius_ak135( 32) = 1519090.00000000
+ Mak135_V%radius_ak135( 33) = 1569420.00000000
+ Mak135_V%radius_ak135( 34) = 1619750.00000000
+ Mak135_V%radius_ak135( 35) = 1670080.00000000
+ Mak135_V%radius_ak135( 36) = 1720410.00000000
+ Mak135_V%radius_ak135( 37) = 1770740.00000000
+ Mak135_V%radius_ak135( 38) = 1821070.00000000
+ Mak135_V%radius_ak135( 39) = 1871400.00000000
+ Mak135_V%radius_ak135( 40) = 1921740.00000000
+ Mak135_V%radius_ak135( 41) = 1972070.00000000
+ Mak135_V%radius_ak135( 42) = 2022400.00000000
+ Mak135_V%radius_ak135( 43) = 2072730.00000000
+ Mak135_V%radius_ak135( 44) = 2123060.00000000
+ Mak135_V%radius_ak135( 45) = 2173390.00000000
+ Mak135_V%radius_ak135( 46) = 2223720.00000000
+ Mak135_V%radius_ak135( 47) = 2274050.00000000
+ Mak135_V%radius_ak135( 48) = 2324380.00000000
+ Mak135_V%radius_ak135( 49) = 2374720.00000000
+ Mak135_V%radius_ak135( 50) = 2425050.00000000
+ Mak135_V%radius_ak135( 51) = 2475380.00000000
+ Mak135_V%radius_ak135( 52) = 2525710.00000000
+ Mak135_V%radius_ak135( 53) = 2576040.00000000
+ Mak135_V%radius_ak135( 54) = 2626370.00000000
+ Mak135_V%radius_ak135( 55) = 2676700.00000000
+ Mak135_V%radius_ak135( 56) = 2727030.00000000
+ Mak135_V%radius_ak135( 57) = 2777360.00000000
+ Mak135_V%radius_ak135( 58) = 2827700.00000000
+ Mak135_V%radius_ak135( 59) = 2878030.00000000
+ Mak135_V%radius_ak135( 60) = 2928360.00000000
+ Mak135_V%radius_ak135( 61) = 2978690.00000000
+ Mak135_V%radius_ak135( 62) = 3029020.00000000
+ Mak135_V%radius_ak135( 63) = 3079350.00000000
+ Mak135_V%radius_ak135( 64) = 3129680.00000000
+ Mak135_V%radius_ak135( 65) = 3180010.00000000
+ Mak135_V%radius_ak135( 66) = 3230340.00000000
+ Mak135_V%radius_ak135( 67) = 3280680.00000000
+ Mak135_V%radius_ak135( 68) = 3331010.00000000
+ Mak135_V%radius_ak135( 69) = 3381340.00000000
+ Mak135_V%radius_ak135( 70) = 3431670.00000000
+ Mak135_V%radius_ak135( 71) = 3479500.00000000
+ Mak135_V%radius_ak135( 72) = 3479500.00000000
+ Mak135_V%radius_ak135( 73) = 3531670.00000000
+ Mak135_V%radius_ak135( 74) = 3581330.00000000
+ Mak135_V%radius_ak135( 75) = 3631000.00000000
+ Mak135_V%radius_ak135( 76) = 3631000.00000000
+ Mak135_V%radius_ak135( 77) = 3681000.00000000
+ Mak135_V%radius_ak135( 78) = 3731000.00000000
+ Mak135_V%radius_ak135( 79) = 3779500.00000000
+ Mak135_V%radius_ak135( 80) = 3829000.00000000
+ Mak135_V%radius_ak135( 81) = 3878500.00000000
+ Mak135_V%radius_ak135( 82) = 3928000.00000000
+ Mak135_V%radius_ak135( 83) = 3977500.00000000
+ Mak135_V%radius_ak135( 84) = 4027000.00000000
+ Mak135_V%radius_ak135( 85) = 4076500.00000000
+ Mak135_V%radius_ak135( 86) = 4126000.00000000
+ Mak135_V%radius_ak135( 87) = 4175500.00000000
+ Mak135_V%radius_ak135( 88) = 4225000.00000000
+ Mak135_V%radius_ak135( 89) = 4274500.00000000
+ Mak135_V%radius_ak135( 90) = 4324000.00000000
+ Mak135_V%radius_ak135( 91) = 4373500.00000000
+ Mak135_V%radius_ak135( 92) = 4423000.00000000
+ Mak135_V%radius_ak135( 93) = 4472500.00000000
+ Mak135_V%radius_ak135( 94) = 4522000.00000000
+ Mak135_V%radius_ak135( 95) = 4571500.00000000
+ Mak135_V%radius_ak135( 96) = 4621000.00000000
+ Mak135_V%radius_ak135( 97) = 4670500.00000000
+ Mak135_V%radius_ak135( 98) = 4720000.00000000
+ Mak135_V%radius_ak135( 99) = 4769500.00000000
+ Mak135_V%radius_ak135(100) = 4819000.00000000
+ Mak135_V%radius_ak135(101) = 4868500.00000000
+ Mak135_V%radius_ak135(102) = 4918000.00000000
+ Mak135_V%radius_ak135(103) = 4967500.00000000
+ Mak135_V%radius_ak135(104) = 5017000.00000000
+ Mak135_V%radius_ak135(105) = 5066500.00000000
+ Mak135_V%radius_ak135(106) = 5116000.00000000
+ Mak135_V%radius_ak135(107) = 5165500.00000000
+ Mak135_V%radius_ak135(108) = 5215000.00000000
+ Mak135_V%radius_ak135(109) = 5264500.00000000
+ Mak135_V%radius_ak135(110) = 5314000.00000000
+ Mak135_V%radius_ak135(111) = 5363500.00000000
+ Mak135_V%radius_ak135(112) = 5413000.00000000
+ Mak135_V%radius_ak135(113) = 5462500.00000000
+ Mak135_V%radius_ak135(114) = 5512000.00000000
+ Mak135_V%radius_ak135(115) = 5561500.00000000
+ Mak135_V%radius_ak135(116) = 5611000.00000000
+ Mak135_V%radius_ak135(117) = 5661000.00000000
+ Mak135_V%radius_ak135(118) = 5711000.00000000
+ Mak135_V%radius_ak135(119) = 5711000.00000000
+ Mak135_V%radius_ak135(120) = 5761000.00000000
+ Mak135_V%radius_ak135(121) = 5811000.00000000
+ Mak135_V%radius_ak135(122) = 5861000.00000000
+ Mak135_V%radius_ak135(123) = 5911000.00000000
+ Mak135_V%radius_ak135(124) = 5961000.00000000
+ Mak135_V%radius_ak135(125) = 5961000.00000000
+ Mak135_V%radius_ak135(126) = 6011000.00000000
+ Mak135_V%radius_ak135(127) = 6061000.00000000
+ Mak135_V%radius_ak135(128) = 6111000.00000000
+ Mak135_V%radius_ak135(129) = 6161000.00000000
+ Mak135_V%radius_ak135(130) = 6161000.00000000
+ Mak135_V%radius_ak135(131) = 6206000.00000000
+ Mak135_V%radius_ak135(132) = 6251000.00000000
+ Mak135_V%radius_ak135(133) = 6291000.00000000
+ Mak135_V%radius_ak135(134) = 6291000.00000000
+ Mak135_V%radius_ak135(135) = 6328000.00000000
+ Mak135_V%radius_ak135(136) = 6353000.00000000
+ Mak135_V%radius_ak135(137) = 6353000.00000000
+ Mak135_V%radius_ak135(138) = 6361000.00000000
+ Mak135_V%radius_ak135(139) = 6361000.00000000
+ Mak135_V%radius_ak135(140) = 6367700.00000000
+ Mak135_V%radius_ak135(141) = 6367700.00000000
+ Mak135_V%radius_ak135(142) = 6368000.00000000
+ Mak135_V%radius_ak135(143) = 6368000.00000000
+ Mak135_V%radius_ak135(144) = 6371000.00000000
+
+ Mak135_V%density_ak135( 1) = 13.0122000000000
+ Mak135_V%density_ak135( 2) = 13.0117000000000
+ Mak135_V%density_ak135( 3) = 13.0100000000000
+ Mak135_V%density_ak135( 4) = 13.0074000000000
+ Mak135_V%density_ak135( 5) = 13.0036000000000
+ Mak135_V%density_ak135( 6) = 12.9988000000000
+ Mak135_V%density_ak135( 7) = 12.9929000000000
+ Mak135_V%density_ak135( 8) = 12.9859000000000
+ Mak135_V%density_ak135( 9) = 12.9779000000000
+ Mak135_V%density_ak135( 10) = 12.9688000000000
+ Mak135_V%density_ak135( 11) = 12.9586000000000
+ Mak135_V%density_ak135( 12) = 12.9474000000000
+ Mak135_V%density_ak135( 13) = 12.9351000000000
+ Mak135_V%density_ak135( 14) = 12.9217000000000
+ Mak135_V%density_ak135( 15) = 12.9072000000000
+ Mak135_V%density_ak135( 16) = 12.8917000000000
+ Mak135_V%density_ak135( 17) = 12.8751000000000
+ Mak135_V%density_ak135( 18) = 12.8574000000000
+ Mak135_V%density_ak135( 19) = 12.8387000000000
+ Mak135_V%density_ak135( 20) = 12.8188000000000
+ Mak135_V%density_ak135( 21) = 12.7980000000000
+ Mak135_V%density_ak135( 22) = 12.7760000000000
+ Mak135_V%density_ak135( 23) = 12.7530000000000
+ Mak135_V%density_ak135( 24) = 12.7289000000000
+ Mak135_V%density_ak135( 25) = 12.7037000000000
+ Mak135_V%density_ak135( 26) = 12.1391000000000
+ Mak135_V%density_ak135( 27) = 12.1133000000000
+ Mak135_V%density_ak135( 28) = 12.0867000000000
+ Mak135_V%density_ak135( 29) = 12.0593000000000
+ Mak135_V%density_ak135( 30) = 12.0311000000000
+ Mak135_V%density_ak135( 31) = 12.0001000000000
+ Mak135_V%density_ak135( 32) = 11.9722000000000
+ Mak135_V%density_ak135( 33) = 11.9414000000000
+ Mak135_V%density_ak135( 34) = 11.9098000000000
+ Mak135_V%density_ak135( 35) = 11.8772000000000
+ Mak135_V%density_ak135( 36) = 11.8437000000000
+ Mak135_V%density_ak135( 37) = 11.8092000000000
+ Mak135_V%density_ak135( 38) = 11.7737000000000
+ Mak135_V%density_ak135( 39) = 11.7373000000000
+ Mak135_V%density_ak135( 40) = 11.6998000000000
+ Mak135_V%density_ak135( 41) = 11.6612000000000
+ Mak135_V%density_ak135( 42) = 11.6216000000000
+ Mak135_V%density_ak135( 43) = 11.5809000000000
+ Mak135_V%density_ak135( 44) = 11.5391000000000
+ Mak135_V%density_ak135( 45) = 11.4962000000000
+ Mak135_V%density_ak135( 46) = 11.4521000000000
+ Mak135_V%density_ak135( 47) = 11.4069000000000
+ Mak135_V%density_ak135( 48) = 11.3604000000000
+ Mak135_V%density_ak135( 49) = 11.3127000000000
+ Mak135_V%density_ak135( 50) = 11.2639000000000
+ Mak135_V%density_ak135( 51) = 11.2137000000000
+ Mak135_V%density_ak135( 52) = 11.1623000000000
+ Mak135_V%density_ak135( 53) = 11.1095000000000
+ Mak135_V%density_ak135( 54) = 11.0555000000000
+ Mak135_V%density_ak135( 55) = 11.0001000000000
+ Mak135_V%density_ak135( 56) = 10.9434000000000
+ Mak135_V%density_ak135( 57) = 10.8852000000000
+ Mak135_V%density_ak135( 58) = 10.8257000000000
+ Mak135_V%density_ak135( 59) = 10.7647000000000
+ Mak135_V%density_ak135( 60) = 10.7023000000000
+ Mak135_V%density_ak135( 61) = 10.6385000000000
+ Mak135_V%density_ak135( 62) = 10.5731000000000
+ Mak135_V%density_ak135( 63) = 10.5062000000000
+ Mak135_V%density_ak135( 64) = 10.4378000000000
+ Mak135_V%density_ak135( 65) = 10.3679000000000
+ Mak135_V%density_ak135( 66) = 10.2964000000000
+ Mak135_V%density_ak135( 67) = 10.2233000000000
+ Mak135_V%density_ak135( 68) = 10.1485000000000
+ Mak135_V%density_ak135( 69) = 10.0722000000000
+ Mak135_V%density_ak135( 70) = 9.99420000000000
+ Mak135_V%density_ak135( 71) = 9.91450000000000
+ Mak135_V%density_ak135( 72) = 5.77210000000000
+ Mak135_V%density_ak135( 73) = 5.74580000000000
+ Mak135_V%density_ak135( 74) = 5.71960000000000
+ Mak135_V%density_ak135( 75) = 5.69340000000000
+ Mak135_V%density_ak135( 76) = 5.43870000000000
+ Mak135_V%density_ak135( 77) = 5.41760000000000
+ Mak135_V%density_ak135( 78) = 5.39620000000000
+ Mak135_V%density_ak135( 79) = 5.37480000000000
+ Mak135_V%density_ak135( 80) = 5.35310000000000
+ Mak135_V%density_ak135( 81) = 5.33130000000000
+ Mak135_V%density_ak135( 82) = 5.30920000000000
+ Mak135_V%density_ak135( 83) = 5.28700000000000
+ Mak135_V%density_ak135( 84) = 5.26460000000000
+ Mak135_V%density_ak135( 85) = 5.24200000000000
+ Mak135_V%density_ak135( 86) = 5.21920000000000
+ Mak135_V%density_ak135( 87) = 5.19630000000000
+ Mak135_V%density_ak135( 88) = 5.17320000000000
+ Mak135_V%density_ak135( 89) = 5.14990000000000
+ Mak135_V%density_ak135( 90) = 5.12640000000000
+ Mak135_V%density_ak135( 91) = 5.10270000000000
+ Mak135_V%density_ak135( 92) = 5.07890000000000
+ Mak135_V%density_ak135( 93) = 5.05480000000000
+ Mak135_V%density_ak135( 94) = 5.03060000000000
+ Mak135_V%density_ak135( 95) = 5.00620000000000
+ Mak135_V%density_ak135( 96) = 4.98170000000000
+ Mak135_V%density_ak135( 97) = 4.95700000000000
+ Mak135_V%density_ak135( 98) = 4.93210000000000
+ Mak135_V%density_ak135( 99) = 4.90690000000000
+ Mak135_V%density_ak135(100) = 4.88170000000000
+ Mak135_V%density_ak135(101) = 4.85620000000000
+ Mak135_V%density_ak135(102) = 4.83070000000000
+ Mak135_V%density_ak135(103) = 4.80500000000000
+ Mak135_V%density_ak135(104) = 4.77900000000000
+ Mak135_V%density_ak135(105) = 4.75280000000000
+ Mak135_V%density_ak135(106) = 4.72660000000000
+ Mak135_V%density_ak135(107) = 4.70010000000000
+ Mak135_V%density_ak135(108) = 4.67350000000000
+ Mak135_V%density_ak135(109) = 4.64670000000000
+ Mak135_V%density_ak135(110) = 4.61980000000000
+ Mak135_V%density_ak135(111) = 4.59260000000000
+ Mak135_V%density_ak135(112) = 4.56540000000000
+ Mak135_V%density_ak135(113) = 4.51620000000000
+ Mak135_V%density_ak135(114) = 4.46500000000000
+ Mak135_V%density_ak135(115) = 4.41180000000000
+ Mak135_V%density_ak135(116) = 4.35650000000000
+ Mak135_V%density_ak135(117) = 4.29860000000000
+ Mak135_V%density_ak135(118) = 4.23870000000000
+ Mak135_V%density_ak135(119) = 3.92010000000000
+ Mak135_V%density_ak135(120) = 3.92060000000000
+ Mak135_V%density_ak135(121) = 3.92180000000000
+ Mak135_V%density_ak135(122) = 3.92330000000000
+ Mak135_V%density_ak135(123) = 3.92730000000000
+ Mak135_V%density_ak135(124) = 3.93170000000000
+ Mak135_V%density_ak135(125) = 3.50680000000000
+ Mak135_V%density_ak135(126) = 3.45770000000000
+ Mak135_V%density_ak135(127) = 3.41100000000000
+ Mak135_V%density_ak135(128) = 3.36630000000000
+ Mak135_V%density_ak135(129) = 3.32430000000000
+ Mak135_V%density_ak135(130) = 3.32430000000000
+ Mak135_V%density_ak135(131) = 3.37110000000000
+ Mak135_V%density_ak135(132) = 3.42680000000000
+ Mak135_V%density_ak135(133) = 3.50200000000000
+ Mak135_V%density_ak135(134) = 3.50200000000000
+ Mak135_V%density_ak135(135) = 3.58010000000000
+ Mak135_V%density_ak135(136) = 3.64100000000000
+ Mak135_V%density_ak135(137) = 2.92000000000000
+ Mak135_V%density_ak135(138) = 2.92000000000000
+ Mak135_V%density_ak135(139) = 2.60000000000000
+ Mak135_V%density_ak135(140) = 2.60000000000000
+ Mak135_V%density_ak135(141) = 2.60000000000000
+ Mak135_V%density_ak135(142) = 2.60000000000000
+ Mak135_V%density_ak135(143) = 2.60000000000000
+ Mak135_V%density_ak135(144) = 2.60000000000000
+
+ Mak135_V%vp_ak135( 1) = 11.2622000000000
+ Mak135_V%vp_ak135( 2) = 11.2618000000000
+ Mak135_V%vp_ak135( 3) = 11.2606000000000
+ Mak135_V%vp_ak135( 4) = 11.2586000000000
+ Mak135_V%vp_ak135( 5) = 11.2557000000000
+ Mak135_V%vp_ak135( 6) = 11.2521000000000
+ Mak135_V%vp_ak135( 7) = 11.2477000000000
+ Mak135_V%vp_ak135( 8) = 11.2424000000000
+ Mak135_V%vp_ak135( 9) = 11.2364000000000
+ Mak135_V%vp_ak135( 10) = 11.2295000000000
+ Mak135_V%vp_ak135( 11) = 11.2219000000000
+ Mak135_V%vp_ak135( 12) = 11.2134000000000
+ Mak135_V%vp_ak135( 13) = 11.2041000000000
+ Mak135_V%vp_ak135( 14) = 11.1941000000000
+ Mak135_V%vp_ak135( 15) = 11.1832000000000
+ Mak135_V%vp_ak135( 16) = 11.1715000000000
+ Mak135_V%vp_ak135( 17) = 11.1590000000000
+ Mak135_V%vp_ak135( 18) = 11.1457000000000
+ Mak135_V%vp_ak135( 19) = 11.1316000000000
+ Mak135_V%vp_ak135( 20) = 11.1166000000000
+ Mak135_V%vp_ak135( 21) = 11.0983000000000
+ Mak135_V%vp_ak135( 22) = 11.0850000000000
+ Mak135_V%vp_ak135( 23) = 11.0718000000000
+ Mak135_V%vp_ak135( 24) = 11.0585000000000
+ Mak135_V%vp_ak135( 25) = 11.0427000000000
+ Mak135_V%vp_ak135( 26) = 10.2890000000000
+ Mak135_V%vp_ak135( 27) = 10.2854000000000
+ Mak135_V%vp_ak135( 28) = 10.2745000000000
+ Mak135_V%vp_ak135( 29) = 10.2565000000000
+ Mak135_V%vp_ak135( 30) = 10.2329000000000
+ Mak135_V%vp_ak135( 31) = 10.2049000000000
+ Mak135_V%vp_ak135( 32) = 10.1739000000000
+ Mak135_V%vp_ak135( 33) = 10.1415000000000
+ Mak135_V%vp_ak135( 34) = 10.1095000000000
+ Mak135_V%vp_ak135( 35) = 10.0768000000000
+ Mak135_V%vp_ak135( 36) = 10.0439000000000
+ Mak135_V%vp_ak135( 37) = 10.0103000000000
+ Mak135_V%vp_ak135( 38) = 9.97610000000000
+ Mak135_V%vp_ak135( 39) = 9.94100000000000
+ Mak135_V%vp_ak135( 40) = 9.90510000000000
+ Mak135_V%vp_ak135( 41) = 9.86820000000000
+ Mak135_V%vp_ak135( 42) = 9.83040000000000
+ Mak135_V%vp_ak135( 43) = 9.79140000000000
+ Mak135_V%vp_ak135( 44) = 9.75130000000000
+ Mak135_V%vp_ak135( 45) = 9.71000000000000
+ Mak135_V%vp_ak135( 46) = 9.66730000000000
+ Mak135_V%vp_ak135( 47) = 9.62320000000000
+ Mak135_V%vp_ak135( 48) = 9.57770000000000
+ Mak135_V%vp_ak135( 49) = 9.53060000000000
+ Mak135_V%vp_ak135( 50) = 9.48140000000000
+ Mak135_V%vp_ak135( 51) = 9.42970000000000
+ Mak135_V%vp_ak135( 52) = 9.37600000000000
+ Mak135_V%vp_ak135( 53) = 9.32050000000000
+ Mak135_V%vp_ak135( 54) = 9.26340000000000
+ Mak135_V%vp_ak135( 55) = 9.20420000000000
+ Mak135_V%vp_ak135( 56) = 9.14260000000000
+ Mak135_V%vp_ak135( 57) = 9.07920000000000
+ Mak135_V%vp_ak135( 58) = 9.01380000000000
+ Mak135_V%vp_ak135( 59) = 8.94610000000000
+ Mak135_V%vp_ak135( 60) = 8.87610000000000
+ Mak135_V%vp_ak135( 61) = 8.80360000000000
+ Mak135_V%vp_ak135( 62) = 8.72830000000000
+ Mak135_V%vp_ak135( 63) = 8.64960000000000
+ Mak135_V%vp_ak135( 64) = 8.56920000000000
+ Mak135_V%vp_ak135( 65) = 8.48610000000000
+ Mak135_V%vp_ak135( 66) = 8.40010000000000
+ Mak135_V%vp_ak135( 67) = 8.31220000000000
+ Mak135_V%vp_ak135( 68) = 8.22130000000000
+ Mak135_V%vp_ak135( 69) = 8.12830000000000
+ Mak135_V%vp_ak135( 70) = 8.03820000000000
+ Mak135_V%vp_ak135( 71) = 8.00000000000000
+ Mak135_V%vp_ak135( 72) = 13.6601000000000
+ Mak135_V%vp_ak135( 73) = 13.6570000000000
+ Mak135_V%vp_ak135( 74) = 13.6533000000000
+ Mak135_V%vp_ak135( 75) = 13.6498000000000
+ Mak135_V%vp_ak135( 76) = 13.6498000000000
+ Mak135_V%vp_ak135( 77) = 13.5899000000000
+ Mak135_V%vp_ak135( 78) = 13.5311000000000
+ Mak135_V%vp_ak135( 79) = 13.4741000000000
+ Mak135_V%vp_ak135( 80) = 13.4156000000000
+ Mak135_V%vp_ak135( 81) = 13.3584000000000
+ Mak135_V%vp_ak135( 82) = 13.3017000000000
+ Mak135_V%vp_ak135( 83) = 13.2465000000000
+ Mak135_V%vp_ak135( 84) = 13.1895000000000
+ Mak135_V%vp_ak135( 85) = 13.1337000000000
+ Mak135_V%vp_ak135( 86) = 13.0786000000000
+ Mak135_V%vp_ak135( 87) = 13.0226000000000
+ Mak135_V%vp_ak135( 88) = 12.9663000000000
+ Mak135_V%vp_ak135( 89) = 12.9093000000000
+ Mak135_V%vp_ak135( 90) = 12.8524000000000
+ Mak135_V%vp_ak135( 91) = 12.7956000000000
+ Mak135_V%vp_ak135( 92) = 12.7384000000000
+ Mak135_V%vp_ak135( 93) = 12.6807000000000
+ Mak135_V%vp_ak135( 94) = 12.6226000000000
+ Mak135_V%vp_ak135( 95) = 12.5638000000000
+ Mak135_V%vp_ak135( 96) = 12.5030000000000
+ Mak135_V%vp_ak135( 97) = 12.4427000000000
+ Mak135_V%vp_ak135( 98) = 12.3813000000000
+ Mak135_V%vp_ak135( 99) = 12.3181000000000
+ Mak135_V%vp_ak135(100) = 12.2558000000000
+ Mak135_V%vp_ak135(101) = 12.1912000000000
+ Mak135_V%vp_ak135(102) = 12.1247000000000
+ Mak135_V%vp_ak135(103) = 12.0571000000000
+ Mak135_V%vp_ak135(104) = 11.9891000000000
+ Mak135_V%vp_ak135(105) = 11.9208000000000
+ Mak135_V%vp_ak135(106) = 11.8491000000000
+ Mak135_V%vp_ak135(107) = 11.7768000000000
+ Mak135_V%vp_ak135(108) = 11.7020000000000
+ Mak135_V%vp_ak135(109) = 11.6265000000000
+ Mak135_V%vp_ak135(110) = 11.5493000000000
+ Mak135_V%vp_ak135(111) = 11.4704000000000
+ Mak135_V%vp_ak135(112) = 11.3897000000000
+ Mak135_V%vp_ak135(113) = 11.3068000000000
+ Mak135_V%vp_ak135(114) = 11.2228000000000
+ Mak135_V%vp_ak135(115) = 11.1355000000000
+ Mak135_V%vp_ak135(116) = 11.0553000000000
+ Mak135_V%vp_ak135(117) = 10.9222000000000
+ Mak135_V%vp_ak135(118) = 10.7909000000000
+ Mak135_V%vp_ak135(119) = 10.2000000000000
+ Mak135_V%vp_ak135(120) = 10.0320000000000
+ Mak135_V%vp_ak135(121) = 9.86400000000000
+ Mak135_V%vp_ak135(122) = 9.69620000000000
+ Mak135_V%vp_ak135(123) = 9.52800000000000
+ Mak135_V%vp_ak135(124) = 9.36010000000000
+ Mak135_V%vp_ak135(125) = 9.03020000000000
+ Mak135_V%vp_ak135(126) = 8.84760000000000
+ Mak135_V%vp_ak135(127) = 8.66500000000000
+ Mak135_V%vp_ak135(128) = 8.48220000000000
+ Mak135_V%vp_ak135(129) = 8.30070000000000
+ Mak135_V%vp_ak135(130) = 8.30070000000000
+ Mak135_V%vp_ak135(131) = 8.17500000000000
+ Mak135_V%vp_ak135(132) = 8.05050000000000
+ Mak135_V%vp_ak135(133) = 8.04500000000000
+ Mak135_V%vp_ak135(134) = 8.04000000000000
+ Mak135_V%vp_ak135(135) = 8.03790000000000
+ Mak135_V%vp_ak135(136) = 8.03550000000000
+ Mak135_V%vp_ak135(137) = 6.80000000000000
+ Mak135_V%vp_ak135(138) = 6.80000000000000
+ Mak135_V%vp_ak135(139) = 5.80000000000000
+ Mak135_V%vp_ak135(140) = 5.80000000000000
+ Mak135_V%vp_ak135(141) = 5.80000000000000
+ Mak135_V%vp_ak135(142) = 5.80000000000000
+ Mak135_V%vp_ak135(143) = 5.80000000000000
+ Mak135_V%vp_ak135(144) = 5.80000000000000
+
+ Mak135_V%vs_ak135( 1) = 3.66780000000000
+ Mak135_V%vs_ak135( 2) = 3.66750000000000
+ Mak135_V%vs_ak135( 3) = 3.66670000000000
+ Mak135_V%vs_ak135( 4) = 3.66530000000000
+ Mak135_V%vs_ak135( 5) = 3.66330000000000
+ Mak135_V%vs_ak135( 6) = 3.66080000000000
+ Mak135_V%vs_ak135( 7) = 3.65770000000000
+ Mak135_V%vs_ak135( 8) = 3.65400000000000
+ Mak135_V%vs_ak135( 9) = 3.64980000000000
+ Mak135_V%vs_ak135( 10) = 3.64500000000000
+ Mak135_V%vs_ak135( 11) = 3.63960000000000
+ Mak135_V%vs_ak135( 12) = 3.63370000000000
+ Mak135_V%vs_ak135( 13) = 3.62720000000000
+ Mak135_V%vs_ak135( 14) = 3.62020000000000
+ Mak135_V%vs_ak135( 15) = 3.61260000000000
+ Mak135_V%vs_ak135( 16) = 3.60440000000000
+ Mak135_V%vs_ak135( 17) = 3.59570000000000
+ Mak135_V%vs_ak135( 18) = 3.58640000000000
+ Mak135_V%vs_ak135( 19) = 3.57650000000000
+ Mak135_V%vs_ak135( 20) = 3.56610000000000
+ Mak135_V%vs_ak135( 21) = 3.55510000000000
+ Mak135_V%vs_ak135( 22) = 3.54350000000000
+ Mak135_V%vs_ak135( 23) = 3.53140000000000
+ Mak135_V%vs_ak135( 24) = 3.51870000000000
+ Mak135_V%vs_ak135( 25) = 3.50430000000000
+ Mak135_V%vs_ak135( 26) = 0.000000000000000
+ Mak135_V%vs_ak135( 27) = 0.000000000000000
+ Mak135_V%vs_ak135( 28) = 0.000000000000000
+ Mak135_V%vs_ak135( 29) = 0.000000000000000
+ Mak135_V%vs_ak135( 30) = 0.000000000000000
+ Mak135_V%vs_ak135( 31) = 0.000000000000000
+ Mak135_V%vs_ak135( 32) = 0.000000000000000
+ Mak135_V%vs_ak135( 33) = 0.000000000000000
+ Mak135_V%vs_ak135( 34) = 0.000000000000000
+ Mak135_V%vs_ak135( 35) = 0.000000000000000
+ Mak135_V%vs_ak135( 36) = 0.000000000000000
+ Mak135_V%vs_ak135( 37) = 0.000000000000000
+ Mak135_V%vs_ak135( 38) = 0.000000000000000
+ Mak135_V%vs_ak135( 39) = 0.000000000000000
+ Mak135_V%vs_ak135( 40) = 0.000000000000000
+ Mak135_V%vs_ak135( 41) = 0.000000000000000
+ Mak135_V%vs_ak135( 42) = 0.000000000000000
+ Mak135_V%vs_ak135( 43) = 0.000000000000000
+ Mak135_V%vs_ak135( 44) = 0.000000000000000
+ Mak135_V%vs_ak135( 45) = 0.000000000000000
+ Mak135_V%vs_ak135( 46) = 0.000000000000000
+ Mak135_V%vs_ak135( 47) = 0.000000000000000
+ Mak135_V%vs_ak135( 48) = 0.000000000000000
+ Mak135_V%vs_ak135( 49) = 0.000000000000000
+ Mak135_V%vs_ak135( 50) = 0.000000000000000
+ Mak135_V%vs_ak135( 51) = 0.000000000000000
+ Mak135_V%vs_ak135( 52) = 0.000000000000000
+ Mak135_V%vs_ak135( 53) = 0.000000000000000
+ Mak135_V%vs_ak135( 54) = 0.000000000000000
+ Mak135_V%vs_ak135( 55) = 0.000000000000000
+ Mak135_V%vs_ak135( 56) = 0.000000000000000
+ Mak135_V%vs_ak135( 57) = 0.000000000000000
+ Mak135_V%vs_ak135( 58) = 0.000000000000000
+ Mak135_V%vs_ak135( 59) = 0.000000000000000
+ Mak135_V%vs_ak135( 60) = 0.000000000000000
+ Mak135_V%vs_ak135( 61) = 0.000000000000000
+ Mak135_V%vs_ak135( 62) = 0.000000000000000
+ Mak135_V%vs_ak135( 63) = 0.000000000000000
+ Mak135_V%vs_ak135( 64) = 0.000000000000000
+ Mak135_V%vs_ak135( 65) = 0.000000000000000
+ Mak135_V%vs_ak135( 66) = 0.000000000000000
+ Mak135_V%vs_ak135( 67) = 0.000000000000000
+ Mak135_V%vs_ak135( 68) = 0.000000000000000
+ Mak135_V%vs_ak135( 69) = 0.000000000000000
+ Mak135_V%vs_ak135( 70) = 0.000000000000000
+ Mak135_V%vs_ak135( 71) = 0.000000000000000
+ Mak135_V%vs_ak135( 72) = 7.28170000000000
+ Mak135_V%vs_ak135( 73) = 7.27000000000000
+ Mak135_V%vs_ak135( 74) = 7.25930000000000
+ Mak135_V%vs_ak135( 75) = 7.24850000000000
+ Mak135_V%vs_ak135( 76) = 7.24850000000000
+ Mak135_V%vs_ak135( 77) = 7.22530000000000
+ Mak135_V%vs_ak135( 78) = 7.20310000000000
+ Mak135_V%vs_ak135( 79) = 7.18040000000000
+ Mak135_V%vs_ak135( 80) = 7.15840000000000
+ Mak135_V%vs_ak135( 81) = 7.13680000000000
+ Mak135_V%vs_ak135( 82) = 7.11440000000000
+ Mak135_V%vs_ak135( 83) = 7.09320000000000
+ Mak135_V%vs_ak135( 84) = 7.07220000000000
+ Mak135_V%vs_ak135( 85) = 7.05040000000000
+ Mak135_V%vs_ak135( 86) = 7.02860000000000
+ Mak135_V%vs_ak135( 87) = 7.00690000000000
+ Mak135_V%vs_ak135( 88) = 6.98520000000000
+ Mak135_V%vs_ak135( 89) = 6.96250000000000
+ Mak135_V%vs_ak135( 90) = 6.94160000000000
+ Mak135_V%vs_ak135( 91) = 6.91940000000000
+ Mak135_V%vs_ak135( 92) = 6.89720000000000
+ Mak135_V%vs_ak135( 93) = 6.87430000000000
+ Mak135_V%vs_ak135( 94) = 6.85170000000000
+ Mak135_V%vs_ak135( 95) = 6.82890000000000
+ Mak135_V%vs_ak135( 96) = 6.80560000000000
+ Mak135_V%vs_ak135( 97) = 6.78200000000000
+ Mak135_V%vs_ak135( 98) = 6.75790000000000
+ Mak135_V%vs_ak135( 99) = 6.73230000000000
+ Mak135_V%vs_ak135(100) = 6.70700000000000
+ Mak135_V%vs_ak135(101) = 6.68130000000000
+ Mak135_V%vs_ak135(102) = 6.65540000000000
+ Mak135_V%vs_ak135(103) = 6.62850000000000
+ Mak135_V%vs_ak135(104) = 6.60090000000000
+ Mak135_V%vs_ak135(105) = 6.57280000000000
+ Mak135_V%vs_ak135(106) = 6.54310000000000
+ Mak135_V%vs_ak135(107) = 6.51310000000000
+ Mak135_V%vs_ak135(108) = 6.48220000000000
+ Mak135_V%vs_ak135(109) = 6.45140000000000
+ Mak135_V%vs_ak135(110) = 6.41820000000000
+ Mak135_V%vs_ak135(111) = 6.38600000000000
+ Mak135_V%vs_ak135(112) = 6.35190000000000
+ Mak135_V%vs_ak135(113) = 6.31640000000000
+ Mak135_V%vs_ak135(114) = 6.27990000000000
+ Mak135_V%vs_ak135(115) = 6.24240000000000
+ Mak135_V%vs_ak135(116) = 6.21000000000000
+ Mak135_V%vs_ak135(117) = 6.08980000000000
+ Mak135_V%vs_ak135(118) = 5.96070000000000
+ Mak135_V%vs_ak135(119) = 5.61040000000000
+ Mak135_V%vs_ak135(120) = 5.50470000000000
+ Mak135_V%vs_ak135(121) = 5.39890000000000
+ Mak135_V%vs_ak135(122) = 5.29220000000000
+ Mak135_V%vs_ak135(123) = 5.18640000000000
+ Mak135_V%vs_ak135(124) = 5.08060000000000
+ Mak135_V%vs_ak135(125) = 4.87020000000000
+ Mak135_V%vs_ak135(126) = 4.78320000000000
+ Mak135_V%vs_ak135(127) = 4.69640000000000
+ Mak135_V%vs_ak135(128) = 4.60940000000000
+ Mak135_V%vs_ak135(129) = 4.51840000000000
+ Mak135_V%vs_ak135(130) = 4.51840000000000
+ Mak135_V%vs_ak135(131) = 4.50900000000000
+ Mak135_V%vs_ak135(132) = 4.50000000000000
+ Mak135_V%vs_ak135(133) = 4.49000000000000
+ Mak135_V%vs_ak135(134) = 4.48000000000000
+ Mak135_V%vs_ak135(135) = 4.48560000000000
+ Mak135_V%vs_ak135(136) = 4.48390000000000
+ Mak135_V%vs_ak135(137) = 3.90000000000000
+ Mak135_V%vs_ak135(138) = 3.90000000000000
+ Mak135_V%vs_ak135(139) = 3.20000000000000
+ Mak135_V%vs_ak135(140) = 3.20000000000000
+ Mak135_V%vs_ak135(141) = 3.20000000000000
+ Mak135_V%vs_ak135(142) = 3.20000000000000
+ Mak135_V%vs_ak135(143) = 3.20000000000000
+ Mak135_V%vs_ak135(144) = 3.20000000000000
+
+ if (SUPPRESS_CRUSTAL_MESH) then
+ Mak135_V%vp_ak135(137:144) = Mak135_V%vp_ak135(136)
+ Mak135_V%vs_ak135(137:144) = Mak135_V%vs_ak135(136)
+ Mak135_V%density_ak135(137:144) = Mak135_V%density_ak135(136)
+ endif
+
+ Mak135_V%Qkappa_ak135( 1) = 601.270000000000
+ Mak135_V%Qkappa_ak135( 2) = 601.320000000000
+ Mak135_V%Qkappa_ak135( 3) = 601.460000000000
+ Mak135_V%Qkappa_ak135( 4) = 601.700000000000
+ Mak135_V%Qkappa_ak135( 5) = 602.050000000000
+ Mak135_V%Qkappa_ak135( 6) = 602.490000000000
+ Mak135_V%Qkappa_ak135( 7) = 603.040000000000
+ Mak135_V%Qkappa_ak135( 8) = 603.690000000000
+ Mak135_V%Qkappa_ak135( 9) = 604.440000000000
+ Mak135_V%Qkappa_ak135( 10) = 605.280000000000
+ Mak135_V%Qkappa_ak135( 11) = 606.260000000000
+ Mak135_V%Qkappa_ak135( 12) = 607.310000000000
+ Mak135_V%Qkappa_ak135( 13) = 608.480000000000
+ Mak135_V%Qkappa_ak135( 14) = 609.740000000000
+ Mak135_V%Qkappa_ak135( 15) = 611.120000000000
+ Mak135_V%Qkappa_ak135( 16) = 612.620000000000
+ Mak135_V%Qkappa_ak135( 17) = 614.210000000000
+ Mak135_V%Qkappa_ak135( 18) = 615.930000000000
+ Mak135_V%Qkappa_ak135( 19) = 617.780000000000
+ Mak135_V%Qkappa_ak135( 20) = 619.710000000000
+ Mak135_V%Qkappa_ak135( 21) = 621.500000000000
+ Mak135_V%Qkappa_ak135( 22) = 624.080000000000
+ Mak135_V%Qkappa_ak135( 23) = 626.870000000000
+ Mak135_V%Qkappa_ak135( 24) = 629.890000000000
+ Mak135_V%Qkappa_ak135( 25) = 633.260000000000
+ Mak135_V%Qkappa_ak135( 26) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 27) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 28) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 29) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 30) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 31) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 32) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 33) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 34) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 35) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 36) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 37) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 38) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 39) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 40) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 41) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 42) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 43) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 44) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 45) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 46) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 47) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 48) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 49) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 50) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 51) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 52) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 53) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 54) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 55) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 56) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 57) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 58) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 59) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 60) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 61) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 62) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 63) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 64) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 65) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 66) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 67) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 68) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 69) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 70) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 71) = 57822.0000000000
+ Mak135_V%Qkappa_ak135( 72) = 723.120000000000
+ Mak135_V%Qkappa_ak135( 73) = 725.110000000000
+ Mak135_V%Qkappa_ak135( 74) = 726.870000000000
+ Mak135_V%Qkappa_ak135( 75) = 722.730000000000
+ Mak135_V%Qkappa_ak135( 76) = 933.210000000000
+ Mak135_V%Qkappa_ak135( 77) = 940.880000000000
+ Mak135_V%Qkappa_ak135( 78) = 952.000000000000
+ Mak135_V%Qkappa_ak135( 79) = 960.360000000000
+ Mak135_V%Qkappa_ak135( 80) = 968.460000000000
+ Mak135_V%Qkappa_ak135( 81) = 976.810000000000
+ Mak135_V%Qkappa_ak135( 82) = 985.630000000000
+ Mak135_V%Qkappa_ak135( 83) = 990.770000000000
+ Mak135_V%Qkappa_ak135( 84) = 999.440000000000
+ Mak135_V%Qkappa_ak135( 85) = 1008.79000000000
+ Mak135_V%Qkappa_ak135( 86) = 1018.38000000000
+ Mak135_V%Qkappa_ak135( 87) = 1032.14000000000
+ Mak135_V%Qkappa_ak135( 88) = 1042.07000000000
+ Mak135_V%Qkappa_ak135( 89) = 1048.09000000000
+ Mak135_V%Qkappa_ak135( 90) = 1058.03000000000
+ Mak135_V%Qkappa_ak135( 91) = 1064.23000000000
+ Mak135_V%Qkappa_ak135( 92) = 1070.38000000000
+ Mak135_V%Qkappa_ak135( 93) = 1085.97000000000
+ Mak135_V%Qkappa_ak135( 94) = 1097.16000000000
+ Mak135_V%Qkappa_ak135( 95) = 1108.58000000000
+ Mak135_V%Qkappa_ak135( 96) = 1120.09000000000
+ Mak135_V%Qkappa_ak135( 97) = 1127.02000000000
+ Mak135_V%Qkappa_ak135( 98) = 1134.01000000000
+ Mak135_V%Qkappa_ak135( 99) = 1141.32000000000
+ Mak135_V%Qkappa_ak135(100) = 1148.76000000000
+ Mak135_V%Qkappa_ak135(101) = 1156.04000000000
+ Mak135_V%Qkappa_ak135(102) = 1163.16000000000
+ Mak135_V%Qkappa_ak135(103) = 1170.53000000000
+ Mak135_V%Qkappa_ak135(104) = 1178.19000000000
+ Mak135_V%Qkappa_ak135(105) = 1186.06000000000
+ Mak135_V%Qkappa_ak135(106) = 1193.99000000000
+ Mak135_V%Qkappa_ak135(107) = 1202.04000000000
+ Mak135_V%Qkappa_ak135(108) = 1210.02000000000
+ Mak135_V%Qkappa_ak135(109) = 1217.91000000000
+ Mak135_V%Qkappa_ak135(110) = 1226.52000000000
+ Mak135_V%Qkappa_ak135(111) = 1234.54000000000
+ Mak135_V%Qkappa_ak135(112) = 1243.02000000000
+ Mak135_V%Qkappa_ak135(113) = 1251.69000000000
+ Mak135_V%Qkappa_ak135(114) = 1260.68000000000
+ Mak135_V%Qkappa_ak135(115) = 1269.44000000000
+ Mak135_V%Qkappa_ak135(116) = 1277.93000000000
+ Mak135_V%Qkappa_ak135(117) = 1311.17000000000
+ Mak135_V%Qkappa_ak135(118) = 1350.54000000000
+ Mak135_V%Qkappa_ak135(119) = 428.690000000000
+ Mak135_V%Qkappa_ak135(120) = 425.510000000000
+ Mak135_V%Qkappa_ak135(121) = 422.550000000000
+ Mak135_V%Qkappa_ak135(122) = 419.940000000000
+ Mak135_V%Qkappa_ak135(123) = 417.320000000000
+ Mak135_V%Qkappa_ak135(124) = 413.660000000000
+ Mak135_V%Qkappa_ak135(125) = 377.930000000000
+ Mak135_V%Qkappa_ak135(126) = 366.340000000000
+ Mak135_V%Qkappa_ak135(127) = 355.850000000000
+ Mak135_V%Qkappa_ak135(128) = 346.370000000000
+ Mak135_V%Qkappa_ak135(129) = 338.470000000000
+ Mak135_V%Qkappa_ak135(130) = 200.970000000000
+ Mak135_V%Qkappa_ak135(131) = 188.720000000000
+ Mak135_V%Qkappa_ak135(132) = 182.570000000000
+ Mak135_V%Qkappa_ak135(133) = 182.030000000000
+ Mak135_V%Qkappa_ak135(134) = 1008.71000000000
+ Mak135_V%Qkappa_ak135(135) = 972.770000000000
+ Mak135_V%Qkappa_ak135(136) = 950.500000000000
+ Mak135_V%Qkappa_ak135(137) = 1368.02000000000
+ Mak135_V%Qkappa_ak135(138) = 1368.02000000000
+ Mak135_V%Qkappa_ak135(139) = 1478.30000000000
+ Mak135_V%Qkappa_ak135(140) = 1478.30000000000
+ Mak135_V%Qkappa_ak135(141) = 1478.30000000000
+ Mak135_V%Qkappa_ak135(142) = 1478.30000000000
+ Mak135_V%Qkappa_ak135(143) = 1478.30000000000
+ Mak135_V%Qkappa_ak135(144) = 1478.30000000000
+
+ Mak135_V%Qmu_ak135( 1) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 2) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 3) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 4) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 5) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 6) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 7) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 8) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 9) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 10) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 11) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 12) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 13) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 14) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 15) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 16) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 17) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 18) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 19) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 20) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 21) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 22) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 23) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 24) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 25) = 85.0300000000000
+ Mak135_V%Qmu_ak135( 26) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 27) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 28) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 29) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 30) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 31) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 32) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 33) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 34) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 35) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 36) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 37) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 38) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 39) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 40) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 41) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 42) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 43) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 44) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 45) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 46) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 47) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 48) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 49) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 50) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 51) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 52) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 53) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 54) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 55) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 56) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 57) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 58) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 59) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 60) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 61) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 62) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 63) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 64) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 65) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 66) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 67) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 68) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 69) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 70) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 71) = 0.000000000000000
+ Mak135_V%Qmu_ak135( 72) = 273.970000000000
+ Mak135_V%Qmu_ak135( 73) = 273.970000000000
+ Mak135_V%Qmu_ak135( 74) = 273.970000000000
+ Mak135_V%Qmu_ak135( 75) = 271.740000000000
+ Mak135_V%Qmu_ak135( 76) = 350.880000000000
+ Mak135_V%Qmu_ak135( 77) = 354.610000000000
+ Mak135_V%Qmu_ak135( 78) = 359.710000000000
+ Mak135_V%Qmu_ak135( 79) = 363.640000000000
+ Mak135_V%Qmu_ak135( 80) = 367.650000000000
+ Mak135_V%Qmu_ak135( 81) = 371.750000000000
+ Mak135_V%Qmu_ak135( 82) = 375.940000000000
+ Mak135_V%Qmu_ak135( 83) = 378.790000000000
+ Mak135_V%Qmu_ak135( 84) = 383.140000000000
+ Mak135_V%Qmu_ak135( 85) = 387.600000000000
+ Mak135_V%Qmu_ak135( 86) = 392.160000000000
+ Mak135_V%Qmu_ak135( 87) = 398.410000000000
+ Mak135_V%Qmu_ak135( 88) = 403.230000000000
+ Mak135_V%Qmu_ak135( 89) = 406.500000000000
+ Mak135_V%Qmu_ak135( 90) = 411.520000000000
+ Mak135_V%Qmu_ak135( 91) = 414.940000000000
+ Mak135_V%Qmu_ak135( 92) = 418.410000000000
+ Mak135_V%Qmu_ak135( 93) = 425.530000000000
+ Mak135_V%Qmu_ak135( 94) = 431.030000000000
+ Mak135_V%Qmu_ak135( 95) = 436.680000000000
+ Mak135_V%Qmu_ak135( 96) = 442.480000000000
+ Mak135_V%Qmu_ak135( 97) = 446.430000000000
+ Mak135_V%Qmu_ak135( 98) = 450.450000000000
+ Mak135_V%Qmu_ak135( 99) = 454.550000000000
+ Mak135_V%Qmu_ak135(100) = 458.720000000000
+ Mak135_V%Qmu_ak135(101) = 462.960000000000
+ Mak135_V%Qmu_ak135(102) = 467.290000000000
+ Mak135_V%Qmu_ak135(103) = 471.700000000000
+ Mak135_V%Qmu_ak135(104) = 476.190000000000
+ Mak135_V%Qmu_ak135(105) = 480.770000000000
+ Mak135_V%Qmu_ak135(106) = 485.440000000000
+ Mak135_V%Qmu_ak135(107) = 490.200000000000
+ Mak135_V%Qmu_ak135(108) = 495.050000000000
+ Mak135_V%Qmu_ak135(109) = 500.000000000000
+ Mak135_V%Qmu_ak135(110) = 505.050000000000
+ Mak135_V%Qmu_ak135(111) = 510.200000000000
+ Mak135_V%Qmu_ak135(112) = 515.460000000000
+ Mak135_V%Qmu_ak135(113) = 520.830000000000
+ Mak135_V%Qmu_ak135(114) = 526.320000000000
+ Mak135_V%Qmu_ak135(115) = 531.910000000000
+ Mak135_V%Qmu_ak135(116) = 537.630000000000
+ Mak135_V%Qmu_ak135(117) = 543.480000000000
+ Mak135_V%Qmu_ak135(118) = 549.450000000000
+ Mak135_V%Qmu_ak135(119) = 172.930000000000
+ Mak135_V%Qmu_ak135(120) = 170.820000000000
+ Mak135_V%Qmu_ak135(121) = 168.780000000000
+ Mak135_V%Qmu_ak135(122) = 166.800000000000
+ Mak135_V%Qmu_ak135(123) = 164.870000000000
+ Mak135_V%Qmu_ak135(124) = 162.500000000000
+ Mak135_V%Qmu_ak135(125) = 146.570000000000
+ Mak135_V%Qmu_ak135(126) = 142.760000000000
+ Mak135_V%Qmu_ak135(127) = 139.380000000000
+ Mak135_V%Qmu_ak135(128) = 136.380000000000
+ Mak135_V%Qmu_ak135(129) = 133.720000000000
+ Mak135_V%Qmu_ak135(130) = 79.4000000000000
+ Mak135_V%Qmu_ak135(131) = 76.5500000000000
+ Mak135_V%Qmu_ak135(132) = 76.0600000000000
+ Mak135_V%Qmu_ak135(133) = 75.6000000000000
+ Mak135_V%Qmu_ak135(134) = 417.590000000000
+ Mak135_V%Qmu_ak135(135) = 403.930000000000
+ Mak135_V%Qmu_ak135(136) = 394.620000000000
+ Mak135_V%Qmu_ak135(137) = 599.990000000000
+ Mak135_V%Qmu_ak135(138) = 599.990000000000
+ Mak135_V%Qmu_ak135(139) = 599.990000000000
+ Mak135_V%Qmu_ak135(140) = 599.990000000000
+ Mak135_V%Qmu_ak135(141) = 599.990000000000
+ Mak135_V%Qmu_ak135(142) = 599.990000000000
+ Mak135_V%Qmu_ak135(143) = 599.990000000000
+ Mak135_V%Qmu_ak135(144) = 599.990000000000
+
+! strip the crust and replace it by mantle
+ if(USE_EXTERNAL_CRUSTAL_MODEL) then
+ do i=NR_AK135-8,NR_AK135
+ Mak135_V%density_ak135(i) = Mak135_V%density_ak135(NR_AK135-9)
+ Mak135_V%vp_ak135(i) = Mak135_V%vp_ak135(NR_AK135-9)
+ Mak135_V%vs_ak135(i) = Mak135_V%vs_ak135(NR_AK135-9)
+ Mak135_V%Qkappa_ak135(i) = Mak135_V%Qkappa_ak135(NR_AK135-9)
+ Mak135_V%Qmu_ak135(i) = Mak135_V%Qmu_ak135(NR_AK135-9)
+ enddo
+ endif
+
+ end subroutine define_model_ak135
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_iasp91.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_iasp91.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_iasp91.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,229 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine model_iasp91(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling,ONE_CRUST,check_doubling_flag, &
+ RICB,RCMB,RTOPDDOUBLEPRIME,R771,R670,R400,R220,R120,RMOHO,RMIDDLE_CRUST)
+
+ implicit none
+
+ include "constants.h"
+
+! given a normalized radius x, gives the non-dimesionalized density rho,
+! speeds vp and vs, and the quality factors Qkappa and Qmu
+
+ logical check_doubling_flag
+
+ integer idoubling,myrank
+
+ double precision x,rho,vp,vs,Qkappa,Qmu,RICB,RCMB,RTOPDDOUBLEPRIME,R771,R670,R400,R220,R120,RMOHO,RMIDDLE_CRUST
+
+ logical ONE_CRUST
+
+ double precision r,scaleval
+
+ double precision x1,x2
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+ x1 = R120 / R_EARTH
+ x2 = RMOHO / R_EARTH
+
+! check flags to make sure we correctly honor the discontinuities
+! we use strict inequalities since r has been slighly changed in mesher
+
+ if(check_doubling_flag) then
+
+!
+!--- inner core
+!
+ if(r >= 0.d0 .and. r < RICB) then
+ if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. &
+ idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_IN_FICTITIOUS_CUBE) &
+ call exit_MPI(myrank,'wrong doubling flag for inner core point')
+!
+!--- outer core
+!
+ else if(r > RICB .and. r < RCMB) then
+ if(idoubling /= IFLAG_OUTER_CORE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for outer core point')
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for D" point')
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r < R670) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point')
+
+!
+!--- mantle: from d670 to d220
+!
+ else if(r > R670 .and. r < R220) then
+ if(idoubling /= IFLAG_670_220) &
+ call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point')
+
+!
+!--- mantle and crust: from d220 to MOHO and then to surface
+!
+ else if(r > R220) then
+ if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) &
+ call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point')
+
+ endif
+
+ endif
+
+!
+!--- inner core
+!
+ if(r >= 0.d0 .and. r <= RICB) then
+ rho=13.0885d0-8.8381d0*x*x
+ vp=11.24094-4.09689*x**2
+ vs=3.56454-3.45241*x**2
+ Qmu=84.6d0
+ Qkappa=1327.7d0
+!
+!--- outer core
+!
+ else if(r > RICB .and. r <= RCMB) then
+ rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
+ vp=10.03904+3.75665*x-13.67046*x**2
+ vs=0.0d0
+ Qmu=0.0d0
+ Qkappa=57827.0d0
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=14.49470-1.47089*x
+ vs=8.16616-1.58206*x
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=25.1486-41.1538*x+51.9932*x**2-26.6083*x**3
+ vs=12.9303-21.2590*x+27.8988*x**2-14.1080*x**3
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+ else if(r > R771 .and. r <= R670) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=25.96984-16.93412*x
+ vs=20.76890-16.53147*x
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: above d670
+!
+ else if(r > R670 .and. r <= R400) then
+ rho=5.3197d0-1.4836d0*x
+ vp=29.38896-21.40656*x
+ vs=17.70732-13.50652*x
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R400 .and. r <= R220) then
+ rho=7.1089d0-3.8045d0*x
+ vp=30.78765-23.25415*x
+ vs=15.24213-11.08552*x
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+
+! from Sebastien Chevrot: for the IASP91 model
+! Depth R Vp Vs
+! 0-20 6351-6371 5.80 3.36
+! 20-35 6336-6351 6.50 3.75
+! 35-120 6251-6336 8.78541-0.74953 x 6.706231-2.248585 x
+! with x = r / 6371
+
+ else if(r > R220 .and. r <= R120) then
+ rho=2.6910d0+0.6924d0*x
+ vp=25.41389-17.69722*x
+ vs=5.75020-1.27420*x
+ Qmu=80.0d0
+ Qkappa=57827.0d0
+
+ else if(r > R120 .and. r <= RMOHO) then
+ vp = 8.78541d0-0.74953d0*x
+ vs = 6.706231d0-2.248585d0*x
+ rho = 3.3713d0 + (3.3198d0-3.3713d0)*(x-x1)/(x2-x1)
+ if(rho < 3.30d0 .or. rho > 3.38d0) stop 'incorrect density computed for IASP91'
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+ else if (SUPPRESS_CRUSTAL_MESH) then
+!! DK DK extend the Moho up to the surface instead of the crust
+ vp = 8.78541d0-0.74953d0*(RMOHO / R_EARTH)
+ vs = 6.706231d0-2.248585d0*(RMOHO / R_EARTH)
+ rho = 3.3198d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+ else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
+ vp = 6.5d0
+ vs = 3.75d0
+ rho = 2.92d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+! same properties everywhere in PREM crust if we decide to define only one layer in the crust
+ if(ONE_CRUST) then
+ vp = 5.8d0
+ vs = 3.36d0
+ rho = 2.72d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+
+ else
+ vp = 5.8d0
+ vs = 3.36d0
+ rho = 2.72d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ rho=rho*1000.0d0/RHOAV
+ vp=vp*1000.0d0/(R_EARTH*scaleval)
+ vs=vs*1000.0d0/(R_EARTH*scaleval)
+
+ end subroutine model_iasp91
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_jp1d.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_jp1d.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_jp1d.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,204 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+subroutine model_jp1d(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling, &
+ check_doubling_flag,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST)
+
+ implicit none
+
+ include "constants.h"
+
+ ! given a normalized radius x, gives the non-dimesionalized density rho,
+! speeds vp and vs, and the quality factors Qkappa and Qmu
+
+ logical check_doubling_flag
+ integer idoubling,myrank
+
+ double precision x,rho,vp,vs,Qkappa,Qmu,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST
+
+ double precision r
+ double precision scaleval
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+! check flags to make sure we correctly honor the discontinuities
+! we use strict inequalities since r has been slighly changed in mesher
+
+ if(check_doubling_flag) then
+
+!--- inner core
+!
+ if(r >= 0.d0 .and. r < RICB) then
+ if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. &
+ idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_IN_FICTITIOUS_CUBE) &
+ call exit_MPI(myrank,'wrong doubling flag for inner core point')
+!
+!--- outer core
+!
+ else if(r > RICB .and. r < RCMB) then
+ if(idoubling /= IFLAG_OUTER_CORE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for outer core point')
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for D" point')
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r < R670) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point')
+
+!
+!--- mantle: from d670 to d220
+!
+ else if(r > R670 .and. r < R220) then
+ if(idoubling /= IFLAG_670_220) &
+ call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point')
+
+!
+!--- mantle and crust: from d220 to MOHO and then to surface
+!
+ else if(r > R220) then
+ if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) &
+ call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point')
+
+ endif
+
+ endif
+
+
+!
+!--- inner core
+!
+ if (r >= 0.d0 .and. r <= RICB) then
+ rho=13.0885d0-8.8381d0*x*x
+ vp=11.24094-4.09689*x**2
+ vs=3.56454-3.45241*x**2
+ Qmu=84.6d0
+ Qkappa=1327.7d0
+!
+!--- outer core
+!
+ else if (r > RICB .and. r <= RCMB) then
+ rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
+ vp=10.03904+3.75665*x-13.67046*x**2
+ vs=0.0d0
+ Qmu=0.0d0
+ Qkappa=57827.0d0
+!
+!--- D" at the base of the mantle
+!
+ else if (r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=14.49470-1.47089*x
+ vs=8.16616-1.58206*x
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=-355.58324*x**4 + 1002.03178*x**3 - 1057.3873425*x**2 + 487.0891011*x - 68.520645
+ vs=-243.33862*x**4 + 668.06411*x**3 - 685.20113*x**2 + 308.04893*x - 43.737642
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+ else if(r > R771 .and. r <= R670) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=-174.468866*x**2 + 286.37769*x - 106.034798
+ vs=-81.0865*x*x + 129.67095*x - 45.268933
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: above d670
+!
+ else if(r > R670 .and. r <= 5871000.d0) then
+ vp=-300.510146*x*x + 511.17372648*x - 206.265832
+ vs=-139.78275*x*x + 233.3097462*x - 91.0129372
+ rho=3.3d0 + (vs-4.4d0)*0.7d0
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+
+ else if(r > 5871000.d0 .and. r <= R400) then
+ vp=-601.0202917*x*x + 1063.3823*x - 459.9388738
+ vs=-145.2465705*x*x + 243.2807524*x - 95.561877
+ rho=3.3d0 + (vs - 4.4d0)*0.7d0
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+
+ else if(r > R400 .and. r <= R220) then
+ vp=25.042512155*x*x - 68.8367583*x + 51.4120272
+ vs=15.540158021*x*x - 40.2087657*x + 28.9578929
+ rho=3.3d0 + (vs - 4.4d0)*0.7d0
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+
+ else if(r > R220 .and. r <= R80) then
+ vp=27.0989608 - 19.473338*x
+ vs=13.920596 - 9.6309917*x
+ rho=3.3d0 + (vs - 4.4d0)*0.7d0
+ Qmu=80.0d0
+ Qkappa=57827.0d0
+
+ else if(r > R80 .and. r <= RMOHO) then
+ vp=26.7663028 - 19.13645*x
+ vs=13.4601434 - 9.164683*x
+ rho=3.3d0 + (vs - 4.4d0)*0.7d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+ else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
+ rho=2.9d0
+ vp = 6.7d0
+ vs = 3.8d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ else
+ rho=2.6d0
+ vp = 6.0d0
+ vs = 3.5d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ end if
+
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ rho=rho*1000.0d0/RHOAV
+ vp=vp*1000.0d0/(R_EARTH*scaleval)
+ vs=vs*1000.0d0/(R_EARTH*scaleval)
+end subroutine model_jp1d
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_prem.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_prem.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_prem.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,609 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine prem_iso(myrank,x,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, &
+ ONE_CRUST,check_doubling_flag,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ implicit none
+
+ include "constants.h"
+
+! given a normalized radius x, gives the non-dimesionalized density rho,
+! speeds vp and vs, and the quality factors Qkappa and Qmu
+
+ logical CRUSTAL,ONE_CRUST,check_doubling_flag
+
+ integer idoubling,myrank
+
+ double precision x,rho,drhodr,vp,vs,Qkappa,Qmu,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
+
+ double precision r
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+! check flags to make sure we correctly honor the discontinuities
+! we use strict inequalities since r has been slighly changed in mesher
+
+ if(check_doubling_flag) then
+
+!
+!--- inner core
+!
+
+ if(r >= 0.d0 .and. r < RICB) then
+ if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. &
+ idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_IN_FICTITIOUS_CUBE) &
+ call exit_MPI(myrank,'wrong doubling flag for inner core point')
+!
+!--- outer core
+!
+ else if(r > RICB .and. r < RCMB) then
+ if(idoubling /= IFLAG_OUTER_CORE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for outer core point')
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for D" point')
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r < R670) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point')
+
+!
+!--- mantle: from d670 to d220
+!
+ else if(r > R670 .and. r < R220) then
+ if(idoubling /= IFLAG_670_220) &
+ call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point')
+
+!
+!--- mantle and crust: from d220 to MOHO and then to surface
+!
+ else if(r > R220) then
+ if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) &
+ call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point')
+
+ endif
+
+ endif
+
+!
+!--- inner core
+!
+ if(r >= 0.d0 .and. r <= RICB) then
+ drhodr=-2.0d0*8.8381d0*x
+ rho=13.0885d0-8.8381d0*x*x
+ vp=11.2622d0-6.3640d0*x*x
+ vs=3.6678d0-4.4475d0*x*x
+ Qmu=84.6d0
+ Qkappa=1327.7d0
+!
+!--- outer core
+!
+ else if(r > RICB .and. r <= RCMB) then
+ drhodr=-1.2638d0-2.0d0*3.6426d0*x-3.0d0*5.5281d0*x*x
+ rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
+ vp=11.0487d0-4.0362d0*x+4.8023d0*x*x-13.5732d0*x*x*x
+ vs=0.0d0
+ Qmu=0.0d0
+ Qkappa=57827.0d0
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
+ drhodr=-6.4761d0+2.0d0*5.5283d0*x-3.0d0*3.0807d0*x*x
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=15.3891d0-5.3181d0*x+5.5242d0*x*x-2.5514d0*x*x*x
+ vs=6.9254d0+1.4672d0*x-2.0834d0*x*x+0.9783d0*x*x*x
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
+ drhodr=-6.4761d0+2.0d0*5.5283d0*x-3.0d0*3.0807d0*x*x
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=24.9520d0-40.4673d0*x+51.4832d0*x*x-26.6419d0*x*x*x
+ vs=11.1671d0-13.7818d0*x+17.4575d0*x*x-9.2777d0*x*x*x
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+ else if(r > R771 .and. r <= R670) then
+ drhodr=-6.4761d0+2.0d0*5.5283d0*x-3.0d0*3.0807d0*x*x
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=29.2766d0-23.6027d0*x+5.5242d0*x*x-2.5514d0*x*x*x
+ vs=22.3459d0-17.2473d0*x-2.0834d0*x*x+0.9783d0*x*x*x
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: above d670
+!
+ else if(r > R670 .and. r <= R600) then
+ drhodr=-1.4836d0
+ rho=5.3197d0-1.4836d0*x
+ vp=19.0957d0-9.8672d0*x
+ vs=9.9839d0-4.9324d0*x
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R600 .and. r <= R400) then
+ drhodr=-8.0298d0
+ rho=11.2494d0-8.0298d0*x
+ vp=39.7027d0-32.6166d0*x
+ vs=22.3512d0-18.5856d0*x
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R400 .and. r <= R220) then
+ drhodr=-3.8045d0
+ rho=7.1089d0-3.8045d0*x
+ vp=20.3926d0-12.2569d0*x
+ vs=8.9496d0-4.4597d0*x
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R220 .and. r <= R80) then
+ drhodr=0.6924d0
+ rho=2.6910d0+0.6924d0*x
+ vp=4.1875d0+3.9382d0*x
+ vs=2.1519d0+2.3481d0*x
+ Qmu=80.0d0
+ Qkappa=57827.0d0
+ else
+ if(CRUSTAL .and. .not. SUPPRESS_CRUSTAL_MESH) then
+! fill with PREM mantle and later add CRUST2.0
+ if(r > R80) then
+ drhodr=0.6924d0
+ rho=2.6910d0+0.6924d0*x
+ vp=4.1875d0+3.9382d0*x
+ vs=2.1519d0+2.3481d0*x
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+ else
+! use PREM crust
+ if(r > R80 .and. r <= RMOHO) then
+ drhodr=0.6924d0
+ rho=2.6910d0+0.6924d0*x
+ vp=4.1875d0+3.9382d0*x
+ vs=2.1519d0+2.3481d0*x
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+
+ else if (SUPPRESS_CRUSTAL_MESH) then
+!! DK DK extend the Moho up to the surface instead of the crust
+ drhodr=0.6924d0
+ rho = 2.6910d0+0.6924d0*(RMOHO / R_EARTH)
+ vp = 4.1875d0+3.9382d0*(RMOHO / R_EARTH)
+ vs = 2.1519d0+2.3481d0*(RMOHO / R_EARTH)
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+ else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
+ drhodr=0.0d0
+ rho=2.9d0
+ vp=6.8d0
+ vs=3.9d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+! same properties everywhere in PREM crust if we decide to define only one layer in the crust
+ if(ONE_CRUST) then
+ drhodr=0.0d0
+ rho=2.6d0
+ vp=5.8d0
+ vs=3.2d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+
+ else if(r > RMIDDLE_CRUST .and. r <= ROCEAN) then
+ drhodr=0.0d0
+ rho=2.6d0
+ vp=5.8d0
+ vs=3.2d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+! for density profile for gravity, we do not check that r <= R_EARTH
+ else if(r > ROCEAN) then
+ drhodr=0.0d0
+ rho=2.6d0
+ vp=5.8d0
+ vs=3.2d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+ endif
+ endif
+ endif
+
+! non-dimensionalize
+ rho=rho*1000.0d0
+ vp=vp*1000.0d0
+ vs=vs*1000.0d0
+
+ end subroutine prem_iso
+
+!
+!=====================================================================
+!
+
+ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, &
+ idoubling,CRUSTAL,ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ implicit none
+
+ include "constants.h"
+
+! given a normalized radius x, gives the non-dimesionalized density rho,
+! speeds vp and vs, and the quality factors Qkappa and Qmu
+
+ logical CRUSTAL,ONE_CRUST
+
+ integer idoubling,myrank
+
+ double precision x,rho,Qkappa,Qmu,vpv,vph,vsv,vsh,eta_aniso,RICB,RCMB, &
+ RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
+
+ double precision r
+ double precision scaleval
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+! check flags to make sure we correctly honor the discontinuities
+! we use strict inequalities since r has been slighly changed in mesher
+
+!
+!--- inner core
+!
+ if(r >= 0.d0 .and. r < RICB) then
+ if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. &
+ idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_IN_FICTITIOUS_CUBE) &
+ call exit_MPI(myrank,'wrong doubling flag for inner core point')
+!
+!--- outer core
+!
+ else if(r > RICB .and. r < RCMB) then
+ if(idoubling /= IFLAG_OUTER_CORE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for outer core point')
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for D" point')
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r < R670) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point')
+
+!
+!--- mantle: from d670 to d220
+!
+ else if(r > R670 .and. r < R220) then
+ if(idoubling /= IFLAG_670_220) &
+ call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point')
+
+!
+!--- mantle and crust: from d220 to MOHO and then to surface
+!
+ else if(r > R220) then
+ if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) &
+ call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point')
+
+ endif
+
+! no anisotropy by default
+ eta_aniso = 1.d0
+
+!
+!--- inner core
+!
+ if(r >= 0.d0 .and. r <= RICB) then
+ rho=13.0885d0-8.8381d0*x*x
+ vpv=11.2622d0-6.3640d0*x*x
+ vsv=3.6678d0-4.4475d0*x*x
+ vph=vpv
+ vsh=vsv
+ Qmu=84.6d0
+ Qkappa=1327.7d0
+!
+!--- outer core
+!
+ else if(r > RICB .and. r <= RCMB) then
+ rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
+ vpv=11.0487d0-4.0362d0*x+4.8023d0*x*x-13.5732d0*x*x*x
+ vsv=0.0d0
+ vph=vpv
+ vsh=vsv
+ Qmu=0.0d0
+ Qkappa=57827.0d0
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vpv=15.3891d0-5.3181d0*x+5.5242d0*x*x-2.5514d0*x*x*x
+ vsv=6.9254d0+1.4672d0*x-2.0834d0*x*x+0.9783d0*x*x*x
+ vph=vpv
+ vsh=vsv
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vpv=24.9520d0-40.4673d0*x+51.4832d0*x*x-26.6419d0*x*x*x
+ vsv=11.1671d0-13.7818d0*x+17.4575d0*x*x-9.2777d0*x*x*x
+ vph=vpv
+ vsh=vsv
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+ else if(r > R771 .and. r <= R670) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vpv=29.2766d0-23.6027d0*x+5.5242d0*x*x-2.5514d0*x*x*x
+ vsv=22.3459d0-17.2473d0*x-2.0834d0*x*x+0.9783d0*x*x*x
+ vph=vpv
+ vsh=vsv
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: above d670
+!
+ else if(r > R670 .and. r <= R600) then
+ rho=5.3197d0-1.4836d0*x
+ vpv=19.0957d0-9.8672d0*x
+ vsv=9.9839d0-4.9324d0*x
+ vph=vpv
+ vsh=vsv
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R600 .and. r <= R400) then
+ rho=11.2494d0-8.0298d0*x
+ vpv=39.7027d0-32.6166d0*x
+ vsv=22.3512d0-18.5856d0*x
+ vph=vpv
+ vsh=vsv
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R400 .and. r <= R220) then
+ rho=7.1089d0-3.8045d0*x
+ vpv=20.3926d0-12.2569d0*x
+ vsv=8.9496d0-4.4597d0*x
+ vph=vpv
+ vsh=vsv
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R220 .and. r <= R80) then
+
+! anisotropy in PREM only above 220 km
+
+ rho=2.6910d0+0.6924d0*x
+ vpv=0.8317d0+7.2180d0*x
+ vph=3.5908d0+4.6172d0*x
+ vsv=5.8582d0-1.4678d0*x
+ vsh=-1.0839d0+5.7176d0*x
+ eta_aniso=3.3687d0-2.4778d0*x
+ Qmu=80.0d0
+ Qkappa=57827.0d0
+
+ else
+ if(CRUSTAL) then
+! fill with PREM mantle and later add CRUST2.0
+ if(r > R80) then
+ rho=2.6910d0+0.6924d0*x
+ vpv=0.8317d0+7.2180d0*x
+ vph=3.5908d0+4.6172d0*x
+ vsv=5.8582d0-1.4678d0*x
+ vsh=-1.0839d0+5.7176d0*x
+ eta_aniso=3.3687d0-2.4778d0*x
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+ else
+! use PREM crust
+ if(r > R80 .and. r <= RMOHO) then
+
+! anisotropy in PREM only above 220 km
+
+ rho=2.6910d0+0.6924d0*x
+ vpv=0.8317d0+7.2180d0*x
+ vph=3.5908d0+4.6172d0*x
+ vsv=5.8582d0-1.4678d0*x
+ vsh=-1.0839d0+5.7176d0*x
+ eta_aniso=3.3687d0-2.4778d0*x
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+! no anisotropy in the crust in PREM
+
+ else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
+ rho=2.9d0
+ vpv=6.8d0
+ vsv=3.9d0
+ vph=vpv
+ vsh=vsv
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+! same properties everywhere in PREM crust (only one layer in the crust)
+ if(ONE_CRUST) then
+ rho=2.6d0
+ vpv=5.8d0
+ vsv=3.2d0
+ vph=vpv
+ vsh=vsv
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+
+ else if(r > RMIDDLE_CRUST .and. r <= ROCEAN) then
+ rho=2.6d0
+ vpv=5.8d0
+ vsv=3.2d0
+ vph=vpv
+ vsh=vsv
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ else if(r > ROCEAN) then
+ rho=2.6d0
+ vpv=5.8d0
+ vsv=3.2d0
+ vph=vpv
+ vsh=vsv
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+ endif
+ endif
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+! do not scale anisotropy parameter eta_aniso, which is dimensionless
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ rho=rho*1000.0d0/RHOAV
+ vpv=vpv*1000.0d0/(R_EARTH*scaleval)
+ vsv=vsv*1000.0d0/(R_EARTH*scaleval)
+ vph=vph*1000.0d0/(R_EARTH*scaleval)
+ vsh=vsh*1000.0d0/(R_EARTH*scaleval)
+
+ end subroutine prem_aniso
+
+!
+!=====================================================================
+!
+
+ subroutine prem_display_outer_core(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling)
+
+! routine used for AVS or DX display of stability condition
+! and number of points per wavelength only in the fluid outer core
+
+ implicit none
+
+ include "constants.h"
+
+! given a normalized radius x, gives the non-dimesionalized density rho,
+! speeds vp and vs, and the quality factors Qkappa and Qmu
+
+ integer idoubling,myrank
+ double precision x,rho,vp,vs,Qkappa,Qmu
+
+ double precision scaleval
+
+ if(idoubling /= IFLAG_OUTER_CORE_NORMAL) call exit_MPI(myrank,'wrong doubling flag for outer core point')
+
+!
+!--- outer core
+!
+ rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
+ vp=11.0487d0-4.0362d0*x+4.8023d0*x*x-13.5732d0*x*x*x
+ vs=0.0d0
+ Qmu=0.0d0
+ Qkappa=57827.0d0
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval = dsqrt(PI*GRAV*RHOAV)
+ rho = rho*1000.0d0/RHOAV
+ vp = vp*1000.0d0/(R_EARTH*scaleval)
+ vs = vs*1000.0d0/(R_EARTH*scaleval)
+
+ end subroutine prem_display_outer_core
+
+!
+!=====================================================================
+!
+
+ subroutine prem_density(x,rho,ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision x,rho,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
+
+ logical ONE_CRUST
+
+ double precision r
+
+ r = x * R_EARTH
+
+ if(r <= RICB) then
+ rho=13.0885d0-8.8381d0*x*x
+ else if(r > RICB .and. r <= RCMB) then
+ rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
+ else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ else if(r > R771 .and. r <= R670) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ else if(r > R670 .and. r <= R600) then
+ rho=5.3197d0-1.4836d0*x
+ else if(r > R600 .and. r <= R400) then
+ rho=11.2494d0-8.0298d0*x
+ else if(r > R400 .and. r <= R220) then
+ rho=7.1089d0-3.8045d0*x
+ else if(r > R220 .and. r <= R80) then
+ rho=2.6910d0+0.6924d0*x
+ else
+ if(r > R80 .and. r <= RMOHO) then
+ rho=2.6910d0+0.6924d0*x
+ else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
+ if(ONE_CRUST) then
+ rho=2.6d0
+ else
+ rho=2.9d0
+ endif
+ else if(r > RMIDDLE_CRUST .and. r <= ROCEAN) then
+ rho=2.6d0
+ else if(r > ROCEAN) then
+ rho=2.6d0
+ endif
+ endif
+
+ rho=rho*1000.0d0/RHOAV
+
+ end subroutine prem_density
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_ref.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_ref.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_ref.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,7374 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+
+ subroutine model_ref(x,rho,vpv,vph,vsv,vsh,eta,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V)
+
+ implicit none
+
+ include "constants.h"
+
+! model_ref_variables
+ type model_ref_variables
+ sequence
+ double precision, dimension(NR_REF) :: radius_ref
+ double precision, dimension(NR_REF) :: density_ref
+ double precision, dimension(NR_REF) :: vpv_ref
+ double precision, dimension(NR_REF) :: vph_ref
+ double precision, dimension(NR_REF) :: vsv_ref
+ double precision, dimension(NR_REF) :: vsh_ref
+ double precision, dimension(NR_REF) :: eta_ref
+ double precision, dimension(NR_REF) :: Qkappa_ref
+ double precision, dimension(NR_REF) :: Qmu_ref
+ end type model_ref_variables
+
+ type (model_ref_variables) Mref_V
+! model_ref_variables
+
+! input:
+! dimensionless radius x
+
+! output: non-dimensionalized
+! mass density rho
+! compressional wave speed vpv
+! compressional wave speed vph
+! shear wave speed vsv
+! shear wave speed vsh
+! dimensionless parameter eta
+! shear quality factor Qmu
+! bulk quality factor Qkappa
+
+ integer iregion_code
+
+ double precision x,rho,vpv,vph,vsv,vsh,eta,Qmu,Qkappa
+
+ integer i
+
+ double precision r,frac,scaleval
+ logical CRUSTAL
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+ i = 1
+ do while(r >= Mref_V%radius_ref(i) .and. i /= NR_REF)
+ i = i + 1
+ enddo
+
+! make sure we stay in the right region
+ if(iregion_code == IREGION_INNER_CORE .and. i > 180) i = 180
+
+ if(iregion_code == IREGION_OUTER_CORE .and. i < 182) i = 182
+ if(iregion_code == IREGION_OUTER_CORE .and. i > 358) i = 358
+
+ if(iregion_code == IREGION_CRUST_MANTLE .and. i < 360) i = 360
+ if(CRUSTAL .and. i > 717) i = 717
+
+
+ if(i == 1) then
+ rho = Mref_V%density_ref(i)
+ vpv = Mref_V%vpv_ref(i)
+ vph = Mref_V%vph_ref(i)
+ vsv = Mref_V%vsv_ref(i)
+ vsh = Mref_V%vsh_ref(i)
+ eta = Mref_V%eta_ref(i)
+ Qkappa = Mref_V%Qkappa_ref(i)
+ Qmu = Mref_V%Qmu_ref(i)
+ else
+
+! interpolate from radius_ref(i-1) to r using the values at i-1 and i
+ frac = (r-Mref_V%radius_ref(i-1))/(Mref_V%radius_ref(i)-Mref_V%radius_ref(i-1))
+
+ rho = Mref_V%density_ref(i-1) + frac * (Mref_V%density_ref(i)-Mref_V%density_ref(i-1))
+ vpv = Mref_V%vpv_ref(i-1) + frac * (Mref_V%vpv_ref(i)-Mref_V%vpv_ref(i-1))
+ vph = Mref_V%vph_ref(i-1) + frac * (Mref_V%vph_ref(i)-Mref_V%vph_ref(i-1))
+ vsv = Mref_V%vsv_ref(i-1) + frac * (Mref_V%vsv_ref(i)-Mref_V%vsv_ref(i-1))
+ vsh = Mref_V%vsh_ref(i-1) + frac * (Mref_V%vsh_ref(i)-Mref_V%vsh_ref(i-1))
+ eta = Mref_V%eta_ref(i-1) + frac * (Mref_V%eta_ref(i)-Mref_V%eta_ref(i-1))
+ Qkappa = Mref_V%Qkappa_ref(i-1) + frac * (Mref_V%Qkappa_ref(i)-Mref_V%Qkappa_ref(i-1))
+ Qmu = Mref_V%Qmu_ref(i-1) + frac * (Mref_V%Qmu_ref(i)-Mref_V%Qmu_ref(i-1))
+
+ endif
+
+! make sure Vs is zero in the outer core even if roundoff errors on depth
+! also set fictitious attenuation to a very high value (attenuation is not used in the fluid)
+ if(iregion_code == IREGION_OUTER_CORE) then
+ vsv = 0.d0
+ vsh = 0.d0
+ Qkappa = 3000.d0
+ Qmu = 3000.d0
+ endif
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ rho=rho/RHOAV
+ vpv=vpv/(R_EARTH*scaleval)
+ vph=vph/(R_EARTH*scaleval)
+ vsv=vsv/(R_EARTH*scaleval)
+ vsh=vsh/(R_EARTH*scaleval)
+
+ end subroutine model_ref
+
+!-------------------
+
+ subroutine define_model_ref(Mref_V)
+
+ implicit none
+ include "constants.h"
+
+! model_ref_variables
+ type model_ref_variables
+ sequence
+ double precision, dimension(NR_REF) :: radius_ref
+ double precision, dimension(NR_REF) :: density_ref
+ double precision, dimension(NR_REF) :: vpv_ref
+ double precision, dimension(NR_REF) :: vph_ref
+ double precision, dimension(NR_REF) :: vsv_ref
+ double precision, dimension(NR_REF) :: vsh_ref
+ double precision, dimension(NR_REF) :: eta_ref
+ double precision, dimension(NR_REF) :: Qkappa_ref
+ double precision, dimension(NR_REF) :: Qmu_ref
+ end type model_ref_variables
+
+ type (model_ref_variables) Mref_V
+! model_ref_variables
+
+
+! define the 1D REF model of Kustowski et al. (2007)
+
+ Mref_V%radius_ref( 1 : 30 ) = (/ &
+ 0.000000000000000E+000 , &
+ 6824.00000000000 , &
+ 13648.0000000000 , &
+ 20472.0000000000 , &
+ 27296.0000000000 , &
+ 34120.0000000000 , &
+ 40944.0000000000 , &
+ 47768.0000000000 , &
+ 54592.0000000000 , &
+ 61416.0000000000 , &
+ 68240.0000000000 , &
+ 75064.0000000000 , &
+ 81888.0000000000 , &
+ 88712.0000000000 , &
+ 95536.0000000000 , &
+ 102360.000000000 , &
+ 109184.000000000 , &
+ 116007.000000000 , &
+ 122831.000000000 , &
+ 129655.000000000 , &
+ 136479.000000000 , &
+ 143303.000000000 , &
+ 150127.000000000 , &
+ 156951.000000000 , &
+ 163775.000000000 , &
+ 170599.000000000 , &
+ 177423.000000000 , &
+ 184247.000000000 , &
+ 191071.000000000 , &
+ 197895.000000000 /)
+
+ Mref_V%radius_ref( 31 : 60 ) = (/ &
+ 204719.000000000 , &
+ 211543.000000000 , &
+ 218367.000000000 , &
+ 225191.000000000 , &
+ 232015.000000000 , &
+ 238839.000000000 , &
+ 245663.000000000 , &
+ 252487.000000000 , &
+ 259311.000000000 , &
+ 266135.000000000 , &
+ 272959.000000000 , &
+ 279783.000000000 , &
+ 286607.000000000 , &
+ 293431.000000000 , &
+ 300255.000000000 , &
+ 307079.000000000 , &
+ 313903.000000000 , &
+ 320727.000000000 , &
+ 327551.000000000 , &
+ 334375.000000000 , &
+ 341199.000000000 , &
+ 348022.000000000 , &
+ 354846.000000000 , &
+ 361670.000000000 , &
+ 368494.000000000 , &
+ 375318.000000000 , &
+ 382142.000000000 , &
+ 388966.000000000 , &
+ 395790.000000000 , &
+ 402614.000000000 /)
+
+ Mref_V%radius_ref( 61 : 90 ) = (/ &
+ 409438.000000000 , &
+ 416262.000000000 , &
+ 423086.000000000 , &
+ 429910.000000000 , &
+ 436734.000000000 , &
+ 443558.000000000 , &
+ 450382.000000000 , &
+ 457206.000000000 , &
+ 464030.000000000 , &
+ 470854.000000000 , &
+ 477678.000000000 , &
+ 484502.000000000 , &
+ 491326.000000000 , &
+ 498150.000000000 , &
+ 504974.000000000 , &
+ 511798.000000000 , &
+ 518622.000000000 , &
+ 525446.000000000 , &
+ 532270.000000000 , &
+ 539094.000000000 , &
+ 545918.000000000 , &
+ 552742.000000000 , &
+ 559566.000000000 , &
+ 566390.000000000 , &
+ 573214.000000000 , &
+ 580037.000000000 , &
+ 586861.000000000 , &
+ 593685.000000000 , &
+ 600509.000000000 , &
+ 607333.000000000 /)
+
+ Mref_V%radius_ref( 91 : 120 ) = (/ &
+ 614157.000000000 , &
+ 620981.000000000 , &
+ 627805.000000000 , &
+ 634629.000000000 , &
+ 641453.000000000 , &
+ 648277.000000000 , &
+ 655101.000000000 , &
+ 661925.000000000 , &
+ 668749.000000000 , &
+ 675573.000000000 , &
+ 682397.000000000 , &
+ 689221.000000000 , &
+ 696045.000000000 , &
+ 702869.000000000 , &
+ 709693.000000000 , &
+ 716517.000000000 , &
+ 723341.000000000 , &
+ 730165.000000000 , &
+ 736989.000000000 , &
+ 743813.000000000 , &
+ 750637.000000000 , &
+ 757461.000000000 , &
+ 764285.000000000 , &
+ 771109.000000000 , &
+ 777933.000000000 , &
+ 784757.000000000 , &
+ 791581.000000000 , &
+ 798405.000000000 , &
+ 805229.000000000 , &
+ 812052.000000000 /)
+
+ Mref_V%radius_ref( 121 : 150 ) = (/ &
+ 818876.000000000 , &
+ 825700.000000000 , &
+ 832524.000000000 , &
+ 839348.000000000 , &
+ 846172.000000000 , &
+ 852996.000000000 , &
+ 859820.000000000 , &
+ 866644.000000000 , &
+ 873468.000000000 , &
+ 880292.000000000 , &
+ 887116.000000000 , &
+ 893940.000000000 , &
+ 900764.000000000 , &
+ 907588.000000000 , &
+ 914412.000000000 , &
+ 921236.000000000 , &
+ 928060.000000000 , &
+ 934884.000000000 , &
+ 941708.000000000 , &
+ 948532.000000000 , &
+ 955356.000000000 , &
+ 962180.000000000 , &
+ 969004.000000000 , &
+ 975828.000000000 , &
+ 982652.000000000 , &
+ 989476.000000000 , &
+ 996300.000000000 , &
+ 1003124.00000000 , &
+ 1009948.00000000 , &
+ 1016772.00000000 /)
+
+ Mref_V%radius_ref( 151 : 180 ) = (/ &
+ 1023596.00000000 , &
+ 1030420.00000000 , &
+ 1037244.00000000 , &
+ 1044067.00000000 , &
+ 1050891.00000000 , &
+ 1057715.00000000 , &
+ 1064539.00000000 , &
+ 1071363.00000000 , &
+ 1078187.00000000 , &
+ 1085011.00000000 , &
+ 1091835.00000000 , &
+ 1098659.00000000 , &
+ 1105483.00000000 , &
+ 1112307.00000000 , &
+ 1119131.00000000 , &
+ 1125955.00000000 , &
+ 1132779.00000000 , &
+ 1139603.00000000 , &
+ 1146427.00000000 , &
+ 1153251.00000000 , &
+ 1160075.00000000 , &
+ 1166899.00000000 , &
+ 1173723.00000000 , &
+ 1180547.00000000 , &
+ 1187371.00000000 , &
+ 1194195.00000000 , &
+ 1201019.00000000 , &
+ 1207843.00000000 , &
+ 1214667.00000000 , &
+ 1221491.00000000 /)
+
+ Mref_V%radius_ref( 181 : 210 ) = (/ &
+ 1221491.00000000 , &
+ 1234250.00000000 , &
+ 1247010.00000000 , &
+ 1259770.00000000 , &
+ 1272530.00000000 , &
+ 1285289.00000000 , &
+ 1298049.00000000 , &
+ 1310809.00000000 , &
+ 1323568.00000000 , &
+ 1336328.00000000 , &
+ 1349088.00000000 , &
+ 1361847.00000000 , &
+ 1374607.00000000 , &
+ 1387367.00000000 , &
+ 1400127.00000000 , &
+ 1412886.00000000 , &
+ 1425646.00000000 , &
+ 1438406.00000000 , &
+ 1451165.00000000 , &
+ 1463925.00000000 , &
+ 1476685.00000000 , &
+ 1489444.00000000 , &
+ 1502204.00000000 , &
+ 1514964.00000000 , &
+ 1527724.00000000 , &
+ 1540483.00000000 , &
+ 1553243.00000000 , &
+ 1566003.00000000 , &
+ 1578762.00000000 , &
+ 1591522.00000000 /)
+
+ Mref_V%radius_ref( 211 : 240 ) = (/ &
+ 1604282.00000000 , &
+ 1617041.00000000 , &
+ 1629801.00000000 , &
+ 1642561.00000000 , &
+ 1655321.00000000 , &
+ 1668080.00000000 , &
+ 1680840.00000000 , &
+ 1693600.00000000 , &
+ 1706359.00000000 , &
+ 1719119.00000000 , &
+ 1731879.00000000 , &
+ 1744638.00000000 , &
+ 1757398.00000000 , &
+ 1770158.00000000 , &
+ 1782918.00000000 , &
+ 1795677.00000000 , &
+ 1808437.00000000 , &
+ 1821197.00000000 , &
+ 1833956.00000000 , &
+ 1846716.00000000 , &
+ 1859476.00000000 , &
+ 1872235.00000000 , &
+ 1884995.00000000 , &
+ 1897755.00000000 , &
+ 1910515.00000000 , &
+ 1923274.00000000 , &
+ 1936034.00000000 , &
+ 1948794.00000000 , &
+ 1961553.00000000 , &
+ 1974313.00000000 /)
+
+ Mref_V%radius_ref( 241 : 270 ) = (/ &
+ 1987073.00000000 , &
+ 1999832.00000000 , &
+ 2012592.00000000 , &
+ 2025352.00000000 , &
+ 2038112.00000000 , &
+ 2050871.00000000 , &
+ 2063631.00000000 , &
+ 2076391.00000000 , &
+ 2089150.00000000 , &
+ 2101910.00000000 , &
+ 2114670.00000000 , &
+ 2127429.00000000 , &
+ 2140189.00000000 , &
+ 2152949.00000000 , &
+ 2165709.00000000 , &
+ 2178468.00000000 , &
+ 2191228.00000000 , &
+ 2203988.00000000 , &
+ 2216747.00000000 , &
+ 2229507.00000000 , &
+ 2242267.00000000 , &
+ 2255026.00000000 , &
+ 2267786.00000000 , &
+ 2280546.00000000 , &
+ 2293306.00000000 , &
+ 2306065.00000000 , &
+ 2318825.00000000 , &
+ 2331585.00000000 , &
+ 2344344.00000000 , &
+ 2357104.00000000 /)
+
+ Mref_V%radius_ref( 271 : 300 ) = (/ &
+ 2369864.00000000 , &
+ 2382623.00000000 , &
+ 2395383.00000000 , &
+ 2408143.00000000 , &
+ 2420903.00000000 , &
+ 2433662.00000000 , &
+ 2446422.00000000 , &
+ 2459182.00000000 , &
+ 2471941.00000000 , &
+ 2484701.00000000 , &
+ 2497461.00000000 , &
+ 2510220.00000000 , &
+ 2522980.00000000 , &
+ 2535740.00000000 , &
+ 2548500.00000000 , &
+ 2561259.00000000 , &
+ 2574019.00000000 , &
+ 2586779.00000000 , &
+ 2599538.00000000 , &
+ 2612298.00000000 , &
+ 2625058.00000000 , &
+ 2637818.00000000 , &
+ 2650577.00000000 , &
+ 2663337.00000000 , &
+ 2676097.00000000 , &
+ 2688856.00000000 , &
+ 2701616.00000000 , &
+ 2714376.00000000 , &
+ 2727135.00000000 , &
+ 2739895.00000000 /)
+
+ Mref_V%radius_ref( 301 : 330 ) = (/ &
+ 2752655.00000000 , &
+ 2765415.00000000 , &
+ 2778174.00000000 , &
+ 2790934.00000000 , &
+ 2803694.00000000 , &
+ 2816453.00000000 , &
+ 2829213.00000000 , &
+ 2841973.00000000 , &
+ 2854732.00000000 , &
+ 2867492.00000000 , &
+ 2880252.00000000 , &
+ 2893012.00000000 , &
+ 2905771.00000000 , &
+ 2918531.00000000 , &
+ 2931291.00000000 , &
+ 2944050.00000000 , &
+ 2956810.00000000 , &
+ 2969570.00000000 , &
+ 2982329.00000000 , &
+ 2995089.00000000 , &
+ 3007849.00000000 , &
+ 3020609.00000000 , &
+ 3033368.00000000 , &
+ 3046128.00000000 , &
+ 3058888.00000000 , &
+ 3071647.00000000 , &
+ 3084407.00000000 , &
+ 3097167.00000000 , &
+ 3109926.00000000 , &
+ 3122686.00000000 /)
+
+ Mref_V%radius_ref( 331 : 360 ) = (/ &
+ 3135446.00000000 , &
+ 3148206.00000000 , &
+ 3160965.00000000 , &
+ 3173725.00000000 , &
+ 3186485.00000000 , &
+ 3199244.00000000 , &
+ 3212004.00000000 , &
+ 3224764.00000000 , &
+ 3237523.00000000 , &
+ 3250283.00000000 , &
+ 3263043.00000000 , &
+ 3275803.00000000 , &
+ 3288562.00000000 , &
+ 3301322.00000000 , &
+ 3314082.00000000 , &
+ 3326841.00000000 , &
+ 3339601.00000000 , &
+ 3352361.00000000 , &
+ 3365120.00000000 , &
+ 3377880.00000000 , &
+ 3390640.00000000 , &
+ 3403400.00000000 , &
+ 3416159.00000000 , &
+ 3428919.00000000 , &
+ 3441679.00000000 , &
+ 3454438.00000000 , &
+ 3467198.00000000 , &
+ 3479958.00000000 , &
+ 3479958.00000000 , &
+ 3489335.00000000 /)
+
+ Mref_V%radius_ref( 361 : 390 ) = (/ &
+ 3498713.00000000 , &
+ 3508091.00000000 , &
+ 3517468.00000000 , &
+ 3526846.00000000 , &
+ 3536224.00000000 , &
+ 3545601.00000000 , &
+ 3554979.00000000 , &
+ 3564357.00000000 , &
+ 3573734.00000000 , &
+ 3583112.00000000 , &
+ 3592489.00000000 , &
+ 3601867.00000000 , &
+ 3611245.00000000 , &
+ 3620622.00000000 , &
+ 3630000.00000000 , &
+ 3630000.00000000 , &
+ 3639471.00000000 , &
+ 3648942.00000000 , &
+ 3658413.00000000 , &
+ 3667885.00000000 , &
+ 3677356.00000000 , &
+ 3686827.00000000 , &
+ 3696298.00000000 , &
+ 3705769.00000000 , &
+ 3715240.00000000 , &
+ 3724712.00000000 , &
+ 3734183.00000000 , &
+ 3743654.00000000 , &
+ 3753125.00000000 , &
+ 3762596.00000000 /)
+
+ Mref_V%radius_ref( 391 : 420 ) = (/ &
+ 3772067.00000000 , &
+ 3781538.00000000 , &
+ 3791010.00000000 , &
+ 3800481.00000000 , &
+ 3809952.00000000 , &
+ 3819423.00000000 , &
+ 3828894.00000000 , &
+ 3838365.00000000 , &
+ 3847837.00000000 , &
+ 3857308.00000000 , &
+ 3866779.00000000 , &
+ 3876250.00000000 , &
+ 3885721.00000000 , &
+ 3895192.00000000 , &
+ 3904663.00000000 , &
+ 3914135.00000000 , &
+ 3923606.00000000 , &
+ 3933077.00000000 , &
+ 3942548.00000000 , &
+ 3952019.00000000 , &
+ 3961490.00000000 , &
+ 3970962.00000000 , &
+ 3980433.00000000 , &
+ 3989904.00000000 , &
+ 3999375.00000000 , &
+ 4008846.00000000 , &
+ 4018317.00000000 , &
+ 4027788.00000000 , &
+ 4037260.00000000 , &
+ 4046731.00000000 /)
+
+ Mref_V%radius_ref( 421 : 450 ) = (/ &
+ 4056202.00000000 , &
+ 4065673.00000000 , &
+ 4075144.00000000 , &
+ 4084615.00000000 , &
+ 4094087.00000000 , &
+ 4103558.00000000 , &
+ 4113029.00000000 , &
+ 4122500.00000000 , &
+ 4131971.00000000 , &
+ 4141442.00000000 , &
+ 4150913.00000000 , &
+ 4160385.00000000 , &
+ 4169856.00000000 , &
+ 4179327.00000000 , &
+ 4188798.00000000 , &
+ 4198269.00000000 , &
+ 4207740.00000000 , &
+ 4217212.00000000 , &
+ 4226683.00000000 , &
+ 4236154.00000000 , &
+ 4245625.00000000 , &
+ 4255096.00000000 , &
+ 4264567.00000000 , &
+ 4274038.00000000 , &
+ 4283510.00000000 , &
+ 4292981.00000000 , &
+ 4302452.00000000 , &
+ 4311923.00000000 , &
+ 4321394.00000000 , &
+ 4330865.00000000 /)
+
+ Mref_V%radius_ref( 451 : 480 ) = (/ &
+ 4340337.00000000 , &
+ 4349808.00000000 , &
+ 4359279.00000000 , &
+ 4368750.00000000 , &
+ 4378221.00000000 , &
+ 4387692.00000000 , &
+ 4397163.00000000 , &
+ 4406635.00000000 , &
+ 4416106.00000000 , &
+ 4425577.00000000 , &
+ 4435048.00000000 , &
+ 4444519.00000000 , &
+ 4453990.00000000 , &
+ 4463462.00000000 , &
+ 4472933.00000000 , &
+ 4482404.00000000 , &
+ 4491875.00000000 , &
+ 4501346.00000000 , &
+ 4510817.00000000 , &
+ 4520288.00000000 , &
+ 4529760.00000000 , &
+ 4539231.00000000 , &
+ 4548702.00000000 , &
+ 4558173.00000000 , &
+ 4567644.00000000 , &
+ 4577115.00000000 , &
+ 4586587.00000000 , &
+ 4596058.00000000 , &
+ 4605529.00000000 , &
+ 4615000.00000000 /)
+
+ Mref_V%radius_ref( 481 : 510 ) = (/ &
+ 4624471.00000000 , &
+ 4633942.00000000 , &
+ 4643413.00000000 , &
+ 4652885.00000000 , &
+ 4662356.00000000 , &
+ 4671827.00000000 , &
+ 4681298.00000000 , &
+ 4690769.00000000 , &
+ 4700240.00000000 , &
+ 4709712.00000000 , &
+ 4719183.00000000 , &
+ 4728654.00000000 , &
+ 4738125.00000000 , &
+ 4747596.00000000 , &
+ 4757067.00000000 , &
+ 4766538.00000000 , &
+ 4776010.00000000 , &
+ 4785481.00000000 , &
+ 4794952.00000000 , &
+ 4804423.00000000 , &
+ 4813894.00000000 , &
+ 4823365.00000000 , &
+ 4832837.00000000 , &
+ 4842308.00000000 , &
+ 4851779.00000000 , &
+ 4861250.00000000 , &
+ 4870721.00000000 , &
+ 4880192.00000000 , &
+ 4889663.00000000 , &
+ 4899135.00000000 /)
+
+ Mref_V%radius_ref( 511 : 540 ) = (/ &
+ 4908606.00000000 , &
+ 4918077.00000000 , &
+ 4927548.00000000 , &
+ 4937019.00000000 , &
+ 4946490.00000000 , &
+ 4955962.00000000 , &
+ 4965433.00000000 , &
+ 4974904.00000000 , &
+ 4984375.00000000 , &
+ 4993846.00000000 , &
+ 5003317.00000000 , &
+ 5012788.00000000 , &
+ 5022260.00000000 , &
+ 5031731.00000000 , &
+ 5041202.00000000 , &
+ 5050673.00000000 , &
+ 5060144.00000000 , &
+ 5069615.00000000 , &
+ 5079087.00000000 , &
+ 5088558.00000000 , &
+ 5098029.00000000 , &
+ 5107500.00000000 , &
+ 5116971.00000000 , &
+ 5126442.00000000 , &
+ 5135913.00000000 , &
+ 5145385.00000000 , &
+ 5154856.00000000 , &
+ 5164327.00000000 , &
+ 5173798.00000000 , &
+ 5183269.00000000 /)
+
+ Mref_V%radius_ref( 541 : 570 ) = (/ &
+ 5192740.00000000 , &
+ 5202212.00000000 , &
+ 5211683.00000000 , &
+ 5221154.00000000 , &
+ 5230625.00000000 , &
+ 5240096.00000000 , &
+ 5249567.00000000 , &
+ 5259038.00000000 , &
+ 5268510.00000000 , &
+ 5277981.00000000 , &
+ 5287452.00000000 , &
+ 5296923.00000000 , &
+ 5306394.00000000 , &
+ 5315865.00000000 , &
+ 5325337.00000000 , &
+ 5334808.00000000 , &
+ 5344279.00000000 , &
+ 5353750.00000000 , &
+ 5363221.00000000 , &
+ 5372692.00000000 , &
+ 5382163.00000000 , &
+ 5391635.00000000 , &
+ 5401106.00000000 , &
+ 5410577.00000000 , &
+ 5420048.00000000 , &
+ 5429519.00000000 , &
+ 5438990.00000000 , &
+ 5448462.00000000 , &
+ 5457933.00000000 , &
+ 5467404.00000000 /)
+
+ Mref_V%radius_ref( 571 : 600 ) = (/ &
+ 5476875.00000000 , &
+ 5486346.00000000 , &
+ 5495817.00000000 , &
+ 5505288.00000000 , &
+ 5514760.00000000 , &
+ 5524231.00000000 , &
+ 5533702.00000000 , &
+ 5543173.00000000 , &
+ 5552644.00000000 , &
+ 5562115.00000000 , &
+ 5571587.00000000 , &
+ 5581058.00000000 , &
+ 5590529.00000000 , &
+ 5600000.00000000 , &
+ 5600000.00000000 , &
+ 5607562.00000000 , &
+ 5615125.00000000 , &
+ 5622688.00000000 , &
+ 5630250.00000000 , &
+ 5637812.00000000 , &
+ 5645375.00000000 , &
+ 5652938.00000000 , &
+ 5660500.00000000 , &
+ 5668062.00000000 , &
+ 5675625.00000000 , &
+ 5683188.00000000 , &
+ 5690750.00000000 , &
+ 5698312.00000000 , &
+ 5705875.00000000 , &
+ 5713438.00000000 /)
+
+ Mref_V%radius_ref( 601 : 630 ) = (/ &
+ 5721000.00000000 , &
+ 5721000.00000000 , &
+ 5724572.00000000 , &
+ 5728143.00000000 , &
+ 5731714.00000000 , &
+ 5735286.00000000 , &
+ 5738857.00000000 , &
+ 5742428.00000000 , &
+ 5746000.00000000 , &
+ 5749572.00000000 , &
+ 5753143.00000000 , &
+ 5756714.00000000 , &
+ 5760286.00000000 , &
+ 5763857.00000000 , &
+ 5767428.00000000 , &
+ 5771000.00000000 , &
+ 5771000.00000000 , &
+ 5777334.00000000 , &
+ 5783666.00000000 , &
+ 5790000.00000000 , &
+ 5796334.00000000 , &
+ 5802666.00000000 , &
+ 5809000.00000000 , &
+ 5815334.00000000 , &
+ 5821666.00000000 , &
+ 5828000.00000000 , &
+ 5834334.00000000 , &
+ 5840666.00000000 , &
+ 5847000.00000000 , &
+ 5853334.00000000 /)
+
+ Mref_V%radius_ref( 631 : 660 ) = (/ &
+ 5859666.00000000 , &
+ 5866000.00000000 , &
+ 5872334.00000000 , &
+ 5878666.00000000 , &
+ 5885000.00000000 , &
+ 5891334.00000000 , &
+ 5897666.00000000 , &
+ 5904000.00000000 , &
+ 5910334.00000000 , &
+ 5916666.00000000 , &
+ 5923000.00000000 , &
+ 5929334.00000000 , &
+ 5935666.00000000 , &
+ 5942000.00000000 , &
+ 5948334.00000000 , &
+ 5954666.00000000 , &
+ 5961000.00000000 , &
+ 5961000.00000000 , &
+ 5967334.00000000 , &
+ 5973666.00000000 , &
+ 5980000.00000000 , &
+ 5986334.00000000 , &
+ 5992666.00000000 , &
+ 5999000.00000000 , &
+ 6005334.00000000 , &
+ 6011666.00000000 , &
+ 6018000.00000000 , &
+ 6024334.00000000 , &
+ 6030666.00000000 , &
+ 6037000.00000000 /)
+
+ Mref_V%radius_ref( 661 : 690 ) = (/ &
+ 6043334.00000000 , &
+ 6049666.00000000 , &
+ 6056000.00000000 , &
+ 6062334.00000000 , &
+ 6068666.00000000 , &
+ 6075000.00000000 , &
+ 6081334.00000000 , &
+ 6087666.00000000 , &
+ 6094000.00000000 , &
+ 6100334.00000000 , &
+ 6106666.00000000 , &
+ 6113000.00000000 , &
+ 6119334.00000000 , &
+ 6125666.00000000 , &
+ 6132000.00000000 , &
+ 6138334.00000000 , &
+ 6144666.00000000 , &
+ 6151000.00000000 , &
+ 6151000.00000000 , &
+ 6157087.00000000 , &
+ 6163174.00000000 , &
+ 6169261.00000000 , &
+ 6175348.00000000 , &
+ 6181435.00000000 , &
+ 6187522.00000000 , &
+ 6193609.00000000 , &
+ 6199696.00000000 , &
+ 6205783.00000000 , &
+ 6211870.00000000 , &
+ 6217957.00000000 /)
+
+ Mref_V%radius_ref( 691 : 720 ) = (/ &
+ 6224043.00000000 , &
+ 6230130.00000000 , &
+ 6236217.00000000 , &
+ 6242304.00000000 , &
+ 6248391.00000000 , &
+ 6254478.00000000 , &
+ 6260565.00000000 , &
+ 6266652.00000000 , &
+ 6272739.00000000 , &
+ 6278826.00000000 , &
+ 6284913.00000000 , &
+ 6291000.00000000 , &
+ 6291000.00000000 , &
+ 6294971.00000000 , &
+ 6298943.00000000 , &
+ 6302914.00000000 , &
+ 6306886.00000000 , &
+ 6310857.00000000 , &
+ 6314829.00000000 , &
+ 6318800.00000000 , &
+ 6322771.00000000 , &
+ 6326743.00000000 , &
+ 6330714.00000000 , &
+ 6334686.00000000 , &
+ 6338657.00000000 , &
+ 6342629.00000000 , &
+ 6346600.00000000 , &
+ 6346600.00000000 , &
+ 6347540.00000000 , &
+ 6348480.00000000 /)
+
+ Mref_V%radius_ref( 721 : 750 ) = (/ &
+ 6349420.00000000 , &
+ 6350360.00000000 , &
+ 6351300.00000000 , &
+ 6352240.00000000 , &
+ 6353180.00000000 , &
+ 6354120.00000000 , &
+ 6355060.00000000 , &
+ 6356000.00000000 , &
+ 6356000.00000000 , &
+ 6357200.00000000 , &
+ 6358400.00000000 , &
+ 6359600.00000000 , &
+ 6360800.00000000 , &
+ 6362000.00000000 , &
+ 6363200.00000000 , &
+ 6364400.00000000 , &
+ 6365600.00000000 , &
+ 6366800.00000000 , &
+ 6368000.00000000 , &
+ 6368000.00000000 , &
+ 6368300.00000000 , &
+ 6368600.00000000 , &
+ 6368900.00000000 , &
+ 6369200.00000000 , &
+ 6369500.00000000 , &
+ 6369800.00000000 , &
+ 6370100.00000000 , &
+ 6370400.00000000 , &
+ 6370700.00000000 , &
+ 6371000.00000000 /)
+
+ Mref_V%density_ref( 1 : 30 ) = (/ &
+ 13088.4800000000 , &
+ 13088.4700000000 , &
+ 13088.4400000000 , &
+ 13088.3900000000 , &
+ 13088.3200000000 , &
+ 13088.2200000000 , &
+ 13088.1100000000 , &
+ 13087.9800000000 , &
+ 13087.8300000000 , &
+ 13087.6600000000 , &
+ 13087.4600000000 , &
+ 13087.2500000000 , &
+ 13087.0200000000 , &
+ 13086.7600000000 , &
+ 13086.4900000000 , &
+ 13086.2000000000 , &
+ 13085.8800000000 , &
+ 13085.5500000000 , &
+ 13085.1900000000 , &
+ 13084.8200000000 , &
+ 13084.4200000000 , &
+ 13084.0100000000 , &
+ 13083.5700000000 , &
+ 13083.1100000000 , &
+ 13082.6400000000 , &
+ 13082.1400000000 , &
+ 13081.6200000000 , &
+ 13081.0900000000 , &
+ 13080.5300000000 , &
+ 13079.9500000000 /)
+
+ Mref_V%density_ref( 31 : 60 ) = (/ &
+ 13079.3500000000 , &
+ 13078.7300000000 , &
+ 13078.0900000000 , &
+ 13077.4400000000 , &
+ 13076.7600000000 , &
+ 13076.0600000000 , &
+ 13075.3400000000 , &
+ 13074.6000000000 , &
+ 13073.8400000000 , &
+ 13073.0600000000 , &
+ 13072.2500000000 , &
+ 13071.4300000000 , &
+ 13070.5900000000 , &
+ 13069.7300000000 , &
+ 13068.8500000000 , &
+ 13067.9500000000 , &
+ 13067.0200000000 , &
+ 13066.0800000000 , &
+ 13065.1200000000 , &
+ 13064.1300000000 , &
+ 13063.1300000000 , &
+ 13062.1000000000 , &
+ 13061.0600000000 , &
+ 13060.0000000000 , &
+ 13058.9100000000 , &
+ 13057.8100000000 , &
+ 13056.6800000000 , &
+ 13055.5300000000 , &
+ 13054.3700000000 , &
+ 13053.1800000000 /)
+
+ Mref_V%density_ref( 61 : 90 ) = (/ &
+ 13051.9800000000 , &
+ 13050.7500000000 , &
+ 13049.5000000000 , &
+ 13048.2300000000 , &
+ 13046.9500000000 , &
+ 13045.6400000000 , &
+ 13044.3100000000 , &
+ 13042.9600000000 , &
+ 13041.5900000000 , &
+ 13040.2000000000 , &
+ 13038.7900000000 , &
+ 13037.3600000000 , &
+ 13035.9100000000 , &
+ 13034.4400000000 , &
+ 13032.9500000000 , &
+ 13031.4400000000 , &
+ 13029.9100000000 , &
+ 13028.3600000000 , &
+ 13026.7900000000 , &
+ 13025.2000000000 , &
+ 13023.5800000000 , &
+ 13021.9500000000 , &
+ 13020.3000000000 , &
+ 13018.6300000000 , &
+ 13016.9300000000 , &
+ 13015.2200000000 , &
+ 13013.4900000000 , &
+ 13011.7300000000 , &
+ 13009.9600000000 , &
+ 13008.1600000000 /)
+
+ Mref_V%density_ref( 91 : 120 ) = (/ &
+ 13006.3500000000 , &
+ 13004.5100000000 , &
+ 13002.6600000000 , &
+ 13000.7800000000 , &
+ 12998.8800000000 , &
+ 12996.9700000000 , &
+ 12995.0300000000 , &
+ 12993.0700000000 , &
+ 12991.1000000000 , &
+ 12989.1000000000 , &
+ 12987.0800000000 , &
+ 12985.0400000000 , &
+ 12982.9900000000 , &
+ 12980.9100000000 , &
+ 12978.8100000000 , &
+ 12976.6900000000 , &
+ 12974.5500000000 , &
+ 12972.3900000000 , &
+ 12970.2100000000 , &
+ 12968.0100000000 , &
+ 12965.7900000000 , &
+ 12963.5500000000 , &
+ 12961.2900000000 , &
+ 12959.0100000000 , &
+ 12956.7000000000 , &
+ 12954.3800000000 , &
+ 12952.0400000000 , &
+ 12949.6800000000 , &
+ 12947.2900000000 , &
+ 12944.8900000000 /)
+
+ Mref_V%density_ref( 121 : 150 ) = (/ &
+ 12942.4700000000 , &
+ 12940.0200000000 , &
+ 12937.5600000000 , &
+ 12935.0800000000 , &
+ 12932.5700000000 , &
+ 12930.0500000000 , &
+ 12927.5000000000 , &
+ 12924.9400000000 , &
+ 12922.3500000000 , &
+ 12919.7500000000 , &
+ 12917.1200000000 , &
+ 12914.4700000000 , &
+ 12911.8100000000 , &
+ 12909.1200000000 , &
+ 12906.4100000000 , &
+ 12903.6800000000 , &
+ 12900.9400000000 , &
+ 12898.1700000000 , &
+ 12895.3800000000 , &
+ 12892.5700000000 , &
+ 12889.7400000000 , &
+ 12886.8900000000 , &
+ 12884.0200000000 , &
+ 12881.1300000000 , &
+ 12878.2200000000 , &
+ 12875.2900000000 , &
+ 12872.3400000000 , &
+ 12869.3700000000 , &
+ 12866.3800000000 , &
+ 12863.3700000000 /)
+
+ Mref_V%density_ref( 151 : 180 ) = (/ &
+ 12860.3400000000 , &
+ 12857.2900000000 , &
+ 12854.2100000000 , &
+ 12851.1200000000 , &
+ 12848.0100000000 , &
+ 12844.8800000000 , &
+ 12841.7200000000 , &
+ 12838.5500000000 , &
+ 12835.3500000000 , &
+ 12832.1400000000 , &
+ 12828.9100000000 , &
+ 12825.6500000000 , &
+ 12822.3800000000 , &
+ 12819.0800000000 , &
+ 12815.7600000000 , &
+ 12812.4300000000 , &
+ 12809.0700000000 , &
+ 12805.7000000000 , &
+ 12802.3000000000 , &
+ 12798.8800000000 , &
+ 12795.4400000000 , &
+ 12791.9900000000 , &
+ 12788.5100000000 , &
+ 12785.0100000000 , &
+ 12781.4900000000 , &
+ 12777.9500000000 , &
+ 12774.4000000000 , &
+ 12770.8200000000 , &
+ 12767.2200000000 , &
+ 12763.6000000000 /)
+
+ Mref_V%density_ref( 181 : 210 ) = (/ &
+ 12166.3500000000 , &
+ 12159.7700000000 , &
+ 12153.1400000000 , &
+ 12146.4500000000 , &
+ 12139.7100000000 , &
+ 12132.9100000000 , &
+ 12126.0500000000 , &
+ 12119.1400000000 , &
+ 12112.1800000000 , &
+ 12105.1500000000 , &
+ 12098.0700000000 , &
+ 12090.9300000000 , &
+ 12083.7300000000 , &
+ 12076.4800000000 , &
+ 12069.1700000000 , &
+ 12061.8000000000 , &
+ 12054.3700000000 , &
+ 12046.8800000000 , &
+ 12039.3300000000 , &
+ 12031.7200000000 , &
+ 12024.0500000000 , &
+ 12016.3300000000 , &
+ 12008.5400000000 , &
+ 12000.6900000000 , &
+ 11992.7800000000 , &
+ 11984.8100000000 , &
+ 11976.7800000000 , &
+ 11968.6800000000 , &
+ 11960.5300000000 , &
+ 11952.3100000000 /)
+
+ Mref_V%density_ref( 211 : 240 ) = (/ &
+ 11944.0300000000 , &
+ 11935.6900000000 , &
+ 11927.2800000000 , &
+ 11918.8100000000 , &
+ 11910.2800000000 , &
+ 11901.6800000000 , &
+ 11893.0200000000 , &
+ 11884.3000000000 , &
+ 11875.5100000000 , &
+ 11866.6600000000 , &
+ 11857.7400000000 , &
+ 11848.7500000000 , &
+ 11839.7000000000 , &
+ 11830.5800000000 , &
+ 11821.4000000000 , &
+ 11812.1500000000 , &
+ 11802.8400000000 , &
+ 11793.4500000000 , &
+ 11784.0100000000 , &
+ 11774.4900000000 , &
+ 11764.9000000000 , &
+ 11755.2500000000 , &
+ 11745.5300000000 , &
+ 11735.7400000000 , &
+ 11725.8800000000 , &
+ 11715.9500000000 , &
+ 11705.9500000000 , &
+ 11695.8900000000 , &
+ 11685.7500000000 , &
+ 11675.5400000000 /)
+
+ Mref_V%density_ref( 241 : 270 ) = (/ &
+ 11665.2600000000 , &
+ 11654.9200000000 , &
+ 11644.5000000000 , &
+ 11634.0100000000 , &
+ 11623.4400000000 , &
+ 11612.8100000000 , &
+ 11602.1000000000 , &
+ 11591.3200000000 , &
+ 11580.4700000000 , &
+ 11569.5500000000 , &
+ 11558.5500000000 , &
+ 11547.4800000000 , &
+ 11536.3400000000 , &
+ 11525.1200000000 , &
+ 11513.8300000000 , &
+ 11502.4600000000 , &
+ 11491.0200000000 , &
+ 11479.5100000000 , &
+ 11467.9100000000 , &
+ 11456.2500000000 , &
+ 11444.5000000000 , &
+ 11432.6900000000 , &
+ 11420.7900000000 , &
+ 11408.8200000000 , &
+ 11396.7700000000 , &
+ 11384.6400000000 , &
+ 11372.4400000000 , &
+ 11360.1600000000 , &
+ 11347.8000000000 , &
+ 11335.3700000000 /)
+
+ Mref_V%density_ref( 271 : 300 ) = (/ &
+ 11322.8500000000 , &
+ 11310.2600000000 , &
+ 11297.5800000000 , &
+ 11284.8300000000 , &
+ 11272.0000000000 , &
+ 11259.0900000000 , &
+ 11246.1000000000 , &
+ 11233.0300000000 , &
+ 11219.8700000000 , &
+ 11206.6400000000 , &
+ 11193.3300000000 , &
+ 11179.9300000000 , &
+ 11166.4500000000 , &
+ 11152.8900000000 , &
+ 11139.2500000000 , &
+ 11125.5300000000 , &
+ 11111.7200000000 , &
+ 11097.8300000000 , &
+ 11083.8600000000 , &
+ 11069.8000000000 , &
+ 11055.6600000000 , &
+ 11041.4400000000 , &
+ 11027.1300000000 , &
+ 11012.7400000000 , &
+ 10998.2600000000 , &
+ 10983.7000000000 , &
+ 10969.0500000000 , &
+ 10954.3200000000 , &
+ 10939.5000000000 , &
+ 10924.5900000000 /)
+
+ Mref_V%density_ref( 301 : 330 ) = (/ &
+ 10909.6000000000 , &
+ 10894.5200000000 , &
+ 10879.3500000000 , &
+ 10864.1000000000 , &
+ 10848.7600000000 , &
+ 10833.3300000000 , &
+ 10817.8100000000 , &
+ 10802.2100000000 , &
+ 10786.5100000000 , &
+ 10770.7300000000 , &
+ 10754.8600000000 , &
+ 10738.9000000000 , &
+ 10722.8500000000 , &
+ 10706.7100000000 , &
+ 10690.4800000000 , &
+ 10674.1600000000 , &
+ 10657.7500000000 , &
+ 10641.2400000000 , &
+ 10624.6500000000 , &
+ 10607.9600000000 , &
+ 10591.1900000000 , &
+ 10574.3200000000 , &
+ 10557.3600000000 , &
+ 10540.3000000000 , &
+ 10523.1600000000 , &
+ 10505.9200000000 , &
+ 10488.5800000000 , &
+ 10471.1500000000 , &
+ 10453.6300000000 , &
+ 10436.0200000000 /)
+
+ Mref_V%density_ref( 331 : 360 ) = (/ &
+ 10418.3100000000 , &
+ 10400.5100000000 , &
+ 10382.6100000000 , &
+ 10364.6100000000 , &
+ 10346.5200000000 , &
+ 10328.3400000000 , &
+ 10310.0500000000 , &
+ 10291.6800000000 , &
+ 10273.2000000000 , &
+ 10254.6300000000 , &
+ 10235.9600000000 , &
+ 10217.2000000000 , &
+ 10198.3300000000 , &
+ 10179.3700000000 , &
+ 10160.3100000000 , &
+ 10141.1500000000 , &
+ 10121.9000000000 , &
+ 10102.5400000000 , &
+ 10083.0900000000 , &
+ 10063.5300000000 , &
+ 10043.8800000000 , &
+ 10024.1200000000 , &
+ 10004.2700000000 , &
+ 9984.32000000000 , &
+ 9964.26000000000 , &
+ 9944.10000000000 , &
+ 9923.84000000000 , &
+ 9903.48000000000 , &
+ 5566.45000000000 , &
+ 5561.75000000000 /)
+
+ Mref_V%density_ref( 361 : 390 ) = (/ &
+ 5557.05000000000 , &
+ 5552.36000000000 , &
+ 5547.66000000000 , &
+ 5542.97000000000 , &
+ 5538.28000000000 , &
+ 5533.59000000000 , &
+ 5528.90000000000 , &
+ 5524.21000000000 , &
+ 5519.53000000000 , &
+ 5514.85000000000 , &
+ 5510.16000000000 , &
+ 5505.48000000000 , &
+ 5500.81000000000 , &
+ 5496.13000000000 , &
+ 5491.45000000000 , &
+ 5491.45000000000 , &
+ 5486.73000000000 , &
+ 5482.01000000000 , &
+ 5477.29000000000 , &
+ 5472.57000000000 , &
+ 5467.85000000000 , &
+ 5463.13000000000 , &
+ 5458.42000000000 , &
+ 5453.70000000000 , &
+ 5448.99000000000 , &
+ 5444.27000000000 , &
+ 5439.56000000000 , &
+ 5434.85000000000 , &
+ 5430.13000000000 , &
+ 5425.42000000000 /)
+
+ Mref_V%density_ref( 391 : 420 ) = (/ &
+ 5420.71000000000 , &
+ 5416.00000000000 , &
+ 5411.29000000000 , &
+ 5406.57000000000 , &
+ 5401.86000000000 , &
+ 5397.15000000000 , &
+ 5392.44000000000 , &
+ 5387.73000000000 , &
+ 5383.02000000000 , &
+ 5378.30000000000 , &
+ 5373.59000000000 , &
+ 5368.88000000000 , &
+ 5364.17000000000 , &
+ 5359.45000000000 , &
+ 5354.74000000000 , &
+ 5350.02000000000 , &
+ 5345.31000000000 , &
+ 5340.59000000000 , &
+ 5335.87000000000 , &
+ 5331.16000000000 , &
+ 5326.44000000000 , &
+ 5321.72000000000 , &
+ 5317.00000000000 , &
+ 5312.28000000000 , &
+ 5307.55000000000 , &
+ 5302.83000000000 , &
+ 5298.10000000000 , &
+ 5293.38000000000 , &
+ 5288.65000000000 , &
+ 5283.92000000000 /)
+
+ Mref_V%density_ref( 421 : 450 ) = (/ &
+ 5279.19000000000 , &
+ 5274.45000000000 , &
+ 5269.72000000000 , &
+ 5264.98000000000 , &
+ 5260.25000000000 , &
+ 5255.51000000000 , &
+ 5250.77000000000 , &
+ 5246.02000000000 , &
+ 5241.28000000000 , &
+ 5236.53000000000 , &
+ 5231.78000000000 , &
+ 5227.03000000000 , &
+ 5222.27000000000 , &
+ 5217.52000000000 , &
+ 5212.76000000000 , &
+ 5208.00000000000 , &
+ 5203.23000000000 , &
+ 5198.47000000000 , &
+ 5193.70000000000 , &
+ 5188.93000000000 , &
+ 5184.15000000000 , &
+ 5179.38000000000 , &
+ 5174.60000000000 , &
+ 5169.82000000000 , &
+ 5165.03000000000 , &
+ 5160.24000000000 , &
+ 5155.45000000000 , &
+ 5150.65000000000 , &
+ 5145.86000000000 , &
+ 5141.06000000000 /)
+
+ Mref_V%density_ref( 451 : 480 ) = (/ &
+ 5136.25000000000 , &
+ 5131.44000000000 , &
+ 5126.63000000000 , &
+ 5121.82000000000 , &
+ 5117.00000000000 , &
+ 5112.18000000000 , &
+ 5107.35000000000 , &
+ 5102.52000000000 , &
+ 5097.69000000000 , &
+ 5092.85000000000 , &
+ 5088.01000000000 , &
+ 5083.16000000000 , &
+ 5078.31000000000 , &
+ 5073.46000000000 , &
+ 5068.60000000000 , &
+ 5063.74000000000 , &
+ 5058.87000000000 , &
+ 5054.00000000000 , &
+ 5049.13000000000 , &
+ 5044.25000000000 , &
+ 5039.36000000000 , &
+ 5034.47000000000 , &
+ 5029.58000000000 , &
+ 5024.68000000000 , &
+ 5019.78000000000 , &
+ 5014.87000000000 , &
+ 5009.96000000000 , &
+ 5005.04000000000 , &
+ 5000.12000000000 , &
+ 4995.19000000000 /)
+
+ Mref_V%density_ref( 481 : 510 ) = (/ &
+ 4990.26000000000 , &
+ 4985.32000000000 , &
+ 4980.38000000000 , &
+ 4975.43000000000 , &
+ 4970.47000000000 , &
+ 4965.51000000000 , &
+ 4960.55000000000 , &
+ 4955.58000000000 , &
+ 4950.60000000000 , &
+ 4945.62000000000 , &
+ 4940.63000000000 , &
+ 4935.64000000000 , &
+ 4930.64000000000 , &
+ 4925.63000000000 , &
+ 4920.62000000000 , &
+ 4915.60000000000 , &
+ 4910.58000000000 , &
+ 4905.55000000000 , &
+ 4900.51000000000 , &
+ 4895.47000000000 , &
+ 4890.42000000000 , &
+ 4885.37000000000 , &
+ 4880.31000000000 , &
+ 4875.24000000000 , &
+ 4870.16000000000 , &
+ 4865.08000000000 , &
+ 4859.99000000000 , &
+ 4854.90000000000 , &
+ 4849.80000000000 , &
+ 4844.69000000000 /)
+
+ Mref_V%density_ref( 511 : 540 ) = (/ &
+ 4839.57000000000 , &
+ 4834.45000000000 , &
+ 4829.32000000000 , &
+ 4824.18000000000 , &
+ 4819.04000000000 , &
+ 4813.88000000000 , &
+ 4808.73000000000 , &
+ 4803.56000000000 , &
+ 4798.39000000000 , &
+ 4793.20000000000 , &
+ 4788.02000000000 , &
+ 4782.82000000000 , &
+ 4777.61000000000 , &
+ 4772.40000000000 , &
+ 4767.18000000000 , &
+ 4761.95000000000 , &
+ 4756.72000000000 , &
+ 4751.47000000000 , &
+ 4746.22000000000 , &
+ 4740.95000000000 , &
+ 4735.68000000000 , &
+ 4730.40000000000 , &
+ 4725.10000000000 , &
+ 4719.80000000000 , &
+ 4714.48000000000 , &
+ 4709.15000000000 , &
+ 4703.81000000000 , &
+ 4698.44000000000 , &
+ 4693.08000000000 , &
+ 4687.69000000000 /)
+
+ Mref_V%density_ref( 541 : 570 ) = (/ &
+ 4682.29000000000 , &
+ 4676.87000000000 , &
+ 4671.44000000000 , &
+ 4665.99000000000 , &
+ 4660.52000000000 , &
+ 4655.03000000000 , &
+ 4649.52000000000 , &
+ 4644.00000000000 , &
+ 4638.46000000000 , &
+ 4632.89000000000 , &
+ 4627.31000000000 , &
+ 4621.70000000000 , &
+ 4616.08000000000 , &
+ 4610.44000000000 , &
+ 4604.76000000000 , &
+ 4599.08000000000 , &
+ 4593.36000000000 , &
+ 4587.63000000000 , &
+ 4581.86000000000 , &
+ 4576.07000000000 , &
+ 4570.26000000000 , &
+ 4564.43000000000 , &
+ 4558.56000000000 , &
+ 4552.67000000000 , &
+ 4546.76000000000 , &
+ 4540.82000000000 , &
+ 4534.84000000000 , &
+ 4528.85000000000 , &
+ 4522.81000000000 , &
+ 4516.76000000000 /)
+
+ Mref_V%density_ref( 571 : 600 ) = (/ &
+ 4510.67000000000 , &
+ 4504.56000000000 , &
+ 4498.41000000000 , &
+ 4492.23000000000 , &
+ 4486.02000000000 , &
+ 4479.78000000000 , &
+ 4473.51000000000 , &
+ 4467.20000000000 , &
+ 4460.87000000000 , &
+ 4454.49000000000 , &
+ 4448.08000000000 , &
+ 4441.63000000000 , &
+ 4435.13000000000 , &
+ 4428.60000000000 , &
+ 4428.59000000000 , &
+ 4423.32000000000 , &
+ 4418.01000000000 , &
+ 4412.67000000000 , &
+ 4407.30000000000 , &
+ 4401.90000000000 , &
+ 4396.45000000000 , &
+ 4390.96000000000 , &
+ 4385.40000000000 , &
+ 4379.81000000000 , &
+ 4374.16000000000 , &
+ 4368.47000000000 , &
+ 4362.72000000000 , &
+ 4356.92000000000 , &
+ 4351.08000000000 , &
+ 4345.18000000000 /)
+
+ Mref_V%density_ref( 601 : 630 ) = (/ &
+ 4339.24000000000 , &
+ 4047.01000000000 , &
+ 4042.50000000000 , &
+ 4037.98000000000 , &
+ 4033.48000000000 , &
+ 4028.95000000000 , &
+ 4024.45000000000 , &
+ 4019.93000000000 , &
+ 4015.42000000000 , &
+ 4010.90000000000 , &
+ 4006.38000000000 , &
+ 4001.87000000000 , &
+ 3997.35000000000 , &
+ 3992.84000000000 , &
+ 3988.32000000000 , &
+ 3983.80000000000 , &
+ 3983.80000000000 , &
+ 3975.79000000000 , &
+ 3967.77000000000 , &
+ 3959.76000000000 , &
+ 3951.75000000000 , &
+ 3943.73000000000 , &
+ 3935.71000000000 , &
+ 3927.69000000000 , &
+ 3919.67000000000 , &
+ 3911.65000000000 , &
+ 3903.61000000000 , &
+ 3895.58000000000 , &
+ 3887.56000000000 , &
+ 3879.53000000000 /)
+
+ Mref_V%density_ref( 631 : 660 ) = (/ &
+ 3871.50000000000 , &
+ 3863.46000000000 , &
+ 3855.42000000000 , &
+ 3847.38000000000 , &
+ 3839.33000000000 , &
+ 3831.27000000000 , &
+ 3823.22000000000 , &
+ 3815.16000000000 , &
+ 3807.09000000000 , &
+ 3799.01000000000 , &
+ 3790.94000000000 , &
+ 3782.85000000000 , &
+ 3774.78000000000 , &
+ 3766.66000000000 , &
+ 3758.56000000000 , &
+ 3750.45000000000 , &
+ 3742.34000000000 , &
+ 3554.91000000000 , &
+ 3551.00000000000 , &
+ 3547.07000000000 , &
+ 3543.16000000000 , &
+ 3539.23000000000 , &
+ 3535.32000000000 , &
+ 3531.39000000000 , &
+ 3527.46000000000 , &
+ 3523.57000000000 , &
+ 3519.67000000000 , &
+ 3515.77000000000 , &
+ 3511.91000000000 , &
+ 3508.06000000000 /)
+
+ Mref_V%density_ref( 661 : 690 ) = (/ &
+ 3504.21000000000 , &
+ 3500.39000000000 , &
+ 3496.58000000000 , &
+ 3492.80000000000 , &
+ 3489.05000000000 , &
+ 3485.32000000000 , &
+ 3481.61000000000 , &
+ 3477.88000000000 , &
+ 3474.16000000000 , &
+ 3470.41000000000 , &
+ 3466.59000000000 , &
+ 3462.74000000000 , &
+ 3458.78000000000 , &
+ 3454.75000000000 , &
+ 3450.61000000000 , &
+ 3446.33000000000 , &
+ 3441.91000000000 , &
+ 3437.35000000000 , &
+ 3437.34000000000 , &
+ 3432.81000000000 , &
+ 3428.15000000000 , &
+ 3423.37000000000 , &
+ 3418.47000000000 , &
+ 3413.47000000000 , &
+ 3408.35000000000 , &
+ 3403.15000000000 , &
+ 3397.87000000000 , &
+ 3392.50000000000 , &
+ 3387.07000000000 , &
+ 3381.58000000000 /)
+
+ Mref_V%density_ref( 691 : 720 ) = (/ &
+ 3376.03000000000 , &
+ 3370.45000000000 , &
+ 3364.87000000000 , &
+ 3359.31000000000 , &
+ 3353.79000000000 , &
+ 3348.37000000000 , &
+ 3343.03000000000 , &
+ 3337.85000000000 , &
+ 3332.83000000000 , &
+ 3328.01000000000 , &
+ 3323.39000000000 , &
+ 3319.04000000000 , &
+ 3319.03000000000 , &
+ 3316.33000000000 , &
+ 3313.75000000000 , &
+ 3311.30000000000 , &
+ 3308.97000000000 , &
+ 3306.73000000000 , &
+ 3304.58000000000 , &
+ 3302.53000000000 , &
+ 3300.55000000000 , &
+ 3298.63000000000 , &
+ 3296.79000000000 , &
+ 3295.00000000000 , &
+ 3293.25000000000 , &
+ 3291.54000000000 , &
+ 3289.84000000000 , &
+ 2900.00000000000 , &
+ 2900.00000000000 , &
+ 2900.00000000000 /)
+
+ Mref_V%density_ref( 721 : 750 ) = (/ &
+ 2900.00000000000 , &
+ 2900.00000000000 , &
+ 2900.00000000000 , &
+ 2900.00000000000 , &
+ 2900.00000000000 , &
+ 2900.00000000000 , &
+ 2900.00000000000 , &
+ 2900.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 , &
+ 2600.00000000000 /)
+
+ Mref_V%vpv_ref( 1 : 30 ) = (/ &
+ 11262.2000000000 , &
+ 11262.2000000000 , &
+ 11262.1800000000 , &
+ 11262.1400000000 , &
+ 11262.0900000000 , &
+ 11262.0200000000 , &
+ 11261.9400000000 , &
+ 11261.8500000000 , &
+ 11261.7400000000 , &
+ 11261.6100000000 , &
+ 11261.4700000000 , &
+ 11261.3200000000 , &
+ 11261.1500000000 , &
+ 11260.9700000000 , &
+ 11260.7700000000 , &
+ 11260.5600000000 , &
+ 11260.3400000000 , &
+ 11260.0900000000 , &
+ 11259.8400000000 , &
+ 11259.5700000000 , &
+ 11259.2800000000 , &
+ 11258.9900000000 , &
+ 11258.6700000000 , &
+ 11258.3400000000 , &
+ 11258.0000000000 , &
+ 11257.6400000000 , &
+ 11257.2700000000 , &
+ 11256.8800000000 , &
+ 11256.4800000000 , &
+ 11256.0600000000 /)
+
+ Mref_V%vpv_ref( 31 : 60 ) = (/ &
+ 11255.6300000000 , &
+ 11255.1900000000 , &
+ 11254.7300000000 , &
+ 11254.2500000000 , &
+ 11253.7600000000 , &
+ 11253.2600000000 , &
+ 11252.7400000000 , &
+ 11252.2100000000 , &
+ 11251.6600000000 , &
+ 11251.1000000000 , &
+ 11250.5200000000 , &
+ 11249.9300000000 , &
+ 11249.3300000000 , &
+ 11248.7100000000 , &
+ 11248.0700000000 , &
+ 11247.4200000000 , &
+ 11246.7600000000 , &
+ 11246.0800000000 , &
+ 11245.3800000000 , &
+ 11244.6700000000 , &
+ 11243.9500000000 , &
+ 11243.2100000000 , &
+ 11242.4600000000 , &
+ 11241.7000000000 , &
+ 11240.9100000000 , &
+ 11240.1200000000 , &
+ 11239.3100000000 , &
+ 11238.4800000000 , &
+ 11237.6400000000 , &
+ 11236.7900000000 /)
+
+ Mref_V%vpv_ref( 61 : 90 ) = (/ &
+ 11235.9200000000 , &
+ 11235.0400000000 , &
+ 11234.1400000000 , &
+ 11233.2300000000 , &
+ 11232.3000000000 , &
+ 11231.3600000000 , &
+ 11230.4000000000 , &
+ 11229.4300000000 , &
+ 11228.4400000000 , &
+ 11227.4400000000 , &
+ 11226.4300000000 , &
+ 11225.4000000000 , &
+ 11224.3600000000 , &
+ 11223.3000000000 , &
+ 11222.2200000000 , &
+ 11221.1400000000 , &
+ 11220.0300000000 , &
+ 11218.9200000000 , &
+ 11217.7800000000 , &
+ 11216.6400000000 , &
+ 11215.4800000000 , &
+ 11214.3000000000 , &
+ 11213.1100000000 , &
+ 11211.9100000000 , &
+ 11210.6900000000 , &
+ 11209.4500000000 , &
+ 11208.2100000000 , &
+ 11206.9400000000 , &
+ 11205.6700000000 , &
+ 11204.3700000000 /)
+
+ Mref_V%vpv_ref( 91 : 120 ) = (/ &
+ 11203.0700000000 , &
+ 11201.7400000000 , &
+ 11200.4100000000 , &
+ 11199.0600000000 , &
+ 11197.6900000000 , &
+ 11196.3100000000 , &
+ 11194.9200000000 , &
+ 11193.5100000000 , &
+ 11192.0900000000 , &
+ 11190.6500000000 , &
+ 11189.1900000000 , &
+ 11187.7300000000 , &
+ 11186.2400000000 , &
+ 11184.7500000000 , &
+ 11183.2400000000 , &
+ 11181.7100000000 , &
+ 11180.1700000000 , &
+ 11178.6100000000 , &
+ 11177.0400000000 , &
+ 11175.4600000000 , &
+ 11173.8600000000 , &
+ 11172.2500000000 , &
+ 11170.6200000000 , &
+ 11168.9800000000 , &
+ 11167.3200000000 , &
+ 11165.6500000000 , &
+ 11163.9600000000 , &
+ 11162.2600000000 , &
+ 11160.5400000000 , &
+ 11158.8100000000 /)
+
+ Mref_V%vpv_ref( 121 : 150 ) = (/ &
+ 11157.0700000000 , &
+ 11155.3100000000 , &
+ 11153.5400000000 , &
+ 11151.7500000000 , &
+ 11149.9400000000 , &
+ 11148.1300000000 , &
+ 11146.2900000000 , &
+ 11144.4500000000 , &
+ 11142.5800000000 , &
+ 11140.7100000000 , &
+ 11138.8200000000 , &
+ 11136.9100000000 , &
+ 11134.9900000000 , &
+ 11133.0600000000 , &
+ 11131.1100000000 , &
+ 11129.1400000000 , &
+ 11127.1600000000 , &
+ 11125.1700000000 , &
+ 11123.1600000000 , &
+ 11121.1400000000 , &
+ 11119.1000000000 , &
+ 11117.0500000000 , &
+ 11114.9900000000 , &
+ 11112.9000000000 , &
+ 11110.8100000000 , &
+ 11108.7000000000 , &
+ 11106.5700000000 , &
+ 11104.4400000000 , &
+ 11102.2800000000 , &
+ 11100.1100000000 /)
+
+ Mref_V%vpv_ref( 151 : 180 ) = (/ &
+ 11097.9300000000 , &
+ 11095.7300000000 , &
+ 11093.5200000000 , &
+ 11091.2900000000 , &
+ 11089.0500000000 , &
+ 11086.8000000000 , &
+ 11084.5300000000 , &
+ 11082.2400000000 , &
+ 11079.9400000000 , &
+ 11077.6300000000 , &
+ 11075.3000000000 , &
+ 11072.9500000000 , &
+ 11070.5900000000 , &
+ 11068.2200000000 , &
+ 11065.8300000000 , &
+ 11063.4300000000 , &
+ 11061.0200000000 , &
+ 11058.5800000000 , &
+ 11056.1400000000 , &
+ 11053.6800000000 , &
+ 11051.2000000000 , &
+ 11048.7100000000 , &
+ 11046.2100000000 , &
+ 11043.6900000000 , &
+ 11041.1600000000 , &
+ 11038.6100000000 , &
+ 11036.0500000000 , &
+ 11033.4700000000 , &
+ 11030.8800000000 , &
+ 11028.2700000000 /)
+
+ Mref_V%vpv_ref( 181 : 210 ) = (/ &
+ 10355.6900000000 , &
+ 10348.2800000000 , &
+ 10340.8500000000 , &
+ 10333.3900000000 , &
+ 10325.9100000000 , &
+ 10318.4000000000 , &
+ 10310.8700000000 , &
+ 10303.3000000000 , &
+ 10295.7100000000 , &
+ 10288.0900000000 , &
+ 10280.4400000000 , &
+ 10272.7600000000 , &
+ 10265.0400000000 , &
+ 10257.3000000000 , &
+ 10249.5200000000 , &
+ 10241.7100000000 , &
+ 10233.8600000000 , &
+ 10225.9800000000 , &
+ 10218.0600000000 , &
+ 10210.1100000000 , &
+ 10202.1200000000 , &
+ 10194.1000000000 , &
+ 10186.0400000000 , &
+ 10177.9400000000 , &
+ 10169.7900000000 , &
+ 10161.6100000000 , &
+ 10153.3900000000 , &
+ 10145.1300000000 , &
+ 10136.8300000000 , &
+ 10128.4800000000 /)
+
+ Mref_V%vpv_ref( 211 : 240 ) = (/ &
+ 10120.0900000000 , &
+ 10111.6600000000 , &
+ 10103.1800000000 , &
+ 10094.6600000000 , &
+ 10086.0900000000 , &
+ 10077.4800000000 , &
+ 10068.8200000000 , &
+ 10060.1100000000 , &
+ 10051.3500000000 , &
+ 10042.5400000000 , &
+ 10033.6900000000 , &
+ 10024.7800000000 , &
+ 10015.8200000000 , &
+ 10006.8200000000 , &
+ 9997.75000000000 , &
+ 9988.64000000000 , &
+ 9979.47000000000 , &
+ 9970.25000000000 , &
+ 9960.97000000000 , &
+ 9951.64000000000 , &
+ 9942.25000000000 , &
+ 9932.81000000000 , &
+ 9923.31000000000 , &
+ 9913.75000000000 , &
+ 9904.13000000000 , &
+ 9894.45000000000 , &
+ 9884.71000000000 , &
+ 9874.91000000000 , &
+ 9865.05000000000 , &
+ 9855.13000000000 /)
+
+ Mref_V%vpv_ref( 241 : 270 ) = (/ &
+ 9845.14000000000 , &
+ 9835.09000000000 , &
+ 9824.98000000000 , &
+ 9814.80000000000 , &
+ 9804.56000000000 , &
+ 9794.25000000000 , &
+ 9783.87000000000 , &
+ 9773.43000000000 , &
+ 9762.92000000000 , &
+ 9752.34000000000 , &
+ 9741.69000000000 , &
+ 9730.97000000000 , &
+ 9720.18000000000 , &
+ 9709.32000000000 , &
+ 9698.39000000000 , &
+ 9687.38000000000 , &
+ 9676.31000000000 , &
+ 9665.15000000000 , &
+ 9653.93000000000 , &
+ 9642.63000000000 , &
+ 9631.25000000000 , &
+ 9619.80000000000 , &
+ 9608.27000000000 , &
+ 9596.66000000000 , &
+ 9584.97000000000 , &
+ 9573.20000000000 , &
+ 9561.36000000000 , &
+ 9549.43000000000 , &
+ 9537.43000000000 , &
+ 9525.34000000000 /)
+
+ Mref_V%vpv_ref( 271 : 300 ) = (/ &
+ 9513.17000000000 , &
+ 9500.91000000000 , &
+ 9488.57000000000 , &
+ 9476.15000000000 , &
+ 9463.64000000000 , &
+ 9451.05000000000 , &
+ 9438.37000000000 , &
+ 9425.61000000000 , &
+ 9412.75000000000 , &
+ 9399.81000000000 , &
+ 9386.78000000000 , &
+ 9373.66000000000 , &
+ 9360.45000000000 , &
+ 9347.15000000000 , &
+ 9333.76000000000 , &
+ 9320.27000000000 , &
+ 9306.70000000000 , &
+ 9293.03000000000 , &
+ 9279.26000000000 , &
+ 9265.40000000000 , &
+ 9251.45000000000 , &
+ 9237.40000000000 , &
+ 9223.25000000000 , &
+ 9209.00000000000 , &
+ 9194.66000000000 , &
+ 9180.22000000000 , &
+ 9165.68000000000 , &
+ 9151.03000000000 , &
+ 9136.29000000000 , &
+ 9121.45000000000 /)
+
+ Mref_V%vpv_ref( 301 : 330 ) = (/ &
+ 9106.50000000000 , &
+ 9091.46000000000 , &
+ 9076.30000000000 , &
+ 9061.05000000000 , &
+ 9045.69000000000 , &
+ 9030.23000000000 , &
+ 9014.65000000000 , &
+ 8998.98000000000 , &
+ 8983.19000000000 , &
+ 8967.30000000000 , &
+ 8951.30000000000 , &
+ 8935.19000000000 , &
+ 8918.97000000000 , &
+ 8902.64000000000 , &
+ 8886.20000000000 , &
+ 8869.64000000000 , &
+ 8852.98000000000 , &
+ 8836.20000000000 , &
+ 8819.31000000000 , &
+ 8802.30000000000 , &
+ 8785.18000000000 , &
+ 8767.94000000000 , &
+ 8750.59000000000 , &
+ 8733.12000000000 , &
+ 8715.53000000000 , &
+ 8697.82000000000 , &
+ 8680.00000000000 , &
+ 8662.05000000000 , &
+ 8643.99000000000 , &
+ 8625.80000000000 /)
+
+ Mref_V%vpv_ref( 331 : 360 ) = (/ &
+ 8607.49000000000 , &
+ 8589.06000000000 , &
+ 8570.51000000000 , &
+ 8551.83000000000 , &
+ 8533.03000000000 , &
+ 8514.10000000000 , &
+ 8495.05000000000 , &
+ 8475.87000000000 , &
+ 8456.57000000000 , &
+ 8437.14000000000 , &
+ 8417.58000000000 , &
+ 8397.89000000000 , &
+ 8378.07000000000 , &
+ 8358.12000000000 , &
+ 8338.04000000000 , &
+ 8317.83000000000 , &
+ 8297.49000000000 , &
+ 8277.01000000000 , &
+ 8256.41000000000 , &
+ 8235.66000000000 , &
+ 8214.79000000000 , &
+ 8193.77000000000 , &
+ 8172.62000000000 , &
+ 8151.34000000000 , &
+ 8129.92000000000 , &
+ 8108.36000000000 , &
+ 8086.66000000000 , &
+ 8064.82000000000 , &
+ 13716.6000000000 , &
+ 13714.2900000000 /)
+
+ Mref_V%vpv_ref( 361 : 390 ) = (/ &
+ 13712.0000000000 , &
+ 13709.7000000000 , &
+ 13707.4200000000 , &
+ 13705.1400000000 , &
+ 13702.8600000000 , &
+ 13700.5900000000 , &
+ 13698.3300000000 , &
+ 13696.0700000000 , &
+ 13693.8200000000 , &
+ 13691.5700000000 , &
+ 13689.3300000000 , &
+ 13687.0900000000 , &
+ 13684.8600000000 , &
+ 13682.6300000000 , &
+ 13680.4100000000 , &
+ 13680.4100000000 , &
+ 13668.9000000000 , &
+ 13657.4300000000 , &
+ 13645.9700000000 , &
+ 13634.5400000000 , &
+ 13623.1400000000 , &
+ 13611.7600000000 , &
+ 13600.4000000000 , &
+ 13589.0700000000 , &
+ 13577.7600000000 , &
+ 13566.4700000000 , &
+ 13555.2000000000 , &
+ 13543.9500000000 , &
+ 13532.7200000000 , &
+ 13521.5100000000 /)
+
+ Mref_V%vpv_ref( 391 : 420 ) = (/ &
+ 13510.3200000000 , &
+ 13499.1400000000 , &
+ 13487.9900000000 , &
+ 13476.8500000000 , &
+ 13465.7300000000 , &
+ 13454.6300000000 , &
+ 13443.5400000000 , &
+ 13432.4600000000 , &
+ 13421.4100000000 , &
+ 13410.3600000000 , &
+ 13399.3300000000 , &
+ 13388.3100000000 , &
+ 13377.3100000000 , &
+ 13366.3100000000 , &
+ 13355.3300000000 , &
+ 13344.3600000000 , &
+ 13333.4000000000 , &
+ 13322.4500000000 , &
+ 13311.5100000000 , &
+ 13300.5800000000 , &
+ 13289.6600000000 , &
+ 13278.7400000000 , &
+ 13267.8400000000 , &
+ 13256.9300000000 , &
+ 13246.0400000000 , &
+ 13235.1500000000 , &
+ 13224.2700000000 , &
+ 13213.3900000000 , &
+ 13202.5100000000 , &
+ 13191.6400000000 /)
+
+ Mref_V%vpv_ref( 421 : 450 ) = (/ &
+ 13180.7800000000 , &
+ 13169.9100000000 , &
+ 13159.0500000000 , &
+ 13148.1900000000 , &
+ 13137.3300000000 , &
+ 13126.4700000000 , &
+ 13115.6100000000 , &
+ 13104.7500000000 , &
+ 13093.8900000000 , &
+ 13083.0200000000 , &
+ 13072.1600000000 , &
+ 13061.2900000000 , &
+ 13050.4200000000 , &
+ 13039.5500000000 , &
+ 13028.6700000000 , &
+ 13017.7800000000 , &
+ 13006.9000000000 , &
+ 12996.0000000000 , &
+ 12985.1000000000 , &
+ 12974.1900000000 , &
+ 12963.2800000000 , &
+ 12952.3600000000 , &
+ 12941.4200000000 , &
+ 12930.4800000000 , &
+ 12919.5400000000 , &
+ 12908.5800000000 , &
+ 12897.6100000000 , &
+ 12886.6300000000 , &
+ 12875.6300000000 , &
+ 12864.6300000000 /)
+
+ Mref_V%vpv_ref( 451 : 480 ) = (/ &
+ 12853.6100000000 , &
+ 12842.5800000000 , &
+ 12831.5400000000 , &
+ 12820.4800000000 , &
+ 12809.4100000000 , &
+ 12798.3200000000 , &
+ 12787.2200000000 , &
+ 12776.1000000000 , &
+ 12764.9600000000 , &
+ 12753.8100000000 , &
+ 12742.6300000000 , &
+ 12731.4400000000 , &
+ 12720.2400000000 , &
+ 12709.0100000000 , &
+ 12697.7600000000 , &
+ 12686.4900000000 , &
+ 12675.2000000000 , &
+ 12663.8900000000 , &
+ 12652.5600000000 , &
+ 12641.2000000000 , &
+ 12629.8200000000 , &
+ 12618.4200000000 , &
+ 12606.9900000000 , &
+ 12595.5400000000 , &
+ 12584.0600000000 , &
+ 12572.5600000000 , &
+ 12561.0300000000 , &
+ 12549.4800000000 , &
+ 12537.8900000000 , &
+ 12526.2800000000 /)
+
+ Mref_V%vpv_ref( 481 : 510 ) = (/ &
+ 12514.6400000000 , &
+ 12502.9800000000 , &
+ 12491.2800000000 , &
+ 12479.5500000000 , &
+ 12467.7900000000 , &
+ 12456.0100000000 , &
+ 12444.1900000000 , &
+ 12432.3300000000 , &
+ 12420.4500000000 , &
+ 12408.5300000000 , &
+ 12396.5800000000 , &
+ 12384.6000000000 , &
+ 12372.5800000000 , &
+ 12360.5200000000 , &
+ 12348.4300000000 , &
+ 12336.3000000000 , &
+ 12324.1400000000 , &
+ 12311.9400000000 , &
+ 12299.7000000000 , &
+ 12287.4200000000 , &
+ 12275.1100000000 , &
+ 12262.7500000000 , &
+ 12250.3500000000 , &
+ 12237.9200000000 , &
+ 12225.4400000000 , &
+ 12212.9200000000 , &
+ 12200.3600000000 , &
+ 12187.7600000000 , &
+ 12175.1100000000 , &
+ 12162.4300000000 /)
+
+ Mref_V%vpv_ref( 511 : 540 ) = (/ &
+ 12149.6900000000 , &
+ 12136.9100000000 , &
+ 12124.0900000000 , &
+ 12111.2200000000 , &
+ 12098.3100000000 , &
+ 12085.3400000000 , &
+ 12072.3400000000 , &
+ 12059.2800000000 , &
+ 12046.1700000000 , &
+ 12033.0200000000 , &
+ 12019.8200000000 , &
+ 12006.5600000000 , &
+ 11993.2600000000 , &
+ 11979.9000000000 , &
+ 11966.5000000000 , &
+ 11953.0400000000 , &
+ 11939.5300000000 , &
+ 11925.9700000000 , &
+ 11912.3500000000 , &
+ 11898.6900000000 , &
+ 11884.9600000000 , &
+ 11871.1900000000 , &
+ 11857.3700000000 , &
+ 11843.4800000000 , &
+ 11829.5500000000 , &
+ 11815.5700000000 , &
+ 11801.5300000000 , &
+ 11787.4400000000 , &
+ 11773.3000000000 , &
+ 11759.1000000000 /)
+
+ Mref_V%vpv_ref( 541 : 570 ) = (/ &
+ 11744.8500000000 , &
+ 11730.5500000000 , &
+ 11716.1800000000 , &
+ 11701.7800000000 , &
+ 11687.3100000000 , &
+ 11672.8000000000 , &
+ 11658.2300000000 , &
+ 11643.6000000000 , &
+ 11628.9200000000 , &
+ 11614.1900000000 , &
+ 11599.4000000000 , &
+ 11584.5700000000 , &
+ 11569.6800000000 , &
+ 11554.7200000000 , &
+ 11539.7200000000 , &
+ 11524.6700000000 , &
+ 11509.5600000000 , &
+ 11494.3900000000 , &
+ 11479.1700000000 , &
+ 11463.8900000000 , &
+ 11448.5500000000 , &
+ 11433.1700000000 , &
+ 11417.7300000000 , &
+ 11402.2300000000 , &
+ 11386.6800000000 , &
+ 11371.0700000000 , &
+ 11355.4100000000 , &
+ 11339.6900000000 , &
+ 11323.9100000000 , &
+ 11308.0900000000 /)
+
+ Mref_V%vpv_ref( 571 : 600 ) = (/ &
+ 11292.2000000000 , &
+ 11276.2500000000 , &
+ 11260.2500000000 , &
+ 11244.1900000000 , &
+ 11228.0800000000 , &
+ 11211.9000000000 , &
+ 11195.6700000000 , &
+ 11179.3800000000 , &
+ 11163.0400000000 , &
+ 11146.6300000000 , &
+ 11130.1800000000 , &
+ 11113.6700000000 , &
+ 11097.1100000000 , &
+ 11080.5100000000 , &
+ 11080.5100000000 , &
+ 11063.0100000000 , &
+ 11045.2200000000 , &
+ 11026.8200000000 , &
+ 11008.4700000000 , &
+ 10989.0400000000 , &
+ 10969.6300000000 , &
+ 10948.7600000000 , &
+ 10928.0200000000 , &
+ 10907.4200000000 , &
+ 10886.9400000000 , &
+ 10866.6000000000 , &
+ 10846.4100000000 , &
+ 10826.3500000000 , &
+ 10806.4200000000 , &
+ 10786.6100000000 /)
+
+ Mref_V%vpv_ref( 601 : 630 ) = (/ &
+ 10766.9000000000 , &
+ 10278.8800000000 , &
+ 10261.8700000000 , &
+ 10244.8400000000 , &
+ 10227.8200000000 , &
+ 10210.8000000000 , &
+ 10193.7800000000 , &
+ 10176.7700000000 , &
+ 10159.7400000000 , &
+ 10142.7200000000 , &
+ 10125.7100000000 , &
+ 10108.7000000000 , &
+ 10091.6800000000 , &
+ 10074.6800000000 , &
+ 10057.6800000000 , &
+ 10040.6400000000 , &
+ 10040.6700000000 , &
+ 10010.5200000000 , &
+ 9980.51000000000 , &
+ 9950.64000000000 , &
+ 9920.91000000000 , &
+ 9891.35000000000 , &
+ 9861.96000000000 , &
+ 9832.79000000000 , &
+ 9803.79000000000 , &
+ 9774.98000000000 , &
+ 9746.41000000000 , &
+ 9718.08000000000 , &
+ 9689.96000000000 , &
+ 9662.10000000000 /)
+
+ Mref_V%vpv_ref( 631 : 660 ) = (/ &
+ 9634.47000000000 , &
+ 9607.11000000000 , &
+ 9579.97000000000 , &
+ 9553.08000000000 , &
+ 9526.38000000000 , &
+ 9499.78000000000 , &
+ 9473.25000000000 , &
+ 9446.74000000000 , &
+ 9420.19000000000 , &
+ 9393.55000000000 , &
+ 9366.75000000000 , &
+ 9339.76000000000 , &
+ 9312.50000000000 , &
+ 9284.96000000000 , &
+ 9257.04000000000 , &
+ 9228.73000000000 , &
+ 9199.94000000000 , &
+ 8940.94000000000 , &
+ 8930.61000000000 , &
+ 8920.22000000000 , &
+ 8909.68000000000 , &
+ 8898.47000000000 , &
+ 8886.28000000000 , &
+ 8873.03000000000 , &
+ 8858.58000000000 , &
+ 8842.82000000000 , &
+ 8825.64000000000 , &
+ 8806.94000000000 , &
+ 8786.67000000000 , &
+ 8764.85000000000 /)
+
+ Mref_V%vpv_ref( 661 : 690 ) = (/ &
+ 8741.49000000000 , &
+ 8716.63000000000 , &
+ 8690.30000000000 , &
+ 8662.50000000000 , &
+ 8633.28000000000 , &
+ 8602.66000000000 , &
+ 8570.81000000000 , &
+ 8538.06000000000 , &
+ 8504.66000000000 , &
+ 8470.92000000000 , &
+ 8437.13000000000 , &
+ 8403.52000000000 , &
+ 8370.42000000000 , &
+ 8338.11000000000 , &
+ 8306.25000000000 , &
+ 8275.42000000000 , &
+ 8241.77000000000 , &
+ 8207.37000000000 , &
+ 8207.01000000000 , &
+ 8174.32000000000 , &
+ 8141.99000000000 , &
+ 8110.40000000000 , &
+ 8079.71000000000 , &
+ 8050.15000000000 , &
+ 8021.89000000000 , &
+ 7995.08000000000 , &
+ 7969.97000000000 , &
+ 7946.70000000000 , &
+ 7925.45000000000 , &
+ 7906.44000000000 /)
+
+ Mref_V%vpv_ref( 691 : 720 ) = (/ &
+ 7889.80000000000 , &
+ 7875.56000000000 , &
+ 7863.64000000000 , &
+ 7853.87000000000 , &
+ 7846.17000000000 , &
+ 7840.38000000000 , &
+ 7836.39000000000 , &
+ 7834.11000000000 , &
+ 7833.38000000000 , &
+ 7834.11000000000 , &
+ 7836.11000000000 , &
+ 7839.12000000000 , &
+ 7839.37000000000 , &
+ 7841.82000000000 , &
+ 7844.77000000000 , &
+ 7848.07000000000 , &
+ 7851.72000000000 , &
+ 7855.75000000000 , &
+ 7860.14000000000 , &
+ 7864.89000000000 , &
+ 7870.01000000000 , &
+ 7875.49000000000 , &
+ 7881.33000000000 , &
+ 7887.54000000000 , &
+ 7894.13000000000 , &
+ 7901.10000000000 , &
+ 7908.24000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 /)
+
+ Mref_V%vpv_ref( 721 : 750 ) = (/ &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 /)
+
+ Mref_V%vsv_ref( 1 : 30 ) = (/ &
+ 3667.80000000000 , &
+ 3667.79000000000 , &
+ 3667.78000000000 , &
+ 3667.75000000000 , &
+ 3667.72000000000 , &
+ 3667.67000000000 , &
+ 3667.62000000000 , &
+ 3667.55000000000 , &
+ 3667.47000000000 , &
+ 3667.39000000000 , &
+ 3667.29000000000 , &
+ 3667.18000000000 , &
+ 3667.06000000000 , &
+ 3666.94000000000 , &
+ 3666.80000000000 , &
+ 3666.65000000000 , &
+ 3666.49000000000 , &
+ 3666.32000000000 , &
+ 3666.15000000000 , &
+ 3665.96000000000 , &
+ 3665.76000000000 , &
+ 3665.55000000000 , &
+ 3665.33000000000 , &
+ 3665.10000000000 , &
+ 3664.86000000000 , &
+ 3664.61000000000 , &
+ 3664.35000000000 , &
+ 3664.08000000000 , &
+ 3663.80000000000 , &
+ 3663.51000000000 /)
+
+ Mref_V%vsv_ref( 31 : 60 ) = (/ &
+ 3663.21000000000 , &
+ 3662.90000000000 , &
+ 3662.57000000000 , &
+ 3662.24000000000 , &
+ 3661.90000000000 , &
+ 3661.55000000000 , &
+ 3661.19000000000 , &
+ 3660.81000000000 , &
+ 3660.43000000000 , &
+ 3660.04000000000 , &
+ 3659.64000000000 , &
+ 3659.22000000000 , &
+ 3658.80000000000 , &
+ 3658.36000000000 , &
+ 3657.92000000000 , &
+ 3657.47000000000 , &
+ 3657.00000000000 , &
+ 3656.53000000000 , &
+ 3656.04000000000 , &
+ 3655.55000000000 , &
+ 3655.04000000000 , &
+ 3654.53000000000 , &
+ 3654.00000000000 , &
+ 3653.47000000000 , &
+ 3652.92000000000 , &
+ 3652.36000000000 , &
+ 3651.80000000000 , &
+ 3651.22000000000 , &
+ 3650.63000000000 , &
+ 3650.04000000000 /)
+
+ Mref_V%vsv_ref( 61 : 90 ) = (/ &
+ 3649.43000000000 , &
+ 3648.81000000000 , &
+ 3648.19000000000 , &
+ 3647.55000000000 , &
+ 3646.90000000000 , &
+ 3646.24000000000 , &
+ 3645.57000000000 , &
+ 3644.89000000000 , &
+ 3644.21000000000 , &
+ 3643.51000000000 , &
+ 3642.80000000000 , &
+ 3642.08000000000 , &
+ 3641.35000000000 , &
+ 3640.61000000000 , &
+ 3639.86000000000 , &
+ 3639.10000000000 , &
+ 3638.33000000000 , &
+ 3637.55000000000 , &
+ 3636.76000000000 , &
+ 3635.96000000000 , &
+ 3635.14000000000 , &
+ 3634.32000000000 , &
+ 3633.49000000000 , &
+ 3632.65000000000 , &
+ 3631.80000000000 , &
+ 3630.93000000000 , &
+ 3630.06000000000 , &
+ 3629.18000000000 , &
+ 3628.29000000000 , &
+ 3627.38000000000 /)
+
+ Mref_V%vsv_ref( 91 : 120 ) = (/ &
+ 3626.47000000000 , &
+ 3625.55000000000 , &
+ 3624.61000000000 , &
+ 3623.67000000000 , &
+ 3622.71000000000 , &
+ 3621.75000000000 , &
+ 3620.78000000000 , &
+ 3619.79000000000 , &
+ 3618.80000000000 , &
+ 3617.79000000000 , &
+ 3616.78000000000 , &
+ 3615.75000000000 , &
+ 3614.71000000000 , &
+ 3613.67000000000 , &
+ 3612.61000000000 , &
+ 3611.55000000000 , &
+ 3610.47000000000 , &
+ 3609.38000000000 , &
+ 3608.28000000000 , &
+ 3607.18000000000 , &
+ 3606.06000000000 , &
+ 3604.93000000000 , &
+ 3603.79000000000 , &
+ 3602.65000000000 , &
+ 3601.49000000000 , &
+ 3600.32000000000 , &
+ 3599.14000000000 , &
+ 3597.95000000000 , &
+ 3596.75000000000 , &
+ 3595.54000000000 /)
+
+ Mref_V%vsv_ref( 121 : 150 ) = (/ &
+ 3594.32000000000 , &
+ 3593.10000000000 , &
+ 3591.86000000000 , &
+ 3590.61000000000 , &
+ 3589.34000000000 , &
+ 3588.07000000000 , &
+ 3586.79000000000 , &
+ 3585.50000000000 , &
+ 3584.20000000000 , &
+ 3582.89000000000 , &
+ 3581.57000000000 , &
+ 3580.24000000000 , &
+ 3578.90000000000 , &
+ 3577.54000000000 , &
+ 3576.18000000000 , &
+ 3574.81000000000 , &
+ 3573.43000000000 , &
+ 3572.03000000000 , &
+ 3570.63000000000 , &
+ 3569.22000000000 , &
+ 3567.79000000000 , &
+ 3566.36000000000 , &
+ 3564.91000000000 , &
+ 3563.46000000000 , &
+ 3562.00000000000 , &
+ 3560.52000000000 , &
+ 3559.04000000000 , &
+ 3557.54000000000 , &
+ 3556.04000000000 , &
+ 3554.52000000000 /)
+
+ Mref_V%vsv_ref( 151 : 180 ) = (/ &
+ 3553.00000000000 , &
+ 3551.46000000000 , &
+ 3549.91000000000 , &
+ 3548.36000000000 , &
+ 3546.79000000000 , &
+ 3545.21000000000 , &
+ 3543.63000000000 , &
+ 3542.03000000000 , &
+ 3540.42000000000 , &
+ 3538.81000000000 , &
+ 3537.18000000000 , &
+ 3535.54000000000 , &
+ 3533.89000000000 , &
+ 3532.23000000000 , &
+ 3530.57000000000 , &
+ 3528.89000000000 , &
+ 3527.20000000000 , &
+ 3525.50000000000 , &
+ 3523.79000000000 , &
+ 3522.07000000000 , &
+ 3520.34000000000 , &
+ 3518.60000000000 , &
+ 3516.85000000000 , &
+ 3515.09000000000 , &
+ 3513.32000000000 , &
+ 3511.54000000000 , &
+ 3509.75000000000 , &
+ 3507.95000000000 , &
+ 3506.13000000000 , &
+ 3504.31000000000 /)
+
+ Mref_V%vsv_ref( 181 : 210 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsv_ref( 211 : 240 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsv_ref( 241 : 270 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsv_ref( 271 : 300 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsv_ref( 301 : 330 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsv_ref( 331 : 360 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 7264.66000000000 , &
+ 7264.75000000000 /)
+
+ Mref_V%vsv_ref( 361 : 390 ) = (/ &
+ 7264.85000000000 , &
+ 7264.94000000000 , &
+ 7265.03000000000 , &
+ 7265.12000000000 , &
+ 7265.21000000000 , &
+ 7265.29000000000 , &
+ 7265.38000000000 , &
+ 7265.46000000000 , &
+ 7265.54000000000 , &
+ 7265.62000000000 , &
+ 7265.69000000000 , &
+ 7265.76000000000 , &
+ 7265.84000000000 , &
+ 7265.91000000000 , &
+ 7265.97000000000 , &
+ 7265.97000000000 , &
+ 7261.63000000000 , &
+ 7257.29000000000 , &
+ 7252.97000000000 , &
+ 7248.64000000000 , &
+ 7244.33000000000 , &
+ 7240.01000000000 , &
+ 7235.71000000000 , &
+ 7231.41000000000 , &
+ 7227.12000000000 , &
+ 7222.83000000000 , &
+ 7218.55000000000 , &
+ 7214.27000000000 , &
+ 7210.00000000000 , &
+ 7205.73000000000 /)
+
+ Mref_V%vsv_ref( 391 : 420 ) = (/ &
+ 7201.47000000000 , &
+ 7197.21000000000 , &
+ 7192.95000000000 , &
+ 7188.70000000000 , &
+ 7184.45000000000 , &
+ 7180.21000000000 , &
+ 7175.97000000000 , &
+ 7171.73000000000 , &
+ 7167.50000000000 , &
+ 7163.27000000000 , &
+ 7159.04000000000 , &
+ 7154.81000000000 , &
+ 7150.59000000000 , &
+ 7146.37000000000 , &
+ 7142.15000000000 , &
+ 7137.93000000000 , &
+ 7133.71000000000 , &
+ 7129.50000000000 , &
+ 7125.29000000000 , &
+ 7121.07000000000 , &
+ 7116.86000000000 , &
+ 7112.65000000000 , &
+ 7108.44000000000 , &
+ 7104.23000000000 , &
+ 7100.02000000000 , &
+ 7095.81000000000 , &
+ 7091.60000000000 , &
+ 7087.39000000000 , &
+ 7083.18000000000 , &
+ 7078.96000000000 /)
+
+ Mref_V%vsv_ref( 421 : 450 ) = (/ &
+ 7074.75000000000 , &
+ 7070.54000000000 , &
+ 7066.32000000000 , &
+ 7062.10000000000 , &
+ 7057.88000000000 , &
+ 7053.66000000000 , &
+ 7049.44000000000 , &
+ 7045.22000000000 , &
+ 7040.99000000000 , &
+ 7036.76000000000 , &
+ 7032.52000000000 , &
+ 7028.29000000000 , &
+ 7024.05000000000 , &
+ 7019.81000000000 , &
+ 7015.56000000000 , &
+ 7011.31000000000 , &
+ 7007.06000000000 , &
+ 7002.80000000000 , &
+ 6998.54000000000 , &
+ 6994.27000000000 , &
+ 6990.00000000000 , &
+ 6985.72000000000 , &
+ 6981.44000000000 , &
+ 6977.15000000000 , &
+ 6972.86000000000 , &
+ 6968.57000000000 , &
+ 6964.26000000000 , &
+ 6959.95000000000 , &
+ 6955.64000000000 , &
+ 6951.32000000000 /)
+
+ Mref_V%vsv_ref( 451 : 480 ) = (/ &
+ 6946.99000000000 , &
+ 6942.66000000000 , &
+ 6938.31000000000 , &
+ 6933.97000000000 , &
+ 6929.61000000000 , &
+ 6925.25000000000 , &
+ 6920.88000000000 , &
+ 6916.50000000000 , &
+ 6912.11000000000 , &
+ 6907.72000000000 , &
+ 6903.32000000000 , &
+ 6898.91000000000 , &
+ 6894.49000000000 , &
+ 6890.06000000000 , &
+ 6885.62000000000 , &
+ 6881.17000000000 , &
+ 6876.72000000000 , &
+ 6872.25000000000 , &
+ 6867.78000000000 , &
+ 6863.29000000000 , &
+ 6858.80000000000 , &
+ 6854.29000000000 , &
+ 6849.78000000000 , &
+ 6845.25000000000 , &
+ 6840.71000000000 , &
+ 6836.16000000000 , &
+ 6831.60000000000 , &
+ 6827.03000000000 , &
+ 6822.45000000000 , &
+ 6817.85000000000 /)
+
+ Mref_V%vsv_ref( 481 : 510 ) = (/ &
+ 6813.25000000000 , &
+ 6808.63000000000 , &
+ 6804.00000000000 , &
+ 6799.35000000000 , &
+ 6794.70000000000 , &
+ 6790.03000000000 , &
+ 6785.34000000000 , &
+ 6780.65000000000 , &
+ 6775.94000000000 , &
+ 6771.22000000000 , &
+ 6766.48000000000 , &
+ 6761.73000000000 , &
+ 6756.97000000000 , &
+ 6752.19000000000 , &
+ 6747.40000000000 , &
+ 6742.59000000000 , &
+ 6737.76000000000 , &
+ 6732.93000000000 , &
+ 6728.07000000000 , &
+ 6723.21000000000 , &
+ 6718.32000000000 , &
+ 6713.42000000000 , &
+ 6708.51000000000 , &
+ 6703.57000000000 , &
+ 6698.62000000000 , &
+ 6693.66000000000 , &
+ 6688.68000000000 , &
+ 6683.68000000000 , &
+ 6678.66000000000 , &
+ 6673.63000000000 /)
+
+ Mref_V%vsv_ref( 511 : 540 ) = (/ &
+ 6668.58000000000 , &
+ 6663.51000000000 , &
+ 6658.43000000000 , &
+ 6653.32000000000 , &
+ 6648.20000000000 , &
+ 6643.06000000000 , &
+ 6637.90000000000 , &
+ 6632.73000000000 , &
+ 6627.53000000000 , &
+ 6622.31000000000 , &
+ 6617.08000000000 , &
+ 6611.82000000000 , &
+ 6606.55000000000 , &
+ 6601.26000000000 , &
+ 6595.94000000000 , &
+ 6590.61000000000 , &
+ 6584.91000000000 , &
+ 6579.51000000000 , &
+ 6574.11000000000 , &
+ 6568.67000000000 , &
+ 6563.22000000000 , &
+ 6557.74000000000 , &
+ 6552.24000000000 , &
+ 6546.73000000000 , &
+ 6541.19000000000 , &
+ 6535.63000000000 , &
+ 6530.05000000000 , &
+ 6524.44000000000 , &
+ 6518.82000000000 , &
+ 6513.17000000000 /)
+
+ Mref_V%vsv_ref( 541 : 570 ) = (/ &
+ 6507.50000000000 , &
+ 6501.80000000000 , &
+ 6496.09000000000 , &
+ 6490.35000000000 , &
+ 6484.59000000000 , &
+ 6478.80000000000 , &
+ 6472.99000000000 , &
+ 6467.16000000000 , &
+ 6461.30000000000 , &
+ 6455.42000000000 , &
+ 6449.51000000000 , &
+ 6443.58000000000 , &
+ 6437.63000000000 , &
+ 6431.65000000000 , &
+ 6425.65000000000 , &
+ 6419.61000000000 , &
+ 6413.56000000000 , &
+ 6407.48000000000 , &
+ 6401.37000000000 , &
+ 6395.25000000000 , &
+ 6389.09000000000 , &
+ 6382.91000000000 , &
+ 6376.70000000000 , &
+ 6370.46000000000 , &
+ 6364.20000000000 , &
+ 6357.91000000000 , &
+ 6351.59000000000 , &
+ 6345.25000000000 , &
+ 6338.88000000000 , &
+ 6332.49000000000 /)
+
+ Mref_V%vsv_ref( 571 : 600 ) = (/ &
+ 6326.05000000000 , &
+ 6319.60000000000 , &
+ 6313.13000000000 , &
+ 6306.62000000000 , &
+ 6300.08000000000 , &
+ 6293.52000000000 , &
+ 6286.92000000000 , &
+ 6280.29000000000 , &
+ 6273.64000000000 , &
+ 6266.96000000000 , &
+ 6260.25000000000 , &
+ 6253.51000000000 , &
+ 6246.75000000000 , &
+ 6239.95000000000 , &
+ 6239.95000000000 , &
+ 6219.68000000000 , &
+ 6200.29000000000 , &
+ 6181.16000000000 , &
+ 6162.04000000000 , &
+ 6143.01000000000 , &
+ 6123.98000000000 , &
+ 6103.71000000000 , &
+ 6083.53000000000 , &
+ 6063.45000000000 , &
+ 6043.44000000000 , &
+ 6023.52000000000 , &
+ 6003.73000000000 , &
+ 5984.03000000000 , &
+ 5964.38000000000 , &
+ 5944.81000000000 /)
+
+ Mref_V%vsv_ref( 601 : 630 ) = (/ &
+ 5925.27000000000 , &
+ 5550.32000000000 , &
+ 5541.20000000000 , &
+ 5532.08000000000 , &
+ 5522.96000000000 , &
+ 5513.83000000000 , &
+ 5504.71000000000 , &
+ 5495.59000000000 , &
+ 5486.47000000000 , &
+ 5477.35000000000 , &
+ 5468.22000000000 , &
+ 5459.10000000000 , &
+ 5449.97000000000 , &
+ 5440.84000000000 , &
+ 5431.71000000000 , &
+ 5422.57000000000 , &
+ 5422.59000000000 , &
+ 5406.39000000000 , &
+ 5390.30000000000 , &
+ 5374.34000000000 , &
+ 5358.52000000000 , &
+ 5342.83000000000 , &
+ 5327.31000000000 , &
+ 5311.92000000000 , &
+ 5296.73000000000 , &
+ 5281.71000000000 , &
+ 5266.86000000000 , &
+ 5252.21000000000 , &
+ 5237.78000000000 , &
+ 5223.55000000000 /)
+
+ Mref_V%vsv_ref( 631 : 660 ) = (/ &
+ 5209.54000000000 , &
+ 5195.72000000000 , &
+ 5182.10000000000 , &
+ 5168.69000000000 , &
+ 5155.42000000000 , &
+ 5142.22000000000 , &
+ 5129.05000000000 , &
+ 5115.84000000000 , &
+ 5102.55000000000 , &
+ 5089.14000000000 , &
+ 5075.50000000000 , &
+ 5061.63000000000 , &
+ 5047.46000000000 , &
+ 5032.93000000000 , &
+ 5018.03000000000 , &
+ 5002.66000000000 , &
+ 4986.77000000000 , &
+ 4802.15000000000 , &
+ 4798.23000000000 , &
+ 4794.28000000000 , &
+ 4790.38000000000 , &
+ 4785.95000000000 , &
+ 4780.83000000000 , &
+ 4775.01000000000 , &
+ 4768.45000000000 , &
+ 4761.12000000000 , &
+ 4752.97000000000 , &
+ 4744.01000000000 , &
+ 4734.25000000000 , &
+ 4723.77000000000 /)
+
+ Mref_V%vsv_ref( 661 : 690 ) = (/ &
+ 4712.70000000000 , &
+ 4701.12000000000 , &
+ 4689.11000000000 , &
+ 4676.77000000000 , &
+ 4664.20000000000 , &
+ 4651.49000000000 , &
+ 4638.69000000000 , &
+ 4625.88000000000 , &
+ 4613.07000000000 , &
+ 4600.31000000000 , &
+ 4587.67000000000 , &
+ 4575.18000000000 , &
+ 4562.88000000000 , &
+ 4550.85000000000 , &
+ 4539.08000000000 , &
+ 4527.67000000000 , &
+ 4516.65000000000 , &
+ 4506.09000000000 , &
+ 4506.00000000000 , &
+ 4496.29000000000 , &
+ 4487.00000000000 , &
+ 4478.17000000000 , &
+ 4469.83000000000 , &
+ 4462.00000000000 , &
+ 4454.69000000000 , &
+ 4447.94000000000 , &
+ 4441.76000000000 , &
+ 4436.18000000000 , &
+ 4431.20000000000 , &
+ 4426.83000000000 /)
+
+ Mref_V%vsv_ref( 691 : 720 ) = (/ &
+ 4423.12000000000 , &
+ 4420.09000000000 , &
+ 4417.81000000000 , &
+ 4416.30000000000 , &
+ 4415.67000000000 , &
+ 4415.93000000000 , &
+ 4417.15000000000 , &
+ 4419.42000000000 , &
+ 4422.78000000000 , &
+ 4427.25000000000 , &
+ 4432.88000000000 , &
+ 4439.57000000000 , &
+ 4439.74000000000 , &
+ 4444.71000000000 , &
+ 4450.28000000000 , &
+ 4456.35000000000 , &
+ 4462.89000000000 , &
+ 4469.94000000000 , &
+ 4477.40000000000 , &
+ 4485.33000000000 , &
+ 4493.69000000000 , &
+ 4502.48000000000 , &
+ 4511.66000000000 , &
+ 4521.24000000000 , &
+ 4531.23000000000 , &
+ 4541.57000000000 , &
+ 4552.08000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 /)
+
+ Mref_V%vsv_ref( 721 : 750 ) = (/ &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 /)
+
+ Mref_V%Qkappa_ref( 1 : 30 ) = (/ &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 /)
+
+ Mref_V%Qkappa_ref( 31 : 60 ) = (/ &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 /)
+
+ Mref_V%Qkappa_ref( 61 : 90 ) = (/ &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 /)
+
+ Mref_V%Qkappa_ref( 91 : 120 ) = (/ &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 /)
+
+ Mref_V%Qkappa_ref( 121 : 150 ) = (/ &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 /)
+
+ Mref_V%Qkappa_ref( 151 : 180 ) = (/ &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 , &
+ 1327.60000000000 /)
+
+ Mref_V%Qkappa_ref( 181 : 210 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 211 : 240 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 241 : 270 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 271 : 300 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 301 : 330 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 331 : 360 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 361 : 390 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 391 : 420 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 421 : 450 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 451 : 480 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 481 : 510 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 511 : 540 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 541 : 570 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 571 : 600 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 601 : 630 ) = (/ &
+ 57822.5000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 /)
+
+ Mref_V%Qkappa_ref( 631 : 660 ) = (/ &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 /)
+
+ Mref_V%Qkappa_ref( 661 : 690 ) = (/ &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 /)
+
+ Mref_V%Qkappa_ref( 691 : 720 ) = (/ &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 943.000000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qkappa_ref( 721 : 750 ) = (/ &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 , &
+ 57822.5000000000 /)
+
+ Mref_V%Qmu_ref( 1 : 30 ) = (/ &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 /)
+
+ Mref_V%Qmu_ref( 31 : 60 ) = (/ &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 /)
+
+ Mref_V%Qmu_ref( 61 : 90 ) = (/ &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 /)
+
+ Mref_V%Qmu_ref( 91 : 120 ) = (/ &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 /)
+
+ Mref_V%Qmu_ref( 121 : 150 ) = (/ &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 /)
+
+ Mref_V%Qmu_ref( 151 : 180 ) = (/ &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 , &
+ 104.000000000000 /)
+
+ Mref_V%Qmu_ref( 181 : 210 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%Qmu_ref( 211 : 240 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%Qmu_ref( 241 : 270 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%Qmu_ref( 271 : 300 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%Qmu_ref( 301 : 330 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%Qmu_ref( 331 : 360 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 361 : 390 ) = (/ &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 391 : 420 ) = (/ &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 421 : 450 ) = (/ &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 451 : 480 ) = (/ &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 481 : 510 ) = (/ &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 511 : 540 ) = (/ &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 541 : 570 ) = (/ &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 571 : 600 ) = (/ &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 , &
+ 355.000000000000 /)
+
+ Mref_V%Qmu_ref( 601 : 630 ) = (/ &
+ 355.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 /)
+
+ Mref_V%Qmu_ref( 631 : 660 ) = (/ &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 /)
+
+ Mref_V%Qmu_ref( 661 : 690 ) = (/ &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 165.000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 /)
+
+ Mref_V%Qmu_ref( 691 : 720 ) = (/ &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 70.0000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 191.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 /)
+
+ Mref_V%Qmu_ref( 721 : 750 ) = (/ &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 , &
+ 300.000000000000 /)
+
+ Mref_V%vph_ref( 1 : 30 ) = (/ &
+ 11262.2000000000 , &
+ 11262.2000000000 , &
+ 11262.1800000000 , &
+ 11262.1400000000 , &
+ 11262.0900000000 , &
+ 11262.0200000000 , &
+ 11261.9400000000 , &
+ 11261.8500000000 , &
+ 11261.7400000000 , &
+ 11261.6100000000 , &
+ 11261.4700000000 , &
+ 11261.3200000000 , &
+ 11261.1500000000 , &
+ 11260.9700000000 , &
+ 11260.7700000000 , &
+ 11260.5600000000 , &
+ 11260.3400000000 , &
+ 11260.0900000000 , &
+ 11259.8400000000 , &
+ 11259.5700000000 , &
+ 11259.2800000000 , &
+ 11258.9900000000 , &
+ 11258.6700000000 , &
+ 11258.3400000000 , &
+ 11258.0000000000 , &
+ 11257.6400000000 , &
+ 11257.2700000000 , &
+ 11256.8800000000 , &
+ 11256.4800000000 , &
+ 11256.0600000000 /)
+
+ Mref_V%vph_ref( 31 : 60 ) = (/ &
+ 11255.6300000000 , &
+ 11255.1900000000 , &
+ 11254.7300000000 , &
+ 11254.2500000000 , &
+ 11253.7600000000 , &
+ 11253.2600000000 , &
+ 11252.7400000000 , &
+ 11252.2100000000 , &
+ 11251.6600000000 , &
+ 11251.1000000000 , &
+ 11250.5200000000 , &
+ 11249.9300000000 , &
+ 11249.3300000000 , &
+ 11248.7100000000 , &
+ 11248.0700000000 , &
+ 11247.4200000000 , &
+ 11246.7600000000 , &
+ 11246.0800000000 , &
+ 11245.3800000000 , &
+ 11244.6700000000 , &
+ 11243.9500000000 , &
+ 11243.2100000000 , &
+ 11242.4600000000 , &
+ 11241.7000000000 , &
+ 11240.9100000000 , &
+ 11240.1200000000 , &
+ 11239.3100000000 , &
+ 11238.4800000000 , &
+ 11237.6400000000 , &
+ 11236.7900000000 /)
+
+ Mref_V%vph_ref( 61 : 90 ) = (/ &
+ 11235.9200000000 , &
+ 11235.0400000000 , &
+ 11234.1400000000 , &
+ 11233.2300000000 , &
+ 11232.3000000000 , &
+ 11231.3600000000 , &
+ 11230.4000000000 , &
+ 11229.4300000000 , &
+ 11228.4400000000 , &
+ 11227.4400000000 , &
+ 11226.4300000000 , &
+ 11225.4000000000 , &
+ 11224.3600000000 , &
+ 11223.3000000000 , &
+ 11222.2200000000 , &
+ 11221.1400000000 , &
+ 11220.0300000000 , &
+ 11218.9200000000 , &
+ 11217.7800000000 , &
+ 11216.6400000000 , &
+ 11215.4800000000 , &
+ 11214.3000000000 , &
+ 11213.1100000000 , &
+ 11211.9100000000 , &
+ 11210.6900000000 , &
+ 11209.4500000000 , &
+ 11208.2100000000 , &
+ 11206.9400000000 , &
+ 11205.6700000000 , &
+ 11204.3700000000 /)
+
+ Mref_V%vph_ref( 91 : 120 ) = (/ &
+ 11203.0700000000 , &
+ 11201.7400000000 , &
+ 11200.4100000000 , &
+ 11199.0600000000 , &
+ 11197.6900000000 , &
+ 11196.3100000000 , &
+ 11194.9200000000 , &
+ 11193.5100000000 , &
+ 11192.0900000000 , &
+ 11190.6500000000 , &
+ 11189.1900000000 , &
+ 11187.7300000000 , &
+ 11186.2400000000 , &
+ 11184.7500000000 , &
+ 11183.2400000000 , &
+ 11181.7100000000 , &
+ 11180.1700000000 , &
+ 11178.6100000000 , &
+ 11177.0400000000 , &
+ 11175.4600000000 , &
+ 11173.8600000000 , &
+ 11172.2500000000 , &
+ 11170.6200000000 , &
+ 11168.9800000000 , &
+ 11167.3200000000 , &
+ 11165.6500000000 , &
+ 11163.9600000000 , &
+ 11162.2600000000 , &
+ 11160.5400000000 , &
+ 11158.8100000000 /)
+
+ Mref_V%vph_ref( 121 : 150 ) = (/ &
+ 11157.0700000000 , &
+ 11155.3100000000 , &
+ 11153.5400000000 , &
+ 11151.7500000000 , &
+ 11149.9400000000 , &
+ 11148.1300000000 , &
+ 11146.2900000000 , &
+ 11144.4500000000 , &
+ 11142.5800000000 , &
+ 11140.7100000000 , &
+ 11138.8200000000 , &
+ 11136.9100000000 , &
+ 11134.9900000000 , &
+ 11133.0600000000 , &
+ 11131.1100000000 , &
+ 11129.1400000000 , &
+ 11127.1600000000 , &
+ 11125.1700000000 , &
+ 11123.1600000000 , &
+ 11121.1400000000 , &
+ 11119.1000000000 , &
+ 11117.0500000000 , &
+ 11114.9900000000 , &
+ 11112.9000000000 , &
+ 11110.8100000000 , &
+ 11108.7000000000 , &
+ 11106.5700000000 , &
+ 11104.4400000000 , &
+ 11102.2800000000 , &
+ 11100.1100000000 /)
+
+ Mref_V%vph_ref( 151 : 180 ) = (/ &
+ 11097.9300000000 , &
+ 11095.7300000000 , &
+ 11093.5200000000 , &
+ 11091.2900000000 , &
+ 11089.0500000000 , &
+ 11086.8000000000 , &
+ 11084.5300000000 , &
+ 11082.2400000000 , &
+ 11079.9400000000 , &
+ 11077.6300000000 , &
+ 11075.3000000000 , &
+ 11072.9500000000 , &
+ 11070.5900000000 , &
+ 11068.2200000000 , &
+ 11065.8300000000 , &
+ 11063.4300000000 , &
+ 11061.0200000000 , &
+ 11058.5800000000 , &
+ 11056.1400000000 , &
+ 11053.6800000000 , &
+ 11051.2000000000 , &
+ 11048.7100000000 , &
+ 11046.2100000000 , &
+ 11043.6900000000 , &
+ 11041.1600000000 , &
+ 11038.6100000000 , &
+ 11036.0500000000 , &
+ 11033.4700000000 , &
+ 11030.8800000000 , &
+ 11028.2700000000 /)
+
+ Mref_V%vph_ref( 181 : 210 ) = (/ &
+ 10355.6900000000 , &
+ 10348.2800000000 , &
+ 10340.8500000000 , &
+ 10333.3900000000 , &
+ 10325.9100000000 , &
+ 10318.4000000000 , &
+ 10310.8700000000 , &
+ 10303.3000000000 , &
+ 10295.7100000000 , &
+ 10288.0900000000 , &
+ 10280.4400000000 , &
+ 10272.7600000000 , &
+ 10265.0400000000 , &
+ 10257.3000000000 , &
+ 10249.5200000000 , &
+ 10241.7100000000 , &
+ 10233.8600000000 , &
+ 10225.9800000000 , &
+ 10218.0600000000 , &
+ 10210.1100000000 , &
+ 10202.1200000000 , &
+ 10194.1000000000 , &
+ 10186.0400000000 , &
+ 10177.9400000000 , &
+ 10169.7900000000 , &
+ 10161.6100000000 , &
+ 10153.3900000000 , &
+ 10145.1300000000 , &
+ 10136.8300000000 , &
+ 10128.4800000000 /)
+
+ Mref_V%vph_ref( 211 : 240 ) = (/ &
+ 10120.0900000000 , &
+ 10111.6600000000 , &
+ 10103.1800000000 , &
+ 10094.6600000000 , &
+ 10086.0900000000 , &
+ 10077.4800000000 , &
+ 10068.8200000000 , &
+ 10060.1100000000 , &
+ 10051.3500000000 , &
+ 10042.5400000000 , &
+ 10033.6900000000 , &
+ 10024.7800000000 , &
+ 10015.8200000000 , &
+ 10006.8200000000 , &
+ 9997.75000000000 , &
+ 9988.64000000000 , &
+ 9979.47000000000 , &
+ 9970.25000000000 , &
+ 9960.97000000000 , &
+ 9951.64000000000 , &
+ 9942.25000000000 , &
+ 9932.81000000000 , &
+ 9923.31000000000 , &
+ 9913.75000000000 , &
+ 9904.13000000000 , &
+ 9894.45000000000 , &
+ 9884.71000000000 , &
+ 9874.91000000000 , &
+ 9865.05000000000 , &
+ 9855.13000000000 /)
+
+ Mref_V%vph_ref( 241 : 270 ) = (/ &
+ 9845.14000000000 , &
+ 9835.09000000000 , &
+ 9824.98000000000 , &
+ 9814.80000000000 , &
+ 9804.56000000000 , &
+ 9794.25000000000 , &
+ 9783.87000000000 , &
+ 9773.43000000000 , &
+ 9762.92000000000 , &
+ 9752.34000000000 , &
+ 9741.69000000000 , &
+ 9730.97000000000 , &
+ 9720.18000000000 , &
+ 9709.32000000000 , &
+ 9698.39000000000 , &
+ 9687.38000000000 , &
+ 9676.31000000000 , &
+ 9665.15000000000 , &
+ 9653.93000000000 , &
+ 9642.63000000000 , &
+ 9631.25000000000 , &
+ 9619.80000000000 , &
+ 9608.27000000000 , &
+ 9596.66000000000 , &
+ 9584.97000000000 , &
+ 9573.20000000000 , &
+ 9561.36000000000 , &
+ 9549.43000000000 , &
+ 9537.43000000000 , &
+ 9525.34000000000 /)
+
+ Mref_V%vph_ref( 271 : 300 ) = (/ &
+ 9513.17000000000 , &
+ 9500.91000000000 , &
+ 9488.57000000000 , &
+ 9476.15000000000 , &
+ 9463.64000000000 , &
+ 9451.05000000000 , &
+ 9438.37000000000 , &
+ 9425.61000000000 , &
+ 9412.75000000000 , &
+ 9399.81000000000 , &
+ 9386.78000000000 , &
+ 9373.66000000000 , &
+ 9360.45000000000 , &
+ 9347.15000000000 , &
+ 9333.76000000000 , &
+ 9320.27000000000 , &
+ 9306.70000000000 , &
+ 9293.03000000000 , &
+ 9279.26000000000 , &
+ 9265.40000000000 , &
+ 9251.45000000000 , &
+ 9237.40000000000 , &
+ 9223.25000000000 , &
+ 9209.00000000000 , &
+ 9194.66000000000 , &
+ 9180.22000000000 , &
+ 9165.68000000000 , &
+ 9151.03000000000 , &
+ 9136.29000000000 , &
+ 9121.45000000000 /)
+
+ Mref_V%vph_ref( 301 : 330 ) = (/ &
+ 9106.50000000000 , &
+ 9091.46000000000 , &
+ 9076.30000000000 , &
+ 9061.05000000000 , &
+ 9045.69000000000 , &
+ 9030.23000000000 , &
+ 9014.65000000000 , &
+ 8998.98000000000 , &
+ 8983.19000000000 , &
+ 8967.30000000000 , &
+ 8951.30000000000 , &
+ 8935.19000000000 , &
+ 8918.97000000000 , &
+ 8902.64000000000 , &
+ 8886.20000000000 , &
+ 8869.64000000000 , &
+ 8852.98000000000 , &
+ 8836.20000000000 , &
+ 8819.31000000000 , &
+ 8802.30000000000 , &
+ 8785.18000000000 , &
+ 8767.94000000000 , &
+ 8750.59000000000 , &
+ 8733.12000000000 , &
+ 8715.53000000000 , &
+ 8697.82000000000 , &
+ 8680.00000000000 , &
+ 8662.05000000000 , &
+ 8643.99000000000 , &
+ 8625.80000000000 /)
+
+ Mref_V%vph_ref( 331 : 360 ) = (/ &
+ 8607.49000000000 , &
+ 8589.06000000000 , &
+ 8570.51000000000 , &
+ 8551.83000000000 , &
+ 8533.03000000000 , &
+ 8514.10000000000 , &
+ 8495.05000000000 , &
+ 8475.87000000000 , &
+ 8456.57000000000 , &
+ 8437.14000000000 , &
+ 8417.58000000000 , &
+ 8397.89000000000 , &
+ 8378.07000000000 , &
+ 8358.12000000000 , &
+ 8338.04000000000 , &
+ 8317.83000000000 , &
+ 8297.49000000000 , &
+ 8277.01000000000 , &
+ 8256.41000000000 , &
+ 8235.66000000000 , &
+ 8214.79000000000 , &
+ 8193.77000000000 , &
+ 8172.62000000000 , &
+ 8151.34000000000 , &
+ 8129.92000000000 , &
+ 8108.36000000000 , &
+ 8086.66000000000 , &
+ 8064.82000000000 , &
+ 13716.6000000000 , &
+ 13714.2900000000 /)
+
+ Mref_V%vph_ref( 361 : 390 ) = (/ &
+ 13712.0000000000 , &
+ 13709.7000000000 , &
+ 13707.4200000000 , &
+ 13705.1400000000 , &
+ 13702.8600000000 , &
+ 13700.5900000000 , &
+ 13698.3300000000 , &
+ 13696.0700000000 , &
+ 13693.8200000000 , &
+ 13691.5700000000 , &
+ 13689.3300000000 , &
+ 13687.0900000000 , &
+ 13684.8600000000 , &
+ 13682.6300000000 , &
+ 13680.4100000000 , &
+ 13680.4100000000 , &
+ 13668.9000000000 , &
+ 13657.4300000000 , &
+ 13645.9700000000 , &
+ 13634.5400000000 , &
+ 13623.1400000000 , &
+ 13611.7600000000 , &
+ 13600.4000000000 , &
+ 13589.0700000000 , &
+ 13577.7600000000 , &
+ 13566.4700000000 , &
+ 13555.2000000000 , &
+ 13543.9500000000 , &
+ 13532.7200000000 , &
+ 13521.5100000000 /)
+
+ Mref_V%vph_ref( 391 : 420 ) = (/ &
+ 13510.3200000000 , &
+ 13499.1400000000 , &
+ 13487.9900000000 , &
+ 13476.8500000000 , &
+ 13465.7300000000 , &
+ 13454.6300000000 , &
+ 13443.5400000000 , &
+ 13432.4600000000 , &
+ 13421.4100000000 , &
+ 13410.3600000000 , &
+ 13399.3300000000 , &
+ 13388.3100000000 , &
+ 13377.3100000000 , &
+ 13366.3100000000 , &
+ 13355.3300000000 , &
+ 13344.3600000000 , &
+ 13333.4000000000 , &
+ 13322.4500000000 , &
+ 13311.5100000000 , &
+ 13300.5800000000 , &
+ 13289.6600000000 , &
+ 13278.7400000000 , &
+ 13267.8400000000 , &
+ 13256.9300000000 , &
+ 13246.0400000000 , &
+ 13235.1500000000 , &
+ 13224.2700000000 , &
+ 13213.3900000000 , &
+ 13202.5100000000 , &
+ 13191.6400000000 /)
+
+ Mref_V%vph_ref( 421 : 450 ) = (/ &
+ 13180.7800000000 , &
+ 13169.9100000000 , &
+ 13159.0500000000 , &
+ 13148.1900000000 , &
+ 13137.3300000000 , &
+ 13126.4700000000 , &
+ 13115.6100000000 , &
+ 13104.7500000000 , &
+ 13093.8900000000 , &
+ 13083.0200000000 , &
+ 13072.1600000000 , &
+ 13061.2900000000 , &
+ 13050.4200000000 , &
+ 13039.5500000000 , &
+ 13028.6700000000 , &
+ 13017.7800000000 , &
+ 13006.9000000000 , &
+ 12996.0000000000 , &
+ 12985.1000000000 , &
+ 12974.1900000000 , &
+ 12963.2800000000 , &
+ 12952.3600000000 , &
+ 12941.4200000000 , &
+ 12930.4800000000 , &
+ 12919.5400000000 , &
+ 12908.5800000000 , &
+ 12897.6100000000 , &
+ 12886.6300000000 , &
+ 12875.6300000000 , &
+ 12864.6300000000 /)
+
+ Mref_V%vph_ref( 451 : 480 ) = (/ &
+ 12853.6100000000 , &
+ 12842.5800000000 , &
+ 12831.5400000000 , &
+ 12820.4800000000 , &
+ 12809.4100000000 , &
+ 12798.3200000000 , &
+ 12787.2200000000 , &
+ 12776.1000000000 , &
+ 12764.9600000000 , &
+ 12753.8100000000 , &
+ 12742.6300000000 , &
+ 12731.4400000000 , &
+ 12720.2400000000 , &
+ 12709.0100000000 , &
+ 12697.7600000000 , &
+ 12686.4900000000 , &
+ 12675.2000000000 , &
+ 12663.8900000000 , &
+ 12652.5600000000 , &
+ 12641.2000000000 , &
+ 12629.8200000000 , &
+ 12618.4200000000 , &
+ 12606.9900000000 , &
+ 12595.5400000000 , &
+ 12584.0600000000 , &
+ 12572.5600000000 , &
+ 12561.0300000000 , &
+ 12549.4800000000 , &
+ 12537.8900000000 , &
+ 12526.2800000000 /)
+
+ Mref_V%vph_ref( 481 : 510 ) = (/ &
+ 12514.6400000000 , &
+ 12502.9800000000 , &
+ 12491.2800000000 , &
+ 12479.5500000000 , &
+ 12467.7900000000 , &
+ 12456.0100000000 , &
+ 12444.1900000000 , &
+ 12432.3300000000 , &
+ 12420.4500000000 , &
+ 12408.5300000000 , &
+ 12396.5800000000 , &
+ 12384.6000000000 , &
+ 12372.5800000000 , &
+ 12360.5200000000 , &
+ 12348.4300000000 , &
+ 12336.3000000000 , &
+ 12324.1400000000 , &
+ 12311.9400000000 , &
+ 12299.7000000000 , &
+ 12287.4200000000 , &
+ 12275.1100000000 , &
+ 12262.7500000000 , &
+ 12250.3500000000 , &
+ 12237.9200000000 , &
+ 12225.4400000000 , &
+ 12212.9200000000 , &
+ 12200.3600000000 , &
+ 12187.7600000000 , &
+ 12175.1100000000 , &
+ 12162.4300000000 /)
+
+ Mref_V%vph_ref( 511 : 540 ) = (/ &
+ 12149.6900000000 , &
+ 12136.9100000000 , &
+ 12124.0900000000 , &
+ 12111.2200000000 , &
+ 12098.3100000000 , &
+ 12085.3400000000 , &
+ 12072.3400000000 , &
+ 12059.2800000000 , &
+ 12046.1700000000 , &
+ 12033.0200000000 , &
+ 12019.8200000000 , &
+ 12006.5600000000 , &
+ 11993.2600000000 , &
+ 11979.9000000000 , &
+ 11966.5000000000 , &
+ 11953.0400000000 , &
+ 11939.5300000000 , &
+ 11925.9700000000 , &
+ 11912.3500000000 , &
+ 11898.6900000000 , &
+ 11884.9600000000 , &
+ 11871.1900000000 , &
+ 11857.3700000000 , &
+ 11843.4800000000 , &
+ 11829.5500000000 , &
+ 11815.5700000000 , &
+ 11801.5300000000 , &
+ 11787.4400000000 , &
+ 11773.3000000000 , &
+ 11759.1000000000 /)
+
+ Mref_V%vph_ref( 541 : 570 ) = (/ &
+ 11744.8500000000 , &
+ 11730.5500000000 , &
+ 11716.1800000000 , &
+ 11701.7800000000 , &
+ 11687.3100000000 , &
+ 11672.8000000000 , &
+ 11658.2300000000 , &
+ 11643.6000000000 , &
+ 11628.9200000000 , &
+ 11614.1900000000 , &
+ 11599.4000000000 , &
+ 11584.5700000000 , &
+ 11569.6800000000 , &
+ 11554.7200000000 , &
+ 11539.7200000000 , &
+ 11524.6700000000 , &
+ 11509.5600000000 , &
+ 11494.3900000000 , &
+ 11479.1700000000 , &
+ 11463.8900000000 , &
+ 11448.5500000000 , &
+ 11433.1700000000 , &
+ 11417.7300000000 , &
+ 11402.2300000000 , &
+ 11386.6800000000 , &
+ 11371.0700000000 , &
+ 11355.4100000000 , &
+ 11339.6900000000 , &
+ 11323.9100000000 , &
+ 11308.0900000000 /)
+
+ Mref_V%vph_ref( 571 : 600 ) = (/ &
+ 11292.2000000000 , &
+ 11276.2500000000 , &
+ 11260.2500000000 , &
+ 11244.1900000000 , &
+ 11228.0800000000 , &
+ 11211.9000000000 , &
+ 11195.6700000000 , &
+ 11179.3800000000 , &
+ 11163.0400000000 , &
+ 11146.6300000000 , &
+ 11130.1800000000 , &
+ 11113.6700000000 , &
+ 11097.1100000000 , &
+ 11080.5100000000 , &
+ 11080.5100000000 , &
+ 11063.0100000000 , &
+ 11045.2200000000 , &
+ 11026.8200000000 , &
+ 11008.4700000000 , &
+ 10989.0400000000 , &
+ 10969.6300000000 , &
+ 10948.7600000000 , &
+ 10928.0200000000 , &
+ 10907.4200000000 , &
+ 10886.9400000000 , &
+ 10866.6000000000 , &
+ 10846.4100000000 , &
+ 10826.3500000000 , &
+ 10806.4200000000 , &
+ 10786.6100000000 /)
+
+ Mref_V%vph_ref( 601 : 630 ) = (/ &
+ 10766.9000000000 , &
+ 10278.8800000000 , &
+ 10261.8700000000 , &
+ 10244.8400000000 , &
+ 10227.8200000000 , &
+ 10210.8000000000 , &
+ 10193.7800000000 , &
+ 10176.7700000000 , &
+ 10159.7400000000 , &
+ 10142.7200000000 , &
+ 10125.7100000000 , &
+ 10108.7000000000 , &
+ 10091.6800000000 , &
+ 10074.6800000000 , &
+ 10057.6800000000 , &
+ 10040.6400000000 , &
+ 10040.6700000000 , &
+ 10010.5200000000 , &
+ 9980.51000000000 , &
+ 9950.64000000000 , &
+ 9920.91000000000 , &
+ 9891.35000000000 , &
+ 9861.96000000000 , &
+ 9832.79000000000 , &
+ 9803.79000000000 , &
+ 9774.98000000000 , &
+ 9746.41000000000 , &
+ 9718.08000000000 , &
+ 9689.96000000000 , &
+ 9662.10000000000 /)
+
+ Mref_V%vph_ref( 631 : 660 ) = (/ &
+ 9634.47000000000 , &
+ 9607.11000000000 , &
+ 9579.97000000000 , &
+ 9553.08000000000 , &
+ 9526.38000000000 , &
+ 9499.78000000000 , &
+ 9473.25000000000 , &
+ 9446.74000000000 , &
+ 9420.19000000000 , &
+ 9393.55000000000 , &
+ 9366.75000000000 , &
+ 9339.76000000000 , &
+ 9312.50000000000 , &
+ 9284.96000000000 , &
+ 9257.04000000000 , &
+ 9228.73000000000 , &
+ 9199.94000000000 , &
+ 8940.94000000000 , &
+ 8930.61000000000 , &
+ 8920.22000000000 , &
+ 8909.68000000000 , &
+ 8898.47000000000 , &
+ 8886.28000000000 , &
+ 8873.03000000000 , &
+ 8858.58000000000 , &
+ 8842.82000000000 , &
+ 8825.64000000000 , &
+ 8806.94000000000 , &
+ 8786.67000000000 , &
+ 8764.85000000000 /)
+
+ Mref_V%vph_ref( 661 : 690 ) = (/ &
+ 8741.49000000000 , &
+ 8716.63000000000 , &
+ 8690.30000000000 , &
+ 8662.50000000000 , &
+ 8633.28000000000 , &
+ 8602.66000000000 , &
+ 8570.81000000000 , &
+ 8538.06000000000 , &
+ 8504.66000000000 , &
+ 8470.92000000000 , &
+ 8437.13000000000 , &
+ 8403.52000000000 , &
+ 8370.42000000000 , &
+ 8338.11000000000 , &
+ 8307.42000000000 , &
+ 8278.36000000000 , &
+ 8255.33000000000 , &
+ 8236.90000000000 , &
+ 8236.81000000000 , &
+ 8222.27000000000 , &
+ 8210.47000000000 , &
+ 8201.14000000000 , &
+ 8193.99000000000 , &
+ 8188.67000000000 , &
+ 8184.92000000000 , &
+ 8182.39000000000 , &
+ 8180.79000000000 , &
+ 8179.83000000000 , &
+ 8179.17000000000 , &
+ 8178.54000000000 /)
+
+ Mref_V%vph_ref( 691 : 720 ) = (/ &
+ 8177.64000000000 , &
+ 8176.30000000000 , &
+ 8174.55000000000 , &
+ 8172.42000000000 , &
+ 8169.91000000000 , &
+ 8167.05000000000 , &
+ 8163.88000000000 , &
+ 8160.37000000000 , &
+ 8156.58000000000 , &
+ 8152.57000000000 , &
+ 8148.41000000000 , &
+ 8144.20000000000 , &
+ 8144.32000000000 , &
+ 8141.60000000000 , &
+ 8139.01000000000 , &
+ 8136.50000000000 , &
+ 8134.11000000000 , &
+ 8131.82000000000 , &
+ 8129.66000000000 , &
+ 8127.60000000000 , &
+ 8125.65000000000 , &
+ 8123.87000000000 , &
+ 8122.23000000000 , &
+ 8120.74000000000 , &
+ 8119.38000000000 , &
+ 8118.22000000000 , &
+ 8117.13000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 /)
+
+ Mref_V%vph_ref( 721 : 750 ) = (/ &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 6800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 , &
+ 5800.00000000000 /)
+
+ Mref_V%vsh_ref( 1 : 30 ) = (/ &
+ 3667.80000000000 , &
+ 3667.79000000000 , &
+ 3667.78000000000 , &
+ 3667.75000000000 , &
+ 3667.72000000000 , &
+ 3667.67000000000 , &
+ 3667.62000000000 , &
+ 3667.55000000000 , &
+ 3667.47000000000 , &
+ 3667.39000000000 , &
+ 3667.29000000000 , &
+ 3667.18000000000 , &
+ 3667.06000000000 , &
+ 3666.94000000000 , &
+ 3666.80000000000 , &
+ 3666.65000000000 , &
+ 3666.49000000000 , &
+ 3666.32000000000 , &
+ 3666.15000000000 , &
+ 3665.96000000000 , &
+ 3665.76000000000 , &
+ 3665.55000000000 , &
+ 3665.33000000000 , &
+ 3665.10000000000 , &
+ 3664.86000000000 , &
+ 3664.61000000000 , &
+ 3664.35000000000 , &
+ 3664.08000000000 , &
+ 3663.80000000000 , &
+ 3663.51000000000 /)
+
+ Mref_V%vsh_ref( 31 : 60 ) = (/ &
+ 3663.21000000000 , &
+ 3662.90000000000 , &
+ 3662.57000000000 , &
+ 3662.24000000000 , &
+ 3661.90000000000 , &
+ 3661.55000000000 , &
+ 3661.19000000000 , &
+ 3660.81000000000 , &
+ 3660.43000000000 , &
+ 3660.04000000000 , &
+ 3659.64000000000 , &
+ 3659.22000000000 , &
+ 3658.80000000000 , &
+ 3658.36000000000 , &
+ 3657.92000000000 , &
+ 3657.47000000000 , &
+ 3657.00000000000 , &
+ 3656.53000000000 , &
+ 3656.04000000000 , &
+ 3655.55000000000 , &
+ 3655.04000000000 , &
+ 3654.53000000000 , &
+ 3654.00000000000 , &
+ 3653.47000000000 , &
+ 3652.92000000000 , &
+ 3652.36000000000 , &
+ 3651.80000000000 , &
+ 3651.22000000000 , &
+ 3650.63000000000 , &
+ 3650.04000000000 /)
+
+ Mref_V%vsh_ref( 61 : 90 ) = (/ &
+ 3649.43000000000 , &
+ 3648.81000000000 , &
+ 3648.19000000000 , &
+ 3647.55000000000 , &
+ 3646.90000000000 , &
+ 3646.24000000000 , &
+ 3645.57000000000 , &
+ 3644.89000000000 , &
+ 3644.21000000000 , &
+ 3643.51000000000 , &
+ 3642.80000000000 , &
+ 3642.08000000000 , &
+ 3641.35000000000 , &
+ 3640.61000000000 , &
+ 3639.86000000000 , &
+ 3639.10000000000 , &
+ 3638.33000000000 , &
+ 3637.55000000000 , &
+ 3636.76000000000 , &
+ 3635.96000000000 , &
+ 3635.14000000000 , &
+ 3634.32000000000 , &
+ 3633.49000000000 , &
+ 3632.65000000000 , &
+ 3631.80000000000 , &
+ 3630.93000000000 , &
+ 3630.06000000000 , &
+ 3629.18000000000 , &
+ 3628.29000000000 , &
+ 3627.38000000000 /)
+
+ Mref_V%vsh_ref( 91 : 120 ) = (/ &
+ 3626.47000000000 , &
+ 3625.55000000000 , &
+ 3624.61000000000 , &
+ 3623.67000000000 , &
+ 3622.71000000000 , &
+ 3621.75000000000 , &
+ 3620.78000000000 , &
+ 3619.79000000000 , &
+ 3618.80000000000 , &
+ 3617.79000000000 , &
+ 3616.78000000000 , &
+ 3615.75000000000 , &
+ 3614.71000000000 , &
+ 3613.67000000000 , &
+ 3612.61000000000 , &
+ 3611.55000000000 , &
+ 3610.47000000000 , &
+ 3609.38000000000 , &
+ 3608.28000000000 , &
+ 3607.18000000000 , &
+ 3606.06000000000 , &
+ 3604.93000000000 , &
+ 3603.79000000000 , &
+ 3602.65000000000 , &
+ 3601.49000000000 , &
+ 3600.32000000000 , &
+ 3599.14000000000 , &
+ 3597.95000000000 , &
+ 3596.75000000000 , &
+ 3595.54000000000 /)
+
+ Mref_V%vsh_ref( 121 : 150 ) = (/ &
+ 3594.32000000000 , &
+ 3593.10000000000 , &
+ 3591.86000000000 , &
+ 3590.61000000000 , &
+ 3589.34000000000 , &
+ 3588.07000000000 , &
+ 3586.79000000000 , &
+ 3585.50000000000 , &
+ 3584.20000000000 , &
+ 3582.89000000000 , &
+ 3581.57000000000 , &
+ 3580.24000000000 , &
+ 3578.90000000000 , &
+ 3577.54000000000 , &
+ 3576.18000000000 , &
+ 3574.81000000000 , &
+ 3573.43000000000 , &
+ 3572.03000000000 , &
+ 3570.63000000000 , &
+ 3569.22000000000 , &
+ 3567.79000000000 , &
+ 3566.36000000000 , &
+ 3564.91000000000 , &
+ 3563.46000000000 , &
+ 3562.00000000000 , &
+ 3560.52000000000 , &
+ 3559.04000000000 , &
+ 3557.54000000000 , &
+ 3556.04000000000 , &
+ 3554.52000000000 /)
+
+ Mref_V%vsh_ref( 151 : 180 ) = (/ &
+ 3553.00000000000 , &
+ 3551.46000000000 , &
+ 3549.91000000000 , &
+ 3548.36000000000 , &
+ 3546.79000000000 , &
+ 3545.21000000000 , &
+ 3543.63000000000 , &
+ 3542.03000000000 , &
+ 3540.42000000000 , &
+ 3538.81000000000 , &
+ 3537.18000000000 , &
+ 3535.54000000000 , &
+ 3533.89000000000 , &
+ 3532.23000000000 , &
+ 3530.57000000000 , &
+ 3528.89000000000 , &
+ 3527.20000000000 , &
+ 3525.50000000000 , &
+ 3523.79000000000 , &
+ 3522.07000000000 , &
+ 3520.34000000000 , &
+ 3518.60000000000 , &
+ 3516.85000000000 , &
+ 3515.09000000000 , &
+ 3513.32000000000 , &
+ 3511.54000000000 , &
+ 3509.75000000000 , &
+ 3507.95000000000 , &
+ 3506.13000000000 , &
+ 3504.31000000000 /)
+
+ Mref_V%vsh_ref( 181 : 210 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsh_ref( 211 : 240 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsh_ref( 241 : 270 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsh_ref( 271 : 300 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsh_ref( 301 : 330 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 /)
+
+ Mref_V%vsh_ref( 331 : 360 ) = (/ &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 0.000000000000000E+000 , &
+ 7264.66000000000 , &
+ 7264.75000000000 /)
+
+ Mref_V%vsh_ref( 361 : 390 ) = (/ &
+ 7264.85000000000 , &
+ 7264.94000000000 , &
+ 7265.03000000000 , &
+ 7265.12000000000 , &
+ 7265.21000000000 , &
+ 7265.29000000000 , &
+ 7265.38000000000 , &
+ 7265.46000000000 , &
+ 7265.54000000000 , &
+ 7265.62000000000 , &
+ 7265.69000000000 , &
+ 7265.76000000000 , &
+ 7265.84000000000 , &
+ 7265.91000000000 , &
+ 7265.97000000000 , &
+ 7265.97000000000 , &
+ 7261.63000000000 , &
+ 7257.29000000000 , &
+ 7252.97000000000 , &
+ 7248.64000000000 , &
+ 7244.33000000000 , &
+ 7240.01000000000 , &
+ 7235.71000000000 , &
+ 7231.41000000000 , &
+ 7227.12000000000 , &
+ 7222.83000000000 , &
+ 7218.55000000000 , &
+ 7214.27000000000 , &
+ 7210.00000000000 , &
+ 7205.73000000000 /)
+
+ Mref_V%vsh_ref( 391 : 420 ) = (/ &
+ 7201.47000000000 , &
+ 7197.21000000000 , &
+ 7192.95000000000 , &
+ 7188.70000000000 , &
+ 7184.45000000000 , &
+ 7180.21000000000 , &
+ 7175.97000000000 , &
+ 7171.73000000000 , &
+ 7167.50000000000 , &
+ 7163.27000000000 , &
+ 7159.04000000000 , &
+ 7154.81000000000 , &
+ 7150.59000000000 , &
+ 7146.37000000000 , &
+ 7142.15000000000 , &
+ 7137.93000000000 , &
+ 7133.71000000000 , &
+ 7129.50000000000 , &
+ 7125.29000000000 , &
+ 7121.07000000000 , &
+ 7116.86000000000 , &
+ 7112.65000000000 , &
+ 7108.44000000000 , &
+ 7104.23000000000 , &
+ 7100.02000000000 , &
+ 7095.81000000000 , &
+ 7091.60000000000 , &
+ 7087.39000000000 , &
+ 7083.18000000000 , &
+ 7078.96000000000 /)
+
+ Mref_V%vsh_ref( 421 : 450 ) = (/ &
+ 7074.75000000000 , &
+ 7070.54000000000 , &
+ 7066.32000000000 , &
+ 7062.10000000000 , &
+ 7057.88000000000 , &
+ 7053.66000000000 , &
+ 7049.44000000000 , &
+ 7045.22000000000 , &
+ 7040.99000000000 , &
+ 7036.76000000000 , &
+ 7032.52000000000 , &
+ 7028.29000000000 , &
+ 7024.05000000000 , &
+ 7019.81000000000 , &
+ 7015.56000000000 , &
+ 7011.31000000000 , &
+ 7007.06000000000 , &
+ 7002.80000000000 , &
+ 6998.54000000000 , &
+ 6994.27000000000 , &
+ 6990.00000000000 , &
+ 6985.72000000000 , &
+ 6981.44000000000 , &
+ 6977.15000000000 , &
+ 6972.86000000000 , &
+ 6968.57000000000 , &
+ 6964.26000000000 , &
+ 6959.95000000000 , &
+ 6955.64000000000 , &
+ 6951.32000000000 /)
+
+ Mref_V%vsh_ref( 451 : 480 ) = (/ &
+ 6946.99000000000 , &
+ 6942.66000000000 , &
+ 6938.31000000000 , &
+ 6933.97000000000 , &
+ 6929.61000000000 , &
+ 6925.25000000000 , &
+ 6920.88000000000 , &
+ 6916.50000000000 , &
+ 6912.11000000000 , &
+ 6907.72000000000 , &
+ 6903.32000000000 , &
+ 6898.91000000000 , &
+ 6894.49000000000 , &
+ 6890.06000000000 , &
+ 6885.62000000000 , &
+ 6881.17000000000 , &
+ 6876.72000000000 , &
+ 6872.25000000000 , &
+ 6867.78000000000 , &
+ 6863.29000000000 , &
+ 6858.80000000000 , &
+ 6854.29000000000 , &
+ 6849.78000000000 , &
+ 6845.25000000000 , &
+ 6840.71000000000 , &
+ 6836.16000000000 , &
+ 6831.60000000000 , &
+ 6827.03000000000 , &
+ 6822.45000000000 , &
+ 6817.85000000000 /)
+
+ Mref_V%vsh_ref( 481 : 510 ) = (/ &
+ 6813.25000000000 , &
+ 6808.63000000000 , &
+ 6804.00000000000 , &
+ 6799.35000000000 , &
+ 6794.70000000000 , &
+ 6790.03000000000 , &
+ 6785.34000000000 , &
+ 6780.65000000000 , &
+ 6775.94000000000 , &
+ 6771.22000000000 , &
+ 6766.48000000000 , &
+ 6761.73000000000 , &
+ 6756.97000000000 , &
+ 6752.19000000000 , &
+ 6747.40000000000 , &
+ 6742.59000000000 , &
+ 6737.76000000000 , &
+ 6732.93000000000 , &
+ 6728.07000000000 , &
+ 6723.21000000000 , &
+ 6718.32000000000 , &
+ 6713.42000000000 , &
+ 6708.51000000000 , &
+ 6703.57000000000 , &
+ 6698.62000000000 , &
+ 6693.66000000000 , &
+ 6688.68000000000 , &
+ 6683.68000000000 , &
+ 6678.66000000000 , &
+ 6673.63000000000 /)
+
+ Mref_V%vsh_ref( 511 : 540 ) = (/ &
+ 6668.58000000000 , &
+ 6663.51000000000 , &
+ 6658.43000000000 , &
+ 6653.32000000000 , &
+ 6648.20000000000 , &
+ 6643.06000000000 , &
+ 6637.90000000000 , &
+ 6632.73000000000 , &
+ 6627.53000000000 , &
+ 6622.31000000000 , &
+ 6617.08000000000 , &
+ 6611.82000000000 , &
+ 6606.55000000000 , &
+ 6601.26000000000 , &
+ 6595.94000000000 , &
+ 6590.61000000000 , &
+ 6584.91000000000 , &
+ 6579.51000000000 , &
+ 6574.11000000000 , &
+ 6568.67000000000 , &
+ 6563.22000000000 , &
+ 6557.74000000000 , &
+ 6552.24000000000 , &
+ 6546.73000000000 , &
+ 6541.19000000000 , &
+ 6535.63000000000 , &
+ 6530.05000000000 , &
+ 6524.44000000000 , &
+ 6518.82000000000 , &
+ 6513.17000000000 /)
+
+ Mref_V%vsh_ref( 541 : 570 ) = (/ &
+ 6507.50000000000 , &
+ 6501.80000000000 , &
+ 6496.09000000000 , &
+ 6490.35000000000 , &
+ 6484.59000000000 , &
+ 6478.80000000000 , &
+ 6472.99000000000 , &
+ 6467.16000000000 , &
+ 6461.30000000000 , &
+ 6455.42000000000 , &
+ 6449.51000000000 , &
+ 6443.58000000000 , &
+ 6437.63000000000 , &
+ 6431.65000000000 , &
+ 6425.65000000000 , &
+ 6419.61000000000 , &
+ 6413.56000000000 , &
+ 6407.48000000000 , &
+ 6401.37000000000 , &
+ 6395.25000000000 , &
+ 6389.09000000000 , &
+ 6382.91000000000 , &
+ 6376.70000000000 , &
+ 6370.46000000000 , &
+ 6364.20000000000 , &
+ 6357.91000000000 , &
+ 6351.59000000000 , &
+ 6345.25000000000 , &
+ 6338.88000000000 , &
+ 6332.49000000000 /)
+
+ Mref_V%vsh_ref( 571 : 600 ) = (/ &
+ 6326.05000000000 , &
+ 6319.60000000000 , &
+ 6313.13000000000 , &
+ 6306.62000000000 , &
+ 6300.08000000000 , &
+ 6293.52000000000 , &
+ 6286.92000000000 , &
+ 6280.29000000000 , &
+ 6273.64000000000 , &
+ 6266.96000000000 , &
+ 6260.25000000000 , &
+ 6253.51000000000 , &
+ 6246.75000000000 , &
+ 6239.95000000000 , &
+ 6239.95000000000 , &
+ 6219.68000000000 , &
+ 6200.29000000000 , &
+ 6181.16000000000 , &
+ 6162.04000000000 , &
+ 6143.01000000000 , &
+ 6123.98000000000 , &
+ 6103.71000000000 , &
+ 6083.53000000000 , &
+ 6063.45000000000 , &
+ 6043.44000000000 , &
+ 6023.52000000000 , &
+ 6003.73000000000 , &
+ 5984.03000000000 , &
+ 5964.38000000000 , &
+ 5944.81000000000 /)
+
+ Mref_V%vsh_ref( 601 : 630 ) = (/ &
+ 5925.27000000000 , &
+ 5550.32000000000 , &
+ 5541.20000000000 , &
+ 5532.08000000000 , &
+ 5522.96000000000 , &
+ 5513.83000000000 , &
+ 5504.71000000000 , &
+ 5495.59000000000 , &
+ 5486.47000000000 , &
+ 5477.35000000000 , &
+ 5468.22000000000 , &
+ 5459.10000000000 , &
+ 5449.97000000000 , &
+ 5440.84000000000 , &
+ 5431.71000000000 , &
+ 5422.57000000000 , &
+ 5422.59000000000 , &
+ 5406.39000000000 , &
+ 5390.30000000000 , &
+ 5374.34000000000 , &
+ 5358.52000000000 , &
+ 5342.83000000000 , &
+ 5327.31000000000 , &
+ 5311.92000000000 , &
+ 5296.73000000000 , &
+ 5281.71000000000 , &
+ 5266.86000000000 , &
+ 5252.21000000000 , &
+ 5237.78000000000 , &
+ 5223.55000000000 /)
+
+ Mref_V%vsh_ref( 631 : 660 ) = (/ &
+ 5209.54000000000 , &
+ 5195.72000000000 , &
+ 5182.10000000000 , &
+ 5168.69000000000 , &
+ 5155.42000000000 , &
+ 5142.22000000000 , &
+ 5129.05000000000 , &
+ 5115.84000000000 , &
+ 5102.55000000000 , &
+ 5089.14000000000 , &
+ 5075.50000000000 , &
+ 5061.63000000000 , &
+ 5047.46000000000 , &
+ 5032.93000000000 , &
+ 5018.03000000000 , &
+ 5002.66000000000 , &
+ 4986.77000000000 , &
+ 4803.78000000000 , &
+ 4800.54000000000 , &
+ 4797.28000000000 , &
+ 4793.96000000000 , &
+ 4790.18000000000 , &
+ 4785.78000000000 , &
+ 4780.71000000000 , &
+ 4775.00000000000 , &
+ 4768.58000000000 , &
+ 4761.41000000000 , &
+ 4753.51000000000 , &
+ 4744.86000000000 , &
+ 4735.64000000000 /)
+
+ Mref_V%vsh_ref( 661 : 690 ) = (/ &
+ 4725.88000000000 , &
+ 4715.76000000000 , &
+ 4705.34000000000 , &
+ 4694.74000000000 , &
+ 4684.08000000000 , &
+ 4673.46000000000 , &
+ 4662.94000000000 , &
+ 4652.61000000000 , &
+ 4642.55000000000 , &
+ 4632.81000000000 , &
+ 4623.51000000000 , &
+ 4614.68000000000 , &
+ 4606.39000000000 , &
+ 4598.73000000000 , &
+ 4591.76000000000 , &
+ 4585.56000000000 , &
+ 4580.21000000000 , &
+ 4575.75000000000 , &
+ 4575.74000000000 , &
+ 4572.27000000000 , &
+ 4569.53000000000 , &
+ 4567.46000000000 , &
+ 4566.02000000000 , &
+ 4565.10000000000 , &
+ 4564.66000000000 , &
+ 4564.65000000000 , &
+ 4564.99000000000 , &
+ 4565.62000000000 , &
+ 4566.47000000000 , &
+ 4567.46000000000 /)
+
+ Mref_V%vsh_ref( 691 : 720 ) = (/ &
+ 4568.58000000000 , &
+ 4569.70000000000 , &
+ 4570.85000000000 , &
+ 4571.91000000000 , &
+ 4572.83000000000 , &
+ 4573.60000000000 , &
+ 4574.16000000000 , &
+ 4574.44000000000 , &
+ 4574.42000000000 , &
+ 4574.04000000000 , &
+ 4573.36000000000 , &
+ 4572.41000000000 , &
+ 4572.46000000000 , &
+ 4571.71000000000 , &
+ 4570.93000000000 , &
+ 4570.06000000000 , &
+ 4569.16000000000 , &
+ 4568.21000000000 , &
+ 4567.22000000000 , &
+ 4566.21000000000 , &
+ 4565.16000000000 , &
+ 4564.11000000000 , &
+ 4563.05000000000 , &
+ 4562.00000000000 , &
+ 4560.94000000000 , &
+ 4559.94000000000 , &
+ 4558.94000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 /)
+
+ Mref_V%vsh_ref( 721 : 750 ) = (/ &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3900.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 , &
+ 3200.00000000000 /)
+
+ Mref_V%eta_ref( 1 : 30 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 31 : 60 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 61 : 90 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 91 : 120 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 121 : 150 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 151 : 180 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 181 : 210 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 211 : 240 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 241 : 270 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 271 : 300 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 301 : 330 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 331 : 360 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 361 : 390 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 391 : 420 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 421 : 450 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 451 : 480 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 481 : 510 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 511 : 540 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 541 : 570 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 571 : 600 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 601 : 630 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 631 : 660 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 0.999990000000000 , &
+ 0.999970000000000 , &
+ 0.999950000000000 , &
+ 0.999940000000000 , &
+ 0.999900000000000 , &
+ 0.999860000000000 , &
+ 0.999800000000000 , &
+ 0.999740000000000 , &
+ 0.999660000000000 /)
+
+ Mref_V%eta_ref( 661 : 690 ) = (/ &
+ 0.999570000000000 , &
+ 0.999470000000000 , &
+ 0.999340000000000 , &
+ 0.999200000000000 , &
+ 0.999040000000000 , &
+ 0.998860000000000 , &
+ 0.998640000000000 , &
+ 0.998320000000000 , &
+ 0.997900000000000 , &
+ 0.997320000000000 , &
+ 0.996540000000000 , &
+ 0.995530000000000 , &
+ 0.994260000000000 , &
+ 0.992680000000000 , &
+ 0.990750000000000 , &
+ 0.988430000000000 , &
+ 0.985710000000000 , &
+ 0.982550000000000 , &
+ 0.982500000000000 , &
+ 0.979070000000000 , &
+ 0.975310000000000 , &
+ 0.971280000000000 , &
+ 0.967040000000000 , &
+ 0.962680000000000 , &
+ 0.958230000000000 , &
+ 0.953780000000000 , &
+ 0.949380000000000 , &
+ 0.945090000000000 , &
+ 0.940980000000000 , &
+ 0.937120000000000 /)
+
+ Mref_V%eta_ref( 691 : 720 ) = (/ &
+ 0.933560000000000 , &
+ 0.930340000000000 , &
+ 0.927430000000000 , &
+ 0.924830000000000 , &
+ 0.922510000000000 , &
+ 0.920460000000000 , &
+ 0.918670000000000 , &
+ 0.917110000000000 , &
+ 0.915770000000000 , &
+ 0.914650000000000 , &
+ 0.913710000000000 , &
+ 0.912960000000000 , &
+ 0.912940000000000 , &
+ 0.912540000000000 , &
+ 0.912210000000000 , &
+ 0.911930000000000 , &
+ 0.911710000000000 , &
+ 0.911550000000000 , &
+ 0.911420000000000 , &
+ 0.911340000000000 , &
+ 0.911300000000000 , &
+ 0.911290000000000 , &
+ 0.911300000000000 , &
+ 0.911350000000000 , &
+ 0.911400000000000 , &
+ 0.911470000000000 , &
+ 0.911550000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ Mref_V%eta_ref( 721 : 750 ) = (/ &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 , &
+ 1.00000000000000 /)
+
+ if (SUPPRESS_CRUSTAL_MESH) then
+ Mref_V%density_ref(718:750) = Mref_V%density_ref(717)
+ Mref_V%vpv_ref(718:750) = Mref_V%vpv_ref(717)
+ Mref_V%vph_ref(718:750) = Mref_V%vph_ref(717)
+ Mref_V%vsv_ref(718:750) = Mref_V%vsv_ref(717)
+ Mref_V%vsh_ref(718:750) = Mref_V%vsh_ref(717)
+ endif
+
+
+ end subroutine define_model_ref
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_sea1d.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_sea1d.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/model_sea1d.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,1144 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine model_sea1d(x,rho,vp,vs,Qkappa,Qmu,iregion_code,SEA1DM_V)
+
+ implicit none
+
+ include "constants.h"
+
+! sea1d_model_variables
+ type sea1d_model_variables
+ sequence
+ double precision, dimension(NR_SEA1D) :: radius_sea1d
+ double precision, dimension(NR_SEA1D) :: density_sea1d
+ double precision, dimension(NR_SEA1D) :: vp_sea1d
+ double precision, dimension(NR_SEA1D) :: vs_sea1d
+ double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
+ double precision, dimension(NR_SEA1D) :: Qmu_sea1d
+ end type sea1d_model_variables
+
+ type (sea1d_model_variables) SEA1DM_V
+! sea1d_model_variables
+
+! input:
+! radius r: meters
+
+! output:
+! density rho: kg/m^3
+! compressional wave speed vp: km/s
+! shear wave speed vs: km/s
+
+ integer iregion_code
+
+ double precision x,rho,vp,vs,Qmu,Qkappa
+
+ integer i
+
+ double precision r,frac,scaleval
+
+!! DK DK UGLY implementation of model sea1d below and its radii in
+!! DK DK UGLY subroutine read_parameter_file.f90 has not been thoroughly
+!! DK DK UGLY checked yet
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+ i = 1
+ do while(r >= SEA1DM_V%radius_sea1d(i) .and. i /= NR_SEA1D)
+ i = i + 1
+ enddo
+
+! make sure we stay in the right region
+ if(iregion_code == IREGION_INNER_CORE .and. i > 13) i = 13
+
+ if(iregion_code == IREGION_OUTER_CORE .and. i < 15) i = 15
+ if(iregion_code == IREGION_OUTER_CORE .and. i > 37) i = 37
+
+ if(iregion_code == IREGION_CRUST_MANTLE .and. i < 39) i = 39
+
+ if(i == 1) then
+ rho = SEA1DM_V%density_sea1d(i)
+ vp = SEA1DM_V%vp_sea1d(i)
+ vs = SEA1DM_V%vs_sea1d(i)
+ Qmu = SEA1DM_V%Qmu_sea1d(i)
+ Qkappa = SEA1DM_V%Qkappa_sea1d(i)
+ else
+
+! interpolate from SEA1DM_V%radius_sea1d(i-1) to r using the values at i-1 and i
+ frac = (r-SEA1DM_V%radius_sea1d(i-1))/(SEA1DM_V%radius_sea1d(i)-SEA1DM_V%radius_sea1d(i-1))
+
+ rho = SEA1DM_V%density_sea1d(i-1) + frac * (SEA1DM_V%density_sea1d(i)-SEA1DM_V%density_sea1d(i-1))
+ vp = SEA1DM_V%vp_sea1d(i-1) + frac * (SEA1DM_V%vp_sea1d(i)-SEA1DM_V%vp_sea1d(i-1))
+ vs = SEA1DM_V%vs_sea1d(i-1) + frac * (SEA1DM_V%vs_sea1d(i)-SEA1DM_V%vs_sea1d(i-1))
+ Qmu = SEA1DM_V%Qmu_sea1d(i-1) + frac * (SEA1DM_V%Qmu_sea1d(i)-SEA1DM_V%Qmu_sea1d(i-1))
+ Qkappa = SEA1DM_V%Qkappa_sea1d(i-1) + frac * (SEA1DM_V%Qkappa_sea1d(i)-SEA1DM_V%Qkappa_sea1d(i-1))
+
+ endif
+
+! make sure Vs is zero in the outer core even if roundoff errors on depth
+! also set fictitious attenuation to a very high value (attenuation is not used in the fluid)
+ if(iregion_code == IREGION_OUTER_CORE) then
+ vs = 0.d0
+ Qkappa = 3000.d0
+ Qmu = 3000.d0
+ endif
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ rho=rho*1000.0d0/RHOAV
+ vp=vp*1000.0d0/(R_EARTH*scaleval)
+ vs=vs*1000.0d0/(R_EARTH*scaleval)
+
+ end subroutine model_sea1d
+
+!-------------------
+
+ subroutine define_model_sea1d(USE_EXTERNAL_CRUSTAL_MODEL,SEA1DM_V)
+
+ implicit none
+
+ include "constants.h"
+
+! sea1d_model_variables
+ type sea1d_model_variables
+ sequence
+ double precision, dimension(NR_SEA1D) :: radius_sea1d
+ double precision, dimension(NR_SEA1D) :: density_sea1d
+ double precision, dimension(NR_SEA1D) :: vp_sea1d
+ double precision, dimension(NR_SEA1D) :: vs_sea1d
+ double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
+ double precision, dimension(NR_SEA1D) :: Qmu_sea1d
+ end type sea1d_model_variables
+
+ type (sea1d_model_variables) SEA1DM_V
+! three_d_mantle_model_variables
+
+ logical USE_EXTERNAL_CRUSTAL_MODEL
+
+ integer i
+
+! define all the values in the model
+
+ SEA1DM_V%radius_sea1d(1)= 0.0000000000
+ SEA1DM_V%radius_sea1d(2)= 101425.0000000000
+ SEA1DM_V%radius_sea1d(3)= 202850.0000000000
+ SEA1DM_V%radius_sea1d(4)= 304275.0000000000
+ SEA1DM_V%radius_sea1d(5)= 405700.0000000000
+ SEA1DM_V%radius_sea1d(6)= 507125.0000000000
+ SEA1DM_V%radius_sea1d(7)= 608550.0000000000
+ SEA1DM_V%radius_sea1d(8)= 709975.0000000000
+ SEA1DM_V%radius_sea1d(9)= 811400.0000000000
+ SEA1DM_V%radius_sea1d(10)= 912825.0000000000
+ SEA1DM_V%radius_sea1d(11)= 1014250.0000000000
+ SEA1DM_V%radius_sea1d(12)= 1115675.0000000000
+ SEA1DM_V%radius_sea1d(13)= 1217100.0000000000
+ SEA1DM_V%radius_sea1d(14)= 1217100.0000000000
+ SEA1DM_V%radius_sea1d(15)= 1315735.0000000000
+ SEA1DM_V%radius_sea1d(16)= 1414370.0000000000
+ SEA1DM_V%radius_sea1d(17)= 1513004.0000000000
+ SEA1DM_V%radius_sea1d(18)= 1611639.0000000000
+ SEA1DM_V%radius_sea1d(19)= 1710274.0000000000
+ SEA1DM_V%radius_sea1d(20)= 1808909.0000000000
+ SEA1DM_V%radius_sea1d(21)= 1907544.0000000000
+ SEA1DM_V%radius_sea1d(22)= 2006178.0000000000
+ SEA1DM_V%radius_sea1d(23)= 2104813.0000000000
+ SEA1DM_V%radius_sea1d(24)= 2203448.0000000000
+ SEA1DM_V%radius_sea1d(25)= 2302082.0000000000
+ SEA1DM_V%radius_sea1d(26)= 2400717.0000000000
+ SEA1DM_V%radius_sea1d(27)= 2499352.0000000000
+ SEA1DM_V%radius_sea1d(28)= 2597987.0000000000
+ SEA1DM_V%radius_sea1d(29)= 2696622.0000000000
+ SEA1DM_V%radius_sea1d(30)= 2795256.0000000000
+ SEA1DM_V%radius_sea1d(31)= 2893891.0000000000
+ SEA1DM_V%radius_sea1d(32)= 2992526.0000000000
+ SEA1DM_V%radius_sea1d(33)= 3091161.0000000000
+ SEA1DM_V%radius_sea1d(34)= 3189796.0000000000
+ SEA1DM_V%radius_sea1d(35)= 3288431.0000000000
+ SEA1DM_V%radius_sea1d(36)= 3387066.0000000000
+ SEA1DM_V%radius_sea1d(37)= 3485700.0000000000
+ SEA1DM_V%radius_sea1d(38)= 3485700.0000000000
+ SEA1DM_V%radius_sea1d(39)= 3536048.0000000000
+ SEA1DM_V%radius_sea1d(40)= 3586396.0000000000
+ SEA1DM_V%radius_sea1d(41)= 3636743.0000000000
+ SEA1DM_V%radius_sea1d(42)= 3687091.0000000000
+ SEA1DM_V%radius_sea1d(43)= 3737438.0000000000
+ SEA1DM_V%radius_sea1d(44)= 3787786.0000000000
+ SEA1DM_V%radius_sea1d(45)= 3838134.0000000000
+ SEA1DM_V%radius_sea1d(46)= 3888482.0000000000
+ SEA1DM_V%radius_sea1d(47)= 3938830.0000000000
+ SEA1DM_V%radius_sea1d(48)= 3989177.0000000000
+ SEA1DM_V%radius_sea1d(49)= 4039525.0000000000
+ SEA1DM_V%radius_sea1d(50)= 4089872.0000000000
+ SEA1DM_V%radius_sea1d(51)= 4140220.0000000000
+ SEA1DM_V%radius_sea1d(52)= 4190568.0000000000
+ SEA1DM_V%radius_sea1d(53)= 4240916.0000000000
+ SEA1DM_V%radius_sea1d(54)= 4291264.0000000000
+ SEA1DM_V%radius_sea1d(55)= 4341612.0000000000
+ SEA1DM_V%radius_sea1d(56)= 4391959.0000000000
+ SEA1DM_V%radius_sea1d(57)= 4442306.0000000000
+ SEA1DM_V%radius_sea1d(58)= 4492654.0000000000
+ SEA1DM_V%radius_sea1d(59)= 4543002.0000000000
+ SEA1DM_V%radius_sea1d(60)= 4593350.0000000000
+ SEA1DM_V%radius_sea1d(61)= 4643698.0000000000
+ SEA1DM_V%radius_sea1d(62)= 4694046.0000000000
+ SEA1DM_V%radius_sea1d(63)= 4744393.0000000000
+ SEA1DM_V%radius_sea1d(64)= 4794740.0000000000
+ SEA1DM_V%radius_sea1d(65)= 4845089.0000000000
+ SEA1DM_V%radius_sea1d(66)= 4895436.0000000000
+ SEA1DM_V%radius_sea1d(67)= 4945784.0000000000
+ SEA1DM_V%radius_sea1d(68)= 4996132.0000000000
+ SEA1DM_V%radius_sea1d(69)= 5046480.0000000000
+ SEA1DM_V%radius_sea1d(70)= 5096827.0000000000
+ SEA1DM_V%radius_sea1d(71)= 5147175.0000000000
+ SEA1DM_V%radius_sea1d(72)= 5197522.0000000000
+ SEA1DM_V%radius_sea1d(73)= 5247870.0000000000
+ SEA1DM_V%radius_sea1d(74)= 5298218.0000000000
+ SEA1DM_V%radius_sea1d(75)= 5348566.0000000000
+ SEA1DM_V%radius_sea1d(76)= 5398914.0000000000
+ SEA1DM_V%radius_sea1d(77)= 5449261.0000000000
+ SEA1DM_V%radius_sea1d(78)= 5499610.0000000000
+ SEA1DM_V%radius_sea1d(79)= 5549957.0000000000
+ SEA1DM_V%radius_sea1d(80)= 5600304.0000000000
+ SEA1DM_V%radius_sea1d(81)= 5650652.0000000000
+ SEA1DM_V%radius_sea1d(82)= 5701000.0000000000
+ SEA1DM_V%radius_sea1d(83)= 5711000.0000000000
+ SEA1DM_V%radius_sea1d(84)= 5711000.0000000000
+ SEA1DM_V%radius_sea1d(85)= 5721000.0000000000
+ SEA1DM_V%radius_sea1d(86)= 5731000.0000000000
+ SEA1DM_V%radius_sea1d(87)= 5741000.0000000000
+ SEA1DM_V%radius_sea1d(88)= 5751000.0000000000
+ SEA1DM_V%radius_sea1d(89)= 5761000.0000000000
+ SEA1DM_V%radius_sea1d(90)= 5771000.0000000000
+ SEA1DM_V%radius_sea1d(91)= 5781000.0000000000
+ SEA1DM_V%radius_sea1d(92)= 5791000.0000000000
+ SEA1DM_V%radius_sea1d(93)= 5801000.0000000000
+ SEA1DM_V%radius_sea1d(94)= 5811000.0000000000
+ SEA1DM_V%radius_sea1d(95)= 5821000.0000000000
+ SEA1DM_V%radius_sea1d(96)= 5831000.0000000000
+ SEA1DM_V%radius_sea1d(97)= 5841000.0000000000
+ SEA1DM_V%radius_sea1d(98)= 5851000.0000000000
+ SEA1DM_V%radius_sea1d(99)= 5861000.0000000000
+ SEA1DM_V%radius_sea1d(100)= 5871000.0000000000
+ SEA1DM_V%radius_sea1d(101)= 5881000.0000000000
+ SEA1DM_V%radius_sea1d(102)= 5891000.0000000000
+ SEA1DM_V%radius_sea1d(103)= 5901000.0000000000
+ SEA1DM_V%radius_sea1d(104)= 5911000.0000000000
+ SEA1DM_V%radius_sea1d(105)= 5921000.0000000000
+ SEA1DM_V%radius_sea1d(106)= 5931000.0000000000
+ SEA1DM_V%radius_sea1d(107)= 5941000.0000000000
+ SEA1DM_V%radius_sea1d(108)= 5951000.0000000000
+ SEA1DM_V%radius_sea1d(109)= 5961000.0000000000
+ SEA1DM_V%radius_sea1d(110)= 5961000.0000000000
+ SEA1DM_V%radius_sea1d(111)= 5971000.0000000000
+ SEA1DM_V%radius_sea1d(112)= 5981000.0000000000
+ SEA1DM_V%radius_sea1d(113)= 5991000.0000000000
+ SEA1DM_V%radius_sea1d(114)= 6001000.0000000000
+ SEA1DM_V%radius_sea1d(115)= 6011000.0000000000
+ SEA1DM_V%radius_sea1d(116)= 6021000.0000000000
+ SEA1DM_V%radius_sea1d(117)= 6031000.0000000000
+ SEA1DM_V%radius_sea1d(118)= 6041000.0000000000
+ SEA1DM_V%radius_sea1d(119)= 6051000.0000000000
+ SEA1DM_V%radius_sea1d(120)= 6061000.0000000000
+ SEA1DM_V%radius_sea1d(121)= 6071000.0000000000
+ SEA1DM_V%radius_sea1d(122)= 6081000.0000000000
+ SEA1DM_V%radius_sea1d(123)= 6091000.0000000000
+ SEA1DM_V%radius_sea1d(124)= 6101000.0000000000
+ SEA1DM_V%radius_sea1d(125)= 6111000.0000000000
+ SEA1DM_V%radius_sea1d(126)= 6121000.0000000000
+ SEA1DM_V%radius_sea1d(127)= 6131000.0000000000
+ SEA1DM_V%radius_sea1d(128)= 6141000.0000000000
+ SEA1DM_V%radius_sea1d(129)= 6151000.0000000000
+ SEA1DM_V%radius_sea1d(130)= 6161000.0000000000
+ SEA1DM_V%radius_sea1d(131)= 6171000.0000000000
+ SEA1DM_V%radius_sea1d(132)= 6181000.0000000000
+ SEA1DM_V%radius_sea1d(133)= 6191000.0000000000
+ SEA1DM_V%radius_sea1d(134)= 6201000.0000000000
+ SEA1DM_V%radius_sea1d(135)= 6211000.0000000000
+ SEA1DM_V%radius_sea1d(136)= 6221000.0000000000
+ SEA1DM_V%radius_sea1d(137)= 6231000.0000000000
+ SEA1DM_V%radius_sea1d(138)= 6241000.0000000000
+ SEA1DM_V%radius_sea1d(139)= 6251000.0000000000
+ SEA1DM_V%radius_sea1d(140)= 6261000.0000000000
+ SEA1DM_V%radius_sea1d(141)= 6271000.0000000000
+ SEA1DM_V%radius_sea1d(142)= 6281000.0000000000
+ SEA1DM_V%radius_sea1d(143)= 6291000.0000000000
+ SEA1DM_V%radius_sea1d(144)= 6301000.0000000000
+ SEA1DM_V%radius_sea1d(145)= 6311000.0000000000
+ SEA1DM_V%radius_sea1d(146)= 6321000.0000000000
+ SEA1DM_V%radius_sea1d(147)= 6326000.0000000000
+ SEA1DM_V%radius_sea1d(148)= 6331000.0000000000
+ SEA1DM_V%radius_sea1d(149)= 6336000.0000000000
+ SEA1DM_V%radius_sea1d(150)= 6341000.0000000000
+ SEA1DM_V%radius_sea1d(151)= 6346000.0000000000
+ SEA1DM_V%radius_sea1d(152)= 6346000.0000000000
+ SEA1DM_V%radius_sea1d(153)= 6351000.0000000000
+ SEA1DM_V%radius_sea1d(154)= 6353800.0000000000
+ SEA1DM_V%radius_sea1d(155)= 6356600.0000000000
+ SEA1DM_V%radius_sea1d(156)= 6360000.0000000000
+ SEA1DM_V%radius_sea1d(157)= 6363000.0000000000
+ SEA1DM_V%radius_sea1d(158)= 6365000.0000000000
+ SEA1DM_V%radius_sea1d(159)= 6366000.0000000000
+ SEA1DM_V%radius_sea1d(160)= 6366000.0000000000
+ SEA1DM_V%radius_sea1d(161)= 6368000.0000000000
+ SEA1DM_V%radius_sea1d(162)= 6368000.0000000000
+ SEA1DM_V%radius_sea1d(163)= 6371000.0000000000
+
+ SEA1DM_V%density_sea1d(1)= 13.0121900000000
+ SEA1DM_V%density_sea1d(2)= 13.0100200000000
+ SEA1DM_V%density_sea1d(3)= 13.0035600000000
+ SEA1DM_V%density_sea1d(4)= 12.9928300000000
+ SEA1DM_V%density_sea1d(5)= 12.9778000000000
+ SEA1DM_V%density_sea1d(6)= 12.9585000000000
+ SEA1DM_V%density_sea1d(7)= 12.9349100000000
+ SEA1DM_V%density_sea1d(8)= 12.9070300000000
+ SEA1DM_V%density_sea1d(9)= 12.8748700000000
+ SEA1DM_V%density_sea1d(10)= 12.8384300000000
+ SEA1DM_V%density_sea1d(11)= 12.7977100000000
+ SEA1DM_V%density_sea1d(12)= 12.7526900000000
+ SEA1DM_V%density_sea1d(13)= 12.7037000000000
+ SEA1DM_V%density_sea1d(14)= 12.1391000000000
+ SEA1DM_V%density_sea1d(15)= 12.0877600000000
+ SEA1DM_V%density_sea1d(16)= 12.0333900000000
+ SEA1DM_V%density_sea1d(17)= 11.9757900000000
+ SEA1DM_V%density_sea1d(18)= 11.9148500000000
+ SEA1DM_V%density_sea1d(19)= 11.8503900000000
+ SEA1DM_V%density_sea1d(20)= 11.7822500000000
+ SEA1DM_V%density_sea1d(21)= 11.7102700000000
+ SEA1DM_V%density_sea1d(22)= 11.6343000000000
+ SEA1DM_V%density_sea1d(23)= 11.5541800000000
+ SEA1DM_V%density_sea1d(24)= 11.4697400000000
+ SEA1DM_V%density_sea1d(25)= 11.3808400000000
+ SEA1DM_V%density_sea1d(26)= 11.2873100000000
+ SEA1DM_V%density_sea1d(27)= 11.1890000000000
+ SEA1DM_V%density_sea1d(28)= 11.0857400000000
+ SEA1DM_V%density_sea1d(29)= 10.9773800000000
+ SEA1DM_V%density_sea1d(30)= 10.8637600000000
+ SEA1DM_V%density_sea1d(31)= 10.7447200000000
+ SEA1DM_V%density_sea1d(32)= 10.6201000000000
+ SEA1DM_V%density_sea1d(33)= 10.4897500000000
+ SEA1DM_V%density_sea1d(34)= 10.3535000000000
+ SEA1DM_V%density_sea1d(35)= 10.2112100000000
+ SEA1DM_V%density_sea1d(36)= 10.0627000000000
+ SEA1DM_V%density_sea1d(37)= 9.9085500000000
+ SEA1DM_V%density_sea1d(38)= 5.5497800000000
+ SEA1DM_V%density_sea1d(39)= 5.5263200000000
+ SEA1DM_V%density_sea1d(40)= 5.5027000000000
+ SEA1DM_V%density_sea1d(41)= 5.4789400000000
+ SEA1DM_V%density_sea1d(42)= 5.4550400000000
+ SEA1DM_V%density_sea1d(43)= 5.4309700000000
+ SEA1DM_V%density_sea1d(44)= 5.4067700000000
+ SEA1DM_V%density_sea1d(45)= 5.3824200000000
+ SEA1DM_V%density_sea1d(46)= 5.3579200000000
+ SEA1DM_V%density_sea1d(47)= 5.3332700000000
+ SEA1DM_V%density_sea1d(48)= 5.3084700000000
+ SEA1DM_V%density_sea1d(49)= 5.2835200000000
+ SEA1DM_V%density_sea1d(50)= 5.2584400000000
+ SEA1DM_V%density_sea1d(51)= 5.2331900000000
+ SEA1DM_V%density_sea1d(52)= 5.2078000000000
+ SEA1DM_V%density_sea1d(53)= 5.1822700000000
+ SEA1DM_V%density_sea1d(54)= 5.1565900000000
+ SEA1DM_V%density_sea1d(55)= 5.1307500000000
+ SEA1DM_V%density_sea1d(56)= 5.1047600000000
+ SEA1DM_V%density_sea1d(57)= 5.0786400000000
+ SEA1DM_V%density_sea1d(58)= 5.0523600000000
+ SEA1DM_V%density_sea1d(59)= 5.0259400000000
+ SEA1DM_V%density_sea1d(60)= 4.9993600000000
+ SEA1DM_V%density_sea1d(61)= 4.9726500000000
+ SEA1DM_V%density_sea1d(62)= 4.9457800000000
+ SEA1DM_V%density_sea1d(63)= 4.9187500000000
+ SEA1DM_V%density_sea1d(64)= 4.8915900000000
+ SEA1DM_V%density_sea1d(65)= 4.8642700000000
+ SEA1DM_V%density_sea1d(66)= 4.8368200000000
+ SEA1DM_V%density_sea1d(67)= 4.8092100000000
+ SEA1DM_V%density_sea1d(68)= 4.7814400000000
+ SEA1DM_V%density_sea1d(69)= 4.7535400000000
+ SEA1DM_V%density_sea1d(70)= 4.7254900000000
+ SEA1DM_V%density_sea1d(71)= 4.6972900000000
+ SEA1DM_V%density_sea1d(72)= 4.6689400000000
+ SEA1DM_V%density_sea1d(73)= 4.6404400000000
+ SEA1DM_V%density_sea1d(74)= 4.6117900000000
+ SEA1DM_V%density_sea1d(75)= 4.5830000000000
+ SEA1DM_V%density_sea1d(76)= 4.5540600000000
+ SEA1DM_V%density_sea1d(77)= 4.5249700000000
+ SEA1DM_V%density_sea1d(78)= 4.4957300000000
+ SEA1DM_V%density_sea1d(79)= 4.4663500000000
+ SEA1DM_V%density_sea1d(80)= 4.4368100000000
+ SEA1DM_V%density_sea1d(81)= 4.4071300000000
+ SEA1DM_V%density_sea1d(82)= 4.3773100000000
+ SEA1DM_V%density_sea1d(83)= 4.3713900000000
+ SEA1DM_V%density_sea1d(84)= 4.0645800000000
+ SEA1DM_V%density_sea1d(85)= 4.0522200000000
+ SEA1DM_V%density_sea1d(86)= 4.0398700000000
+ SEA1DM_V%density_sea1d(87)= 4.0275200000000
+ SEA1DM_V%density_sea1d(88)= 4.0151600000000
+ SEA1DM_V%density_sea1d(89)= 4.0028100000000
+ SEA1DM_V%density_sea1d(90)= 3.9904500000000
+ SEA1DM_V%density_sea1d(91)= 3.9781000000000
+ SEA1DM_V%density_sea1d(92)= 3.9657500000000
+ SEA1DM_V%density_sea1d(93)= 3.9533900000000
+ SEA1DM_V%density_sea1d(94)= 3.9410400000000
+ SEA1DM_V%density_sea1d(95)= 3.9286900000000
+ SEA1DM_V%density_sea1d(96)= 3.9163300000000
+ SEA1DM_V%density_sea1d(97)= 3.9039800000000
+ SEA1DM_V%density_sea1d(98)= 3.8916200000000
+ SEA1DM_V%density_sea1d(99)= 3.8792700000000
+ SEA1DM_V%density_sea1d(100)= 3.8669200000000
+ SEA1DM_V%density_sea1d(101)= 3.8545600000000
+ SEA1DM_V%density_sea1d(102)= 3.8422100000000
+ SEA1DM_V%density_sea1d(103)= 3.8298600000000
+ SEA1DM_V%density_sea1d(104)= 3.8175000000000
+ SEA1DM_V%density_sea1d(105)= 3.8051500000000
+ SEA1DM_V%density_sea1d(106)= 3.7928000000000
+ SEA1DM_V%density_sea1d(107)= 3.7804400000000
+ SEA1DM_V%density_sea1d(108)= 3.7680900000000
+ SEA1DM_V%density_sea1d(109)= 3.7557300000000
+ SEA1DM_V%density_sea1d(110)= 3.5469600000000
+ SEA1DM_V%density_sea1d(111)= 3.5409000000000
+ SEA1DM_V%density_sea1d(112)= 3.5348400000000
+ SEA1DM_V%density_sea1d(113)= 3.5287900000000
+ SEA1DM_V%density_sea1d(114)= 3.5227300000000
+ SEA1DM_V%density_sea1d(115)= 3.5166700000000
+ SEA1DM_V%density_sea1d(116)= 3.5106100000000
+ SEA1DM_V%density_sea1d(117)= 3.5045500000000
+ SEA1DM_V%density_sea1d(118)= 3.4984900000000
+ SEA1DM_V%density_sea1d(119)= 3.4924300000000
+ SEA1DM_V%density_sea1d(120)= 3.4863800000000
+ SEA1DM_V%density_sea1d(121)= 3.4803200000000
+ SEA1DM_V%density_sea1d(122)= 3.4742600000000
+ SEA1DM_V%density_sea1d(123)= 3.4682000000000
+ SEA1DM_V%density_sea1d(124)= 3.4621400000000
+ SEA1DM_V%density_sea1d(125)= 3.4560800000000
+ SEA1DM_V%density_sea1d(126)= 3.4500200000000
+ SEA1DM_V%density_sea1d(127)= 3.4439700000000
+ SEA1DM_V%density_sea1d(128)= 3.4379100000000
+ SEA1DM_V%density_sea1d(129)= 3.4318500000000
+ SEA1DM_V%density_sea1d(130)= 3.4257900000000
+ SEA1DM_V%density_sea1d(131)= 3.4197300000000
+ SEA1DM_V%density_sea1d(132)= 3.4136800000000
+ SEA1DM_V%density_sea1d(133)= 3.4076200000000
+ SEA1DM_V%density_sea1d(134)= 3.4015600000000
+ SEA1DM_V%density_sea1d(135)= 3.3955000000000
+ SEA1DM_V%density_sea1d(136)= 3.3894400000000
+ SEA1DM_V%density_sea1d(137)= 3.3833800000000
+ SEA1DM_V%density_sea1d(138)= 3.3773200000000
+ SEA1DM_V%density_sea1d(139)= 3.3712600000000
+ SEA1DM_V%density_sea1d(140)= 3.3652100000000
+ SEA1DM_V%density_sea1d(141)= 3.3591500000000
+ SEA1DM_V%density_sea1d(142)= 3.3530900000000
+ SEA1DM_V%density_sea1d(143)= 3.3470300000000
+ SEA1DM_V%density_sea1d(144)= 3.3409700000000
+ SEA1DM_V%density_sea1d(145)= 3.3349100000000
+ SEA1DM_V%density_sea1d(146)= 3.3288500000000
+ SEA1DM_V%density_sea1d(147)= 3.3288500000000
+ SEA1DM_V%density_sea1d(148)= 3.3227900000000
+ SEA1DM_V%density_sea1d(149)= 3.3227900000000
+ SEA1DM_V%density_sea1d(150)= 3.3227900000000
+ SEA1DM_V%density_sea1d(151)= 3.3227900000000
+ SEA1DM_V%density_sea1d(152)= 2.8500000000000
+ SEA1DM_V%density_sea1d(153)= 2.8500000000000
+ SEA1DM_V%density_sea1d(154)= 2.8500000000000
+ SEA1DM_V%density_sea1d(155)= 2.8500000000000
+ SEA1DM_V%density_sea1d(156)= 2.8500000000000
+ SEA1DM_V%density_sea1d(157)= 2.8500000000000
+ SEA1DM_V%density_sea1d(158)= 2.8500000000000
+ SEA1DM_V%density_sea1d(159)= 2.8500000000000
+ SEA1DM_V%density_sea1d(160)= 2.8500000000000
+ SEA1DM_V%density_sea1d(161)= 2.8500000000000
+ SEA1DM_V%density_sea1d(162)= 2.8500000000000
+ SEA1DM_V%density_sea1d(163)= 2.8500000000000
+
+ SEA1DM_V%vp_sea1d(1)= 11.2409400000000
+ SEA1DM_V%vp_sea1d(2)= 11.2398900000000
+ SEA1DM_V%vp_sea1d(3)= 11.2367600000000
+ SEA1DM_V%vp_sea1d(4)= 11.2315600000000
+ SEA1DM_V%vp_sea1d(5)= 11.2242700000000
+ SEA1DM_V%vp_sea1d(6)= 11.2149200000000
+ SEA1DM_V%vp_sea1d(7)= 11.2034800000000
+ SEA1DM_V%vp_sea1d(8)= 11.1899700000000
+ SEA1DM_V%vp_sea1d(9)= 11.1743800000000
+ SEA1DM_V%vp_sea1d(10)= 11.1567200000000
+ SEA1DM_V%vp_sea1d(11)= 11.1369900000000
+ SEA1DM_V%vp_sea1d(12)= 11.1151700000000
+ SEA1DM_V%vp_sea1d(13)= 11.0914200000000
+ SEA1DM_V%vp_sea1d(14)= 10.2577900000000
+ SEA1DM_V%vp_sea1d(15)= 10.2317700000000
+ SEA1DM_V%vp_sea1d(16)= 10.1991900000000
+ SEA1DM_V%vp_sea1d(17)= 10.1600600000000
+ SEA1DM_V%vp_sea1d(18)= 10.1143700000000
+ SEA1DM_V%vp_sea1d(19)= 10.0621400000000
+ SEA1DM_V%vp_sea1d(20)= 10.0033600000000
+ SEA1DM_V%vp_sea1d(21)= 9.9380100000000
+ SEA1DM_V%vp_sea1d(22)= 9.8661300000000
+ SEA1DM_V%vp_sea1d(23)= 9.7876800000000
+ SEA1DM_V%vp_sea1d(24)= 9.7026900000000
+ SEA1DM_V%vp_sea1d(25)= 9.6111500000000
+ SEA1DM_V%vp_sea1d(26)= 9.5130500000000
+ SEA1DM_V%vp_sea1d(27)= 9.4084000000000
+ SEA1DM_V%vp_sea1d(28)= 9.2972000000000
+ SEA1DM_V%vp_sea1d(29)= 9.1794500000000
+ SEA1DM_V%vp_sea1d(30)= 9.0551400000000
+ SEA1DM_V%vp_sea1d(31)= 8.9242800000000
+ SEA1DM_V%vp_sea1d(32)= 8.7868700000000
+ SEA1DM_V%vp_sea1d(33)= 8.6429000000000
+ SEA1DM_V%vp_sea1d(34)= 8.4923900000000
+ SEA1DM_V%vp_sea1d(35)= 8.3353300000000
+ SEA1DM_V%vp_sea1d(36)= 8.1717000000000
+ SEA1DM_V%vp_sea1d(37)= 8.0022600000000
+ SEA1DM_V%vp_sea1d(38)= 13.7318200000000
+ SEA1DM_V%vp_sea1d(39)= 13.6839600000000
+ SEA1DM_V%vp_sea1d(40)= 13.6355700000000
+ SEA1DM_V%vp_sea1d(41)= 13.5866700000000
+ SEA1DM_V%vp_sea1d(42)= 13.5372000000000
+ SEA1DM_V%vp_sea1d(43)= 13.4871700000000
+ SEA1DM_V%vp_sea1d(44)= 13.4365700000000
+ SEA1DM_V%vp_sea1d(45)= 13.3853700000000
+ SEA1DM_V%vp_sea1d(46)= 13.3335400000000
+ SEA1DM_V%vp_sea1d(47)= 13.2811000000000
+ SEA1DM_V%vp_sea1d(48)= 13.2280100000000
+ SEA1DM_V%vp_sea1d(49)= 13.1742700000000
+ SEA1DM_V%vp_sea1d(50)= 13.1198500000000
+ SEA1DM_V%vp_sea1d(51)= 13.0647300000000
+ SEA1DM_V%vp_sea1d(52)= 13.0089100000000
+ SEA1DM_V%vp_sea1d(53)= 12.9523700000000
+ SEA1DM_V%vp_sea1d(54)= 12.8951000000000
+ SEA1DM_V%vp_sea1d(55)= 12.8370600000000
+ SEA1DM_V%vp_sea1d(56)= 12.7782600000000
+ SEA1DM_V%vp_sea1d(57)= 12.7186700000000
+ SEA1DM_V%vp_sea1d(58)= 12.6582800000000
+ SEA1DM_V%vp_sea1d(59)= 12.5970700000000
+ SEA1DM_V%vp_sea1d(60)= 12.5350400000000
+ SEA1DM_V%vp_sea1d(61)= 12.4721600000000
+ SEA1DM_V%vp_sea1d(62)= 12.4084000000000
+ SEA1DM_V%vp_sea1d(63)= 12.3437700000000
+ SEA1DM_V%vp_sea1d(64)= 12.2782500000000
+ SEA1DM_V%vp_sea1d(65)= 12.2118200000000
+ SEA1DM_V%vp_sea1d(66)= 12.1444600000000
+ SEA1DM_V%vp_sea1d(67)= 12.0761600000000
+ SEA1DM_V%vp_sea1d(68)= 12.0069000000000
+ SEA1DM_V%vp_sea1d(69)= 11.9366700000000
+ SEA1DM_V%vp_sea1d(70)= 11.8654400000000
+ SEA1DM_V%vp_sea1d(71)= 11.7932100000000
+ SEA1DM_V%vp_sea1d(72)= 11.7199700000000
+ SEA1DM_V%vp_sea1d(73)= 11.6456800000000
+ SEA1DM_V%vp_sea1d(74)= 11.5703400000000
+ SEA1DM_V%vp_sea1d(75)= 11.4939400000000
+ SEA1DM_V%vp_sea1d(76)= 11.4164500000000
+ SEA1DM_V%vp_sea1d(77)= 11.3378700000000
+ SEA1DM_V%vp_sea1d(78)= 11.2581700000000
+ SEA1DM_V%vp_sea1d(79)= 11.1773300000000
+ SEA1DM_V%vp_sea1d(80)= 11.0953600000000
+ SEA1DM_V%vp_sea1d(81)= 11.0122200000000
+ SEA1DM_V%vp_sea1d(82)= 10.9280200000000
+ SEA1DM_V%vp_sea1d(83)= 10.9113000000000
+ SEA1DM_V%vp_sea1d(84)= 10.0182900000000
+ SEA1DM_V%vp_sea1d(85)= 9.9989600000000
+ SEA1DM_V%vp_sea1d(86)= 9.9796300000000
+ SEA1DM_V%vp_sea1d(87)= 9.9603000000000
+ SEA1DM_V%vp_sea1d(88)= 9.9409700000000
+ SEA1DM_V%vp_sea1d(89)= 9.9216400000000
+ SEA1DM_V%vp_sea1d(90)= 9.9023100000000
+ SEA1DM_V%vp_sea1d(91)= 9.8829800000000
+ SEA1DM_V%vp_sea1d(92)= 9.8636600000000
+ SEA1DM_V%vp_sea1d(93)= 9.8443300000000
+ SEA1DM_V%vp_sea1d(94)= 9.8250000000000
+ SEA1DM_V%vp_sea1d(95)= 9.8056700000000
+ SEA1DM_V%vp_sea1d(96)= 9.7863400000000
+ SEA1DM_V%vp_sea1d(97)= 9.7670100000000
+ SEA1DM_V%vp_sea1d(98)= 9.7476800000000
+ SEA1DM_V%vp_sea1d(99)= 9.7283500000000
+ SEA1DM_V%vp_sea1d(100)= 9.7090300000000
+ SEA1DM_V%vp_sea1d(101)= 9.6897000000000
+ SEA1DM_V%vp_sea1d(102)= 9.6703700000000
+ SEA1DM_V%vp_sea1d(103)= 9.6510400000000
+ SEA1DM_V%vp_sea1d(104)= 9.6317100000000
+ SEA1DM_V%vp_sea1d(105)= 9.6123800000000
+ SEA1DM_V%vp_sea1d(106)= 9.5930500000000
+ SEA1DM_V%vp_sea1d(107)= 9.5737200000000
+ SEA1DM_V%vp_sea1d(108)= 9.5543900000000
+ SEA1DM_V%vp_sea1d(109)= 9.5350600000000
+ SEA1DM_V%vp_sea1d(110)= 9.0766800000000
+ SEA1DM_V%vp_sea1d(111)= 9.0188500000000
+ SEA1DM_V%vp_sea1d(112)= 8.9610200000000
+ SEA1DM_V%vp_sea1d(113)= 8.9031800000000
+ SEA1DM_V%vp_sea1d(114)= 8.8453500000000
+ SEA1DM_V%vp_sea1d(115)= 8.7875100000000
+ SEA1DM_V%vp_sea1d(116)= 8.7296800000000
+ SEA1DM_V%vp_sea1d(117)= 8.6718500000000
+ SEA1DM_V%vp_sea1d(118)= 8.6140100000000
+ SEA1DM_V%vp_sea1d(119)= 8.5561800000000
+ SEA1DM_V%vp_sea1d(120)= 8.4983400000000
+ SEA1DM_V%vp_sea1d(121)= 8.4405100000000
+ SEA1DM_V%vp_sea1d(122)= 8.3826700000000
+ SEA1DM_V%vp_sea1d(123)= 8.3248400000000
+ SEA1DM_V%vp_sea1d(124)= 8.2670100000000
+ SEA1DM_V%vp_sea1d(125)= 8.2091700000000
+ SEA1DM_V%vp_sea1d(126)= 8.1513400000000
+ SEA1DM_V%vp_sea1d(127)= 8.0935000000000
+ SEA1DM_V%vp_sea1d(128)= 8.0356700000000
+ SEA1DM_V%vp_sea1d(129)= 7.9778300000000
+ SEA1DM_V%vp_sea1d(130)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(131)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(132)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(133)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(134)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(135)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(136)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(137)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(138)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(139)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(140)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(141)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(142)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(143)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(144)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(145)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(146)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(147)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(148)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(149)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(150)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(151)= 7.9200000000000
+ SEA1DM_V%vp_sea1d(152)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(153)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(154)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(155)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(156)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(157)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(158)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(159)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(160)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(161)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(162)= 6.4000000000000
+ SEA1DM_V%vp_sea1d(163)= 6.4000000000000
+
+ SEA1DM_V%vs_sea1d(1)= 3.5645400000000
+ SEA1DM_V%vs_sea1d(2)= 3.5636500000000
+ SEA1DM_V%vs_sea1d(3)= 3.5610200000000
+ SEA1DM_V%vs_sea1d(4)= 3.5566300000000
+ SEA1DM_V%vs_sea1d(5)= 3.5504900000000
+ SEA1DM_V%vs_sea1d(6)= 3.5426100000000
+ SEA1DM_V%vs_sea1d(7)= 3.5329700000000
+ SEA1DM_V%vs_sea1d(8)= 3.5215900000000
+ SEA1DM_V%vs_sea1d(9)= 3.5084500000000
+ SEA1DM_V%vs_sea1d(10)= 3.4935700000000
+ SEA1DM_V%vs_sea1d(11)= 3.4769300000000
+ SEA1DM_V%vs_sea1d(12)= 3.4585500000000
+ SEA1DM_V%vs_sea1d(13)= 3.4385400000000
+ SEA1DM_V%vs_sea1d(14)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(15)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(16)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(17)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(18)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(19)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(20)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(21)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(22)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(23)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(24)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(25)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(26)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(27)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(28)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(29)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(30)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(31)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(32)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(33)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(34)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(35)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(36)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(37)= 0.0000000000000
+ SEA1DM_V%vs_sea1d(38)= 7.2433800000000
+ SEA1DM_V%vs_sea1d(39)= 7.2260300000000
+ SEA1DM_V%vs_sea1d(40)= 7.2085500000000
+ SEA1DM_V%vs_sea1d(41)= 7.1909200000000
+ SEA1DM_V%vs_sea1d(42)= 7.1731300000000
+ SEA1DM_V%vs_sea1d(43)= 7.1551600000000
+ SEA1DM_V%vs_sea1d(44)= 7.1370000000000
+ SEA1DM_V%vs_sea1d(45)= 7.1186000000000
+ SEA1DM_V%vs_sea1d(46)= 7.0999800000000
+ SEA1DM_V%vs_sea1d(47)= 7.0810900000000
+ SEA1DM_V%vs_sea1d(48)= 7.0619300000000
+ SEA1DM_V%vs_sea1d(49)= 7.0424700000000
+ SEA1DM_V%vs_sea1d(50)= 7.0227000000000
+ SEA1DM_V%vs_sea1d(51)= 7.0026000000000
+ SEA1DM_V%vs_sea1d(52)= 6.9821500000000
+ SEA1DM_V%vs_sea1d(53)= 6.9613400000000
+ SEA1DM_V%vs_sea1d(54)= 6.9401300000000
+ SEA1DM_V%vs_sea1d(55)= 6.9185200000000
+ SEA1DM_V%vs_sea1d(56)= 6.8964900000000
+ SEA1DM_V%vs_sea1d(57)= 6.8740200000000
+ SEA1DM_V%vs_sea1d(58)= 6.8510900000000
+ SEA1DM_V%vs_sea1d(59)= 6.8276700000000
+ SEA1DM_V%vs_sea1d(60)= 6.8037600000000
+ SEA1DM_V%vs_sea1d(61)= 6.7793300000000
+ SEA1DM_V%vs_sea1d(62)= 6.7543700000000
+ SEA1DM_V%vs_sea1d(63)= 6.7288500000000
+ SEA1DM_V%vs_sea1d(64)= 6.7027700000000
+ SEA1DM_V%vs_sea1d(65)= 6.6760900000000
+ SEA1DM_V%vs_sea1d(66)= 6.6488100000000
+ SEA1DM_V%vs_sea1d(67)= 6.6208900000000
+ SEA1DM_V%vs_sea1d(68)= 6.5923300000000
+ SEA1DM_V%vs_sea1d(69)= 6.5631100000000
+ SEA1DM_V%vs_sea1d(70)= 6.5332000000000
+ SEA1DM_V%vs_sea1d(71)= 6.5026000000000
+ SEA1DM_V%vs_sea1d(72)= 6.4712600000000
+ SEA1DM_V%vs_sea1d(73)= 6.4392000000000
+ SEA1DM_V%vs_sea1d(74)= 6.4063800000000
+ SEA1DM_V%vs_sea1d(75)= 6.3727800000000
+ SEA1DM_V%vs_sea1d(76)= 6.3383900000000
+ SEA1DM_V%vs_sea1d(77)= 6.3031900000000
+ SEA1DM_V%vs_sea1d(78)= 6.2671500000000
+ SEA1DM_V%vs_sea1d(79)= 6.2302600000000
+ SEA1DM_V%vs_sea1d(80)= 6.1925100000000
+ SEA1DM_V%vs_sea1d(81)= 6.1538700000000
+ SEA1DM_V%vs_sea1d(82)= 6.1144200000000
+ SEA1DM_V%vs_sea1d(83)= 6.1065800000000
+ SEA1DM_V%vs_sea1d(84)= 5.4546300000000
+ SEA1DM_V%vs_sea1d(85)= 5.4378400000000
+ SEA1DM_V%vs_sea1d(86)= 5.4210500000000
+ SEA1DM_V%vs_sea1d(87)= 5.4042500000000
+ SEA1DM_V%vs_sea1d(88)= 5.3874600000000
+ SEA1DM_V%vs_sea1d(89)= 5.3706700000000
+ SEA1DM_V%vs_sea1d(90)= 5.3538800000000
+ SEA1DM_V%vs_sea1d(91)= 5.3370900000000
+ SEA1DM_V%vs_sea1d(92)= 5.3203000000000
+ SEA1DM_V%vs_sea1d(93)= 5.3035100000000
+ SEA1DM_V%vs_sea1d(94)= 5.2867200000000
+ SEA1DM_V%vs_sea1d(95)= 5.2699300000000
+ SEA1DM_V%vs_sea1d(96)= 5.2531400000000
+ SEA1DM_V%vs_sea1d(97)= 5.2363500000000
+ SEA1DM_V%vs_sea1d(98)= 5.2195600000000
+ SEA1DM_V%vs_sea1d(99)= 5.2027700000000
+ SEA1DM_V%vs_sea1d(100)= 5.1859800000000
+ SEA1DM_V%vs_sea1d(101)= 5.1691900000000
+ SEA1DM_V%vs_sea1d(102)= 5.1524000000000
+ SEA1DM_V%vs_sea1d(103)= 5.1356100000000
+ SEA1DM_V%vs_sea1d(104)= 5.1188200000000
+ SEA1DM_V%vs_sea1d(105)= 5.1020200000000
+ SEA1DM_V%vs_sea1d(106)= 5.0852300000000
+ SEA1DM_V%vs_sea1d(107)= 5.0684400000000
+ SEA1DM_V%vs_sea1d(108)= 5.0516500000000
+ SEA1DM_V%vs_sea1d(109)= 5.0348600000000
+ SEA1DM_V%vs_sea1d(110)= 4.7959100000000
+ SEA1DM_V%vs_sea1d(111)= 4.7761200000000
+ SEA1DM_V%vs_sea1d(112)= 4.7563200000000
+ SEA1DM_V%vs_sea1d(113)= 4.7365300000000
+ SEA1DM_V%vs_sea1d(114)= 4.7167300000000
+ SEA1DM_V%vs_sea1d(115)= 4.6969400000000
+ SEA1DM_V%vs_sea1d(116)= 4.6771400000000
+ SEA1DM_V%vs_sea1d(117)= 4.6573400000000
+ SEA1DM_V%vs_sea1d(118)= 4.6375500000000
+ SEA1DM_V%vs_sea1d(119)= 4.6177500000000
+ SEA1DM_V%vs_sea1d(120)= 4.5979600000000
+ SEA1DM_V%vs_sea1d(121)= 4.5781600000000
+ SEA1DM_V%vs_sea1d(122)= 4.5583700000000
+ SEA1DM_V%vs_sea1d(123)= 4.5385700000000
+ SEA1DM_V%vs_sea1d(124)= 4.5187700000000
+ SEA1DM_V%vs_sea1d(125)= 4.4989800000000
+ SEA1DM_V%vs_sea1d(126)= 4.4791800000000
+ SEA1DM_V%vs_sea1d(127)= 4.4593900000000
+ SEA1DM_V%vs_sea1d(128)= 4.4395900000000
+ SEA1DM_V%vs_sea1d(129)= 4.4198000000000
+ SEA1DM_V%vs_sea1d(130)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(131)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(132)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(133)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(134)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(135)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(136)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(137)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(138)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(139)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(140)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(141)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(142)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(143)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(144)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(145)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(146)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(147)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(148)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(149)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(150)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(151)= 4.4000000000000
+ SEA1DM_V%vs_sea1d(152)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(153)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(154)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(155)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(156)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(157)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(158)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(159)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(160)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(161)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(162)= 3.4500000000000
+ SEA1DM_V%vs_sea1d(163)= 3.4500000000000
+
+ SEA1DM_V%Qkappa_sea1d(1)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(2)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(3)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(4)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(5)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(6)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(7)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(8)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(9)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(10)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(11)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(12)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(13)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(14)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(15)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(16)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(17)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(18)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(19)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(20)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(21)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(22)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(23)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(24)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(25)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(26)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(27)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(28)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(29)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(30)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(31)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(32)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(33)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(34)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(35)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(36)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(37)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(38)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(39)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(40)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(41)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(42)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(43)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(44)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(45)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(46)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(47)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(48)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(49)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(50)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(51)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(52)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(53)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(54)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(55)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(56)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(57)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(58)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(59)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(60)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(61)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(62)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(63)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(64)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(65)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(66)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(67)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(68)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(69)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(70)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(71)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(72)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(73)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(74)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(75)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(76)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(77)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(78)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(79)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(80)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(81)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(82)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(83)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(84)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(85)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(86)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(87)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(88)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(89)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(90)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(91)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(92)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(93)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(94)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(95)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(96)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(97)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(98)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(99)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(100)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(101)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(102)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(103)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(104)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(105)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(106)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(107)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(108)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(109)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(110)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(111)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(112)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(113)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(114)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(115)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(116)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(117)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(118)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(119)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(120)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(121)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(122)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(123)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(124)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(125)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(126)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(127)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(128)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(129)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(130)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(131)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(132)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(133)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(134)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(135)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(136)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(137)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(138)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(139)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(140)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(141)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(142)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(143)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(144)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(145)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(146)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(147)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(148)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(149)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(150)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(151)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(152)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(153)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(154)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(155)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(156)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(157)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(158)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(159)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(160)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(161)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(162)= 99999.0000000000000
+ SEA1DM_V%Qkappa_sea1d(163)= 99999.0000000000000
+
+ SEA1DM_V%Qmu_sea1d(1)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(2)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(3)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(4)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(5)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(6)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(7)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(8)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(9)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(10)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(11)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(12)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(13)= 84.6000000000000
+ SEA1DM_V%Qmu_sea1d(14)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(15)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(16)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(17)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(18)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(19)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(20)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(21)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(22)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(23)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(24)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(25)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(26)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(27)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(28)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(29)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(30)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(31)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(32)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(33)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(34)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(35)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(36)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(37)= 0.0000000000000
+ SEA1DM_V%Qmu_sea1d(38)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(39)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(40)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(41)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(42)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(43)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(44)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(45)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(46)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(47)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(48)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(49)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(50)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(51)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(52)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(53)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(54)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(55)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(56)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(57)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(58)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(59)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(60)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(61)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(62)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(63)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(64)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(65)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(66)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(67)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(68)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(69)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(70)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(71)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(72)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(73)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(74)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(75)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(76)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(77)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(78)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(79)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(80)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(81)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(82)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(83)= 312.0000000000000
+ SEA1DM_V%Qmu_sea1d(84)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(85)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(86)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(87)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(88)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(89)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(90)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(91)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(92)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(93)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(94)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(95)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(96)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(97)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(98)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(99)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(100)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(101)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(102)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(103)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(104)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(105)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(106)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(107)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(108)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(109)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(110)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(111)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(112)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(113)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(114)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(115)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(116)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(117)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(118)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(119)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(120)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(121)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(122)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(123)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(124)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(125)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(126)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(127)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(128)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(129)= 143.0000000000000
+ SEA1DM_V%Qmu_sea1d(130)= 110.0000000000000
+ SEA1DM_V%Qmu_sea1d(131)= 80.0000000000000
+ SEA1DM_V%Qmu_sea1d(132)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(133)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(134)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(135)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(136)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(137)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(138)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(139)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(140)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(141)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(142)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(143)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(144)= 50.0000000000000
+ SEA1DM_V%Qmu_sea1d(145)= 100.0000000000000
+ SEA1DM_V%Qmu_sea1d(146)= 150.0000000000000
+ SEA1DM_V%Qmu_sea1d(147)= 150.0000000000000
+ SEA1DM_V%Qmu_sea1d(148)= 150.0000000000000
+ SEA1DM_V%Qmu_sea1d(149)= 150.0000000000000
+ SEA1DM_V%Qmu_sea1d(150)= 150.0000000000000
+ SEA1DM_V%Qmu_sea1d(151)= 150.0000000000000
+ SEA1DM_V%Qmu_sea1d(152)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(153)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(154)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(155)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(156)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(157)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(158)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(159)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(160)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(161)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(162)= 300.0000000000000
+ SEA1DM_V%Qmu_sea1d(163)= 300.0000000000000
+
+! strip the crust and replace it by mantle
+ if(USE_EXTERNAL_CRUSTAL_MODEL) then
+ do i=NR_SEA1D-12,NR_SEA1D
+ SEA1DM_V%density_sea1d(i) = SEA1DM_V%density_sea1d(NR_SEA1D-13)
+ SEA1DM_V%vp_sea1d(i) = SEA1DM_V%vp_sea1d(NR_SEA1D-13)
+ SEA1DM_V%vs_sea1d(i) = SEA1DM_V%vs_sea1d(NR_SEA1D-13)
+ SEA1DM_V%Qkappa_sea1d(i) = SEA1DM_V%Qkappa_sea1d(NR_SEA1D-13)
+ SEA1DM_V%Qmu_sea1d(i) = SEA1DM_V%Qmu_sea1d(NR_SEA1D-13)
+ enddo
+ endif
+
+ end subroutine define_model_sea1d
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/moho_stretching.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/moho_stretching.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/moho_stretching.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,301 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine moho_stretching(myrank,xelm,yelm,zelm,RMOHO,R220)
+
+ implicit none
+
+ include "constants.h"
+
+! ocean-continent function maximum spherical harmonic degree
+ integer, parameter :: NL_OCEAN_CONTINENT = 12
+
+! spherical harmonic coefficients of the ocean-continent function (km)
+ double precision A_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT),B_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT)
+
+ common /smooth_moho/ A_lm,B_lm
+
+ integer myrank
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+ double precision RMOHO,R220
+
+ integer ia
+
+ integer l,m
+ double precision r,theta,phi
+ double precision sint,cost,x(2*NL_OCEAN_CONTINENT+1),dx(2*NL_OCEAN_CONTINENT+1)
+ double precision elevation
+ double precision gamma
+
+! we loop on all the points of the element
+ do ia = 1,NGNOD
+
+! convert to r theta phi
+ call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
+ call reduce(theta,phi)
+
+ elevation = 0.0d0
+ do l = 0,NL_OCEAN_CONTINENT
+ sint = dsin(theta)
+ cost = dcos(theta)
+ call lgndr(l,cost,sint,x,dx)
+ m = 0
+ elevation = elevation + A_lm(l,m)*x(m+1)
+ do m = 1,l
+ elevation = elevation + (A_lm(l,m)*dcos(dble(m)*phi)+B_lm(l,m)*dsin(dble(m)*phi))*x(m+1)
+ enddo
+ enddo
+ elevation = -0.25d0*elevation/R_EARTH_KM
+
+ gamma = 0.0d0
+ if(r >= RMOHO/R_EARTH) then
+! stretching above the Moho
+ gamma = (1.0d0 - r) / (1.0d0 - RMOHO/R_EARTH)
+ elseif(r>= R220/R_EARTH .and. r< RMOHO/R_EARTH) then
+! stretching between R220 and RMOHO
+ gamma = (r - R220/R_EARTH) / (RMOHO/R_EARTH - R220/R_EARTH)
+ endif
+ if(gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for Moho topography')
+
+ xelm(ia) = xelm(ia)*(ONE + gamma * elevation / r)
+ yelm(ia) = yelm(ia)*(ONE + gamma * elevation / r)
+ zelm(ia) = zelm(ia)*(ONE + gamma * elevation / r)
+
+ enddo
+
+ end subroutine moho_stretching
+
+ subroutine read_smooth_moho
+
+ implicit none
+
+! ocean-continent function maximum spherical harmonic degree
+ integer, parameter :: NL_OCEAN_CONTINENT = 12
+
+! spherical harmonic coefficients of the ocean-continent function (km)
+ double precision A_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT),B_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT)
+
+ common /smooth_moho/ A_lm,B_lm
+
+! integer l,m
+!
+! ocean-continent function (km)
+! open(unit=10,file='DATA/ocean_continent_function/ocean_continent_function.txt',status='old',action='read')
+! do l=0,NL_OCEAN_CONTINENT
+! read(10,*) A_lm(l,0),(A_lm(l,m),B_lm(l,m),m=1,l)
+! enddo
+! close(10)
+
+ A_lm(0,0) = -3.8201999E-04
+ B_lm(0,0) = 0.
+ A_lm(1,0) = 13.88800
+ B_lm(1,0) = 0.
+ A_lm(1,1) = -15.24000
+ B_lm(1,1) = -9.187200
+ A_lm(2,0) = 11.21500
+ B_lm(2,0) = 0.
+ A_lm(2,1) = -6.754500
+ B_lm(2,1) = -8.516700
+ A_lm(2,2) = -8.327800
+ B_lm(2,2) = -5.029200
+ A_lm(3,0) = -3.614500
+ B_lm(3,0) = 0.
+ A_lm(3,1) = 5.394800
+ B_lm(3,1) = -0.9220800
+ A_lm(3,2) = -10.05100
+ B_lm(3,2) = 13.98100
+ A_lm(3,3) = -2.711200
+ B_lm(3,3) = -13.57100
+ A_lm(4,0) = 7.523300
+ B_lm(4,0) = 0.
+ A_lm(4,1) = 5.156100
+ B_lm(4,1) = 2.184400
+ A_lm(4,2) = -10.67300
+ B_lm(4,2) = 2.640600
+ A_lm(4,3) = -7.786300
+ B_lm(4,3) = 0.3674500
+ A_lm(4,4) = -3.076400
+ B_lm(4,4) = 16.83000
+ A_lm(5,0) = -9.681000
+ B_lm(5,0) = 0.
+ A_lm(5,1) = 0.5026800
+ B_lm(5,1) = 2.111300
+ A_lm(5,2) = -2.931000
+ B_lm(5,2) = -4.329000
+ A_lm(5,3) = -1.766800
+ B_lm(5,3) = -3.621200
+ A_lm(5,4) = 16.08200
+ B_lm(5,4) = -4.493900
+ A_lm(5,5) = -0.3705800
+ B_lm(5,5) = -5.574500
+ A_lm(6,0) = 4.407900
+ B_lm(6,0) = 0.
+ A_lm(6,1) = 0.3799000
+ B_lm(6,1) = 1.589400
+ A_lm(6,2) = -1.886400
+ B_lm(6,2) = -0.5686300
+ A_lm(6,3) = -0.9816800
+ B_lm(6,3) = -5.827800
+ A_lm(6,4) = 3.620600
+ B_lm(6,4) = -2.713100
+ A_lm(6,5) = 1.445600
+ B_lm(6,5) = 3.964100
+ A_lm(6,6) = 1.167400
+ B_lm(6,6) = 2.134100
+ A_lm(7,0) = -4.086100
+ B_lm(7,0) = 0.
+ A_lm(7,1) = 0.5462000
+ B_lm(7,1) = -4.488100
+ A_lm(7,2) = 3.116400
+ B_lm(7,2) = 1.793600
+ A_lm(7,3) = 2.594600
+ B_lm(7,3) = -2.129100
+ A_lm(7,4) = -5.445000
+ B_lm(7,4) = 0.5381500
+ A_lm(7,5) = -2.178100
+ B_lm(7,5) = 1.766700
+ A_lm(7,6) = -1.040000
+ B_lm(7,6) = -5.541000
+ A_lm(7,7) = 1.536500
+ B_lm(7,7) = 3.700600
+ A_lm(8,0) = -2.562200
+ B_lm(8,0) = 0.
+ A_lm(8,1) = 0.3736200
+ B_lm(8,1) = 1.488000
+ A_lm(8,2) = 1.347500
+ B_lm(8,2) = 0.5288200
+ A_lm(8,3) = -0.8493700
+ B_lm(8,3) = -1.626500
+ A_lm(8,4) = 0.2423400
+ B_lm(8,4) = 4.202800
+ A_lm(8,5) = 2.052200
+ B_lm(8,5) = 0.6880400
+ A_lm(8,6) = 2.838500
+ B_lm(8,6) = 2.835700
+ A_lm(8,7) = -4.981400
+ B_lm(8,7) = -1.883100
+ A_lm(8,8) = -1.102800
+ B_lm(8,8) = -1.951700
+ A_lm(9,0) = -1.202100
+ B_lm(9,0) = 0.
+ A_lm(9,1) = 1.020300
+ B_lm(9,1) = 1.371000
+ A_lm(9,2) = -0.3430100
+ B_lm(9,2) = 0.8782800
+ A_lm(9,3) = -0.4462500
+ B_lm(9,3) = -0.3046100
+ A_lm(9,4) = 0.7750700
+ B_lm(9,4) = 2.351600
+ A_lm(9,5) = -2.092600
+ B_lm(9,5) = -2.377100
+ A_lm(9,6) = 0.3126900
+ B_lm(9,6) = 4.996000
+ A_lm(9,7) = -2.284000
+ B_lm(9,7) = 1.183700
+ A_lm(9,8) = 1.445900
+ B_lm(9,8) = 1.080000
+ A_lm(9,9) = 1.146700
+ B_lm(9,9) = 1.457800
+ A_lm(10,0) = -2.516900
+ B_lm(10,0) = 0.
+ A_lm(10,1) = -0.9739500
+ B_lm(10,1) = -0.7195500
+ A_lm(10,2) = -2.846000
+ B_lm(10,2) = -1.464700
+ A_lm(10,3) = 2.720100
+ B_lm(10,3) = 0.8241400
+ A_lm(10,4) = -1.247800
+ B_lm(10,4) = 1.220300
+ A_lm(10,5) = -1.638500
+ B_lm(10,5) = -1.099500
+ A_lm(10,6) = 3.043000
+ B_lm(10,6) = -1.976400
+ A_lm(10,7) = -1.007300
+ B_lm(10,7) = -1.604900
+ A_lm(10,8) = 0.6620500
+ B_lm(10,8) = -1.135000
+ A_lm(10,9) = -3.576800
+ B_lm(10,9) = 0.5554900
+ A_lm(10,10) = 2.418700
+ B_lm(10,10) = -1.482200
+ A_lm(11,0) = 0.7158800
+ B_lm(11,0) = 0.
+ A_lm(11,1) = -3.694800
+ B_lm(11,1) = 0.8491400
+ A_lm(11,2) = 9.3208998E-02
+ B_lm(11,2) = -1.276000
+ A_lm(11,3) = 1.575600
+ B_lm(11,3) = 0.1972100
+ A_lm(11,4) = 0.8989600
+ B_lm(11,4) = -1.063000
+ A_lm(11,5) = -0.6301000
+ B_lm(11,5) = -1.329400
+ A_lm(11,6) = 1.389000
+ B_lm(11,6) = 1.184100
+ A_lm(11,7) = 0.5640700
+ B_lm(11,7) = 2.286200
+ A_lm(11,8) = 1.530300
+ B_lm(11,8) = 0.7677500
+ A_lm(11,9) = 0.8495500
+ B_lm(11,9) = 0.7247500
+ A_lm(11,10) = 2.106800
+ B_lm(11,10) = 0.6588000
+ A_lm(11,11) = 0.6067800
+ B_lm(11,11) = 0.1366800
+ A_lm(12,0) = -2.598700
+ B_lm(12,0) = 0.
+ A_lm(12,1) = -1.150500
+ B_lm(12,1) = -0.8425700
+ A_lm(12,2) = -0.1593300
+ B_lm(12,2) = -1.241400
+ A_lm(12,3) = 1.508600
+ B_lm(12,3) = 0.3385500
+ A_lm(12,4) = -1.941200
+ B_lm(12,4) = 1.120000
+ A_lm(12,5) = -0.4630500
+ B_lm(12,5) = -6.4753003E-02
+ A_lm(12,6) = 0.8967000
+ B_lm(12,6) = 4.7417998E-02
+ A_lm(12,7) = 4.5407999E-02
+ B_lm(12,7) = 0.8876400
+ A_lm(12,8) = -2.444400
+ B_lm(12,8) = 1.172500
+ A_lm(12,9) = -2.593400
+ B_lm(12,9) = 0.1703700
+ A_lm(12,10) = 0.5662700
+ B_lm(12,10) = 0.7050800
+ A_lm(12,11) = -0.1930000
+ B_lm(12,11) = -2.008100
+ A_lm(12,12) = -3.187900
+ B_lm(12,12) = -1.672000
+
+ end subroutine read_smooth_moho
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/netlib_specfun_erf.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/netlib_specfun_erf.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/netlib_specfun_erf.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -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
+! >
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/precision.h
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/precision.h (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/precision.h 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,38 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! precision.h. Generated from precision.h.in by configure.
+
+!
+! solver in single or double precision depending on the machine
+!
+! set to MPI_REAL to run in single precision
+! set to MPI_DOUBLE_PRECISION to run in double precision
+!
+! ALSO CHANGE FILE constants.h ACCORDINGLY
+!
+ integer, parameter :: CUSTOM_MPI_TYPE = MPI_REAL
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/read_compute_parameters.F90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/read_compute_parameters.F90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/read_compute_parameters.F90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,2500 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,EMULATE_ONLY)
+
+
+ implicit none
+
+ include "constants.h"
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
+ NEX_XI_read,NEX_ETA_read,NPROC_XI_read,NPROC_ETA_read
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP_KM,MOVIE_TOP,MOVIE_BOTTOM_KM,MOVIE_BOTTOM, &
+ MOVIE_EAST_DEG,MOVIE_EAST,MOVIE_WEST_DEG,MOVIE_WEST,MOVIE_NORTH_DEG,MOVIE_NORTH,MOVIE_SOUTH_DEG,MOVIE_SOUTH
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,EMULATE_ONLY
+
+ character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL
+
+! local variables
+ integer NEX_MAX
+
+ double precision RECORD_LENGTH_IN_MINUTES,ELEMENT_WIDTH
+
+ integer, external :: err_occurred
+
+! parameters to be computed based upon parameters above read from file
+ integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NGLOB
+
+ integer nblocks_xi,nblocks_eta
+
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+
+ integer :: ielem,elem_doubling_mantle,elem_doubling_middle_outer_core,elem_doubling_bottom_outer_core
+ double precision :: DEPTH_SECOND_DOUBLING_REAL,DEPTH_THIRD_DOUBLING_REAL, &
+ DEPTH_FOURTH_DOUBLING_REAL,distance,distance_min,zval
+
+! honor PREM Moho or not
+! doing so drastically reduces the stability condition and therefore the time step
+ logical :: HONOR_1D_SPHERICAL_MOHO,CASE_3D
+
+ integer :: ifirst_region, ilast_region, iter_region, iter_layer, doubling, padding, tmp_sum, tmp_sum_xi, tmp_sum_eta
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+ integer :: NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
+ nb_lay_sb, nspec_sb, nglob_vol, nglob_surf, nglob_edge
+
+ integer :: multiplication_factor
+
+! for the cut doublingbrick improvement
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer :: lastdoubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
+ normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge
+ integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+
+ integer :: tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,nglob_edge_v,to_remove
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+ call open_parameter_file
+
+ call read_value_integer(SIMULATION_TYPE, 'solver.SIMULATION_TYPE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(SAVE_FORWARD, 'solver.SAVE_FORWARD')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+ call read_value_integer(NCHUNKS, 'mesher.NCHUNKS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ if(NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) &
+ stop 'NCHUNKS must be either 1, 2, 3 or 6'
+
+ call read_value_double_precision(ANGULAR_WIDTH_XI_IN_DEGREES, 'mesher.ANGULAR_WIDTH_XI_IN_DEGREES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(ANGULAR_WIDTH_ETA_IN_DEGREES, 'mesher.ANGULAR_WIDTH_ETA_IN_DEGREES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(CENTER_LATITUDE_IN_DEGREES, 'mesher.CENTER_LATITUDE_IN_DEGREES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(CENTER_LONGITUDE_IN_DEGREES, 'mesher.CENTER_LONGITUDE_IN_DEGREES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(GAMMA_ROTATION_AZIMUTH, 'mesher.GAMMA_ROTATION_AZIMUTH')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+!! DK DK this version of the mesher for the GPU + MPI solver is limited to one chunk for now
+ if(NCHUNKS > 1) stop 'this version of the mesher for the GPU + MPI solver is limited to one chunk for now'
+
+! this MUST be 90 degrees for two chunks or more to match geometrically
+ if(NCHUNKS > 1 .and. abs(ANGULAR_WIDTH_XI_IN_DEGREES - 90.d0) > 0.00000001d0) &
+ stop 'ANGULAR_WIDTH_XI_IN_DEGREES must be 90 for more than one chunk'
+
+! this can be any value in the case of two chunks
+ if(NCHUNKS > 2 .and. abs(ANGULAR_WIDTH_ETA_IN_DEGREES - 90.d0) > 0.00000001d0) &
+ stop 'ANGULAR_WIDTH_ETA_IN_DEGREES must be 90 for more than two chunks'
+
+! include central cube or not
+! use regular cubed sphere instead of cube for large distances
+ if(NCHUNKS == 6) then
+ INCLUDE_CENTRAL_CUBE = .true.
+ INFLATE_CENTRAL_CUBE = .false.
+ else
+ INCLUDE_CENTRAL_CUBE = .false.
+ INFLATE_CENTRAL_CUBE = .true.
+ endif
+
+! number of elements at the surface along the two sides of the first chunk
+ call read_value_integer(NEX_XI_read, 'mesher.NEX_XI')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NEX_ETA_read, 'mesher.NEX_ETA')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NPROC_XI_read, 'mesher.NPROC_XI')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NPROC_ETA_read, 'mesher.NPROC_ETA')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+ if(.not. EMULATE_ONLY) then
+ NEX_XI = NEX_XI_read
+ NEX_ETA = NEX_ETA_read
+ NPROC_XI = NPROC_XI_read
+ NPROC_ETA = NPROC_ETA_read
+ else
+! this is used in UTILS/estimate_best_values_runs.f90 only, to estimate memory use
+ NEX_ETA = NEX_XI
+ NPROC_ETA = NPROC_XI
+ endif
+
+! define the velocity model
+ call read_value_string(MODEL, 'model.name')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+! use PREM as the 1D reference model by default
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM
+
+! HONOR_1D_SPHERICAL_MOHO: honor PREM Moho or not: doing so drastically reduces
+! the stability condition and therefore the time step, resulting in expensive
+! calculations. If not, honor a fictitious Moho at the depth of 40 km
+! in order to have even radial sampling from the d220 to the Earth surface.
+
+! ONE_CRUST: in order to increase stability and therefore to allow cheaper
+! simulations (larger time step), 1D models can be run with just one average crustal
+! layer instead of two.
+
+! CASE_3D : this flag allows the stretching of the elements in the crustal
+! layers in the case of 3D models. The purpose of this stretching is to squeeze more
+! GLL points per km in the upper part of the crust than in the lower part.
+ HONOR_1D_SPHERICAL_MOHO = .false.
+ ONE_CRUST = .false.
+ CASE_3D = .false.
+
+! default is no 3D model
+ THREE_D_MODEL = 0
+
+ if(MODEL == '1D_isotropic_prem') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+
+ else if(MODEL == '1D_transversely_isotropic_prem') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+
+ else if(MODEL == '1D_iasp91' .or. MODEL == '1D_1066a' .or. &
+ MODEL == '1D_ak135' .or. MODEL == '1D_jp3d' .or. &
+ MODEL == '1D_sea99') then
+ if(MODEL == '1D_iasp91') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_IASP91
+ else if(MODEL == '1D_1066a') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1066A
+ else if(MODEL == '1D_ak135') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_AK135
+ else if(MODEL == '1D_jp3d') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_JP1D
+ else if(MODEL == '1D_sea99') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
+ else
+ stop 'reference 1D Earth model unknown'
+ endif
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+
+ else if(MODEL == '1D_ref') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+
+ else if(MODEL == '1D_ref_iso') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+
+ else if(MODEL == '1D_isotropic_prem_onecrust') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ ONE_CRUST = .true.
+
+ else if(MODEL == '1D_transversely_isotropic_prem_onecrust') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ ONE_CRUST = .true.
+
+ else if(MODEL == '1D_iasp91_onecrust' .or. MODEL == '1D_1066a_onecrust' .or. MODEL == '1D_ak135_onecrust') then
+ if(MODEL == '1D_iasp91_onecrust') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_IASP91
+ else if(MODEL == '1D_1066a_onecrust') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1066A
+ else if(MODEL == '1D_ak135_onecrust') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_AK135
+ else
+ stop 'reference 1D Earth model unknown'
+ endif
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ ONE_CRUST = .true.
+
+ else if(MODEL == 'transversely_isotropic_prem_plus_3D_crust_2.0') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+
+ else if(MODEL == 's20rts') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM
+ THREE_D_MODEL = THREE_D_MODEL_S20RTS
+
+ else if(MODEL == 'sea99_jp3d1994') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
+ THREE_D_MODEL = THREE_D_MODEL_SEA99_JP3D
+
+ else if(MODEL == 'sea99') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
+ THREE_D_MODEL = THREE_D_MODEL_SEA99
+
+
+ else if(MODEL == 'jp3d1994') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_JP1D
+ THREE_D_MODEL = THREE_D_MODEL_JP3D
+
+ else if(MODEL == 's362ani') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+ THREE_D_MODEL = THREE_D_MODEL_S362ANI
+
+ else if(MODEL == 's362iso') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+ THREE_D_MODEL = THREE_D_MODEL_S362ANI
+
+ else if(MODEL == 's362wmani') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+ THREE_D_MODEL = THREE_D_MODEL_S362WMANI
+
+ else if(MODEL == 's362ani_prem') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM
+ THREE_D_MODEL = THREE_D_MODEL_S362ANI_PREM
+
+ else if(MODEL == 's29ea') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+ THREE_D_MODEL = THREE_D_MODEL_S29EA
+
+ else if(MODEL == '3D_attenuation') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .true.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+
+ else if(MODEL == '3D_anisotropic') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+
+ else
+ stop 'model not implemented, edit read_compute_parameters.f90 and recompile'
+ endif
+
+! set time step, radial distribution of elements, and attenuation period range
+! right distribution is determined based upon maximum value of NEX
+ NEX_MAX = max(NEX_XI,NEX_ETA)
+
+!----
+!---- case prem_onecrust by default
+!----
+ if (SUPPRESS_CRUSTAL_MESH) then
+ multiplication_factor=2
+ else
+ multiplication_factor=1
+ endif
+
+ ! element width = 0.5625000 degrees = 62.54715 km
+ if(NEX_MAX*multiplication_factor <= 160) then
+ DT = 0.252d0
+
+ MIN_ATTENUATION_PERIOD = 30
+ MAX_ATTENUATION_PERIOD = 1500
+
+ NER_CRUST = 1
+ NER_80_MOHO = 1
+ NER_220_80 = 2
+ NER_400_220 = 2
+ NER_600_400 = 2
+ NER_670_600 = 1
+ NER_771_670 = 1
+ NER_TOPDDOUBLEPRIME_771 = 15
+ NER_CMB_TOPDDOUBLEPRIME = 1
+ NER_OUTER_CORE = 16
+ NER_TOP_CENTRAL_CUBE_ICB = 2
+ R_CENTRAL_CUBE = 950000.d0
+
+ ! element width = 0.3515625 degrees = 39.09196 km
+ else if(NEX_MAX*multiplication_factor <= 256) then
+ DT = 0.225d0
+
+ MIN_ATTENUATION_PERIOD = 20
+ MAX_ATTENUATION_PERIOD = 1000
+
+ NER_CRUST = 1
+ NER_80_MOHO = 1
+ NER_220_80 = 2
+ NER_400_220 = 3
+ NER_600_400 = 3
+ NER_670_600 = 1
+ NER_771_670 = 1
+ NER_TOPDDOUBLEPRIME_771 = 22
+ NER_CMB_TOPDDOUBLEPRIME = 2
+ NER_OUTER_CORE = 24
+ NER_TOP_CENTRAL_CUBE_ICB = 3
+ R_CENTRAL_CUBE = 965000.d0
+
+ ! element width = 0.2812500 degrees = 31.27357 km
+ else if(NEX_MAX*multiplication_factor <= 320) then
+ DT = 0.16d0
+
+ MIN_ATTENUATION_PERIOD = 15
+ MAX_ATTENUATION_PERIOD = 750
+
+ NER_CRUST = 1
+ NER_80_MOHO = 1
+ NER_220_80 = 3
+ NER_400_220 = 4
+ NER_600_400 = 4
+ NER_670_600 = 1
+ NER_771_670 = 2
+ NER_TOPDDOUBLEPRIME_771 = 29
+ NER_CMB_TOPDDOUBLEPRIME = 2
+ NER_OUTER_CORE = 32
+ NER_TOP_CENTRAL_CUBE_ICB = 4
+ R_CENTRAL_CUBE = 940000.d0
+
+ ! element width = 0.1875000 degrees = 20.84905 km
+ else if(NEX_MAX*multiplication_factor <= 480) then
+ DT = 0.11d0
+
+ MIN_ATTENUATION_PERIOD = 10
+ MAX_ATTENUATION_PERIOD = 500
+
+ NER_CRUST = 1
+ NER_80_MOHO = 2
+ NER_220_80 = 4
+ NER_400_220 = 5
+ NER_600_400 = 6
+ NER_670_600 = 2
+ NER_771_670 = 2
+ NER_TOPDDOUBLEPRIME_771 = 44
+ NER_CMB_TOPDDOUBLEPRIME = 3
+ NER_OUTER_CORE = 48
+ NER_TOP_CENTRAL_CUBE_ICB = 5
+ R_CENTRAL_CUBE = 988000.d0
+
+ ! element width = 0.1757812 degrees = 19.54598 km
+ else if(NEX_MAX*multiplication_factor <= 512) then
+ DT = 0.1125d0
+
+ MIN_ATTENUATION_PERIOD = 9
+ MAX_ATTENUATION_PERIOD = 500
+
+ NER_CRUST = 1
+ NER_80_MOHO = 2
+ NER_220_80 = 4
+ NER_400_220 = 6
+ NER_600_400 = 6
+ NER_670_600 = 2
+ NER_771_670 = 3
+ NER_TOPDDOUBLEPRIME_771 = 47
+ NER_CMB_TOPDDOUBLEPRIME = 3
+ NER_OUTER_CORE = 51
+ NER_TOP_CENTRAL_CUBE_ICB = 5
+ R_CENTRAL_CUBE = 1010000.d0
+
+ ! element width = 0.1406250 degrees = 15.63679 km
+ else if(NEX_MAX*multiplication_factor <= 640) then
+ DT = 0.09d0
+
+ MIN_ATTENUATION_PERIOD = 8
+ MAX_ATTENUATION_PERIOD = 400
+
+ NER_CRUST = 2
+ NER_80_MOHO = 3
+ NER_220_80 = 5
+ NER_400_220 = 7
+ NER_600_400 = 8
+ NER_670_600 = 3
+ NER_771_670 = 3
+ NER_TOPDDOUBLEPRIME_771 = 59
+ NER_CMB_TOPDDOUBLEPRIME = 4
+ NER_OUTER_CORE = 64
+ NER_TOP_CENTRAL_CUBE_ICB = 6
+ R_CENTRAL_CUBE = 1020000.d0
+
+ ! element width = 0.1041667 degrees = 11.58280 km
+ else if(NEX_MAX*multiplication_factor <= 864) then
+ DT = 0.0667d0
+
+ MIN_ATTENUATION_PERIOD = 6
+ MAX_ATTENUATION_PERIOD = 300
+
+ NER_CRUST = 2
+ NER_80_MOHO = 4
+ NER_220_80 = 6
+ NER_400_220 = 10
+ NER_600_400 = 10
+ NER_670_600 = 3
+ NER_771_670 = 4
+ NER_TOPDDOUBLEPRIME_771 = 79
+ NER_CMB_TOPDDOUBLEPRIME = 5
+ NER_OUTER_CORE = 86
+ NER_TOP_CENTRAL_CUBE_ICB = 9
+ R_CENTRAL_CUBE = 990000.d0
+
+ ! element width = 7.8125000E-02 degrees = 8.687103 km
+ else if(NEX_MAX*multiplication_factor <= 1152) then
+ DT = 0.05d0
+
+ MIN_ATTENUATION_PERIOD = 4
+ MAX_ATTENUATION_PERIOD = 200
+
+ NER_CRUST = 3
+ NER_80_MOHO = 6
+ NER_220_80 = 8
+ NER_400_220 = 13
+ NER_600_400 = 13
+ NER_670_600 = 4
+ NER_771_670 = 6
+ NER_TOPDDOUBLEPRIME_771 = 106
+ NER_CMB_TOPDDOUBLEPRIME = 7
+ NER_OUTER_CORE = 116
+ NER_TOP_CENTRAL_CUBE_ICB = 12
+ R_CENTRAL_CUBE = 985000.d0
+
+ ! element width = 7.2115384E-02 degrees = 8.018865 km
+ else if(NEX_MAX*multiplication_factor <= 1248) then
+ DT = 0.0462d0
+
+ MIN_ATTENUATION_PERIOD = 4
+ MAX_ATTENUATION_PERIOD = 200
+
+ NER_CRUST = 3
+ NER_80_MOHO = 6
+ NER_220_80 = 9
+ NER_400_220 = 14
+ NER_600_400 = 14
+ NER_670_600 = 5
+ NER_771_670 = 6
+ NER_TOPDDOUBLEPRIME_771 = 114
+ NER_CMB_TOPDDOUBLEPRIME = 8
+ NER_OUTER_CORE = 124
+ NER_TOP_CENTRAL_CUBE_ICB = 13
+ R_CENTRAL_CUBE = 985000.d0
+
+ else
+
+! scale with respect to 1248 if above that limit
+ DT = 0.0462d0 * 1248.d0 / (2.d0*NEX_MAX)
+
+ MIN_ATTENUATION_PERIOD = 4
+ MAX_ATTENUATION_PERIOD = 200
+
+ NER_CRUST = nint(3 * 2.d0*NEX_MAX / 1248.d0)
+ NER_80_MOHO = nint(6 * 2.d0*NEX_MAX / 1248.d0)
+ NER_220_80 = nint(9 * 2.d0*NEX_MAX / 1248.d0)
+ NER_400_220 = nint(14 * 2.d0*NEX_MAX / 1248.d0)
+ NER_600_400 = nint(14 * 2.d0*NEX_MAX / 1248.d0)
+ NER_670_600 = nint(5 * 2.d0*NEX_MAX / 1248.d0)
+ NER_771_670 = nint(6 * 2.d0*NEX_MAX / 1248.d0)
+ NER_TOPDDOUBLEPRIME_771 = nint(114 * 2.d0*NEX_MAX / 1248.d0)
+ NER_CMB_TOPDDOUBLEPRIME = nint(8 * 2.d0*NEX_MAX / 1248.d0)
+ NER_OUTER_CORE = nint(124 * 2.d0*NEX_MAX / 1248.d0)
+ NER_TOP_CENTRAL_CUBE_ICB = nint(13 * 2.d0*NEX_MAX / 1248.d0)
+ R_CENTRAL_CUBE = 985000.d0
+
+!! removed this limit else
+!! removed this limit stop 'problem with this value of NEX_MAX'
+ endif
+
+!----
+!---- change some values in the case of regular PREM with two crustal layers or of 3D models
+!----
+
+! case of regular PREM with two crustal layers: change the time step for small meshes
+! because of a different size of elements in the radial direction in the crust
+ if (HONOR_1D_SPHERICAL_MOHO) then
+ if (.not. ONE_CRUST) then
+ ! case 1D + two crustal layers
+ if (NER_CRUST<2) NER_CRUST=2
+ if(NEX_MAX*multiplication_factor <= 160) then
+ DT = 0.20d0
+ else if(NEX_MAX*multiplication_factor <= 256) then
+ DT = 0.20d0
+ endif
+ endif
+ else
+ ! case 3D
+ if (NER_CRUST<2) NER_CRUST=2
+ if(NEX_MAX*multiplication_factor <= 160) then
+ DT = 0.15d0
+ else if(NEX_MAX*multiplication_factor <= 256) then
+ DT = 0.17d0
+ else if(NEX_MAX*multiplication_factor <= 320) then
+ DT = 0.155d0
+ endif
+ endif
+
+ if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
+ DT = DT*0.20d0
+ endif
+
+
+ if( .not. ATTENUATION_RANGE_PREDEFINED ) then
+ call auto_attenuation_periods(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
+ MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD)
+ endif
+
+ if(ANGULAR_WIDTH_XI_IN_DEGREES < 90.0d0 .or. &
+ ANGULAR_WIDTH_ETA_IN_DEGREES < 90.0d0 .or. &
+ NEX_MAX > 1248) then
+
+ call auto_ner(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
+ NER_CRUST, NER_80_MOHO, NER_220_80, NER_400_220, NER_600_400, &
+ NER_670_600, NER_771_670, NER_TOPDDOUBLEPRIME_771, &
+ NER_CMB_TOPDDOUBLEPRIME, NER_OUTER_CORE, NER_TOP_CENTRAL_CUBE_ICB, &
+ R_CENTRAL_CUBE, CASE_3D)
+
+ call auto_attenuation_periods(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
+ MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD)
+
+ call auto_time_stepping(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, DT)
+
+!! DK DK suppressed because this routine should not write anything to the screen
+! write(*,*)'##############################################################'
+! write(*,*)
+! write(*,*)' Auto Radial Meshing Code '
+! write(*,*)' Consult read_compute_parameters.f90 and auto_ner.f90 '
+! write(*,*)' This should only be invoked for chunks less than 90 degrees'
+! write(*,*)' and for chunks greater than 1248 elements wide'
+! write(*,*)
+! write(*,*)'CHUNK WIDTH: ', ANGULAR_WIDTH_XI_IN_DEGREES
+! write(*,*)'NEX: ', NEX_MAX
+! write(*,*)'NER_CRUST: ', NER_CRUST
+! write(*,*)'NER_80_MOHO: ', NER_80_MOHO
+! write(*,*)'NER_220_80: ', NER_220_80
+! write(*,*)'NER_400_220: ', NER_400_220
+! write(*,*)'NER_600_400: ', NER_600_400
+! write(*,*)'NER_670_600: ', NER_670_600
+! write(*,*)'NER_771_670: ', NER_771_670
+! write(*,*)'NER_TOPDDOUBLEPRIME_771: ', NER_TOPDDOUBLEPRIME_771
+! write(*,*)'NER_CMB_TOPDDOUBLEPRIME: ', NER_CMB_TOPDDOUBLEPRIME
+! write(*,*)'NER_OUTER_CORE: ', NER_OUTER_CORE
+! write(*,*)'NER_TOP_CENTRAL_CUBE_ICB: ', NER_TOP_CENTRAL_CUBE_ICB
+! write(*,*)'R_CENTRAL_CUBE: ', R_CENTRAL_CUBE
+! write(*,*)'multiplication factor: ', multiplication_factor
+! write(*,*)
+! write(*,*)'DT: ',DT
+! write(*,*)'MIN_ATTENUATION_PERIOD ',MIN_ATTENUATION_PERIOD
+! write(*,*)'MAX_ATTENUATION_PERIOD ',MAX_ATTENUATION_PERIOD
+! write(*,*)
+! write(*,*)'##############################################################'
+
+ if (HONOR_1D_SPHERICAL_MOHO) then
+ if (.not. ONE_CRUST) then
+ ! case 1D + two crustal layers
+ if (NER_CRUST<2) NER_CRUST=2
+ endif
+ else
+ ! case 3D
+ if (NER_CRUST<2) NER_CRUST=2
+ endif
+ endif
+
+
+! take a 5% safety margin on the maximum stable time step
+! which was obtained by trial and error
+!!!!!!!! DT = DT * (1.d0 - 0.05d0)
+
+ call read_value_logical(OCEANS, 'model.OCEANS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(ELLIPTICITY, 'model.ELLIPTICITY')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(TOPOGRAPHY, 'model.TOPOGRAPHY')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(GRAVITY, 'model.GRAVITY')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(ROTATION, 'model.ROTATION')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(ATTENUATION, 'model.ATTENUATION')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+ call read_value_logical(ABSORBING_CONDITIONS, 'solver.ABSORBING_CONDITIONS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+ if(ABSORBING_CONDITIONS .and. NCHUNKS == 6) stop 'cannot have absorbing conditions in the full Earth'
+
+ if(ABSORBING_CONDITIONS .and. NCHUNKS == 3) stop 'absorbing conditions not supported for three chunks yet'
+
+ if(ATTENUATION_3D .and. .not. ATTENUATION) stop 'need ATTENUATION to use ATTENUATION_3D'
+
+! radii in PREM or IASP91
+! and normalized density at fluid-solid interface on fluid size for coupling
+! ROCEAN: radius of the ocean (m)
+! RMIDDLE_CRUST: radius of the middle crust (m)
+! RMOHO: radius of the Moho (m)
+! R80: radius of 80 km discontinuity (m)
+! R120: radius of 120 km discontinuity (m) in IASP91
+! R220: radius of 220 km discontinuity (m)
+! R400: radius of 400 km discontinuity (m)
+! R600: radius of 600 km 2nd order discontinuity (m)
+! R670: radius of 670 km discontinuity (m)
+! R771: radius of 771 km 2nd order discontinuity (m)
+! RTOPDDOUBLEPRIME: radius of top of D" 2nd order discontinuity (m)
+! RCMB: radius of CMB (m)
+! RICB: radius of ICB (m)
+
+! by default there is no d120 discontinuity, except in IASP91, therefore set to fictitious value
+ R120 = -1.d0
+
+! value common to all models
+ RHO_OCEANS = 1020.0 / RHOAV
+
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
+
+! IASP91
+ ROCEAN = 6371000.d0
+ RMIDDLE_CRUST = 6351000.d0
+ RMOHO = 6336000.d0
+ R80 = 6291000.d0
+ R120 = 6251000.d0
+ R220 = 6161000.d0
+ R400 = 5961000.d0
+! there is no d600 discontinuity in IASP91 therefore this value is useless
+! but it needs to be there for compatibility with other subroutines
+ R600 = R_EARTH - 600000.d0
+ R670 = 5711000.d0
+ R771 = 5611000.d0
+ RTOPDDOUBLEPRIME = 3631000.d0
+ RCMB = 3482000.d0
+ RICB = 1217000.d0
+
+ RHO_TOP_OC = 9900.2379 / RHOAV
+ RHO_BOTTOM_OC = 12168.6383 / RHOAV
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
+
+! our implementation of AK135 has not been checked carefully yet
+! therefore let us doublecheck it carefully one day
+
+! values below corrected by Ying Zhou <yingz at gps.caltech.edu>
+
+! AK135 without the 300 meters of mud layer
+ ROCEAN = 6368000.d0
+ RMIDDLE_CRUST = 6361000.d0
+ RMOHO = 6353000.d0
+ R80 = 6291000.d0
+ R220 = 6161000.d0
+ R400 = 5961000.d0
+ R670 = 5711000.d0
+ RTOPDDOUBLEPRIME = 3631000.d0
+ RCMB = 3479500.d0
+ RICB = 1217500.d0
+
+! values for AK135 that are not discontinuities
+ R600 = 5771000.d0
+ R771 = 5611000.d0
+
+ RHO_TOP_OC = 9914.5000 / RHOAV
+ RHO_BOTTOM_OC = 12139.1000 / RHOAV
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
+
+! values below corrected by Ying Zhou <yingz at gps.caltech.edu>
+
+! 1066A
+ RMOHO = 6360000.d0
+ R400 = 5950000.d0
+ R600 = 5781000.d0
+ R670 = 5700000.d0
+ RCMB = 3484300.d0
+ RICB = 1229480.d0
+
+! values for 1066A that are not discontinuities
+ RTOPDDOUBLEPRIME = 3631000.d0
+ R220 = 6161000.d0
+ R771 = 5611000.d0
+! RMIDDLE_CRUST used only for high resolution FFSW1C model, with 3 elements crust simulations
+! mid_crust = 10 km
+ RMIDDLE_CRUST = 6361000.d0
+ R80 = 6291000.d0
+
+! model 1066A has no oceans, therefore we use the radius of the Earth instead
+ ROCEAN = R_EARTH
+
+ RHO_TOP_OC = 9917.4500 / RHOAV
+ RHO_BOTTOM_OC = 12160.6500 / RHOAV
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
+
+! REF
+ ROCEAN = 6368000.d0
+ RMIDDLE_CRUST = 6356000.d0
+ RMOHO = 6346600.d0
+ R80 = 6291000.d0
+ R220 = 6151000.d0
+ R400 = 5961000.d0
+ R600 = 5771000.d0
+ R670 = 5721000.d0
+ R771 = 5600000.d0
+ RTOPDDOUBLEPRIME = 3630000.d0
+ RCMB = 3479958.d0
+ RICB = 1221491.d0
+
+ RHO_TOP_OC = 9903.48 / RHOAV
+ RHO_BOTTOM_OC = 12166.35 / RHOAV
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then
+
+! values below corrected by Min Chen <mchen at gps.caltech.edu>
+
+! jp1d
+ ROCEAN = 6371000.d0
+ RMIDDLE_CRUST = 6359000.d0
+ RMOHO = 6345000.d0
+ R80 = 6291000.d0
+ R220 = 6161000.d0
+ R400 = 5949000.d0
+ R600 = 5781000.d0
+ R670 = 5711000.d0
+ R771 = 5611000.d0
+ RTOPDDOUBLEPRIME = 3631000.d0
+ RCMB = 3482000.d0
+ RICB = 1217000.d0
+ RHO_TOP_OC = 9900.2379 / RHOAV
+ RHO_BOTTOM_OC = 12168.6383 / RHOAV
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
+
+! SEA1D without the 2 km of mud layer or the 3km water layer
+ ROCEAN = 6371000.d0
+ RMIDDLE_CRUST = 6361000.d0
+ RMOHO = 6346000.d0
+ R80 = 6291000.d0
+ R220 = 6161000.d0
+ R400 = 5961000.d0
+ R670 = 5711000.d0
+ RTOPDDOUBLEPRIME = 3631000.d0
+ RCMB = 3485700.d0
+ RICB = 1217100.d0
+
+! values for SEA1D that are not discontinuities
+ R600 = 5771000.d0
+ R771 = 5611000.d0
+
+ RHO_TOP_OC = 9903.4384 / RHOAV
+ RHO_BOTTOM_OC = 12166.5885 / RHOAV
+
+ else
+
+! PREM
+ ROCEAN = 6368000.d0
+ RMIDDLE_CRUST = 6356000.d0
+ RMOHO = 6346600.d0
+ R80 = 6291000.d0
+ R220 = 6151000.d0
+ R400 = 5971000.d0
+ R600 = 5771000.d0
+ R670 = 5701000.d0
+ R771 = 5600000.d0
+ RTOPDDOUBLEPRIME = 3630000.d0
+ RCMB = 3480000.d0
+ RICB = 1221000.d0
+
+ RHO_TOP_OC = 9903.4384 / RHOAV
+ RHO_BOTTOM_OC = 12166.5885 / RHOAV
+
+ endif
+
+! honor the PREM Moho or define a fictitious Moho in order to have even radial sampling
+! from the d220 to the Earth surface
+ if(HONOR_1D_SPHERICAL_MOHO) then
+ RMOHO_FICTITIOUS_IN_MESHER = RMOHO
+ else
+ RMOHO_FICTITIOUS_IN_MESHER = (R80 + R_EARTH) / 2
+ endif
+
+ call read_value_double_precision(RECORD_LENGTH_IN_MINUTES, 'solver.RECORD_LENGTH_IN_MINUTES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+! compute total number of time steps, rounded to next multiple of 100
+ NSTEP = 100 * (int(RECORD_LENGTH_IN_MINUTES * 60.d0 / (100.d0*DT)) + 1)
+
+ call read_value_logical(MOVIE_SURFACE, 'solver.MOVIE_SURFACE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(MOVIE_VOLUME, 'solver.MOVIE_VOLUME')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(MOVIE_COARSE,'solver.MOVIE_COARSE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NTSTEP_BETWEEN_FRAMES, 'solver.NTSTEP_BETWEEN_FRAMES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(HDUR_MOVIE, 'solver.HDUR_MOVIE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+! computes a default hdur_movie that creates nice looking movies.
+! Sets HDUR_MOVIE as the minimum period the mesh can resolve
+ if(HDUR_MOVIE <= TINYVAL) &
+ HDUR_MOVIE = 1.2d0*max(240.d0/NEX_XI*18.d0*ANGULAR_WIDTH_XI_IN_DEGREES/90.d0, &
+ 240.d0/NEX_ETA*18.d0*ANGULAR_WIDTH_ETA_IN_DEGREES/90.d0)
+
+ call read_value_integer(MOVIE_VOLUME_TYPE, 'solver.MOVIE_VOLUME_TYPE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_TOP_KM, 'solver.MOVIE_TOP_KM')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_BOTTOM_KM, 'solver.MOVIE_BOTTOM_KM')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_WEST_DEG, 'solver.MOVIE_WEST_DEG')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_EAST_DEG, 'solver.MOVIE_EAST_DEG')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_NORTH_DEG, 'solver.MOVIE_NORTH_DEG')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_SOUTH_DEG, 'solver.MOVIE_SOUTH_DEG')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(MOVIE_START, 'solver.MOVIE_START')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(MOVIE_STOP, 'solver.MOVIE_STOP')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ MOVIE_TOP = (R_EARTH_KM-MOVIE_TOP_KM)/R_EARTH_KM
+ MOVIE_BOTTOM = (R_EARTH_KM-MOVIE_BOTTOM_KM)/R_EARTH_KM
+ MOVIE_EAST = MOVIE_EAST_DEG * DEGREES_TO_RADIANS
+ MOVIE_WEST = MOVIE_WEST_DEG * DEGREES_TO_RADIANS
+ MOVIE_NORTH = (90.0d0 - MOVIE_NORTH_DEG) * DEGREES_TO_RADIANS ! converting from latitude to colatitude
+ MOVIE_SOUTH = (90.0d0 - MOVIE_SOUTH_DEG) * DEGREES_TO_RADIANS
+
+ call read_value_logical(SAVE_MESH_FILES, 'mesher.SAVE_MESH_FILES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NUMBER_OF_RUNS, 'solver.NUMBER_OF_RUNS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NUMBER_OF_THIS_RUN, 'solver.NUMBER_OF_THIS_RUN')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_string(LOCAL_PATH, 'LOCAL_PATH')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NTSTEP_BETWEEN_OUTPUT_INFO, 'solver.NTSTEP_BETWEEN_OUTPUT_INFO')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NTSTEP_BETWEEN_OUTPUT_SEISMOS, 'solver.NTSTEP_BETWEEN_OUTPUT_SEISMOS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NTSTEP_BETWEEN_READ_ADJSRC, 'solver.NTSTEP_BETWEEN_READ_ADJSRC')
+ if(err_occurred() /= 0) return
+
+ call read_value_logical(OUTPUT_SEISMOS_ASCII_TEXT, 'solver.OUTPUT_SEISMOS_ASCII_TEXT')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(OUTPUT_SEISMOS_SAC_ALPHANUM, 'solver.OUTPUT_SEISMOS_SAC_ALPHANUM')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(OUTPUT_SEISMOS_SAC_BINARY, 'solver.OUTPUT_SEISMOS_SAC_BINARY')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(ROTATE_SEISMOGRAMS_RT, 'solver.ROTATE_SEISMOGRAMS_RT')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(WRITE_SEISMOGRAMS_BY_MASTER, 'solver.WRITE_SEISMOGRAMS_BY_MASTER')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(SAVE_ALL_SEISMOS_IN_ONE_FILE, 'solver.SAVE_ALL_SEISMOS_IN_ONE_FILE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(USE_BINARY_FOR_LARGE_FILE, 'solver.USE_BINARY_FOR_LARGE_FILE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+ call read_value_logical(RECEIVERS_CAN_BE_BURIED, 'solver.RECEIVERS_CAN_BE_BURIED')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(PRINT_SOURCE_TIME_FUNCTION, 'solver.PRINT_SOURCE_TIME_FUNCTION')
+
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+! close parameter file
+ call close_parameter_file
+!--- check that parameters make sense
+
+ if (OUTPUT_SEISMOS_SAC_ALPHANUM .and. (mod(NTSTEP_BETWEEN_OUTPUT_SEISMOS,5)/=0)) &
+ stop 'if OUTPUT_SEISMOS_SAC_ALPHANUM = .true. then NTSTEP_BETWEEN_OUTPUT_SEISMOS must be a multiple of 5, check the Par_file'
+
+! subsets used to save seismograms must not be larger than the whole time series,
+! otherwise we waste memory
+ if(NTSTEP_BETWEEN_OUTPUT_SEISMOS > NSTEP) then
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS = NSTEP
+ if (OUTPUT_SEISMOS_SAC_ALPHANUM .and. (mod(NTSTEP_BETWEEN_OUTPUT_SEISMOS,5)/=0)) &
+ stop 'if OUTPUT_SEISMOS_SAC_ALPHANUM = .true. then modified NTSTEP_BETWEEN_OUTPUT_SEISMOS must be a multiple of 5'
+ endif
+
+! check that reals are either 4 or 8 bytes
+ if(CUSTOM_REAL /= SIZE_REAL .and. CUSTOM_REAL /= SIZE_DOUBLE) stop 'wrong size of CUSTOM_REAL for reals'
+
+! check that the parameter file is correct
+ if(NGNOD /= 27) stop 'number of control nodes must be 27'
+ if(NGNOD == 27 .and. NGNOD2D /= 9) stop 'elements with 27 points should have NGNOD2D = 9'
+
+! for the number of standard linear solids for attenuation
+ if(N_SLS /= 3) stop 'number of SLS must be 3'
+
+! check number of slices in each direction
+ if(NCHUNKS < 1) stop 'must have at least one chunk'
+#ifdef USE_MPI
+ if(NPROC_XI < 2) stop 'NPROC_XI must be at least 2 for the MPI + GPU version'
+ if(NPROC_ETA < 2) stop 'NPROC_ETA must be at least 2 for the MPI + GPU version'
+#endif
+
+! check number of chunks
+ if(NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) &
+ stop 'only one, two, three or six chunks can be meshed'
+
+! check that the central cube can be included
+ if(INCLUDE_CENTRAL_CUBE .and. NCHUNKS /= 6) stop 'need six chunks to include central cube'
+
+! check that sphere can be cut into slices without getting negative Jacobian
+ if(NEX_XI < 48) stop 'NEX_XI must be greater than 48 to cut the sphere into slices with positive Jacobian'
+ if(NEX_ETA < 48) stop 'NEX_ETA must be greater than 48 to cut the sphere into slices with positive Jacobian'
+
+! check that mesh can be coarsened in depth three or four times
+ CUT_SUPERBRICK_XI=.false.
+ CUT_SUPERBRICK_ETA=.false.
+
+ if (SUPPRESS_CRUSTAL_MESH .and. .not. ADD_4TH_DOUBLING) then
+ if(mod(NEX_XI,8) /= 0) stop 'NEX_XI must be a multiple of 8'
+ if(mod(NEX_ETA,8) /= 0) stop 'NEX_ETA must be a multiple of 8'
+ if(mod(NEX_XI/4,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 4*NPROC_XI'
+ if(mod(NEX_ETA/4,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 4*NPROC_ETA'
+ if(mod(NEX_XI/8,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
+ if(mod(NEX_ETA/8,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
+ elseif (SUPPRESS_CRUSTAL_MESH .or. .not. ADD_4TH_DOUBLING) then
+ if(mod(NEX_XI,16) /= 0) stop 'NEX_XI must be a multiple of 16'
+ if(mod(NEX_ETA,16) /= 0) stop 'NEX_ETA must be a multiple of 16'
+ if(mod(NEX_XI/8,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 8*NPROC_XI'
+ if(mod(NEX_ETA/8,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 8*NPROC_ETA'
+ if(mod(NEX_XI/16,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
+ if(mod(NEX_ETA/16,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
+ else
+ if(mod(NEX_XI,32) /= 0) stop 'NEX_XI must be a multiple of 32'
+ if(mod(NEX_ETA,32) /= 0) stop 'NEX_ETA must be a multiple of 32'
+ if(mod(NEX_XI/16,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 16*NPROC_XI'
+ if(mod(NEX_ETA/16,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 16*NPROC_ETA'
+ if(mod(NEX_XI/32,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
+ if(mod(NEX_ETA/32,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
+ endif
+
+! check that topology is correct if more than two chunks
+ if(NCHUNKS > 2 .and. NEX_XI /= NEX_ETA) stop 'must have NEX_XI = NEX_ETA for more than two chunks'
+ if(NCHUNKS > 2 .and. NPROC_XI /= NPROC_ETA) stop 'must have NPROC_XI = NPROC_ETA for more than two chunks'
+
+! check that IASP91, AK135, 1066A, JP1D or SEA1D is isotropic
+ if((REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91 .or. &
+ REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135 .or. &
+ REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A .or. &
+ REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D .or. &
+ REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) .and. TRANSVERSE_ISOTROPY) &
+ stop 'models IASP91, AK135, 1066A, JP1D and SEA1D are currently isotropic'
+
+ ELEMENT_WIDTH = ANGULAR_WIDTH_XI_IN_DEGREES/dble(NEX_MAX) * DEGREES_TO_RADIANS
+
+!
+!--- compute additional parameters
+!
+
+! number of elements horizontally in each slice (i.e. per processor)
+! these two values MUST be equal in all cases
+ NEX_PER_PROC_XI = NEX_XI / NPROC_XI
+ NEX_PER_PROC_ETA = NEX_ETA / NPROC_ETA
+
+! total number of processors in each of the six chunks
+ NPROC = NPROC_XI * NPROC_ETA
+
+! total number of processors in the full Earth composed of the six chunks
+ NPROCTOT = NCHUNKS * NPROC
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! definition of general mesh parameters below
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! find element below top of which we should implement the second doubling in the mantle
+! locate element closest to optimal value
+ distance_min = HUGEVAL
+ do ielem = 2,NER_TOPDDOUBLEPRIME_771
+ zval = RTOPDDOUBLEPRIME + ielem * (R771 - RTOPDDOUBLEPRIME) / dble(NER_TOPDDOUBLEPRIME_771)
+ distance = abs(zval - (R_EARTH - DEPTH_SECOND_DOUBLING_OPTIMAL))
+ if(distance < distance_min) then
+ elem_doubling_mantle = ielem
+ distance_min = distance
+ DEPTH_SECOND_DOUBLING_REAL = R_EARTH - zval
+ endif
+ enddo
+
+! find element below top of which we should implement the third doubling in the middle of the outer core
+! locate element closest to optimal value
+ distance_min = HUGEVAL
+! start at element number 4 because we need at least two elements below for the fourth doubling
+! implemented at the bottom of the outer core
+ do ielem = 4,NER_OUTER_CORE
+ zval = RICB + ielem * (RCMB - RICB) / dble(NER_OUTER_CORE)
+ distance = abs(zval - (R_EARTH - DEPTH_THIRD_DOUBLING_OPTIMAL))
+ if(distance < distance_min) then
+ elem_doubling_middle_outer_core = ielem
+ distance_min = distance
+ DEPTH_THIRD_DOUBLING_REAL = R_EARTH - zval
+ endif
+ enddo
+
+ if (ADD_4TH_DOUBLING) then
+! find element below top of which we should implement the fourth doubling in the middle of the outer core
+! locate element closest to optimal value
+ distance_min = HUGEVAL
+! end two elements before the top because we need at least two elements above for the third doubling
+! implemented in the middle of the outer core
+ do ielem = 2,NER_OUTER_CORE-2
+ zval = RICB + ielem * (RCMB - RICB) / dble(NER_OUTER_CORE)
+ distance = abs(zval - (R_EARTH - DEPTH_FOURTH_DOUBLING_OPTIMAL))
+ if(distance < distance_min) then
+ elem_doubling_bottom_outer_core = ielem
+ distance_min = distance
+ DEPTH_FOURTH_DOUBLING_REAL = R_EARTH - zval
+ endif
+ enddo
+! make sure that the two doublings in the outer core are found in the right order
+ if(elem_doubling_bottom_outer_core >= elem_doubling_middle_outer_core) &
+ stop 'error in location of the two doublings in the outer core'
+ endif
+
+ ratio_sampling_array(15) = 0
+
+! define all the layers of the mesh
+ if (.not. ADD_4TH_DOUBLING) then
+
+ if (SUPPRESS_CRUSTAL_MESH) then
+
+ ONE_CRUST = .false.
+ OCEANS= .false.
+ TOPOGRAPHY = .false.
+ CRUSTAL = .false.
+
+ NUMBER_OF_MESH_LAYERS = 14
+ layer_offset = 1
+
+ ! now only one region
+ ner( 1) = NER_CRUST + NER_80_MOHO
+ ner( 2) = 0
+ ner( 3) = 0
+
+ ner( 4) = NER_220_80
+ ner( 5) = NER_400_220
+ ner( 6) = NER_600_400
+ ner( 7) = NER_670_600
+ ner( 8) = NER_771_670
+ ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner(10) = elem_doubling_mantle
+ ner(11) = NER_CMB_TOPDDOUBLEPRIME
+ ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(13) = elem_doubling_middle_outer_core
+ ner(14) = NER_TOP_CENTRAL_CUBE_ICB
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1:9) = 1
+ ratio_sampling_array(10:12) = 2
+ ratio_sampling_array(13:14) = 4
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1:3) = IFLAG_CRUST !!!!! IFLAG_80_MOHO
+ doubling_index(4) = IFLAG_220_80
+ doubling_index(5:7) = IFLAG_670_220
+ doubling_index(8:11) = IFLAG_MANTLE_NORMAL
+ doubling_index(12:13) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(14) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(10) = .true.
+ this_region_has_a_doubling(13) = .true.
+ lastdoubling_layer = 13
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = R80
+
+ r_top(2) = RMIDDLE_CRUST !!!! now fictitious
+ r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
+
+ r_top(3) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
+ r_bottom(3) = R80 !!!! now fictitious
+
+ r_top(4) = R80
+ r_bottom(4) = R220
+
+ r_top(5) = R220
+ r_bottom(5) = R400
+
+ r_top(6) = R400
+ r_bottom(6) = R600
+
+ r_top(7) = R600
+ r_bottom(7) = R670
+
+ r_top(8) = R670
+ r_bottom(8) = R771
+
+ r_top(9) = R771
+ r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(10) = RTOPDDOUBLEPRIME
+
+ r_top(11) = RTOPDDOUBLEPRIME
+ r_bottom(11) = RCMB
+
+ r_top(12) = RCMB
+ r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(13) = RICB
+
+ r_top(14) = RICB
+ r_bottom(14) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = R80 / R_EARTH
+
+ rmaxs(2) = RMIDDLE_CRUST / R_EARTH !!!! now fictitious
+ rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
+
+ rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
+ rmins(3) = R80 / R_EARTH !!!! now fictitious
+
+ rmaxs(4) = R80 / R_EARTH
+ rmins(4) = R220 / R_EARTH
+
+ rmaxs(5) = R220 / R_EARTH
+ rmins(5) = R400 / R_EARTH
+
+ rmaxs(6) = R400 / R_EARTH
+ rmins(6) = R600 / R_EARTH
+
+ rmaxs(7) = R600 / R_EARTH
+ rmins(7) = R670 / R_EARTH
+
+ rmaxs(8) = R670 / R_EARTH
+ rmins(8) = R771 / R_EARTH
+
+ rmaxs(9:10) = R771 / R_EARTH
+ rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(11) = RCMB / R_EARTH
+
+ rmaxs(12:13) = RCMB / R_EARTH
+ rmins(12:13) = RICB / R_EARTH
+
+ rmaxs(14) = RICB / R_EARTH
+ rmins(14) = R_CENTRAL_CUBE / R_EARTH
+
+ elseif (ONE_CRUST) then
+
+ NUMBER_OF_MESH_LAYERS = 13
+ layer_offset = 0
+
+ ner( 1) = NER_CRUST
+ ner( 2) = NER_80_MOHO
+ ner( 3) = NER_220_80
+ ner( 4) = NER_400_220
+ ner( 5) = NER_600_400
+ ner( 6) = NER_670_600
+ ner( 7) = NER_771_670
+ ner( 8) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner( 9) = elem_doubling_mantle
+ ner(10) = NER_CMB_TOPDDOUBLEPRIME
+ ner(11) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(12) = elem_doubling_middle_outer_core
+ ner(13) = NER_TOP_CENTRAL_CUBE_ICB
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1) = 1
+ ratio_sampling_array(2:8) = 2
+ ratio_sampling_array(9:11) = 4
+ ratio_sampling_array(12:13) = 8
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1) = IFLAG_CRUST
+ doubling_index(2) = IFLAG_80_MOHO
+ doubling_index(3) = IFLAG_220_80
+ doubling_index(4:6) = IFLAG_670_220
+ doubling_index(7:10) = IFLAG_MANTLE_NORMAL
+ doubling_index(11:12) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(13) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(2) = .true.
+ this_region_has_a_doubling(9) = .true.
+ this_region_has_a_doubling(12) = .true.
+ lastdoubling_layer = 12
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ !!!!!!!!!!! DK DK UGLY: beware, is there a bug when 3D crust crosses anisotropy in the mantle?
+ !!!!!!!!!!! DK DK UGLY: i.e. if there is no thick crust there, some elements above the Moho
+ !!!!!!!!!!! DK DK UGLY: should be anisotropic but anisotropy is currently only
+ !!!!!!!!!!! DK DK UGLY: stored between d220 and MOHO to save memory? Clarify this one day.
+ !!!!!!!!!!! DK DK UGLY: The Moho stretching and squishing that Jeroen added to V4.0
+ !!!!!!!!!!! DK DK UGLY: should partly deal with this problem.
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = RMOHO_FICTITIOUS_IN_MESHER
+
+ r_top(2) = RMOHO_FICTITIOUS_IN_MESHER
+ r_bottom(2) = R80
+
+ r_top(3) = R80
+ r_bottom(3) = R220
+
+ r_top(4) = R220
+ r_bottom(4) = R400
+
+ r_top(5) = R400
+ r_bottom(5) = R600
+
+ r_top(6) = R600
+ r_bottom(6) = R670
+
+ r_top(7) = R670
+ r_bottom(7) = R771
+
+ r_top(8) = R771
+ r_bottom(8) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(9) = RTOPDDOUBLEPRIME
+
+ r_top(10) = RTOPDDOUBLEPRIME
+ r_bottom(10) = RCMB
+
+ r_top(11) = RCMB
+ r_bottom(11) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(12) = RICB
+
+ r_top(13) = RICB
+ r_bottom(13) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(2) = R80 / R_EARTH
+
+ rmaxs(3) = R80 / R_EARTH
+ rmins(3) = R220 / R_EARTH
+
+ rmaxs(4) = R220 / R_EARTH
+ rmins(4) = R400 / R_EARTH
+
+ rmaxs(5) = R400 / R_EARTH
+ rmins(5) = R600 / R_EARTH
+
+ rmaxs(6) = R600 / R_EARTH
+ rmins(6) = R670 / R_EARTH
+
+ rmaxs(7) = R670 / R_EARTH
+ rmins(7) = R771 / R_EARTH
+
+ rmaxs(8:9) = R771 / R_EARTH
+ rmins(8:9) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(10) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(10) = RCMB / R_EARTH
+
+ rmaxs(11:12) = RCMB / R_EARTH
+ rmins(11:12) = RICB / R_EARTH
+
+ rmaxs(13) = RICB / R_EARTH
+ rmins(13) = R_CENTRAL_CUBE / R_EARTH
+
+ else
+
+ NUMBER_OF_MESH_LAYERS = 14
+ layer_offset = 1
+ if ((RMIDDLE_CRUST-RMOHO_FICTITIOUS_IN_MESHER)<(R_EARTH-RMIDDLE_CRUST)) then
+ ner( 1) = ceiling (NER_CRUST / 2.d0)
+ ner( 2) = floor (NER_CRUST / 2.d0)
+ else
+ ner( 1) = floor (NER_CRUST / 2.d0)
+ ner( 2) = ceiling (NER_CRUST / 2.d0)
+ endif
+ ner( 3) = NER_80_MOHO
+ ner( 4) = NER_220_80
+ ner( 5) = NER_400_220
+ ner( 6) = NER_600_400
+ ner( 7) = NER_670_600
+ ner( 8) = NER_771_670
+ ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner(10) = elem_doubling_mantle
+ ner(11) = NER_CMB_TOPDDOUBLEPRIME
+ ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(13) = elem_doubling_middle_outer_core
+ ner(14) = NER_TOP_CENTRAL_CUBE_ICB
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1:2) = 1
+ ratio_sampling_array(3:9) = 2
+ ratio_sampling_array(10:12) = 4
+ ratio_sampling_array(13:14) = 8
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1:2) = IFLAG_CRUST
+ doubling_index(3) = IFLAG_80_MOHO
+ doubling_index(4) = IFLAG_220_80
+ doubling_index(5:7) = IFLAG_670_220
+ doubling_index(8:11) = IFLAG_MANTLE_NORMAL
+ doubling_index(12:13) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(14) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(3) = .true.
+ this_region_has_a_doubling(10) = .true.
+ this_region_has_a_doubling(13) = .true.
+ this_region_has_a_doubling(14) = .false.
+ lastdoubling_layer = 13
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = RMIDDLE_CRUST
+
+ r_top(2) = RMIDDLE_CRUST
+ r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER
+
+ r_top(3) = RMOHO_FICTITIOUS_IN_MESHER
+ r_bottom(3) = R80
+
+ r_top(4) = R80
+ r_bottom(4) = R220
+
+ r_top(5) = R220
+ r_bottom(5) = R400
+
+ r_top(6) = R400
+ r_bottom(6) = R600
+
+ r_top(7) = R600
+ r_bottom(7) = R670
+
+ r_top(8) = R670
+ r_bottom(8) = R771
+
+ r_top(9) = R771
+ r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(10) = RTOPDDOUBLEPRIME
+
+ r_top(11) = RTOPDDOUBLEPRIME
+ r_bottom(11) = RCMB
+
+ r_top(12) = RCMB
+ r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(13) = RICB
+
+ r_top(14) = RICB
+ r_bottom(14) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = RMIDDLE_CRUST / R_EARTH
+
+ rmaxs(2) = RMIDDLE_CRUST / R_EARTH
+ rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(3) = R80 / R_EARTH
+
+ rmaxs(4) = R80 / R_EARTH
+ rmins(4) = R220 / R_EARTH
+
+ rmaxs(5) = R220 / R_EARTH
+ rmins(5) = R400 / R_EARTH
+
+ rmaxs(6) = R400 / R_EARTH
+ rmins(6) = R600 / R_EARTH
+
+ rmaxs(7) = R600 / R_EARTH
+ rmins(7) = R670 / R_EARTH
+
+ rmaxs(8) = R670 / R_EARTH
+ rmins(8) = R771 / R_EARTH
+
+ rmaxs(9:10) = R771 / R_EARTH
+ rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(11) = RCMB / R_EARTH
+
+ rmaxs(12:13) = RCMB / R_EARTH
+ rmins(12:13) = RICB / R_EARTH
+
+ rmaxs(14) = RICB / R_EARTH
+ rmins(14) = R_CENTRAL_CUBE / R_EARTH
+
+ endif
+ else
+ if (SUPPRESS_CRUSTAL_MESH) then
+
+ ONE_CRUST = .false.
+ OCEANS= .false.
+ TOPOGRAPHY = .false.
+ CRUSTAL = .false.
+
+ NUMBER_OF_MESH_LAYERS = 15
+ layer_offset = 1
+
+ ! now only one region
+ ner( 1) = NER_CRUST + NER_80_MOHO
+ ner( 2) = 0
+ ner( 3) = 0
+
+ ner( 4) = NER_220_80
+ ner( 5) = NER_400_220
+ ner( 6) = NER_600_400
+ ner( 7) = NER_670_600
+ ner( 8) = NER_771_670
+ ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner(10) = elem_doubling_mantle
+ ner(11) = NER_CMB_TOPDDOUBLEPRIME
+ ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(13) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
+ ner(14) = elem_doubling_bottom_outer_core
+ ner(15) = NER_TOP_CENTRAL_CUBE_ICB
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1:9) = 1
+ ratio_sampling_array(10:12) = 2
+ ratio_sampling_array(13) = 4
+ ratio_sampling_array(14:15) = 8
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1:3) = IFLAG_CRUST !!!!! IFLAG_80_MOHO
+ doubling_index(4) = IFLAG_220_80
+ doubling_index(5:7) = IFLAG_670_220
+ doubling_index(8:11) = IFLAG_MANTLE_NORMAL
+ doubling_index(12:14) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(15) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(10) = .true.
+ this_region_has_a_doubling(13) = .true.
+ this_region_has_a_doubling(14) = .true.
+ lastdoubling_layer = 14
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = R80
+
+ r_top(2) = RMIDDLE_CRUST !!!! now fictitious
+ r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
+
+ r_top(3) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
+ r_bottom(3) = R80 !!!! now fictitious
+
+ r_top(4) = R80
+ r_bottom(4) = R220
+
+ r_top(5) = R220
+ r_bottom(5) = R400
+
+ r_top(6) = R400
+ r_bottom(6) = R600
+
+ r_top(7) = R600
+ r_bottom(7) = R670
+
+ r_top(8) = R670
+ r_bottom(8) = R771
+
+ r_top(9) = R771
+ r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(10) = RTOPDDOUBLEPRIME
+
+ r_top(11) = RTOPDDOUBLEPRIME
+ r_bottom(11) = RCMB
+
+ r_top(12) = RCMB
+ r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+
+ r_top(14) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+ r_bottom(14) = RICB
+
+ r_top(15) = RICB
+ r_bottom(15) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = R80 / R_EARTH
+
+ rmaxs(2) = RMIDDLE_CRUST / R_EARTH !!!! now fictitious
+ rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
+
+ rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
+ rmins(3) = R80 / R_EARTH !!!! now fictitious
+
+ rmaxs(4) = R80 / R_EARTH
+ rmins(4) = R220 / R_EARTH
+
+ rmaxs(5) = R220 / R_EARTH
+ rmins(5) = R400 / R_EARTH
+
+ rmaxs(6) = R400 / R_EARTH
+ rmins(6) = R600 / R_EARTH
+
+ rmaxs(7) = R600 / R_EARTH
+ rmins(7) = R670 / R_EARTH
+
+ rmaxs(8) = R670 / R_EARTH
+ rmins(8) = R771 / R_EARTH
+
+ rmaxs(9:10) = R771 / R_EARTH
+ rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(11) = RCMB / R_EARTH
+
+ rmaxs(12:14) = RCMB / R_EARTH
+ rmins(12:14) = RICB / R_EARTH
+
+ rmaxs(15) = RICB / R_EARTH
+ rmins(15) = R_CENTRAL_CUBE / R_EARTH
+
+ elseif (ONE_CRUST) then
+
+ NUMBER_OF_MESH_LAYERS = 14
+ layer_offset = 0
+
+ ner( 1) = NER_CRUST
+ ner( 2) = NER_80_MOHO
+ ner( 3) = NER_220_80
+ ner( 4) = NER_400_220
+ ner( 5) = NER_600_400
+ ner( 6) = NER_670_600
+ ner( 7) = NER_771_670
+ ner( 8) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner( 9) = elem_doubling_mantle
+ ner(10) = NER_CMB_TOPDDOUBLEPRIME
+ ner(11) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(12) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
+ ner(13) = elem_doubling_bottom_outer_core
+ ner(14) = NER_TOP_CENTRAL_CUBE_ICB
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1) = 1
+ ratio_sampling_array(2:8) = 2
+ ratio_sampling_array(9:11) = 4
+ ratio_sampling_array(12) = 8
+ ratio_sampling_array(13:14) = 16
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1) = IFLAG_CRUST
+ doubling_index(2) = IFLAG_80_MOHO
+ doubling_index(3) = IFLAG_220_80
+ doubling_index(4:6) = IFLAG_670_220
+ doubling_index(7:10) = IFLAG_MANTLE_NORMAL
+ doubling_index(11:13) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(14) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(2) = .true.
+ this_region_has_a_doubling(9) = .true.
+ this_region_has_a_doubling(12) = .true.
+ this_region_has_a_doubling(13) = .true.
+ lastdoubling_layer = 13
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ !!!!!!!!!!! DK DK UGLY: beware, is there a bug when 3D crust crosses anisotropy in the mantle?
+ !!!!!!!!!!! DK DK UGLY: i.e. if there is no thick crust there, some elements above the Moho
+ !!!!!!!!!!! DK DK UGLY: should be anisotropic but anisotropy is currently only
+ !!!!!!!!!!! DK DK UGLY: stored between d220 and MOHO to save memory? Clarify this one day.
+ !!!!!!!!!!! DK DK UGLY: The Moho stretching and squishing that Jeroen added to V4.0
+ !!!!!!!!!!! DK DK UGLY: should partly deal with this problem.
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = RMOHO_FICTITIOUS_IN_MESHER
+
+ r_top(2) = RMOHO_FICTITIOUS_IN_MESHER
+ r_bottom(2) = R80
+
+ r_top(3) = R80
+ r_bottom(3) = R220
+
+ r_top(4) = R220
+ r_bottom(4) = R400
+
+ r_top(5) = R400
+ r_bottom(5) = R600
+
+ r_top(6) = R600
+ r_bottom(6) = R670
+
+ r_top(7) = R670
+ r_bottom(7) = R771
+
+ r_top(8) = R771
+ r_bottom(8) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(9) = RTOPDDOUBLEPRIME
+
+ r_top(10) = RTOPDDOUBLEPRIME
+ r_bottom(10) = RCMB
+
+ r_top(11) = RCMB
+ r_bottom(11) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(12) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+
+ r_top(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+ r_bottom(13) = RICB
+
+ r_top(14) = RICB
+ r_bottom(14) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(2) = R80 / R_EARTH
+
+ rmaxs(3) = R80 / R_EARTH
+ rmins(3) = R220 / R_EARTH
+
+ rmaxs(4) = R220 / R_EARTH
+ rmins(4) = R400 / R_EARTH
+
+ rmaxs(5) = R400 / R_EARTH
+ rmins(5) = R600 / R_EARTH
+
+ rmaxs(6) = R600 / R_EARTH
+ rmins(6) = R670 / R_EARTH
+
+ rmaxs(7) = R670 / R_EARTH
+ rmins(7) = R771 / R_EARTH
+
+ rmaxs(8:9) = R771 / R_EARTH
+ rmins(8:9) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(10) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(10) = RCMB / R_EARTH
+
+ rmaxs(11:13) = RCMB / R_EARTH
+ rmins(11:13) = RICB / R_EARTH
+
+ rmaxs(14) = RICB / R_EARTH
+ rmins(14) = R_CENTRAL_CUBE / R_EARTH
+
+ else
+
+ NUMBER_OF_MESH_LAYERS = 15
+ layer_offset = 1
+ if ((RMIDDLE_CRUST-RMOHO_FICTITIOUS_IN_MESHER)<(R_EARTH-RMIDDLE_CRUST)) then
+ ner( 1) = ceiling (NER_CRUST / 2.d0)
+ ner( 2) = floor (NER_CRUST / 2.d0)
+ else
+ ner( 1) = floor (NER_CRUST / 2.d0)
+ ner( 2) = ceiling (NER_CRUST / 2.d0)
+ endif
+ ner( 3) = NER_80_MOHO
+ ner( 4) = NER_220_80
+ ner( 5) = NER_400_220
+ ner( 6) = NER_600_400
+ ner( 7) = NER_670_600
+ ner( 8) = NER_771_670
+ ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
+ ner(10) = elem_doubling_mantle
+ ner(11) = NER_CMB_TOPDDOUBLEPRIME
+ ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
+ ner(13) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
+ ner(14) = elem_doubling_bottom_outer_core
+ ner(15) = NER_TOP_CENTRAL_CUBE_ICB
+
+ ! value of the doubling ratio in each radial region of the mesh
+ ratio_sampling_array(1:2) = 1
+ ratio_sampling_array(3:9) = 2
+ ratio_sampling_array(10:12) = 4
+ ratio_sampling_array(13) = 8
+ ratio_sampling_array(14:15) = 16
+
+ ! value of the doubling index flag in each radial region of the mesh
+ doubling_index(1:2) = IFLAG_CRUST
+ doubling_index(3) = IFLAG_80_MOHO
+ doubling_index(4) = IFLAG_220_80
+ doubling_index(5:7) = IFLAG_670_220
+ doubling_index(8:11) = IFLAG_MANTLE_NORMAL
+ doubling_index(12:14) = IFLAG_OUTER_CORE_NORMAL
+ doubling_index(15) = IFLAG_INNER_CORE_NORMAL
+
+ ! define the three regions in which we implement a mesh doubling at the top of that region
+ this_region_has_a_doubling(:) = .false.
+ this_region_has_a_doubling(3) = .true.
+ this_region_has_a_doubling(10) = .true.
+ this_region_has_a_doubling(13) = .true.
+ this_region_has_a_doubling(14) = .true.
+ lastdoubling_layer = 14
+
+ ! define the top and bottom radii of all the regions of the mesh in the radial direction
+ ! the first region is the crust at the surface of the Earth
+ ! the last region is in the inner core near the center of the Earth
+
+ r_top(1) = R_EARTH
+ r_bottom(1) = RMIDDLE_CRUST
+
+ r_top(2) = RMIDDLE_CRUST
+ r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER
+
+ r_top(3) = RMOHO_FICTITIOUS_IN_MESHER
+ r_bottom(3) = R80
+
+ r_top(4) = R80
+ r_bottom(4) = R220
+
+ r_top(5) = R220
+ r_bottom(5) = R400
+
+ r_top(6) = R400
+ r_bottom(6) = R600
+
+ r_top(7) = R600
+ r_bottom(7) = R670
+
+ r_top(8) = R670
+ r_bottom(8) = R771
+
+ r_top(9) = R771
+ r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+
+ r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
+ r_bottom(10) = RTOPDDOUBLEPRIME
+
+ r_top(11) = RTOPDDOUBLEPRIME
+ r_bottom(11) = RCMB
+
+ r_top(12) = RCMB
+ r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+
+ r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
+ r_bottom(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+
+ r_top(14) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
+ r_bottom(14) = RICB
+
+ r_top(15) = RICB
+ r_bottom(15) = R_CENTRAL_CUBE
+
+ ! new definition of rmins & rmaxs
+ rmaxs(1) = ONE
+ rmins(1) = RMIDDLE_CRUST / R_EARTH
+
+ rmaxs(2) = RMIDDLE_CRUST / R_EARTH
+ rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+
+ rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
+ rmins(3) = R80 / R_EARTH
+
+ rmaxs(4) = R80 / R_EARTH
+ rmins(4) = R220 / R_EARTH
+
+ rmaxs(5) = R220 / R_EARTH
+ rmins(5) = R400 / R_EARTH
+
+ rmaxs(6) = R400 / R_EARTH
+ rmins(6) = R600 / R_EARTH
+
+ rmaxs(7) = R600 / R_EARTH
+ rmins(7) = R670 / R_EARTH
+
+ rmaxs(8) = R670 / R_EARTH
+ rmins(8) = R771 / R_EARTH
+
+ rmaxs(9:10) = R771 / R_EARTH
+ rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
+
+ rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
+ rmins(11) = RCMB / R_EARTH
+
+ rmaxs(12:14) = RCMB / R_EARTH
+ rmins(12:14) = RICB / R_EARTH
+
+ rmaxs(15) = RICB / R_EARTH
+ rmins(15) = R_CENTRAL_CUBE / R_EARTH
+ endif
+ endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! calculation of number of elements (NSPEC) below
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ ratio_divide_central_cube = maxval(ratio_sampling_array)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 1D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+! theoretical number of spectral elements in radial direction
+do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
+ if(iter_region == IREGION_CRUST_MANTLE) then
+ ifirst_region = 1
+ ilast_region = 10 + layer_offset
+ else if(iter_region == IREGION_OUTER_CORE) then
+ ifirst_region = 11 + layer_offset
+ ilast_region = NUMBER_OF_MESH_LAYERS - 1
+ else if(iter_region == IREGION_INNER_CORE) then
+ ifirst_region = NUMBER_OF_MESH_LAYERS
+ ilast_region = NUMBER_OF_MESH_LAYERS
+ else
+ stop 'incorrect region code detected'
+ endif
+ NSPEC1D_RADIAL(iter_region) = sum(ner(ifirst_region:ilast_region))
+enddo
+
+! difference of radial number of element for outer core if the superbrick is cut
+ DIFF_NSPEC1D_RADIAL(:,:) = 0
+ if (CUT_SUPERBRICK_XI) then
+ if (CUT_SUPERBRICK_ETA) then
+ DIFF_NSPEC1D_RADIAL(2,1) = 1
+ DIFF_NSPEC1D_RADIAL(3,1) = 2
+ DIFF_NSPEC1D_RADIAL(4,1) = 1
+
+ DIFF_NSPEC1D_RADIAL(1,2) = 1
+ DIFF_NSPEC1D_RADIAL(2,2) = 2
+ DIFF_NSPEC1D_RADIAL(3,2) = 1
+
+ DIFF_NSPEC1D_RADIAL(1,3) = 1
+ DIFF_NSPEC1D_RADIAL(3,3) = 1
+ DIFF_NSPEC1D_RADIAL(4,3) = 2
+
+ DIFF_NSPEC1D_RADIAL(1,4) = 2
+ DIFF_NSPEC1D_RADIAL(2,4) = 1
+ DIFF_NSPEC1D_RADIAL(4,4) = 1
+ else
+ DIFF_NSPEC1D_RADIAL(2,1) = 1
+ DIFF_NSPEC1D_RADIAL(3,1) = 1
+
+ DIFF_NSPEC1D_RADIAL(1,2) = 1
+ DIFF_NSPEC1D_RADIAL(4,2) = 1
+ endif
+ else
+ if (CUT_SUPERBRICK_ETA) then
+ DIFF_NSPEC1D_RADIAL(3,1) = 1
+ DIFF_NSPEC1D_RADIAL(4,1) = 1
+
+ DIFF_NSPEC1D_RADIAL(1,2) = 1
+ DIFF_NSPEC1D_RADIAL(2,2) = 1
+ endif
+ endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 2D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! exact number of surface elements for faces along XI and ETA
+
+do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
+ if(iter_region == IREGION_CRUST_MANTLE) then
+ ifirst_region = 1
+ ilast_region = 10 + layer_offset
+ else if(iter_region == IREGION_OUTER_CORE) then
+ ifirst_region = 11 + layer_offset
+ ilast_region = NUMBER_OF_MESH_LAYERS - 1
+ else if(iter_region == IREGION_INNER_CORE) then
+ ifirst_region = NUMBER_OF_MESH_LAYERS
+ ilast_region = NUMBER_OF_MESH_LAYERS
+ else
+ stop 'incorrect region code detected'
+ endif
+ tmp_sum_xi = 0
+ tmp_sum_eta = 0
+ tmp_sum_nglob2D_xi = 0
+ tmp_sum_nglob2D_eta = 0
+ do iter_layer = ifirst_region, ilast_region
+ if (this_region_has_a_doubling(iter_layer)) then
+ if (iter_region == IREGION_OUTER_CORE .and. iter_layer == lastdoubling_layer) then
+ ! simple brick
+ divider = 1
+ nglob_surf = 6*NGLLX**2 - 7*NGLLX + 2
+ nglob_edges_h = 2*(NGLLX-1)+1 + NGLLX
+ ! minimum value to be safe
+ nglob_edge_v = NGLLX-2
+ nb_lay_sb = 2
+ nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK
+ nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK
+ else
+ ! double brick
+ divider = 2
+ if (ner(iter_layer) == 1) then
+ nglob_surf = 6*NGLLX**2 - 8*NGLLX + 3
+ nglob_edges_h = 4*(NGLLX-1)+1 + 2*(NGLLX-1)+1
+ nglob_edge_v = NGLLX-2
+ nb_lay_sb = 1
+ nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK_1L
+ nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK_1L
+ else
+ nglob_surf = 8*NGLLX**2 - 11*NGLLX + 4
+ nglob_edges_h = 4*(NGLLX-1)+1 + 2*(NGLLX-1)+1
+ nglob_edge_v = 2*(NGLLX-1)+1 -2
+ nb_lay_sb = 2
+ nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK
+ nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK
+ divider = 2
+ endif
+ endif
+ doubling = 1
+ to_remove = 1
+ else
+ if (iter_layer /= ifirst_region) then
+ to_remove = 0
+ else
+ to_remove = 1
+ endif
+ ! dummy value
+ divider = 1
+ doubling = 0
+ nb_lay_sb = 0
+ nspec2D_xi_sb = 0
+ nspec2D_eta_sb = 0
+ nglob_surf = 0
+ nglob_edges_h = 0
+ nglob_edge_v = 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
+ NSPEC2D_XI(iter_region) = tmp_sum_xi
+ NSPEC2D_ETA(iter_region) = tmp_sum_eta
+
+ NGLOB2DMAX_YMIN_YMAX(iter_region) = tmp_sum_nglob2D_xi
+ NGLOB2DMAX_XMIN_XMAX(iter_region) = tmp_sum_nglob2D_eta
+
+ if (iter_region == IREGION_INNER_CORE .and. INCLUDE_CENTRAL_CUBE) then
+ NSPEC2D_XI(iter_region) = NSPEC2D_XI(iter_region) + &
+ ((NEX_PER_PROC_XI / ratio_divide_central_cube)*(NEX_XI / ratio_divide_central_cube))
+ NSPEC2D_ETA(iter_region) = NSPEC2D_ETA(iter_region) + &
+ ((NEX_PER_PROC_ETA / ratio_divide_central_cube)*(NEX_XI / ratio_divide_central_cube))
+
+ NGLOB2DMAX_YMIN_YMAX(iter_region) = NGLOB2DMAX_YMIN_YMAX(iter_region) + &
+ (((NEX_PER_PROC_XI / ratio_divide_central_cube)*(NGLLX-1)+1)*((NEX_XI / ratio_divide_central_cube)*(NGLLX-1)+1))
+
+ NGLOB2DMAX_XMIN_XMAX(iter_region) = NGLOB2DMAX_XMIN_XMAX(iter_region) + &
+ (((NEX_PER_PROC_ETA / ratio_divide_central_cube)*(NGLLX-1)+1)*((NEX_XI / ratio_divide_central_cube)*(NGLLX-1)+1))
+ endif
+enddo
+
+! difference of number of surface elements along xi or eta for outer core if the superbrick is cut
+ DIFF_NSPEC2D_XI(:,:) = 0
+ DIFF_NSPEC2D_ETA(:,:) = 0
+ if (CUT_SUPERBRICK_XI) then
+ if (CUT_SUPERBRICK_ETA) then
+ DIFF_NSPEC2D_XI(2,1) = 2
+ DIFF_NSPEC2D_XI(1,2) = 2
+ DIFF_NSPEC2D_XI(2,3) = 2
+ DIFF_NSPEC2D_XI(1,4) = 2
+
+ DIFF_NSPEC2D_ETA(2,1) = 1
+ DIFF_NSPEC2D_ETA(2,2) = 1
+ DIFF_NSPEC2D_ETA(1,3) = 1
+ DIFF_NSPEC2D_ETA(1,4) = 1
+ else
+ DIFF_NSPEC2D_ETA(2,1) = 1
+ DIFF_NSPEC2D_ETA(1,2) = 1
+ endif
+ else
+ if (CUT_SUPERBRICK_ETA) then
+ DIFF_NSPEC2D_XI(2,1) = 2
+ DIFF_NSPEC2D_XI(1,2) = 2
+ endif
+ endif
+ DIFF_NSPEC2D_XI(:,:) = DIFF_NSPEC2D_XI(:,:) * (NEX_PER_PROC_XI / ratio_divide_central_cube)
+ DIFF_NSPEC2D_ETA(:,:) = DIFF_NSPEC2D_ETA(:,:) * (NEX_PER_PROC_ETA / ratio_divide_central_cube)
+
+! exact number of surface elements on the bottom and top boundaries
+
+! in the crust and mantle
+ NSPEC2D_TOP(IREGION_CRUST_MANTLE) = (NEX_XI/ratio_sampling_array(1))*(NEX_ETA/ratio_sampling_array(1))/NPROC
+ NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE) = (NEX_XI/ratio_sampling_array(10+layer_offset))*&
+ (NEX_ETA/ratio_sampling_array(10+layer_offset))/NPROC
+
+! in the outer core with mesh doubling
+ if (ADD_4TH_DOUBLING) then
+ NSPEC2D_TOP(IREGION_OUTER_CORE) = (NEX_XI/(ratio_divide_central_cube/4))*(NEX_ETA/(ratio_divide_central_cube/4))/NPROC
+ NSPEC2D_BOTTOM(IREGION_OUTER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
+ else
+ NSPEC2D_TOP(IREGION_OUTER_CORE) = (NEX_XI/(ratio_divide_central_cube/2))*(NEX_ETA/(ratio_divide_central_cube/2))/NPROC
+ NSPEC2D_BOTTOM(IREGION_OUTER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
+ endif
+
+! in the top of the inner core
+ NSPEC2D_TOP(IREGION_INNER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
+ NSPEC2D_BOTTOM(IREGION_INNER_CORE) = NSPEC2D_TOP(IREGION_INNER_CORE)
+
+! maximum number of surface elements on vertical boundaries of the slices
+ NSPEC2DMAX_XMIN_XMAX(:) = NSPEC2D_ETA(:)
+ NSPEC2DMAX_XMIN_XMAX(IREGION_OUTER_CORE) = NSPEC2DMAX_XMIN_XMAX(IREGION_OUTER_CORE) + maxval(DIFF_NSPEC2D_ETA(:,:))
+ NSPEC2DMAX_YMIN_YMAX(:) = NSPEC2D_XI(:)
+ NSPEC2DMAX_YMIN_YMAX(IREGION_OUTER_CORE) = NSPEC2DMAX_YMIN_YMAX(IREGION_OUTER_CORE) + maxval(DIFF_NSPEC2D_XI(:,:))
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 3D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! exact number of spectral elements in each region
+
+do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
+ if(iter_region == IREGION_CRUST_MANTLE) then
+ ifirst_region = 1
+ ilast_region = 10 + layer_offset
+ else if(iter_region == IREGION_OUTER_CORE) then
+ ifirst_region = 11 + layer_offset
+ ilast_region = NUMBER_OF_MESH_LAYERS - 1
+ else if(iter_region == IREGION_INNER_CORE) then
+ ifirst_region = NUMBER_OF_MESH_LAYERS
+ ilast_region = NUMBER_OF_MESH_LAYERS
+ else
+ stop 'incorrect region code detected'
+ endif
+ tmp_sum = 0;
+ do iter_layer = ifirst_region, ilast_region
+ if (this_region_has_a_doubling(iter_layer)) then
+ if (ner(iter_layer) == 1) then
+ nb_lay_sb = 1
+ nspec_sb = NSPEC_SUPERBRICK_1L
+ else
+ nb_lay_sb = 2
+ nspec_sb = NSPEC_DOUBLING_SUPERBRICK
+ endif
+ doubling = 1
+ else
+ doubling = 0
+ nb_lay_sb = 0
+ nspec_sb = 0
+ endif
+ tmp_sum = tmp_sum + (((NEX_XI / ratio_sampling_array(iter_layer)) * (NEX_ETA / ratio_sampling_array(iter_layer)) * &
+ (ner(iter_layer) - doubling*nb_lay_sb)) + &
+ doubling * ((NEX_XI / ratio_sampling_array(iter_layer)) * (NEX_ETA / ratio_sampling_array(iter_layer)) * &
+ (nspec_sb/4))) / NPROC
+ enddo
+ NSPEC(iter_region) = tmp_sum
+enddo
+
+ if(INCLUDE_CENTRAL_CUBE) NSPEC(IREGION_INNER_CORE) = NSPEC(IREGION_INNER_CORE) + &
+ (NEX_PER_PROC_XI / ratio_divide_central_cube) * &
+ (NEX_PER_PROC_ETA / ratio_divide_central_cube) * &
+ (NEX_XI / ratio_divide_central_cube)
+
+ if(minval(NSPEC) <= 0) stop 'negative NSPEC, there is a problem somewhere'
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! calculation of number of points (NGLOB) below
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 1D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! theoretical number of Gauss-Lobatto points in radial direction
+ NGLOB1D_RADIAL(:) = NSPEC1D_RADIAL(:)*(NGLLZ-1)+1
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 2D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! 2-D addressing and buffers for summation between slices
+! we add one to number of points because of the flag after the last point
+ NGLOB2DMAX_XMIN_XMAX(:) = NGLOB2DMAX_XMIN_XMAX(:) + 1
+ NGLOB2DMAX_YMIN_YMAX(:) = NGLOB2DMAX_YMIN_YMAX(:) + 1
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 3D case
+!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! exact number of global points in each region
+
+! initialize array
+ NGLOB(:) = 0
+
+! in the inner core (no doubling region + eventually central cube)
+ if(INCLUDE_CENTRAL_CUBE) then
+ NGLOB(IREGION_INNER_CORE) = ((NEX_PER_PROC_XI/ratio_divide_central_cube) &
+ *(NGLLX-1)+1)*((NEX_PER_PROC_ETA/ratio_divide_central_cube) &
+ *(NGLLY-1)+1)*((NER_TOP_CENTRAL_CUBE_ICB + NEX_XI / ratio_divide_central_cube)*(NGLLZ-1)+1)
+ else
+ NGLOB(IREGION_INNER_CORE) = ((NEX_PER_PROC_XI/ratio_divide_central_cube) &
+ *(NGLLX-1)+1)*((NEX_PER_PROC_ETA/ratio_divide_central_cube) &
+ *(NGLLY-1)+1)*((NER_TOP_CENTRAL_CUBE_ICB)*(NGLLZ-1)+1)
+ endif
+
+! in the crust-mantle and outercore
+ do iter_region = IREGION_CRUST_MANTLE,IREGION_OUTER_CORE
+ if(iter_region == IREGION_CRUST_MANTLE) then
+ ifirst_region = 1
+ ilast_region = 10 + layer_offset
+ else if(iter_region == IREGION_OUTER_CORE) then
+ ifirst_region = 11 + layer_offset
+ ilast_region = NUMBER_OF_MESH_LAYERS - 1
+ else
+ stop 'incorrect region code detected'
+ endif
+ tmp_sum = 0;
+ do iter_layer = ifirst_region, ilast_region
+ nglob_int_surf_eta=0
+ nglob_int_surf_xi=0
+ nglob_ext_surf = 0
+ nglob_center_edge = 0
+ nglob_corner_edge = 0
+ nglob_border_edge = 0
+ if (this_region_has_a_doubling(iter_layer)) then
+ if (iter_region == IREGION_OUTER_CORE .and. iter_layer == lastdoubling_layer .and. &
+ (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA)) then
+ doubling = 1
+ normal_doubling = 0
+ cut_doubling = 1
+ nb_lay_sb = 2
+ nglob_edge = 0
+ nglob_surf = 0
+ nglob_vol = 8*NGLLX**3 - 12*NGLLX**2 + 6*NGLLX - 1
+ nglob_int_surf_eta = 6*NGLLX**2 - 7*NGLLX + 2
+ nglob_int_surf_xi = 5*NGLLX**2 - 5*NGLLX + 1
+ nglob_ext_surf = 4*NGLLX**2-4*NGLLX+1
+ nglob_center_edge = 4*(NGLLX-1)+1
+ nglob_corner_edge = 2*(NGLLX-1)+1
+ nglob_border_edge = 3*(NGLLX-1)+1
+ else
+ if (ner(iter_layer) == 1) then
+ nb_lay_sb = 1
+ nglob_vol = 28*NGLLX**3 - 62*NGLLX**2 + 47*NGLLX - 12
+ nglob_surf = 6*NGLLX**2-8*NGLLX+3
+ nglob_edge = NGLLX
+ else
+ nb_lay_sb = 2
+ nglob_vol = 32*NGLLX**3 - 70*NGLLX**2 + 52*NGLLX - 13
+ nglob_surf = 8*NGLLX**2-11*NGLLX+4
+ nglob_edge = 2*NGLLX-1
+ endif
+ doubling = 1
+ normal_doubling = 1
+ cut_doubling = 0
+ endif
+ padding = -1
+ else
+ doubling = 0
+ normal_doubling = 0
+ cut_doubling = 0
+ padding = 0
+ nb_lay_sb = 0
+ nglob_vol = 0
+ nglob_surf = 0
+ nglob_edge = 0
+ endif
+ if (iter_layer == ilast_region) padding = padding +1
+ nblocks_xi = NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)
+ nblocks_eta = NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)
+
+ tmp_sum = tmp_sum + &
+ ((nblocks_xi)*(NGLLX-1)+1) * ((nblocks_eta)*(NGLLX-1)+1) * ((ner(iter_layer) - doubling*nb_lay_sb)*(NGLLX-1)+padding)+&
+ normal_doubling * ((((nblocks_xi*nblocks_eta)/4)*nglob_vol) - &
+ (((nblocks_eta/2-1)*nblocks_xi/2+(nblocks_xi/2-1)*nblocks_eta/2)*nglob_surf) + &
+ ((nblocks_eta/2-1)*(nblocks_xi/2-1)*nglob_edge)) + &
+ cut_doubling*(nglob_vol*(nblocks_xi*nblocks_eta) - &
+ ( nblocks_eta*(int(nblocks_xi/2)*nglob_int_surf_xi + int((nblocks_xi-1)/2)*nglob_ext_surf) + &
+ nblocks_xi*(int(nblocks_eta/2)*nglob_int_surf_eta + int((nblocks_eta-1)/2)*nglob_ext_surf)&
+ ) + &
+ ( int(nblocks_xi/2)*int(nblocks_eta/2)*nglob_center_edge + &
+ int((nblocks_xi-1)/2)*int((nblocks_eta-1)/2)*nglob_corner_edge + &
+ ((int(nblocks_eta/2)*int((nblocks_xi-1)/2))+(int((nblocks_eta-1)/2)*int(nblocks_xi/2)))*nglob_border_edge&
+ ))
+ enddo
+ NGLOB(iter_region) = tmp_sum
+ enddo
+
+!!! example :
+!!! nblocks_xi/2=5
+!!! ____________________________________
+!!! I I I I I I
+!!! I I I I I I
+!!! I I I I I I
+!!! nblocks_eta/2=3 I______+______+______+______+______I
+!!! I I I I I I
+!!! I I I I I I
+!!! I I I I I I
+!!! I______+______+______+______+______I
+!!! I I I I I I
+!!! I I I I I I
+!!! I I I I I I
+!!! I______I______I______I______I______I
+!!!
+!!! NGLOB for this doubling layer = 3*5*Volume - ((3-1)*5+(5-1)*3)*Surface + (3-1)*(5-1)*Edge
+!!!
+!!! 32*NGLLX**3 - 70*NGLLX**2 + 52*NGLLX - 13 -> nb GLL points in a superbrick (Volume)
+!!! 8*NGLLX**2-11*NGLLX+4 -> nb GLL points on a superbrick side (Surface)
+!!! 2*NGLLX-1 -> nb GLL points on a corner edge of a superbrick (Edge)
+
+!!! for the one layer superbrick :
+!!! NGLOB = 28.NGLL^3 - 62.NGLL^2 + 47.NGLL - 12 (Volume)
+!!! NGLOB = 6.NGLL^2 - 8.NGLL + 3 (Surface)
+!!! NGLOB = NGLL (Edge)
+!!!
+!!! those results were obtained by using the script UTILS/doubling_brick/count_nglob_analytical.pl
+!!! with an opendx file of the superbrick's geometry
+
+!!! for the basic doubling bricks (two layers)
+!!! NGLOB = 8.NGLL^3 - 12.NGLL^2 + 6.NGLL - 1 (VOLUME)
+!!! NGLOB = 5.NGLL^2 - 5.NGLL + 1 (SURFACE 1)
+!!! NGLOB = 6.NGLL^2 - 7.NGLL + 2 (SURFACE 2)
+
+ end subroutine read_compute_parameters
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/read_value_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/read_value_parameters.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/read_value_parameters.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,179 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! read values from parameter file, ignoring white lines and comments
+
+ subroutine read_value_integer(value_to_read, name)
+
+ implicit none
+
+ integer value_to_read
+ character(len=*) name
+ character(len=100) string_read
+
+ call unused_string(name)
+
+ call read_next_line(string_read)
+ read(string_read,*) value_to_read
+
+ end subroutine read_value_integer
+
+!--------------------
+
+ subroutine read_value_double_precision(value_to_read, name)
+
+ implicit none
+
+ double precision value_to_read
+ character(len=*) name
+ character(len=100) string_read
+
+ call unused_string(name)
+
+ call read_next_line(string_read)
+ read(string_read,*) value_to_read
+
+ end subroutine read_value_double_precision
+
+!--------------------
+
+ subroutine read_value_logical(value_to_read, name)
+
+ implicit none
+
+ logical value_to_read
+ character(len=*) name
+ character(len=100) string_read
+
+ call unused_string(name)
+
+ call read_next_line(string_read)
+ read(string_read,*) value_to_read
+
+ end subroutine read_value_logical
+
+!--------------------
+
+ subroutine read_value_string(value_to_read, name)
+
+ implicit none
+
+ character(len=*) value_to_read
+ character(len=*) name
+ character(len=100) string_read
+
+ call unused_string(name)
+
+ call read_next_line(string_read)
+ value_to_read = string_read
+
+ end subroutine read_value_string
+
+!--------------------
+
+ subroutine read_next_line(string_read)
+
+ implicit none
+
+ include "constants.h"
+
+ character(len=100) string_read
+
+ integer index_equal_sign,ios
+
+ do
+ read(unit=IIN,fmt="(a100)",iostat=ios) string_read
+ if(ios /= 0) stop 'error while reading parameter file'
+
+! suppress leading white spaces, if any
+ string_read = adjustl(string_read)
+
+! suppress trailing carriage return (ASCII code 13) if any (e.g. if input text file coming from Windows/DOS)
+ if(index(string_read,achar(13)) > 0) string_read = string_read(1:index(string_read,achar(13))-1)
+
+! exit loop when we find the first line that is not a comment or a white line
+ if(len_trim(string_read) == 0) cycle
+ if(string_read(1:1) /= '#') exit
+
+ enddo
+
+! suppress trailing white spaces, if any
+ string_read = string_read(1:len_trim(string_read))
+
+! suppress trailing comments, if any
+ if(index(string_read,'#') > 0) string_read = string_read(1:index(string_read,'#')-1)
+
+! suppress leading junk (up to the first equal sign, included)
+ index_equal_sign = index(string_read,'=')
+ if(index_equal_sign <= 1 .or. index_equal_sign == len_trim(string_read)) stop 'incorrect syntax detected in DATA/Par_file'
+ string_read = string_read(index_equal_sign + 1:len_trim(string_read))
+
+! suppress leading and trailing white spaces again, if any, after having suppressed the leading junk
+ string_read = adjustl(string_read)
+ string_read = string_read(1:len_trim(string_read))
+
+ end subroutine read_next_line
+
+!--------------------
+
+ subroutine open_parameter_file
+
+ include "constants.h"
+
+ open(unit=IIN,file='DATA/Par_file',status='old',action='read')
+
+ end subroutine open_parameter_file
+
+!--------------------
+
+ subroutine close_parameter_file
+
+ include "constants.h"
+
+ close(IIN)
+
+ end subroutine close_parameter_file
+
+!--------------------
+
+ integer function err_occurred()
+
+ err_occurred = 0
+
+ end function err_occurred
+
+!--------------------
+
+! dummy subroutine to avoid warnings about variable not used in other subroutines
+ subroutine unused_string(s)
+
+ character(len=*) s
+
+ if (len(s) == 1) continue
+
+ end subroutine unused_string
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/recompute_jacobian.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/recompute_jacobian.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/recompute_jacobian.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,267 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! recompute 3D jacobian at a given point for 27-node elements
+
+ subroutine recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision x,y,z,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+ double precision xi,eta,gamma,jacobian
+
+! coordinates of the control points of the surface element
+ double precision xelm(NGNOD),yelm(NGNOD),zelm(NGNOD)
+
+! 3D shape functions and their derivatives at receiver
+ double precision shape3D(NGNOD)
+ double precision dershape3D(NDIM,NGNOD)
+
+ double precision l1xi,l2xi,l3xi
+ double precision l1eta,l2eta,l3eta
+ double precision l1gamma,l2gamma,l3gamma
+ double precision l1pxi,l2pxi,l3pxi
+ double precision l1peta,l2peta,l3peta
+ double precision l1pgamma,l2pgamma,l3pgamma
+
+ double precision xxi,yxi,zxi
+ double precision xeta,yeta,zeta
+ double precision xgamma,ygamma,zgamma
+
+ integer ia
+
+! recompute jacobian for any given (xi,eta,gamma) point
+! not necessarily a GLL point
+
+! check that the parameter file is correct
+ if(NGNOD /= 27) stop 'elements should have 27 control nodes'
+
+ l1xi=HALF*xi*(xi-ONE)
+ l2xi=ONE-xi**2
+ l3xi=HALF*xi*(xi+ONE)
+
+ l1pxi=xi-HALF
+ l2pxi=-TWO*xi
+ l3pxi=xi+HALF
+
+ l1eta=HALF*eta*(eta-ONE)
+ l2eta=ONE-eta**2
+ l3eta=HALF*eta*(eta+ONE)
+
+ l1peta=eta-HALF
+ l2peta=-TWO*eta
+ l3peta=eta+HALF
+
+ l1gamma=HALF*gamma*(gamma-ONE)
+ l2gamma=ONE-gamma**2
+ l3gamma=HALF*gamma*(gamma+ONE)
+
+ l1pgamma=gamma-HALF
+ l2pgamma=-TWO*gamma
+ l3pgamma=gamma+HALF
+
+! corner nodes
+
+ shape3D(1)=l1xi*l1eta*l1gamma
+ shape3D(2)=l3xi*l1eta*l1gamma
+ shape3D(3)=l3xi*l3eta*l1gamma
+ shape3D(4)=l1xi*l3eta*l1gamma
+ shape3D(5)=l1xi*l1eta*l3gamma
+ shape3D(6)=l3xi*l1eta*l3gamma
+ shape3D(7)=l3xi*l3eta*l3gamma
+ shape3D(8)=l1xi*l3eta*l3gamma
+
+ dershape3D(1,1)=l1pxi*l1eta*l1gamma
+ dershape3D(1,2)=l3pxi*l1eta*l1gamma
+ dershape3D(1,3)=l3pxi*l3eta*l1gamma
+ dershape3D(1,4)=l1pxi*l3eta*l1gamma
+ dershape3D(1,5)=l1pxi*l1eta*l3gamma
+ dershape3D(1,6)=l3pxi*l1eta*l3gamma
+ dershape3D(1,7)=l3pxi*l3eta*l3gamma
+ dershape3D(1,8)=l1pxi*l3eta*l3gamma
+
+ dershape3D(2,1)=l1xi*l1peta*l1gamma
+ dershape3D(2,2)=l3xi*l1peta*l1gamma
+ dershape3D(2,3)=l3xi*l3peta*l1gamma
+ dershape3D(2,4)=l1xi*l3peta*l1gamma
+ dershape3D(2,5)=l1xi*l1peta*l3gamma
+ dershape3D(2,6)=l3xi*l1peta*l3gamma
+ dershape3D(2,7)=l3xi*l3peta*l3gamma
+ dershape3D(2,8)=l1xi*l3peta*l3gamma
+
+ dershape3D(3,1)=l1xi*l1eta*l1pgamma
+ dershape3D(3,2)=l3xi*l1eta*l1pgamma
+ dershape3D(3,3)=l3xi*l3eta*l1pgamma
+ dershape3D(3,4)=l1xi*l3eta*l1pgamma
+ dershape3D(3,5)=l1xi*l1eta*l3pgamma
+ dershape3D(3,6)=l3xi*l1eta*l3pgamma
+ dershape3D(3,7)=l3xi*l3eta*l3pgamma
+ dershape3D(3,8)=l1xi*l3eta*l3pgamma
+
+! midside nodes
+
+ shape3D(9)=l2xi*l1eta*l1gamma
+ shape3D(10)=l3xi*l2eta*l1gamma
+ shape3D(11)=l2xi*l3eta*l1gamma
+ shape3D(12)=l1xi*l2eta*l1gamma
+ shape3D(13)=l1xi*l1eta*l2gamma
+ shape3D(14)=l3xi*l1eta*l2gamma
+ shape3D(15)=l3xi*l3eta*l2gamma
+ shape3D(16)=l1xi*l3eta*l2gamma
+ shape3D(17)=l2xi*l1eta*l3gamma
+ shape3D(18)=l3xi*l2eta*l3gamma
+ shape3D(19)=l2xi*l3eta*l3gamma
+ shape3D(20)=l1xi*l2eta*l3gamma
+
+ dershape3D(1,9)=l2pxi*l1eta*l1gamma
+ dershape3D(1,10)=l3pxi*l2eta*l1gamma
+ dershape3D(1,11)=l2pxi*l3eta*l1gamma
+ dershape3D(1,12)=l1pxi*l2eta*l1gamma
+ dershape3D(1,13)=l1pxi*l1eta*l2gamma
+ dershape3D(1,14)=l3pxi*l1eta*l2gamma
+ dershape3D(1,15)=l3pxi*l3eta*l2gamma
+ dershape3D(1,16)=l1pxi*l3eta*l2gamma
+ dershape3D(1,17)=l2pxi*l1eta*l3gamma
+ dershape3D(1,18)=l3pxi*l2eta*l3gamma
+ dershape3D(1,19)=l2pxi*l3eta*l3gamma
+ dershape3D(1,20)=l1pxi*l2eta*l3gamma
+
+ dershape3D(2,9)=l2xi*l1peta*l1gamma
+ dershape3D(2,10)=l3xi*l2peta*l1gamma
+ dershape3D(2,11)=l2xi*l3peta*l1gamma
+ dershape3D(2,12)=l1xi*l2peta*l1gamma
+ dershape3D(2,13)=l1xi*l1peta*l2gamma
+ dershape3D(2,14)=l3xi*l1peta*l2gamma
+ dershape3D(2,15)=l3xi*l3peta*l2gamma
+ dershape3D(2,16)=l1xi*l3peta*l2gamma
+ dershape3D(2,17)=l2xi*l1peta*l3gamma
+ dershape3D(2,18)=l3xi*l2peta*l3gamma
+ dershape3D(2,19)=l2xi*l3peta*l3gamma
+ dershape3D(2,20)=l1xi*l2peta*l3gamma
+
+ dershape3D(3,9)=l2xi*l1eta*l1pgamma
+ dershape3D(3,10)=l3xi*l2eta*l1pgamma
+ dershape3D(3,11)=l2xi*l3eta*l1pgamma
+ dershape3D(3,12)=l1xi*l2eta*l1pgamma
+ dershape3D(3,13)=l1xi*l1eta*l2pgamma
+ dershape3D(3,14)=l3xi*l1eta*l2pgamma
+ dershape3D(3,15)=l3xi*l3eta*l2pgamma
+ dershape3D(3,16)=l1xi*l3eta*l2pgamma
+ dershape3D(3,17)=l2xi*l1eta*l3pgamma
+ dershape3D(3,18)=l3xi*l2eta*l3pgamma
+ dershape3D(3,19)=l2xi*l3eta*l3pgamma
+ dershape3D(3,20)=l1xi*l2eta*l3pgamma
+
+! side center nodes
+
+ shape3D(21)=l2xi*l2eta*l1gamma
+ shape3D(22)=l2xi*l1eta*l2gamma
+ shape3D(23)=l3xi*l2eta*l2gamma
+ shape3D(24)=l2xi*l3eta*l2gamma
+ shape3D(25)=l1xi*l2eta*l2gamma
+ shape3D(26)=l2xi*l2eta*l3gamma
+
+ dershape3D(1,21)=l2pxi*l2eta*l1gamma
+ dershape3D(1,22)=l2pxi*l1eta*l2gamma
+ dershape3D(1,23)=l3pxi*l2eta*l2gamma
+ dershape3D(1,24)=l2pxi*l3eta*l2gamma
+ dershape3D(1,25)=l1pxi*l2eta*l2gamma
+ dershape3D(1,26)=l2pxi*l2eta*l3gamma
+
+ dershape3D(2,21)=l2xi*l2peta*l1gamma
+ dershape3D(2,22)=l2xi*l1peta*l2gamma
+ dershape3D(2,23)=l3xi*l2peta*l2gamma
+ dershape3D(2,24)=l2xi*l3peta*l2gamma
+ dershape3D(2,25)=l1xi*l2peta*l2gamma
+ dershape3D(2,26)=l2xi*l2peta*l3gamma
+
+ dershape3D(3,21)=l2xi*l2eta*l1pgamma
+ dershape3D(3,22)=l2xi*l1eta*l2pgamma
+ dershape3D(3,23)=l3xi*l2eta*l2pgamma
+ dershape3D(3,24)=l2xi*l3eta*l2pgamma
+ dershape3D(3,25)=l1xi*l2eta*l2pgamma
+ dershape3D(3,26)=l2xi*l2eta*l3pgamma
+
+! center node
+
+ shape3D(27)=l2xi*l2eta*l2gamma
+
+ dershape3D(1,27)=l2pxi*l2eta*l2gamma
+ dershape3D(2,27)=l2xi*l2peta*l2gamma
+ dershape3D(3,27)=l2xi*l2eta*l2pgamma
+
+! compute coordinates and jacobian matrix
+ x=ZERO
+ y=ZERO
+ z=ZERO
+ xxi=ZERO
+ xeta=ZERO
+ xgamma=ZERO
+ yxi=ZERO
+ yeta=ZERO
+ ygamma=ZERO
+ zxi=ZERO
+ zeta=ZERO
+ zgamma=ZERO
+
+ do ia=1,NGNOD
+ x=x+shape3D(ia)*xelm(ia)
+ y=y+shape3D(ia)*yelm(ia)
+ z=z+shape3D(ia)*zelm(ia)
+
+ xxi=xxi+dershape3D(1,ia)*xelm(ia)
+ xeta=xeta+dershape3D(2,ia)*xelm(ia)
+ xgamma=xgamma+dershape3D(3,ia)*xelm(ia)
+ yxi=yxi+dershape3D(1,ia)*yelm(ia)
+ yeta=yeta+dershape3D(2,ia)*yelm(ia)
+ ygamma=ygamma+dershape3D(3,ia)*yelm(ia)
+ zxi=zxi+dershape3D(1,ia)*zelm(ia)
+ zeta=zeta+dershape3D(2,ia)*zelm(ia)
+ zgamma=zgamma+dershape3D(3,ia)*zelm(ia)
+ enddo
+
+ jacobian = xxi*(yeta*zgamma-ygamma*zeta) - xeta*(yxi*zgamma-ygamma*zxi) + &
+ xgamma*(yxi*zeta-yeta*zxi)
+
+ if(jacobian <= ZERO) stop '3D Jacobian undefined'
+
+! invert the relation (Fletcher p. 50 vol. 2)
+ xix=(yeta*zgamma-ygamma*zeta)/jacobian
+ xiy=(xgamma*zeta-xeta*zgamma)/jacobian
+ xiz=(xeta*ygamma-xgamma*yeta)/jacobian
+ etax=(ygamma*zxi-yxi*zgamma)/jacobian
+ etay=(xxi*zgamma-xgamma*zxi)/jacobian
+ etaz=(xgamma*yxi-xxi*ygamma)/jacobian
+ gammax=(yxi*zeta-yeta*zxi)/jacobian
+ gammay=(xeta*zxi-xxi*zeta)/jacobian
+ gammaz=(xxi*yeta-xeta*yxi)/jacobian
+
+ end subroutine recompute_jacobian
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/reduce.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/reduce.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/reduce.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,84 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine reduce(theta,phi)
+
+! bring theta between 0 and PI, and phi between 0 and 2*PI
+
+ implicit none
+
+ include "constants.h"
+
+ double precision theta,phi
+
+ integer i
+ double precision th,ph
+
+ th=theta
+ ph=phi
+ i=abs(int(ph/TWO_PI))
+ if(ph<ZERO) then
+ ph=ph+(i+1)*TWO_PI
+ else
+ if(ph>TWO_PI) ph=ph-i*TWO_PI
+ endif
+ phi=ph
+ if(th<ZERO .or. th>PI) then
+ i=int(th/PI)
+ if(th>ZERO) then
+ if(mod(i,2) /= 0) then
+ th=(i+1)*PI-th
+ if(ph<PI) then
+ ph=ph+PI
+ else
+ ph=ph-PI
+ endif
+ else
+ th=th-i*PI
+ endif
+ else
+ if(mod(i,2) == 0) then
+ th=-th+i*PI
+ if(ph<PI) then
+ ph=ph+PI
+ else
+ ph=ph-PI
+ endif
+ else
+ th=th-i*PI
+ endif
+ endif
+ theta=th
+ phi=ph
+ endif
+
+ if(theta<ZERO .or. theta>PI) stop 'theta out of range in reduce'
+
+ if(phi<ZERO .or. phi>TWO_PI) stop 'phi out of range in reduce'
+
+ end subroutine reduce
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/rthetaphi_xyz.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/rthetaphi_xyz.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/rthetaphi_xyz.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,119 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine xyz_2_rthetaphi(x,y,z,r,theta,phi)
+
+! convert x y z to r theta phi, single precision call
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL) x,y,z,r,theta,phi
+ double precision xmesh,ymesh,zmesh
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+
+ xmesh = dble(x)
+ ymesh = dble(y)
+ zmesh = dble(z)
+
+ if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE
+ if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE
+ theta = sngl(datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh))
+ if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE
+ if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE
+ phi = sngl(datan2(ymesh,xmesh))
+
+ r = sngl(dsqrt(xmesh**2 + ymesh**2 + zmesh**2))
+
+ else
+
+ xmesh = x
+ ymesh = y
+ zmesh = z
+
+ if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE
+ if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE
+ theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh)
+ if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE
+ if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE
+ phi = datan2(ymesh,xmesh)
+
+ r = dsqrt(xmesh**2 + ymesh**2 + zmesh**2)
+
+ endif
+
+ end subroutine xyz_2_rthetaphi
+
+!-------------------------------------------------------------
+
+ subroutine xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
+
+! convert x y z to r theta phi, double precision call
+
+ implicit none
+
+ include "constants.h"
+
+ double precision x,y,z,r,theta,phi
+ double precision xmesh,ymesh,zmesh
+
+ xmesh = x
+ ymesh = y
+ zmesh = z
+
+ if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE
+ if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE
+ theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh)
+ if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE
+ if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE
+ phi = datan2(ymesh,xmesh)
+
+ r = dsqrt(xmesh**2 + ymesh**2 + zmesh**2)
+
+ end subroutine xyz_2_rthetaphi_dble
+
+!-------------------------------------------------------------
+
+ subroutine rthetaphi_2_xyz(x,y,z,r,theta,phi)
+
+! convert r theta phi to x y z
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL) x,y,z,r,theta,phi
+
+ x = r * sin(theta) * cos(phi)
+ y = r * sin(theta) * sin(phi)
+ z = r * cos(theta)
+
+ end subroutine rthetaphi_2_xyz
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/s362ani.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/s362ani.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/s362ani.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,1784 @@
+
+ subroutine evradker(depth,string,nker,vercof,dvercof,ierror)
+
+ implicit none
+
+ integer :: nker,ierror
+
+ real(kind=4) :: chebyshev(100)
+ real(kind=4) :: chebyshev2(100)
+ real(kind=4) :: vercof(nker)
+ real(kind=4) :: dvercof(nker)
+ real(kind=4) :: splpts(100)
+
+ character(len=80) string
+
+ logical upper,upper_650
+ logical lower,lower_650
+
+ real(kind=4), parameter :: r0=6371.
+ real(kind=4), parameter :: rmoho=6371.0-24.4
+ real(kind=4), parameter :: r670=6371.-670.
+ real(kind=4), parameter :: r650=6371.-650.
+ real(kind=4), parameter :: rcmb=3480.0
+
+ integer :: i,nspl,nskip,nlower,nupper,iker,lstr
+
+ real(kind=4) :: u,u2,ddep,radius2,radius,depth
+
+ ierror=0
+ lstr=len_trim(string)
+
+ radius=r0-depth
+ ddep=0.1
+ radius2=r0-depth+ddep
+ upper=.false.
+ lower=.false.
+ if(radius > rcmb.and.radius < r670) then
+ lower=.true.
+ else if(radius >= r670.and.radius < rmoho) then
+ upper=.true.
+ endif
+ upper_650=.false.
+ lower_650=.false.
+ if(radius > rcmb.and.radius < r650) then
+ lower_650=.true.
+ else if(radius >= r650.and.radius < rmoho) then
+ upper_650=.true.
+ endif
+ do iker=1,nker
+ vercof(iker)=0.
+ dvercof(iker)=0.
+ enddo
+
+ if(string(1:16) == 'WDC+SPC_U4L8CHEB') then
+ nupper=5
+ nlower=9
+ nskip=2
+ if(upper) then
+ u=(radius+radius-rmoho-r670)/(rmoho-r670)
+ u2=(radius2+radius2-rmoho-r670)/(rmoho-r670)
+! write(6,"('upper mantle:',2f10.3)") u,u2
+ call chebyfun(u,13,chebyshev)
+ do i=1+nskip,nskip+nupper
+ vercof(i)=chebyshev(i-nskip)
+ enddo
+ call chebyfun(u2,13,chebyshev2)
+ do i=1+nskip,nskip+nupper
+ dvercof(i)=(chebyshev2(i-nskip)-chebyshev(i-nskip))/ddep
+ enddo
+ else if(lower) then
+ u=(radius+radius-r670-rcmb)/(r670-rcmb)
+ u2=(radius2+radius2-r670-rcmb)/(r670-rcmb)
+! write(6,"('lower mantle:',2f10.3)") u,u2
+ call chebyfun(u,13,chebyshev)
+ do i=1+nskip+nupper,nskip+nupper+nlower
+ vercof(i)=chebyshev(i-nskip-nupper)
+ enddo
+ call chebyfun(u2,13,chebyshev2)
+ do i=1+nskip+nupper,nskip+nupper+nlower
+ dvercof(i)=(chebyshev2(i-nskip-nupper)- &
+ chebyshev(i-nskip-nupper))/ddep
+ enddo
+ endif
+ else if(string(1:13) == 'WDC+SHSVWM20A') then
+ nspl=20
+ splpts(1)=0.
+ splpts(2)=50.
+ splpts(3)=100.
+ splpts(4)=150.
+ splpts(5)=200.
+ splpts(6)=250.
+ splpts(7)=300.
+ splpts(8)=400.
+ splpts(9)=500.
+ splpts(10)=600.
+ splpts(11)=700.
+ splpts(12)=850.
+ splpts(13)=1050.
+ splpts(14)=1300.
+ splpts(15)=1600.
+ splpts(16)=1900.
+ splpts(17)=2200.
+ splpts(18)=2500.
+ splpts(19)=2700.
+ splpts(20)=2891.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=22,27
+ vercof(i)=vercof(i-20)
+ dvercof(i)=dvercof(i-20)
+ enddo
+ vercof(1)=1.
+ else if(string(1:16) == 'WDC+XBS_362_U6L8') then
+ if(upper) then
+ nspl=6
+ splpts(1)=24.4
+ splpts(2)=100.
+ splpts(3)=225.
+ splpts(4)=350.
+ splpts(5)=500.
+ splpts(6)=670.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ else if(lower) then
+ nspl=8
+ splpts(1)=670.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
+ endif
+ vercof(1)=1.
+! vercof(16)=1.
+! vercof(17)=1.
+! else if(string(1:21) == 'WDC+ANI_362_U6L8_TOPO') then
+! if(upper) then
+! nspl=6
+! splpts(1)=24.4
+! splpts(2)=100.
+! splpts(3)=225.
+! splpts(4)=350.
+! splpts(5)=500.
+! splpts(6)=670.
+! call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+! do i=16,21
+! vercof(i)=vercof(i-14)
+! dvercof(i)=dvercof(i-14)
+! enddo
+! else if(lower) then
+! nspl=8
+! splpts(1)=670.
+! splpts(2)=820.
+! splpts(3)=1320.
+! splpts(4)=1820.
+! splpts(5)=2320.
+! splpts(6)=2550.
+! splpts(7)=2791.
+! splpts(8)=2891.
+! call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
+! endif
+! vercof(1)=1.
+! vercof(22)=1.
+! vercof(23)=1.
+! vercof(24)=1.
+! vercof(25)=1.
+ else if( &
+ (string(1:lstr) == 'WDC+ANI_362_U6L8'.and.lstr == 16) &
+ .or. &
+ (string(1:lstr) == 'WDC+ANI_362_U6L8_TOPO'.and.lstr == 21) &
+ ) then
+ if(upper) then
+ nspl=6
+ splpts(1)=24.4
+ splpts(2)=100.
+ splpts(3)=225.
+ splpts(4)=350.
+ splpts(5)=500.
+ splpts(6)=670.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=16,21
+ vercof(i)=vercof(i-14)
+ dvercof(i)=dvercof(i-14)
+ enddo
+ else if(lower) then
+ nspl=8
+ splpts(1)=670.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
+ endif
+ vercof(1)=1.
+ vercof(22)=1.
+ vercof(23)=1.
+ else if(string(1:lstr) == 'WDC+WM_362_U6L8'.and.lstr == 15) then
+ if(upper) then
+ nspl=6
+ splpts(1)=24.4
+ splpts(2)=100.
+ splpts(3)=225.
+ splpts(4)=350.
+ splpts(5)=500.
+ splpts(6)=670.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=16,21
+ vercof(i)=vercof(i-14)
+ dvercof(i)=dvercof(i-14)
+ enddo
+ else if(lower) then
+ nspl=8
+ splpts(1)=670.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
+ do i=22,29
+ vercof(i)=vercof(i-14)
+ dvercof(i)=dvercof(i-14)
+ enddo
+ endif
+ vercof(1)=1.
+ vercof(30)=1.
+ vercof(31)=1.
+ vercof(32)=1.
+ else if( &
+ (string(1:lstr) == 'WDC+ANI_362_U6L8_650'.and.lstr == 20) &
+ .or. &
+ (string(1:lstr) == 'WDC+ANI_362_U6L8_TOPO_650'.and.lstr == 25) &
+ ) then
+ if(upper_650) then
+ nspl=6
+ splpts(1)=24.4
+ splpts(2)=100.
+ splpts(3)=225.
+ splpts(4)=350.
+ splpts(5)=500.
+ splpts(6)=650.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=16,21
+ vercof(i)=vercof(i-14)
+ dvercof(i)=dvercof(i-14)
+ enddo
+ else if(lower_650) then
+ nspl=8
+ splpts(1)=650.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
+ endif
+ vercof(1)=1.
+ vercof(22)=1.
+ vercof(23)=1.
+ else if(string(1:lstr) == 'WDC+WM_362_U6L8_650' &
+ .and.lstr == 19) then
+ if(upper_650) then
+ nspl=6
+ splpts(1)=24.4
+ splpts(2)=100.
+ splpts(3)=225.
+ splpts(4)=350.
+ splpts(5)=500.
+ splpts(6)=650.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=16,21
+ vercof(i)=vercof(i-14)
+ dvercof(i)=dvercof(i-14)
+ enddo
+ else if(lower_650) then
+ nspl=8
+ splpts(1)=650.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(8),dvercof(8))
+ do i=22,29
+ vercof(i)=vercof(i-14)
+ dvercof(i)=dvercof(i-14)
+ enddo
+ endif
+ vercof(1)=1.
+ vercof(30)=1.
+ vercof(31)=1.
+ vercof(32)=1.
+ else if(string(1:lstr) == 'WDC+U8L8_650'.and.lstr == 12) then
+ if(upper_650) then
+ nspl=8
+ splpts(1)=24.4
+ splpts(2)=75.
+ splpts(3)=150.
+ splpts(4)=225.
+ splpts(5)=300.
+ splpts(6)=410.
+ splpts(7)=530.
+ splpts(8)=650.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=18,25
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ else if(lower_650) then
+ nspl=8
+ splpts(1)=650.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(10),dvercof(10))
+ do i=26,33
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ endif
+ vercof(1)=1.
+ vercof(34)=1.
+ vercof(35)=1.
+ vercof(36)=1.
+ else if(string(1:lstr) == 'WDC+U8L8_670'.and.lstr == 12) then
+ if(upper) then
+ nspl=8
+ splpts(1)=24.4
+ splpts(2)=75.
+ splpts(3)=150.
+ splpts(4)=225.
+ splpts(5)=300.
+ splpts(6)=410.
+ splpts(7)=530.
+ splpts(8)=670.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=18,25
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ else if(lower) then
+ nspl=8
+ splpts(1)=670.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(10),dvercof(10))
+ do i=26,33
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ endif
+ vercof(1)=1.
+ vercof(34)=1.
+ vercof(35)=1.
+ vercof(36)=1.
+ else if( &
+ (string(1:lstr) == 'WDC+U8L8_I1D_650'.and.lstr == 16) &
+ .or. &
+ (string(1:lstr) == 'WDC+U8L8_I3D_650'.and.lstr == 16) &
+ ) then
+ if(upper_650) then
+ nspl=8
+ splpts(1)=24.4
+ splpts(2)=75.
+ splpts(3)=150.
+ splpts(4)=225.
+ splpts(5)=300.
+ splpts(6)=410.
+ splpts(7)=530.
+ splpts(8)=650.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=18,25
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ do i=37,40
+ vercof(i)=vercof(i-35)
+ dvercof(i)=dvercof(i-35)
+ enddo
+ do i=41,44
+ vercof(i)=vercof(i-39)
+ dvercof(i)=dvercof(i-39)
+ enddo
+ do i=45,48
+ vercof(i)=vercof(i-43)
+ dvercof(i)=dvercof(i-43)
+ enddo
+ do i=49,52
+ vercof(i)=vercof(i-47)
+ dvercof(i)=dvercof(i-47)
+ enddo
+ else if(lower_650) then
+ nspl=8
+ splpts(1)=650.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(10),dvercof(10))
+ do i=26,33
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ endif
+ vercof(1)=1.
+ vercof(34)=1.
+ vercof(35)=1.
+ vercof(36)=1.
+ else if((string(1:lstr) == 'WDC+I1D_650'.and.lstr == 11).or. &
+ (string(1:lstr) == 'WDC+I3D_650'.and.lstr == 11)) then
+ if(upper_650) then
+ nspl=8
+ splpts(1)=24.4
+ splpts(2)=75.
+ splpts(3)=150.
+ splpts(4)=225.
+ splpts(5)=300.
+ splpts(6)=410.
+ splpts(7)=530.
+ splpts(8)=650.
+ call vbspl(depth,nspl,splpts,vercof(2),dvercof(2))
+ do i=18,25
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ do i=37,44
+ vercof(i)=vercof(i-35)
+ dvercof(i)=dvercof(i-35)
+ enddo
+ do i=53,60
+ vercof(i)=vercof(i-51)
+ dvercof(i)=dvercof(i-51)
+ enddo
+ do i=69,76
+ vercof(i)=vercof(i-67)
+ dvercof(i)=dvercof(i-67)
+ enddo
+ do i=85,92
+ vercof(i)=vercof(i-83)
+ dvercof(i)=dvercof(i-83)
+ enddo
+ else if(lower_650) then
+ nspl=8
+ splpts(1)=650.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(10),dvercof(10))
+ do i=26,33
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ do i=45,52
+ vercof(i)=vercof(i-35)
+ dvercof(i)=dvercof(i-35)
+ enddo
+ do i=61,68
+ vercof(i)=vercof(i-51)
+ dvercof(i)=dvercof(i-51)
+ enddo
+ do i=77,84
+ vercof(i)=vercof(i-67)
+ dvercof(i)=dvercof(i-67)
+ enddo
+ do i=93,100
+ vercof(i)=vercof(i-83)
+ dvercof(i)=dvercof(i-83)
+ enddo
+ endif
+ vercof(1)=1.
+ vercof(34)=1.
+ vercof(35)=1.
+ vercof(36)=1.
+ else if(string(1:lstr) == 'V16A4_V7A4'.and.lstr == 10) then
+ if(upper_650) then
+ nspl=8
+ splpts(1)=24.4
+ splpts(2)=75.
+ splpts(3)=150.
+ splpts(4)=225.
+ splpts(5)=300.
+ splpts(6)=410.
+ splpts(7)=530.
+ splpts(8)=650.
+ call vbspl(depth,nspl,splpts,vercof(1),dvercof(1))
+ do i=17,20
+ vercof(i)=vercof(i-16)
+ dvercof(i)=dvercof(i-16)
+ enddo
+ do i=23,29
+ vercof(i)=vercof(i-22)
+ dvercof(i)=dvercof(i-22)
+ enddo
+ do i=30,33
+ vercof(i)=vercof(i-29)
+ dvercof(i)=dvercof(i-29)
+ enddo
+ else if(lower_650) then
+ nspl=8
+ splpts(1)=650.
+ splpts(2)=820.
+ splpts(3)=1320.
+ splpts(4)=1820.
+ splpts(5)=2320.
+ splpts(6)=2550.
+ splpts(7)=2791.
+ splpts(8)=2891.
+ call vbspl(depth,nspl,splpts,vercof(9),dvercof(9))
+ endif
+ vercof(21)=1.
+ vercof(22)=1.
+ else
+ write(6,"('problem 4')")
+ write(6,"(a)")string(1:len_trim(string))
+ stop
+ endif
+
+ end subroutine evradker
+
+! ---
+
+ subroutine chebyfun(u,kmax,f)
+
+ implicit none
+
+ integer :: kmax
+
+ real(kind=4) :: chebycoeff(0:13),f(0:kmax),u
+
+ integer :: k
+
+ real(kind=4) :: twou
+
+ data chebycoeff / &
+ 0.70710678118655,1.2247448713916,1.0350983390135,1.0145993123918, &
+ 1.00803225754840,1.0050890913907,1.0035149493262,1.0025740068320, &
+ 1.00196657023780,1.0015515913133,1.0012554932754,1.0010368069141, &
+ 1.00087070107920,1.0007415648034 /
+
+ if(kmax > 13)then
+ write(*,"(' kmax exceeds the limit in chebyfun')")
+ stop
+ endif
+
+ f(0)=1.0
+ f(1)=u
+ twou=2.0*u
+
+ do k=2,kmax
+ f(k) = twou*f(k-1)-f(k-2)
+ enddo
+
+ do k=0,kmax
+ f(k)=f(k)*chebycoeff(k)
+ enddo
+
+ end subroutine chebyfun
+
+
+ subroutine gt3dmodl(lu,targetfile, &
+ maxhpa,maxker,maxcoe, &
+ numhpa,numker,numcoe,lmxhpa, &
+ ihpakern,itypehpa,coe, &
+ itpspl,xlatspl,xlonspl,radispl, &
+ numvar,ivarkern,varstr, &
+ refmdl,kerstr,hsplfl,dskker,ierror)
+
+ implicit none
+
+ integer, parameter :: mxhpar=2
+ integer, parameter :: mxkern=200
+ integer, parameter :: mxcoef=2000
+
+ character(len=80) refmodel
+ character(len=80) kernstri
+ character(len=40) desckern(mxkern)
+ character(len=80) hsplfile(mxhpar)
+
+ integer ihorpar(mxkern)
+ integer ityphpar(mxhpar)
+ integer ixlspl(mxcoef,mxhpar)
+ integer lmaxhor(mxhpar)
+ integer ncoefhor(mxhpar)
+
+ real(kind=4) coef(mxcoef,mxkern)
+ real(kind=4) xlaspl(mxcoef,mxhpar)
+ real(kind=4) xlospl(mxcoef,mxhpar)
+ real(kind=4) xraspl(mxcoef,mxhpar)
+
+ character(len=128) targetfile
+
+ integer numhpa,numker,maxhpa,maxker,maxcoe
+
+ integer numcoe(maxhpa)
+ integer lmxhpa(maxhpa)
+ integer ihpakern(maxker)
+ integer itypehpa(maxhpa)
+ integer itpspl(maxcoe,maxhpa)
+ integer ivarkern(maxker)
+
+ real(kind=4) coe(maxcoe,maxker)
+ real(kind=4) xlatspl(maxcoe,maxhpa)
+ real(kind=4) xlonspl(maxcoe,maxhpa)
+ real(kind=4) radispl(maxcoe,maxhpa)
+
+ character(len=80) refmdl
+ character(len=80) kerstr
+ character(len=80) hsplfl(maxhpa)
+ character(len=40) dskker(maxker)
+ character(len=40) string
+ character(len=40) varstr(maxker)
+
+ integer numvar,ierror,lu,nhorpar,nmodkern,i,j,lstr,k
+
+ ierror=0
+ call rd3dmodl(lu,targetfile,ierror, &
+ nmodkern,nhorpar,ityphpar, &
+ ihorpar,lmaxhor,ncoefhor, &
+ xlaspl,xlospl,xraspl,ixlspl,coef, &
+ hsplfile,refmodel,kernstri,desckern)
+
+ if(nhorpar <= maxhpa) then
+ numhpa=nhorpar
+ else
+ ierror=ierror+1
+ endif
+
+ if(nmodkern <= maxker) then
+ numker=nmodkern
+ else
+ ierror=ierror+1
+ endif
+
+ do i=1,nmodkern
+ ihpakern(i)=ihorpar(i)
+ dskker(i)=desckern(i)
+ do j=1,ncoefhor(ihpakern(i))
+ coe(j,i)=coef(j,i)
+! if(j == 1) then
+! write(6,"(e12.4)") coe(j,i)
+! endif
+ enddo
+ enddo
+
+ do i=1,nhorpar
+ numcoe(i)=ncoefhor(i)
+ lmxhpa(i)=lmaxhor(i)
+ itypehpa(i)=ityphpar(i)
+ if(itypehpa(i) == 2) then
+ do j=1,ncoefhor(i)
+ itpspl(j,i)=ixlspl(j,i)
+ xlatspl(j,i)=xlaspl(j,i)
+ xlonspl(j,i)=xlospl(j,i)
+ radispl(j,i)=xraspl(j,i)
+ enddo
+ endif
+ hsplfl(i)=hsplfile(i)
+ enddo
+
+ numvar=0
+ do i=1,nmodkern
+ string=dskker(i)
+ lstr=len_trim(string)
+ j=1
+ do while(string(j:j) /= ','.and.j < lstr)
+ j=j+1
+ enddo
+ ivarkern(i)=0
+ do k=1,numvar
+ if(string(1:j) == varstr(k)(1:j)) then
+ ivarkern(i)=k
+ endif
+ enddo
+ if(ivarkern(i) == 0) then
+ numvar=numvar+1
+ varstr(numvar)=string(1:j)
+ ivarkern(i)=numvar
+ endif
+ enddo
+
+ refmdl=refmodel
+ kerstr=kernstri
+
+ end subroutine gt3dmodl
+
+
+ subroutine rd3dmodl(lu,filename,ierror, &
+ nmodkern,nhorpar,ityphpar, &
+ ihorpar,lmaxhor,ncoefhor, &
+ xlaspl,xlospl,xraspl,ixlspl,coef, &
+ hsplfile,refmodel,kernstri,desckern)
+
+ implicit none
+
+ integer, parameter :: mxhpar=2
+ integer, parameter :: mxkern=200
+ integer, parameter :: mxcoef=2000
+
+ character(len=80) refmodel
+ character(len=80) kernstri
+ character(len=40) desckern(mxkern)
+ character(len=80) hsplfile(mxhpar)
+
+ integer ihorpar(mxkern)
+ integer ityphpar(mxhpar)
+ integer ixlspl(mxcoef,mxhpar)
+ integer lmaxhor(mxhpar)
+ integer ncoefhor(mxhpar)
+
+ real(kind=4) coef(mxcoef,mxkern)
+ real(kind=4) xlaspl(mxcoef,mxhpar)
+ real(kind=4) xlospl(mxcoef,mxhpar)
+ real(kind=4) xraspl(mxcoef,mxhpar)
+
+ character(len=128) filename
+
+ character(len=128) string
+ character(len=128) substr
+
+ integer :: lu,ierror
+
+ integer :: ncoef,i,ihor,ifst,ilst,ifst1,ios,lstr,nmodkern,idummy,nhorpar,lmax
+
+ open(lu,file=filename,iostat=ios)
+ if(ios /= 0) then
+ stop 'error opening 3-d model'
+ endif
+ do while (ios == 0)
+ read(lu,"(a)",iostat=ios) string
+ lstr=len_trim(string)
+ if(ios == 0) then
+ if(string(1:16) == 'REFERENCE MODEL:') then
+ substr=string(17:lstr)
+ ifst=1
+ ilst=len_trim(substr)
+ do while (substr(ifst:ifst) == ' '.and.ifst < ilst)
+ ifst=ifst+1
+ enddo
+ if(ilst-ifst <= 0) then
+ stop 'error reading model 1'
+ else
+ refmodel=substr(ifst:ilst)
+ endif
+ else if(string(1:11) == 'KERNEL SET:') then
+ substr=string(12:len_trim(string))
+ ifst=1
+ ilst=len_trim(substr)
+ do while (substr(ifst:ifst) == ' '.and.ifst < ilst)
+ ifst=ifst+1
+ enddo
+ if(ilst-ifst <= 0) then
+ stop 'error reading model 2'
+ else
+ kernstri=substr(ifst:ilst)
+ endif
+ else if(string(1:25) == 'RADIAL STRUCTURE KERNELS:') then
+ substr=string(26:len_trim(string))
+ read(substr,*,iostat=ierror) nmodkern
+ if(ierror /= 0) then
+ stop 'error reading model 3'
+ endif
+ else if(string(1:4) == 'DESC'.and.string(9:9) == ':') then
+ read(string(5:8),"(i4)") idummy
+ substr=string(10:len_trim(string))
+ ifst=1
+ ilst=len_trim(substr)
+ do while (substr(ifst:ifst) == ' '.and.ifst < ilst)
+ ifst=ifst+1
+ enddo
+ if(ilst-ifst <= 0) then
+ stop 'error reading model 4'
+ else
+ desckern(idummy)=substr(ifst:ilst)
+ endif
+ else if(string(1:29) == 'HORIZONTAL PARAMETERIZATIONS:') then
+ substr=string(30:len_trim(string))
+ read(substr,*,iostat=ierror) nhorpar
+ if(ierror /= 0) then
+ stop 'error reading model 5'
+ endif
+ else if(string(1:4) == 'HPAR'.and.string(9:9) == ':') then
+ read(string(5:8),"(i4)") idummy
+ ifst=10
+ ilst=len_trim(string)
+ do while (string(ifst:ifst) == ' '.and.ifst < ilst)
+ ifst=ifst+1
+ enddo
+ if(ilst-ifst <= 0) then
+ stop 'error reading model 6'
+ else if(string(ifst:ifst+19) == 'SPHERICAL HARMONICS,') then
+ substr=string(20+ifst:len_trim(string))
+ read(substr,*) lmax
+ ityphpar(idummy)=1
+ lmaxhor(idummy)=lmax
+ ncoefhor(idummy)=(lmax+1)**2
+ else if(string(ifst:ifst+17) == 'SPHERICAL SPLINES,') then
+ ifst1=ifst+18
+ ifst=len_trim(string)
+ ilst=len_trim(string)
+ do while(string(ifst:ifst) /= ',')
+ ifst=ifst-1
+ enddo
+ read(string(ifst+1:ilst),*) ncoef
+ substr=string(ifst1:ifst-1)
+ do while (string(ifst1:ifst1) == ' '.and.ifst1 < ifst)
+ ifst1=ifst1+1
+ enddo
+ hsplfile(idummy)=string(ifst1:ifst-1)
+ ityphpar(idummy)=2
+ lmaxhor(idummy)=0
+ ncoefhor(idummy)=ncoef
+ do i=1,ncoef
+ read(lu,*) ixlspl(i,idummy),xlaspl(i,idummy), &
+ xlospl(i,idummy),xraspl(i,idummy)
+ enddo
+ endif
+ else if(string(1:4) == 'STRU'.and.string(9:9) == ':') then
+ read(string(5:8),"(i4)") idummy
+ substr=string(10:len_trim(string))
+ read(substr,*) ihor
+ ihorpar(idummy)=ihor
+ ncoef=ncoefhor(ihor)
+ read(lu,"(6e12.4)") (coef(i,idummy),i=1,ncoef)
+ endif
+ endif
+ enddo
+ close(lu)
+
+ end subroutine rd3dmodl
+
+
+ subroutine read_model_s362ani(THREE_D_MODEL, &
+ THREE_D_MODEL_S362ANI,THREE_D_MODEL_S362WMANI, &
+ THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA, &
+ numker,numhpa,ihpa,lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,itpspl, &
+ xlaspl,xlospl,radspl,coe,hsplfl,dskker,kerstr,varstr,refmdl)
+
+ implicit none
+
+ integer THREE_D_MODEL,THREE_D_MODEL_S362ANI
+ integer THREE_D_MODEL_S362WMANI
+ integer THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA
+
+ integer lu
+ character(len=128) modeldef
+ logical exists
+ integer numvar
+ integer ierror
+
+ integer, parameter :: maxker=200
+ integer, parameter :: maxl=72
+ integer, parameter :: maxcoe=2000
+ integer, parameter :: maxver=1000
+ integer, parameter :: maxhpa=2
+
+ integer numker
+ integer numhpa
+ integer ihpa
+ integer lmxhpa(maxhpa)
+ integer itypehpa(maxhpa)
+ integer ihpakern(maxker)
+ integer numcoe(maxhpa)
+ integer ivarkern(maxker)
+ integer itpspl(maxcoe,maxhpa)
+
+ real(kind=4) xlaspl(maxcoe,maxhpa)
+ real(kind=4) xlospl(maxcoe,maxhpa)
+ real(kind=4) radspl(maxcoe,maxhpa)
+ real(kind=4) coe(maxcoe,maxker)
+ character(len=80) hsplfl(maxhpa)
+ character(len=40) dskker(maxker)
+
+ character(len=80) kerstr
+ character(len=80) refmdl
+ character(len=40) varstr(maxker)
+
+! -------------------------------------
+
+ lu=1 ! --- log unit: input 3-D model
+ if(THREE_D_MODEL == THREE_D_MODEL_S362ANI) then
+ modeldef='DATA/s362ani/S362ANI'
+ elseif(THREE_D_MODEL == THREE_D_MODEL_S362WMANI) then
+ modeldef='DATA/s362ani/S362WMANI'
+ elseif(THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM) then
+ modeldef='DATA/s362ani/S362ANI_PREM'
+ elseif(THREE_D_MODEL == THREE_D_MODEL_S29EA) then
+ modeldef='DATA/s362ani/S2.9EA'
+ else
+ stop 'unknown 3D model in read_model_s362ani'
+ endif
+ inquire(file=modeldef,exist=exists)
+ if(exists) then
+ call gt3dmodl(lu,modeldef, &
+ maxhpa,maxker,maxcoe, &
+ numhpa,numker,numcoe,lmxhpa, &
+ ihpakern,itypehpa,coe, &
+ itpspl,xlaspl,xlospl,radspl, &
+ numvar,ivarkern,varstr, &
+ refmdl,kerstr,hsplfl,dskker,ierror)
+ else
+ write(6,"('the model ',a,' does not exits')") modeldef(1:len_trim(modeldef))
+ endif
+
+! --- check arrays
+
+ if(numker > maxker) stop 'numker > maxker'
+ do ihpa=1,numhpa
+ if(itypehpa(ihpa) == 1) then
+ if(lmxhpa(ihpa) > maxl) stop 'lmxhpa(ihpa) > maxl'
+ else if(itypehpa(ihpa) == 2) then
+ if(numcoe(ihpa) > maxcoe) stop 'numcoe(ihpa) > maxcoe'
+ else
+ stop 'problem with itypehpa'
+ endif
+ enddo
+
+ end subroutine read_model_s362ani
+
+
+ subroutine splcon(xlat,xlon,nver,verlat,verlon,verrad,ncon,icon,con)
+
+ implicit none
+
+ integer icon(1)
+
+ real(kind=4) verlat(1)
+ real(kind=4) verlon(1)
+ real(kind=4) verrad(1)
+ real(kind=4) con(1)
+
+ double precision dd
+ double precision rn
+ double precision dr
+ double precision xrad
+ double precision ver8
+ double precision xla8
+
+ integer :: ncon,iver,nver
+
+ real(kind=4) :: xlat,xlon
+
+ xrad=3.14159265358979/180.d0
+
+ ncon=0
+
+ do iver=1,nver
+ if(xlat > verlat(iver)-2.*verrad(iver)) then
+ if(xlat < verlat(iver)+2.*verrad(iver)) then
+ ver8=xrad*(verlat(iver))
+ xla8=xrad*(xlat)
+ dd=sin(ver8)*sin(xla8)
+ dd=dd+cos(ver8)*cos(xla8)* cos(xrad*(xlon-verlon(iver)))
+ dd=acos(dd)/xrad
+ if(dd > (verrad(iver))*2.d0) then
+ else
+ ncon=ncon+1
+ icon(ncon)=iver
+ rn=dd/(verrad(iver))
+ dr=rn-1.d0
+ if(rn <= 1.d0) then
+ con(ncon)=(0.75d0*rn-1.5d0)*(rn**2)+1.d0
+ else if(rn > 1.d0) then
+ con(ncon)=((-0.25d0*dr+0.75d0)*dr-0.75d0)*dr+0.25d0
+ else
+ con(ncon)=0.
+ endif
+ endif
+ endif
+ endif
+ enddo
+
+ end subroutine splcon
+
+
+! --- evaluate perturbations in per cent
+
+ subroutine subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+
+ implicit none
+
+ integer, parameter :: maxker=200
+ integer, parameter :: maxl=72
+ integer, parameter :: maxcoe=2000
+ integer, parameter :: maxver=1000
+ integer, parameter :: maxhpa=2
+
+ integer numker
+ integer numhpa,numcof
+ integer ihpa,lmax,nylm
+ integer lmxhpa(maxhpa)
+ integer itypehpa(maxhpa)
+ integer ihpakern(maxker)
+ integer numcoe(maxhpa)
+ integer ivarkern(maxker)
+
+ integer nconpt(maxhpa),iver
+ integer iconpt(maxver,maxhpa)
+ real(kind=4) conpt(maxver,maxhpa)
+
+ real(kind=4) xlaspl(maxcoe,maxhpa)
+ real(kind=4) xlospl(maxcoe,maxhpa)
+ real(kind=4) radspl(maxcoe,maxhpa)
+ real(kind=4) coe(maxcoe,maxker)
+ real(kind=4) vercof(maxker)
+ real(kind=4) vercofd(maxker)
+
+ real(kind=4) ylmcof((maxl+1)**2,maxhpa)
+ real(kind=4) wk1(maxl+1)
+ real(kind=4) wk2(maxl+1)
+ real(kind=4) wk3(maxl+1)
+
+ character(len=80) kerstr
+ character(len=40) varstr(maxker)
+
+ real(kind=4) :: xcolat,xlon,xrad
+ real(kind=4) :: dvsh,dvsv,dvph,dvpv
+
+! --- model evaluation
+
+ integer ish ! --- 0 if SV, 1 if SH
+ integer ieval ! --- 1 for velocity, 2 for anisotropy
+ real(kind=4) :: valu(2) ! --- valu(1) if S; valu(1)=velo, valu(2)=aniso
+ real(kind=4) :: value ! --- used in single evaluation of perturbation
+ integer isel ! --- if variable should be included
+ real(kind=4) :: depth ! --- depth
+ real(kind=4) :: x,y ! --- lat lon
+ real(kind=4) :: vsh3drel ! --- relative perturbation
+ real(kind=4) :: vsv3drel ! --- relative perturbation
+
+! ---
+
+ integer iker,i
+ character(len=40) vstr
+ integer lstr
+ integer ierror
+
+! -------------------------------------
+
+ depth=6371.0-xrad
+ call evradker (depth,kerstr,numker,vercof,vercofd,ierror)
+ if(ierror /= 0) stop 'ierror evradker'
+
+! --- loop over sv and sh (sv=0,sh=1)
+
+ do ish=0,1
+
+! --- contributing horizontal basis functions at xlat,xlon
+
+ y=90.0-xcolat
+ x=xlon
+ do ihpa=1,numhpa
+ if(itypehpa(ihpa) == 1) then
+ lmax=lmxhpa(ihpa)
+ call ylm(y,x,lmax,ylmcof(1,ihpa),wk1,wk2,wk3)
+ else if(itypehpa(ihpa) == 2) then
+ numcof=numcoe(ihpa)
+ call splcon(y,x,numcof,xlaspl(1,ihpa), &
+ xlospl(1,ihpa),radspl(1,ihpa), &
+ nconpt(ihpa),iconpt(1,ihpa),conpt(1,ihpa))
+ else
+ write(6,"('problem 1')")
+ endif
+ enddo
+
+! --- evaluate 3-D perturbations in velocity and anisotropy
+
+ valu(1)=0. ! --- velocity
+ valu(2)=0. ! --- anisotropy
+
+ do ieval=1,2
+ value=0.
+ do iker=1,numker
+ isel=0
+ lstr=len_trim(varstr(ivarkern(iker)))
+ vstr=(varstr(ivarkern(iker)))
+ if(ieval == 1) then
+ if(vstr(1:lstr) == 'UM (SH+SV)*0.5,'.or. &
+ vstr(1:lstr) == 'LM (SH+SV)*0.5,'.or. &
+ vstr(1:lstr) == 'EA (SH+SV)*0.5,') then
+ isel=1
+ endif
+ else if(ieval == 2) then
+ if(vstr(1:lstr) == 'UM SH-SV,'.or. &
+ vstr(1:lstr) == 'LM SH-SV,'.or. &
+ vstr(1:lstr) == 'EA SH-SV,') then
+ isel=1
+ endif
+ endif
+
+ if(isel == 1) then
+ if(vercof(iker) /= 0.) then
+ if(itypehpa(ihpakern(iker)) == 1) then
+ ihpa=ihpakern(iker)
+ nylm=(lmxhpa(ihpakern(iker))+1)**2
+ do i=1,nylm
+ value=value+vercof(iker)*ylmcof(i,ihpa) &
+ *coe(i,iker)
+ enddo
+ else if(itypehpa(ihpakern(iker)) == 2) then
+ ihpa=ihpakern(iker)
+ do i=1,nconpt(ihpa)
+ iver=iconpt(i,ihpa)
+ value=value+vercof(iker)*conpt(i,ihpa) &
+ *coe(iver,iker)
+ enddo
+ else
+ write(6,"('problem 2')")
+ stop
+ endif ! --- itypehpa
+ endif ! --- vercof(iker) /= 0.
+ endif ! --- isel == 1
+ enddo ! --- end of do iker=1,numker
+
+ valu(ieval)=value
+ enddo ! --- ieval
+
+! --- evaluate perturbations in vsh and vsv
+
+ if(ish == 1) then
+ vsh3drel=valu(1)+0.5*valu(2)
+ else if(ish == 0) then
+ vsv3drel=valu(1)-0.5*valu(2)
+ else
+ stop 'something wrong'
+ endif
+
+ enddo ! --- by ish
+
+! --- evaluate perturbations in per cent
+
+ dvsh=vsh3drel
+ dvsv=vsv3drel
+ dvph=0.55*dvsh ! --- scaling used in the inversion
+ dvpv=0.55*dvsv ! --- scaling used in the inversion
+
+ end subroutine subshsv
+
+
+! --- evaluate depressions of the 410- and 650-km discontinuities in km
+
+ subroutine subtopo(xcolat,xlon,topo410,topo650, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,ylmcof,wk1,wk2,wk3,varstr)
+
+ implicit none
+
+ integer, parameter :: maxker=200
+ integer, parameter :: maxl=72
+ integer, parameter :: maxcoe=2000
+ integer, parameter :: maxver=1000
+ integer, parameter :: maxhpa=2
+
+ integer numker
+ integer numhpa,numcof
+ integer ihpa,lmax,nylm
+ integer lmxhpa(maxhpa)
+ integer itypehpa(maxhpa)
+ integer ihpakern(maxker)
+ integer numcoe(maxhpa)
+ integer ivarkern(maxker)
+
+ integer nconpt(maxhpa),iver
+ integer iconpt(maxver,maxhpa)
+ real(kind=4) conpt(maxver,maxhpa)
+
+ real(kind=4) xlaspl(maxcoe,maxhpa)
+ real(kind=4) xlospl(maxcoe,maxhpa)
+ real(kind=4) radspl(maxcoe,maxhpa)
+ real(kind=4) coe(maxcoe,maxker)
+
+ real(kind=4) ylmcof((maxl+1)**2,maxhpa)
+ real(kind=4) wk1(maxl+1)
+ real(kind=4) wk2(maxl+1)
+ real(kind=4) wk3(maxl+1)
+
+ character(len=40) varstr(maxker)
+
+ real(kind=4) :: xcolat,xlon
+ real(kind=4) :: topo410,topo650
+
+! --- model evaluation
+
+ integer ieval ! --- 1 for velocity, 2 for anisotropy
+ real(kind=4) :: valu(2) ! --- valu(1) if S; valu(1)=velo, valu(2)=aniso
+ real(kind=4) :: value ! --- used in single evaluation of perturbation
+ integer isel ! --- if variable should be included
+ real(kind=4) :: x,y ! --- lat lon
+
+! ---
+ integer iker,i
+ character(len=40) vstr
+ integer lstr
+
+! -------------------------------------
+
+! --- contributing horizontal basis functions at xlat,xlon
+
+ y=90.0-xcolat
+ x=xlon
+ do ihpa=1,numhpa
+ if(itypehpa(ihpa) == 1) then
+ lmax=lmxhpa(ihpa)
+ call ylm(y,x,lmax,ylmcof(1,ihpa),wk1,wk2,wk3)
+ else if(itypehpa(ihpa) == 2) then
+ numcof=numcoe(ihpa)
+ call splcon(y,x,numcof,xlaspl(1,ihpa), &
+ xlospl(1,ihpa),radspl(1,ihpa), &
+ nconpt(ihpa),iconpt(1,ihpa),conpt(1,ihpa))
+ else
+ write(6,"('problem 1')")
+ endif
+ enddo
+
+! --- evaluate topography (depression) in km
+
+ valu(1)=0. ! --- 410
+ valu(2)=0. ! --- 650
+
+ do ieval=1,2
+ value=0.
+ do iker=1,numker
+ isel=0
+ lstr=len_trim(varstr(ivarkern(iker)))
+ vstr=(varstr(ivarkern(iker)))
+ if(ieval == 1) then
+ if(vstr(1:lstr) == 'Topo 400,') then
+ isel=1
+ endif
+ else if(ieval == 2) then
+ if(vstr(1:lstr) == 'Topo 670,') then
+ isel=1
+ endif
+ endif
+
+ if(isel == 1) then
+ if(itypehpa(ihpakern(iker)) == 1) then
+ ihpa=ihpakern(iker)
+ nylm=(lmxhpa(ihpakern(iker))+1)**2
+ do i=1,nylm
+ value=value+ylmcof(i,ihpa)*coe(i,iker)
+ enddo
+ else if(itypehpa(ihpakern(iker)) == 2) then
+ ihpa=ihpakern(iker)
+ do i=1,nconpt(ihpa)
+ iver=iconpt(i,ihpa)
+ value=value+conpt(i,ihpa)*coe(iver,iker)
+ enddo
+ else
+ write(6,"('problem 2')")
+ stop
+ endif ! --- itypehpa
+ endif ! --- isel == 1
+ enddo ! --- end of do iker=1,numker
+
+ valu(ieval)=value
+ enddo ! --- ieval
+
+ topo410=valu(1)
+ topo650=valu(2)
+
+ end subroutine subtopo
+
+ subroutine vbspl(x,np,xarr,splcon,splcond)
+!
+!---- this subroutine returns the spline contributions at a particular value of x
+!
+ implicit none
+
+ integer :: np
+
+ real(kind=4) :: xarr(np),x
+ real(kind=4) :: splcon(np)
+ real(kind=4) :: splcond(np)
+
+ real(kind=4) :: r1,r2,r3,r4,r5,r6,r7,r8,r9,r10,r11,r12,r13
+ real(kind=4) :: r1d,r2d,r3d,r4d,r5d,r6d,r7d,r8d,r9d,r10d,r11d,r12d,r13d,val,vald
+
+ real(kind=4) :: rr1,rr2,rr3,rr4,rr5,rr6,rr7,rr8,rr9,rr10,rr11,rr12
+ real(kind=4) :: rr1d,rr2d,rr3d,rr4d,rr5d,rr6d,rr7d,rr8d,rr9d,rr10d,rr11d,rr12d
+
+ integer :: iflag,interval,ik,ib
+
+!
+!---- iflag=1 ==>> second derivative is 0 at end points
+!---- iflag=0 ==>> first derivative is 0 at end points
+!
+ iflag=1
+!
+!---- first, find out within which interval x falls
+!
+ interval=0
+ ik=1
+ do while(interval == 0.and.ik < np)
+ ik=ik+1
+ if(x >= xarr(ik-1).and.x <= xarr(ik)) interval=ik-1
+ enddo
+ if(x > xarr(np)) then
+ interval=np
+ endif
+
+ if(interval == 0) then
+! write(6,"('low value:',2f10.3)") x,xarr(1)
+ else if(interval > 0.and.interval < np) then
+! write(6,"('bracket:',i5,3f10.3)") interval,xarr(interval),x,xarr(interval+1)
+ else
+! write(6,"('high value:',2f10.3)") xarr(np),x
+ endif
+
+ do ib=1,np
+ val=0.
+ vald=0.
+ if(ib == 1) then
+
+ r1=(x-xarr(1))/(xarr(2)-xarr(1))
+ r2=(xarr(3)-x)/(xarr(3)-xarr(1))
+ r4=(xarr(2)-x)/(xarr(2)-xarr(1))
+ r5=(x-xarr(1))/(xarr(2)-xarr(1))
+ r6=(xarr(3)-x)/(xarr(3)-xarr(1))
+ r10=(xarr(2)-x)/(xarr(2)-xarr(1))
+ r11=(x-xarr(1)) /(xarr(2)-xarr(1))
+ r12=(xarr(3)-x)/(xarr(3)-xarr(2))
+ r13=(xarr(2)-x)/(xarr(2)-xarr(1))
+
+ r1d=1./(xarr(2)-xarr(1))
+ r2d=-1./(xarr(3)-xarr(1))
+ r4d=-1./(xarr(2)-xarr(1))
+ r5d=1./(xarr(2)-xarr(1))
+ r6d=-1./(xarr(3)-xarr(1))
+ r10d=-1./(xarr(2)-xarr(1))
+ r11d=1./(xarr(2)-xarr(1))
+ r12d=-1./(xarr(3)-xarr(2))
+ r13d=-1./(xarr(2)-xarr(1))
+
+ if(interval == ib.or.interval == 0) then
+ if(iflag == 0) then
+ val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11 +r13**3
+ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
+ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
+ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
+ vald=vald+3.*r13d*r13**2
+ else if(iflag == 1) then
+ val=0.6667*(r1*r4*r10 + r2*r5*r10 + r2*r6*r11 &
+ + 1.5*r13**3)
+ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
+ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
+ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
+ vald=vald+4.5*r13d*r13**2
+ vald=0.6667*vald
+ endif
+ else if(interval == ib+1) then
+ if(iflag == 0) then
+ val=r2*r6*r12
+ vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d
+ else if(iflag == 1) then
+ val=0.6667*r2*r6*r12
+ vald=0.6667*(r2d*r6*r12+r2*r6d*r12+r2*r6*r12d)
+ endif
+ else
+ val=0.
+ endif
+
+ else if(ib == 2) then
+
+ rr1=(x-xarr(1))/(xarr(2)-xarr(1))
+ rr2=(xarr(3)-x)/(xarr(3)-xarr(1))
+ rr4=(xarr(2)-x)/(xarr(2)-xarr(1))
+ rr5=(x-xarr(1))/(xarr(2)-xarr(1))
+ rr6=(xarr(3)-x)/(xarr(3)-xarr(1))
+ rr10=(xarr(2)-x)/(xarr(2)-xarr(1))
+ rr11=(x-xarr(1)) /(xarr(2)-xarr(1))
+ rr12=(xarr(3)-x)/(xarr(3)-xarr(2))
+
+ rr1d=1./(xarr(2)-xarr(1))
+ rr2d=-1./(xarr(3)-xarr(1))
+ rr4d=-1./(xarr(2)-xarr(1))
+ rr5d=1./(xarr(2)-xarr(1))
+ rr6d=-1./(xarr(3)-xarr(1))
+ rr10d=-1./(xarr(2)-xarr(1))
+ rr11d=1./(xarr(2)-xarr(1))
+ rr12d=-1./(xarr(3)-xarr(2))
+
+ r1=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
+ r2=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib-1))
+ r3=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
+ r4=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
+ r5=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
+ r6=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib))
+ r8=(xarr(ib)-x)/ (xarr(ib)-xarr(ib-1))
+ r9=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
+ r10=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
+ r11=(x-xarr(ib)) /(xarr(ib+1)-xarr(ib))
+ r12=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib+1))
+
+ r1d=1./(xarr(ib+1)-xarr(ib-1))
+ r2d=-1./(xarr(ib+2)-xarr(ib-1))
+ r3d=1./(xarr(ib)-xarr(ib-1))
+ r4d=-1./(xarr(ib+1)-xarr(ib-1))
+ r5d=1./(xarr(ib+1)-xarr(ib-1))
+ r6d=-1./(xarr(ib+2)-xarr(ib))
+ r8d=-1./ (xarr(ib)-xarr(ib-1))
+ r9d=1./(xarr(ib)-xarr(ib-1))
+ r10d=-1./(xarr(ib+1)-xarr(ib))
+ r11d=1./(xarr(ib+1)-xarr(ib))
+ r12d=-1./(xarr(ib+2)-xarr(ib+1))
+
+ if(interval == ib-1.or.interval == 0) then
+ val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9
+ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
+ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
+ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
+ if(iflag == 1) then
+ val=val+0.3333*(rr1*rr4*rr10 + rr2*rr5*rr10 + &
+ rr2*rr6*rr11)
+ vald=vald+0.3333*(rr1d*rr4*rr10+rr1*rr4d*rr10+ &
+ rr1*rr4*rr10d)
+ vald=vald+0.3333*(rr2d*rr5*rr10+rr2*rr5d*rr10+ &
+ rr2*rr5*rr10d)
+ vald=vald+0.3333*(rr2d*rr6*rr11+rr2*rr6d*rr11+ &
+ rr2*rr6*rr11d)
+ endif
+ else if(interval == ib) then
+ val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11
+ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
+ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
+ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
+ if(iflag == 1) then
+ val=val+0.3333*rr2*rr6*rr12
+ vald=vald+0.3333*(rr2d*rr6*rr12+rr2*rr6d*rr12+ &
+ rr2*rr6*rr12d)
+ endif
+ else if(interval == ib+1) then
+ val=r2*r6*r12
+ vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d
+ else
+ val=0.
+ endif
+ else if(ib == np-1) then
+
+ rr1=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
+ rr2=(xarr(np)-x)/(xarr(np)-xarr(np-1))
+ rr3=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
+ rr4=(xarr(np)-x)/(xarr(np)-xarr(np-1))
+ rr5=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
+ rr7=(x-xarr(np-2))/(xarr(np-1)-xarr(np-2))
+ rr8=(xarr(np)-x)/ (xarr(np)-xarr(np-1))
+ rr9=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
+
+ rr1d=1./(xarr(np)-xarr(np-2))
+ rr2d=-1./(xarr(np)-xarr(np-1))
+ rr3d=1./(xarr(np)-xarr(np-2))
+ rr4d=-1./(xarr(np)-xarr(np-1))
+ rr5d=1./(xarr(np)-xarr(np-1))
+ rr7d=1./(xarr(np-1)-xarr(np-2))
+ rr8d=-1./ (xarr(np)-xarr(np-1))
+ rr9d=1./(xarr(np)-xarr(np-1))
+
+ r1=(x-xarr(ib-2))/(xarr(ib+1)-xarr(ib-2))
+ r2=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
+ r3=(x-xarr(ib-2))/(xarr(ib)-xarr(ib-2))
+ r4=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
+ r5=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
+ r6=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
+ r7=(x-xarr(ib-2))/(xarr(ib-1)-xarr(ib-2))
+ r8=(xarr(ib)-x)/ (xarr(ib)-xarr(ib-1))
+ r9=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
+ r10=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
+ r11=(x-xarr(ib)) /(xarr(ib+1)-xarr(ib))
+
+ r1d=1./(xarr(ib+1)-xarr(ib-2))
+ r2d=-1./(xarr(ib+1)-xarr(ib-1))
+ r3d=1./(xarr(ib)-xarr(ib-2))
+ r4d=-1./(xarr(ib+1)-xarr(ib-1))
+ r5d=1./(xarr(ib+1)-xarr(ib-1))
+ r6d=-1./(xarr(ib+1)-xarr(ib))
+ r7d=1./(xarr(ib-1)-xarr(ib-2))
+ r8d=-1./(xarr(ib)-xarr(ib-1))
+ r9d=1./(xarr(ib)-xarr(ib-1))
+ r10d=-1./(xarr(ib+1)-xarr(ib))
+ r11d=1./(xarr(ib+1)-xarr(ib))
+
+ if(interval == ib-2) then
+ val=r1*r3*r7
+ vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d
+ else if(interval == ib-1) then
+ val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9
+ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
+ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
+ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
+ if(iflag == 1) then
+ val=val+0.3333*rr1*rr3*rr7
+ vald=vald+0.3333*(rr1d*rr3*rr7+rr1*rr3d*rr7+ &
+ rr1*rr3*rr7d)
+ endif
+ else if(interval == ib.or.interval == np) then
+ val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11
+ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
+ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
+ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
+ if(iflag == 1) then
+ val=val+0.3333*(rr1*rr3*rr8 + rr1*rr4*rr9 + &
+ rr2*rr5*rr9)
+ vald=vald+0.3333*(rr1d*rr3*rr8+rr1*rr3d*rr8+ &
+ rr1*rr3*rr8d)
+ vald=vald+0.3333*(rr1d*rr4*rr9+rr1*rr4d*rr9+ &
+ rr1*rr4*rr9d)
+ vald=vald+0.3333*(rr2d*rr5*rr9+rr2*rr5d*rr9+ &
+ rr2*rr5*rr9d)
+ endif
+ else
+ val=0.
+ endif
+ else if(ib == np) then
+
+ r1=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
+ r2=(xarr(np)-x)/(xarr(np)-xarr(np-1))
+ r3=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
+ r4=(xarr(np)-x)/(xarr(np)-xarr(np-1))
+ r5=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
+ r7=(x-xarr(np-2))/(xarr(np-1)-xarr(np-2))
+ r8=(xarr(np)-x)/ (xarr(np)-xarr(np-1))
+ r9=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
+ r13=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
+
+ r1d=1./(xarr(np)-xarr(np-2))
+ r2d=-1./(xarr(np)-xarr(np-1))
+ r3d=1./(xarr(np)-xarr(np-2))
+ r4d=-1./(xarr(np)-xarr(np-1))
+ r5d=1./(xarr(np)-xarr(np-1))
+ r7d=1./(xarr(np-1)-xarr(np-2))
+ r8d=-1./ (xarr(np)-xarr(np-1))
+ r9d=1./(xarr(np)-xarr(np-1))
+ r13d=1./(xarr(np)-xarr(np-1))
+
+ if(interval == np-2) then
+ if(iflag == 0) then
+ val=r1*r3*r7
+ vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d
+ else if(iflag == 1) then
+ val=0.6667*r1*r3*r7
+ vald=0.6667*(r1d*r3*r7+r1*r3d*r7+r1*r3*r7d)
+ endif
+ else if(interval == np-1.or.interval == np) then
+ if(iflag == 0) then
+ val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9 + r13**3
+ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
+ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
+ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
+ vald=vald+3.*r13d*r13**2
+ else if(iflag == 1) then
+ val=0.6667*(r1*r3*r8 + r1*r4*r9 + r2*r5*r9 + &
+ 1.5*r13**3)
+ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
+ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
+ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
+ vald=vald+4.5*r13d*r13**2
+ vald=0.6667*vald
+ endif
+ else
+ val=0.
+ endif
+ else
+
+ r1=(x-xarr(ib-2))/(xarr(ib+1)-xarr(ib-2))
+ r2=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib-1))
+ r3=(x-xarr(ib-2))/(xarr(ib)-xarr(ib-2))
+ r4=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
+ r5=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
+ r6=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib))
+ r7=(x-xarr(ib-2))/(xarr(ib-1)-xarr(ib-2))
+ r8=(xarr(ib)-x)/ (xarr(ib)-xarr(ib-1))
+ r9=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
+ r10=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
+ r11=(x-xarr(ib)) /(xarr(ib+1)-xarr(ib))
+ r12=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib+1))
+
+ r1d=1./(xarr(ib+1)-xarr(ib-2))
+ r2d=-1./(xarr(ib+2)-xarr(ib-1))
+ r3d=1./(xarr(ib)-xarr(ib-2))
+ r4d=-1./(xarr(ib+1)-xarr(ib-1))
+ r5d=1./(xarr(ib+1)-xarr(ib-1))
+ r6d=-1./(xarr(ib+2)-xarr(ib))
+ r7d=1./(xarr(ib-1)-xarr(ib-2))
+ r8d=-1./ (xarr(ib)-xarr(ib-1))
+ r9d=1./(xarr(ib)-xarr(ib-1))
+ r10d=-1./(xarr(ib+1)-xarr(ib))
+ r11d=1./(xarr(ib+1)-xarr(ib))
+ r12d=-1./(xarr(ib+2)-xarr(ib+1))
+
+ if(interval == ib-2) then
+ val=r1*r3*r7
+ vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d
+ else if(interval == ib-1) then
+ val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9
+ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
+ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
+ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
+ else if(interval == ib) then
+ val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11
+ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
+ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
+ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
+ else if(interval == ib+1) then
+ val=r2*r6*r12
+ vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d
+ else
+ val=0.
+ endif
+ endif
+ splcon(ib)=val
+ splcond(ib)=vald
+ enddo
+
+ end subroutine vbspl
+
+
+ subroutine ylm(XLAT,XLON,LMAX,Y,WK1,WK2,WK3)
+
+ implicit none
+
+ complex TEMP,FAC,DFAC
+
+ real(kind=4) WK1(1),WK2(1),WK3(1),Y(1),XLAT,XLON
+
+ integer :: LMAX
+
+!
+! WK1,WK2,WK3 SHOULD BE DIMENSIONED AT LEAST (LMAX+1)*4
+!
+ real(kind=4), parameter :: RADIAN = 57.2957795
+
+ integer :: IM,IL1,IND,LM1,L
+
+ real(kind=4) :: THETA,PHI
+
+ THETA=(90.-XLAT)/RADIAN
+ PHI=XLON/RADIAN
+
+ IND=0
+ LM1=LMAX+1
+
+ DO IL1=1,LM1
+
+ L=IL1-1
+ CALL legndr(THETA,L,L,WK1,WK2,WK3)
+
+ FAC=(1.,0.)
+ DFAC=CEXP(CMPLX(0.,PHI))
+
+ do IM=1,IL1
+ TEMP=FAC*CMPLX(WK1(IM),0.)
+ IND=IND+1
+ Y(IND)=REAL(TEMP)
+ IF(IM == 1) GOTO 20
+ IND=IND+1
+ Y(IND)=AIMAG(TEMP)
+ 20 FAC=FAC*DFAC
+ enddo
+
+ enddo
+
+ end subroutine ylm
+
+!------------------------------------
+
+ subroutine legndr(THETA,L,M,X,XP,XCOSEC)
+
+ implicit none
+
+ real(kind=4) :: X(2),XP(2),XCOSEC(2)
+
+ double precision :: SMALL,SUM,COMPAR,CT,ST,FCT,COT,X1,X2,X3,F1,F2,XM,TH
+
+ double precision, parameter :: FPI = 12.56637062D0
+
+ integer :: i,M,MP1,k,l,LP1
+
+ real(kind=4) :: THETA,DSFL3,COSEC,SFL3
+
+!!!!!! illegal statement, removed by Dimitri Komatitsch DFLOAT(I)=FLOAT(I)
+
+ SUM=0.D0
+ LP1=L+1
+ TH=THETA
+ CT=DCOS(TH)
+ ST=DSIN(TH)
+ MP1=M+1
+ FCT=DSQRT(dble(2*L+1)/FPI)
+ SFL3=SQRT(FLOAT(L*(L+1)))
+ COMPAR=dble(2*L+1)/FPI
+ DSFL3=SFL3
+ SMALL=1.D-16*COMPAR
+
+ do I=1,MP1
+ X(I)=0.
+ XCOSEC(I)=0.
+ XP(I)=0.
+ enddo
+
+ IF(L > 1.AND.ABS(THETA) > 1.E-5) GO TO 3
+ X(1)=FCT
+ IF(L == 0) RETURN
+ X(1)=CT*FCT
+ X(2)=-ST*FCT/DSFL3
+ XP(1)=-ST*FCT
+ XP(2)=-.5D0*CT*FCT*DSFL3
+ IF(ABS(THETA) < 1.E-5) XCOSEC(2)=XP(2)
+ IF(ABS(THETA) >= 1.E-5) XCOSEC(2)=X(2)/ST
+ RETURN
+
+ 3 X1=1.D0
+ X2=CT
+
+ do I=2,L
+ X3=(dble(2*I-1)*CT*X2-dble(I-1)*X1)/dble(I)
+ X1=X2
+ X2=X3
+ enddo
+
+ COT=CT/ST
+ COSEC=1./ST
+ X3=X2*FCT
+ X2=dble(L)*(X1-CT*X2)*FCT/ST
+ X(1)=X3
+ X(2)=X2
+ SUM=X3*X3
+ XP(1)=-X2
+ XP(2)=dble(L*(L+1))*X3-COT*X2
+ X(2)=-X(2)/SFL3
+ XCOSEC(2)=X(2)*COSEC
+ XP(2)=-XP(2)/SFL3
+ SUM=SUM+2.D0*X(2)*X(2)
+ IF(SUM-COMPAR > SMALL) RETURN
+ X1=X3
+ X2=-X2/DSQRT(dble(L*(L+1)))
+
+ do I=3,MP1
+ K=I-1
+ F1=DSQRT(dble((L+I-1)*(L-I+2)))
+ F2=DSQRT(dble((L+I-2)*(L-I+3)))
+ XM=K
+ X3=-(2.D0*COT*(XM-1.D0)*X2+F2*X1)/F1
+ SUM=SUM+2.D0*X3*X3
+ IF(SUM-COMPAR > SMALL.AND.I /= LP1) RETURN
+ X(I)=X3
+ XCOSEC(I)=X(I)*COSEC
+ X1=X2
+ XP(I)=-(F1*X2+XM*COT*X3)
+ X2=X3
+ enddo
+
+ end subroutine legndr
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/save_arrays_solver.F90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/save_arrays_solver.F90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/save_arrays_solver.F90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,138 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine save_arrays_solver(prname,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ kappav,muv,ibool,rmass,nspec,nglob,myrank,NPROCTOT,xstore,ystore,zstore)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nspec,nglob,myrank,NPROCTOT
+
+! arrays with jacobian matrix
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,kappav,muv
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+! mass matrix
+ real(kind=CUSTOM_REAL) rmass(nglob)
+
+! 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)
+
+!!!!!!!!!!!!!!!!!! integer :: i,j,k,ispec
+
+ real(kind=CUSTOM_REAL) :: memory_size
+
+! processor identification
+ character(len=150) prname
+
+! estimate total memory size (the size of a real number is 4 bytes)
+! we perform the calculation in single precision rather than integer
+! to avoid integer overflow in the case of very large meshes
+ memory_size = 4. * ((3.*NDIM + 1.) * NGLOB + 12. * real(NGLLX*NGLLY*NGLLZ)*real(NSPEC))
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'approximate total memory size that will be used by the solver in each slice = ',memory_size/1024./1024.,' Mb'
+ write(IMAIN,*) 'i.e. = ',memory_size/1024./1024./1024.,' Gb'
+#ifdef USE_MPI
+ write(IMAIN,*)
+ write(IMAIN,*) 'approximate total memory size that will be used by the solver for all the slices = ', &
+ NPROCTOT*memory_size/1024./1024.,' Mb'
+ write(IMAIN,*) 'i.e. = ',NPROCTOT*memory_size/1024./1024./1024.,' Gb'
+#else
+!! DK DK this line is completely useless and meaningless but I put it to
+!! DK DK avoid a compiler warning about an unused variable
+ memory_size = NPROCTOT
+#endif
+ write(IMAIN,*)
+ endif
+
+! open(unit=IOUT,file=prname(1:len_trim(prname))//'database.dat',status='unknown')
+ open(unit=IOUT,file=prname(1:len_trim(prname))//'database.dat',status='unknown',form='unformatted')
+
+! write real numbers here
+ write(IOUT) xix
+ write(IOUT) xiy
+ write(IOUT) xiz
+ write(IOUT) etax
+ write(IOUT) etay
+ write(IOUT) etaz
+ write(IOUT) gammax
+ write(IOUT) gammay
+ write(IOUT) gammaz
+ write(IOUT) kappav
+ write(IOUT) muv
+
+! write an integer here
+ write(IOUT) ibool
+
+! store the mass matrix
+ write(IOUT) rmass
+
+! store the coordinates of the mesh
+ write(IOUT) xstore
+ write(IOUT) ystore
+ write(IOUT) zstore
+
+! do ispec = 1,NSPEC
+! do k=1,NGLLZ
+! do j=1,NGLLY
+! do i=1,NGLLX
+! write real numbers here
+! write(IOUT,*) xix(i,j,k,ispec)
+! write(IOUT,*) xiy(i,j,k,ispec)
+! write(IOUT,*) xiz(i,j,k,ispec)
+! write(IOUT,*) etax(i,j,k,ispec)
+! write(IOUT,*) etay(i,j,k,ispec)
+! write(IOUT,*) etaz(i,j,k,ispec)
+! write(IOUT,*) gammax(i,j,k,ispec)
+! write(IOUT,*) gammay(i,j,k,ispec)
+! write(IOUT,*) gammaz(i,j,k,ispec)
+! write(IOUT,*) kappav(i,j,k,ispec)
+! write(IOUT,*) muv(i,j,k,ispec)
+
+! write an integer here
+! write(IOUT,*) ibool(i,j,k,ispec)
+! enddo
+! enddo
+! enddo
+! enddo
+
+! store the mass matrix
+! do i = 1,nglob
+! write(IOUT,*) rmass(i)
+! enddo
+
+ close(IOUT)
+
+ end subroutine save_arrays_solver
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/save_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/save_header_file.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/save_header_file.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,483 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! save header file OUTPUT_FILES/values_from_mesher.h
+
+ subroutine save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ ELLIPTICITY,GRAVITY,ROTATION,ATTENUATION,ATTENUATION_3D, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,NCHUNKS, &
+ INCLUDE_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,NSOURCES,NSTEP,&
+ static_memory_size,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NSPEC2D_TOP,NSPEC2D_BOTTOM, &
+ NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX, &
+ NPROC_XI,NPROC_ETA, &
+ NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC, nglob
+
+ integer NEX_XI,NEX_ETA,NPROC,NPROCTOT,NCHUNKS,NSOURCES,NSTEP
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ ELLIPTICITY,GRAVITY,ROTATION,ATTENUATION,ATTENUATION_3D,INCLUDE_CENTRAL_CUBE
+
+ double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES, &
+ CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH
+
+ double precision :: subtract_central_cube_elems,subtract_central_cube_points
+
+ character(len=150) HEADER_FILE
+
+! for regional code
+ double precision x,y,gamma,rgt,xi,eta
+ double precision x_top,y_top,z_top
+ double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
+
+! rotation matrix from Euler angles
+ integer i,j,ix,iy,icorner
+ double precision rotation_matrix(3,3)
+ double precision vector_ori(3),vector_rotated(3)
+ double precision r_corner,theta_corner,phi_corner,lat,long,colat_corner
+
+! static memory size needed by the solver
+ double precision :: static_memory_size
+
+ integer :: att1,att2,att3,att4,att5,NCORNERSCHUNKS,NUM_FACES,NUM_MSG_TYPES
+
+ integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NSPEC2D_TOP,NSPEC2D_BOTTOM,NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX
+ integer :: NPROC_XI,NPROC_ETA
+
+ integer :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION, &
+ NSPEC2D_MOHO, NSPEC2D_400, NSPEC2D_670, NSPEC2D_CMB, NSPEC2D_ICB
+
+! copy number of elements and points in an include file for the solver
+ call get_value_string(HEADER_FILE, 'solver.HEADER_FILE', 'OUTPUT_FILES/values_from_mesher.h')
+ open(unit=IOUT,file=HEADER_FILE,status='unknown')
+ write(IOUT,*)
+
+ write(IOUT,*) '!'
+ write(IOUT,*) '! this is the parameter file for static compilation of the solver'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! mesh statistics:'
+ write(IOUT,*) '! ---------------'
+ write(IOUT,*) '!'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! number of chunks = ',NCHUNKS
+ write(IOUT,*) '!'
+
+! the central cube is counted 6 times, therefore remove 5 times
+ if(INCLUDE_CENTRAL_CUBE) then
+ write(IOUT,*) '! these statistics include the central cube'
+ subtract_central_cube_elems = 5.d0 * dble((NEX_XI/8))**3
+ subtract_central_cube_points = 5.d0 * (dble(NEX_XI/8)*dble(NGLLX-1)+1.d0)**3
+ else
+ write(IOUT,*) '! these statistics do not include the central cube'
+ subtract_central_cube_elems = 0.d0
+ subtract_central_cube_points = 0.d0
+ endif
+
+ write(IOUT,*) '!'
+ write(IOUT,*) '! number of processors = ',NPROCTOT
+ write(IOUT,*) '!'
+ write(IOUT,*) '! total elements per slice = ',NSPEC(IREGION_CRUST_MANTLE)
+ write(IOUT,*) '! total points per slice = ',NGLOB(IREGION_CRUST_MANTLE)
+ 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 in MB = ',static_memory_size/1048576.d0
+ write(IOUT,*) '! (max size at CCRT/GPU in Paris is 4000 MB)'
+ write(IOUT,*) '! size of static arrays per slice in GB = ',static_memory_size/1073741824.d0
+ write(IOUT,*) '! (max size at CCRT/GPU in Paris is 4 GB)'
+ write(IOUT,*) '! i.e. ',sngl(100.d0*static_memory_size/1073741824.d0/4.d0),'% of the 4GB at CCRT/GPU in Paris'
+ write(IOUT,*) '!'
+! write(IOUT,*) '! (should be below and typically equal to 80% of 1.5 GB = 1.2 GB on pangu'
+! write(IOUT,*) '! at Caltech, and below and typically equal to 85% of 2 GB = 1.7 GB'
+! write(IOUT,*) '! in Barcelona)'
+! write(IOUT,*) '! (if significantly more, the job will not run by lack of memory)'
+! write(IOUT,*) '! (if significantly less, you waste a significant amount of memory)'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! size of static arrays for all slices = ',static_memory_size*dble(NPROCTOT)/1073741824.d0,' GB'
+ write(IOUT,*) '! = ',static_memory_size*dble(NPROCTOT)/1099511627776.d0,' TB'
+ write(IOUT,*) '!'
+
+ write(IOUT,*)
+ write(IOUT,*) 'integer, parameter :: NEX_XI_VAL = ',NEX_XI
+ write(IOUT,*) 'integer, parameter :: NEX_ETA_VAL = ',NEX_ETA
+ write(IOUT,*)
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE = ',NSPEC(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE = ',NSPEC(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE = ',NSPEC(IREGION_INNER_CORE)
+ write(IOUT,*)
+ write(IOUT,*) 'integer, parameter :: NGLOB_CRUST_MANTLE = ',nglob(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NGLOB_OUTER_CORE = ',nglob(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NGLOB_INNER_CORE = ',nglob(IREGION_INNER_CORE)
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPECMAX_ANISO_IC = ',NSPECMAX_ANISO_IC
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPECMAX_ISO_MANTLE = ',NSPECMAX_ISO_MANTLE
+ write(IOUT,*) 'integer, parameter :: NSPECMAX_TISO_MANTLE = ',NSPECMAX_TISO_MANTLE
+ write(IOUT,*) 'integer, parameter :: NSPECMAX_ANISO_MANTLE = ',NSPECMAX_ANISO_MANTLE
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_ATTENUAT = ',NSPEC_CRUST_MANTLE_ATTENUAT
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_ATTENUATION = ',NSPEC_INNER_CORE_ATTENUATION
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_STR_OR_ATT = ',NSPEC_CRUST_MANTLE_STR_OR_ATT
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_STR_OR_ATT = ',NSPEC_INNER_CORE_STR_OR_ATT
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_STR_AND_ATT = ',NSPEC_CRUST_MANTLE_STR_AND_ATT
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_STR_AND_ATT = ',NSPEC_INNER_CORE_STR_AND_ATT
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_STRAIN_ONLY = ',NSPEC_CRUST_MANTLE_STRAIN_ONLY
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_STRAIN_ONLY = ',NSPEC_INNER_CORE_STRAIN_ONLY
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_ADJOINT = ',NSPEC_CRUST_MANTLE_ADJOINT
+ write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE_ADJOINT = ',NSPEC_OUTER_CORE_ADJOINT
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_ADJOINT = ',NSPEC_INNER_CORE_ADJOINT
+
+ write(IOUT,*) 'integer, parameter :: NGLOB_CRUST_MANTLE_ADJOINT = ',NGLOB_CRUST_MANTLE_ADJOINT
+ write(IOUT,*) 'integer, parameter :: NGLOB_OUTER_CORE_ADJOINT = ',NGLOB_OUTER_CORE_ADJOINT
+ write(IOUT,*) 'integer, parameter :: NGLOB_INNER_CORE_ADJOINT = ',NGLOB_INNER_CORE_ADJOINT
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE_ROT_ADJOINT = ',NSPEC_OUTER_CORE_ROT_ADJOINT
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_STACEY = ',NSPEC_CRUST_MANTLE_STACEY
+ write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE_STACEY = ',NSPEC_OUTER_CORE_STACEY
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NGLOB_CRUST_MANTLE_OCEANS = ',NGLOB_CRUST_MANTLE_OCEANS
+ write(IOUT,*)
+
+! this to allow for code elimination by compiler in solver for performance
+
+ if(TRANSVERSE_ISOTROPY) then
+ write(IOUT,*) 'logical, parameter :: TRANSVERSE_ISOTROPY_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: TRANSVERSE_ISOTROPY_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ANISOTROPIC_3D_MANTLE) then
+ write(IOUT,*) 'logical, parameter :: ANISOTROPIC_3D_MANTLE_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ANISOTROPIC_3D_MANTLE_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ANISOTROPIC_INNER_CORE) then
+ write(IOUT,*) 'logical, parameter :: ANISOTROPIC_INNER_CORE_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ANISOTROPIC_INNER_CORE_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ATTENUATION) then
+ write(IOUT,*) 'logical, parameter :: ATTENUATION_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ATTENUATION_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ATTENUATION_3D) then
+ write(IOUT,*) 'logical, parameter :: ATTENUATION_3D_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ATTENUATION_3D_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ELLIPTICITY) then
+ write(IOUT,*) 'logical, parameter :: ELLIPTICITY_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ELLIPTICITY_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(GRAVITY) then
+ write(IOUT,*) 'logical, parameter :: GRAVITY_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: GRAVITY_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ROTATION) then
+ write(IOUT,*) 'logical, parameter :: ROTATION_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ROTATION_VAL = .false.'
+ endif
+ write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE_ROTATION = ',NSPEC_OUTER_CORE_ROTATION
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NGLOB1D_RADIAL_CM = ',NGLOB1D_RADIAL(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NGLOB1D_RADIAL_OC = ',NGLOB1D_RADIAL(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NGLOB1D_RADIAL_IC = ',NGLOB1D_RADIAL(IREGION_INNER_CORE)
+
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XMIN_XMAX_CM = ',NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XMIN_XMAX_OC = ',NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XMIN_XMAX_IC = ',NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE)
+
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_YMIN_YMAX_CM = ',NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_YMIN_YMAX_OC = ',NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_YMIN_YMAX_IC = ',NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE)
+
+ write(IOUT,*) 'integer, parameter :: NPROC_XI_VAL = ',NPROC_XI
+ write(IOUT,*) 'integer, parameter :: NPROC_ETA_VAL = ',NPROC_ETA
+ write(IOUT,*) 'integer, parameter :: NCHUNKS_VAL = ',NCHUNKS
+ write(IOUT,*) 'integer, parameter :: NPROCTOT_VAL = ',NPROCTOT
+
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XY_VAL = ', &
+ 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
+ endif
+
+ write(IOUT,*) 'integer, parameter :: NUMMSGS_FACES_VAL = ',NPROC_XI*NUM_FACES*NUM_MSG_TYPES
+ write(IOUT,*) 'integer, parameter :: NCORNERSCHUNKS_VAL = ',NCORNERSCHUNKS
+
+ if(ATTENUATION) then
+ if(ATTENUATION_3D) then
+ att1 = NGLLX
+ att2 = NGLLY
+ att3 = NGLLZ
+ att4 = NSPEC(IREGION_CRUST_MANTLE)
+ att5 = NSPEC(IREGION_INNER_CORE)
+ else
+ att1 = 1
+ att2 = 1
+ att3 = 1
+ att4 = NRAD_ATTENUATION
+ att5 = NRAD_ATTENUATION
+ endif
+ else
+ att1 = 1
+ att2 = 1
+ att3 = 1
+ att4 = 1
+ att5 = 1
+ endif
+
+ write(IOUT,*) 'integer, parameter :: ATT1 = ',att1
+ write(IOUT,*) 'integer, parameter :: ATT2 = ',att2
+ write(IOUT,*) 'integer, parameter :: ATT3 = ',att3
+ write(IOUT,*) 'integer, parameter :: ATT4 = ',att4
+ write(IOUT,*) 'integer, parameter :: ATT5 = ',att5
+
+ write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_XMIN_XMAX_CM = ',NSPEC2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_YMIN_YMAX_CM = ',NSPEC2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_BOTTOM_CM = ',NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_TOP_CM = ',NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_XMIN_XMAX_IC = ',NSPEC2DMAX_XMIN_XMAX(IREGION_INNER_CORE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_YMIN_YMAX_IC = ',NSPEC2DMAX_YMIN_YMAX(IREGION_INNER_CORE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_BOTTOM_IC = ',NSPEC2D_BOTTOM(IREGION_INNER_CORE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_TOP_IC = ',NSPEC2D_TOP(IREGION_INNER_CORE)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_XMIN_XMAX_OC = ',NSPEC2DMAX_XMIN_XMAX(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_YMIN_YMAX_OC = ',NSPEC2DMAX_YMIN_YMAX(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_BOTTOM_OC = ',NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_TOP_OC = ',NSPEC2D_TOP(IREGION_OUTER_CORE)
+
+ ! for boundary kernels
+
+ if (SAVE_BOUNDARY_MESH) then
+ NSPEC2D_MOHO = NSPEC2D_TOP(IREGION_CRUST_MANTLE)
+ NSPEC2D_400 = NSPEC2D_MOHO / 4
+ NSPEC2D_670 = NSPEC2D_400
+ NSPEC2D_CMB = NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE)
+ NSPEC2D_ICB = NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
+ else
+ NSPEC2D_MOHO = 1
+ NSPEC2D_400 = 1
+ NSPEC2D_670 = 1
+ NSPEC2D_CMB = 1
+ NSPEC2D_ICB = 1
+ endif
+
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_MOHO = ',NSPEC2D_MOHO
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_400 = ',NSPEC2D_400
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_670 = ',NSPEC2D_670
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_CMB = ',NSPEC2D_CMB
+ write(IOUT,*) 'integer, parameter :: NSPEC2D_ICB = ',NSPEC2D_ICB
+
+ close(IOUT)
+
+ end subroutine save_header_file
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/sea99_s_model.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/sea99_s_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/sea99_s_model.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,157 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+subroutine read_sea99_s_model(SEA99M_V)
+
+ implicit none
+
+ include "constants.h"
+
+! sea99_s_model_variables
+ type sea99_s_model_variables
+ sequence
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ end type sea99_s_model_variables
+
+ type (sea99_s_model_variables) SEA99M_V
+! sea99_s_model_variables
+
+ integer :: i,ia,io,j
+
+!----------------------- choose input file: ------------------
+! relative anomaly
+
+
+ open(1,file='DATA/Lebedev_sea99/sea99_dvsvs')
+
+!----------------------- read input file: ------------------
+
+ do i = 1, 6
+ read(1,*)
+ enddo
+ read(1,*) SEA99M_V%sea99_ndep
+ read(1,*) (SEA99M_V%sea99_depth(i), i = 1, SEA99M_V%sea99_ndep)
+ read(1,*)
+ read(1,*) SEA99M_V%alatmin, SEA99M_V%alatmax
+ read(1,*) SEA99M_V%alonmin, SEA99M_V%alonmax
+ read(1,*) SEA99M_V%sea99_ddeg,SEA99M_V%sea99_nlat,SEA99M_V%sea99_nlon
+ if (SEA99M_V%sea99_nlat /= 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 sea99_s_model(radius,theta,phi,dvs,SEA99M_V)
+
+ implicit none
+
+ include "constants.h"
+
+! sea99_s_model_variables
+ type sea99_s_model_variables
+ sequence
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ end type sea99_s_model_variables
+
+ type (sea99_s_model_variables) SEA99M_V
+! sea99_s_model_variables
+
+ integer :: id1,i,ilat,ilon
+ double precision :: alat1,alon1,radius,theta,phi,dvs
+ double precision :: xxx,yyy,dep,pla,plo,xd1,dd1,dd2,ddd(2)
+ !----------------------- depth in the model ------------------
+ dep=R_EARTH_KM*(R_UNIT_SPHERE - radius)
+ pla=90.0d0 - theta/DEGREES_TO_RADIANS
+ plo=phi/DEGREES_TO_RADIANS
+ if (dep .le. SEA99M_V%sea99_depth(1)) then
+ id1 = 1
+ xd1 = 0
+ else if (dep .ge. SEA99M_V%sea99_depth(SEA99M_V%sea99_ndep)) then
+ id1 = SEA99M_V%sea99_ndep
+ xd1 = 0
+ else
+ do i = 2, SEA99M_V%sea99_ndep
+ if (dep .le. SEA99M_V%sea99_depth(i)) then
+ id1 = i-1
+ xd1 = (dep-SEA99M_V%sea99_depth(i-1)) / (SEA99M_V%sea99_depth(i) - SEA99M_V%sea99_depth(i-1))
+ go to 1
+ endif
+ enddo
+ endif
+1 continue
+
+!----------------------- value at a point ---------------------
+!----- approximate interpolation, OK for the (dense) 1-degree sampling ------
+
+ ilat = int((pla - SEA99M_V%alatmin)/SEA99M_V%sea99_ddeg) + 1
+ ilon = int((plo - SEA99M_V%alonmin)/SEA99M_V%sea99_ddeg) + 1
+ alat1 = SEA99M_V%alatmin + (ilat-1)*SEA99M_V%sea99_ddeg
+ alon1 = SEA99M_V%alonmin + (ilon-1)*SEA99M_V%sea99_ddeg
+
+ do i = 1, 2
+ xxx = (pla-alat1)/SEA99M_V%sea99_ddeg
+ yyy = SEA99M_V%sea99_vs(ilat+1,ilon,id1+i-1)-SEA99M_V%sea99_vs(ilat,ilon,id1+i-1)
+ dd1 = SEA99M_V%sea99_vs(ilat,ilon,id1+i-1) + yyy*xxx
+ yyy = SEA99M_V%sea99_vs(ilat+1,ilon+1,id1+i-1)-SEA99M_V%sea99_vs(ilat,ilon+1,id1+i-1)
+ dd2 = SEA99M_V%sea99_vs(ilat,ilon+1,id1+i-1) + yyy*xxx
+ xxx = (plo-alon1)/SEA99M_V%sea99_ddeg
+ yyy = dd2 - dd1
+ ddd(i) = dd1 + yyy*xxx
+ enddo
+ dvs = ddd(1) + (ddd(2)-ddd(1)) * xd1
+ if(dvs>1.d0) dvs=0.0d0
+
+end subroutine sea99_s_model
+
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/sort_array_coordinates.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/sort_array_coordinates.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/sort_array_coordinates.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,235 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! subroutines to sort MPI buffers to assemble between chunks
+
+ subroutine sort_array_coordinates(npointot,x,y,z,ibool,iglob,loc,ifseg,nglob,ind,ninseg,iwork,work)
+
+! this routine MUST be in double precision to avoid sensitivity
+! to roundoff errors in the coordinates of the points
+
+ implicit none
+
+ include "constants.h"
+
+ integer npointot,nglob
+
+ integer ibool(npointot),iglob(npointot),loc(npointot)
+ integer ind(npointot),ninseg(npointot)
+ logical ifseg(npointot)
+ double precision x(npointot),y(npointot),z(npointot)
+ integer iwork(npointot)
+ double precision work(npointot)
+
+ integer ipoin,i,j
+ integer nseg,ioff,iseg,ig
+ double precision xtol
+
+! establish initial pointers
+ do ipoin=1,npointot
+ loc(ipoin)=ipoin
+ enddo
+
+! define a tolerance, normalized radius is 1., so let's use a small value
+ xtol = SMALLVALTOL
+
+ ifseg(:)=.false.
+
+ nseg=1
+ ifseg(1)=.true.
+ ninseg(1)=npointot
+
+ do j=1,NDIM
+
+! sort within each segment
+ ioff=1
+ do iseg=1,nseg
+ if(j == 1) then
+
+ call rank_buffers(x(ioff),ind,ninseg(iseg))
+
+ else if(j == 2) then
+
+ call rank_buffers(y(ioff),ind,ninseg(iseg))
+
+ else
+
+ call rank_buffers(z(ioff),ind,ninseg(iseg))
+
+ endif
+
+ call swap_all_buffers(ibool(ioff),loc(ioff), &
+ x(ioff),y(ioff),z(ioff),iwork,work,ind,ninseg(iseg))
+
+ ioff=ioff+ninseg(iseg)
+ enddo
+
+! check for jumps in current coordinate
+ if(j == 1) then
+ do i=2,npointot
+ if(dabs(x(i)-x(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ else if(j == 2) then
+ do i=2,npointot
+ if(dabs(y(i)-y(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ else
+ do i=2,npointot
+ if(dabs(z(i)-z(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ endif
+
+! count up number of different segments
+ nseg=0
+ do i=1,npointot
+ if(ifseg(i)) then
+ nseg=nseg+1
+ ninseg(nseg)=1
+ else
+ ninseg(nseg)=ninseg(nseg)+1
+ endif
+ enddo
+ enddo
+
+! assign global node numbers (now sorted lexicographically)
+ ig=0
+ do i=1,npointot
+ if(ifseg(i)) ig=ig+1
+ iglob(loc(i))=ig
+ enddo
+
+ nglob=ig
+
+ end subroutine sort_array_coordinates
+
+! -------------------- library for sorting routine ------------------
+
+! sorting routines put here in same file to allow for inlining
+
+ subroutine rank_buffers(A,IND,N)
+!
+! Use Heap Sort (Numerical Recipes)
+!
+ implicit none
+
+ integer n
+ double precision A(n)
+ integer IND(n)
+
+ integer i,j,l,ir,indx
+ double precision q
+
+ do j=1,n
+ IND(j)=j
+ enddo
+
+ if(n == 1) return
+
+ L=n/2+1
+ ir=n
+ 100 CONTINUE
+ IF(l>1) THEN
+ l=l-1
+ indx=ind(l)
+ q=a(indx)
+ ELSE
+ indx=ind(ir)
+ q=a(indx)
+ ind(ir)=ind(1)
+ ir=ir-1
+ if (ir == 1) then
+ ind(1)=indx
+ return
+ endif
+ ENDIF
+ i=l
+ j=l+l
+ 200 CONTINUE
+ IF(J <= IR) THEN
+ IF(J < IR) THEN
+ IF(A(IND(j)) < A(IND(j+1))) j=j+1
+ ENDIF
+ IF (q < A(IND(j))) THEN
+ IND(I)=IND(J)
+ I=J
+ J=J+J
+ ELSE
+ J=IR+1
+ ENDIF
+ goto 200
+ ENDIF
+ IND(I)=INDX
+ goto 100
+ end subroutine rank_buffers
+
+! -------------------------------------------------------------------
+
+ subroutine swap_all_buffers(IA,IB,A,B,C,IW,W,ind,n)
+!
+! swap arrays IA, IB, A, B and C according to addressing in array IND
+!
+ implicit none
+
+ integer n
+
+ integer IND(n)
+ integer IA(n),IB(n),IW(n)
+ double precision A(n),B(n),C(n),W(n)
+
+ integer i
+
+ do i=1,n
+ W(i)=A(i)
+ IW(i)=IA(i)
+ enddo
+
+ do i=1,n
+ A(i)=W(ind(i))
+ IA(i)=IW(ind(i))
+ enddo
+
+ do i=1,n
+ W(i)=B(i)
+ IW(i)=IB(i)
+ enddo
+
+ do i=1,n
+ B(i)=W(ind(i))
+ IB(i)=IW(ind(i))
+ enddo
+
+ do i=1,n
+ W(i)=C(i)
+ enddo
+
+ do i=1,n
+ C(i)=W(ind(i))
+ enddo
+
+ end subroutine swap_all_buffers
+
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/spline_routines.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/spline_routines.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/spline_routines.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,130 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! compute spline coefficients
+
+ subroutine spline_construction(xpoint,ypoint,npoint,tangent_first_point,tangent_last_point,spline_coefficients)
+
+ implicit none
+
+! tangent to the spline imposed at the first and last points
+ double precision, intent(in) :: tangent_first_point,tangent_last_point
+
+! number of input points and coordinates of the input points
+ integer, intent(in) :: npoint
+ double precision, dimension(npoint), intent(in) :: xpoint,ypoint
+
+! spline coefficients output by the routine
+ double precision, dimension(npoint), intent(out) :: spline_coefficients
+
+ integer :: i
+
+ double precision, dimension(:), allocatable :: temporary_array
+
+ allocate(temporary_array(npoint))
+
+ spline_coefficients(1) = - 1.d0 / 2.d0
+
+ temporary_array(1) = (3.d0/(xpoint(2)-xpoint(1)))*((ypoint(2)-ypoint(1))/(xpoint(2)-xpoint(1))-tangent_first_point)
+
+ do i = 2,npoint-1
+
+ spline_coefficients(i) = ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))-1.d0) &
+ / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)
+
+ temporary_array(i) = (6.d0*((ypoint(i+1)-ypoint(i))/(xpoint(i+1)-xpoint(i)) &
+ - (ypoint(i)-ypoint(i-1))/(xpoint(i)-xpoint(i-1)))/(xpoint(i+1)-xpoint(i-1)) &
+ - (xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*temporary_array(i-1)) &
+ / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)
+
+ enddo
+
+ spline_coefficients(npoint) = ((3.d0/(xpoint(npoint)-xpoint(npoint-1))) &
+ * (tangent_last_point-(ypoint(npoint)-ypoint(npoint-1))/(xpoint(npoint)-xpoint(npoint-1))) &
+ - 1.d0/2.d0*temporary_array(npoint-1))/(1.d0/2.d0*spline_coefficients(npoint-1)+1.d0)
+
+ do i = npoint-1,1,-1
+ spline_coefficients(i) = spline_coefficients(i)*spline_coefficients(i+1) + temporary_array(i)
+ enddo
+
+ deallocate(temporary_array)
+
+ end subroutine spline_construction
+
+! --------------
+
+! evaluate a spline
+
+ subroutine spline_evaluation(xpoint,ypoint,spline_coefficients,npoint,x_evaluate_spline,y_spline_obtained)
+
+ implicit none
+
+! number of input points and coordinates of the input points
+ integer, intent(in) :: npoint
+ double precision, dimension(npoint), intent(in) :: xpoint,ypoint
+
+! spline coefficients to use
+ double precision, dimension(npoint), intent(in) :: spline_coefficients
+
+! abscissa at which we need to evaluate the value of the spline
+ double precision, intent(in):: x_evaluate_spline
+
+! ordinate evaluated by the routine for the spline at this abscissa
+ double precision, intent(out):: y_spline_obtained
+
+ integer :: index_loop,index_lower,index_higher
+
+ double precision :: coef1,coef2
+
+! initialize to the whole interval
+ index_lower = 1
+ index_higher = npoint
+
+! determine the right interval to use, by dichotomy
+ do while (index_higher - index_lower > 1)
+! compute the middle of the interval
+ index_loop = (index_higher + index_lower) / 2
+ if(xpoint(index_loop) > x_evaluate_spline) then
+ index_higher = index_loop
+ else
+ index_lower = index_loop
+ endif
+ enddo
+
+! test that the interval obtained does not have a size of zero
+! (this could happen for instance in the case of duplicates in the input list of points)
+ if(xpoint(index_higher) == xpoint(index_lower)) stop 'incorrect interval found in spline evaluation'
+
+ coef1 = (xpoint(index_higher) - x_evaluate_spline) / (xpoint(index_higher) - xpoint(index_lower))
+ coef2 = (x_evaluate_spline - xpoint(index_lower)) / (xpoint(index_higher) - xpoint(index_lower))
+
+ y_spline_obtained = coef1*ypoint(index_lower) + coef2*ypoint(index_higher) + &
+ ((coef1**3 - coef1)*spline_coefficients(index_lower) + &
+ (coef2**3 - coef2)*spline_coefficients(index_higher))*((xpoint(index_higher) - xpoint(index_lower))**2)/6.d0
+
+ end subroutine spline_evaluation
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/stretching_function.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/stretching_function.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/stretching_function.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,75 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+subroutine stretching_function(r_top,r_bottom,ner,stretch_tab)
+
+! define stretch_tab which contains r_top and r_bottom for each element layer in the crust for 3D models.
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: r_top, r_bottom,value
+ integer :: ner,i
+ double precision, dimension (2,ner) :: stretch_tab
+! for increasing execution speed but have less precision in stretching, increase step
+! not very effective algorithm, but sufficient : used once per proc for meshing.
+ double precision, parameter :: step = 0.001
+
+! initialize array
+ do i=1,ner
+ stretch_tab(2,i)=(1.d0/ner)
+ enddo
+
+! fill with ratio of the layer one thickness for each element
+ do while((stretch_tab(2,1) / stretch_tab(2,ner)) > MAX_RATIO_CRUST_STRETCHING)
+ if (modulo(ner,2) /= 0) then
+ value = -floor(ner/2.d0)*step
+ else
+ value = (0.5d0-floor(ner/2.d0))*step
+ endif
+ do i=1,ner
+ stretch_tab(2,i) = stretch_tab(2,i) + value
+ value = value + step
+ enddo
+ enddo
+
+! deduce r_top and r_bottom
+ ! r_top
+ stretch_tab(1,1) = r_top
+ do i=2,ner
+ stretch_tab(1,i) = sum(stretch_tab(2,i:ner))*(r_top-r_bottom) + r_bottom
+ enddo
+
+ ! r_bottom
+ stretch_tab(2,ner) = r_bottom
+ do i=1,ner-1
+ stretch_tab(2,i) = stretch_tab(1,i+1)
+ enddo
+
+end subroutine stretching_function
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/topo_bathy.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/topo_bathy.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/topo_bathy.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,106 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_topo_bathy(xlat,xlon,value,ibathy_topo)
+
+!
+!---- get elevation or ocean depth in meters at a given latitude and longitude
+!
+
+ implicit none
+
+ include "constants.h"
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+ double precision xlat,xlon,value
+
+ integer iadd1,iel1
+ double precision samples_per_degree_topo
+ double precision xlo
+
+ xlo = xlon
+ if(xlon < 0.d0) xlo = xlo + 360.d0
+
+! compute number of samples per degree
+ samples_per_degree_topo = dble(RESOLUTION_TOPO_FILE) / 60.d0
+
+! compute offset in data file and avoid edge effects
+ iadd1 = 1 + int((90.d0-xlat)/samples_per_degree_topo)
+ if(iadd1 < 1) iadd1 = 1
+ if(iadd1 > NY_BATHY) iadd1 = NY_BATHY
+
+ iel1 = int(xlo/samples_per_degree_topo)
+ if(iel1 <= 0 .or. iel1 > NX_BATHY) iel1 = NX_BATHY
+
+! convert integer value to double precision
+ value = dble(ibathy_topo(iel1,iadd1))
+
+ end subroutine get_topo_bathy
+
+! -------------------------------------------
+
+ subroutine read_topo_bathy_file(ibathy_topo)
+!
+!---- read topography and bathymetry file once and for all
+!
+ implicit none
+
+ include "constants.h"
+
+ character(len=150) topo_bathy_file
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+ integer itopo_x,itopo_y
+
+ call get_value_string(topo_bathy_file, 'model.topoBathy.PATHNAME_TOPO_FILE', PATHNAME_TOPO_FILE)
+
+ open(unit=13,file=topo_bathy_file,status='old',action='read')
+
+ do itopo_y=1,NY_BATHY
+ do itopo_x=1,NX_BATHY
+
+ read(13,*) ibathy_topo(itopo_x,itopo_y)
+
+! impose maximum height of mountains, to suppress oscillations in Himalaya etc.
+ if(USE_MAXIMUM_HEIGHT_TOPO .and. ibathy_topo(itopo_x,itopo_y) > MAXIMUM_HEIGHT_TOPO) &
+ ibathy_topo(itopo_x,itopo_y) = MAXIMUM_HEIGHT_TOPO
+
+! impose maximum depth of oceans, to suppress oscillations near deep trenches
+ if(USE_MAXIMUM_DEPTH_OCEANS .and. ibathy_topo(itopo_x,itopo_y) < MAXIMUM_DEPTH_OCEANS) &
+ ibathy_topo(itopo_x,itopo_y) = MAXIMUM_DEPTH_OCEANS
+
+ enddo
+ enddo
+
+ close(13)
+
+ end subroutine read_topo_bathy_file
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/write_AVS_DX_global_chunks_data.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/write_AVS_DX_global_chunks_data.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/write_AVS_DX_global_chunks_data.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,705 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! create 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,CRUSTAL,ONE_CRUST,REFERENCE_1D_MODEL, &
+ RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
+ RMIDDLE_CRUST,ROCEAN,M1066a_V,Mak135_V,Mref_V,SEA1DM_V)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank,REFERENCE_1D_MODEL
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer idoubling(nspec)
+
+ logical iboun(6,nspec),ELLIPTICITY,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST
+
+ 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
+
+! model_1066a_variables
+ type model_1066a_variables
+ sequence
+ double precision, dimension(NR_1066A) :: radius_1066a
+ double precision, dimension(NR_1066A) :: density_1066a
+ double precision, dimension(NR_1066A) :: vp_1066a
+ double precision, dimension(NR_1066A) :: vs_1066a
+ double precision, dimension(NR_1066A) :: Qkappa_1066a
+ double precision, dimension(NR_1066A) :: Qmu_1066a
+ end type model_1066a_variables
+
+ type (model_1066a_variables) M1066a_V
+! model_1066a_variables
+
+! model_ak135_variables
+ type model_ak135_variables
+ sequence
+ double precision, dimension(NR_AK135) :: radius_ak135
+ double precision, dimension(NR_AK135) :: density_ak135
+ double precision, dimension(NR_AK135) :: vp_ak135
+ double precision, dimension(NR_AK135) :: vs_ak135
+ double precision, dimension(NR_AK135) :: Qkappa_ak135
+ double precision, dimension(NR_AK135) :: Qmu_ak135
+ end type model_ak135_variables
+
+ type (model_ak135_variables) Mak135_V
+! model_ak135_variables
+
+! model_ref_variables
+ type model_ref_variables
+ sequence
+ double precision, dimension(NR_REF) :: radius_ref
+ double precision, dimension(NR_REF) :: density_ref
+ double precision, dimension(NR_REF) :: vpv_ref
+ double precision, dimension(NR_REF) :: vph_ref
+ double precision, dimension(NR_REF) :: vsv_ref
+ double precision, dimension(NR_REF) :: vsh_ref
+ double precision, dimension(NR_REF) :: eta_ref
+ double precision, dimension(NR_REF) :: Qkappa_ref
+ double precision, dimension(NR_REF) :: Qmu_ref
+ end type model_ref_variables
+
+ type (model_ref_variables) Mref_V
+! model_ref_variables
+
+! sea1d_model_variables
+ type sea1d_model_variables
+ sequence
+ double precision, dimension(NR_SEA1D) :: radius_sea1d
+ double precision, dimension(NR_SEA1D) :: density_sea1d
+ double precision, dimension(NR_SEA1D) :: vp_sea1d
+ double precision, dimension(NR_SEA1D) :: vs_sea1d
+ double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
+ double precision, dimension(NR_SEA1D) :: Qmu_sea1d
+ end type sea1d_model_variables
+
+ type (sea1d_model_variables) SEA1DM_V
+! sea1d_model_variables
+
+! 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
+
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
+ call model_iasp91(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec),ONE_CRUST, &
+ .true.,RICB,RCMB,RTOPDDOUBLEPRIME,R771,R670,R400,R220,R120,RMOHO,RMIDDLE_CRUST)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
+ call prem_iso(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec), &
+ CRUSTAL,ONE_CRUST,.true.,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
+ call model_1066a(r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec),M1066a_V)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
+ call model_ak135(r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec),Mak135_V)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
+ call model_ref(r,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu,idoubling(ispec),CRUSTAL,Mref_V)
+ vp = vpv
+ vs = vsv
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then
+ call model_jp1d(myrank,r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec), &
+ .true.,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST)
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
+ call model_sea1d(r,rho,vp,vs,Qkappa,Qmu,idoubling(ispec),SEA1DM_V)
+ else
+ call exit_MPI(myrank,'unknown 1D reference Earth model in writing of AVS/DX data')
+ endif
+
+ 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)
+ 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
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/write_AVS_DX_global_data.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/write_AVS_DX_global_data.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/write_AVS_DX_global_data.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -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 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! create 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
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/write_AVS_DX_global_faces_data.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/write_AVS_DX_global_faces_data.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/write_AVS_DX_global_faces_data.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,351 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! 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)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer idoubling(nspec)
+
+ logical iMPIcut_xi(2,nspec)
+ logical iMPIcut_eta(2,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,nspecface,ispecface
+
+! processor identification
+ character(len=150) prname
+
+! 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')
+
+! 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)
+
+! 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)
+ 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)
+ 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)
+ 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)
+ 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)
+
+ end subroutine write_AVS_DX_global_faces_data
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/write_AVS_DX_surface_data.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/write_AVS_DX_surface_data.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/mesher_for_serial/write_AVS_DX_surface_data.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,191 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! create 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)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer idoubling(nspec)
+
+ 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)
+
+! 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, dimension(8) :: iglobval
+ integer npoin,numpoin,nspecface,ispecface
+
+! processor identification
+ character(len=150) prname
+
+! 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')
+
+! 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)
+
+! 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))
+
+ 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)
+
+ end subroutine write_AVS_DX_surface_data
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/plotall.gnu
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/plotall.gnu (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/plotall.gnu 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,14 @@
+
+#set xrange [0:2000]
+
+#plot "seismogram_F90.txt" w l 1, "seismogram_C_single_correct.txt" w l 3, "seismogram_C_single.txt" w l 4
+plot "seismogram_C_single.txt" w l 1, "seismogram_C_single_correct.txt" w l 3
+
+pause -1 "Hit any key..."
+
+plot "seismogram_C_single.txt" w l 1
+pause -1 "Hit any key..."
+
+plot "seismogram_C_single_correct.txt" w l 3
+pause -1 "Hit any key..."
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/read_arrays_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/read_arrays_solver.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/read_arrays_solver.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,236 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, read to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!! DK DK read binary unformatted arrays in Fortran format because they are faster
+!! DK DK and smaller to use in the mesher, which is written in Fortran.
+
+!! DK DK permutation of indices from Fortran order to C order is done automatically
+!! DK DK (more precisely there is nothing to do) because these arrays are declared
+!! DK DK with an inverted order of indices in the main calling program in C
+
+ subroutine read_arrays_solver(xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ kappav,muv,ibool,rmass,myrank,xstore,ystore,zstore)
+
+ implicit none
+
+ include "DATABASES_FOR_SOLVER/values_from_mesher_f90.h"
+
+ integer, parameter :: NGLLX = 5
+ integer, parameter :: NGLLY = 5
+ integer, parameter :: NGLLZ = 5
+
+ integer, parameter :: NGLL2 = NGLLX * NGLLX
+ integer, parameter :: NGLL3 = NGLLX * NGLLX * NGLLX ! do not align for the regular C version for CPUs
+
+! use single precision
+ integer, parameter :: CUSTOM_REAL = 4
+
+! only one region: crust_mantle
+ integer, parameter :: iregion_code = 1
+
+! unit to access the file
+ integer, parameter :: IOUT = 56
+
+ integer :: myrank,i,j,k,ispec
+
+! arrays with jacobian matrix
+ real(kind=CUSTOM_REAL), dimension(NGLL3*NSPEC) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,kappav,muv
+
+ integer ibool(NGLL3*NSPEC)
+
+! temporary arrays to convert from four indices: NGLLX,NGLLY,NGLLZ,NSPEC
+! to only one index: NGLL3*NSPEC, and with padding to align memory
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: dummy_float_read
+ integer dummy_int_read(NGLLX,NGLLY,NGLLZ,NSPEC)
+! we can use the same temporary memory space to save space
+ equivalence(dummy_float_read, dummy_int_read)
+
+! mass matrix
+ real(kind=CUSTOM_REAL) rmass(nglob)
+
+! 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)
+
+! processor identification
+ character(len=250) prname
+
+! create the name for the database of the current slide and region
+ write(prname,"('DATABASES_FOR_SOLVER/proc',i6.6,'_reg',i1,'_')") myrank,iregion_code
+
+ open(unit=IOUT,file=prname(1:len_trim(prname))//'database.dat',status='old',action='read',form='unformatted')
+
+! read real numbers here
+ read(IOUT) dummy_float_read
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+! indices start at 1 in Fortran and 0 in C therefore we subtract 1 to all
+! the indices in this formula to convert to a linear offset
+ xix((ispec-1)*NGLL3+(k-1)*NGLL2+(j-1)*NGLLX+i-1+1) = dummy_float_read(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ read(IOUT) dummy_float_read
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ xiy((ispec-1)*NGLL3+(k-1)*NGLL2+(j-1)*NGLLX+i-1+1) = dummy_float_read(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ read(IOUT) dummy_float_read
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ xiz((ispec-1)*NGLL3+(k-1)*NGLL2+(j-1)*NGLLX+i-1+1) = dummy_float_read(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ read(IOUT) dummy_float_read
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ etax((ispec-1)*NGLL3+(k-1)*NGLL2+(j-1)*NGLLX+i-1+1) = dummy_float_read(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ read(IOUT) dummy_float_read
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ etay((ispec-1)*NGLL3+(k-1)*NGLL2+(j-1)*NGLLX+i-1+1) = dummy_float_read(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ read(IOUT) dummy_float_read
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ etaz((ispec-1)*NGLL3+(k-1)*NGLL2+(j-1)*NGLLX+i-1+1) = dummy_float_read(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ read(IOUT) dummy_float_read
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ gammax((ispec-1)*NGLL3+(k-1)*NGLL2+(j-1)*NGLLX+i-1+1) = dummy_float_read(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ read(IOUT) dummy_float_read
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ gammay((ispec-1)*NGLL3+(k-1)*NGLL2+(j-1)*NGLLX+i-1+1) = dummy_float_read(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ read(IOUT) dummy_float_read
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ gammaz((ispec-1)*NGLL3+(k-1)*NGLL2+(j-1)*NGLLX+i-1+1) = dummy_float_read(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ read(IOUT) dummy_float_read
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ kappav((ispec-1)*NGLL3+(k-1)*NGLL2+(j-1)*NGLLX+i-1+1) = dummy_float_read(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ read(IOUT) dummy_float_read
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ muv((ispec-1)*NGLL3+(k-1)*NGLL2+(j-1)*NGLLX+i-1+1) = dummy_float_read(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+! read an integer here
+ read(IOUT) dummy_int_read
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ibool((ispec-1)*NGLL3+(k-1)*NGLL2+(j-1)*NGLLX+i-1+1) = dummy_int_read(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+! read the mass matrix
+ read(IOUT) rmass
+
+! read the coordinates of the mesh
+ read(IOUT) xstore
+ read(IOUT) ystore
+ read(IOUT) zstore
+
+ close(IOUT)
+
+ end subroutine read_arrays_solver
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_double.c
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_double.c (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_double.c 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,510 @@
+
+/*
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+*/
+
+//
+// All the arrays below use static memory allocation,
+// using constant sizes defined in values_from_mesher.h.
+// This is done purposely to improve performance (Fortran compilers
+// can optimize much more when the size of the loops and arrays
+// is known at compile time).
+// NGLLX, NGLLY and NGLLZ are set equal to 5,
+// therefore each element contains NGLLX * NGLLY * NGLLZ = 125 points.
+//
+
+//
+// All the calculations are done in single precision.
+// We do not need double precision in SPECFEM3D.
+//
+
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <time.h>
+
+// include values created by the mesher
+// done for performance only using static allocation to allow for loop unrolling
+#include "DATABASES_FOR_SOLVER/values_from_mesher_C.h"
+
+// constant value of the time step in the main time loop
+#define deltatover2 0.5*deltat
+#define deltatsqover2 0.5*deltat*deltat
+
+// for the source time function
+#define pi 3.14159265
+#define f0 (1. / 50.)
+#define t0 (1.2 / f0)
+#define a pi*pi*f0*f0
+
+// number of GLL integration points in each direction of an element (degree plus one)
+#define NGLLX 5
+#define NGLLY 5
+#define NGLLZ 5
+
+// 3-D simulation
+#define NDIM 3
+
+// displacement threshold above which we consider that the code became unstable
+#define STABILITY_THRESHOLD 1.e+25
+
+#define VERYSMALLVAL 1.e-24
+#define NTSTEP_BETWEEN_OUTPUT_INFO 100
+
+// approximate density of the geophysical medium in which the source is located
+// this value is only a constant scaling factor therefore it does not really matter
+#define rho 4500.
+
+int main(int argc, char *argv[])
+{
+
+// global displacement, velocity and acceleration vectors
+ static double displ[NGLOB][NDIM];
+ static double veloc[NGLOB][NDIM];
+ static double accel[NGLOB][NDIM];
+
+// global diagonal mass matrix
+ static double rmass_inverse[NGLOB];
+
+// record a seismogram to check that the simulation went well
+ static double seismogram[NSTEP];
+
+// arrays with mesh parameters per slice
+ static int ibool[NSPEC][NGLLZ][NGLLY][NGLLX];
+
+ static double xix[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static double xiy[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static double xiz[NSPEC][NGLLZ][NGLLY][NGLLX];
+
+ static double etax[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static double etay[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static double etaz[NSPEC][NGLLZ][NGLLY][NGLLX];
+
+ static double gammax[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static double gammay[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static double gammaz[NSPEC][NGLLZ][NGLLY][NGLLX];
+
+ static double kappav[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static double muv[NSPEC][NGLLZ][NGLLY][NGLLX];
+
+ static double dummyx_loc[NGLLZ][NGLLY][NGLLX];
+ static double dummyy_loc[NGLLZ][NGLLY][NGLLX];
+ static double dummyz_loc[NGLLZ][NGLLY][NGLLX];
+
+// array with derivatives of Lagrange polynomials and precalculated products
+ static double hprime_xx[NGLLX][NGLLX];
+ static double hprimewgll_xx[NGLLX][NGLLX];
+ static double wgllwgll_xy[NGLLY][NGLLX];
+ static double wgllwgll_xz[NGLLZ][NGLLX];
+ static double wgllwgll_yz[NGLLZ][NGLLY];
+
+ static double tempx1[NGLLZ][NGLLY][NGLLX];
+ static double tempx2[NGLLZ][NGLLY][NGLLX];
+ static double tempx3[NGLLZ][NGLLY][NGLLX];
+ static double tempy1[NGLLZ][NGLLY][NGLLX];
+ static double tempy2[NGLLZ][NGLLY][NGLLX];
+ static double tempy3[NGLLZ][NGLLY][NGLLX];
+ static double tempz1[NGLLZ][NGLLY][NGLLX];
+ static double tempz2[NGLLZ][NGLLY][NGLLX];
+ static double tempz3[NGLLZ][NGLLY][NGLLX];
+
+// time step
+ int it;
+
+ clock_t timeloop_begin;
+ float timeloop_total;
+
+ int ispec,iglob,i,j,k,l;
+
+ double xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl;
+ double duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl;
+ double duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl;
+ double duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl;
+ double sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz;
+ double hp1,hp2,hp3,fac1,fac2,fac3,lambdal,mul,lambdalplus2mul,kappal;
+ double tempx1l,tempx2l,tempx3l,tempy1l,tempy2l,tempy3l,tempz1l,tempz2l,tempz3l;
+
+ double Usolidnorm,current_value,time,memory_size;
+
+// to read external files
+ FILE *IIN;
+
+// estimate of total memory size used
+ printf("\nNSPEC = %d\n",NSPEC);
+ printf("NGLOB = %d\n\n",NGLOB);
+ printf("NSTEP = %d\n",NSTEP);
+ printf("deltat = %lf\n\n",deltat);
+
+// estimate total memory size (the size of a real number is 4 bytes)
+// we perform the calculation in single precision rather than integer
+// to avoid integer overflow in the case of very large meshes
+ memory_size = 4. * ((3.*NDIM + 1.) * NGLOB + 12. * (double)(NGLLX*NGLLY*NGLLZ)*(double)(NSPEC));
+ printf("approximate total memory size used = %lf Mb\n\n",memory_size/1024./1024.);
+
+// make sure the source element number is an integer
+ if(NSPEC % 2 != 0) {
+ fprintf(stderr,"source element number is not an integer, exiting...\n");
+ exit(1);
+ }
+
+ printf("reading file DATABASES_FOR_SOLVER/proc000000_reg1_database.dat\n");
+// read the mesh from external file
+ if((IIN=fopen("DATABASES_FOR_SOLVER/proc000000_reg1_database.dat","r"))==NULL) {
+ fprintf(stderr,"Cannot open file DATABASES_FOR_SOLVER/proc000000_reg1_database.dat, exiting...\n");
+ exit(1);
+ }
+
+ for (ispec=0;ispec<NSPEC;ispec++) {
+ for (k=0;k<NGLLZ;k++) {
+ for (j=0;j<NGLLY;j++) {
+ for (i=0;i<NGLLX;i++) {
+// read real numbers here
+ fscanf(IIN, "%le\n", &xix[ispec][k][j][i]);
+ fscanf(IIN, "%le\n", &xiy[ispec][k][j][i]);
+ fscanf(IIN, "%le\n", &xiz[ispec][k][j][i]);
+ fscanf(IIN, "%le\n", &etax[ispec][k][j][i]);
+ fscanf(IIN, "%le\n", &etay[ispec][k][j][i]);
+ fscanf(IIN, "%le\n", &etaz[ispec][k][j][i]);
+ fscanf(IIN, "%le\n", &gammax[ispec][k][j][i]);
+ fscanf(IIN, "%le\n", &gammay[ispec][k][j][i]);
+ fscanf(IIN, "%le\n", &gammaz[ispec][k][j][i]);
+ fscanf(IIN, "%le\n", &kappav[ispec][k][j][i]);
+ fscanf(IIN, "%le\n", &muv[ispec][k][j][i]);
+
+// read an integer here
+ fscanf(IIN, "%d\n", &ibool[ispec][k][j][i]);
+// subtract one because indices start at zero in C but this array was created by a Fortran
+// program and therefore starts at one in the file stored on the disk
+ ibool[ispec][k][j][i]--;
+ }
+ }
+ }
+ }
+ for (i=0;i<NGLOB;i++) {
+ fscanf(IIN, "%le\n", &rmass_inverse[i]);
+// the real exactly diagonal mass matrix is read (not its inverse)
+// therefore invert it here once and for all
+ rmass_inverse[i] = 1.f / rmass_inverse[i];
+ }
+ fclose(IIN);
+
+ printf("reading file DATABASES_FOR_SOLVER/matrices.dat\n");
+// read the derivation matrices from external file
+ if((IIN=fopen("DATABASES_FOR_SOLVER/matrices.dat","r"))==NULL) {
+ fprintf(stderr,"Cannot open file DATABASES_FOR_SOLVER/matrices.dat, exiting...\n");
+ exit(1);
+ }
+
+ for (j=0;j<NGLLY;j++) {
+ for (i=0;i<NGLLX;i++) {
+ fscanf(IIN, "%le\n", &hprime_xx[j][i]);
+ fscanf(IIN, "%le\n", &hprimewgll_xx[j][i]);
+ fscanf(IIN, "%le\n", &wgllwgll_yz[j][i]);
+ fscanf(IIN, "%le\n", &wgllwgll_xz[j][i]);
+ fscanf(IIN, "%le\n", &wgllwgll_xy[j][i]);
+ }
+ }
+ fclose(IIN);
+
+// clear initial vectors before starting the time loop
+// (can remain serial because done only once before entering the time loop)
+ for (i=0;i<NGLOB;i++) {
+ displ[i][0] = 1; // VERYSMALLVAL;
+ displ[i][1] = 1; // VERYSMALLVAL;
+ displ[i][2] = 1; // VERYSMALLVAL;
+
+ veloc[i][0] = 1; // 0.;
+ veloc[i][1] = 1; // 0.;
+ veloc[i][2] = 1; // 0.;
+
+ accel[i][0] = 1; // 0.;
+ accel[i][1] = 1; // 0.;
+ accel[i][2] = 1; // 0.;
+ }
+
+ printf("starting the time loop\n");
+
+ timeloop_begin = clock();
+
+// start of the time loop (which must remain serial obviously)
+ for (it=1;it<=NSTEP;it++) {
+
+// compute maximum of norm of displacement from time to time and display it
+// in order to monitor the simulation
+// this can remain serial because it is done only every 200 time steps
+ if((it % NTSTEP_BETWEEN_OUTPUT_INFO) == 0 || it == 5 || it == NSTEP) {
+
+ Usolidnorm = -1.;
+
+ for (iglob = 0; iglob < NGLOB; iglob++) {
+ current_value = sqrt(displ[iglob][0]*displ[iglob][0] + displ[iglob][1]*displ[iglob][1] + displ[iglob][2]*displ[iglob][2]);
+ if(current_value > Usolidnorm) { Usolidnorm = current_value; }
+ }
+
+ printf("\nTime step # %d out of %d\n",it,NSTEP);
+// compute current time
+ time = (it-1)*deltat;
+ printf("Max norm displacement vector U in the solid (m) = %.8g\n",Usolidnorm);
+ timeloop_total = ((clock()-timeloop_begin)/(float)CLOCKS_PER_SEC);
+ printf("Total elapsed time so far: %f\n",timeloop_total);
+ if (it>100) {
+ printf("Average elapsed time per time step: %f\n",timeloop_total/(float)(it-1));
+ }
+// check stability of the code, exit if unstable
+ if(Usolidnorm > STABILITY_THRESHOLD || Usolidnorm < 0) {
+ fprintf(stderr,"code became unstable and blew up\n");
+ exit(1);
+ }
+ }
+
+// big loop over all the global points (not elements) in the mesh to update
+// the displacement and velocity vectors and clear the acceleration vector
+ for (i=0;i<NGLOB;i++) {
+ displ[i][0] += deltat*veloc[i][0] + deltatsqover2*accel[i][0];
+ displ[i][1] += deltat*veloc[i][1] + deltatsqover2*accel[i][1];
+ displ[i][2] += deltat*veloc[i][2] + deltatsqover2*accel[i][2];
+
+ veloc[i][0] += deltatover2*accel[i][0];
+ veloc[i][1] += deltatover2*accel[i][1];
+ veloc[i][2] += deltatover2*accel[i][2];
+
+ accel[i][0] = 0.;
+ accel[i][1] = 0.;
+ accel[i][2] = 0.;
+ }
+
+// big loop over all the elements in the mesh to localize data
+// from the global vectors to the local mesh
+// using indirect addressing (contained in array ibool)
+// and then to compute the elemental contribution
+// to the acceleration vector of each element of the finite-element mesh
+ for (ispec=0;ispec<NSPEC;ispec++) {
+
+ for (k=0;k<NGLLZ;k++) {
+ for (j=0;j<NGLLY;j++) {
+ for (i=0;i<NGLLX;i++) {
+ iglob = ibool[ispec][k][j][i];
+ dummyx_loc[k][j][i] = displ[iglob][0];
+ dummyy_loc[k][j][i] = displ[iglob][1];
+ dummyz_loc[k][j][i] = displ[iglob][2];
+ }
+ }
+ }
+
+// big loop over all the elements in the mesh to compute the elemental contribution
+// to the acceleration vector of each element of the finite-element mesh
+
+ for (k=0;k<NGLLZ;k++) {
+ for (j=0;j<NGLLY;j++) {
+ for (i=0;i<NGLLX;i++) {
+
+ tempx1l = 0.;
+ tempx2l = 0.;
+ tempx3l = 0.;
+
+ tempy1l = 0.;
+ tempy2l = 0.;
+ tempy3l = 0.;
+
+ tempz1l = 0.;
+ tempz2l = 0.;
+ tempz3l = 0.;
+
+ for (l=0;l<NGLLX;l++) {
+ hp1 = hprime_xx[l][i];
+ tempx1l += dummyx_loc[k][j][l]*hp1;
+ tempy1l += dummyy_loc[k][j][l]*hp1;
+ tempz1l += dummyz_loc[k][j][l]*hp1;
+
+ hp2 = hprime_xx[l][j];
+ tempx2l += dummyx_loc[k][l][i]*hp2;
+ tempy2l += dummyy_loc[k][l][i]*hp2;
+ tempz2l += dummyz_loc[k][l][i]*hp2;
+
+ hp3 = hprime_xx[l][k];
+ tempx3l += dummyx_loc[l][j][i]*hp3;
+ tempy3l += dummyy_loc[l][j][i]*hp3;
+ tempz3l += dummyz_loc[l][j][i]*hp3;
+ }
+
+// compute derivatives of ux, uy and uz with respect to x, y and z
+ xixl = xix[ispec][k][j][i];
+ xiyl = xiy[ispec][k][j][i];
+ xizl = xiz[ispec][k][j][i];
+ etaxl = etax[ispec][k][j][i];
+ etayl = etay[ispec][k][j][i];
+ etazl = etaz[ispec][k][j][i];
+ gammaxl = gammax[ispec][k][j][i];
+ gammayl = gammay[ispec][k][j][i];
+ gammazl = gammaz[ispec][k][j][i];
+ jacobianl = 1. / (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 isotropic elements
+ kappal = kappav[ispec][k][j][i];
+ mul = muv[ispec][k][j][i];
+
+ lambdalplus2mul = kappal + (4./3.) * 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;
+
+// form dot product with test vector
+ tempx1[k][j][i] = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl);
+ tempy1[k][j][i] = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl);
+ tempz1[k][j][i] = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl);
+
+ tempx2[k][j][i] = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl);
+ tempy2[k][j][i] = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl);
+ tempz2[k][j][i] = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl);
+
+ tempx3[k][j][i] = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl);
+ tempy3[k][j][i] = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl);
+ tempz3[k][j][i] = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl);
+
+ }
+ }
+ }
+
+ for (k=0;k<NGLLZ;k++) {
+ for (j=0;j<NGLLY;j++) {
+ for (i=0;i<NGLLX;i++) {
+
+ tempx1l = 0.;
+ tempy1l = 0.;
+ tempz1l = 0.;
+
+ tempx2l = 0.;
+ tempy2l = 0.;
+ tempz2l = 0.;
+
+ tempx3l = 0.;
+ tempy3l = 0.;
+ tempz3l = 0.;
+
+ for (l=0;l<NGLLX;l++) {
+ fac1 = hprimewgll_xx[i][l];
+ tempx1l += tempx1[k][j][l]*fac1;
+ tempy1l += tempy1[k][j][l]*fac1;
+ tempz1l += tempz1[k][j][l]*fac1;
+
+ fac2 = hprimewgll_xx[j][l];
+ tempx2l += tempx2[k][l][i]*fac2;
+ tempy2l += tempy2[k][l][i]*fac2;
+ tempz2l += tempz2[k][l][i]*fac2;
+
+ fac3 = hprimewgll_xx[k][l];
+ tempx3l += tempx3[l][j][i]*fac3;
+ tempy3l += tempy3[l][j][i]*fac3;
+ tempz3l += tempz3[l][j][i]*fac3;
+ }
+
+ fac1 = wgllwgll_yz[k][j];
+ fac2 = wgllwgll_xz[k][i];
+ fac3 = wgllwgll_xy[j][i];
+
+// sum contributions from each element to the global mesh using indirect addressing
+ iglob = ibool[ispec][k][j][i];
+ accel[iglob][0] -= (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l);
+ accel[iglob][1] -= (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l);
+ accel[iglob][2] -= (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l);
+
+ }
+ }
+ }
+
+ } // end of main loop on all the elements
+
+// big loop over all the global points (not elements) in the mesh to update
+// the acceleration and velocity vectors
+ for (i=0;i<NGLOB;i++) {
+ accel[i][0] *= rmass_inverse[i];
+ accel[i][1] *= rmass_inverse[i];
+ accel[i][2] *= rmass_inverse[i];
+ }
+
+// add the earthquake source at a given grid point
+// this is negligible and is intrinsically serial because it is done by only
+// one grid point out of several millions typically
+// we subtract one to the element number of the source because arrays start at 0 in C
+// compute current time
+ time = (it-1)*deltat;
+ accel[ibool[NSPEC_SOURCE-1][1][1][1]][2] += 1.e4 * (1.-2.*a*(time-t0)*(time-t0)) * exp(-a*(time-t0)*(time-t0)) / rho;
+
+ for (i=0;i<NGLOB;i++) {
+ veloc[i][0] += deltatover2*accel[i][0];
+ veloc[i][1] += deltatover2*accel[i][1];
+ veloc[i][2] += deltatover2*accel[i][2];
+ }
+
+// record a seismogram to check that the simulation went well
+// we subtract one to the element number of the receiver because arrays start at 0 in C
+ seismogram[it-1] = displ[ibool[NSPEC_STATION-1][1][1][1]][2];
+
+ } // end of the serial time loop
+
+// save the seismogram at the end of the run
+ if((IIN = fopen("seismogram_C_double.txt","w")) == NULL) {
+ fprintf(stderr,"Cannot open file seismogram_C_double.txt, exiting...\n");
+ exit(1);
+ }
+ for (it=0;it<NSTEP;it++)
+ { fprintf(IIN,"%e %e\n",(float)(it*deltat),(float)seismogram[it]);
+ }
+ fclose(IIN);
+
+ printf("\nEnd of the program\n\n");
+
+ }
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_inlined_v03_is_the_fastest_no_more_function_calls.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_inlined_v03_is_the_fastest_no_more_function_calls.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_inlined_v03_is_the_fastest_no_more_function_calls.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,867 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ program serial_specfem3D
+
+ implicit none
+
+!!!!!!!!!!
+!!!!!!!!!! All the arrays below use static memory allocation,
+!!!!!!!!!! using constant sizes defined in values_from_mesher.h.
+!!!!!!!!!! This is done purposely to improve performance (Fortran compilers
+!!!!!!!!!! can optimize much more when the size of the loops and arrays
+!!!!!!!!!! is known at compile time).
+!!!!!!!!!! NGLLX, NGLLY and NGLLZ are set equal to 5,
+!!!!!!!!!! therefore each element contains NGLLX * NGLLY * NGLLZ = 125 points.
+!!!!!!!!!!
+
+!!!!!!!!!!
+!!!!!!!!!! All the calculations are done in single precision.
+!!!!!!!!!! We do not need double precision in SPECFEM3D.
+!!!!!!!!!!
+
+ include "constants.h"
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "DATABASES_FOR_SOLVER/values_from_mesher_f90.h"
+
+! constant value of the time step in the main time loop
+ real(kind=4), parameter :: deltatover2 = 0.5*deltat, deltatsqover2 = 0.5*deltat*deltat
+
+! for the source time function
+ real, parameter :: pi = 3.141592653589793
+ real, parameter :: f0 = 1. / 50.
+ real, parameter :: t0 = 1.2 / f0
+ real, parameter :: a = pi*pi*f0*f0
+
+ integer, parameter :: NTSTEP_BETWEEN_OUTPUT_INFO = 1000
+
+ integer, parameter :: IIN = 40
+
+! 3-D simulation
+ integer, parameter :: NDIM = 3
+
+!!!!!!!!!! real(kind=4), parameter :: VERYSMALLVAL = 1.e-24
+
+! displacement threshold above which we consider that the code became unstable
+ real(kind=4), parameter :: STABILITY_THRESHOLD = 1.e+25
+
+! approximate density of the geophysical medium in which the source is located
+! this value is only a constant scaling factor therefore it does not really matter
+ real(kind=4), parameter :: rho = 4500.
+
+! global displacement, velocity and acceleration vectors
+ real(kind=4), dimension(NDIM,NGLOB) :: displ,veloc,accel
+
+! global diagonal mass matrix
+ real(kind=4), dimension(NGLOB) :: rmass_inverse
+
+! record a seismogram to check that the simulation went well
+ real(kind=4), dimension(NSTEP) :: seismogram_x,seismogram_y,seismogram_z
+
+! 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 :: dist,distmin
+
+! time step
+ integer it
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: ibool
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,kappav,muv
+
+! array with derivatives of Lagrange polynomials and precalculated products
+! also store transpose of matrix
+ real(kind=4), dimension(NGLLX,NGLLX) :: hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT
+ real(kind=4), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=4), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=4), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
+ newtempx1,newtempx2,newtempx3,newtempy1,newtempy2,newtempy3,newtempz1,newtempz2,newtempz3
+
+ integer :: ispec,iglob,i,j,k !!!!!!!!!!!!! ,l
+
+ real(kind=4) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=4) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+ real(kind=4) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=4) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+ real(kind=4) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz,sigma_yx,sigma_zx,sigma_zy
+! real(kind=4) hp1,hp2,hp3
+ real(kind=4) fac1,fac2,fac3,lambdal,mul,lambdalplus2mul,kappal
+! real(kind=4) tempx1l,tempx2l,tempx3l,tempy1l,tempy2l,tempy3l,tempz1l,tempz2l,tempz3l
+
+ real(kind=4) Usolidnorm,current_value,time,memory_size
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc
+
+! manually inline the calls to the Deville et al. (2002) routines
+ real(kind=4), dimension(NGLLX,m2) :: B1_m1_m2_5points,B2_m1_m2_5points,B3_m1_m2_5points
+ real(kind=4), dimension(m1,m2) :: C1_m1_m2_5points,C2_m1_m2_5points,C3_m1_m2_5points
+ real(kind=4), 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=4), dimension(m2,NGLLX) :: A1_mxm_m2_m1_5points,A2_mxm_m2_m1_5points,A3_mxm_m2_m1_5points
+ real(kind=4), dimension(m2,m1) :: C1_mxm_m2_m1_5points,C2_mxm_m2_m1_5points,C3_mxm_m2_m1_5points
+ real(kind=4), 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)
+
+! timer to count elapsed time
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+ integer ihours,iminutes,iseconds,int_tCPU
+ double precision :: time_start,time_end,tCPU
+
+ integer, parameter :: myrank = 0
+
+ integer :: ix_source,iy_source,iz_source,nspec_source_to_use
+ integer :: ix_station,iy_station,iz_station,nspec_station_to_use
+
+ double precision, parameter :: x_target_source = 0.483972800858796d0
+ double precision, parameter :: y_target_source = -0.483972800858796d0
+ double precision, parameter :: z_target_source = 0.664256180122661d0
+
+ double precision, parameter :: x_target_station = -0.434342247909227d0
+ double precision, parameter :: y_target_station = 0.384622712535266d0
+ double precision, parameter :: z_target_station = 0.804378489723495d0
+
+! estimate of total memory size used
+ print *
+ print *,'NSPEC = ',NSPEC
+ print *,'NGLOB = ',NGLOB
+ print *
+
+ print *,'NSTEP = ',NSTEP
+ print *,'deltat = ',deltat
+ print *
+
+! estimate total memory size (the size of a real number is 4 bytes)
+! we perform the calculation in single precision rather than integer
+! to avoid integer overflow in the case of very large meshes
+ memory_size = 4. * ((3.*NDIM + 1.) * NGLOB + 12. * real(NGLLX*NGLLY*NGLLZ)*real(NSPEC))
+ print *,'approximate total memory size used = ',memory_size/1024./1024.,' Mb'
+ print *
+
+! make sure the source element number is an integer
+ if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...'
+
+! read the mesh from external file
+ call read_arrays_solver(xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ kappav,muv,ibool,rmass_inverse,myrank,xstore,ystore,zstore)
+
+! the real exactly diagonal mass matrix is read (not its inverse)
+! therefore invert it here once and for all
+ do i = 1,NGLOB
+ rmass_inverse(i) = 1. / rmass_inverse(i)
+ enddo
+
+ open(unit=IIN,file='DATABASES_FOR_SOLVER/matrices.dat',status='old')
+ do j=1,NGLLY
+ do i=1,NGLLX
+ read(IIN,*) hprime_xx(i,j)
+ read(IIN,*) hprimewgll_xx(i,j)
+ read(IIN,*) wgllwgll_yz(i,j)
+ read(IIN,*) wgllwgll_xz(i,j)
+ read(IIN,*) wgllwgll_xy(i,j)
+ enddo
+ enddo
+ close(IIN)
+
+! define transpose of 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
+
+ if(NGLLX /= 5) stop 'this inlined version with matrix products following Deville (2002) is only valid for NGLL = 5'
+
+!! DK DK original source and receiver to use
+! ix_source = 2
+! iy_source = 2
+! iz_source = 2
+! nspec_source_to_use = NSPEC_SOURCE
+
+! ix_station = 2
+! iy_station = 2
+! iz_station = 2
+! nspec_station_to_use = NSPEC_STATION
+
+!! DK DK now look for the right point to use in the mesh for the source
+
+! set distance to huge initial value
+ distmin = HUGEVAL
+
+ nspec_source_to_use = 0
+
+ do ispec = 1,NSPEC
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+! keep this point if it is closer to the source
+ dist = dsqrt((x_target_source-xstore(i,j,k,ispec))**2 &
+ + (y_target_source-ystore(i,j,k,ispec))**2 &
+ + (z_target_source-zstore(i,j,k,ispec))**2)
+ if(dist < distmin) then
+ distmin = dist
+ nspec_source_to_use = ispec
+ ix_source = i
+ iy_source = j
+ iz_source = k
+ endif
+
+ enddo
+ enddo
+ enddo
+
+! end of loop on all the elements in the mesh
+ enddo
+
+ print *
+ print *,'found source at distance = ',distmin
+ print *,'at point i,j,k,ispec = ',ix_source,iy_source,iz_source,nspec_source_to_use
+
+!! DK DK now look for the right point to use in the mesh for the station
+
+! set distance to huge initial value
+ distmin = HUGEVAL
+
+ nspec_station_to_use = 0
+
+ do ispec = 1,NSPEC
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+! keep this point if it is closer to the station
+ dist = dsqrt((x_target_station-xstore(i,j,k,ispec))**2 &
+ + (y_target_station-ystore(i,j,k,ispec))**2 &
+ + (z_target_station-zstore(i,j,k,ispec))**2)
+ if(dist < distmin) then
+ distmin = dist
+ nspec_station_to_use = ispec
+ ix_station = i
+ iy_station = j
+ iz_station = k
+ endif
+
+ enddo
+ enddo
+ enddo
+
+! end of loop on all the elements in the mesh
+ enddo
+
+ print *
+ print *,'found station at distance = ',distmin
+ print *,'at point i,j,k,ispec = ',ix_station,iy_station,iz_station,nspec_station_to_use
+
+! clear initial vectors before starting the time loop
+! (can remain serial because done only once before entering the time loop)
+ displ(:,:) = 0. !!!!!!!!!! VERYSMALLVAL
+ veloc(:,:) = 0.
+ accel(:,:) = 0.
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! start of the time loop (which must remain serial obviously)
+ do it = 1,NSTEP
+
+! compute maximum of norm of displacement from time to time and display it
+! in order to monitor the simulation
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
+ Usolidnorm = -1.
+ do iglob = 1,NGLOB
+ current_value = sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2)
+ if(current_value > Usolidnorm) Usolidnorm = current_value
+ enddo
+ write(*,*) 'Time step # ',it,' out of ',NSTEP
+! compute current time
+ time = (it-1)*deltat
+ write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm
+! check stability of the code, exit if unstable
+ if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up'
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! elapsed time since beginning of the simulation
+ tCPU = time_end - time_start
+ int_tCPU = int(tCPU)
+ ihours = int_tCPU / 3600
+ iminutes = (int_tCPU - 3600*ihours) / 60
+ iseconds = int_tCPU - 3600*ihours - 60*iminutes
+ write(*,*) 'Elapsed time in seconds = ',tCPU
+ write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ write(*,*)
+
+ endif
+
+! big loop over all the global points (not elements) in the mesh to update
+! the displacement and velocity vectors and clear the acceleration vector
+ displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsqover2*accel(:,:)
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+ accel(:,:) = 0.
+
+! big loop over all the elements in the mesh to localize data
+! from the global vectors to the local mesh
+! using indirect addressing (contained in array ibool)
+! and then to compute the elemental contribution
+! to the acceleration vector of each element of the finite-element mesh
+ do ispec = 1,NSPEC
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ dummyx_loc(i,j,k) = displ(1,iglob)
+ dummyy_loc(i,j,k) = displ(2,iglob)
+ dummyz_loc(i,j,k) = displ(3,iglob)
+ enddo
+ enddo
+ enddo
+
+! 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
+! call mxm_m1_m2_5points(hprime_xx,dummyx_loc,dummyy_loc,dummyz_loc,tempx1,tempy1,tempz1)
+ 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
+
+! call mxm_m1_m1_5points(dummyx_loc(1,1,k),dummyy_loc(1,1,k),dummyz_loc(1,1,k), &
+! hprime_xxT,tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k))
+ 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
+
+! call mxm_m2_m1_5points(dummyx_loc,dummyy_loc,dummyz_loc,tempx3,tempy3,tempz3)
+ 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
+
+! tempx1l = 0.
+! tempx2l = 0.
+! tempx3l = 0.
+
+! tempy1l = 0.
+! tempy2l = 0.
+! tempy3l = 0.
+
+! tempz1l = 0.
+! tempz2l = 0.
+! tempz3l = 0.
+
+! do l=1,NGLLX
+! hp1 = hprime_xx(i,l)
+! tempx1l = tempx1l + dummyx_loc(l,j,k)*hp1
+! tempy1l = tempy1l + dummyy_loc(l,j,k)*hp1
+! tempz1l = tempz1l + dummyz_loc(l,j,k)*hp1
+
+! hp2 = hprime_xx(j,l)
+! tempx2l = tempx2l + dummyx_loc(i,l,k)*hp2
+! tempy2l = tempy2l + dummyy_loc(i,l,k)*hp2
+! tempz2l = tempz2l + dummyz_loc(i,l,k)*hp2
+
+! hp3 = hprime_xx(k,l)
+! tempx3l = tempx3l + dummyx_loc(i,j,l)*hp3
+! tempy3l = tempy3l + dummyy_loc(i,j,l)*hp3
+! tempz3l = tempz3l + dummyz_loc(i,j,l)*hp3
+! enddo
+
+! compute 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)
+ jacobianl = 1. / (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 isotropic elements
+ kappal = kappav(i,j,k,ispec)
+ mul = muv(i,j,k,ispec)
+
+! lambdalplus2mul = kappal + (4./3.) * mul
+! precompute the 4/3 ratio to avoid a division here
+ lambdalplus2mul = kappal + 1.33333333333333 * 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
+
+ ! define symmetric components of sigma
+ sigma_yx = sigma_xy
+ sigma_zx = sigma_xz
+ sigma_zy = sigma_yz
+
+ ! form dot product with test vector, non-symmetric form (which is useful in the case of PML)
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl) ! this goes to accel_x
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl) ! this goes to accel_y
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl) ! this goes to accel_z
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl) ! this goes to accel_x
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl) ! this goes to accel_y
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl) ! this goes to accel_z
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl) ! this goes to accel_x
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl) ! this goes to accel_y
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl) ! this goes to accel_z
+
+ 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
+! call mxm_m1_m2_5points(hprimewgll_xxT,tempx1,tempy1,tempz1,newtempx1,newtempy1,newtempz1)
+ 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
+
+! call mxm_m1_m1_5points(tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k), &
+! hprimewgll_xx,newtempx2(1,1,k),newtempy2(1,1,k),newtempz2(1,1,k))
+ 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
+
+! call mxm_m2_m1_5points(tempx3,tempy3,tempz3,hprimewgll_xx,newtempx3,newtempy3,newtempz3)
+ 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
+
+! tempx1l = 0.
+! tempy1l = 0.
+! tempz1l = 0.
+
+! tempx2l = 0.
+! tempy2l = 0.
+! tempz2l = 0.
+
+! tempx3l = 0.
+! tempy3l = 0.
+! tempz3l = 0.
+
+! 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
+
+! fac2 = hprimewgll_xx(l,j)
+! tempx2l = tempx2l + tempx2(i,l,k)*fac2
+! tempy2l = tempy2l + tempy2(i,l,k)*fac2
+! tempz2l = tempz2l + tempz2(i,l,k)*fac2
+
+! fac3 = hprimewgll_xx(l,k)
+! tempx3l = tempx3l + tempx3(i,j,l)*fac3
+! tempy3l = tempy3l + tempy3(i,j,l)*fac3
+! tempz3l = tempz3l + tempz3(i,j,l)*fac3
+! enddo
+
+! enddo
+! 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 from each element to the global mesh using indirect addressing
+ iglob = ibool(i,j,k,ispec)
+ accel(1,iglob) = accel(1,iglob) - (fac1*newtempx1(i,j,k) + fac2*newtempx2(i,j,k) + fac3*newtempx3(i,j,k))
+ accel(2,iglob) = accel(2,iglob) - (fac1*newtempy1(i,j,k) + fac2*newtempy2(i,j,k) + fac3*newtempy3(i,j,k))
+ accel(3,iglob) = accel(3,iglob) - (fac1*newtempz1(i,j,k) + fac2*newtempz2(i,j,k) + fac3*newtempz3(i,j,k))
+
+ enddo
+ enddo
+ enddo
+
+ enddo ! end of main loop on all the elements
+
+! big loop over all the global points (not elements) in the mesh to update
+! the acceleration and velocity vectors
+ accel(1,:) = accel(1,:)*rmass_inverse(:)
+ accel(2,:) = accel(2,:)*rmass_inverse(:)
+ accel(3,:) = accel(3,:)*rmass_inverse(:)
+
+! add the earthquake source at a given grid point
+! this is negligible and can remain serial because it is done by only
+! one grid point out of several millions typically
+ iglob = ibool(ix_source,iy_source,iz_source,nspec_source_to_use)
+! compute current time
+ time = (it-1)*deltat
+ accel(3,iglob) = accel(3,iglob) + 1.e4 * (1.-2.*a*(time-t0)**2) * exp(-a*(time-t0)**2) / rho
+
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+
+! record a seismogram to check that the simulation went well
+ seismogram_x(it) = displ(1,ibool(ix_station,iy_station,iz_station,nspec_station_to_use))
+ seismogram_y(it) = displ(2,ibool(ix_station,iy_station,iz_station,nspec_station_to_use))
+ seismogram_z(it) = displ(3,ibool(ix_station,iy_station,iz_station,nspec_station_to_use))
+
+ enddo ! end of the serial time loop
+
+! save the seismogram at the end of the run
+ open(unit=IIN,file='seismogram_F90.txt',status='unknown')
+ do it = 1,NSTEP
+ write(IIN,*) (it-1)*deltat,seismogram_x(it),seismogram_y(it),seismogram_z(it)
+ enddo
+ close(IIN)
+
+ end program serial_specfem3D
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! 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
+
+ subroutine old_mxm_m1_m2_5points(A,B1,B2,B3,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m1,NGLLX) :: A
+ real(kind=4), dimension(NGLLX,m2) :: B1,B2,B3
+ real(kind=4), dimension(m1,m2) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m2
+ do i=1,m1
+
+ C1(i,j) = A(i,1)*B1(1,j) + &
+ A(i,2)*B1(2,j) + &
+ A(i,3)*B1(3,j) + &
+ A(i,4)*B1(4,j) + &
+ A(i,5)*B1(5,j)
+
+ C2(i,j) = A(i,1)*B2(1,j) + &
+ A(i,2)*B2(2,j) + &
+ A(i,3)*B2(3,j) + &
+ A(i,4)*B2(4,j) + &
+ A(i,5)*B2(5,j)
+
+ C3(i,j) = A(i,1)*B3(1,j) + &
+ A(i,2)*B3(2,j) + &
+ A(i,3)*B3(3,j) + &
+ A(i,4)*B3(4,j) + &
+ A(i,5)*B3(5,j)
+
+ enddo
+ enddo
+
+ end subroutine old_mxm_m1_m2_5points
+
+!---------
+
+ subroutine old_mxm_m1_m1_5points(A1,A2,A3,B,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m1,NGLLX) :: A1,A2,A3
+ real(kind=4), dimension(NGLLX,m1) :: B
+ real(kind=4), dimension(m1,m1) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m1
+ do i=1,m1
+
+ C1(i,j) = A1(i,1)*B(1,j) + &
+ A1(i,2)*B(2,j) + &
+ A1(i,3)*B(3,j) + &
+ A1(i,4)*B(4,j) + &
+ A1(i,5)*B(5,j)
+
+ C2(i,j) = A2(i,1)*B(1,j) + &
+ A2(i,2)*B(2,j) + &
+ A2(i,3)*B(3,j) + &
+ A2(i,4)*B(4,j) + &
+ A2(i,5)*B(5,j)
+
+ C3(i,j) = A3(i,1)*B(1,j) + &
+ A3(i,2)*B(2,j) + &
+ A3(i,3)*B(3,j) + &
+ A3(i,4)*B(4,j) + &
+ A3(i,5)*B(5,j)
+
+ enddo
+ enddo
+
+ end subroutine old_mxm_m1_m1_5points
+
+!---------
+
+ subroutine old_mxm_m2_m1_5points(A1,A2,A3,B,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m2,NGLLX) :: A1,A2,A3
+ real(kind=4), dimension(NGLLX,m1) :: B
+ real(kind=4), dimension(m2,m1) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m1
+ do i=1,m2
+
+ C1(i,j) = A1(i,1)*B(1,j) + &
+ A1(i,2)*B(2,j) + &
+ A1(i,3)*B(3,j) + &
+ A1(i,4)*B(4,j) + &
+ A1(i,5)*B(5,j)
+
+ C2(i,j) = A2(i,1)*B(1,j) + &
+ A2(i,2)*B(2,j) + &
+ A2(i,3)*B(3,j) + &
+ A2(i,4)*B(4,j) + &
+ A2(i,5)*B(5,j)
+
+ C3(i,j) = A3(i,1)*B(1,j) + &
+ A3(i,2)*B(2,j) + &
+ A3(i,3)*B(3,j) + &
+ A3(i,4)*B(4,j) + &
+ A3(i,5)*B(5,j)
+
+ enddo
+ enddo
+
+ end subroutine old_mxm_m2_m1_5points
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_no_Deville.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_no_Deville.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_no_Deville.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,443 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ program serial_specfem3D
+
+ implicit none
+
+!!!!!!!!!!
+!!!!!!!!!! All the arrays below use static memory allocation,
+!!!!!!!!!! using constant sizes defined in values_from_mesher.h.
+!!!!!!!!!! This is done purposely to improve performance (Fortran compilers
+!!!!!!!!!! can optimize much more when the size of the loops and arrays
+!!!!!!!!!! is known at compile time).
+!!!!!!!!!! NGLLX, NGLLY and NGLLZ are set equal to 5,
+!!!!!!!!!! therefore each element contains NGLLX * NGLLY * NGLLZ = 125 points.
+!!!!!!!!!!
+
+!!!!!!!!!!
+!!!!!!!!!! All the calculations are done in single precision.
+!!!!!!!!!! We do not need double precision in SPECFEM3D.
+!!!!!!!!!!
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "DATABASES_FOR_SOLVER/values_from_mesher_f90.h"
+
+! constant value of the time step in the main time loop
+ real(kind=4), parameter :: deltatover2 = 0.5*deltat, deltatsqover2 = 0.5*deltat*deltat
+
+! for the source time function
+ real, parameter :: pi = 3.141592653589793
+ real, parameter :: f0 = 1. / 50.
+ real, parameter :: t0 = 1.2 / f0
+ real, parameter :: a = pi*pi*f0*f0
+
+ integer, parameter :: NTSTEP_BETWEEN_OUTPUT_INFO = 200
+
+ integer, parameter :: IIN = 40
+
+! number of GLL integration points in each direction of an element (degree plus one)
+ integer, parameter :: NGLLX = 5
+ integer, parameter :: NGLLY = NGLLX
+ integer, parameter :: NGLLZ = NGLLX
+
+! 3-D simulation
+ integer, parameter :: NDIM = 3
+
+ real(kind=4), parameter :: VERYSMALLVAL = 1.e-24
+
+! displacement threshold above which we consider that the code became unstable
+ real(kind=4), parameter :: STABILITY_THRESHOLD = 1.e+25
+
+! approximate density of the geophysical medium in which the source is located
+! this value is only a constant scaling factor therefore it does not really matter
+ real(kind=4), parameter :: rho = 4500.
+
+! global displacement, velocity and acceleration vectors
+ real(kind=4), dimension(NDIM,NGLOB) :: displ,veloc,accel
+
+! global diagonal mass matrix
+ real(kind=4), dimension(NGLOB) :: rmass_inverse
+
+! record a seismogram to check that the simulation went well
+ real(kind=4), dimension(NSTEP) :: seismogram
+
+! time step
+ integer it
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: ibool
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,kappav,muv
+
+! 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)
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=4), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=4), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=4), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=4), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+
+ integer, parameter :: myrank = 0
+
+ integer :: ispec,iglob,i,j,k,l
+
+ real(kind=4) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=4) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+ real(kind=4) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=4) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+ real(kind=4) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz,sigma_yx,sigma_zx,sigma_zy
+ real(kind=4) hp1,hp2,hp3,fac1,fac2,fac3,lambdal,mul,lambdalplus2mul,kappal
+ real(kind=4) tempx1l,tempx2l,tempx3l,tempy1l,tempy2l,tempy3l,tempz1l,tempz2l,tempz3l
+
+ real(kind=4) Usolidnorm,current_value,time,memory_size
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc
+
+! timer to count elapsed time
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+ integer ihours,iminutes,iseconds,int_tCPU
+ double precision :: time_start,time_end,tCPU
+
+! estimate of total memory size used
+ print *
+ print *,'NSPEC = ',NSPEC
+ print *,'NGLOB = ',NGLOB
+ print *
+
+ print *,'NSTEP = ',NSTEP
+ print *,'deltat = ',deltat
+ print *
+
+! estimate total memory size (the size of a real number is 4 bytes)
+! we perform the calculation in single precision rather than integer
+! to avoid integer overflow in the case of very large meshes
+ memory_size = 4. * ((3.*NDIM + 1.) * NGLOB + 12. * real(NGLLX*NGLLY*NGLLZ)*real(NSPEC))
+ print *,'approximate total memory size used = ',memory_size/1024./1024.,' Mb'
+ print *
+
+! make sure the source element number is an integer
+ if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...'
+
+! read the mesh from external file
+ call read_arrays_solver(xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ kappav,muv,ibool,rmass_inverse,myrank,xstore,ystore,zstore)
+
+! the real exactly diagonal mass matrix is read (not its inverse)
+! therefore invert it here once and for all
+ do i = 1,NGLOB
+ rmass_inverse(i) = 1. / rmass_inverse(i)
+ enddo
+
+ open(unit=IIN,file='DATABASES_FOR_SOLVER/matrices.dat',status='old')
+ do j=1,NGLLY
+ do i=1,NGLLX
+ read(IIN,*) hprime_xx(i,j)
+ read(IIN,*) hprimewgll_xx(i,j)
+ read(IIN,*) wgllwgll_yz(i,j)
+ read(IIN,*) wgllwgll_xz(i,j)
+ read(IIN,*) wgllwgll_xy(i,j)
+ enddo
+ enddo
+ close(IIN)
+
+! clear initial vectors before starting the time loop
+! (can remain serial because done only once before entering the time loop)
+ displ(:,:) = 0. !!!!!!!!!! VERYSMALLVAL
+ veloc(:,:) = 0.
+ accel(:,:) = 0.
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! start of the time loop (which must remain serial obviously)
+ do it = 1,NSTEP
+
+! compute maximum of norm of displacement from time to time and display it
+! in order to monitor the simulation
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
+ Usolidnorm = -1.
+ do iglob = 1,NGLOB
+ current_value = sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2)
+ if(current_value > Usolidnorm) Usolidnorm = current_value
+ enddo
+ write(*,*) 'Time step # ',it,' out of ',NSTEP
+! compute current time
+ time = (it-1)*deltat
+ write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm
+! check stability of the code, exit if unstable
+ if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up'
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! elapsed time since beginning of the simulation
+ tCPU = time_end - time_start
+ int_tCPU = int(tCPU)
+ ihours = int_tCPU / 3600
+ iminutes = (int_tCPU - 3600*ihours) / 60
+ iseconds = int_tCPU - 3600*ihours - 60*iminutes
+ write(*,*) 'Elapsed time in seconds = ',tCPU
+ write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ write(*,*)
+
+ endif
+
+! big loop over all the global points (not elements) in the mesh to update
+! the displacement and velocity vectors and clear the acceleration vector
+ displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsqover2*accel(:,:)
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+ accel(:,:) = 0.
+
+! big loop over all the elements in the mesh to localize data
+! from the global vectors to the local mesh
+! using indirect addressing (contained in array ibool)
+! and then to compute the elemental contribution
+! to the acceleration vector of each element of the finite-element mesh
+ do ispec = 1,NSPEC
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ dummyx_loc(i,j,k) = displ(1,iglob)
+ dummyy_loc(i,j,k) = displ(2,iglob)
+ dummyz_loc(i,j,k) = displ(3,iglob)
+ enddo
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0.
+ tempx2l = 0.
+ tempx3l = 0.
+
+ tempy1l = 0.
+ tempy2l = 0.
+ tempy3l = 0.
+
+ tempz1l = 0.
+ tempz2l = 0.
+ tempz3l = 0.
+
+ do l=1,NGLLX
+ hp1 = hprime_xx(i,l)
+ tempx1l = tempx1l + dummyx_loc(l,j,k)*hp1
+ tempy1l = tempy1l + dummyy_loc(l,j,k)*hp1
+ tempz1l = tempz1l + dummyz_loc(l,j,k)*hp1
+
+ hp2 = hprime_xx(j,l)
+ tempx2l = tempx2l + dummyx_loc(i,l,k)*hp2
+ tempy2l = tempy2l + dummyy_loc(i,l,k)*hp2
+ tempz2l = tempz2l + dummyz_loc(i,l,k)*hp2
+
+ hp3 = hprime_xx(k,l)
+ tempx3l = tempx3l + dummyx_loc(i,j,l)*hp3
+ tempy3l = tempy3l + dummyy_loc(i,j,l)*hp3
+ tempz3l = tempz3l + dummyz_loc(i,j,l)*hp3
+ enddo
+
+! compute 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)
+ jacobianl = 1. / (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 isotropic elements
+ kappal = kappav(i,j,k,ispec)
+ mul = muv(i,j,k,ispec)
+
+ lambdalplus2mul = kappal + (4./3.) * 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
+
+ ! define symmetric components of sigma
+ sigma_yx = sigma_xy
+ sigma_zx = sigma_xz
+ sigma_zy = sigma_yz
+
+ ! form dot product with test vector, non-symmetric form (which is useful in the case of PML)
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl) ! this goes to accel_x
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl) ! this goes to accel_y
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl) ! this goes to accel_z
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl) ! this goes to accel_x
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl) ! this goes to accel_y
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl) ! this goes to accel_z
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl) ! this goes to accel_x
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl) ! this goes to accel_y
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl) ! this goes to accel_z
+
+ enddo
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0.
+ tempy1l = 0.
+ tempz1l = 0.
+
+ tempx2l = 0.
+ tempy2l = 0.
+ tempz2l = 0.
+
+ tempx3l = 0.
+ tempy3l = 0.
+ tempz3l = 0.
+
+ 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
+
+ fac2 = hprimewgll_xx(l,j)
+ tempx2l = tempx2l + tempx2(i,l,k)*fac2
+ tempy2l = tempy2l + tempy2(i,l,k)*fac2
+ tempz2l = tempz2l + tempz2(i,l,k)*fac2
+
+ fac3 = hprimewgll_xx(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 contributions from each element to the global mesh using indirect addressing
+ iglob = ibool(i,j,k,ispec)
+ accel(1,iglob) = accel(1,iglob) - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
+ accel(2,iglob) = accel(2,iglob) - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
+ accel(3,iglob) = accel(3,iglob) - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
+
+ enddo
+ enddo
+ enddo
+
+ enddo ! end of main loop on all the elements
+
+! big loop over all the global points (not elements) in the mesh to update
+! the acceleration and velocity vectors
+ accel(1,:) = accel(1,:)*rmass_inverse(:)
+ accel(2,:) = accel(2,:)*rmass_inverse(:)
+ accel(3,:) = accel(3,:)*rmass_inverse(:)
+
+! add the earthquake source at a given grid point
+! this is negligible and can remain serial because it is done by only
+! one grid point out of several millions typically
+ iglob = ibool(2,2,2,NSPEC_SOURCE)
+! compute current time
+ time = (it-1)*deltat
+ accel(3,iglob) = accel(3,iglob) + 1.e4 * (1.-2.*a*(time-t0)**2) * exp(-a*(time-t0)**2) / rho
+
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+
+! record a seismogram to check that the simulation went well
+ seismogram(it) = displ(3,ibool(2,2,2,NSPEC_STATION))
+
+ enddo ! end of the serial time loop
+
+! save the seismogram at the end of the run
+ open(unit=IIN,file='seismogram_F90.txt',status='unknown')
+ do it = 1,NSTEP
+ write(IIN,*) (it-1)*deltat,seismogram(it)
+ enddo
+ close(IIN)
+
+ end program serial_specfem3D
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_single_no_Deville.c
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_single_no_Deville.c (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_single_no_Deville.c 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,548 @@
+
+/*
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+*/
+
+//
+// All the arrays below use static memory allocation,
+// using constant sizes defined in values_from_mesher.h.
+// This is done purposely to improve performance (Fortran compilers
+// can optimize much more when the size of the loops and arrays
+// is known at compile time).
+// NGLLX, NGLLY and NGLLZ are set equal to 5,
+// therefore each element contains NGLLX * NGLLY * NGLLZ = 125 points.
+//
+
+//
+// All the calculations are done in single precision.
+// We do not need double precision in SPECFEM3D.
+//
+
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <time.h>
+
+// include values created by the mesher
+// done for performance only using static allocation to allow for loop unrolling
+#include "DATABASES_FOR_SOLVER/values_from_mesher_C.h"
+
+// constant value of the time step in the main time loop
+#define deltatover2 0.5f*deltat
+#define deltatsqover2 0.5f*deltat*deltat
+
+// for the source time function
+#define pi 3.141592653589793f
+#define f0 (1.f / 50.f)
+#define t0 (1.2f / f0)
+#define a pi*pi*f0*f0
+
+// number of GLL integration points in each direction of an element (degree plus one)
+#define NGLLX 5
+#define NGLLY 5
+#define NGLLZ 5
+
+// 3-D simulation
+#define NDIM 3
+
+// displacement threshold above which we consider that the code became unstable
+#define STABILITY_THRESHOLD 1.e+25f
+
+// #define VERYSMALLVAL 1.e-24f
+#define NTSTEP_BETWEEN_OUTPUT_INFO 100
+
+// approximate density of the geophysical medium in which the source is located
+// this value is only a constant scaling factor therefore it does not really matter
+#define rho 4500.f
+
+// call a Fortran routine to read the unformatted binary data files created by the Fortran mesher
+//// DK DK 33333333333333 now in Fortran
+ extern void read_arrays_solver_(float xix[NSPEC][NGLLZ][NGLLY][NGLLX],float xiy[NSPEC][NGLLZ][NGLLY][NGLLX],float xiz[NSPEC][NGLLZ][NGLLY][NGLLX],float etax[NSPEC][NGLLZ][NGLLY][NGLLX],float etay[NSPEC][NGLLZ][NGLLY][NGLLX],float etaz[NSPEC][NGLLZ][NGLLY][NGLLX],float gammax[NSPEC][NGLLZ][NGLLY][NGLLX],float gammay[NSPEC][NGLLZ][NGLLY][NGLLX],float gammaz[NSPEC][NGLLZ][NGLLY][NGLLX],float kappav[NSPEC][NGLLZ][NGLLY][NGLLX],float muv[NSPEC][NGLLZ][NGLLY][NGLLX],int ibool[NSPEC][NGLLZ][NGLLY][NGLLX],float rmass_inverse[NGLOB]);
+
+int main(int argc, char *argv[])
+{
+
+// global displacement, velocity and acceleration vectors
+ static float displx[NGLOB];
+ static float disply[NGLOB];
+ static float displz[NGLOB];
+
+ static float velocx[NGLOB];
+ static float velocy[NGLOB];
+ static float velocz[NGLOB];
+
+ static float accelx[NGLOB];
+ static float accely[NGLOB];
+ static float accelz[NGLOB];
+
+// global diagonal mass matrix
+ static float rmass_inverse[NGLOB];
+
+// record a seismogram to check that the simulation went well
+ static float seismogram[NSTEP];
+
+// arrays with mesh parameters per slice
+ static int ibool[NSPEC][NGLLZ][NGLLY][NGLLX];
+
+ static float xix[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static float xiy[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static float xiz[NSPEC][NGLLZ][NGLLY][NGLLX];
+
+ static float etax[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static float etay[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static float etaz[NSPEC][NGLLZ][NGLLY][NGLLX];
+
+ static float gammax[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static float gammay[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static float gammaz[NSPEC][NGLLZ][NGLLY][NGLLX];
+
+ static float kappav[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static float muv[NSPEC][NGLLZ][NGLLY][NGLLX];
+
+ static float dummyx_loc[NGLLZ][NGLLY][NGLLX];
+ static float dummyy_loc[NGLLZ][NGLLY][NGLLX];
+ static float dummyz_loc[NGLLZ][NGLLY][NGLLX];
+
+// array with derivatives of Lagrange polynomials and precalculated products
+ static float hprime_xx[NGLLX][NGLLX];
+ static float hprimewgll_xx[NGLLX][NGLLX];
+ static float wgllwgll_xy[NGLLY][NGLLX];
+ static float wgllwgll_xz[NGLLZ][NGLLX];
+ static float wgllwgll_yz[NGLLZ][NGLLY];
+
+ static float tempx1[NGLLZ][NGLLY][NGLLX];
+ static float tempx2[NGLLZ][NGLLY][NGLLX];
+ static float tempx3[NGLLZ][NGLLY][NGLLX];
+ static float tempy1[NGLLZ][NGLLY][NGLLX];
+ static float tempy2[NGLLZ][NGLLY][NGLLX];
+ static float tempy3[NGLLZ][NGLLY][NGLLX];
+ static float tempz1[NGLLZ][NGLLY][NGLLX];
+ static float tempz2[NGLLZ][NGLLY][NGLLX];
+ static float tempz3[NGLLZ][NGLLY][NGLLX];
+
+// time step
+ int it;
+
+ clock_t timeloop_begin;
+ float timeloop_total;
+
+ int ispec,iglob,i,j,k,l;
+
+ float xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl;
+ float duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl;
+ float duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl;
+ float duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl;
+ float sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz;
+ float hp1,hp2,hp3,fac1,fac2,fac3,lambdal,mul,lambdalplus2mul,kappal;
+ float tempx1l,tempx2l,tempx3l,tempy1l,tempy2l,tempy3l,tempz1l,tempz2l,tempz3l;
+
+ float Usolidnorm,current_value,time,memory_size;
+
+// to read external files
+ FILE *IIN;
+
+// for the time stamp files
+ char prname[200];
+
+// estimate of total memory size used
+ printf("\nNSPEC = %d\n",NSPEC);
+ printf("NGLOB = %d\n\n",NGLOB);
+ printf("NSTEP = %d\n",NSTEP);
+ printf("deltat = %f\n\n",deltat);
+
+// estimate total memory size (the size of a real number is 4 bytes)
+// we perform the calculation in single precision rather than integer
+// to avoid integer overflow in the case of very large meshes
+ memory_size = 4.f * ((3.f*NDIM + 1.f) * NGLOB + 12.f * (float)(NGLLX*NGLLY*NGLLZ)*(float)(NSPEC));
+ printf("approximate total memory size used = %f Mb\n\n",memory_size/1024.f/1024.f);
+
+// make sure the source element number is an integer
+ if(NSPEC % 2 != 0) {
+ fprintf(stderr,"source element number is not an integer, exiting...\n");
+ exit(1);
+ }
+
+// read the mesh from external file
+//// DK DK 33333333333333 now in Fortran
+//// DK DK 33333333333333 but still open and close the file just to check that it exists on the disk and exit if not
+ printf("reading file DATABASES_FOR_SOLVER/proc000000_reg1_database.dat\n");
+ if((IIN=fopen("DATABASES_FOR_SOLVER/proc000000_reg1_database.dat","r"))==NULL) {
+ fprintf(stderr,"Cannot open file DATABASES_FOR_SOLVER/proc000000_reg1_database.dat, exiting...\n");
+ exit(1);
+ }
+ fclose(IIN);
+//// DK DK 33333333333333 now in Fortran
+ read_arrays_solver_(xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,kappav,muv,ibool,rmass_inverse);
+
+ for (ispec=0;ispec<NSPEC;ispec++) {
+ for (k=0;k<NGLLZ;k++) {
+ for (j=0;j<NGLLY;j++) {
+ for (i=0;i<NGLLX;i++) {
+// read real numbers here
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &xix[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &xiy[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &xiz[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &etax[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &etay[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &etaz[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &gammax[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &gammay[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &gammaz[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &kappav[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &muv[ispec][k][j][i]);
+
+// read an integer here
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%d\n", &ibool[ispec][k][j][i]);
+// subtract one because indices start at zero in C but this array was created by a Fortran
+// program and therefore starts at one in the file stored on the disk
+ ibool[ispec][k][j][i]--;
+ }
+ }
+ }
+ }
+ for (i=0;i<NGLOB;i++) {
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &rmass_inverse[i]);
+// the real exactly diagonal mass matrix is read (not its inverse)
+// therefore invert it here once and for all
+ rmass_inverse[i] = 1.f / rmass_inverse[i];
+ }
+//// DK DK 33333333333333 now in Fortran fclose(IIN);
+
+ printf("reading file DATABASES_FOR_SOLVER/matrices.dat\n");
+// read the derivation matrices from external file
+ if((IIN=fopen("DATABASES_FOR_SOLVER/matrices.dat","r"))==NULL) {
+ fprintf(stderr,"Cannot open file DATABASES_FOR_SOLVER/matrices.dat, exiting...\n");
+ exit(1);
+ }
+
+ for (j=0;j<NGLLY;j++) {
+ for (i=0;i<NGLLX;i++) {
+ fscanf(IIN, "%e\n", &hprime_xx[j][i]);
+ fscanf(IIN, "%e\n", &hprimewgll_xx[j][i]);
+ fscanf(IIN, "%e\n", &wgllwgll_yz[j][i]);
+ fscanf(IIN, "%e\n", &wgllwgll_xz[j][i]);
+ fscanf(IIN, "%e\n", &wgllwgll_xy[j][i]);
+ }
+ }
+ fclose(IIN);
+
+// clear initial vectors before starting the time loop
+// (can remain serial because done only once before entering the time loop)
+ for (i=0;i<NGLOB;i++) {
+ displx[i] = 0.f; // VERYSMALLVAL;
+ disply[i] = 0.f; // VERYSMALLVAL;
+ displz[i] = 0.f; // VERYSMALLVAL;
+
+ velocx[i] = 0.f;
+ velocy[i] = 0.f;
+ velocz[i] = 0.f;
+
+ accelx[i] = 0.f;
+ accely[i] = 0.f;
+ accelz[i] = 0.f;
+ }
+
+ printf("starting the time loop\n");
+
+ timeloop_begin = clock();
+
+// start of the time loop (which must remain serial obviously)
+ for (it=1; it<=NSTEP; it++) {
+
+// compute maximum of norm of displacement from time to time and display it
+// in order to monitor the simulation
+// this can remain serial because it is done only every NTSTEP_BETWEEN_OUTPUT_INFO time steps
+ if((it % NTSTEP_BETWEEN_OUTPUT_INFO) == 0 || it == 5 || it == NSTEP) {
+
+ Usolidnorm = -1.f;
+
+ for (iglob = 0; iglob < NGLOB; iglob++) {
+ current_value = sqrtf(displx[iglob]*displx[iglob] + disply[iglob]*disply[iglob] + displz[iglob]*displz[iglob]);
+ if(current_value > Usolidnorm) { Usolidnorm = current_value; }
+ }
+
+ printf("\nTime step # %d out of %d\n",it,NSTEP);
+// compute current time
+ time = (it-1)*deltat;
+ printf("Max norm displacement vector U in the solid (m) = %.8g\n",Usolidnorm);
+ timeloop_total = ((clock()-timeloop_begin)/(float)CLOCKS_PER_SEC);
+ printf("Total elapsed time so far: %f\n",timeloop_total);
+ if (it>100) {
+ printf("Average elapsed time per time step: %f\n",timeloop_total/(float)(it-1));
+ }
+
+// write a time stamp file
+ sprintf(prname,"timestamp_%07d.txt",it);
+ if((IIN = fopen(prname,"w")) == NULL) {
+ fprintf(stderr,"Cannot create time stamp file, exiting...\n");
+ exit(1);
+ }
+ fprintf(IIN,"Time step # %d out of %d\n",it,NSTEP);
+ fprintf(IIN,"Max norm displacement vector U in the solid (m) = %.8g\n",Usolidnorm);
+ fprintf(IIN,"Total elapsed time so far: %f\n",timeloop_total);
+ if (it >= 100) { fprintf(IIN,"Average elapsed time per time step: %f\n",timeloop_total/(float)(it-1)); }
+ fprintf(IIN,"\n");
+ fclose(IIN);
+
+// check stability of the code, exit if unstable
+ if(Usolidnorm > STABILITY_THRESHOLD || Usolidnorm < 0) {
+ fprintf(stderr,"code became unstable and blew up\n");
+ exit(1);
+ }
+ }
+
+// big loop over all the global points (not elements) in the mesh to update
+// the displacement and velocity vectors and clear the acceleration vector
+ for (i=0;i<NGLOB;i++) {
+ displx[i] += deltat*velocx[i] + deltatsqover2*accelx[i];
+ disply[i] += deltat*velocy[i] + deltatsqover2*accely[i];
+ displz[i] += deltat*velocz[i] + deltatsqover2*accelz[i];
+
+ velocx[i] += deltatover2*accelx[i];
+ velocy[i] += deltatover2*accely[i];
+ velocz[i] += deltatover2*accelz[i];
+ }
+
+// we leave this loop as separate (in principle it could be merged with the previous loop)
+// because then the Intel icc compiler can replace it with a call to memset(0), which is faster
+ for (i=0;i<NGLOB;i++) {
+ accelx[i] = 0.f;
+ accely[i] = 0.f;
+ accelz[i] = 0.f;
+ }
+
+// big loop over all the elements in the mesh to localize data
+// from the global vectors to the local mesh
+// using indirect addressing (contained in array ibool)
+// and then to compute the elemental contribution
+// to the acceleration vector of each element of the finite-element mesh
+ for (ispec=0;ispec<NSPEC;ispec++) {
+
+ for (k=0;k<NGLLZ;k++) {
+ for (j=0;j<NGLLY;j++) {
+ for (i=0;i<NGLLX;i++) {
+ iglob = ibool[ispec][k][j][i];
+ dummyx_loc[k][j][i] = displx[iglob];
+ dummyy_loc[k][j][i] = disply[iglob];
+ dummyz_loc[k][j][i] = displz[iglob];
+ }
+ }
+ }
+
+// big loop over all the elements in the mesh to compute the elemental contribution
+// to the acceleration vector of each element of the finite-element mesh
+
+ for (k=0;k<NGLLZ;k++) {
+ for (j=0;j<NGLLY;j++) {
+ for (i=0;i<NGLLX;i++) {
+
+ tempx1l = 0.f;
+ tempx2l = 0.f;
+ tempx3l = 0.f;
+
+ tempy1l = 0.f;
+ tempy2l = 0.f;
+ tempy3l = 0.f;
+
+ tempz1l = 0.f;
+ tempz2l = 0.f;
+ tempz3l = 0.f;
+
+ for (l=0;l<NGLLX;l++) {
+ hp1 = hprime_xx[l][i];
+ tempx1l += dummyx_loc[k][j][l]*hp1;
+ tempy1l += dummyy_loc[k][j][l]*hp1;
+ tempz1l += dummyz_loc[k][j][l]*hp1;
+
+ hp2 = hprime_xx[l][j];
+ tempx2l += dummyx_loc[k][l][i]*hp2;
+ tempy2l += dummyy_loc[k][l][i]*hp2;
+ tempz2l += dummyz_loc[k][l][i]*hp2;
+
+ hp3 = hprime_xx[l][k];
+ tempx3l += dummyx_loc[l][j][i]*hp3;
+ tempy3l += dummyy_loc[l][j][i]*hp3;
+ tempz3l += dummyz_loc[l][j][i]*hp3;
+ }
+
+// compute derivatives of ux, uy and uz with respect to x, y and z
+ xixl = xix[ispec][k][j][i];
+ xiyl = xiy[ispec][k][j][i];
+ xizl = xiz[ispec][k][j][i];
+ etaxl = etax[ispec][k][j][i];
+ etayl = etay[ispec][k][j][i];
+ etazl = etaz[ispec][k][j][i];
+ gammaxl = gammax[ispec][k][j][i];
+ gammayl = gammay[ispec][k][j][i];
+ gammazl = gammaz[ispec][k][j][i];
+ jacobianl = 1.f / (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 isotropic elements
+ kappal = kappav[ispec][k][j][i];
+ mul = muv[ispec][k][j][i];
+
+ lambdalplus2mul = kappal + 1.33333333333333333333f * mul; // 4./3. = 1.3333333
+ lambdal = lambdalplus2mul - 2.f*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;
+
+// form dot product with test vector
+ tempx1[k][j][i] = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl);
+ tempy1[k][j][i] = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl);
+ tempz1[k][j][i] = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl);
+
+ tempx2[k][j][i] = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl);
+ tempy2[k][j][i] = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl);
+ tempz2[k][j][i] = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl);
+
+ tempx3[k][j][i] = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl);
+ tempy3[k][j][i] = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl);
+ tempz3[k][j][i] = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl);
+
+ }
+ }
+ }
+
+ for (k=0;k<NGLLZ;k++) {
+ for (j=0;j<NGLLY;j++) {
+ for (i=0;i<NGLLX;i++) {
+
+ tempx1l = 0.f;
+ tempy1l = 0.f;
+ tempz1l = 0.f;
+
+ tempx2l = 0.f;
+ tempy2l = 0.f;
+ tempz2l = 0.f;
+
+ tempx3l = 0.f;
+ tempy3l = 0.f;
+ tempz3l = 0.f;
+
+ for (l=0;l<NGLLX;l++) {
+ fac1 = hprimewgll_xx[i][l];
+ tempx1l += tempx1[k][j][l]*fac1;
+ tempy1l += tempy1[k][j][l]*fac1;
+ tempz1l += tempz1[k][j][l]*fac1;
+
+ fac2 = hprimewgll_xx[j][l];
+ tempx2l += tempx2[k][l][i]*fac2;
+ tempy2l += tempy2[k][l][i]*fac2;
+ tempz2l += tempz2[k][l][i]*fac2;
+
+ fac3 = hprimewgll_xx[k][l];
+ tempx3l += tempx3[l][j][i]*fac3;
+ tempy3l += tempy3[l][j][i]*fac3;
+ tempz3l += tempz3[l][j][i]*fac3;
+ }
+
+ fac1 = wgllwgll_yz[k][j];
+ fac2 = wgllwgll_xz[k][i];
+ fac3 = wgllwgll_xy[j][i];
+
+// sum contributions from each element to the global mesh using indirect addressing
+ iglob = ibool[ispec][k][j][i];
+ accelx[iglob] -= (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l);
+ accely[iglob] -= (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l);
+ accelz[iglob] -= (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l);
+
+ }
+ }
+ }
+
+ } // end of main loop on all the elements
+
+// big loop over all the global points (not elements) in the mesh to update
+// the acceleration and velocity vectors
+ for (i=0;i<NGLOB;i++) {
+ accelx[i] *= rmass_inverse[i];
+ accely[i] *= rmass_inverse[i];
+ accelz[i] *= rmass_inverse[i];
+ }
+
+// add the earthquake source at a given grid point
+// this is negligible and is intrinsically serial because it is done by only
+// one grid point out of several millions typically
+// we subtract one to the element number of the source because arrays start at 0 in C
+// compute current time
+ time = (it-1)*deltat;
+ accelz[ibool[NSPEC_SOURCE-1][1][1][1]] += 1.e4f * (1.f - 2.f*a*(time-t0)*(time-t0)) * expf(-a*(time-t0)*(time-t0)) / rho;
+
+ for (i=0;i<NGLOB;i++) {
+ velocx[i] += deltatover2*accelx[i];
+ velocy[i] += deltatover2*accely[i];
+ velocz[i] += deltatover2*accelz[i];
+ }
+
+// record a seismogram to check that the simulation went well
+// we subtract one to the element number of the receiver because arrays start at 0 in C
+ seismogram[it-1] = displz[ibool[NSPEC_STATION-1][1][1][1]];
+
+ } // end of the serial time loop
+
+// save the seismogram at the end of the run
+ if((IIN = fopen("seismogram_C_single.txt","w")) == NULL) {
+ fprintf(stderr,"Cannot open file seismogram_C_single.txt, exiting...\n");
+ exit(1);
+ }
+ for (it=0;it<NSTEP;it++)
+ { fprintf(IIN,"%e %e\n",it*deltat,seismogram[it]);
+ }
+ fclose(IIN);
+
+ printf("\nEnd of the program\n\n");
+
+ }
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_single_with_Deville.c
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_single_with_Deville.c (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/serial_specfem3D_single_with_Deville.c 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,716 @@
+
+/*
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+*/
+
+//
+// All the arrays below use static memory allocation,
+// using constant sizes defined in values_from_mesher.h.
+// This is done purposely to improve performance (Fortran compilers
+// can optimize much more when the size of the loops and arrays
+// is known at compile time).
+// NGLLX, NGLLY and NGLLZ are set equal to 5,
+// therefore each element contains NGLLX * NGLLY * NGLLZ = 125 points.
+//
+
+//
+// All the calculations are done in single precision.
+// We do not need double precision in SPECFEM3D.
+//
+
+#include <stdio.h>
+#include <math.h>
+#include <stdlib.h>
+#include <time.h>
+
+// include values created by the mesher
+// done for performance only using static allocation to allow for loop unrolling
+#include "DATABASES_FOR_SOLVER/values_from_mesher_C.h"
+
+// constant value of the time step in the main time loop
+#define deltatover2 0.5f*deltat
+#define deltatsqover2 0.5f*deltat*deltat
+
+// for the source time function
+#define pi 3.141592653589793f
+#define f0 (1.f / 50.f)
+#define t0 (1.2f / f0)
+#define a pi*pi*f0*f0
+
+// number of GLL integration points in each direction of an element (degree plus one)
+#define NGLLX 5
+#define NGLLY 5
+#define NGLLZ 5
+
+// for the Deville et al. (2002) inlined matrix products
+#define NGLL2 25 // NGLLX^2
+
+// 3-D simulation
+#define NDIM 3
+
+// displacement threshold above which we consider that the code became unstable
+#define STABILITY_THRESHOLD 1.e+25f
+
+// #define VERYSMALLVAL 1.e-24f
+#define NTSTEP_BETWEEN_OUTPUT_INFO 100 // NSTEP
+
+// approximate density of the geophysical medium in which the source is located
+// this value is only a constant scaling factor therefore it does not really matter
+#define rho 4500.f
+
+// call a Fortran routine to read the unformatted binary data files created by the Fortran mesher
+//// DK DK 33333333333333 now in Fortran
+ extern void read_arrays_solver_(float xix[NSPEC][NGLLZ][NGLLY][NGLLX],float xiy[NSPEC][NGLLZ][NGLLY][NGLLX],float xiz[NSPEC][NGLLZ][NGLLY][NGLLX],float etax[NSPEC][NGLLZ][NGLLY][NGLLX],float etay[NSPEC][NGLLZ][NGLLY][NGLLX],float etaz[NSPEC][NGLLZ][NGLLY][NGLLX],float gammax[NSPEC][NGLLZ][NGLLY][NGLLX],float gammay[NSPEC][NGLLZ][NGLLY][NGLLX],float gammaz[NSPEC][NGLLZ][NGLLY][NGLLX],float kappav[NSPEC][NGLLZ][NGLLY][NGLLX],float muv[NSPEC][NGLLZ][NGLLY][NGLLX],int ibool[NSPEC][NGLLZ][NGLLY][NGLLX],float rmass_inverse[NGLOB], int* myrank,
+ double xstore[NSPEC][NGLLZ][NGLLY][NGLLX], double ystore[NSPEC][NGLLZ][NGLLY][NGLLX], double zstore[NSPEC][NGLLZ][NGLLY][NGLLX]);
+
+
+int main(int argc, char *argv[])
+{
+
+ int myrank = 0;
+
+// global displacement, velocity and acceleration vectors
+ static float displx[NGLOB];
+ static float disply[NGLOB];
+ static float displz[NGLOB];
+
+ static float velocx[NGLOB];
+ static float velocy[NGLOB];
+ static float velocz[NGLOB];
+
+ static float accelx[NGLOB];
+ static float accely[NGLOB];
+ static float accelz[NGLOB];
+
+// global diagonal mass matrix
+ static float rmass_inverse[NGLOB];
+
+// record a seismogram to check that the simulation went well
+ static float seismogram[NSTEP];
+
+// arrays with mesh parameters per slice
+ static int ibool[NSPEC][NGLLZ][NGLLY][NGLLX];
+
+ static float xix[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static float xiy[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static float xiz[NSPEC][NGLLZ][NGLLY][NGLLX];
+
+ static float etax[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static float etay[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static float etaz[NSPEC][NGLLZ][NGLLY][NGLLX];
+
+ static float gammax[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static float gammay[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static float gammaz[NSPEC][NGLLZ][NGLLY][NGLLX];
+
+ static float kappav[NSPEC][NGLLZ][NGLLY][NGLLX];
+ static float muv[NSPEC][NGLLZ][NGLLY][NGLLX];
+
+// these three arrays are currently unused, but should be used one day to detect the position of the source in the mesh
+ double xstore[NSPEC][NGLLZ][NGLLY][NGLLX];
+ double ystore[NSPEC][NGLLZ][NGLLY][NGLLX];
+ double zstore[NSPEC][NGLLZ][NGLLY][NGLLX];
+
+ static union ux_tag {
+ float dummyx_loc[NGLLZ][NGLLY][NGLLX];
+ float dummyx_loc_2D_25_5[NGLL2][NGLLX];
+ float dummyx_loc_2D_5_25[NGLLX][NGLL2];
+ } ux;
+
+ static union uy_tag {
+ float dummyy_loc[NGLLZ][NGLLY][NGLLX];
+ float dummyy_loc_2D_25_5[NGLL2][NGLLX];
+ float dummyy_loc_2D_5_25[NGLLX][NGLL2];
+ } uy;
+
+ static union uz_tag {
+ float dummyz_loc[NGLLZ][NGLLY][NGLLX];
+ float dummyz_loc_2D_25_5[NGLL2][NGLLX];
+ float dummyz_loc_2D_5_25[NGLLX][NGLL2];
+ } uz;
+
+// array with derivatives of Lagrange polynomials and precalculated products
+ static float hprime_xx[NGLLX][NGLLX];
+ static float hprime_xxT[NGLLX][NGLLX];
+ static float hprimewgll_xx[NGLLX][NGLLX];
+ static float hprimewgll_xxT[NGLLX][NGLLX];
+ static float wgllwgll_xy[NGLLY][NGLLX];
+ static float wgllwgll_xz[NGLLZ][NGLLX];
+ static float wgllwgll_yz[NGLLZ][NGLLY];
+
+// --------------------------------------------
+ static union utempx1_tag {
+ float tempx1[NGLLZ][NGLLY][NGLLX];
+ float tempx1_2D_25_5[NGLL2][NGLLX];
+ } utempx1;
+
+ static union utempy1_tag {
+ float tempy1[NGLLZ][NGLLY][NGLLX];
+ float tempy1_2D_25_5[NGLL2][NGLLX];
+ } utempy1;
+
+ static union utempz1_tag {
+ float tempz1[NGLLZ][NGLLY][NGLLX];
+ float tempz1_2D_25_5[NGLL2][NGLLX];
+ } utempz1;
+
+// --------------------------------------------
+ static union utempx3_tag {
+ float tempx3[NGLLZ][NGLLY][NGLLX];
+ float tempx3_2D_5_25[NGLLX][NGLL2];
+ } utempx3;
+
+ static union utempy3_tag {
+ float tempy3[NGLLZ][NGLLY][NGLLX];
+ float tempy3_2D_5_25[NGLLX][NGLL2];
+ } utempy3;
+
+ static union utempz3_tag {
+ float tempz3[NGLLZ][NGLLY][NGLLX];
+ float tempz3_2D_5_25[NGLLX][NGLL2];
+ } utempz3;
+
+// --------------------------------------------
+ static float tempx2[NGLLZ][NGLLY][NGLLX];
+ static float tempy2[NGLLZ][NGLLY][NGLLX];
+ static float tempz2[NGLLZ][NGLLY][NGLLX];
+
+// --------------------------------------------
+ static union unewtempx1_tag {
+ float newtempx1[NGLLZ][NGLLY][NGLLX];
+ float newtempx1_2D_25_5[NGLL2][NGLLX];
+ } unewtempx1;
+
+ static union unewtempy1_tag {
+ float newtempy1[NGLLZ][NGLLY][NGLLX];
+ float newtempy1_2D_25_5[NGLL2][NGLLX];
+ } unewtempy1;
+
+ static union unewtempz1_tag {
+ float newtempz1[NGLLZ][NGLLY][NGLLX];
+ float newtempz1_2D_25_5[NGLL2][NGLLX];
+ } unewtempz1;
+
+// --------------------------------------------
+ static float newtempx2[NGLLZ][NGLLY][NGLLX];
+ static float newtempy2[NGLLZ][NGLLY][NGLLX];
+ static float newtempz2[NGLLZ][NGLLY][NGLLX];
+
+// --------------------------------------------
+ static union unewtempx3_tag {
+ float newtempx3[NGLLZ][NGLLY][NGLLX];
+ float newtempx3_2D_5_25[NGLLX][NGLL2];
+ } unewtempx3;
+
+ static union unewtempy3_tag {
+ float newtempy3[NGLLZ][NGLLY][NGLLX];
+ float newtempy3_2D_5_25[NGLLX][NGLL2];
+ } unewtempy3;
+
+ static union unewtempz3_tag {
+ float newtempz3[NGLLZ][NGLLY][NGLLX];
+ float newtempz3_2D_5_25[NGLLX][NGLL2];
+ } unewtempz3;
+
+// time step
+ int it;
+
+ clock_t timeloop_begin;
+ float timeloop_total;
+
+ int ispec,iglob,i,j,k;
+
+ float xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl;
+ float duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl;
+ float duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl;
+ float duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl;
+ float sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz;
+ float lambdal,mul,lambdalplus2mul,kappal;
+
+ float Usolidnorm,current_value,time,memory_size;
+
+// to read external files
+ FILE *IIN;
+
+// for the time stamp files
+ char prname[200];
+
+ printf("\nNSPEC = %d\n",NSPEC);
+ printf("NGLOB = %d\n\n",NGLOB);
+ printf("NSTEP = %d\n",NSTEP);
+ printf("deltat = %f\n\n",deltat);
+
+// make sure that we can use the Deville et al. (2002) routines
+ if(NGLLX != 5 || NGLLY != 5 || NGLLZ != 5) {
+ fprintf(stderr,"we must have NGLLX = NGLLY = NGLLZ = 5 to be able to use the Deville et al. (2002) routines, exiting...\n");
+ exit(1);
+ }
+
+// estimate total memory size (the size of a real number is 4 bytes)
+// we perform the calculation in single precision rather than integer
+// to avoid integer overflow in the case of very large meshes
+ memory_size = 4.f * ((3.f*NDIM + 1.f) * NGLOB + 12.f * (float)(NGLLX*NGLLY*NGLLZ)*(float)(NSPEC));
+ printf("approximate total memory size used = %f Mb\n\n",memory_size/1024.f/1024.f);
+
+// read the mesh from external file
+//// DK DK 33333333333333 now in Fortran
+//// DK DK 33333333333333 but still open and close the file just to check that it exists on the disk and exit if not
+ printf("reading file DATABASES_FOR_SOLVER/proc000000_reg1_database.dat\n");
+ if((IIN=fopen("DATABASES_FOR_SOLVER/proc000000_reg1_database.dat","r"))==NULL) {
+ fprintf(stderr,"Cannot open file DATABASES_FOR_SOLVER/proc000000_reg1_database.dat, exiting...\n");
+ exit(1);
+ }
+ fclose(IIN);
+//// DK DK 33333333333333 now in Fortran
+ read_arrays_solver_(xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,kappav,muv,ibool,rmass_inverse,&myrank,xstore,ystore,zstore);
+
+ for (ispec=0;ispec<NSPEC;ispec++) {
+ for (k=0;k<NGLLZ;k++) {
+ for (j=0;j<NGLLY;j++) {
+ for (i=0;i<NGLLX;i++) {
+// read real numbers here
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &xix[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &xiy[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &xiz[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &etax[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &etay[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &etaz[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &gammax[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &gammay[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &gammaz[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &kappav[ispec][k][j][i]);
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &muv[ispec][k][j][i]);
+
+// read an integer here
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%d\n", &ibool[ispec][k][j][i]);
+// subtract one because indices start at zero in C but this array was created by a Fortran
+// program and therefore starts at one in the file stored on the disk
+ ibool[ispec][k][j][i]--;
+ }
+ }
+ }
+ }
+ for (i=0;i<NGLOB;i++) {
+//// DK DK 33333333333333 now in Fortran fscanf(IIN, "%e\n", &rmass_inverse[i]);
+// the real exactly diagonal mass matrix is read (not its inverse)
+// therefore invert it here once and for all
+ rmass_inverse[i] = 1.f / rmass_inverse[i];
+ }
+//// DK DK 33333333333333 now in Fortran fclose(IIN);
+
+// read the derivation matrices from external file
+ printf("reading file DATABASES_FOR_SOLVER/matrices.dat\n");
+ if((IIN=fopen("DATABASES_FOR_SOLVER/matrices.dat","r"))==NULL) {
+ fprintf(stderr,"Cannot open file DATABASES_FOR_SOLVER/matrices.dat, exiting...\n");
+ exit(1);
+ }
+
+ for (j=0;j<NGLLY;j++) {
+ for (i=0;i<NGLLX;i++) {
+ fscanf(IIN, "%e\n", &hprime_xx[j][i]);
+ fscanf(IIN, "%e\n", &hprimewgll_xx[j][i]);
+
+// compute the transpose matrices
+ hprime_xxT[i][j] = hprime_xx[j][i];
+ hprimewgll_xxT[i][j] = hprimewgll_xx[j][i];
+
+ fscanf(IIN, "%e\n", &wgllwgll_yz[j][i]);
+ fscanf(IIN, "%e\n", &wgllwgll_xz[j][i]);
+ fscanf(IIN, "%e\n", &wgllwgll_xy[j][i]);
+ }
+ }
+ fclose(IIN);
+
+// clear initial vectors before starting the time loop
+// (can remain serial because done only once before entering the time loop)
+ for (i=0;i<NGLOB;i++) {
+ displx[i] = 0.f; // VERYSMALLVAL;
+ disply[i] = 0.f; // VERYSMALLVAL;
+ displz[i] = 0.f; // VERYSMALLVAL;
+
+ velocx[i] = 0.f;
+ velocy[i] = 0.f;
+ velocz[i] = 0.f;
+
+ accelx[i] = 0.f;
+ accely[i] = 0.f;
+ accelz[i] = 0.f;
+ }
+
+ printf("\nstarting the time loop\n\n");
+
+ timeloop_begin = clock();
+
+// start of the time loop (which must remain serial obviously)
+ for (it = 1; it <= NSTEP; it++) {
+
+// compute maximum of norm of displacement from time to time and display it
+// in order to monitor the simulation
+// this can remain serial because it is done only every NTSTEP_BETWEEN_OUTPUT_INFO time steps
+ if((it % NTSTEP_BETWEEN_OUTPUT_INFO) == 0 || it == 5 || it == NSTEP) {
+
+ Usolidnorm = -1.f;
+
+ for (iglob = 0; iglob < NGLOB; iglob++) {
+ current_value = sqrtf(displx[iglob]*displx[iglob] + disply[iglob]*disply[iglob] + displz[iglob]*displz[iglob]);
+ if(current_value > Usolidnorm) { Usolidnorm = current_value; }
+ }
+
+ printf("\nTime step # %d out of %d\n",it,NSTEP);
+ printf("Max norm displacement vector U in the solid (m) = %.8g\n",Usolidnorm);
+ timeloop_total = ((clock()-timeloop_begin)/(float)CLOCKS_PER_SEC);
+ printf("Total elapsed time so far: %f\n",timeloop_total);
+ if (it >= 100) { printf("Average elapsed time per time step: %f\n",timeloop_total/(float)(it-1)); }
+
+// write a time stamp file
+ sprintf(prname,"timestamp_%07d.txt",it);
+ if((IIN = fopen(prname,"w")) == NULL) {
+ fprintf(stderr,"Cannot create time stamp file, exiting...\n");
+ exit(1);
+ }
+ fprintf(IIN,"Time step # %d out of %d\n",it,NSTEP);
+ fprintf(IIN,"Max norm displacement vector U in the solid (m) = %.8g\n",Usolidnorm);
+ fprintf(IIN,"Total elapsed time so far: %f\n",timeloop_total);
+ if (it >= 100) { fprintf(IIN,"Average elapsed time per time step: %f\n",timeloop_total/(float)(it-1)); }
+ fprintf(IIN,"\n");
+ fclose(IIN);
+
+// check stability of the code, exit if unstable
+ if(Usolidnorm > STABILITY_THRESHOLD || Usolidnorm < 0) {
+ fprintf(stderr,"code became unstable and blew up\n");
+ exit(1);
+ }
+ }
+
+// big loop over all the global points (not elements) in the mesh to update
+// the displacement and velocity vectors and clear the acceleration vector
+ for (i=0;i<NGLOB;i++) {
+ displx[i] += deltat*velocx[i] + deltatsqover2*accelx[i];
+ disply[i] += deltat*velocy[i] + deltatsqover2*accely[i];
+ displz[i] += deltat*velocz[i] + deltatsqover2*accelz[i];
+
+ velocx[i] += deltatover2*accelx[i];
+ velocy[i] += deltatover2*accely[i];
+ velocz[i] += deltatover2*accelz[i];
+ }
+
+// we leave this loop as separate (in principle it could be merged with the previous loop)
+// because then the Intel icc compiler can replace it with a call to memset(0), which is faster
+ for (i=0;i<NGLOB;i++) {
+ accelx[i] = 0.f;
+ accely[i] = 0.f;
+ accelz[i] = 0.f;
+ }
+
+// big loop over all the elements in the mesh to localize data
+// from the global vectors to the local mesh
+// using indirect addressing (contained in array ibool)
+// and then to compute the elemental contribution
+// to the acceleration vector of each element of the finite-element mesh
+ for (ispec=0;ispec<NSPEC;ispec++) {
+
+ for (k=0;k<NGLLZ;k++) {
+ for (j=0;j<NGLLY;j++) {
+ for (i=0;i<NGLLX;i++) {
+ iglob = ibool[ispec][k][j][i];
+ ux.dummyx_loc[k][j][i] = displx[iglob];
+ uy.dummyy_loc[k][j][i] = disply[iglob];
+ uz.dummyz_loc[k][j][i] = displz[iglob];
+ }
+ }
+ }
+
+// big loop over all the elements in the mesh to compute the elemental contribution
+// to the acceleration vector of each element of the finite-element mesh
+
+// 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
+ for (j=0;j<NGLL2;j++) {
+ for (i=0;i<NGLLX;i++) {
+ utempx1.tempx1_2D_25_5[j][i] = hprime_xx[0][i]*ux.dummyx_loc_2D_25_5[j][0] +
+ hprime_xx[1][i]*ux.dummyx_loc_2D_25_5[j][1] +
+ hprime_xx[2][i]*ux.dummyx_loc_2D_25_5[j][2] +
+ hprime_xx[3][i]*ux.dummyx_loc_2D_25_5[j][3] +
+ hprime_xx[4][i]*ux.dummyx_loc_2D_25_5[j][4];
+
+ utempy1.tempy1_2D_25_5[j][i] = hprime_xx[0][i]*uy.dummyy_loc_2D_25_5[j][0] +
+ hprime_xx[1][i]*uy.dummyy_loc_2D_25_5[j][1] +
+ hprime_xx[2][i]*uy.dummyy_loc_2D_25_5[j][2] +
+ hprime_xx[3][i]*uy.dummyy_loc_2D_25_5[j][3] +
+ hprime_xx[4][i]*uy.dummyy_loc_2D_25_5[j][4];
+
+ utempz1.tempz1_2D_25_5[j][i] = hprime_xx[0][i]*uz.dummyz_loc_2D_25_5[j][0] +
+ hprime_xx[1][i]*uz.dummyz_loc_2D_25_5[j][1] +
+ hprime_xx[2][i]*uz.dummyz_loc_2D_25_5[j][2] +
+ hprime_xx[3][i]*uz.dummyz_loc_2D_25_5[j][3] +
+ hprime_xx[4][i]*uz.dummyz_loc_2D_25_5[j][4];
+ }
+ }
+
+ for (k=0;k<NGLLZ;k++) {
+ for (j=0;j<NGLLX;j++) {
+ for (i=0;i<NGLLX;i++) {
+ tempx2[k][j][i] = ux.dummyx_loc[k][0][i]*hprime_xxT[j][0] +
+ ux.dummyx_loc[k][1][i]*hprime_xxT[j][1] +
+ ux.dummyx_loc[k][2][i]*hprime_xxT[j][2] +
+ ux.dummyx_loc[k][3][i]*hprime_xxT[j][3] +
+ ux.dummyx_loc[k][4][i]*hprime_xxT[j][4];
+
+ tempy2[k][j][i] = uy.dummyy_loc[k][0][i]*hprime_xxT[j][0] +
+ uy.dummyy_loc[k][1][i]*hprime_xxT[j][1] +
+ uy.dummyy_loc[k][2][i]*hprime_xxT[j][2] +
+ uy.dummyy_loc[k][3][i]*hprime_xxT[j][3] +
+ uy.dummyy_loc[k][4][i]*hprime_xxT[j][4];
+
+ tempz2[k][j][i] = uz.dummyz_loc[k][0][i]*hprime_xxT[j][0] +
+ uz.dummyz_loc[k][1][i]*hprime_xxT[j][1] +
+ uz.dummyz_loc[k][2][i]*hprime_xxT[j][2] +
+ uz.dummyz_loc[k][3][i]*hprime_xxT[j][3] +
+ uz.dummyz_loc[k][4][i]*hprime_xxT[j][4];
+ }
+ }
+ }
+
+ for (j=0;j<NGLLX;j++) {
+ for (i=0;i<NGLL2;i++) {
+ utempx3.tempx3_2D_5_25[j][i] = ux.dummyx_loc_2D_5_25[0][i]*hprime_xxT[j][0] +
+ ux.dummyx_loc_2D_5_25[1][i]*hprime_xxT[j][1] +
+ ux.dummyx_loc_2D_5_25[2][i]*hprime_xxT[j][2] +
+ ux.dummyx_loc_2D_5_25[3][i]*hprime_xxT[j][3] +
+ ux.dummyx_loc_2D_5_25[4][i]*hprime_xxT[j][4];
+
+ utempy3.tempy3_2D_5_25[j][i] = uy.dummyy_loc_2D_5_25[0][i]*hprime_xxT[j][0] +
+ uy.dummyy_loc_2D_5_25[1][i]*hprime_xxT[j][1] +
+ uy.dummyy_loc_2D_5_25[2][i]*hprime_xxT[j][2] +
+ uy.dummyy_loc_2D_5_25[3][i]*hprime_xxT[j][3] +
+ uy.dummyy_loc_2D_5_25[4][i]*hprime_xxT[j][4];
+
+ utempz3.tempz3_2D_5_25[j][i] = uz.dummyz_loc_2D_5_25[0][i]*hprime_xxT[j][0] +
+ uz.dummyz_loc_2D_5_25[1][i]*hprime_xxT[j][1] +
+ uz.dummyz_loc_2D_5_25[2][i]*hprime_xxT[j][2] +
+ uz.dummyz_loc_2D_5_25[3][i]*hprime_xxT[j][3] +
+ uz.dummyz_loc_2D_5_25[4][i]*hprime_xxT[j][4];
+ }
+ }
+
+ for (k=0;k<NGLLZ;k++) {
+ for (j=0;j<NGLLY;j++) {
+ for (i=0;i<NGLLX;i++) {
+
+// compute derivatives of ux, uy and uz with respect to x, y and z
+ xixl = xix[ispec][k][j][i];
+ xiyl = xiy[ispec][k][j][i];
+ xizl = xiz[ispec][k][j][i];
+ etaxl = etax[ispec][k][j][i];
+ etayl = etay[ispec][k][j][i];
+ etazl = etaz[ispec][k][j][i];
+ gammaxl = gammax[ispec][k][j][i];
+ gammayl = gammay[ispec][k][j][i];
+ gammazl = gammaz[ispec][k][j][i];
+ jacobianl = 1.f / (xixl*(etayl*gammazl-etazl*gammayl)-xiyl*(etaxl*gammazl-etazl*gammaxl)+xizl*(etaxl*gammayl-etayl*gammaxl));
+
+ duxdxl = xixl*utempx1.tempx1[k][j][i] + etaxl*tempx2[k][j][i] + gammaxl*utempx3.tempx3[k][j][i];
+ duxdyl = xiyl*utempx1.tempx1[k][j][i] + etayl*tempx2[k][j][i] + gammayl*utempx3.tempx3[k][j][i];
+ duxdzl = xizl*utempx1.tempx1[k][j][i] + etazl*tempx2[k][j][i] + gammazl*utempx3.tempx3[k][j][i];
+
+ duydxl = xixl*utempy1.tempy1[k][j][i] + etaxl*tempy2[k][j][i] + gammaxl*utempy3.tempy3[k][j][i];
+ duydyl = xiyl*utempy1.tempy1[k][j][i] + etayl*tempy2[k][j][i] + gammayl*utempy3.tempy3[k][j][i];
+ duydzl = xizl*utempy1.tempy1[k][j][i] + etazl*tempy2[k][j][i] + gammazl*utempy3.tempy3[k][j][i];
+
+ duzdxl = xixl*utempz1.tempz1[k][j][i] + etaxl*tempz2[k][j][i] + gammaxl*utempz3.tempz3[k][j][i];
+ duzdyl = xiyl*utempz1.tempz1[k][j][i] + etayl*tempz2[k][j][i] + gammayl*utempz3.tempz3[k][j][i];
+ duzdzl = xizl*utempz1.tempz1[k][j][i] + etazl*tempz2[k][j][i] + gammazl*utempz3.tempz3[k][j][i];
+
+// 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 isotropic elements
+ kappal = kappav[ispec][k][j][i];
+ mul = muv[ispec][k][j][i];
+
+ lambdalplus2mul = kappal + 1.33333333333333333333f * mul; // 4./3. = 1.3333333
+ lambdal = lambdalplus2mul - 2.f*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;
+
+// form dot product with test vector
+ utempx1.tempx1[k][j][i] = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl);
+ utempy1.tempy1[k][j][i] = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl);
+ utempz1.tempz1[k][j][i] = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl);
+
+ tempx2[k][j][i] = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl);
+ tempy2[k][j][i] = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl);
+ tempz2[k][j][i] = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl);
+
+ utempx3.tempx3[k][j][i] = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl);
+ utempy3.tempy3[k][j][i] = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl);
+ utempz3.tempz3[k][j][i] = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl);
+
+ }
+ }
+ }
+
+ for (j=0;j<NGLL2;j++) {
+ for (i=0;i<NGLLX;i++) {
+ unewtempx1.newtempx1_2D_25_5[j][i] = hprimewgll_xxT[0][i]*utempx1.tempx1_2D_25_5[j][0] +
+ hprimewgll_xxT[1][i]*utempx1.tempx1_2D_25_5[j][1] +
+ hprimewgll_xxT[2][i]*utempx1.tempx1_2D_25_5[j][2] +
+ hprimewgll_xxT[3][i]*utempx1.tempx1_2D_25_5[j][3] +
+ hprimewgll_xxT[4][i]*utempx1.tempx1_2D_25_5[j][4];
+
+ unewtempy1.newtempy1_2D_25_5[j][i] = hprimewgll_xxT[0][i]*utempy1.tempy1_2D_25_5[j][0] +
+ hprimewgll_xxT[1][i]*utempy1.tempy1_2D_25_5[j][1] +
+ hprimewgll_xxT[2][i]*utempy1.tempy1_2D_25_5[j][2] +
+ hprimewgll_xxT[3][i]*utempy1.tempy1_2D_25_5[j][3] +
+ hprimewgll_xxT[4][i]*utempy1.tempy1_2D_25_5[j][4];
+
+ unewtempz1.newtempz1_2D_25_5[j][i] = hprimewgll_xxT[0][i]*utempz1.tempz1_2D_25_5[j][0] +
+ hprimewgll_xxT[1][i]*utempz1.tempz1_2D_25_5[j][1] +
+ hprimewgll_xxT[2][i]*utempz1.tempz1_2D_25_5[j][2] +
+ hprimewgll_xxT[3][i]*utempz1.tempz1_2D_25_5[j][3] +
+ hprimewgll_xxT[4][i]*utempz1.tempz1_2D_25_5[j][4];
+ }
+ }
+
+ for (k=0;k<NGLLZ;k++) {
+ for (j=0;j<NGLLX;j++) {
+ for (i=0;i<NGLLX;i++) {
+ newtempx2[k][j][i] = tempx2[k][0][i]*hprimewgll_xx[j][0] +
+ tempx2[k][1][i]*hprimewgll_xx[j][1] +
+ tempx2[k][2][i]*hprimewgll_xx[j][2] +
+ tempx2[k][3][i]*hprimewgll_xx[j][3] +
+ tempx2[k][4][i]*hprimewgll_xx[j][4];
+
+ newtempy2[k][j][i] = tempy2[k][0][i]*hprimewgll_xx[j][0] +
+ tempy2[k][1][i]*hprimewgll_xx[j][1] +
+ tempy2[k][2][i]*hprimewgll_xx[j][2] +
+ tempy2[k][3][i]*hprimewgll_xx[j][3] +
+ tempy2[k][4][i]*hprimewgll_xx[j][4];
+
+ newtempz2[k][j][i] = tempz2[k][0][i]*hprimewgll_xx[j][0] +
+ tempz2[k][1][i]*hprimewgll_xx[j][1] +
+ tempz2[k][2][i]*hprimewgll_xx[j][2] +
+ tempz2[k][3][i]*hprimewgll_xx[j][3] +
+ tempz2[k][4][i]*hprimewgll_xx[j][4];
+ }
+ }
+ }
+
+ for (j=0;j<NGLLX;j++) {
+ for (i=0;i<NGLL2;i++) {
+ unewtempx3.newtempx3_2D_5_25[j][i] = utempx3.tempx3_2D_5_25[0][i]*hprimewgll_xx[j][0] +
+ utempx3.tempx3_2D_5_25[1][i]*hprimewgll_xx[j][1] +
+ utempx3.tempx3_2D_5_25[2][i]*hprimewgll_xx[j][2] +
+ utempx3.tempx3_2D_5_25[3][i]*hprimewgll_xx[j][3] +
+ utempx3.tempx3_2D_5_25[4][i]*hprimewgll_xx[j][4];
+
+ unewtempy3.newtempy3_2D_5_25[j][i] = utempy3.tempy3_2D_5_25[0][i]*hprimewgll_xx[j][0] +
+ utempy3.tempy3_2D_5_25[1][i]*hprimewgll_xx[j][1] +
+ utempy3.tempy3_2D_5_25[2][i]*hprimewgll_xx[j][2] +
+ utempy3.tempy3_2D_5_25[3][i]*hprimewgll_xx[j][3] +
+ utempy3.tempy3_2D_5_25[4][i]*hprimewgll_xx[j][4];
+
+ unewtempz3.newtempz3_2D_5_25[j][i] = utempz3.tempz3_2D_5_25[0][i]*hprimewgll_xx[j][0] +
+ utempz3.tempz3_2D_5_25[1][i]*hprimewgll_xx[j][1] +
+ utempz3.tempz3_2D_5_25[2][i]*hprimewgll_xx[j][2] +
+ utempz3.tempz3_2D_5_25[3][i]*hprimewgll_xx[j][3] +
+ utempz3.tempz3_2D_5_25[4][i]*hprimewgll_xx[j][4];
+ }
+ }
+
+ for (k=0;k<NGLLZ;k++) {
+ for (j=0;j<NGLLY;j++) {
+ for (i=0;i<NGLLX;i++) {
+
+// sum contributions from each element to the global mesh using indirect addressing
+ iglob = ibool[ispec][k][j][i];
+ accelx[iglob] -= (wgllwgll_yz[k][j]*unewtempx1.newtempx1[k][j][i] + wgllwgll_xz[k][i]*newtempx2[k][j][i] + wgllwgll_xy[j][i]*unewtempx3.newtempx3[k][j][i]);
+ accely[iglob] -= (wgllwgll_yz[k][j]*unewtempy1.newtempy1[k][j][i] + wgllwgll_xz[k][i]*newtempy2[k][j][i] + wgllwgll_xy[j][i]*unewtempy3.newtempy3[k][j][i]);
+ accelz[iglob] -= (wgllwgll_yz[k][j]*unewtempz1.newtempz1[k][j][i] + wgllwgll_xz[k][i]*newtempz2[k][j][i] + wgllwgll_xy[j][i]*unewtempz3.newtempz3[k][j][i]);
+
+ }
+ }
+ }
+
+ } // end of main loop on all the elements
+
+// big loop over all the global points (not elements) in the mesh to update
+// the acceleration and velocity vectors
+ for (i=0;i<NGLOB;i++) {
+ accelx[i] *= rmass_inverse[i];
+ accely[i] *= rmass_inverse[i];
+ accelz[i] *= rmass_inverse[i];
+ }
+
+// add the earthquake source at a given grid point
+// this is negligible and is intrinsically serial because it is done by only
+// one grid point out of several millions typically
+// we subtract one to the element number of the source because arrays start at 0 in C
+// compute current time
+ time = (it-1)*deltat;
+ accelz[ibool[NSPEC_SOURCE-1][1][1][1]] += 1.e4f * (1.f - 2.f*a*(time-t0)*(time-t0)) * expf(-a*(time-t0)*(time-t0)) / rho;
+
+ for (i=0;i<NGLOB;i++) {
+ velocx[i] += deltatover2*accelx[i];
+ velocy[i] += deltatover2*accely[i];
+ velocz[i] += deltatover2*accelz[i];
+ }
+
+// record a seismogram to check that the simulation went well
+// we subtract one to the element number of the receiver because arrays start at 0 in C
+ seismogram[it-1] = displz[ibool[NSPEC_STATION-1][1][1][1]];
+
+ } // end of the serial time loop
+
+// save the seismogram at the end of the run
+ if((IIN = fopen("seismogram_C_single.txt","w")) == NULL) {
+ fprintf(stderr,"Cannot create file seismogram_C_single.txt, exiting...\n");
+ exit(1);
+ }
+ for (it=0;it<NSTEP;it++)
+ { fprintf(IIN,"%e %e\n",it*deltat,seismogram[it]);
+ }
+ fclose(IIN);
+
+ printf("\nEnd of the program\n\n");
+
+ }
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/older_serial_specfem3D_inlined_v03_is_the_fastest_with_function_calls.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/older_serial_specfem3D_inlined_v03_is_the_fastest_with_function_calls.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/older_serial_specfem3D_inlined_v03_is_the_fastest_with_function_calls.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,647 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ program serial_specfem3D
+
+ implicit none
+
+!!!!!!!!!!
+!!!!!!!!!! All the arrays below use static memory allocation,
+!!!!!!!!!! using constant sizes defined in values_from_mesher.h.
+!!!!!!!!!! This is done purposely to improve performance (Fortran compilers
+!!!!!!!!!! can optimize much more when the size of the loops and arrays
+!!!!!!!!!! is known at compile time).
+!!!!!!!!!! NGLLX, NGLLY and NGLLZ are set equal to 5,
+!!!!!!!!!! therefore each element contains NGLLX * NGLLY * NGLLZ = 125 points.
+!!!!!!!!!!
+
+!!!!!!!!!!
+!!!!!!!!!! All the calculations are done in single precision.
+!!!!!!!!!! We do not need double precision in SPECFEM3D.
+!!!!!!!!!!
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "DATABASES_FOR_SOLVER/values_from_mesher_f90.h"
+
+! constant value of the time step in the main time loop
+ real(kind=4), parameter :: deltatover2 = 0.5*deltat, deltatsqover2 = 0.5*deltat*deltat
+
+! for the source time function
+ real, parameter :: pi = 3.141592653589793
+ real, parameter :: f0 = 1. / 50.
+ real, parameter :: t0 = 1.2 / f0
+ real, parameter :: a = pi*pi*f0*f0
+
+ integer, parameter :: NTSTEP_BETWEEN_OUTPUT_INFO = 200
+
+ integer, parameter :: IIN = 40
+
+! number of GLL integration points in each direction of an element (degree plus one)
+ integer, parameter :: NGLLX = 5
+ integer, parameter :: NGLLY = NGLLX
+ integer, parameter :: NGLLZ = NGLLX
+
+! 3-D simulation
+ integer, parameter :: NDIM = 3
+
+!!!!!!!!!! real(kind=4), parameter :: VERYSMALLVAL = 1.e-24
+
+! displacement threshold above which we consider that the code became unstable
+ real(kind=4), parameter :: STABILITY_THRESHOLD = 1.e+25
+
+! approximate density of the geophysical medium in which the source is located
+! this value is only a constant scaling factor therefore it does not really matter
+ real(kind=4), parameter :: rho = 4500.
+
+! global displacement, velocity and acceleration vectors
+ real(kind=4), dimension(NDIM,NGLOB) :: displ,veloc,accel
+
+! global diagonal mass matrix
+ real(kind=4), dimension(NGLOB) :: rmass_inverse
+
+! record a seismogram to check that the simulation went well
+ real(kind=4), dimension(NSTEP) :: seismogram
+
+! time step
+ integer it
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: ibool
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,kappav,muv,jacobian
+
+! array with derivatives of Lagrange polynomials and precalculated products
+!! DK DK store transpose of matrix
+ real(kind=4), dimension(NGLLX,NGLLX) :: hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT
+ real(kind=4), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=4), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=4), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
+ newtempx1,newtempx2,newtempx3,newtempy1,newtempy2,newtempy3,newtempz1,newtempz2,newtempz3
+
+ integer :: ispec,iglob,i,j,k !!!!!!!!!!!!! ,l
+
+ real(kind=4) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=4) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+ real(kind=4) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=4) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+ real(kind=4) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz,sigma_yx,sigma_zx,sigma_zy
+! real(kind=4) hp1,hp2,hp3
+ real(kind=4) fac1,fac2,fac3,lambdal,mul,lambdalplus2mul,kappal
+! real(kind=4) tempx1l,tempx2l,tempx3l,tempy1l,tempy2l,tempy3l,tempz1l,tempz2l,tempz3l
+
+ real(kind=4) Usolidnorm,current_value,time,memory_size
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc
+
+! timer to count elapsed time
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+ integer ihours,iminutes,iseconds,int_tCPU
+ double precision :: time_start,time_end,tCPU
+
+! estimate of total memory size used
+ print *
+ print *,'NSPEC = ',NSPEC
+ print *,'NGLOB = ',NGLOB
+ print *
+
+ print *,'NSTEP = ',NSTEP
+ print *,'deltat = ',deltat
+ print *
+
+! estimate total memory size (the size of a real number is 4 bytes)
+! we perform the calculation in single precision rather than integer
+! to avoid integer overflow in the case of very large meshes
+ memory_size = 4. * ((3.*NDIM + 1.) * NGLOB + 12. * real(NGLLX*NGLLY*NGLLZ)*real(NSPEC))
+ print *,'approximate total memory size used = ',memory_size/1024./1024.,' Mb'
+ print *
+
+! make sure the source element number is an integer
+ if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...'
+
+! read the mesh from external file
+ open(unit=IIN,file='DATABASES_FOR_SOLVER/proc000000_reg1_database.dat',status='old')
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+! read real numbers here
+ read(IIN,*) xix(i,j,k,ispec)
+ read(IIN,*) xiy(i,j,k,ispec)
+ read(IIN,*) xiz(i,j,k,ispec)
+ read(IIN,*) etax(i,j,k,ispec)
+ read(IIN,*) etay(i,j,k,ispec)
+ read(IIN,*) etaz(i,j,k,ispec)
+ read(IIN,*) gammax(i,j,k,ispec)
+ read(IIN,*) gammay(i,j,k,ispec)
+ read(IIN,*) gammaz(i,j,k,ispec)
+ read(IIN,*) kappav(i,j,k,ispec)
+ read(IIN,*) muv(i,j,k,ispec)
+
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+ jacobian(i,j,k,ispec) = 1. / (xixl*(etayl*gammazl-etazl*gammayl)- &
+ xiyl*(etaxl*gammazl-etazl*gammaxl)+xizl*(etaxl*gammayl-etayl*gammaxl))
+
+
+! read an integer here
+ read(IIN,*) ibool(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+ do i = 1,NGLOB
+ read(IIN,*) rmass_inverse(i)
+! the real exactly diagonal mass matrix is read (not its inverse)
+! therefore invert it here once and for all
+ rmass_inverse(i) = 1. / rmass_inverse(i)
+ enddo
+ close(IIN)
+
+ open(unit=IIN,file='DATABASES_FOR_SOLVER/matrices.dat',status='old')
+ do j=1,NGLLY
+ do i=1,NGLLX
+ read(IIN,*) hprime_xx(i,j)
+ read(IIN,*) hprimewgll_xx(i,j)
+ read(IIN,*) wgllwgll_yz(i,j)
+ read(IIN,*) wgllwgll_xz(i,j)
+ read(IIN,*) wgllwgll_xy(i,j)
+ enddo
+ enddo
+ close(IIN)
+
+!! DK DK define transpose of 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
+
+ if(NGLLX /= 5) stop 'this inlined version with matrix products following Deville (2002) is only valid for NGLL = 5'
+
+! clear initial vectors before starting the time loop
+! (can remain serial because done only once before entering the time loop)
+ displ(:,:) = 0. !!!!!!!!!! VERYSMALLVAL
+ veloc(:,:) = 0.
+ accel(:,:) = 0.
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! start of the time loop (which must remain serial obviously)
+ do it = 1,NSTEP
+
+! compute maximum of norm of displacement from time to time and display it
+! in order to monitor the simulation
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
+ Usolidnorm = -1.
+ do iglob = 1,NGLOB
+ current_value = sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2)
+ if(current_value > Usolidnorm) Usolidnorm = current_value
+ enddo
+ write(*,*) 'Time step # ',it,' out of ',NSTEP
+! compute current time
+ time = (it-1)*deltat
+ write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm
+! check stability of the code, exit if unstable
+ if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up'
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! elapsed time since beginning of the simulation
+ tCPU = time_end - time_start
+ int_tCPU = int(tCPU)
+ ihours = int_tCPU / 3600
+ iminutes = (int_tCPU - 3600*ihours) / 60
+ iseconds = int_tCPU - 3600*ihours - 60*iminutes
+ write(*,*) 'Elapsed time in seconds = ',tCPU
+ write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ write(*,*)
+
+ endif
+
+! big loop over all the global points (not elements) in the mesh to update
+! the displacement and velocity vectors and clear the acceleration vector
+ displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsqover2*accel(:,:)
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+ accel(:,:) = 0.
+
+! big loop over all the elements in the mesh to localize data
+! from the global vectors to the local mesh
+! using indirect addressing (contained in array ibool)
+! and then to compute the elemental contribution
+! to the acceleration vector of each element of the finite-element mesh
+ do ispec = 1,NSPEC
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ dummyx_loc(i,j,k) = displ(1,iglob)
+ dummyy_loc(i,j,k) = displ(2,iglob)
+ dummyz_loc(i,j,k) = displ(3,iglob)
+ enddo
+ enddo
+ enddo
+
+!! DK DK subroutines adapted from Deville, Fischer and Mund, High-order methods
+!! DK DK for incompressible fluid flow, Cambridge University Press (2002),
+!! DK DK pages 386 and 389 and Figure 8.3.1
+ call mxm_m1_m2_5points(hprime_xx,dummyx_loc,dummyy_loc,dummyz_loc,tempx1,tempy1,tempz1)
+
+ do k = 1,NGLLX
+ call mxm_m1_m1_5points(dummyx_loc(1,1,k),dummyy_loc(1,1,k),dummyz_loc(1,1,k), &
+ hprime_xxT,tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k))
+ enddo
+
+ call mxm_m2_m1_5points(dummyx_loc,dummyy_loc,dummyz_loc,hprime_xxT,tempx3,tempy3,tempz3)
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+! tempx1l = 0.
+! tempx2l = 0.
+! tempx3l = 0.
+
+! tempy1l = 0.
+! tempy2l = 0.
+! tempy3l = 0.
+
+! tempz1l = 0.
+! tempz2l = 0.
+! tempz3l = 0.
+
+! do l=1,NGLLX
+! hp1 = hprime_xx(i,l)
+! tempx1l = tempx1l + dummyx_loc(l,j,k)*hp1
+! tempy1l = tempy1l + dummyy_loc(l,j,k)*hp1
+! tempz1l = tempz1l + dummyz_loc(l,j,k)*hp1
+
+! hp2 = hprime_xx(j,l)
+! tempx2l = tempx2l + dummyx_loc(i,l,k)*hp2
+! tempy2l = tempy2l + dummyy_loc(i,l,k)*hp2
+! tempz2l = tempz2l + dummyz_loc(i,l,k)*hp2
+
+! hp3 = hprime_xx(k,l)
+! tempx3l = tempx3l + dummyx_loc(i,j,l)*hp3
+! tempy3l = tempy3l + dummyy_loc(i,j,l)*hp3
+! tempz3l = tempz3l + dummyz_loc(i,j,l)*hp3
+! enddo
+
+! compute 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)
+! jacobianl = 1. / (xixl*(etayl*gammazl-etazl*gammayl)- &
+! xiyl*(etaxl*gammazl-etazl*gammaxl)+xizl*(etaxl*gammayl-etayl*gammaxl))
+!! DK DK this is now precomputed and stored to avoid a costly operation
+ jacobianl = jacobian(i,j,k,ispec)
+
+ 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 isotropic elements
+ kappal = kappav(i,j,k,ispec)
+ mul = muv(i,j,k,ispec)
+
+! lambdalplus2mul = kappal + (4./3.) * mul
+!! DK DK precompute the 4/3 ratio to avoid a division here
+ lambdalplus2mul = kappal + 1.33333333333333 * 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
+
+ ! define symmetric components of sigma
+ sigma_yx = sigma_xy
+ sigma_zx = sigma_xz
+ sigma_zy = sigma_yz
+
+ ! form dot product with test vector, non-symmetric form (which is useful in the case of PML)
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl) ! this goes to accel_x
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl) ! this goes to accel_y
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl) ! this goes to accel_z
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl) ! this goes to accel_x
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl) ! this goes to accel_y
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl) ! this goes to accel_z
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl) ! this goes to accel_x
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl) ! this goes to accel_y
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl) ! this goes to accel_z
+
+ enddo
+ enddo
+ enddo
+
+!! DK DK subroutines adapted from Deville, Fischer and Mund, High-order methods
+!! DK DK for incompressible fluid flow, Cambridge University Press (2002),
+!! DK DK pages 386 and 389 and Figure 8.3.1
+ call mxm_m1_m2_5points(hprimewgll_xxT,tempx1,tempy1,tempz1,newtempx1,newtempy1,newtempz1)
+
+ do k = 1,NGLLX
+ call mxm_m1_m1_5points(tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k), &
+ hprimewgll_xx,newtempx2(1,1,k),newtempy2(1,1,k),newtempz2(1,1,k))
+ enddo
+
+ call mxm_m2_m1_5points(tempx3,tempy3,tempz3,hprimewgll_xx,newtempx3,newtempy3,newtempz3)
+
+! do k=1,NGLLZ
+! do j=1,NGLLY
+! do i=1,NGLLX
+
+! tempx1l = 0.
+! tempy1l = 0.
+! tempz1l = 0.
+
+! tempx2l = 0.
+! tempy2l = 0.
+! tempz2l = 0.
+
+! tempx3l = 0.
+! tempy3l = 0.
+! tempz3l = 0.
+
+! 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
+
+! fac2 = hprimewgll_xx(l,j)
+! tempx2l = tempx2l + tempx2(i,l,k)*fac2
+! tempy2l = tempy2l + tempy2(i,l,k)*fac2
+! tempz2l = tempz2l + tempz2(i,l,k)*fac2
+
+! fac3 = hprimewgll_xx(l,k)
+! tempx3l = tempx3l + tempx3(i,j,l)*fac3
+! tempy3l = tempy3l + tempy3(i,j,l)*fac3
+! tempz3l = tempz3l + tempz3(i,j,l)*fac3
+! enddo
+
+! enddo
+! 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 from each element to the global mesh using indirect addressing
+ iglob = ibool(i,j,k,ispec)
+ accel(1,iglob) = accel(1,iglob) - (fac1*newtempx1(i,j,k) + fac2*newtempx2(i,j,k) + fac3*newtempx3(i,j,k))
+ accel(2,iglob) = accel(2,iglob) - (fac1*newtempy1(i,j,k) + fac2*newtempy2(i,j,k) + fac3*newtempy3(i,j,k))
+ accel(3,iglob) = accel(3,iglob) - (fac1*newtempz1(i,j,k) + fac2*newtempz2(i,j,k) + fac3*newtempz3(i,j,k))
+
+ enddo
+ enddo
+ enddo
+
+ enddo ! end of main loop on all the elements
+
+! big loop over all the global points (not elements) in the mesh to update
+! the acceleration and velocity vectors
+ accel(1,:) = accel(1,:)*rmass_inverse(:)
+ accel(2,:) = accel(2,:)*rmass_inverse(:)
+ accel(3,:) = accel(3,:)*rmass_inverse(:)
+
+! add the earthquake source at a given grid point
+! this is negligible and can remain serial because it is done by only
+! one grid point out of several millions typically
+ iglob = ibool(2,2,2,NSPEC_SOURCE)
+! compute current time
+ time = (it-1)*deltat
+ accel(3,iglob) = accel(3,iglob) + 1.e4 * (1.-2.*a*(time-t0)**2) * exp(-a*(time-t0)**2) / rho
+
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+
+! record a seismogram to check that the simulation went well
+ seismogram(it) = displ(3,ibool(2,2,2,NSPEC_STATION))
+
+ enddo ! end of the serial time loop
+
+! save the seismogram at the end of the run
+ open(unit=IIN,file='seismogram_F90.txt',status='unknown')
+ do it = 1,NSTEP
+ write(IIN,*) (it-1)*deltat,seismogram(it)
+ enddo
+ close(IIN)
+
+ end program serial_specfem3D
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! DK DK subroutines adapted from Deville, Fischer and Mund, High-order methods
+!! DK DK for incompressible fluid flow, Cambridge University Press (2002),
+!! DK DK pages 386 and 389 and Figure 8.3.1
+
+ subroutine mxm_m1_m2_5points(A,B1,B2,B3,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m1,NGLLX) :: A
+ real(kind=4), dimension(NGLLX,m2) :: B1,B2,B3
+ real(kind=4), dimension(m1,m2) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m2
+ do i=1,m1
+
+ C1(i,j) = A(i,1)*B1(1,j) + &
+ A(i,2)*B1(2,j) + &
+ A(i,3)*B1(3,j) + &
+ A(i,4)*B1(4,j) + &
+ A(i,5)*B1(5,j)
+
+ C2(i,j) = A(i,1)*B2(1,j) + &
+ A(i,2)*B2(2,j) + &
+ A(i,3)*B2(3,j) + &
+ A(i,4)*B2(4,j) + &
+ A(i,5)*B2(5,j)
+
+ C3(i,j) = A(i,1)*B3(1,j) + &
+ A(i,2)*B3(2,j) + &
+ A(i,3)*B3(3,j) + &
+ A(i,4)*B3(4,j) + &
+ A(i,5)*B3(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m1_m2_5points
+
+!---------
+
+ subroutine mxm_m1_m1_5points(A1,A2,A3,B,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m1,NGLLX) :: A1,A2,A3
+ real(kind=4), dimension(NGLLX,m1) :: B
+ real(kind=4), dimension(m1,m1) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m1
+ do i=1,m1
+
+ C1(i,j) = A1(i,1)*B(1,j) + &
+ A1(i,2)*B(2,j) + &
+ A1(i,3)*B(3,j) + &
+ A1(i,4)*B(4,j) + &
+ A1(i,5)*B(5,j)
+
+ C2(i,j) = A2(i,1)*B(1,j) + &
+ A2(i,2)*B(2,j) + &
+ A2(i,3)*B(3,j) + &
+ A2(i,4)*B(4,j) + &
+ A2(i,5)*B(5,j)
+
+ C3(i,j) = A3(i,1)*B(1,j) + &
+ A3(i,2)*B(2,j) + &
+ A3(i,3)*B(3,j) + &
+ A3(i,4)*B(4,j) + &
+ A3(i,5)*B(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m1_m1_5points
+
+!---------
+
+ subroutine mxm_m2_m1_5points(A1,A2,A3,B,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m2,NGLLX) :: A1,A2,A3
+ real(kind=4), dimension(NGLLX,m1) :: B
+ real(kind=4), dimension(m2,m1) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m1
+ do i=1,m2
+
+ C1(i,j) = A1(i,1)*B(1,j) + &
+ A1(i,2)*B(2,j) + &
+ A1(i,3)*B(3,j) + &
+ A1(i,4)*B(4,j) + &
+ A1(i,5)*B(5,j)
+
+ C2(i,j) = A2(i,1)*B(1,j) + &
+ A2(i,2)*B(2,j) + &
+ A2(i,3)*B(3,j) + &
+ A2(i,4)*B(4,j) + &
+ A2(i,5)*B(5,j)
+
+ C3(i,j) = A3(i,1)*B(1,j) + &
+ A3(i,2)*B(2,j) + &
+ A3(i,3)*B(3,j) + &
+ A3(i,4)*B(4,j) + &
+ A3(i,5)*B(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m2_m1_5points
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_22dec2008_NGLOB.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_22dec2008_NGLOB.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_22dec2008_NGLOB.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,479 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ program serial_specfem3D
+
+ implicit none
+
+!!!!!!!!!!
+!!!!!!!!!! All the arrays below use static memory allocation,
+!!!!!!!!!! using constant sizes defined in values_from_mesher.h.
+!!!!!!!!!! This is done purposely to improve performance (Fortran compilers
+!!!!!!!!!! can optimize much more when the size of the loops and arrays
+!!!!!!!!!! is known at compile time).
+!!!!!!!!!! NGLLX, NGLLY and NGLLZ are set equal to 5,
+!!!!!!!!!! therefore each element contains NGLLX * NGLLY * NGLLZ = 125 points.
+!!!!!!!!!!
+
+!!!!!!!!!!
+!!!!!!!!!! All the calculations are done in single precision.
+!!!!!!!!!! We do not need double precision in SPECFEM3D.
+!!!!!!!!!!
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "values_from_mesher_f90.h"
+
+! constant value of the time step in the main time loop
+ real(kind=4), parameter :: deltatover2 = 0.5*deltat, deltatsqover2 = 0.5*deltat*deltat
+
+! element in which the source is located
+ integer, parameter :: NSPEC_SOURCE = NSPEC / 2
+
+! for the source time function
+ real, parameter :: pi = 3.14159265
+ real, parameter :: f0 = 1. / 50.
+ real, parameter :: t0 = 1.2 / f0
+ real, parameter :: a = pi*pi*f0*f0
+
+ integer, parameter :: NTSTEP_BETWEEN_OUTPUT_INFO = 100
+
+ integer, parameter :: IIN = 40
+
+! number of GLL integration points in each direction of an element (degree plus one)
+ integer, parameter :: NGLLX = 5
+ integer, parameter :: NGLLY = NGLLX
+ integer, parameter :: NGLLZ = NGLLX
+
+! 3-D simulation
+ integer, parameter :: NDIM = 3
+
+ real(kind=4), parameter :: VERYSMALLVAL = 1.e-24
+
+! displacement threshold above which we consider that the code became unstable
+ real(kind=4), parameter :: STABILITY_THRESHOLD = 1.e+25
+
+! approximate density of the medium in which the source is located
+ real(kind=4), parameter :: rho = 4500.
+
+! global displacement, velocity and acceleration vectors
+ real(kind=4), dimension(NDIM,NGLOB) :: displ,veloc,accel
+
+! global diagonal mass matrix
+ real(kind=4), dimension(NGLOB) :: rmass_inverse
+
+! record a seismogram to check that the simulation went well
+ real(kind=4), dimension(NSTEP) :: seismogram
+
+! time step
+ integer it
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: ibool
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,kappav,muv, &
+ dummyx_glob,dummyy_glob,dummyz_glob
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=4), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=4), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=4), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=4), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+
+ integer :: ispec,iglob,i,j,k,l
+
+ real(kind=4) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=4) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+ real(kind=4) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=4) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+ real(kind=4) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
+ real(kind=4) hp1,hp2,hp3,fac1,fac2,fac3,lambdal,mul,lambdalplus2mul,kappal
+ real(kind=4) tempx1l,tempx2l,tempx3l,tempy1l,tempy2l,tempy3l,tempz1l,tempz2l,tempz3l
+
+ real(kind=4) Usolidnorm,current_value,time,memory_size
+
+! timer to count elapsed time
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+ integer ihours,iminutes,iseconds,int_tCPU
+ double precision :: time_start,time_end,tCPU
+
+! estimate of total memory size used
+ print *
+ print *,'NSPEC = ',NSPEC
+ print *,'NGLOB = ',NGLOB
+ print *
+
+ print *,'NSTEP = ',NSTEP
+ print *,'deltat = ',deltat
+ print *
+
+! estimate total memory size (the size of a real number is 4 bytes)
+! we perform the calculation in single precision rather than integer
+! to avoid integer overflow in the case of very large meshes
+ memory_size = 4. * ((3.*NDIM + 1.) * NGLOB + 16. * real(NGLLX*NGLLY*NGLLZ)*real(NSPEC))
+ print *,'approximate total memory size used = ',memory_size/1024./1024.,' Mb'
+ print *
+
+! make sure the source element number is an integer
+ if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...'
+
+! read the mesh from external file
+ open(unit=IIN,file='database.dat',status='old')
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+! read real numbers here
+ read(IIN,*) xix(i,j,k,ispec)
+ read(IIN,*) xiy(i,j,k,ispec)
+ read(IIN,*) xiz(i,j,k,ispec)
+ read(IIN,*) etax(i,j,k,ispec)
+ read(IIN,*) etay(i,j,k,ispec)
+ read(IIN,*) etaz(i,j,k,ispec)
+ read(IIN,*) gammax(i,j,k,ispec)
+ read(IIN,*) gammay(i,j,k,ispec)
+ read(IIN,*) gammaz(i,j,k,ispec)
+ read(IIN,*) kappav(i,j,k,ispec)
+ read(IIN,*) muv(i,j,k,ispec)
+
+! read an integer here
+ read(IIN,*) ibool(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+ do i = 1,NGLOB
+ read(IIN,*) rmass_inverse(i)
+ enddo
+ close(IIN)
+
+ open(unit=IIN,file='matrices.dat',status='old')
+ do j=1,NGLLY
+ do i=1,NGLLX
+ read(IIN,*) hprime_xx(i,j)
+ read(IIN,*) hprimewgll_xx(i,j)
+ read(IIN,*) wgllwgll_yz(i,j)
+ read(IIN,*) wgllwgll_xz(i,j)
+ read(IIN,*) wgllwgll_xy(i,j)
+ enddo
+ enddo
+ close(IIN)
+
+! clear initial vectors before starting the time loop
+! (can remain serial because done only once before entering the time loop)
+ displ(:,:) = 0. ! 1. !!!!!!!!! VERYSMALLVAL
+ veloc(:,:) = 0. ! 1. !!!!!!!!! 0.
+ accel(:,:) = 0. ! 1. !!!!!!!!! 0.
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! start of the time loop (which must remain serial obviously)
+ do it = 1,NSTEP
+
+! compute maximum of norm of displacement from time to time and display it
+! in order to monitor the simulation
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then
+!!!!!!!!! if(it == 2100 .or. it == 5) then
+ Usolidnorm = -1.
+ do iglob = 1,NGLOB
+ current_value = sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2)
+ if(current_value > Usolidnorm) Usolidnorm = current_value
+ enddo
+ write(*,*) 'Time step # ',it,' out of ',NSTEP
+! compute current time
+ time = (it-1)*deltat
+ write(*,*) 'Time = ',time,' seconds out of ',(NSTEP-1)*deltat,' seconds'
+ write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm
+! check stability of the code, exit if unstable
+ if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up'
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! elapsed time since beginning of the simulation
+ tCPU = time_end - time_start
+ int_tCPU = int(tCPU)
+ ihours = int_tCPU / 3600
+ iminutes = (int_tCPU - 3600*ihours) / 60
+ iseconds = int_tCPU - 3600*ihours - 60*iminutes
+ write(*,*) 'Elapsed time in seconds = ',tCPU
+ write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ write(*,*)
+
+ endif
+
+! big loop over all the global points (not elements) in the mesh to update
+! the displacement and velocity vectors and clear the acceleration vector
+ displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsqover2*accel(:,:)
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+ accel(:,:) = 0.
+
+! big loop over all the elements in the mesh to localize data
+! from the global vectors to the local mesh
+! using indirect addressing (contained in array ibool)
+! and then to compute the elemental contribution
+! to the acceleration vector of each element of the finite-element mesh
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ dummyx_glob(i,j,k,ispec) = displ(1,iglob)
+ dummyy_glob(i,j,k,ispec) = displ(2,iglob)
+ dummyz_glob(i,j,k,ispec) = displ(3,iglob)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0.
+ tempx2l = 0.
+ tempx3l = 0.
+
+ tempy1l = 0.
+ tempy2l = 0.
+ tempy3l = 0.
+
+ tempz1l = 0.
+ tempz2l = 0.
+ tempz3l = 0.
+
+ do l=1,NGLLX
+ hp1 = hprime_xx(i,l)
+ tempx1l = tempx1l + dummyx_glob(l,j,k,ispec)*hp1
+ tempy1l = tempy1l + dummyy_glob(l,j,k,ispec)*hp1
+ tempz1l = tempz1l + dummyz_glob(l,j,k,ispec)*hp1
+
+ hp2 = hprime_xx(j,l)
+ tempx2l = tempx2l + dummyx_glob(i,l,k,ispec)*hp2
+ tempy2l = tempy2l + dummyy_glob(i,l,k,ispec)*hp2
+ tempz2l = tempz2l + dummyz_glob(i,l,k,ispec)*hp2
+
+ hp3 = hprime_xx(k,l)
+ tempx3l = tempx3l + dummyx_glob(i,j,l,ispec)*hp3
+ tempy3l = tempy3l + dummyy_glob(i,j,l,ispec)*hp3
+ tempz3l = tempz3l + dummyz_glob(i,j,l,ispec)*hp3
+ enddo
+
+! compute 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)
+ jacobianl = 1. / (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 isotropic elements
+ kappal = kappav(i,j,k,ispec)
+ mul = muv(i,j,k,ispec)
+
+ lambdalplus2mul = kappal + (4./3.) * 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
+
+! form dot product with test vector
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+
+ enddo
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0.
+ tempy1l = 0.
+ tempz1l = 0.
+
+ tempx2l = 0.
+ tempy2l = 0.
+ tempz2l = 0.
+
+ tempx3l = 0.
+ tempy3l = 0.
+ tempz3l = 0.
+
+ 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
+
+ fac2 = hprimewgll_xx(l,j)
+ tempx2l = tempx2l + tempx2(i,l,k)*fac2
+ tempy2l = tempy2l + tempy2(i,l,k)*fac2
+ tempz2l = tempz2l + tempz2(i,l,k)*fac2
+
+ fac3 = hprimewgll_xx(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 contributions from each element to the global mesh using indirect addressing
+! iglob = ibool(i,j,k,ispec)
+! accel(1,iglob) = accel(1,iglob) - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
+! accel(2,iglob) = accel(2,iglob) - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
+! accel(3,iglob) = accel(3,iglob) - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
+
+!! DK DK made this local, with no dependencies
+ dummyx_glob(i,j,k,ispec) = - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
+ dummyy_glob(i,j,k,ispec) = - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
+ dummyz_glob(i,j,k,ispec) = - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
+
+ enddo
+ enddo
+ enddo
+
+ enddo ! end of main loop on all the elements
+
+!! DK DK added a gather phase with data dependencies and need for atomicity
+!! DK DK there is no real need to distinguish points inside each element
+!! DK DK (i.e., not on faces, edges or corners) for which there are no dependencies
+!! DK DK because they only represent 3^3 = 27 points out of 5^3 = 125
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ accel(1,iglob) = accel(1,iglob) + dummyx_glob(i,j,k,ispec)
+ accel(2,iglob) = accel(2,iglob) + dummyy_glob(i,j,k,ispec)
+ accel(3,iglob) = accel(3,iglob) + dummyz_glob(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+! big loop over all the global points (not elements) in the mesh to update
+! the acceleration and velocity vectors
+ accel(1,:) = accel(1,:)*rmass_inverse(:)
+ accel(2,:) = accel(2,:)*rmass_inverse(:)
+ accel(3,:) = accel(3,:)*rmass_inverse(:)
+
+! add the earthquake source at a given grid point
+! this is negligible and can remain serial because it is done by only
+! one grid point out of several millions typically
+ iglob = ibool(2,2,2,NSPEC_SOURCE)
+! compute current time
+ time = (it-1)*deltat
+ accel(3,iglob) = accel(3,iglob) + 1.e4 * (1.-2.*a*(time-t0)**2) * exp(-a*(time-t0)**2) / rho
+
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+
+! record a seismogram to check that the simulation went well
+! select a point in an element near the end of the mesh, since the source is in the middle
+ iglob = ibool(2,2,2,NSPEC - 10)
+ seismogram(it) = displ(3,iglob)
+
+ enddo ! end of the serial time loop
+
+! save the seismogram at the end of the run
+ open(unit=IIN,file='seismogram_F90.txt',status='unknown')
+ do it = 1,NSTEP
+ write(IIN,*) (it-1)*deltat,seismogram(it)
+ enddo
+ close(IIN)
+
+ end program serial_specfem3D
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_22dec2008_NSPEC.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_22dec2008_NSPEC.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_22dec2008_NSPEC.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,499 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ program serial_specfem3D
+
+ implicit none
+
+!!!!!!!!!!
+!!!!!!!!!! All the arrays below use static memory allocation,
+!!!!!!!!!! using constant sizes defined in values_from_mesher.h.
+!!!!!!!!!! This is done purposely to improve performance (Fortran compilers
+!!!!!!!!!! can optimize much more when the size of the loops and arrays
+!!!!!!!!!! is known at compile time).
+!!!!!!!!!! NGLLX, NGLLY and NGLLZ are set equal to 5,
+!!!!!!!!!! therefore each element contains NGLLX * NGLLY * NGLLZ = 125 points.
+!!!!!!!!!!
+
+!!!!!!!!!!
+!!!!!!!!!! All the calculations are done in single precision.
+!!!!!!!!!! We do not need double precision in SPECFEM3D.
+!!!!!!!!!!
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "values_from_mesher_f90.h"
+
+! constant value of the time step in the main time loop
+ real(kind=4), parameter :: deltatover2 = 0.5*deltat, deltatsqover2 = 0.5*deltat*deltat
+
+! element in which the source is located
+ integer, parameter :: NSPEC_SOURCE = NSPEC / 2
+
+! for the source time function
+ real, parameter :: pi = 3.14159265
+ real, parameter :: f0 = 1. / 50.
+ real, parameter :: t0 = 1.2 / f0
+ real, parameter :: a = pi*pi*f0*f0
+
+ integer, parameter :: NTSTEP_BETWEEN_OUTPUT_INFO = 100
+
+ integer, parameter :: IIN = 40
+
+! number of GLL integration points in each direction of an element (degree plus one)
+ integer, parameter :: NGLLX = 5
+ integer, parameter :: NGLLY = NGLLX
+ integer, parameter :: NGLLZ = NGLLX
+
+! 3-D simulation
+ integer, parameter :: NDIM = 3
+
+ real(kind=4), parameter :: VERYSMALLVAL = 1.e-24
+
+! displacement threshold above which we consider that the code became unstable
+ real(kind=4), parameter :: STABILITY_THRESHOLD = 1.e+25
+
+! approximate density of the medium in which the source is located
+ real(kind=4), parameter :: rho = 4500.
+
+! global displacement, velocity and acceleration vectors
+! real(kind=4), dimension(NDIM,NGLOB) :: displ,veloc,accel
+ real(kind=4), dimension(NDIM,NGLLX,NGLLY,NGLLZ,NSPEC) :: displ,veloc,accel
+
+! global diagonal mass matrix
+ real(kind=4), dimension(NGLOB) :: rmass_inverse
+
+! record a seismogram to check that the simulation went well
+ real(kind=4), dimension(NSTEP) :: seismogram
+
+! time step
+ integer it
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: ibool
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,kappav,muv, &
+ rmass_inverse_nspec
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=4), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=4), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=4), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=4), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+
+ integer :: ispec,iglob,i,j,k,l
+
+ real(kind=4) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=4) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+ real(kind=4) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=4) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+ real(kind=4) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
+ real(kind=4) hp1,hp2,hp3,fac1,fac2,fac3,lambdal,mul,lambdalplus2mul,kappal
+ real(kind=4) tempx1l,tempx2l,tempx3l,tempy1l,tempy2l,tempy3l,tempz1l,tempz2l,tempz3l
+
+ real(kind=4) Usolidnorm,current_value,time,memory_size
+
+! timer to count elapsed time
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+ integer ihours,iminutes,iseconds,int_tCPU
+ double precision :: time_start,time_end,tCPU
+
+! estimate of total memory size used
+ print *
+ print *,'NSPEC = ',NSPEC
+ print *,'NGLOB = ',NGLOB
+ print *
+
+ print *,'NSTEP = ',NSTEP
+ print *,'deltat = ',deltat
+ print *
+
+! estimate total memory size (the size of a real number is 4 bytes)
+! we perform the calculation in single precision rather than integer
+! to avoid integer overflow in the case of very large meshes
+ memory_size = 4. * ((3.*NDIM + 1.) * NGLOB + 16. * real(NGLLX*NGLLY*NGLLZ)*real(NSPEC))
+ print *,'approximate total memory size used = ',memory_size/1024./1024.,' Mb'
+ print *
+
+! make sure the source element number is an integer
+ if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...'
+
+! read the mesh from external file
+ open(unit=IIN,file='database.dat',status='old')
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+! read real numbers here
+ read(IIN,*) xix(i,j,k,ispec)
+ read(IIN,*) xiy(i,j,k,ispec)
+ read(IIN,*) xiz(i,j,k,ispec)
+ read(IIN,*) etax(i,j,k,ispec)
+ read(IIN,*) etay(i,j,k,ispec)
+ read(IIN,*) etaz(i,j,k,ispec)
+ read(IIN,*) gammax(i,j,k,ispec)
+ read(IIN,*) gammay(i,j,k,ispec)
+ read(IIN,*) gammaz(i,j,k,ispec)
+ read(IIN,*) kappav(i,j,k,ispec)
+ read(IIN,*) muv(i,j,k,ispec)
+
+! read an integer here
+ read(IIN,*) ibool(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+ do i = 1,NGLOB
+ read(IIN,*) rmass_inverse(i)
+ enddo
+ close(IIN)
+
+ open(unit=IIN,file='matrices.dat',status='old')
+ do j=1,NGLLY
+ do i=1,NGLLX
+ read(IIN,*) hprime_xx(i,j)
+ read(IIN,*) hprimewgll_xx(i,j)
+ read(IIN,*) wgllwgll_yz(i,j)
+ read(IIN,*) wgllwgll_xz(i,j)
+ read(IIN,*) wgllwgll_xy(i,j)
+ enddo
+ enddo
+ close(IIN)
+
+! clear initial vectors before starting the time loop
+! (can remain serial because done only once before entering the time loop)
+ displ = 0. ! 1. !!!!!!!!! VERYSMALLVAL
+ veloc = 0. ! 1. !!!!!!!!! 0.
+ accel = 0. ! 1. !!!!!!!!! 0.
+
+!! DK DK now create inverse mass matrix stored in element format
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ rmass_inverse_nspec(i,j,k,ispec) = rmass_inverse(iglob)
+ enddo
+ enddo
+ enddo
+ enddo
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! start of the time loop (which must remain serial obviously)
+ do it = 1,NSTEP
+
+! compute maximum of norm of displacement from time to time and display it
+! in order to monitor the simulation
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then
+!!!!!!!!! if(it == 2100 .or. it == 5) then
+ Usolidnorm = -1.
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ current_value = sqrt(displ(1,i,j,k,ispec)**2 + displ(2,i,j,k,ispec)**2 + displ(3,i,j,k,ispec)**2)
+ if(current_value > Usolidnorm) Usolidnorm = current_value
+ enddo
+ enddo
+ enddo
+ enddo
+ write(*,*) 'Time step # ',it,' out of ',NSTEP
+! compute current time
+ time = (it-1)*deltat
+ write(*,*) 'Time = ',time,' seconds out of ',(NSTEP-1)*deltat,' seconds'
+ write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm
+! check stability of the code, exit if unstable
+ if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up'
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! elapsed time since beginning of the simulation
+ tCPU = time_end - time_start
+ int_tCPU = int(tCPU)
+ ihours = int_tCPU / 3600
+ iminutes = (int_tCPU - 3600*ihours) / 60
+ iseconds = int_tCPU - 3600*ihours - 60*iminutes
+ write(*,*) 'Elapsed time in seconds = ',tCPU
+ write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ write(*,*)
+
+ endif
+
+! big loop over all the global points (not elements) in the mesh to update
+! the displacement and velocity vectors and clear the acceleration vector
+ displ = displ + deltat*veloc + deltatsqover2*accel
+ veloc = veloc + deltatover2*accel
+ accel = 0.
+
+! big loop over all the elements in the mesh to localize data
+! from the global vectors to the local mesh
+! using indirect addressing (contained in array ibool)
+! and then to compute the elemental contribution
+! to the acceleration vector of each element of the finite-element mesh
+! do ispec = 1,NSPEC
+! do k=1,NGLLZ
+! do j=1,NGLLY
+! do i=1,NGLLX
+! iglob = ibool(i,j,k,ispec)
+! dummyx_glob(i,j,k,ispec) = displ(1,iglob)
+! dummyy_glob(i,j,k,ispec) = displ(2,iglob)
+! dummyz_glob(i,j,k,ispec) = displ(3,iglob)
+! enddo
+! enddo
+! enddo
+! enddo
+
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0.
+ tempx2l = 0.
+ tempx3l = 0.
+
+ tempy1l = 0.
+ tempy2l = 0.
+ tempy3l = 0.
+
+ tempz1l = 0.
+ tempz2l = 0.
+ tempz3l = 0.
+
+ do l=1,NGLLX
+ hp1 = hprime_xx(i,l)
+ tempx1l = tempx1l + displ(1,l,j,k,ispec)*hp1
+ tempy1l = tempy1l + displ(2,l,j,k,ispec)*hp1
+ tempz1l = tempz1l + displ(3,l,j,k,ispec)*hp1
+
+ hp2 = hprime_xx(j,l)
+ tempx2l = tempx2l + displ(1,i,l,k,ispec)*hp2
+ tempy2l = tempy2l + displ(2,i,l,k,ispec)*hp2
+ tempz2l = tempz2l + displ(3,i,l,k,ispec)*hp2
+
+ hp3 = hprime_xx(k,l)
+ tempx3l = tempx3l + displ(1,i,j,l,ispec)*hp3
+ tempy3l = tempy3l + displ(2,i,j,l,ispec)*hp3
+ tempz3l = tempz3l + displ(3,i,j,l,ispec)*hp3
+ enddo
+
+! compute 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)
+ jacobianl = 1. / (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 isotropic elements
+ kappal = kappav(i,j,k,ispec)
+ mul = muv(i,j,k,ispec)
+
+ lambdalplus2mul = kappal + (4./3.) * 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
+
+! form dot product with test vector
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+
+ enddo
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0.
+ tempy1l = 0.
+ tempz1l = 0.
+
+ tempx2l = 0.
+ tempy2l = 0.
+ tempz2l = 0.
+
+ tempx3l = 0.
+ tempy3l = 0.
+ tempz3l = 0.
+
+ 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
+
+ fac2 = hprimewgll_xx(l,j)
+ tempx2l = tempx2l + tempx2(i,l,k)*fac2
+ tempy2l = tempy2l + tempy2(i,l,k)*fac2
+ tempz2l = tempz2l + tempz2(i,l,k)*fac2
+
+ fac3 = hprimewgll_xx(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 contributions from each element to the global mesh using indirect addressing
+! iglob = ibool(i,j,k,ispec)
+! accel(1,iglob) = accel(1,iglob) - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
+! accel(2,iglob) = accel(2,iglob) - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
+! accel(3,iglob) = accel(3,iglob) - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
+
+!! DK DK made this local, with no dependencies
+ accel(1,i,j,k,ispec) = - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
+ accel(2,i,j,k,ispec) = - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
+ accel(3,i,j,k,ispec) = - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
+
+ enddo
+ enddo
+ enddo
+
+ enddo ! end of main loop on all the elements
+
+!! DK DK added a gather phase with data dependencies and need for atomicity
+!! DK DK there is no real need to distinguish points inside each element
+!! DK DK (i.e., not on faces, edges or corners) for which there are no dependencies
+!! DK DK because they only represent 3^3 = 27 points out of 5^3 = 125
+
+goto 777 !! new gather not implemented for now; partial test only
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+! accel(1,iglob) = accel(1,iglob) + dummyx_glob(i,j,k,ispec)
+! accel(2,iglob) = accel(2,iglob) + dummyy_glob(i,j,k,ispec)
+! accel(3,iglob) = accel(3,iglob) + dummyz_glob(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+777 continue
+
+! big loop over all the global points (not elements) in the mesh to update
+! the acceleration and velocity vectors
+ accel(1,:,:,:,:) = accel(1,:,:,:,:)*rmass_inverse_nspec
+ accel(2,:,:,:,:) = accel(2,:,:,:,:)*rmass_inverse_nspec
+ accel(3,:,:,:,:) = accel(3,:,:,:,:)*rmass_inverse_nspec
+
+! add the earthquake source at a given grid point
+! this is negligible and can remain serial because it is done by only
+! one grid point out of several millions typically
+! compute current time
+ time = (it-1)*deltat
+ accel(3,2,2,2,NSPEC_SOURCE) = accel(3,2,2,2,NSPEC_SOURCE) + 1.e4 * (1.-2.*a*(time-t0)**2) * exp(-a*(time-t0)**2) / rho
+
+ veloc = veloc + deltatover2*accel
+
+! record a seismogram to check that the simulation went well
+! select a point in an element near the end of the mesh, since the source is in the middle
+ seismogram(it) = displ(3,2,2,2,NSPEC - 10)
+
+ enddo ! end of the serial time loop
+
+! save the seismogram at the end of the run
+ open(unit=IIN,file='seismogram_F90.txt',status='unknown')
+ do it = 1,NSTEP
+ write(IIN,*) (it-1)*deltat,seismogram(it)
+ enddo
+ close(IIN)
+
+ end program serial_specfem3D
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v01.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v01.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v01.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,606 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ program serial_specfem3D
+
+ implicit none
+
+!!!!!!!!!!
+!!!!!!!!!! All the arrays below use static memory allocation,
+!!!!!!!!!! using constant sizes defined in values_from_mesher.h.
+!!!!!!!!!! This is done purposely to improve performance (Fortran compilers
+!!!!!!!!!! can optimize much more when the size of the loops and arrays
+!!!!!!!!!! is known at compile time).
+!!!!!!!!!! NGLLX, NGLLY and NGLLZ are set equal to 5,
+!!!!!!!!!! therefore each element contains NGLLX * NGLLY * NGLLZ = 125 points.
+!!!!!!!!!!
+
+!!!!!!!!!!
+!!!!!!!!!! All the calculations are done in single precision.
+!!!!!!!!!! We do not need double precision in SPECFEM3D.
+!!!!!!!!!!
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "values_from_mesher_f90.h"
+
+! constant value of the time step in the main time loop
+ real(kind=4), parameter :: deltatover2 = 0.5*deltat, deltatsqover2 = 0.5*deltat*deltat
+
+! element in which the source is located
+ integer, parameter :: NSPEC_SOURCE = NSPEC / 2
+
+! for the source time function
+ real, parameter :: pi = 3.14159265
+ real, parameter :: f0 = 1. / 50.
+ real, parameter :: t0 = 1.2 / f0
+ real, parameter :: a = pi*pi*f0*f0
+
+ integer, parameter :: NTSTEP_BETWEEN_OUTPUT_INFO = 100
+
+ integer, parameter :: IIN = 40
+
+! number of GLL integration points in each direction of an element (degree plus one)
+ integer, parameter :: NGLLX = 5
+ integer, parameter :: NGLLY = NGLLX
+ integer, parameter :: NGLLZ = NGLLX
+
+! 3-D simulation
+ integer, parameter :: NDIM = 3
+
+ real(kind=4), parameter :: VERYSMALLVAL = 1.e-24
+
+! displacement threshold above which we consider that the code became unstable
+ real(kind=4), parameter :: STABILITY_THRESHOLD = 1.e+25
+
+! approximate density of the medium in which the source is located
+ real(kind=4), parameter :: rho = 4500.
+
+! global displacement, velocity and acceleration vectors
+ real(kind=4), dimension(NDIM,NGLOB) :: displ,veloc,accel
+
+! global diagonal mass matrix
+ real(kind=4), dimension(NGLOB) :: rmass_inverse
+
+! record a seismogram to check that the simulation went well
+ real(kind=4), dimension(NSTEP) :: seismogram
+
+! time step
+ integer it
+
+!! DK DK store transpose of matrix
+ real(kind=4), dimension(NGLLX,NGLLX) :: hprime_xxT
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: ibool
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,kappav,muv
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=4), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=4), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=4), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=4), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+
+ integer :: ispec,iglob,i,j,k,l
+
+ real(kind=4) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=4) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+ real(kind=4) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=4) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+ real(kind=4) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
+! real(kind=4) hp1,hp2,hp3
+ real(kind=4) fac1,fac2,fac3,lambdal,mul,lambdalplus2mul,kappal
+ real(kind=4) tempx1l,tempx2l,tempx3l,tempy1l,tempy2l,tempy3l,tempz1l,tempz2l,tempz3l
+
+ real(kind=4) Usolidnorm,current_value,time,memory_size
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc
+
+! timer to count elapsed time
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+ integer ihours,iminutes,iseconds,int_tCPU
+ double precision :: time_start,time_end,tCPU
+
+! estimate of total memory size used
+ print *
+ print *,'NSPEC = ',NSPEC
+ print *,'NGLOB = ',NGLOB
+ print *
+
+ print *,'NSTEP = ',NSTEP
+ print *,'deltat = ',deltat
+ print *
+
+! estimate total memory size (the size of a real number is 4 bytes)
+! we perform the calculation in single precision rather than integer
+! to avoid integer overflow in the case of very large meshes
+ memory_size = 4. * ((3.*NDIM + 1.) * NGLOB + 13. * real(NGLLX*NGLLY*NGLLZ)*real(NSPEC))
+ print *,'approximate total memory size used = ',memory_size/1024./1024.,' Mb'
+ print *
+
+! make sure the source element number is an integer
+ if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...'
+
+! read the mesh from external file
+ open(unit=IIN,file='database.dat',status='old')
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+! read real numbers here
+ read(IIN,*) xix(i,j,k,ispec)
+ read(IIN,*) xiy(i,j,k,ispec)
+ read(IIN,*) xiz(i,j,k,ispec)
+ read(IIN,*) etax(i,j,k,ispec)
+ read(IIN,*) etay(i,j,k,ispec)
+ read(IIN,*) etaz(i,j,k,ispec)
+ read(IIN,*) gammax(i,j,k,ispec)
+ read(IIN,*) gammay(i,j,k,ispec)
+ read(IIN,*) gammaz(i,j,k,ispec)
+ read(IIN,*) kappav(i,j,k,ispec)
+ read(IIN,*) muv(i,j,k,ispec)
+
+! read an integer here
+ read(IIN,*) ibool(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+ do i = 1,NGLOB
+ read(IIN,*) rmass_inverse(i)
+ enddo
+ close(IIN)
+
+ open(unit=IIN,file='matrices.dat',status='old')
+ do j=1,NGLLY
+ do i=1,NGLLX
+ read(IIN,*) hprime_xx(i,j)
+ read(IIN,*) hprimewgll_xx(i,j)
+ read(IIN,*) wgllwgll_yz(i,j)
+ read(IIN,*) wgllwgll_xz(i,j)
+ read(IIN,*) wgllwgll_xy(i,j)
+ enddo
+ enddo
+ close(IIN)
+
+!! DK DK define transpose of matrix
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ hprime_xxT(j,i) = hprime_xx(i,j)
+ enddo
+ enddo
+
+! clear initial vectors before starting the time loop
+! (can remain serial because done only once before entering the time loop)
+ displ(:,:) = 0. ! 1. !!!!!!!!! VERYSMALLVAL
+ veloc(:,:) = 0. ! 1. !!!!!!!!! 0.
+ accel(:,:) = 0. ! 1. !!!!!!!!! 0.
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! start of the time loop (which must remain serial obviously)
+ do it = 1,NSTEP
+
+! compute maximum of norm of displacement from time to time and display it
+! in order to monitor the simulation
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then
+!!!!!!!!!!!! if(it == 2100 .or. it == 5) then
+ Usolidnorm = -1.
+ do iglob = 1,NGLOB
+ current_value = sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2)
+ if(current_value > Usolidnorm) Usolidnorm = current_value
+ enddo
+ write(*,*) 'Time step # ',it,' out of ',NSTEP
+! compute current time
+ time = (it-1)*deltat
+ write(*,*) 'Time = ',time,' seconds out of ',(NSTEP-1)*deltat,' seconds'
+ write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm
+! check stability of the code, exit if unstable
+ if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up'
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! elapsed time since beginning of the simulation
+ tCPU = time_end - time_start
+ int_tCPU = int(tCPU)
+ ihours = int_tCPU / 3600
+ iminutes = (int_tCPU - 3600*ihours) / 60
+ iseconds = int_tCPU - 3600*ihours - 60*iminutes
+ write(*,*) 'Elapsed time in seconds = ',tCPU
+ write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ write(*,*)
+
+ endif
+
+! big loop over all the global points (not elements) in the mesh to update
+! the displacement and velocity vectors and clear the acceleration vector
+ displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsqover2*accel(:,:)
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+ accel(:,:) = 0.
+
+! big loop over all the elements in the mesh to localize data
+! from the global vectors to the local mesh
+! using indirect addressing (contained in array ibool)
+! and then to compute the elemental contribution
+! to the acceleration vector of each element of the finite-element mesh
+ do ispec = 1,NSPEC
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ dummyx_loc(i,j,k) = displ(1,iglob)
+ dummyy_loc(i,j,k) = displ(2,iglob)
+ dummyz_loc(i,j,k) = displ(3,iglob)
+ enddo
+ enddo
+ enddo
+
+!! DK DK from Deville (2002) page 387
+
+!!!!!!!!!!! DK DK attention, par rapport au bouquin de Deville j'ai la transposee
+!!!!!!!!!!! DK DK de la matrice de derivation D ici; a changer un jour dans v4.0
+
+! code adapted by DK here
+ call mxm_m1_m2_v10(hprime_xx,dummyx_loc,dummyy_loc,dummyz_loc,tempx1,tempy1,tempz1)
+
+ do k = 1,NGLLX
+ call mxm_m1_m1_v10(dummyx_loc(1,1,k),dummyy_loc(1,1,k),dummyz_loc(1,1,k),hprime_xxT,tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k))
+ enddo
+
+ call mxm_m2_m1_v10(dummyx_loc,dummyy_loc,dummyz_loc,hprime_xxT,tempx3,tempy3,tempz3)
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+! tempx1l = 0.
+! tempx2l = 0.
+! tempx3l = 0.
+
+! tempy1l = 0.
+! tempy2l = 0.
+! tempy3l = 0.
+
+! tempz1l = 0.
+! tempz2l = 0.
+! tempz3l = 0.
+
+! do l=1,NGLLX
+! hp1 = hprime_xx(i,l)
+! tempx1l = tempx1l + dummyx_loc(l,j,k)*hp1
+! tempy1l = tempy1l + dummyy_loc(l,j,k)*hp1
+! tempz1l = tempz1l + dummyz_loc(l,j,k)*hp1
+
+! hp2 = hprime_xx(j,l)
+! tempx2l = tempx2l + dummyx_loc(i,l,k)*hp2
+! tempy2l = tempy2l + dummyy_loc(i,l,k)*hp2
+! tempz2l = tempz2l + dummyz_loc(i,l,k)*hp2
+
+! hp3 = hprime_xx(k,l)
+! tempx3l = tempx3l + dummyx_loc(i,j,l)*hp3
+! tempy3l = tempy3l + dummyy_loc(i,j,l)*hp3
+! tempz3l = tempz3l + dummyz_loc(i,j,l)*hp3
+! enddo
+
+! compute 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)
+ jacobianl = 1. / (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 isotropic elements
+ kappal = kappav(i,j,k,ispec)
+ mul = muv(i,j,k,ispec)
+
+ lambdalplus2mul = kappal + (4./3.) * 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
+
+! form dot product with test vector
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+
+ enddo
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0.
+ tempy1l = 0.
+ tempz1l = 0.
+
+ tempx2l = 0.
+ tempy2l = 0.
+ tempz2l = 0.
+
+ tempx3l = 0.
+ tempy3l = 0.
+ tempz3l = 0.
+
+ 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
+
+ fac2 = hprimewgll_xx(l,j)
+ tempx2l = tempx2l + tempx2(i,l,k)*fac2
+ tempy2l = tempy2l + tempy2(i,l,k)*fac2
+ tempz2l = tempz2l + tempz2(i,l,k)*fac2
+
+ fac3 = hprimewgll_xx(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 contributions from each element to the global mesh using indirect addressing
+ iglob = ibool(i,j,k,ispec)
+ accel(1,iglob) = accel(1,iglob) - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
+ accel(2,iglob) = accel(2,iglob) - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
+ accel(3,iglob) = accel(3,iglob) - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
+
+ enddo
+ enddo
+ enddo
+
+ enddo ! end of main loop on all the elements
+
+! big loop over all the global points (not elements) in the mesh to update
+! the acceleration and velocity vectors
+ accel(1,:) = accel(1,:)*rmass_inverse(:)
+ accel(2,:) = accel(2,:)*rmass_inverse(:)
+ accel(3,:) = accel(3,:)*rmass_inverse(:)
+
+! add the earthquake source at a given grid point
+! this is negligible and can remain serial because it is done by only
+! one grid point out of several millions typically
+ iglob = ibool(2,2,2,NSPEC_SOURCE)
+! compute current time
+ time = (it-1)*deltat
+ accel(3,iglob) = accel(3,iglob) + 1.e4 * (1.-2.*a*(time-t0)**2) * exp(-a*(time-t0)**2) / rho
+
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+
+! record a seismogram to check that the simulation went well
+! select a point in an element near the end of the mesh, since the source is in the middle
+ iglob = ibool(2,2,2,NSPEC - 10)
+ seismogram(it) = displ(3,iglob)
+
+ enddo ! end of the serial time loop
+
+! save the seismogram at the end of the run
+ open(unit=IIN,file='seismogram_F90.txt',status='unknown')
+ do it = 1,NSTEP
+ write(IIN,*) (it-1)*deltat,seismogram(it)
+ enddo
+ close(IIN)
+
+ end program serial_specfem3D
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! DK DK subroutines adapted from Deville (2002) page 389
+
+ subroutine mxm_m1_m2_v10(A,B1,B2,B3,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m1,NGLLX) :: A
+ real(kind=4), dimension(NGLLX,m2) :: B1,B2,B3
+ real(kind=4), dimension(m1,m2) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m2
+ do i=1,m1
+
+ C1(i,j) = A(i,1)*B1(1,j) + &
+ A(i,2)*B1(2,j) + &
+ A(i,3)*B1(3,j) + &
+ A(i,4)*B1(4,j) + &
+ A(i,5)*B1(5,j)
+
+ C2(i,j) = A(i,1)*B2(1,j) + &
+ A(i,2)*B2(2,j) + &
+ A(i,3)*B2(3,j) + &
+ A(i,4)*B2(4,j) + &
+ A(i,5)*B2(5,j)
+
+ C3(i,j) = A(i,1)*B3(1,j) + &
+ A(i,2)*B3(2,j) + &
+ A(i,3)*B3(3,j) + &
+ A(i,4)*B3(4,j) + &
+ A(i,5)*B3(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m1_m2_v10
+
+!---------
+
+ subroutine mxm_m1_m1_v10(A1,A2,A3,B,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m1,NGLLX) :: A1,A2,A3
+ real(kind=4), dimension(NGLLX,m1) :: B
+ real(kind=4), dimension(m1,m1) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m1
+ do i=1,m1
+
+ C1(i,j) = A1(i,1)*B(1,j) + &
+ A1(i,2)*B(2,j) + &
+ A1(i,3)*B(3,j) + &
+ A1(i,4)*B(4,j) + &
+ A1(i,5)*B(5,j)
+
+ C2(i,j) = A2(i,1)*B(1,j) + &
+ A2(i,2)*B(2,j) + &
+ A2(i,3)*B(3,j) + &
+ A2(i,4)*B(4,j) + &
+ A2(i,5)*B(5,j)
+
+ C3(i,j) = A3(i,1)*B(1,j) + &
+ A3(i,2)*B(2,j) + &
+ A3(i,3)*B(3,j) + &
+ A3(i,4)*B(4,j) + &
+ A3(i,5)*B(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m1_m1_v10
+
+!---------
+
+ subroutine mxm_m2_m1_v10(A1,A2,A3,B,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m2,NGLLX) :: A1,A2,A3
+ real(kind=4), dimension(NGLLX,m1) :: B
+ real(kind=4), dimension(m2,m1) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m1
+ do i=1,m2
+
+ C1(i,j) = A1(i,1)*B(1,j) + &
+ A1(i,2)*B(2,j) + &
+ A1(i,3)*B(3,j) + &
+ A1(i,4)*B(4,j) + &
+ A1(i,5)*B(5,j)
+
+ C2(i,j) = A2(i,1)*B(1,j) + &
+ A2(i,2)*B(2,j) + &
+ A2(i,3)*B(3,j) + &
+ A2(i,4)*B(4,j) + &
+ A2(i,5)*B(5,j)
+
+ C3(i,j) = A3(i,1)*B(1,j) + &
+ A3(i,2)*B(2,j) + &
+ A3(i,3)*B(3,j) + &
+ A3(i,4)*B(4,j) + &
+ A3(i,5)*B(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m2_m1_v10
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v02.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v02.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v02.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,635 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ program serial_specfem3D
+
+ implicit none
+
+!!!!!!!!!!
+!!!!!!!!!! All the arrays below use static memory allocation,
+!!!!!!!!!! using constant sizes defined in values_from_mesher.h.
+!!!!!!!!!! This is done purposely to improve performance (Fortran compilers
+!!!!!!!!!! can optimize much more when the size of the loops and arrays
+!!!!!!!!!! is known at compile time).
+!!!!!!!!!! NGLLX, NGLLY and NGLLZ are set equal to 5,
+!!!!!!!!!! therefore each element contains NGLLX * NGLLY * NGLLZ = 125 points.
+!!!!!!!!!!
+
+!!!!!!!!!!
+!!!!!!!!!! All the calculations are done in single precision.
+!!!!!!!!!! We do not need double precision in SPECFEM3D.
+!!!!!!!!!!
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "values_from_mesher_f90.h"
+
+! constant value of the time step in the main time loop
+ real(kind=4), parameter :: deltatover2 = 0.5*deltat, deltatsqover2 = 0.5*deltat*deltat
+
+! element in which the source is located
+ integer, parameter :: NSPEC_SOURCE = NSPEC / 2
+
+! for the source time function
+ real, parameter :: pi = 3.14159265
+ real, parameter :: f0 = 1. / 50.
+ real, parameter :: t0 = 1.2 / f0
+ real, parameter :: a = pi*pi*f0*f0
+
+ integer, parameter :: NTSTEP_BETWEEN_OUTPUT_INFO = 100
+
+ integer, parameter :: IIN = 40
+
+! number of GLL integration points in each direction of an element (degree plus one)
+ integer, parameter :: NGLLX = 5
+ integer, parameter :: NGLLY = NGLLX
+ integer, parameter :: NGLLZ = NGLLX
+
+! 3-D simulation
+ integer, parameter :: NDIM = 3
+
+ real(kind=4), parameter :: VERYSMALLVAL = 1.e-24
+
+! displacement threshold above which we consider that the code became unstable
+ real(kind=4), parameter :: STABILITY_THRESHOLD = 1.e+25
+
+! approximate density of the medium in which the source is located
+ real(kind=4), parameter :: rho = 4500.
+
+! global displacement, velocity and acceleration vectors
+ real(kind=4), dimension(NDIM,NGLOB) :: displ,veloc,accel
+
+! global diagonal mass matrix
+ real(kind=4), dimension(NGLOB) :: rmass_inverse
+
+! record a seismogram to check that the simulation went well
+ real(kind=4), dimension(NSTEP) :: seismogram
+
+! time step
+ integer it
+
+!! DK DK store transpose of matrix
+ real(kind=4), dimension(NGLLX,NGLLX) :: hprime_xxT
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: ibool
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,kappav,muv
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=4), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=4), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=4), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=4), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+
+ integer :: ispec,iglob,i,j,k,l
+
+ real(kind=4) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=4) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+ real(kind=4) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=4) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+ real(kind=4) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
+! real(kind=4) hp1,hp2,hp3
+ real(kind=4) fac1,fac2,fac3,lambdal,mul,lambdalplus2mul,kappal
+ real(kind=4) tempx1l,tempx2l,tempx3l,tempy1l,tempy2l,tempy3l,tempz1l,tempz2l,tempz3l
+
+ real(kind=4) Usolidnorm,current_value,time,memory_size
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc
+
+! timer to count elapsed time
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+ integer ihours,iminutes,iseconds,int_tCPU
+ double precision :: time_start,time_end,tCPU
+
+! estimate of total memory size used
+ print *
+ print *,'NSPEC = ',NSPEC
+ print *,'NGLOB = ',NGLOB
+ print *
+
+ print *,'NSTEP = ',NSTEP
+ print *,'deltat = ',deltat
+ print *
+
+! estimate total memory size (the size of a real number is 4 bytes)
+! we perform the calculation in single precision rather than integer
+! to avoid integer overflow in the case of very large meshes
+ memory_size = 4. * ((3.*NDIM + 1.) * NGLOB + 13. * real(NGLLX*NGLLY*NGLLZ)*real(NSPEC))
+ print *,'approximate total memory size used = ',memory_size/1024./1024.,' Mb'
+ print *
+
+! make sure the source element number is an integer
+ if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...'
+
+! read the mesh from external file
+ open(unit=IIN,file='database.dat',status='old')
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+! read real numbers here
+ read(IIN,*) xix(i,j,k,ispec)
+ read(IIN,*) xiy(i,j,k,ispec)
+ read(IIN,*) xiz(i,j,k,ispec)
+ read(IIN,*) etax(i,j,k,ispec)
+ read(IIN,*) etay(i,j,k,ispec)
+ read(IIN,*) etaz(i,j,k,ispec)
+ read(IIN,*) gammax(i,j,k,ispec)
+ read(IIN,*) gammay(i,j,k,ispec)
+ read(IIN,*) gammaz(i,j,k,ispec)
+ read(IIN,*) kappav(i,j,k,ispec)
+ read(IIN,*) muv(i,j,k,ispec)
+
+! read an integer here
+ read(IIN,*) ibool(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+ do i = 1,NGLOB
+ read(IIN,*) rmass_inverse(i)
+ enddo
+ close(IIN)
+
+ open(unit=IIN,file='matrices.dat',status='old')
+ do j=1,NGLLY
+ do i=1,NGLLX
+ read(IIN,*) hprime_xx(i,j)
+ read(IIN,*) hprimewgll_xx(i,j)
+ read(IIN,*) wgllwgll_yz(i,j)
+ read(IIN,*) wgllwgll_xz(i,j)
+ read(IIN,*) wgllwgll_xy(i,j)
+ enddo
+ enddo
+ close(IIN)
+
+!! DK DK define transpose of matrix
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ hprime_xxT(j,i) = hprime_xx(i,j)
+ enddo
+ enddo
+
+! clear initial vectors before starting the time loop
+! (can remain serial because done only once before entering the time loop)
+ displ(:,:) = 0. ! 1. !!!!!!!!! VERYSMALLVAL
+ veloc(:,:) = 0. ! 1. !!!!!!!!! 0.
+ accel(:,:) = 0. ! 1. !!!!!!!!! 0.
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! start of the time loop (which must remain serial obviously)
+ do it = 1,NSTEP
+
+! compute maximum of norm of displacement from time to time and display it
+! in order to monitor the simulation
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then
+!!!!!!!!!!!! if(it == 2100 .or. it == 5) then
+ Usolidnorm = -1.
+ do iglob = 1,NGLOB
+ current_value = sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2)
+ if(current_value > Usolidnorm) Usolidnorm = current_value
+ enddo
+ write(*,*) 'Time step # ',it,' out of ',NSTEP
+! compute current time
+ time = (it-1)*deltat
+ write(*,*) 'Time = ',time,' seconds out of ',(NSTEP-1)*deltat,' seconds'
+ write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm
+! check stability of the code, exit if unstable
+ if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up'
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! elapsed time since beginning of the simulation
+ tCPU = time_end - time_start
+ int_tCPU = int(tCPU)
+ ihours = int_tCPU / 3600
+ iminutes = (int_tCPU - 3600*ihours) / 60
+ iseconds = int_tCPU - 3600*ihours - 60*iminutes
+ write(*,*) 'Elapsed time in seconds = ',tCPU
+ write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ write(*,*)
+
+ endif
+
+! big loop over all the global points (not elements) in the mesh to update
+! the displacement and velocity vectors and clear the acceleration vector
+ displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsqover2*accel(:,:)
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+ accel(:,:) = 0.
+
+! big loop over all the elements in the mesh to localize data
+! from the global vectors to the local mesh
+! using indirect addressing (contained in array ibool)
+! and then to compute the elemental contribution
+! to the acceleration vector of each element of the finite-element mesh
+ do ispec = 1,NSPEC
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ dummyx_loc(i,j,k) = displ(1,iglob)
+ dummyy_loc(i,j,k) = displ(2,iglob)
+ dummyz_loc(i,j,k) = displ(3,iglob)
+ enddo
+ enddo
+ enddo
+
+! do k=1,NGLLZ
+! do j=1,NGLLY
+! do i=1,125 ! NGLLX
+! iglob = ibool(i,1,1,ispec)
+! dummyx_loc(i,1,1) = displ(1,iglob)
+! dummyy_loc(i,1,1) = displ(2,iglob)
+! dummyz_loc(i,1,1) = displ(3,iglob)
+! enddo
+! enddo
+! enddo
+
+!! DK DK from Deville (2002) page 387
+
+!!!!!!!!!!! DK DK attention, par rapport au bouquin de Deville j'ai la transposee
+!!!!!!!!!!! DK DK de la matrice de derivation D ici; a changer un jour dans v4.0
+
+! code adapted by DK here
+ call mxm_m1_m2_v10(hprime_xx,dummyx_loc,dummyy_loc,dummyz_loc,tempx1,tempy1,tempz1)
+
+ do k = 1,NGLLX
+ call mxm_m1_m1_v10(dummyx_loc(1,1,k),dummyy_loc(1,1,k),dummyz_loc(1,1,k),hprime_xxT,tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k))
+ enddo
+
+ call mxm_m2_m1_v10(dummyx_loc,dummyy_loc,dummyz_loc,hprime_xxT,tempx3,tempy3,tempz3)
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+! tempx1l = 0.
+! tempx2l = 0.
+! tempx3l = 0.
+
+! tempy1l = 0.
+! tempy2l = 0.
+! tempy3l = 0.
+
+! tempz1l = 0.
+! tempz2l = 0.
+! tempz3l = 0.
+
+! do l=1,NGLLX
+! hp1 = hprime_xx(i,l)
+! tempx1l = tempx1l + dummyx_loc(l,j,k)*hp1
+! tempy1l = tempy1l + dummyy_loc(l,j,k)*hp1
+! tempz1l = tempz1l + dummyz_loc(l,j,k)*hp1
+
+! hp2 = hprime_xx(j,l)
+! tempx2l = tempx2l + dummyx_loc(i,l,k)*hp2
+! tempy2l = tempy2l + dummyy_loc(i,l,k)*hp2
+! tempz2l = tempz2l + dummyz_loc(i,l,k)*hp2
+
+! hp3 = hprime_xx(k,l)
+! tempx3l = tempx3l + dummyx_loc(i,j,l)*hp3
+! tempy3l = tempy3l + dummyy_loc(i,j,l)*hp3
+! tempz3l = tempz3l + dummyz_loc(i,j,l)*hp3
+! enddo
+
+! compute 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)
+ jacobianl = 1. / (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 isotropic elements
+ kappal = kappav(i,j,k,ispec)
+ mul = muv(i,j,k,ispec)
+
+ lambdalplus2mul = kappal + (4./3.) * 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
+
+! form dot product with test vector
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+
+ enddo
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0.
+ tempy1l = 0.
+ tempz1l = 0.
+
+ tempx2l = 0.
+ tempy2l = 0.
+ tempz2l = 0.
+
+ tempx3l = 0.
+ tempy3l = 0.
+ tempz3l = 0.
+
+ 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
+
+ fac2 = hprimewgll_xx(l,j)
+ tempx2l = tempx2l + tempx2(i,l,k)*fac2
+ tempy2l = tempy2l + tempy2(i,l,k)*fac2
+ tempz2l = tempz2l + tempz2(i,l,k)*fac2
+
+ fac3 = hprimewgll_xx(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 contributions from each element to the global mesh using indirect addressing
+! iglob = ibool(i,j,k,ispec)
+! accel(1,iglob) = accel(1,iglob) - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
+! accel(2,iglob) = accel(2,iglob) - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
+! accel(3,iglob) = accel(3,iglob) - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
+
+ dummyx_loc(i,j,k) = - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
+ dummyy_loc(i,j,k) = - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
+ dummyz_loc(i,j,k) = - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
+
+ enddo
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+! sum contributions from each element to the global mesh using indirect addressing
+ iglob = ibool(i,j,k,ispec)
+ accel(1,iglob) = accel(1,iglob) + dummyx_loc(i,j,k)
+ accel(2,iglob) = accel(2,iglob) + dummyy_loc(i,j,k)
+ accel(3,iglob) = accel(3,iglob) + dummyz_loc(i,j,k)
+
+ enddo
+ enddo
+ enddo
+
+ enddo ! end of main loop on all the elements
+
+! big loop over all the global points (not elements) in the mesh to update
+! the acceleration and velocity vectors
+ accel(1,:) = accel(1,:)*rmass_inverse(:)
+ accel(2,:) = accel(2,:)*rmass_inverse(:)
+ accel(3,:) = accel(3,:)*rmass_inverse(:)
+
+! add the earthquake source at a given grid point
+! this is negligible and can remain serial because it is done by only
+! one grid point out of several millions typically
+ iglob = ibool(2,2,2,NSPEC_SOURCE)
+! compute current time
+ time = (it-1)*deltat
+ accel(3,iglob) = accel(3,iglob) + 1.e4 * (1.-2.*a*(time-t0)**2) * exp(-a*(time-t0)**2) / rho
+
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+
+! record a seismogram to check that the simulation went well
+! select a point in an element near the end of the mesh, since the source is in the middle
+ iglob = ibool(2,2,2,NSPEC - 10)
+ seismogram(it) = displ(3,iglob)
+
+ enddo ! end of the serial time loop
+
+! save the seismogram at the end of the run
+ open(unit=IIN,file='seismogram_F90.txt',status='unknown')
+ do it = 1,NSTEP
+ write(IIN,*) (it-1)*deltat,seismogram(it)
+ enddo
+ close(IIN)
+
+ end program serial_specfem3D
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! DK DK subroutines adapted from Deville (2002) page 389
+
+ subroutine mxm_m1_m2_v10(A,B1,B2,B3,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m1,NGLLX) :: A
+ real(kind=4), dimension(NGLLX,m2) :: B1,B2,B3
+ real(kind=4), dimension(m1,m2) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m2
+ do i=1,m1
+
+ C1(i,j) = A(i,1)*B1(1,j) + &
+ A(i,2)*B1(2,j) + &
+ A(i,3)*B1(3,j) + &
+ A(i,4)*B1(4,j) + &
+ A(i,5)*B1(5,j)
+
+ C2(i,j) = A(i,1)*B2(1,j) + &
+ A(i,2)*B2(2,j) + &
+ A(i,3)*B2(3,j) + &
+ A(i,4)*B2(4,j) + &
+ A(i,5)*B2(5,j)
+
+ C3(i,j) = A(i,1)*B3(1,j) + &
+ A(i,2)*B3(2,j) + &
+ A(i,3)*B3(3,j) + &
+ A(i,4)*B3(4,j) + &
+ A(i,5)*B3(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m1_m2_v10
+
+!---------
+
+ subroutine mxm_m1_m1_v10(A1,A2,A3,B,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m1,NGLLX) :: A1,A2,A3
+ real(kind=4), dimension(NGLLX,m1) :: B
+ real(kind=4), dimension(m1,m1) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m1
+ do i=1,m1
+
+ C1(i,j) = A1(i,1)*B(1,j) + &
+ A1(i,2)*B(2,j) + &
+ A1(i,3)*B(3,j) + &
+ A1(i,4)*B(4,j) + &
+ A1(i,5)*B(5,j)
+
+ C2(i,j) = A2(i,1)*B(1,j) + &
+ A2(i,2)*B(2,j) + &
+ A2(i,3)*B(3,j) + &
+ A2(i,4)*B(4,j) + &
+ A2(i,5)*B(5,j)
+
+ C3(i,j) = A3(i,1)*B(1,j) + &
+ A3(i,2)*B(2,j) + &
+ A3(i,3)*B(3,j) + &
+ A3(i,4)*B(4,j) + &
+ A3(i,5)*B(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m1_m1_v10
+
+!---------
+
+ subroutine mxm_m2_m1_v10(A1,A2,A3,B,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m2,NGLLX) :: A1,A2,A3
+ real(kind=4), dimension(NGLLX,m1) :: B
+ real(kind=4), dimension(m2,m1) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m1
+ do i=1,m2
+
+ C1(i,j) = A1(i,1)*B(1,j) + &
+ A1(i,2)*B(2,j) + &
+ A1(i,3)*B(3,j) + &
+ A1(i,4)*B(4,j) + &
+ A1(i,5)*B(5,j)
+
+ C2(i,j) = A2(i,1)*B(1,j) + &
+ A2(i,2)*B(2,j) + &
+ A2(i,3)*B(3,j) + &
+ A2(i,4)*B(4,j) + &
+ A2(i,5)*B(5,j)
+
+ C3(i,j) = A3(i,1)*B(1,j) + &
+ A3(i,2)*B(2,j) + &
+ A3(i,3)*B(3,j) + &
+ A3(i,4)*B(4,j) + &
+ A3(i,5)*B(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m2_m1_v10
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v04_is_slower.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v04_is_slower.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v04_is_slower.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,649 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ program serial_specfem3D
+
+ implicit none
+
+!!!!!!!!!!
+!!!!!!!!!! All the arrays below use static memory allocation,
+!!!!!!!!!! using constant sizes defined in values_from_mesher.h.
+!!!!!!!!!! This is done purposely to improve performance (Fortran compilers
+!!!!!!!!!! can optimize much more when the size of the loops and arrays
+!!!!!!!!!! is known at compile time).
+!!!!!!!!!! NGLLX, NGLLY and NGLLZ are set equal to 5,
+!!!!!!!!!! therefore each element contains NGLLX * NGLLY * NGLLZ = 125 points.
+!!!!!!!!!!
+
+!!!!!!!!!!
+!!!!!!!!!! All the calculations are done in single precision.
+!!!!!!!!!! We do not need double precision in SPECFEM3D.
+!!!!!!!!!!
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "values_from_mesher_f90.h"
+
+! constant value of the time step in the main time loop
+ real(kind=4), parameter :: deltatover2 = 0.5*deltat, deltatsqover2 = 0.5*deltat*deltat
+
+! element in which the source is located
+ integer, parameter :: NSPEC_SOURCE = NSPEC / 2
+
+! for the source time function
+ real, parameter :: pi = 3.14159265
+ real, parameter :: f0 = 1. / 50.
+ real, parameter :: t0 = 1.2 / f0
+ real, parameter :: a = pi*pi*f0*f0
+
+ integer, parameter :: NTSTEP_BETWEEN_OUTPUT_INFO = 100
+
+ integer, parameter :: IIN = 40
+
+! number of GLL integration points in each direction of an element (degree plus one)
+ integer, parameter :: NGLLX = 5
+ integer, parameter :: NGLLY = NGLLX
+ integer, parameter :: NGLLZ = NGLLX
+
+! 3-D simulation
+ integer, parameter :: NDIM = 3
+
+ real(kind=4), parameter :: VERYSMALLVAL = 1.e-24
+
+! displacement threshold above which we consider that the code became unstable
+ real(kind=4), parameter :: STABILITY_THRESHOLD = 1.e+25
+
+! approximate density of the medium in which the source is located
+ real(kind=4), parameter :: rho = 4500.
+
+! global displacement, velocity and acceleration vectors
+ real(kind=4), dimension(NDIM,NGLOB) :: displ,veloc,accel
+
+! global diagonal mass matrix
+ real(kind=4), dimension(NGLOB) :: rmass_inverse
+
+! record a seismogram to check that the simulation went well
+ real(kind=4), dimension(NSTEP) :: seismogram
+
+! time step
+ integer it
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: ibool
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,kappav,muv,jacobian
+
+! array with derivatives of Lagrange polynomials and precalculated products
+!! DK DK store transpose of matrix
+ real(kind=4), dimension(NGLLX,NGLLX) :: hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT
+ real(kind=4), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=4), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=4), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: wgllwgll_xy_3indices,wgllwgll_xz_3indices,wgllwgll_yz_3indices
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
+ newtempx1,newtempx2,newtempx3,newtempy1,newtempy2,newtempy3,newtempz1,newtempz2,newtempz3
+
+ integer :: ispec,iglob,i,j,k !!!!!!!!!!!!! ,l
+
+ real(kind=4) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=4) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+ real(kind=4) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=4) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+ real(kind=4) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
+! real(kind=4) hp1,hp2,hp3
+ real(kind=4) fac1,fac2,fac3,lambdal,mul,lambdalplus2mul,kappal
+! real(kind=4) tempx1l,tempx2l,tempx3l,tempy1l,tempy2l,tempy3l,tempz1l,tempz2l,tempz3l
+
+ real(kind=4) Usolidnorm,current_value,time,memory_size
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc
+
+! timer to count elapsed time
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+ integer ihours,iminutes,iseconds,int_tCPU
+ double precision :: time_start,time_end,tCPU
+
+! estimate of total memory size used
+ print *
+ print *,'NSPEC = ',NSPEC
+ print *,'NGLOB = ',NGLOB
+ print *
+
+ print *,'NSTEP = ',NSTEP
+ print *,'deltat = ',deltat
+ print *
+
+! estimate total memory size (the size of a real number is 4 bytes)
+! we perform the calculation in single precision rather than integer
+! to avoid integer overflow in the case of very large meshes
+ memory_size = 4. * ((3.*NDIM + 1.) * NGLOB + 13. * real(NGLLX*NGLLY*NGLLZ)*real(NSPEC))
+ print *,'approximate total memory size used = ',memory_size/1024./1024.,' Mb'
+ print *
+
+! make sure the source element number is an integer
+ if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...'
+
+! read the mesh from external file
+ open(unit=IIN,file='database.dat',status='old')
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+! read real numbers here
+ read(IIN,*) xix(i,j,k,ispec)
+ read(IIN,*) xiy(i,j,k,ispec)
+ read(IIN,*) xiz(i,j,k,ispec)
+ read(IIN,*) etax(i,j,k,ispec)
+ read(IIN,*) etay(i,j,k,ispec)
+ read(IIN,*) etaz(i,j,k,ispec)
+ read(IIN,*) gammax(i,j,k,ispec)
+ read(IIN,*) gammay(i,j,k,ispec)
+ read(IIN,*) gammaz(i,j,k,ispec)
+ read(IIN,*) kappav(i,j,k,ispec)
+ read(IIN,*) muv(i,j,k,ispec)
+
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+ jacobian(i,j,k,ispec) = 1. / (xixl*(etayl*gammazl-etazl*gammayl)- &
+ xiyl*(etaxl*gammazl-etazl*gammaxl)+xizl*(etaxl*gammayl-etayl*gammaxl))
+
+
+! read an integer here
+ read(IIN,*) ibool(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+ do i = 1,NGLOB
+ read(IIN,*) rmass_inverse(i)
+ enddo
+ close(IIN)
+
+ open(unit=IIN,file='matrices.dat',status='old')
+ do j=1,NGLLY
+ do i=1,NGLLX
+ read(IIN,*) hprime_xx(i,j)
+ read(IIN,*) hprimewgll_xx(i,j)
+ hprimewgll_xx(i,j) = - hprimewgll_xx(i,j) !!!!!!!!!! DK DK
+ read(IIN,*) wgllwgll_yz(i,j)
+ read(IIN,*) wgllwgll_xz(i,j)
+ read(IIN,*) wgllwgll_xy(i,j)
+ enddo
+ enddo
+ close(IIN)
+
+!! DK DK define matrix with three indices
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ wgllwgll_yz_3indices(i,j,k) = wgllwgll_yz(j,k)
+ wgllwgll_xz_3indices(i,j,k) = wgllwgll_xz(i,k)
+ wgllwgll_xy_3indices(i,j,k) = wgllwgll_xy(i,j)
+ enddo
+ enddo
+ enddo
+
+!! DK DK define transpose of 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
+
+! clear initial vectors before starting the time loop
+! (can remain serial because done only once before entering the time loop)
+ displ(:,:) = 0. ! 1. !!!!!!!!! VERYSMALLVAL
+ veloc(:,:) = 0. ! 1. !!!!!!!!! 0.
+ accel(:,:) = 0. ! 1. !!!!!!!!! 0.
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! start of the time loop (which must remain serial obviously)
+ do it = 1,NSTEP
+
+! compute maximum of norm of displacement from time to time and display it
+! in order to monitor the simulation
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then
+!!!!!!!!!!!! if(it == 2100 .or. it == 5) then
+ Usolidnorm = -1.
+ do iglob = 1,NGLOB
+ current_value = sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2)
+ if(current_value > Usolidnorm) Usolidnorm = current_value
+ enddo
+ write(*,*) 'Time step # ',it,' out of ',NSTEP
+! compute current time
+ time = (it-1)*deltat
+ write(*,*) 'Time = ',time,' seconds out of ',(NSTEP-1)*deltat,' seconds'
+ write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm
+! check stability of the code, exit if unstable
+ if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up'
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! elapsed time since beginning of the simulation
+ tCPU = time_end - time_start
+ int_tCPU = int(tCPU)
+ ihours = int_tCPU / 3600
+ iminutes = (int_tCPU - 3600*ihours) / 60
+ iseconds = int_tCPU - 3600*ihours - 60*iminutes
+ write(*,*) 'Elapsed time in seconds = ',tCPU
+ write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ write(*,*)
+
+ endif
+
+! big loop over all the global points (not elements) in the mesh to update
+! the displacement and velocity vectors and clear the acceleration vector
+ displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsqover2*accel(:,:)
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+ accel(:,:) = 0.
+
+! big loop over all the elements in the mesh to localize data
+! from the global vectors to the local mesh
+! using indirect addressing (contained in array ibool)
+! and then to compute the elemental contribution
+! to the acceleration vector of each element of the finite-element mesh
+ do ispec = 1,NSPEC
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ dummyx_loc(i,j,k) = displ(1,iglob)
+ dummyy_loc(i,j,k) = displ(2,iglob)
+ dummyz_loc(i,j,k) = displ(3,iglob)
+ enddo
+ enddo
+ enddo
+
+!! DK DK from Deville et al. (2002) page 387
+
+! code adapted by DK here
+ call mxm_m1_m2(hprime_xx,dummyx_loc,dummyy_loc,dummyz_loc,tempx1,tempy1,tempz1)
+
+ do k = 1,NGLLX
+ call mxm_m1_m1(dummyx_loc(1,1,k),dummyy_loc(1,1,k),dummyz_loc(1,1,k),hprime_xxT,tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k))
+ enddo
+
+ call mxm_m2_m1(dummyx_loc,dummyy_loc,dummyz_loc,hprime_xxT,tempx3,tempy3,tempz3)
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+! tempx1l = 0.
+! tempx2l = 0.
+! tempx3l = 0.
+
+! tempy1l = 0.
+! tempy2l = 0.
+! tempy3l = 0.
+
+! tempz1l = 0.
+! tempz2l = 0.
+! tempz3l = 0.
+
+! do l=1,NGLLX
+! hp1 = hprime_xx(i,l)
+! tempx1l = tempx1l + dummyx_loc(l,j,k)*hp1
+! tempy1l = tempy1l + dummyy_loc(l,j,k)*hp1
+! tempz1l = tempz1l + dummyz_loc(l,j,k)*hp1
+
+! hp2 = hprime_xx(j,l)
+! tempx2l = tempx2l + dummyx_loc(i,l,k)*hp2
+! tempy2l = tempy2l + dummyy_loc(i,l,k)*hp2
+! tempz2l = tempz2l + dummyz_loc(i,l,k)*hp2
+
+! hp3 = hprime_xx(k,l)
+! tempx3l = tempx3l + dummyx_loc(i,j,l)*hp3
+! tempy3l = tempy3l + dummyy_loc(i,j,l)*hp3
+! tempz3l = tempz3l + dummyz_loc(i,j,l)*hp3
+! enddo
+
+! compute 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)
+! jacobianl = 1. / (xixl*(etayl*gammazl-etazl*gammayl)- &
+! xiyl*(etaxl*gammazl-etazl*gammaxl)+xizl*(etaxl*gammayl-etayl*gammaxl))
+ jacobianl = jacobian(i,j,k,ispec)
+
+ 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 isotropic elements
+ kappal = kappav(i,j,k,ispec)
+ mul = muv(i,j,k,ispec)
+
+!!!!!!!!!!!!!!!!!!!!! lambdalplus2mul = kappal + (4./3.) * mul
+ lambdalplus2mul = kappal + 1.33333333333333 * 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
+
+! form dot product with test vector
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+
+ enddo
+ enddo
+ enddo
+
+! code adapted by DK here
+ call mxm_m1_m2(hprimewgll_xxT,tempx1,tempy1,tempz1,newtempx1,newtempy1,newtempz1)
+
+ do k = 1,NGLLX
+ call mxm_m1_m1(tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k),hprimewgll_xx,newtempx2(1,1,k),newtempy2(1,1,k),newtempz2(1,1,k))
+ enddo
+
+ call mxm_m2_m1(tempx3,tempy3,tempz3,hprimewgll_xx,newtempx3,newtempy3,newtempz3)
+
+! do k=1,NGLLZ
+! do j=1,NGLLY
+! do i=1,NGLLX
+
+! tempx1l = 0.
+! tempy1l = 0.
+! tempz1l = 0.
+
+! tempx2l = 0.
+! tempy2l = 0.
+! tempz2l = 0.
+
+! tempx3l = 0.
+! tempy3l = 0.
+! tempz3l = 0.
+
+! 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
+
+! fac2 = hprimewgll_xx(l,j)
+! tempx2l = tempx2l + tempx2(i,l,k)*fac2
+! tempy2l = tempy2l + tempy2(i,l,k)*fac2
+! tempz2l = tempz2l + tempz2(i,l,k)*fac2
+
+! fac3 = hprimewgll_xx(l,k)
+! tempx3l = tempx3l + tempx3(i,j,l)*fac3
+! tempy3l = tempy3l + tempy3(i,j,l)*fac3
+! tempz3l = tempz3l + tempz3(i,j,l)*fac3
+! enddo
+
+! enddo
+! enddo
+! enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ fac1 = wgllwgll_yz_3indices(i,j,k)
+ fac2 = wgllwgll_xz_3indices(i,j,k)
+ fac3 = wgllwgll_xy_3indices(i,j,k)
+
+! sum contributions from each element to the global mesh using indirect addressing
+ iglob = ibool(i,j,k,ispec)
+ accel(1,iglob) = accel(1,iglob) + (fac1*newtempx1(i,j,k) + fac2*newtempx2(i,j,k) + fac3*newtempx3(i,j,k))
+ accel(2,iglob) = accel(2,iglob) + (fac1*newtempy1(i,j,k) + fac2*newtempy2(i,j,k) + fac3*newtempy3(i,j,k))
+ accel(3,iglob) = accel(3,iglob) + (fac1*newtempz1(i,j,k) + fac2*newtempz2(i,j,k) + fac3*newtempz3(i,j,k))
+
+ enddo
+ enddo
+ enddo
+
+ enddo ! end of main loop on all the elements
+
+! big loop over all the global points (not elements) in the mesh to update
+! the acceleration and velocity vectors
+ accel(1,:) = accel(1,:)*rmass_inverse(:)
+ accel(2,:) = accel(2,:)*rmass_inverse(:)
+ accel(3,:) = accel(3,:)*rmass_inverse(:)
+
+! add the earthquake source at a given grid point
+! this is negligible and can remain serial because it is done by only
+! one grid point out of several millions typically
+ iglob = ibool(2,2,2,NSPEC_SOURCE)
+! compute current time
+ time = (it-1)*deltat
+ accel(3,iglob) = accel(3,iglob) + 1.e4 * (1.-2.*a*(time-t0)**2) * exp(-a*(time-t0)**2) / rho
+
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+
+! record a seismogram to check that the simulation went well
+! select a point in an element near the end of the mesh, since the source is in the middle
+ iglob = ibool(2,2,2,NSPEC - 10)
+ seismogram(it) = displ(3,iglob)
+
+ enddo ! end of the serial time loop
+
+! save the seismogram at the end of the run
+ open(unit=IIN,file='seismogram_F90.txt',status='unknown')
+ do it = 1,NSTEP
+ write(IIN,*) (it-1)*deltat,seismogram(it)
+ enddo
+ close(IIN)
+
+ end program serial_specfem3D
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! DK DK subroutines adapted from Deville et al. (2002) page 389
+
+ subroutine mxm_m1_m2(A,B1,B2,B3,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m1,NGLLX) :: A
+ real(kind=4), dimension(NGLLX,m2) :: B1,B2,B3
+ real(kind=4), dimension(m1,m2) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m2
+ do i=1,m1
+
+ C1(i,j) = A(i,1)*B1(1,j) + &
+ A(i,2)*B1(2,j) + &
+ A(i,3)*B1(3,j) + &
+ A(i,4)*B1(4,j) + &
+ A(i,5)*B1(5,j)
+
+ C2(i,j) = A(i,1)*B2(1,j) + &
+ A(i,2)*B2(2,j) + &
+ A(i,3)*B2(3,j) + &
+ A(i,4)*B2(4,j) + &
+ A(i,5)*B2(5,j)
+
+ C3(i,j) = A(i,1)*B3(1,j) + &
+ A(i,2)*B3(2,j) + &
+ A(i,3)*B3(3,j) + &
+ A(i,4)*B3(4,j) + &
+ A(i,5)*B3(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m1_m2
+
+!---------
+
+ subroutine mxm_m1_m1(A1,A2,A3,B,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m1,NGLLX) :: A1,A2,A3
+ real(kind=4), dimension(NGLLX,m1) :: B
+ real(kind=4), dimension(m1,m1) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m1
+ do i=1,m1
+
+ C1(i,j) = A1(i,1)*B(1,j) + &
+ A1(i,2)*B(2,j) + &
+ A1(i,3)*B(3,j) + &
+ A1(i,4)*B(4,j) + &
+ A1(i,5)*B(5,j)
+
+ C2(i,j) = A2(i,1)*B(1,j) + &
+ A2(i,2)*B(2,j) + &
+ A2(i,3)*B(3,j) + &
+ A2(i,4)*B(4,j) + &
+ A2(i,5)*B(5,j)
+
+ C3(i,j) = A3(i,1)*B(1,j) + &
+ A3(i,2)*B(2,j) + &
+ A3(i,3)*B(3,j) + &
+ A3(i,4)*B(4,j) + &
+ A3(i,5)*B(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m1_m1
+
+!---------
+
+ subroutine mxm_m2_m1(A1,A2,A3,B,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m2,NGLLX) :: A1,A2,A3
+ real(kind=4), dimension(NGLLX,m1) :: B
+ real(kind=4), dimension(m2,m1) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m1
+ do i=1,m2
+
+ C1(i,j) = A1(i,1)*B(1,j) + &
+ A1(i,2)*B(2,j) + &
+ A1(i,3)*B(3,j) + &
+ A1(i,4)*B(4,j) + &
+ A1(i,5)*B(5,j)
+
+ C2(i,j) = A2(i,1)*B(1,j) + &
+ A2(i,2)*B(2,j) + &
+ A2(i,3)*B(3,j) + &
+ A2(i,4)*B(4,j) + &
+ A2(i,5)*B(5,j)
+
+ C3(i,j) = A3(i,1)*B(1,j) + &
+ A3(i,2)*B(2,j) + &
+ A3(i,3)*B(3,j) + &
+ A3(i,4)*B(4,j) + &
+ A3(i,5)*B(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m2_m1
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v05_displx_y_z_3arrays.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v05_displx_y_z_3arrays.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v05_displx_y_z_3arrays.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,656 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ program serial_specfem3D
+
+ implicit none
+
+!!!!!!!!!!
+!!!!!!!!!! All the arrays below use static memory allocation,
+!!!!!!!!!! using constant sizes defined in values_from_mesher.h.
+!!!!!!!!!! This is done purposely to improve performance (Fortran compilers
+!!!!!!!!!! can optimize much more when the size of the loops and arrays
+!!!!!!!!!! is known at compile time).
+!!!!!!!!!! NGLLX, NGLLY and NGLLZ are set equal to 5,
+!!!!!!!!!! therefore each element contains NGLLX * NGLLY * NGLLZ = 125 points.
+!!!!!!!!!!
+
+!!!!!!!!!!
+!!!!!!!!!! All the calculations are done in single precision.
+!!!!!!!!!! We do not need double precision in SPECFEM3D.
+!!!!!!!!!!
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "values_from_mesher_f90.h"
+
+! constant value of the time step in the main time loop
+ real(kind=4), parameter :: deltatover2 = 0.5*deltat, deltatsqover2 = 0.5*deltat*deltat
+
+! element in which the source is located
+ integer, parameter :: NSPEC_SOURCE = NSPEC / 2
+
+! for the source time function
+ real, parameter :: pi = 3.14159265
+ real, parameter :: f0 = 1. / 50.
+ real, parameter :: t0 = 1.2 / f0
+ real, parameter :: a = pi*pi*f0*f0
+
+ integer, parameter :: NTSTEP_BETWEEN_OUTPUT_INFO = 200
+
+ integer, parameter :: IIN = 40
+
+! number of GLL integration points in each direction of an element (degree plus one)
+ integer, parameter :: NGLLX = 5
+ integer, parameter :: NGLLY = NGLLX
+ integer, parameter :: NGLLZ = NGLLX
+
+! 3-D simulation
+ integer, parameter :: NDIM = 3
+
+ real(kind=4), parameter :: VERYSMALLVAL = 1.e-24
+
+! displacement threshold above which we consider that the code became unstable
+ real(kind=4), parameter :: STABILITY_THRESHOLD = 1.e+25
+
+! approximate density of the medium in which the source is located
+ real(kind=4), parameter :: rho = 4500.
+
+! global displacement, velocity and acceleration vectors
+ real(kind=4), dimension(NGLOB) :: displx,disply,displz,velocx,velocy,velocz,accelx,accely,accelz
+
+! global diagonal mass matrix
+ real(kind=4), dimension(NGLOB) :: rmass_inverse
+
+! record a seismogram to check that the simulation went well
+ real(kind=4), dimension(NSTEP) :: seismogram
+
+! time step
+ integer it
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: ibool
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,kappav,muv,jacobian
+
+! array with derivatives of Lagrange polynomials and precalculated products
+!! DK DK store transpose of matrix
+ real(kind=4), dimension(NGLLX,NGLLX) :: hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT
+ real(kind=4), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=4), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=4), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
+ newtempx1,newtempx2,newtempx3,newtempy1,newtempy2,newtempy3,newtempz1,newtempz2,newtempz3
+
+ integer :: ispec,iglob,i,j,k !!!!!!!!!!!!! ,l
+
+ real(kind=4) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=4) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+ real(kind=4) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=4) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+ real(kind=4) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
+! real(kind=4) hp1,hp2,hp3
+ real(kind=4) fac1,fac2,fac3,lambdal,mul,lambdalplus2mul,kappal
+! real(kind=4) tempx1l,tempx2l,tempx3l,tempy1l,tempy2l,tempy3l,tempz1l,tempz2l,tempz3l
+
+ real(kind=4) Usolidnorm,current_value,time,memory_size
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc
+
+! timer to count elapsed time
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+ integer ihours,iminutes,iseconds,int_tCPU
+ double precision :: time_start,time_end,tCPU
+
+! estimate of total memory size used
+ print *
+ print *,'NSPEC = ',NSPEC
+ print *,'NGLOB = ',NGLOB
+ print *
+
+ print *,'NSTEP = ',NSTEP
+ print *,'deltat = ',deltat
+ print *
+
+! estimate total memory size (the size of a real number is 4 bytes)
+! we perform the calculation in single precision rather than integer
+! to avoid integer overflow in the case of very large meshes
+ memory_size = 4. * ((3.*NDIM + 1.) * NGLOB + 13. * real(NGLLX*NGLLY*NGLLZ)*real(NSPEC))
+ print *,'approximate total memory size used = ',memory_size/1024./1024.,' Mb'
+ print *
+
+! make sure the source element number is an integer
+ if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...'
+
+! read the mesh from external file
+ open(unit=IIN,file='database.dat',status='old')
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+! read real numbers here
+ read(IIN,*) xix(i,j,k,ispec)
+ read(IIN,*) xiy(i,j,k,ispec)
+ read(IIN,*) xiz(i,j,k,ispec)
+ read(IIN,*) etax(i,j,k,ispec)
+ read(IIN,*) etay(i,j,k,ispec)
+ read(IIN,*) etaz(i,j,k,ispec)
+ read(IIN,*) gammax(i,j,k,ispec)
+ read(IIN,*) gammay(i,j,k,ispec)
+ read(IIN,*) gammaz(i,j,k,ispec)
+ read(IIN,*) kappav(i,j,k,ispec)
+ read(IIN,*) muv(i,j,k,ispec)
+
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+ jacobian(i,j,k,ispec) = 1. / (xixl*(etayl*gammazl-etazl*gammayl)- &
+ xiyl*(etaxl*gammazl-etazl*gammaxl)+xizl*(etaxl*gammayl-etayl*gammaxl))
+
+
+! read an integer here
+ read(IIN,*) ibool(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+ do i = 1,NGLOB
+ read(IIN,*) rmass_inverse(i)
+ enddo
+ close(IIN)
+
+ open(unit=IIN,file='matrices.dat',status='old')
+ do j=1,NGLLY
+ do i=1,NGLLX
+ read(IIN,*) hprime_xx(i,j)
+ read(IIN,*) hprimewgll_xx(i,j)
+ read(IIN,*) wgllwgll_yz(i,j)
+ read(IIN,*) wgllwgll_xz(i,j)
+ read(IIN,*) wgllwgll_xy(i,j)
+ enddo
+ enddo
+ close(IIN)
+
+!! DK DK define transpose of 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
+
+! clear initial vectors before starting the time loop
+! (can remain serial because done only once before entering the time loop)
+ displx(:) = 0. ! 1. !!!!!!!!! VERYSMALLVAL
+ disply(:) = 0. ! 1. !!!!!!!!! VERYSMALLVAL
+ displz(:) = 0. ! 1. !!!!!!!!! VERYSMALLVAL
+ velocx(:) = 0. ! 1. !!!!!!!!! 0.
+ velocy(:) = 0. ! 1. !!!!!!!!! 0.
+ velocz(:) = 0. ! 1. !!!!!!!!! 0.
+ accelx(:) = 0. ! 1. !!!!!!!!! 0.
+ accely(:) = 0. ! 1. !!!!!!!!! 0.
+ accelz(:) = 0. ! 1. !!!!!!!!! 0.
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! start of the time loop (which must remain serial obviously)
+ do it = 1,NSTEP
+
+! compute maximum of norm of displacement from time to time and display it
+! in order to monitor the simulation
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then
+! if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
+!!!!!!!!!!!! if(it == 2100 .or. it == 5) then
+ Usolidnorm = -1.
+ do iglob = 1,NGLOB
+ current_value = sqrt(displx(iglob)**2 + disply(iglob)**2 + displz(iglob)**2)
+ if(current_value > Usolidnorm) Usolidnorm = current_value
+ enddo
+ write(*,*) 'Time step # ',it,' out of ',NSTEP
+! compute current time
+ time = (it-1)*deltat
+ write(*,*) 'Time = ',time,' seconds out of ',(NSTEP-1)*deltat,' seconds'
+ write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm
+! check stability of the code, exit if unstable
+ if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up'
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! elapsed time since beginning of the simulation
+ tCPU = time_end - time_start
+ int_tCPU = int(tCPU)
+ ihours = int_tCPU / 3600
+ iminutes = (int_tCPU - 3600*ihours) / 60
+ iseconds = int_tCPU - 3600*ihours - 60*iminutes
+ write(*,*) 'Elapsed time in seconds = ',tCPU
+ write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ write(*,*)
+
+ endif
+
+! big loop over all the global points (not elements) in the mesh to update
+! the displacement and velocity vectors and clear the acceleration vector
+ displx(:) = displx(:) + deltat*velocx(:) + deltatsqover2*accelx(:)
+ disply(:) = disply(:) + deltat*velocy(:) + deltatsqover2*accely(:)
+ displz(:) = displz(:) + deltat*velocz(:) + deltatsqover2*accelz(:)
+
+ velocx(:) = velocx(:) + deltatover2*accelx(:)
+ velocy(:) = velocy(:) + deltatover2*accely(:)
+ velocz(:) = velocz(:) + deltatover2*accelz(:)
+
+ accelx(:) = 0.
+ accely(:) = 0.
+ accelz(:) = 0.
+
+! big loop over all the elements in the mesh to localize data
+! from the global vectors to the local mesh
+! using indirect addressing (contained in array ibool)
+! and then to compute the elemental contribution
+! to the acceleration vector of each element of the finite-element mesh
+ do ispec = 1,NSPEC
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ dummyx_loc(i,j,k) = displx(iglob)
+ dummyy_loc(i,j,k) = disply(iglob)
+ dummyz_loc(i,j,k) = displz(iglob)
+ enddo
+ enddo
+ enddo
+
+!! DK DK from Deville et al. (2002) page 387
+
+! code adapted by DK here
+ call mxm_m1_m2_5points(hprime_xx,dummyx_loc,dummyy_loc,dummyz_loc,tempx1,tempy1,tempz1)
+
+ do k = 1,NGLLX
+ call mxm_m1_m1_5points(dummyx_loc(1,1,k),dummyy_loc(1,1,k),dummyz_loc(1,1,k), &
+ hprime_xxT,tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k))
+ enddo
+
+ call mxm_m2_m1_5points(dummyx_loc,dummyy_loc,dummyz_loc,hprime_xxT,tempx3,tempy3,tempz3)
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+! tempx1l = 0.
+! tempx2l = 0.
+! tempx3l = 0.
+
+! tempy1l = 0.
+! tempy2l = 0.
+! tempy3l = 0.
+
+! tempz1l = 0.
+! tempz2l = 0.
+! tempz3l = 0.
+
+! do l=1,NGLLX
+! hp1 = hprime_xx(i,l)
+! tempx1l = tempx1l + dummyx_loc(l,j,k)*hp1
+! tempy1l = tempy1l + dummyy_loc(l,j,k)*hp1
+! tempz1l = tempz1l + dummyz_loc(l,j,k)*hp1
+
+! hp2 = hprime_xx(j,l)
+! tempx2l = tempx2l + dummyx_loc(i,l,k)*hp2
+! tempy2l = tempy2l + dummyy_loc(i,l,k)*hp2
+! tempz2l = tempz2l + dummyz_loc(i,l,k)*hp2
+
+! hp3 = hprime_xx(k,l)
+! tempx3l = tempx3l + dummyx_loc(i,j,l)*hp3
+! tempy3l = tempy3l + dummyy_loc(i,j,l)*hp3
+! tempz3l = tempz3l + dummyz_loc(i,j,l)*hp3
+! enddo
+
+! compute 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)
+! jacobianl = 1. / (xixl*(etayl*gammazl-etazl*gammayl)- &
+! xiyl*(etaxl*gammazl-etazl*gammaxl)+xizl*(etaxl*gammayl-etayl*gammaxl))
+ jacobianl = jacobian(i,j,k,ispec)
+
+ 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 isotropic elements
+ kappal = kappav(i,j,k,ispec)
+ mul = muv(i,j,k,ispec)
+
+!!!!!!!!!!!!!!!!!!!!! lambdalplus2mul = kappal + (4./3.) * mul
+ lambdalplus2mul = kappal + 1.33333333333333 * 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
+
+! form dot product with test vector
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+
+ enddo
+ enddo
+ enddo
+
+! code adapted by DK here
+ call mxm_m1_m2_5points(hprimewgll_xxT,tempx1,tempy1,tempz1,newtempx1,newtempy1,newtempz1)
+
+ do k = 1,NGLLX
+ call mxm_m1_m1_5points(tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k), &
+ hprimewgll_xx,newtempx2(1,1,k),newtempy2(1,1,k),newtempz2(1,1,k))
+ enddo
+
+ call mxm_m2_m1_5points(tempx3,tempy3,tempz3,hprimewgll_xx,newtempx3,newtempy3,newtempz3)
+
+! do k=1,NGLLZ
+! do j=1,NGLLY
+! do i=1,NGLLX
+
+! tempx1l = 0.
+! tempy1l = 0.
+! tempz1l = 0.
+
+! tempx2l = 0.
+! tempy2l = 0.
+! tempz2l = 0.
+
+! tempx3l = 0.
+! tempy3l = 0.
+! tempz3l = 0.
+
+! 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
+
+! fac2 = hprimewgll_xx(l,j)
+! tempx2l = tempx2l + tempx2(i,l,k)*fac2
+! tempy2l = tempy2l + tempy2(i,l,k)*fac2
+! tempz2l = tempz2l + tempz2(i,l,k)*fac2
+
+! fac3 = hprimewgll_xx(l,k)
+! tempx3l = tempx3l + tempx3(i,j,l)*fac3
+! tempy3l = tempy3l + tempy3(i,j,l)*fac3
+! tempz3l = tempz3l + tempz3(i,j,l)*fac3
+! enddo
+
+! enddo
+! 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 from each element to the global mesh using indirect addressing
+ iglob = ibool(i,j,k,ispec)
+ accelx(iglob) = accelx(iglob) - (fac1*newtempx1(i,j,k) + fac2*newtempx2(i,j,k) + fac3*newtempx3(i,j,k))
+ accely(iglob) = accely(iglob) - (fac1*newtempy1(i,j,k) + fac2*newtempy2(i,j,k) + fac3*newtempy3(i,j,k))
+ accelz(iglob) = accelz(iglob) - (fac1*newtempz1(i,j,k) + fac2*newtempz2(i,j,k) + fac3*newtempz3(i,j,k))
+
+ enddo
+ enddo
+ enddo
+
+ enddo ! end of main loop on all the elements
+
+! big loop over all the global points (not elements) in the mesh to update
+! the acceleration and velocity vectors
+ accelx(:) = accelx(:)*rmass_inverse(:)
+ accely(:) = accely(:)*rmass_inverse(:)
+ accelz(:) = accelz(:)*rmass_inverse(:)
+
+! add the earthquake source at a given grid point
+! this is negligible and can remain serial because it is done by only
+! one grid point out of several millions typically
+ iglob = ibool(2,2,2,NSPEC_SOURCE)
+! compute current time
+ time = (it-1)*deltat
+ accelz(iglob) = accelz(iglob) + 1.e4 * (1.-2.*a*(time-t0)**2) * exp(-a*(time-t0)**2) / rho
+
+ velocx(:) = velocx(:) + deltatover2*accelx(:)
+ velocy(:) = velocy(:) + deltatover2*accely(:)
+ velocz(:) = velocz(:) + deltatover2*accelz(:)
+
+! record a seismogram to check that the simulation went well
+! select a point in an element near the end of the mesh, since the source is in the middle
+ iglob = ibool(2,2,2,NSPEC - 10)
+ seismogram(it) = displz(iglob)
+
+ enddo ! end of the serial time loop
+
+! save the seismogram at the end of the run
+ open(unit=IIN,file='seismogram_F90.txt',status='unknown')
+ do it = 1,NSTEP
+ write(IIN,*) (it-1)*deltat,seismogram(it)
+ enddo
+ close(IIN)
+
+ end program serial_specfem3D
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! DK DK subroutines adapted from Deville, Fischer and Mund, High-order methods
+!! DK DK for incompressible fluid flow, Cambridge University Press (2002),
+!! DK DK pages 386 and 389 and Figure 8.3.1
+
+ subroutine mxm_m1_m2_5points(A,B1,B2,B3,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m1,NGLLX) :: A
+ real(kind=4), dimension(NGLLX,m2) :: B1,B2,B3
+ real(kind=4), dimension(m1,m2) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m2
+ do i=1,m1
+
+ C1(i,j) = A(i,1)*B1(1,j) + &
+ A(i,2)*B1(2,j) + &
+ A(i,3)*B1(3,j) + &
+ A(i,4)*B1(4,j) + &
+ A(i,5)*B1(5,j)
+
+ C2(i,j) = A(i,1)*B2(1,j) + &
+ A(i,2)*B2(2,j) + &
+ A(i,3)*B2(3,j) + &
+ A(i,4)*B2(4,j) + &
+ A(i,5)*B2(5,j)
+
+ C3(i,j) = A(i,1)*B3(1,j) + &
+ A(i,2)*B3(2,j) + &
+ A(i,3)*B3(3,j) + &
+ A(i,4)*B3(4,j) + &
+ A(i,5)*B3(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m1_m2_5points
+
+!---------
+
+ subroutine mxm_m1_m1_5points(A1,A2,A3,B,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m1,NGLLX) :: A1,A2,A3
+ real(kind=4), dimension(NGLLX,m1) :: B
+ real(kind=4), dimension(m1,m1) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m1
+ do i=1,m1
+
+ C1(i,j) = A1(i,1)*B(1,j) + &
+ A1(i,2)*B(2,j) + &
+ A1(i,3)*B(3,j) + &
+ A1(i,4)*B(4,j) + &
+ A1(i,5)*B(5,j)
+
+ C2(i,j) = A2(i,1)*B(1,j) + &
+ A2(i,2)*B(2,j) + &
+ A2(i,3)*B(3,j) + &
+ A2(i,4)*B(4,j) + &
+ A2(i,5)*B(5,j)
+
+ C3(i,j) = A3(i,1)*B(1,j) + &
+ A3(i,2)*B(2,j) + &
+ A3(i,3)*B(3,j) + &
+ A3(i,4)*B(4,j) + &
+ A3(i,5)*B(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m1_m1_5points
+
+!---------
+
+ subroutine mxm_m2_m1_5points(A1,A2,A3,B,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m2,NGLLX) :: A1,A2,A3
+ real(kind=4), dimension(NGLLX,m1) :: B
+ real(kind=4), dimension(m2,m1) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m1
+ do i=1,m2
+
+ C1(i,j) = A1(i,1)*B(1,j) + &
+ A1(i,2)*B(2,j) + &
+ A1(i,3)*B(3,j) + &
+ A1(i,4)*B(4,j) + &
+ A1(i,5)*B(5,j)
+
+ C2(i,j) = A2(i,1)*B(1,j) + &
+ A2(i,2)*B(2,j) + &
+ A2(i,3)*B(3,j) + &
+ A2(i,4)*B(4,j) + &
+ A2(i,5)*B(5,j)
+
+ C3(i,j) = A3(i,1)*B(1,j) + &
+ A3(i,2)*B(2,j) + &
+ A3(i,3)*B(3,j) + &
+ A3(i,4)*B(4,j) + &
+ A3(i,5)*B(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m2_m1_5points
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v06_fac1_merged_not_faster.f90
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v06_fac1_merged_not_faster.f90 (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/serial_specfem3D_26dec2008_inlined_v06_fac1_merged_not_faster.f90 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,645 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ program serial_specfem3D
+
+ implicit none
+
+!!!!!!!!!!
+!!!!!!!!!! All the arrays below use static memory allocation,
+!!!!!!!!!! using constant sizes defined in values_from_mesher.h.
+!!!!!!!!!! This is done purposely to improve performance (Fortran compilers
+!!!!!!!!!! can optimize much more when the size of the loops and arrays
+!!!!!!!!!! is known at compile time).
+!!!!!!!!!! NGLLX, NGLLY and NGLLZ are set equal to 5,
+!!!!!!!!!! therefore each element contains NGLLX * NGLLY * NGLLZ = 125 points.
+!!!!!!!!!!
+
+!!!!!!!!!!
+!!!!!!!!!! All the calculations are done in single precision.
+!!!!!!!!!! We do not need double precision in SPECFEM3D.
+!!!!!!!!!!
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "values_from_mesher_f90.h"
+
+! constant value of the time step in the main time loop
+ real(kind=4), parameter :: deltatover2 = 0.5*deltat, deltatsqover2 = 0.5*deltat*deltat
+
+! element in which the source is located
+ integer, parameter :: NSPEC_SOURCE = NSPEC / 2
+
+! for the source time function
+ real, parameter :: pi = 3.14159265
+ real, parameter :: f0 = 1. / 50.
+ real, parameter :: t0 = 1.2 / f0
+ real, parameter :: a = pi*pi*f0*f0
+
+ integer, parameter :: NTSTEP_BETWEEN_OUTPUT_INFO = 200
+
+ integer, parameter :: IIN = 40
+
+! number of GLL integration points in each direction of an element (degree plus one)
+ integer, parameter :: NGLLX = 5
+ integer, parameter :: NGLLY = NGLLX
+ integer, parameter :: NGLLZ = NGLLX
+
+! 3-D simulation
+ integer, parameter :: NDIM = 3
+
+ real(kind=4), parameter :: VERYSMALLVAL = 1.e-24
+
+! displacement threshold above which we consider that the code became unstable
+ real(kind=4), parameter :: STABILITY_THRESHOLD = 1.e+25
+
+! approximate density of the medium in which the source is located
+ real(kind=4), parameter :: rho = 4500.
+
+! global displacement, velocity and acceleration vectors
+ real(kind=4), dimension(NDIM,NGLOB) :: displ,veloc,accel
+
+! global diagonal mass matrix
+ real(kind=4), dimension(NGLOB) :: rmass_inverse
+
+! record a seismogram to check that the simulation went well
+ real(kind=4), dimension(NSTEP) :: seismogram
+
+! time step
+ integer it
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: ibool
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,kappav,muv,jacobian,jacobian1,jacobian2,jacobian3
+
+! array with derivatives of Lagrange polynomials and precalculated products
+!! DK DK store transpose of matrix
+ real(kind=4), dimension(NGLLX,NGLLX) :: hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT
+ real(kind=4), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=4), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=4), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3, &
+ newtempx1,newtempx2,newtempx3,newtempy1,newtempy2,newtempy3,newtempz1,newtempz2,newtempz3
+
+ integer :: ispec,iglob,i,j,k !!!!!!!!!!!!! ,l
+
+ real(kind=4) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobian1l,jacobian2l,jacobian3l
+ real(kind=4) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+ real(kind=4) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=4) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+ real(kind=4) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
+! real(kind=4) hp1,hp2,hp3,fac1,fac2,fac3
+ real(kind=4) lambdal,mul,lambdalplus2mul,kappal
+! real(kind=4) tempx1l,tempx2l,tempx3l,tempy1l,tempy2l,tempy3l,tempz1l,tempz2l,tempz3l
+
+ real(kind=4) Usolidnorm,current_value,time,memory_size
+
+ real(kind=4), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc
+
+! timer to count elapsed time
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+ integer ihours,iminutes,iseconds,int_tCPU
+ double precision :: time_start,time_end,tCPU
+
+! estimate of total memory size used
+ print *
+ print *,'NSPEC = ',NSPEC
+ print *,'NGLOB = ',NGLOB
+ print *
+
+ print *,'NSTEP = ',NSTEP
+ print *,'deltat = ',deltat
+ print *
+
+! estimate total memory size (the size of a real number is 4 bytes)
+! we perform the calculation in single precision rather than integer
+! to avoid integer overflow in the case of very large meshes
+ memory_size = 4. * ((3.*NDIM + 1.) * NGLOB + 13. * real(NGLLX*NGLLY*NGLLZ)*real(NSPEC))
+ print *,'approximate total memory size used = ',memory_size/1024./1024.,' Mb'
+ print *
+
+! make sure the source element number is an integer
+ if(mod(NSPEC,2) /= 0) stop 'source element number is not an integer, exiting...'
+
+ open(unit=IIN,file='matrices.dat',status='old')
+ do j=1,NGLLY
+ do i=1,NGLLX
+ read(IIN,*) hprime_xx(i,j)
+ read(IIN,*) hprimewgll_xx(i,j)
+ read(IIN,*) wgllwgll_yz(i,j)
+ read(IIN,*) wgllwgll_xz(i,j)
+ read(IIN,*) wgllwgll_xy(i,j)
+ enddo
+ enddo
+ close(IIN)
+
+! read the mesh from external file
+ open(unit=IIN,file='database.dat',status='old')
+ do ispec = 1,NSPEC
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+! read real numbers here
+ read(IIN,*) xix(i,j,k,ispec)
+ read(IIN,*) xiy(i,j,k,ispec)
+ read(IIN,*) xiz(i,j,k,ispec)
+ read(IIN,*) etax(i,j,k,ispec)
+ read(IIN,*) etay(i,j,k,ispec)
+ read(IIN,*) etaz(i,j,k,ispec)
+ read(IIN,*) gammax(i,j,k,ispec)
+ read(IIN,*) gammay(i,j,k,ispec)
+ read(IIN,*) gammaz(i,j,k,ispec)
+ read(IIN,*) kappav(i,j,k,ispec)
+ read(IIN,*) muv(i,j,k,ispec)
+
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+ jacobian(i,j,k,ispec) = 1. / (xixl*(etayl*gammazl-etazl*gammayl)- &
+ xiyl*(etaxl*gammazl-etazl*gammaxl)+xizl*(etaxl*gammayl-etayl*gammaxl))
+
+ jacobian1(i,j,k,ispec) = - wgllwgll_yz(j,k) * jacobian(i,j,k,ispec)
+ jacobian2(i,j,k,ispec) = - wgllwgll_xz(i,k) * jacobian(i,j,k,ispec)
+ jacobian3(i,j,k,ispec) = - wgllwgll_xy(i,j) * jacobian(i,j,k,ispec)
+
+! read an integer here
+ read(IIN,*) ibool(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+ do i = 1,NGLOB
+ read(IIN,*) rmass_inverse(i)
+ enddo
+ close(IIN)
+
+!! DK DK define transpose of 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
+
+ if(NGLLX /= 5) stop 'this inlined version with matrix products following Deville (2002) is only valid for NGLL = 5'
+
+! clear initial vectors before starting the time loop
+! (can remain serial because done only once before entering the time loop)
+ displ(:,:) = 0. ! 1. !!!!!!!!! VERYSMALLVAL
+ veloc(:,:) = 0. ! 1. !!!!!!!!! 0.
+ accel(:,:) = 0. ! 1. !!!!!!!!! 0.
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! start of the time loop (which must remain serial obviously)
+ do it = 1,NSTEP
+
+! compute maximum of norm of displacement from time to time and display it
+! in order to monitor the simulation
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then
+!!!!!!!!!!!! if(it == 2100 .or. it == 5) then
+ Usolidnorm = -1.
+ do iglob = 1,NGLOB
+ current_value = sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2)
+ if(current_value > Usolidnorm) Usolidnorm = current_value
+ enddo
+ write(*,*) 'Time step # ',it,' out of ',NSTEP
+! compute current time
+ time = (it-1)*deltat
+ write(*,*) 'Time = ',time,' seconds out of ',(NSTEP-1)*deltat,' seconds'
+ write(*,*) 'Max norm displacement vector U in the solid (m) = ',Usolidnorm
+! check stability of the code, exit if unstable
+ if(Usolidnorm > STABILITY_THRESHOLD .or. Usolidnorm < 0) stop 'code became unstable and blew up'
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! elapsed time since beginning of the simulation
+ tCPU = time_end - time_start
+ int_tCPU = int(tCPU)
+ ihours = int_tCPU / 3600
+ iminutes = (int_tCPU - 3600*ihours) / 60
+ iseconds = int_tCPU - 3600*ihours - 60*iminutes
+ write(*,*) 'Elapsed time in seconds = ',tCPU
+ write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ write(*,*)
+
+ endif
+
+! big loop over all the global points (not elements) in the mesh to update
+! the displacement and velocity vectors and clear the acceleration vector
+ displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsqover2*accel(:,:)
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+ accel(:,:) = 0.
+
+! big loop over all the elements in the mesh to localize data
+! from the global vectors to the local mesh
+! using indirect addressing (contained in array ibool)
+! and then to compute the elemental contribution
+! to the acceleration vector of each element of the finite-element mesh
+ do ispec = 1,NSPEC
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ dummyx_loc(i,j,k) = displ(1,iglob)
+ dummyy_loc(i,j,k) = displ(2,iglob)
+ dummyz_loc(i,j,k) = displ(3,iglob)
+ enddo
+ enddo
+ enddo
+
+!! DK DK subroutines adapted from Deville, Fischer and Mund, High-order methods
+!! DK DK for incompressible fluid flow, Cambridge University Press (2002),
+!! DK DK pages 386 and 389 and Figure 8.3.1
+ call mxm_m1_m2_5points(hprime_xx,dummyx_loc,dummyy_loc,dummyz_loc,tempx1,tempy1,tempz1)
+
+ do k = 1,NGLLX
+ call mxm_m1_m1_5points(dummyx_loc(1,1,k),dummyy_loc(1,1,k),dummyz_loc(1,1,k), &
+ hprime_xxT,tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k))
+ enddo
+
+ call mxm_m2_m1_5points(dummyx_loc,dummyy_loc,dummyz_loc,hprime_xxT,tempx3,tempy3,tempz3)
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+! tempx1l = 0.
+! tempx2l = 0.
+! tempx3l = 0.
+
+! tempy1l = 0.
+! tempy2l = 0.
+! tempy3l = 0.
+
+! tempz1l = 0.
+! tempz2l = 0.
+! tempz3l = 0.
+
+! do l=1,NGLLX
+! hp1 = hprime_xx(i,l)
+! tempx1l = tempx1l + dummyx_loc(l,j,k)*hp1
+! tempy1l = tempy1l + dummyy_loc(l,j,k)*hp1
+! tempz1l = tempz1l + dummyz_loc(l,j,k)*hp1
+
+! hp2 = hprime_xx(j,l)
+! tempx2l = tempx2l + dummyx_loc(i,l,k)*hp2
+! tempy2l = tempy2l + dummyy_loc(i,l,k)*hp2
+! tempz2l = tempz2l + dummyz_loc(i,l,k)*hp2
+
+! hp3 = hprime_xx(k,l)
+! tempx3l = tempx3l + dummyx_loc(i,j,l)*hp3
+! tempy3l = tempy3l + dummyy_loc(i,j,l)*hp3
+! tempz3l = tempz3l + dummyz_loc(i,j,l)*hp3
+! enddo
+
+! compute 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)
+! jacobianl = 1. / (xixl*(etayl*gammazl-etazl*gammayl)- &
+! xiyl*(etaxl*gammazl-etazl*gammaxl)+xizl*(etaxl*gammayl-etayl*gammaxl))
+!! DK DK this is now precomputed and stored to avoid a costly operation
+ jacobian1l = jacobian1(i,j,k,ispec)
+ jacobian2l = jacobian2(i,j,k,ispec)
+ jacobian3l = jacobian3(i,j,k,ispec)
+
+ 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 isotropic elements
+ kappal = kappav(i,j,k,ispec)
+ mul = muv(i,j,k,ispec)
+
+! lambdalplus2mul = kappal + (4./3.) * mul
+!! DK DK precompute the 4/3 ratio to avoid a division here
+ lambdalplus2mul = kappal + 1.33333333333333 * 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
+
+ tempx1(i,j,k) = jacobian1l * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
+ tempy1(i,j,k) = jacobian1l * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
+ tempz1(i,j,k) = jacobian1l * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobian2l * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
+ tempy2(i,j,k) = jacobian2l * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
+ tempz2(i,j,k) = jacobian2l * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobian3l * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
+ tempy3(i,j,k) = jacobian3l * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
+ tempz3(i,j,k) = jacobian3l * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+
+ enddo
+ enddo
+ enddo
+
+!! DK DK subroutines adapted from Deville, Fischer and Mund, High-order methods
+!! DK DK for incompressible fluid flow, Cambridge University Press (2002),
+!! DK DK pages 386 and 389 and Figure 8.3.1
+ call mxm_m1_m2_5points(hprimewgll_xxT,tempx1,tempy1,tempz1,newtempx1,newtempy1,newtempz1)
+
+ do k = 1,NGLLX
+ call mxm_m1_m1_5points(tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k), &
+ hprimewgll_xx,newtempx2(1,1,k),newtempy2(1,1,k),newtempz2(1,1,k))
+ enddo
+
+ call mxm_m2_m1_5points(tempx3,tempy3,tempz3,hprimewgll_xx,newtempx3,newtempy3,newtempz3)
+
+! do k=1,NGLLZ
+! do j=1,NGLLY
+! do i=1,NGLLX
+
+! tempx1l = 0.
+! tempy1l = 0.
+! tempz1l = 0.
+
+! tempx2l = 0.
+! tempy2l = 0.
+! tempz2l = 0.
+
+! tempx3l = 0.
+! tempy3l = 0.
+! tempz3l = 0.
+
+! 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
+
+! fac2 = hprimewgll_xx(l,j)
+! tempx2l = tempx2l + tempx2(i,l,k)*fac2
+! tempy2l = tempy2l + tempy2(i,l,k)*fac2
+! tempz2l = tempz2l + tempz2(i,l,k)*fac2
+
+! fac3 = hprimewgll_xx(l,k)
+! tempx3l = tempx3l + tempx3(i,j,l)*fac3
+! tempy3l = tempy3l + tempy3(i,j,l)*fac3
+! tempz3l = tempz3l + tempz3(i,j,l)*fac3
+! enddo
+
+! enddo
+! enddo
+! enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+! sum contributions from each element to the global mesh using indirect addressing
+ iglob = ibool(i,j,k,ispec)
+ accel(1,iglob) = accel(1,iglob) + newtempx1(i,j,k) + newtempx2(i,j,k) + newtempx3(i,j,k)
+ accel(2,iglob) = accel(2,iglob) + newtempy1(i,j,k) + newtempy2(i,j,k) + newtempy3(i,j,k)
+ accel(3,iglob) = accel(3,iglob) + newtempz1(i,j,k) + newtempz2(i,j,k) + newtempz3(i,j,k)
+
+ enddo
+ enddo
+ enddo
+
+ enddo ! end of main loop on all the elements
+
+! big loop over all the global points (not elements) in the mesh to update
+! the acceleration and velocity vectors
+ accel(1,:) = accel(1,:)*rmass_inverse(:)
+ accel(2,:) = accel(2,:)*rmass_inverse(:)
+ accel(3,:) = accel(3,:)*rmass_inverse(:)
+
+! add the earthquake source at a given grid point
+! this is negligible and can remain serial because it is done by only
+! one grid point out of several millions typically
+ iglob = ibool(2,2,2,NSPEC_SOURCE)
+! compute current time
+ time = (it-1)*deltat
+ accel(3,iglob) = accel(3,iglob) + 1.e4 * (1.-2.*a*(time-t0)**2) * exp(-a*(time-t0)**2) / rho
+
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+
+! record a seismogram to check that the simulation went well
+! select a point in an element near the end of the mesh, since the source is in the middle
+ iglob = ibool(2,2,2,NSPEC - 10)
+ seismogram(it) = displ(3,iglob)
+
+ enddo ! end of the serial time loop
+
+! save the seismogram at the end of the run
+ open(unit=IIN,file='seismogram_F90.txt',status='unknown')
+ do it = 1,NSTEP
+ write(IIN,*) (it-1)*deltat,seismogram(it)
+ enddo
+ close(IIN)
+
+ end program serial_specfem3D
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!! DK DK subroutines adapted from Deville, Fischer and Mund, High-order methods
+!! DK DK for incompressible fluid flow, Cambridge University Press (2002),
+!! DK DK pages 386 and 389 and Figure 8.3.1
+
+ subroutine mxm_m1_m2_5points(A,B1,B2,B3,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m1,NGLLX) :: A
+ real(kind=4), dimension(NGLLX,m2) :: B1,B2,B3
+ real(kind=4), dimension(m1,m2) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m2
+ do i=1,m1
+
+ C1(i,j) = A(i,1)*B1(1,j) + &
+ A(i,2)*B1(2,j) + &
+ A(i,3)*B1(3,j) + &
+ A(i,4)*B1(4,j) + &
+ A(i,5)*B1(5,j)
+
+ C2(i,j) = A(i,1)*B2(1,j) + &
+ A(i,2)*B2(2,j) + &
+ A(i,3)*B2(3,j) + &
+ A(i,4)*B2(4,j) + &
+ A(i,5)*B2(5,j)
+
+ C3(i,j) = A(i,1)*B3(1,j) + &
+ A(i,2)*B3(2,j) + &
+ A(i,3)*B3(3,j) + &
+ A(i,4)*B3(4,j) + &
+ A(i,5)*B3(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m1_m2_5points
+
+!---------
+
+ subroutine mxm_m1_m1_5points(A1,A2,A3,B,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m1,NGLLX) :: A1,A2,A3
+ real(kind=4), dimension(NGLLX,m1) :: B
+ real(kind=4), dimension(m1,m1) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m1
+ do i=1,m1
+
+ C1(i,j) = A1(i,1)*B(1,j) + &
+ A1(i,2)*B(2,j) + &
+ A1(i,3)*B(3,j) + &
+ A1(i,4)*B(4,j) + &
+ A1(i,5)*B(5,j)
+
+ C2(i,j) = A2(i,1)*B(1,j) + &
+ A2(i,2)*B(2,j) + &
+ A2(i,3)*B(3,j) + &
+ A2(i,4)*B(4,j) + &
+ A2(i,5)*B(5,j)
+
+ C3(i,j) = A3(i,1)*B(1,j) + &
+ A3(i,2)*B(2,j) + &
+ A3(i,3)*B(3,j) + &
+ A3(i,4)*B(4,j) + &
+ A3(i,5)*B(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m1_m1_5points
+
+!---------
+
+ subroutine mxm_m2_m1_5points(A1,A2,A3,B,C1,C2,C3)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=4), dimension(m2,NGLLX) :: A1,A2,A3
+ real(kind=4), dimension(NGLLX,m1) :: B
+ real(kind=4), dimension(m2,m1) :: C1,C2,C3
+
+ integer :: i,j
+
+ do j=1,m1
+ do i=1,m2
+
+ C1(i,j) = A1(i,1)*B(1,j) + &
+ A1(i,2)*B(2,j) + &
+ A1(i,3)*B(3,j) + &
+ A1(i,4)*B(4,j) + &
+ A1(i,5)*B(5,j)
+
+ C2(i,j) = A2(i,1)*B(1,j) + &
+ A2(i,2)*B(2,j) + &
+ A2(i,3)*B(3,j) + &
+ A2(i,4)*B(4,j) + &
+ A2(i,5)*B(5,j)
+
+ C3(i,j) = A3(i,1)*B(1,j) + &
+ A3(i,2)*B(2,j) + &
+ A3(i,3)*B(3,j) + &
+ A3(i,4)*B(4,j) + &
+ A3(i,5)*B(5,j)
+
+ enddo
+ enddo
+
+ end subroutine mxm_m2_m1_5points
+
Added: seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/timings_comparing_all_versions.txt
===================================================================
--- seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/timings_comparing_all_versions.txt (rev 0)
+++ seismo/3D/SPECFEM3D/trunk/utils/solver_classical_serial_Fortran_or_C_no_MPI/slower_versions_not_so_good/timings_comparing_all_versions.txt 2012-05-20 13:57:13 UTC (rev 20198)
@@ -0,0 +1,84 @@
+
+original :
+
+ Time step # 2200 out of 2200
+ Time = 554.1480 seconds out of 554.1480 seconds
+ Max norm displacement vector U in the solid (m) = 3.036692
+ Elapsed time in seconds = 90.7499999998864
+ Elapsed time in hh:mm:ss = 0 h 01 m 30 s
+ Mean elapsed time per time step in seconds = 4.124999999994836E-002
+
+-----------------
+
+new version NGLOB :
+
+
+ Time step # 2200 out of 2200
+ Time = 554.1480 seconds out of 554.1480 seconds
+ Max norm displacement vector U in the solid (m) = 3.036692
+ Elapsed time in seconds = 95.5060000000130
+ Elapsed time in hh:mm:ss = 0 h 01 m 35 s
+ Mean elapsed time per time step in seconds = 4.341181818182410E-002
+
+-----------------
+
+new version NSPEC *seulement partielle* sans les sommes internes du GATHER :
+(tres lente, donc pas la peine d'insister, cette voie ne peut pas devenir une
+bonne voie rapide)
+
+ Time step # 2200 out of 2200
+ Time = 554.1480 seconds out of 554.1480 seconds
+ Max norm displacement vector U in the solid (m) = 60.49087
+ Elapsed time in seconds = 100.840000000104
+ Elapsed time in hh:mm:ss = 0 h 01 m 40 s
+ Mean elapsed time per time step in seconds = 4.583636363641105E-002
+
+-----------------
+
+avec inlining de Deville, partie 1 :
+
+ Time step # 2200 out of 2200
+ Time = 554.1480 seconds out of 554.1480 seconds
+ Max norm displacement vector U in the solid (m) = 3.036692
+ Elapsed time in seconds = 67.4950000000000
+ Elapsed time in hh:mm:ss = 0 h 01 m 07 s
+ Mean elapsed time per time step in seconds = 3.067954545454546E-002
+
+-------------------------------
+
+avec inlining de Deville, parties 1 et 2 :
+
+ Time step # 2200 out of 2200
+ Time = 554.1480 seconds out of 554.1480 seconds
+ Max norm displacement vector U in the solid (m) = 3.036693
+ Elapsed time in seconds = 46.8210000001416
+ Elapsed time in hh:mm:ss = 0 h 00 m 46 s
+ Mean elapsed time per time step in seconds = 2.128227272733707E-002
+
+-------------------------------
+
+avec separation de displ, veloc, accel en trois tableaux chacun : (only 2% better, not worth the change)
+
+ Time step # 2200 out of 2200
+ Time = 554.1480 seconds out of 554.1480 seconds
+ Max norm displacement vector U in the solid (m) = 3.036693
+ Elapsed time in seconds = 45.8600000001565
+ Elapsed time in hh:mm:ss = 0 h 00 m 45 s
+ Mean elapsed time per time step in seconds = 2.084545454552567E-002
+
+--------------------------
+
+avec passage de fac1, fac2 et fac3 dans des matrices constantes (ce qui
+prendrait beaucoup de memoire car il faudrait stocker trois versions
+differentes) de "jacobian" : pas de gain significatif de performance donc pas
+du tout la peine d'implementer cela :
+
+ Time step # 2200 out of 2200
+ Time = 554.1480 seconds out of 554.1480 seconds
+ Max norm displacement vector U in the solid (m) = 3.036693
+ Elapsed time in seconds = 46.9840000000261
+ Elapsed time in hh:mm:ss = 0 h 00 m 46 s
+ Mean elapsed time per time step in seconds = 2.135636363637549E-002
+
+-------------------
+
More information about the CIG-COMMITS
mailing list