[cig-commits] r11930 - in seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta: . DATA OUTPUT_FILES
dkomati1 at geodynamics.org
dkomati1 at geodynamics.org
Fri May 9 06:08:57 PDT 2008
Author: dkomati1
Date: 2008-05-09 06:08:56 -0700 (Fri, 09 May 2008)
New Revision: 11930
Added:
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION_BOLIVIA
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION_Japan
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION_SEBASTIEN
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION_VANUATU
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/Par_file
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/Par_file_1second_Ranger_elastic
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/Par_file_5seconds_Earth_Simulator_elastic
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_FULL_758
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_JAPAN_REGIONAL
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_Japan_Tomo
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_SEBASTIEN
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_SUBSET_35
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_tsuboi_tokachi-oki
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/Specfem3DGlobe.cfg
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/ori_Par_file
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/OUTPUT_FILES/
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/OUTPUT_FILES/values_from_mesher.h
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_missing_nodes.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_410_650.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_cmb.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_icb.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_after_1.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_after_2.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_before.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/anisotropic_inner_core_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/anisotropic_mantle_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_central_cube.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_scalar.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_vector.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/attenuation_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/auto_ner.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/bak/
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/calc_jacobian.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call1.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call2.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_mass_matrix_one_element.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_source_spectrum.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_source_time_function.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_arrays_source.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_coordinates_grid.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_element_properties.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_crust_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_inner_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_outer_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/constants.h
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/convolve_source_timefunction.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/count_number_of_sources.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_central_cube_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_chunk_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_header_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_list_files_chunks.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_name_database.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_regions_mesh.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/crustal_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/deallocate.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/declar.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/define_derivation_matrices.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/define_superbrick.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/euler_angles.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/exit_mpi.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/flags.guess
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_1D_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_eta.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_xi.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_cmt.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_ellipticity.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_event_info.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_global.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_jacobian_boundaries.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_perm_cuthill_mckee.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_shape2D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_shape3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_value_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/gll_library.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/go_mesher_solver_lsf_globe.bash
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/hex_nodes.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/intgrl.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/jp3d1994_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/lagrange_poly.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/lgndr.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/locate_receivers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/locate_sources.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/make_ellipticity.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/make_gravity.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/mantle_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/memory_eval.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/meshfem3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_1066a.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_ak135.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_iasp91.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_jp1d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_prem.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_ref.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_sea1d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/moho_stretching.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/mpif.h
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/netlib_specfun_erf.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/obj/
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/precision.h
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/read_compute_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/read_value_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/recompute_jacobian.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/recompute_missing_arrays.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/reduce.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/remap_lsf_machines.pl
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/rthetaphi_xyz.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/run_lsf_globe_big.bash
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/s362ani.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/save_header_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/sea99_s_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/sort_array_coordinates.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/specfem3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/spline_routines.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/store_xelm_yelm_zelm.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/stretching_function.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/topo_bathy.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/write_seismograms.f90
Log:
added beta version of version 4.1: merged mesher and solver, no need for local disks
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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: 100.0000
+latitude: 43.8200
+longitude: 12.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_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION_BOLIVIA
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION_BOLIVIA (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION_BOLIVIA 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION_Japan
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION_Japan (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION_Japan 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,13 @@
+ PDE 2005 11 21 15 36 31.00 31.0200 130.0000 145.0 5.9 0.0 KYUSHU, JAPAN
+event name: 200511211536A
+time shift: 0.0000
+half duration: 0.0000
+latitude: 30.9700
+longitude: 130.3100
+depth: 155.0000
+Mrr: 5.180000e+24
+Mtt: -2.800000e+24
+Mpp: -2.380000e+24
+Mrt: -1.350000e+23
+Mrp: 2.020000e+25
+Mtp: -5.590000e+24
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION_SEBASTIEN
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION_SEBASTIEN (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION_SEBASTIEN 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,13 @@
+PDE 1997 5 10 7 57 29.70 33.8300 59.8100 10.0 6.4 7.3 IRAN
+event name: 051097C
+time shift: 0.0000
+half duration: 0.0000
+latitude: 33.5800
+longitude: 60.0200
+depth: 15.0000
+Mrr: 3.300000e+25
+Mtt: -5.270000e+26
+Mpp: 4.940000e+26
+Mrt: 4.600000e+25
+Mrp: -8.000000e+25
+Mtp: 5.200000e+26
Property changes on: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION_SEBASTIEN
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION_VANUATU
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION_VANUATU (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/CMTSOLUTION_VANUATU 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,13 @@
+PDE 1999 11 26 13 21 15.60 -16.4200 168.2100 33.0 6.4 7.3 VANUATU ISLANDS
+event name: 112699G
+time shift: 0.0000
+half duration: 35.0000
+latitude: -16.0800
+longitude: 168.3100
+depth: 15.0000
+Mrr: 1.310000e+27
+Mtt: 1.200000e+26
+Mpp: -1.420000e+27
+Mrt: 4.600000e+26
+Mrp: 8.200000e+26
+Mtp: -2.000000e+26
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/Par_file (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/Par_file 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,112 @@
+
+# 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 = 6
+
+# 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 = 864 # 144 288 432 576 720 864 1008 1152 1296 1440
+NEX_ETA = 864
+
+# number of MPI processors along the two sides of the first chunk
+NPROC_XI = 18
+NPROC_ETA = 18
+
+# 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 = 25.0d0
+
+# save AVS or OpenDX movies
+MOVIE_SURFACE = .false.
+MOVIE_VOLUME = .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_COARSE saves movie only at corners of elements
+MOVIE_VOLUME_TYPE = 2
+MOVIE_VOLUME_COARSE = .true.
+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 = not_used_any_more_ignored
+
+# interval at which we output time step info and max of norm of displacement
+NTSTEP_BETWEEN_OUTPUT_INFO = 1000
+
+# 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 = .true.
+
+# print source time function
+PRINT_SOURCE_TIME_FUNCTION = .false.
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/Par_file_1second_Ranger_elastic
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/Par_file_1second_Ranger_elastic (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/Par_file_1second_Ranger_elastic 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,112 @@
+
+# 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 = 6
+
+# 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 = 4080 # 816 1632 2448 3264 4080 4896 5712 6528
+NEX_ETA = 4080
+
+# number of MPI processors along the two sides of the first chunk
+NPROC_XI = 102
+NPROC_ETA = 102
+
+# 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 = 25.0d0
+
+# save AVS or OpenDX movies
+MOVIE_SURFACE = .false.
+MOVIE_VOLUME = .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_COARSE saves movie only at corners of elements
+MOVIE_VOLUME_TYPE = 2
+MOVIE_VOLUME_COARSE = .true.
+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 = not_used_any_more_ignored
+
+# interval at which we output time step info and max of norm of displacement
+NTSTEP_BETWEEN_OUTPUT_INFO = 1000
+
+# 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 = .true.
+
+# print source time function
+PRINT_SOURCE_TIME_FUNCTION = .false.
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/Par_file_5seconds_Earth_Simulator_elastic
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/Par_file_5seconds_Earth_Simulator_elastic (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/Par_file_5seconds_Earth_Simulator_elastic 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,112 @@
+
+# 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 = 6
+
+# 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 = 864 # 144 288 432 576 720 864 1008 1152 1296 1440
+NEX_ETA = 864
+
+# number of MPI processors along the two sides of the first chunk
+NPROC_XI = 18
+NPROC_ETA = 18
+
+# 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 = 25.0d0
+
+# save AVS or OpenDX movies
+MOVIE_SURFACE = .false.
+MOVIE_VOLUME = .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_COARSE saves movie only at corners of elements
+MOVIE_VOLUME_TYPE = 2
+MOVIE_VOLUME_COARSE = .true.
+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 = not_used_any_more_ignored
+
+# interval at which we output time step info and max of norm of displacement
+NTSTEP_BETWEEN_OUTPUT_INFO = 1000
+
+# 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 = .true.
+
+# print source time function
+PRINT_SOURCE_TIME_FUNCTION = .false.
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,35 @@
+BBSR IU +32.371200 -064.696200 6.0 0.0
+SAML IU -08.948800 -063.183200 130.0 0.0
+SFJD IU +66.995999 -050.621500 328.0 0.0
+TRIS G -37.068200 -012.315200 57.0 0.0
+RAO IU -29.251700 -177.918300 110.0 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
+PAS CI 34.1484 -118.1711 295.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
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_FULL_758
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_FULL_758 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_FULL_758 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/DATA/STATIONS_JAPAN_REGIONAL
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_JAPAN_REGIONAL (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_JAPAN_REGIONAL 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,10 @@
+MAJO AS 36.54090 138.2083 0. 0.
+MDJ CD 44.61640 129.5919 0. 0.
+INU G 35.35000 137.0290 0. 0.
+MDJ IC 44.61640 129.5919 0. 0.
+ERM II 42.01500 143.1572 0. 0.
+YSS IU 46.95830 142.7610 0. 0.
+INCN IU 37.48330 126.6333 0. 0.
+MAJO IU 36.54250 138.2073 0. 0.
+OGS PS 27.05700 142.2030 0. 0.
+TSK PS 36.21080 140.1097 0. 0.
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_Japan_Tomo
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_Japan_Tomo (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_Japan_Tomo 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,845 @@
+BJI CB 40.018 116.170 197 0
+BNX CB 45.739 127.405 198 0
+CN2 CB 43.801 125.448 223 0
+CNS CB 28.182 112.931 81 0
+DL2 CB 38.906 121.628 62 0
+ENS CB 30.282 109.498 420 0
+GUL CB 25.076 110.294 150 0
+GZH CB 23.092 113.341 65 0
+HEF CB 31.836 117.168 65 0
+HEH CB 50.250 127.41 168 0
+HHC CB 40.849 111.564 1169 0
+HLR CB 49.270 119.741 0 0
+HNS CB 37.418 114.708 20 0
+LYN CB 34.551 112.468 170 0
+MDJ CB 44.616 129.592 250 0
+NNC CB 28.778 115.801 78 0
+NJ2 CB 32.052 118.854 45 0
+QZH CB 24.943 118.592 0 0
+QZN CB 19.029 109.844 0 0
+SNY CB 41.828 123.578 54 0
+SSE CB 31.096 121.187 10 0
+SZN CB 22.320 114.080 30 0
+TIA CB 36.211 117.124 300 0
+TIY CB 38.430 113.017 900 0
+WHN CB 30.544 114.350 26 0
+WZH CB 27.926 120.664 20 0
+XAN CB 34.039 108.921 630 0
+XLT CB 43.893 116.074 1020 0
+ABU BO 34.8635 135.5706 138.0000 0.0
+ADM BO 37.9046 138.4303 276.0000 0.0
+AMM BO 28.1571 129.3001 12.0000 0.0
+AOG BO 32.4508 139.7740 84.0000 0.0
+ASI BO 36.6342 139.4206 664.0000 0.0
+CHS BO 35.7055 140.8517 52.0000 0.0
+FUJ BO 35.2307 138.4181 640.0000 0.0
+FUK BO 32.7177 128.7572 75.0000 0.0
+GJM BO 39.9555 140.1113 105.0000 0.0
+HID BO 42.8208 142.4145 109.0000 0.0
+HJO BO 33.1048 139.8024 85.0000 0.0
+HKW BO 35.0965 138.1349 449.0000 0.0
+HRO BO 37.2246 140.8777 630.0000 0.0
+HSS BO 42.9672 141.2286 230.0000 0.0
+IGK BO 24.4131 124.1808 77.0000 0.0
+IMG BO 42.3928 140.1406 80.0000 0.0
+INN BO 33.4701 131.3062 215.0000 0.0
+ISI BO 34.0606 134.4554 27.0000 0.0
+IWT BO 35.9290 139.7349 6.0000 0.0
+IYG BO 40.1217 141.5833 427.0000 0.0
+IZH BO 34.1359 129.2066 386.0000 0.0
+JIZ BO 34.9167 138.9938 263.0000 0.0
+KFU BO 35.7426 138.5658 590.0000 0.0
+KGM BO 26.7567 128.2153 102.0000 0.0
+KIS BO 33.8651 135.8906 70.0000 0.0
+KMT BO 33.6782 135.4899 152.0000 0.0
+KMU BO 42.2391 142.9625 185.0000 0.0
+KNM BO 35.7168 137.1781 339.0000 0.0
+KNP BO 43.7625 143.7084 190.0000 0.0
+KNY BO 34.8738 138.0628 260.0000 0.0
+KSK BO 38.2585 140.5833 320.0000 0.0
+KSN BO 38.9762 141.5301 280.0000 0.0
+KSR BO 42.9820 144.4851 18.0000 0.0
+KYK BO 30.3781 130.4099 320.0000 0.0
+KZK BO 37.2977 138.5143 220.0000 0.0
+KZS BO 34.2056 139.1485 192.0000 0.0
+MMA BO 41.1619 140.4107 90.0000 0.0
+NAA BO 35.2239 137.3622 200.0000 0.0
+NKG BO 44.8017 142.0849 31.0000 0.0
+NMR BO 43.3673 145.7379 20.0000 0.0
+NOK BO 34.1656 135.3478 95.0000 0.0
+NOP BO 44.3218 142.9384 126.0000 0.0
+NRW BO 34.7682 133.5325 199.0000 0.0
+NSK BO 34.3403 132.0018 205.0000 0.0
+OHS BO 34.6858 138.0122 68.0000 0.0
+OKW BO 33.8272 133.4691 828.3300 0.0
+ONS BO 36.1557 138.9822 477.0000 0.0
+OSW BO 27.0983 142.1961 11.0000 0.0
+SAG BO 36.2553 133.3050 72.0000 0.0
+SBR BO 33.5052 130.2530 265.0000 0.0
+SBT BO 37.9683 139.4501 160.0000 0.0
+SGN BO 35.5096 138.9444 800.0000 0.0
+SHR BO 44.0563 144.9944 111.0000 0.0
+SIB BO 31.9698 130.3486 659.0000 0.0
+SMZ BO 34.9904 138.5136 0.0000 0.0
+SRN BO 36.2018 136.6303 473.0000 0.0
+STM BO 32.8870 129.7237 144.0000 0.0
+TAS BO 31.1946 130.9093 506.0000 0.0
+TGA BO 35.1846 136.3382 290.0000 0.0
+TGW BO 33.9734 132.9319 300.0000 0.0
+TKA BO 31.5160 130.7830 535.0000 0.0
+TKD BO 32.8176 131.3873 751.0000 0.0
+TKO BO 31.8931 131.2321 82.0000 0.0
+TMC BO 32.6063 130.9151 285.0000 0.0
+TMR BO 41.1016 141.3831 120.0000 0.0
+TNK BO 44.7779 142.0791 60.0000 0.0
+TNR BO 34.9111 137.8822 140.0000 0.0
+TSA BO 33.1781 132.8200 141.0000 0.0
+TSK BO 36.2141 140.0898 174.0000 0.0
+TTO BO 35.8363 138.1209 1150.0000 0.0
+TYM BO 34.9745 139.8449 30.0000 0.0
+TYS BO 39.3772 141.5932 346.0000 0.0
+UMJ BO 33.5795 134.0367 361.0000 0.0
+URH BO 42.9298 143.6711 75.0000 0.0
+WJM BO 37.4021 137.0257 201.0000 0.0
+WTR BO 34.3739 136.5748 95.0000 0.0
+YAS BO 35.6570 135.1605 232.0000 0.0
+YMZ BO 36.9267 140.2445 555.0000 0.0
+YNG BO 24.4550 123.0070 84.0000 0.0
+YSI BO 35.1942 132.8862 386.0000 0.0
+YTY BO 34.2835 131.0364 155.0000 0.0
+YZK BO 35.0888 134.4594 328.0000 0.0
+ZMM BO 26.2328 127.3038 22.0000 0.0
+AGMH Hinet 35.7839 137.7203 795.0000 103.0000
+AGWH Hinet 43.0822 140.8244 -70.0000 223.0000
+AHIH Hinet 38.2769 139.5519 -70.5000 107.5000
+AIOH Hinet 34.7903 134.4819 -135.0000 203.0000
+AIRH Hinet 31.7106 130.6172 -295.6000 305.0000
+AJSH Hinet 40.7592 140.3156 -110.0000 163.0000
+AKIH Hinet 33.4703 131.6881 -365.0000 403.0000
+AKNH Hinet 31.9906 130.2100 -161.2000 205.0000
+AKSH Hinet 35.4636 133.6333 -93.0000 210.0000
+AMAH Hinet 42.6461 141.8679 -143.0000 156.0000
+AMNH Hinet 35.6783 135.0296 -145.0000 153.0000
+AMZH Hinet 37.2194 136.9725 -49.0000 108.0000
+ANIH Hinet 39.9792 140.4106 45.0000 103.0000
+ANJH Hinet 34.9286 137.0597 -1050.0000 1085.0000
+ANNH Hinet 43.4336 144.0883 324.5000 109.5000
+ANSH Hinet 43.1117 144.1269 -75.0000 108.0000
+AOMH Hinet 40.8497 140.6794 -297.0000 310.0000
+ARIH Hinet 34.6879 137.5634 -444.0000 453.0000
+ARKH Hinet 38.1297 139.4322 -215.0000 224.0000
+ASAH Hinet 38.4675 139.7639 161.0000 107.0000
+ASBH Hinet 41.9833 140.3118 -16.0000 104.0000
+ASHH Hinet 35.2161 137.4069 420.4000 204.0000
+ASKH Hinet 32.2883 130.5800 -200.0000 303.0000
+ASNH Hinet 36.0909 137.3468 690.0000 103.0000
+ASRH Hinet 40.1364 140.9564 208.0000 103.0000
+ASSH Hinet 36.0184 137.3936 810.0000 103.0000
+ASUH Hinet 35.1359 137.3389 30.3000 122.7000
+ASVH Hinet 32.9481 131.0222 347.8000 130.2000
+ATDH Hinet 37.4478 139.8159 9.8000 271.0000
+ATGH Hinet 35.4007 139.3571 -1788.0000 1837.0000
+ATKH Hinet 37.7287 139.8855 229.6000 103.3000
+ATMH Hinet 34.6125 137.0449 -295.0000 303.0000
+AWNH Hinet 36.5478 139.6186 80.0000 103.0000
+AYEH Hinet 43.3797 143.9022 225.0000 106.0000
+AYKH Hinet 34.2153 133.9520 -27.0000 120.0000
+AYWH Hinet 43.2683 143.4356 -1.0000 203.0000
+BEEH Hinet 43.5014 142.6044 243.0000 210.0000
+BEWH Hinet 43.5089 142.3944 147.5000 170.5000
+BFEH Hinet 44.5486 142.5775 171.0000 115.0000
+BFNH Hinet 44.5950 142.3075 -50.0000 114.0000
+BFWH Hinet 44.4708 142.2764 0.0000 103.0000
+BHRH Hinet 43.7203 144.1875 -16.0000 106.0000
+BKEH Hinet 43.3953 145.1264 -186.0000 219.0000
+BKWH Hinet 43.3875 144.8061 -128.0000 223.0000
+BREH Hinet 42.7036 142.4092 120.0000 113.0000
+BRWH Hinet 42.7006 142.2333 -18.0000 103.0000
+BSEH Hinet 34.6724 133.5309 285.0000 103.0000
+BTOH Hinet 36.7311 140.1814 -5.0000 143.0000
+BZNH Hinet 33.5892 131.1372 -268.0000 306.0000
+CBAH Hinet 35.5425 140.2450 -1935.0000 2040.5000
+CCNH Hinet 42.9478 140.8261 140.0000 103.0000
+CH2H Hinet 35.7309 140.8263 -523.0000 528.0000
+CHKH Hinet 39.0689 140.3219 75.0000 203.0000
+CHNH Hinet 35.9433 138.1879 623.0000 250.0000
+CHZH Hinet 35.2572 134.2200 30.0000 203.0000
+CKRH Hinet 34.9674 139.9491 -697.8000 803.0000
+CRNH Hinet 31.3706 130.4356 19.1000 103.3000
+CTSH Hinet 42.8856 141.6436 -242.5000 255.5000
+CZEH Hinet 33.5047 129.8897 -82.0000 203.0000
+DGOH Hinet 36.8338 140.3215 10.0000 203.0000
+DMOH Hinet 36.7111 137.0408 -207.0000 215.0000
+DWAH Hinet 34.5450 132.9506 260.0000 103.0000
+EBTH Hinet 44.6336 141.8225 -189.0000 212.0000
+EDSH Hinet 35.9489 140.3334 -1197.0000 1234.0000
+EIHH Hinet 36.0925 136.3644 -30.0000 103.0000
+FBRH Hinet 43.2317 140.6264 -72.0000 103.0000
+FCHH Hinet 35.6507 139.4736 -2706.5000 2783.0000
+FGNH Hinet 43.8219 142.1632 98.0000 105.0000
+FGSH Hinet 43.6924 142.0814 -67.3000 150.3000
+FGTH Hinet 38.7078 140.3778 -99.0000 207.0000
+FJEH Hinet 34.9109 138.2038 -10.0000 103.0000
+FJIH Hinet 33.4065 130.2354 272.0000 106.0000
+FJOH Hinet 35.6404 139.1315 220.0000 103.0000
+FJWH Hinet 36.9833 139.6962 665.0000 0.0000
+FKCH Hinet 35.3101 135.1364 -260.0000 303.0000
+FKRH Hinet 34.7915 137.9064 -427.3000 453.0000
+FKSH Hinet 37.7613 140.3800 -165.0000 303.0000
+FKUH Hinet 40.7419 140.0272 -68.8000 111.8000
+FMIH Hinet 35.9125 138.3083 1032.3000 208.7000
+FRKH Hinet 36.2417 137.2013 471.6000 103.0000
+FRNH Hinet 43.3672 142.3447 96.0000 112.0000
+FSTH Hinet 40.3161 140.2375 -75.0000 203.0000
+FSWH Hinet 38.8625 141.3547 19.7000 103.3000
+FUTH Hinet 35.3412 139.8586 -1997.0000 2040.0000
+GEIH Hinet 34.7439 132.3819 612.0000 103.0000
+GENH Hinet 33.8469 130.5456 -175.0000 203.0000
+GHKH Hinet 33.7046 133.3667 490.0000 103.0000
+GJOH Hinet 39.9128 140.2256 -10.0000 103.0000
+GKSH Hinet 32.6502 131.2281 502.4000 105.6000
+GNOH Hinet 34.8194 136.4275 -122.0000 200.0000
+GOTH Hinet 35.0056 132.3094 0.0000 103.0000
+GR2H Hinet 35.7959 137.2561 227.3000 130.7000
+GZNH Hinet 36.5535 140.3046 -62.0000 110.0000
+HAGH Hinet 35.2161 134.5264 270.0000 103.0000
+HASH Hinet 35.8259 140.7355 -784.3000 805.0600
+HAZH Hinet 34.7852 137.1087 -391.0000 404.0000
+HBTH Hinet 43.1186 143.6219 -35.0000 103.0000
+HDKH Hinet 35.8958 139.3875 -1749.0000 1832.0000
+HGAH Hinet 36.5450 140.0783 -7.0000 115.0000
+HGIH Hinet 34.3947 131.3798 -95.0000 103.0000
+HH2H Hinet 35.6984 139.1306 260.0000 103.0000
+HHEH Hinet 40.5767 141.4487 -140.0000 153.0000
+HHIH Hinet 34.4540 132.7949 135.0000 103.0000
+HHNH Hinet 35.8605 139.2758 53.5000 104.5000
+HHRH Hinet 35.7353 139.0764 605.0000 0.0000
+HIKH Hinet 34.5693 132.0147 60.0000 203.0000
+HIMH Hinet 36.8836 136.9306 -170.0000 203.0000
+HINH Hinet 35.2281 133.3937 310.0000 103.0000
+HIRH Hinet 35.4228 132.8033 -170.0000 203.0000
+HISH Hinet 34.4089 132.3932 -50.0000 203.0000
+HIYH Hinet 33.3314 132.8005 30.0000 203.0000
+HKBH Hinet 34.9331 133.6232 118.1000 103.0000
+HKSH Hinet 32.8081 131.1033 381.0000 114.0000
+HKTH Hinet 35.2931 133.2630 69.0000 104.0000
+HMAH Hinet 35.2736 136.7031 -1503.2000 1538.2000
+HMMH Hinet 34.6650 137.7471 -990.7000 1025.6500
+HMNH Hinet 39.4531 141.0036 119.3000 103.7000
+HMSH Hinet 39.3406 141.0508 -50.2000 159.2000
+HMTH Hinet 37.0072 139.3788 774.1000 203.0000
+HNBH Hinet 45.0144 142.0833 -70.0000 103.0000
+HNKH Hinet 43.2058 145.1208 -224.0000 258.0000
+HNOH Hinet 34.9606 136.2639 120.0000 203.0000
+HNRH Hinet 39.1711 140.7164 180.0000 103.0000
+HNSH Hinet 34.7251 134.2771 -100.2000 106.0000
+HNZH Hinet 34.1340 135.5397 300.0000 103.0000
+HOBH Hinet 42.8689 142.1322 73.0000 105.0000
+HOCH Hinet 44.1136 142.1452 99.5000 103.5000
+HOFH Hinet 34.0461 131.5642 -165.0000 203.0000
+HOJH Hinet 35.6669 139.2682 63.0000 150.0000
+HONH Hinet 44.2780 142.1633 159.5000 103.5000
+HOSH Hinet 43.9970 142.1296 55.0000 103.0000
+HOTH Hinet 36.3793 137.8231 615.0000 108.0000
+HOUH Hinet 34.9969 137.6273 60.0000 103.0000
+HRDH Hinet 33.2083 129.4375 -177.0000 210.0000
+HRKH Hinet 33.9771 135.2150 -41.0000 104.0000
+HRMH Hinet 35.5508 139.6794 -535.7000 609.0000
+HRNH Hinet 36.4601 138.8563 980.0000 0.0000
+HRSH Hinet 34.5778 132.4320 210.0000 153.0000
+HRYH Hinet 35.3063 137.6292 859.0000 104.0000
+HSEH Hinet 35.7914 138.0855 720.0000 103.0000
+HSFH Hinet 33.3621 130.4069 -145.0000 203.0000
+HSKH Hinet 35.6369 137.3217 223.5000 109.5000
+HSMH Hinet 34.8665 132.6422 64.0000 104.0000
+HTAH Hinet 37.2139 140.5736 365.0000 108.0000
+HTBH Hinet 45.0978 142.4346 -143.0000 153.0000
+HTKH Hinet 36.3599 140.6231 -484.0000 507.0000
+HWSH Hinet 33.7717 134.5021 55.0000 103.0000
+HYGH Hinet 32.3619 131.5917 -30.0000 203.0000
+HYKH Hinet 35.4294 138.3356 234.9000 161.1000
+HYNH Hinet 35.5319 138.3118 588.0000 110.0000
+HYOH Hinet 32.2019 130.7394 -18.0000 126.0000
+HYSH Hinet 34.4250 136.0417 300.2000 104.0000
+IAMH Hinet 35.5698 134.3454 -137.0000 155.0000
+ICEH Hinet 38.9661 141.0047 17.5000 110.5000
+ICHH Hinet 35.4009 140.1768 -146.0000 180.1000
+ICWH Hinet 39.0061 140.8667 125.6000 263.4000
+IGWH Hinet 36.9347 137.8511 49.0000 103.0000
+IHEH Hinet 40.0783 141.1950 329.0000 303.0000
+IICH Hinet 36.7042 139.7733 80.0000 203.0000
+IKIH Hinet 40.6172 140.3533 -2.0000 165.0000
+IKKH Hinet 33.6439 133.1469 160.0000 103.0000
+IKNH Hinet 34.1858 132.1285 -115.0000 203.0000
+IKSH Hinet 36.4567 137.9668 384.5000 108.5000
+IKTH Hinet 33.4686 132.3097 -145.0000 153.0000
+IMIH Hinet 36.5706 136.9614 -54.6000 146.6000
+IMRH Hinet 33.2622 129.8819 -62.5000 105.5000
+INAH Hinet 37.1692 139.5231 471.7000 103.2000
+INEH Hinet 35.7072 135.2525 -172.0000 203.0000
+INHH Hinet 35.8283 137.9267 589.5000 183.5000
+INMH Hinet 33.8214 135.2200 -60.0000 103.0000
+INOH Hinet 33.5280 133.4414 -91.0000 104.0000
+INSH Hinet 34.8310 137.6646 -280.8000 303.0000
+INWH Hinet 37.6431 140.1768 656.6000 103.3000
+ISGH Hinet 36.1078 139.9919 -885.5000 903.5000
+ISSH Hinet 36.3111 139.1879 -1943.0000 2040.0000
+ITDH Hinet 35.7203 136.7876 250.0000 103.0000
+ITHH Hinet 34.9434 139.0887 -160.0000 303.0000
+IWAH Hinet 34.8769 132.4233 200.0000 103.0000
+IWEH Hinet 37.0233 140.9736 -144.0000 150.0000
+IWNH Hinet 38.1103 140.8475 -90.0000 103.0000
+IWSH Hinet 36.3672 140.1436 -43.0000 106.0000
+IWTH Hinet 35.9258 139.7381 -3502.3000 3510.5000
+IWWH Hinet 36.9919 140.5886 475.0000 108.0000
+IWZH Hinet 39.7994 141.6556 209.8000 103.2000
+IZMH Hinet 32.4867 130.9069 420.0000 103.0000
+IZSH Hinet 35.4543 134.8649 -86.6000 104.6000
+IZUH Hinet 35.9383 136.7019 310.0000 203.0000
+JHKH Hinet 36.4358 140.3592 -55.5000 108.5000
+JNSH Hinet 34.8193 133.1701 490.0000 103.0000
+JUOH Hinet 36.6890 140.5518 230.0000 103.0000
+KACH Hinet 35.3391 132.9014 -53.5000 103.0000
+KADH Hinet 35.9292 137.5980 1050.0000 103.0000
+KAHH Hinet 33.5479 130.7475 -40.0000 103.0000
+KAIH Hinet 41.8349 140.6367 -350.0000 363.0000
+KAKH Hinet 38.5131 141.3456 -202.1000 210.1000
+KAMH Hinet 35.0978 134.9064 50.0000 113.0000
+KANH Hinet 39.6414 141.6013 202.0000 106.0000
+KASH Hinet 39.4600 141.6806 452.0000 103.0000
+KAWH Hinet 34.2892 136.0050 257.0000 104.0000
+KAYH Hinet 35.6651 137.1084 335.0000 103.0000
+KDIH Hinet 31.8664 130.4981 -33.7000 110.0000
+KGIH Hinet 35.3027 137.0600 62.5000 103.0000
+KGNH Hinet 35.7518 137.9719 630.0000 0.0000
+KGRH Hinet 36.0832 140.3173 -490.0000 513.0000
+KGSH Hinet 39.1950 141.0153 49.9000 153.1000
+KHEH Hinet 40.1506 141.4281 265.0000 103.0000
+KHKH Hinet 33.1056 130.6972 -24.7000 103.0000
+KHOH Hinet 33.7611 135.9997 -10.0000 103.0000
+KHUH Hinet 33.6714 133.8269 90.0000 103.0000
+KHYH Hinet 42.4826 139.9714 55.0000 115.0000
+KIBH Hinet 36.8777 140.6578 297.8000 101.0000
+KIDH Hinet 35.2921 136.4761 -46.5000 139.5000
+KIGH Hinet 32.6938 131.6854 -190.3000 213.3000
+KIKH Hinet 34.1117 131.0530 -170.0000 203.0000
+KIWH Hinet 33.4621 130.8308 380.0000 103.0000
+KIYH Hinet 35.4595 139.2177 245.0000 213.0000
+KIZH Hinet 36.1478 139.0536 50.0000 103.0000
+KJNH Hinet 40.2658 141.7867 75.0000 103.0000
+KJSH Hinet 40.0833 141.7156 140.0000 103.0000
+KKAH Hinet 43.8522 142.7694 192.0000 151.0000
+KKCH Hinet 32.9950 130.8325 -22.0000 203.0000
+KKEH Hinet 33.2811 131.2142 300.0000 163.0000
+KKGH Hinet 34.8132 134.8106 -82.0000 103.0000
+KKIH Hinet 32.9519 129.8049 -97.0000 103.0000
+KKWH Hinet 38.9189 141.6422 -67.0000 120.0000
+KKYH Hinet 33.8817 130.9822 -185.0000 203.0000
+KMAH Hinet 37.6606 140.6008 105.0000 103.0000
+KMBH Hinet 42.7656 140.9803 185.0000 103.0000
+KMDH Hinet 36.4632 138.1505 292.0000 106.0000
+KMEH Hinet 35.0437 135.4874 75.0000 103.0000
+KMGH Hinet 34.8963 134.3311 -20.0000 103.0000
+KMHH Hinet 35.4089 136.8794 -65.5000 103.5000
+KMIH Hinet 39.2717 141.8267 -59.0000 106.0000
+KMKH Hinet 37.5408 139.3681 118.0000 103.0000
+KMNH Hinet 42.6081 140.4878 30.0000 103.0000
+KMOH Hinet 37.6497 139.0708 -70.0000 103.0000
+KMWH Hinet 35.1351 139.9681 -1842.8000 2032.7500
+KMYH Hinet 38.0783 140.3011 215.0000 103.0000
+KMZH Hinet 43.8542 144.4614 -94.5000 122.5000
+KNBH Hinet 34.5534 133.4205 -180.0000 203.0000
+KNEH Hinet 34.9365 138.0798 43.0000 105.0000
+KNGH Hinet 34.8807 132.2051 59.0000 204.0000
+KNHH Hinet 34.6595 135.3924 -2001.3000 2038.0000
+KNIH Hinet 35.0821 138.9810 -100.0000 203.0000
+KNNH Hinet 33.6594 134.3183 -103.0000 146.0000
+KNSH Hinet 33.8227 132.1064 -41.0000 109.0000
+KNZH Hinet 36.5119 136.6386 -699.5000 805.5000
+KOKH Hinet 36.3749 137.3746 810.0000 103.0000
+KORH Hinet 31.6953 130.4617 -71.9000 206.0000
+KOSH Hinet 40.4536 140.8431 300.0000 108.0000
+KOTH Hinet 35.6081 139.8157 -2994.0000 3030.0000
+KRHH Hinet 34.1129 132.5078 80.0000 103.0000
+KRIH Hinet 40.6064 140.6681 -3.5000 108.5000
+KRMH Hinet 40.2678 141.5744 140.0000 123.0000
+KRTH Hinet 34.3028 135.8397 286.0000 104.0000
+KRYH Hinet 37.3500 140.4297 60.0000 203.0000
+KSAH Hinet 34.6983 132.9550 235.0000 118.0000
+KSBH Hinet 35.2794 133.9290 295.0000 203.0000
+KSGH Hinet 35.4147 136.4376 310.0000 103.0000
+KSIH Hinet 35.5201 133.0252 -82.0000 105.0000
+KSMH Hinet 35.6177 134.6594 129.8000 103.2000
+KSOH Hinet 35.9600 137.7700 856.2000 106.8000
+KTDH Hinet 33.6861 135.4424 -78.2000 103.0000
+KTGH Hinet 33.5387 134.1224 35.0000 203.0000
+KTMH Hinet 32.0181 131.2924 -20.0000 103.0000
+KTNH Hinet 34.7597 135.7081 40.0000 203.0000
+KTRH Hinet 36.2462 137.5204 710.0000 103.0000
+KTWH Hinet 34.9105 132.9149 240.0000 103.0000
+KUCH Hinet 41.2313 140.9932 -80.0000 103.0000
+KUMH Hinet 42.1319 140.0075 -30.0000 103.0000
+KURH Hinet 34.2850 132.6436 128.0000 105.0000
+KWAH Hinet 39.6867 140.4125 65.0000 103.0000
+KWBH Hinet 33.4988 132.7505 90.0000 203.0000
+KWHH Hinet 35.3914 134.2015 -70.0000 103.0000
+KWKH Hinet 35.9703 138.5877 1075.0000 118.0000
+KWMH Hinet 32.2097 131.5333 -145.9000 216.9000
+KWNH Hinet 37.1697 138.7472 -40.0000 208.0000
+KWSH Hinet 38.1772 140.6439 44.0000 145.0000
+KWTH Hinet 36.1086 139.2994 -120.0000 203.0000
+KWZH Hinet 34.7798 138.9732 28.0000 210.0000
+KYAH Hinet 31.3969 130.8564 -61.0000 104.0000
+KYDH Hinet 33.8745 134.1321 439.0000 204.0000
+KYEH Hinet 36.8797 139.6492 499.0000 206.0000
+KYMH Hinet 43.0563 141.8100 -92.0000 125.0000
+KYOH Hinet 42.9733 140.6256 -180.3000 203.3000
+KYSH Hinet 35.2144 136.8539 -736.0000 739.0000
+KYWH Hinet 36.8786 139.4567 985.0000 103.0000
+KZMH Hinet 39.9369 141.5528 453.0000 120.0000
+KZNH Hinet 40.0594 140.8119 211.6000 111.4000
+MABH Hinet 34.6397 133.6888 -50.0000 103.0000
+MAKH Hinet 37.0514 138.3997 130.0000 103.0000
+MASH Hinet 34.5394 136.5061 -115.0000 153.0000
+MBEH Hinet 42.5908 142.3558 54.0000 109.0000
+MBUH Hinet 35.3476 138.4234 51.0000 207.0000
+MBWH Hinet 42.5101 142.0418 -210.0000 223.0000
+MCTH Hinet 34.7368 136.9415 -80.0000 103.0000
+MGMH Hinet 38.7103 140.5578 144.0000 112.0000
+MGWH Hinet 34.3547 136.3325 29.0000 103.0000
+MHRH Hinet 34.2904 134.7968 -37.0000 105.0000
+MHSH Hinet 35.5547 133.3031 -191.0000 203.0000
+MICH Hinet 34.3872 131.8950 149.0000 103.0000
+MIEH Hinet 32.9836 131.5905 59.0000 104.0000
+MIGH Hinet 34.5150 133.1401 -40.0000 203.0000
+MIHH Hinet 34.3704 133.0259 -170.3000 208.3000
+MIKH Hinet 35.5556 135.8722 -197.0000 203.0000
+MINH Hinet 35.1019 139.9908 160.0000 0.0000
+MITH Hinet 34.6908 132.0427 81.0000 212.0000
+MIZH Hinet 34.6715 138.8372 -49.0000 112.0000
+MJNH Hinet 31.8608 130.9478 424.0000 104.0000
+MJSH Hinet 31.7267 131.0814 35.0000 120.0000
+MKGH Hinet 36.8539 138.0997 1155.0000 153.0000
+MKIH Hinet 34.2668 134.1508 -50.0000 103.0000
+MKJH Hinet 37.4672 140.7261 410.0000 103.0000
+MKMH Hinet 35.4495 137.0070 -115.0000 203.0000
+MKOH Hinet 36.9394 138.2625 130.0000 113.0000
+MKRH Hinet 42.7606 140.8121 128.0000 103.0000
+MKWH Hinet 34.1941 131.9968 -132.0000 203.0000
+MMBH Hinet 43.9119 144.1953 -82.0000 125.0000
+MMKH Hinet 35.9664 138.4828 1114.0000 209.0000
+MMOH Hinet 36.2546 137.9929 540.0000 103.0000
+MMRH Hinet 42.8894 143.0642 -130.0000 230.0000
+MMTH Hinet 32.1669 130.3669 -95.0000 113.0000
+MNAH Hinet 36.0683 139.1024 43.0000 125.0000
+MNBH Hinet 36.1411 138.9174 895.0000 0.0000
+MNEH Hinet 34.1078 131.1458 -130.0000 203.0000
+MNKH Hinet 36.8384 139.0588 772.0000 0.0000
+MNMH Hinet 35.6633 136.9648 -30.0000 203.0000
+MNOH Hinet 34.1948 133.7107 -195.0000 203.0000
+MOKH Hinet 36.4461 139.9553 -1578.0000 1738.0000
+MORH Hinet 35.9419 140.0048 1.0000 20.0000
+MOTH Hinet 36.5535 140.2167 140.0000 0.0000
+MRMH Hinet 37.6628 139.2642 -31.5000 109.5000
+MROH Hinet 35.4665 134.5980 125.0000 103.0000
+MRRH Hinet 42.4091 141.0053 -162.0000 565.0000
+MRTH Hinet 32.5147 131.3373 150.0000 103.0000
+MRUH Hinet 37.4864 140.5414 310.0000 103.0000
+MS2H Hinet 35.2201 137.9212 438.0000 105.0000
+MSAH Hinet 43.2276 141.9016 -125.0000 203.0000
+MSFH Hinet 35.5591 138.4521 147.5000 150.5000
+MSIH Hinet 32.7933 130.8222 -197.0000 255.0000
+MSMH Hinet 32.6200 130.5608 -278.0000 303.0000
+MSNH Hinet 35.2953 137.9298 328.5000 104.5000
+MSTH Hinet 36.2510 137.8622 418.0000 253.0000
+MTDH Hinet 35.3631 139.1291 359.5000 108.5000
+MTKH Hinet 35.6120 137.8827 608.0000 110.0000
+MTMH Hinet 34.4805 131.6353 165.0000 203.0000
+MTOH Hinet 34.2143 131.3621 48.0000 105.0000
+MUIH Hinet 37.0503 138.9983 258.0000 103.0000
+MURH Hinet 33.2832 134.1629 -210.0000 303.0000
+MYJH Hinet 31.9778 130.4461 10.1000 103.0000
+MYKH Hinet 34.1886 133.0607 -95.0000 103.0000
+MYMH Hinet 35.2653 135.5536 90.0000 103.0000
+MZEH Hinet 35.8960 137.1525 463.0000 110.0000
+MZKH Hinet 35.3522 133.4944 220.0000 203.0000
+NAGH Hinet 34.3194 135.4511 448.0000 115.0000
+NAKH Hinet 33.0719 132.9550 -69.0000 103.0000
+NANH Hinet 32.3436 131.2692 253.0000 103.0000
+NAWH Hinet 44.6594 142.0567 -40.0000 108.0000
+NAZH Hinet 37.7535 139.7183 337.7000 103.0000
+NCNH Hinet 31.5614 131.3533 -196.0000 204.0000
+NCPH Hinet 42.5951 142.5483 205.0000 103.0000
+NDGH Hinet 35.5211 135.1271 -140.0000 158.0000
+NEOH Hinet 35.6294 136.6164 70.0000 103.0000
+NFRH Hinet 43.3817 142.5283 239.0000 153.0000
+NGIH Hinet 35.6024 137.6135 328.0000 105.0000
+NGKH Hinet 35.1810 137.0504 -147.0000 210.0000
+NGOH Hinet 37.4242 138.8908 -15.0000 103.0000
+NGRH Hinet 35.9086 139.1517 238.0000 105.0000
+NGSH Hinet 32.6965 129.8647 -45.0000 203.0000
+NGTH Hinet 34.3376 131.1794 -158.0000 203.0000
+NGUH Hinet 37.1585 140.0963 364.4000 203.5000
+NGWH Hinet 36.0609 137.6880 994.0000 104.0000
+NHEH Hinet 40.2356 141.3458 29.8000 203.2000
+NHJH Hinet 40.8537 141.1069 -267.0000 315.0000
+NHWH Hinet 40.2583 141.1744 125.0000 103.0000
+NITH Hinet 35.2203 133.0882 239.0000 104.0000
+NJMH Hinet 34.4202 139.2860 20.0000 0.0000
+NKEH Hinet 38.4228 140.1283 205.0000 103.0000
+NKMH Hinet 34.1281 135.3272 19.9000 103.1000
+NKNH Hinet 36.7403 138.3792 178.0000 203.0000
+NKOH Hinet 35.0639 134.4261 102.0000 106.0000
+NKTH Hinet 33.6038 135.8648 -70.0000 103.0000
+NKWH Hinet 38.3831 139.9950 362.0000 106.0000
+NMEH Hinet 37.4881 140.9906 -97.0000 112.0000
+NMKH Hinet 34.3753 133.3519 -175.0000 203.0000
+NMNH Hinet 32.9519 131.2231 593.0000 103.0000
+NMTH Hinet 36.3622 140.5838 -74.3000 100.3000
+NNMH Hinet 37.2792 140.2178 238.0000 108.0000
+NOBH Hinet 32.5026 131.6982 -98.0000 103.0000
+NRAH Hinet 32.1953 131.1969 135.0000 103.0000
+NRKH Hinet 38.8558 140.6547 142.0000 206.0000
+NRTH Hinet 35.8275 140.3013 -1288.0000 1336.0000
+NS2H Hinet 34.7954 138.7755 27.0000 106.0000
+NSBH Hinet 39.5422 140.3506 -129.0000 157.0000
+NSEH Hinet 39.5547 140.6150 -82.0000 180.0000
+NSHH Hinet 35.6863 138.7371 -831.0000 1245.0000
+NSMH Hinet 32.1519 130.1214 -187.1000 205.0000
+NSNH Hinet 39.8119 140.5825 218.0000 103.0000
+NSSH Hinet 39.6606 140.5756 -5.0000 103.0000
+NSTH Hinet 43.5483 144.9706 -197.5000 230.5000
+NTBH Hinet 44.9364 142.2286 -60.0000 103.0000
+NTGH Hinet 35.4539 137.4737 39.5000 403.5000
+NTHH Hinet 33.1492 131.5444 60.0000 103.0000
+NUKH Hinet 34.9157 137.3023 -10.0000 103.0000
+NUMH Hinet 43.8179 141.9435 -5.0000 108.0000
+NWAH Hinet 40.4465 141.3409 -49.1000 117.1000
+NYAH Hinet 40.5461 140.2761 58.0000 103.0000
+NYOH Hinet 38.1006 140.1586 164.0000 117.0000
+NYRH Hinet 44.4353 142.4094 -16.0000 103.0000
+NZWH Hinet 36.9072 138.4439 460.0000 113.0000
+OBMH Hinet 35.4542 135.7294 -61.5000 107.5000
+ODTH Hinet 40.2975 140.5847 -15.0000 103.0000
+ODWH Hinet 35.2491 139.1074 192.0000 98.0000
+OGAH Hinet 39.9522 139.7653 -294.0000 353.0000
+OGCH Hinet 38.9772 140.4986 185.0000 103.0000
+OGNH Hinet 33.1186 131.0653 306.5000 126.5500
+OGOH Hinet 36.0243 138.9722 195.0000 103.0000
+OHAH Hinet 35.0967 134.3217 79.5000 203.5000
+OHCH Hinet 34.2231 134.3069 -70.0000 108.0000
+OHRH Hinet 36.3568 139.6907 105.0000 0.0000
+OHTH Hinet 42.6451 141.0679 150.0000 203.0000
+OIWH Hinet 42.8714 141.8228 -40.6000 103.6000
+OKCH Hinet 36.2636 136.7197 454.5000 108.5000
+OKEH Hinet 43.6328 143.5139 192.0000 103.0000
+OKMH Hinet 34.2058 132.4088 -60.0000 103.0000
+OKYH Hinet 34.7751 133.7917 -101.3000 204.3000
+OKZH Hinet 34.9603 137.2406 100.0000 103.0000
+OM2H Hinet 36.5296 137.8231 719.5000 108.5000
+OMMH Hinet 36.4971 139.3212 463.0000 0.0000
+OMRH Hinet 39.3519 140.3886 -35.0000 103.0000
+ONDH Hinet 38.5764 140.7839 -278.0000 340.0000
+ONIH Hinet 37.9853 139.8050 173.0000 110.0000
+ONPH Hinet 44.7722 142.2581 -36.0000 109.0000
+OOCH Hinet 35.0886 132.5333 139.0000 104.0000
+OOKH Hinet 35.6215 138.9808 265.0000 203.0000
+OOMH Hinet 41.5246 140.9163 -90.0000 103.0000
+OOTH Hinet 32.8380 132.7091 -45.0000 103.0000
+OOZH Hinet 33.5780 132.6024 100.0000 103.0000
+OPEH Hinet 44.3819 143.2446 -70.0000 103.0000
+OPWH Hinet 44.4210 143.0304 -75.0000 116.0000
+OREH Hinet 44.0953 141.9658 2.0000 103.0000
+ORWH Hinet 44.0231 141.7914 -84.0000 108.0000
+OSUH Hinet 31.5583 130.9992 -53.6000 153.5000
+OTAH Hinet 35.9450 136.0586 20.0000 103.0000
+OTOH Hinet 33.6915 135.5981 118.0000 103.0000
+OTUH Hinet 35.2450 135.8700 205.0000 103.0000
+OTWH Hinet 36.8547 140.0258 71.0000 135.0000
+OUMH Hinet 44.5253 142.8483 5.0000 103.0000
+OWNH Hinet 40.4814 140.5600 30.0000 103.0000
+OWSH Hinet 34.0606 136.1717 -15.0000 103.0000
+OYMH Hinet 34.7629 136.2864 80.0000 203.0000
+RBSH Hinet 43.7394 143.4553 216.0000 108.0000
+RKBH Hinet 43.4658 143.6869 128.5000 125.5000
+RKSH Hinet 40.9638 141.3774 -95.0000 103.0000
+RNKH Hinet 42.8285 140.4867 -91.0000 133.0000
+RZTH Hinet 39.0278 141.5356 -20.0000 103.0000
+SADH Hinet 34.0079 134.0945 90.0000 103.0000
+SAIH Hinet 41.4023 140.8603 -170.0000 203.0000
+SAKH Hinet 36.1393 138.5535 760.0000 103.0000
+SAMH Hinet 42.1304 142.9201 -61.0000 104.0000
+SATH Hinet 31.0861 130.7011 -113.1000 203.0000
+SBAH Hinet 32.4719 131.1067 319.0000 203.0000
+SBKH Hinet 35.1995 138.5690 -224.0000 307.0000
+SBNH Hinet 33.2089 129.7675 28.0000 115.0000
+SBSH Hinet 33.1222 129.8125 -190.0000 203.0000
+SCNH Hinet 43.3822 144.6319 -24.0000 110.0000
+SCSH Hinet 43.2114 144.6844 -210.0000 243.0000
+SDAH Hinet 35.2212 132.7249 9.0000 104.0000
+SDMH Hinet 35.8643 138.5770 1270.4000 108.1000
+SDWH Hinet 32.0173 131.4724 -200.3000 215.3000
+SENH Hinet 31.8339 130.3625 -86.6000 103.5000
+SETH Hinet 34.7468 134.0728 -170.0000 203.0000
+SFNH Hinet 45.3324 142.1224 -80.0000 103.0000
+SFSH Hinet 45.2141 142.2293 -95.0000 103.0000
+SGOH Hinet 35.0461 133.3196 463.5000 103.0000
+SGRH Hinet 34.8497 136.0344 160.0000 203.0000
+SGUH Hinet 34.9281 134.5450 -30.0000 103.0000
+SGWH Hinet 33.5260 130.9526 270.0000 103.0000
+SHGH Hinet 40.4597 141.0958 165.0000 153.0000
+SHJH Hinet 35.4924 138.6117 950.0000 0.0000
+SHKH Hinet 37.0503 136.8236 -180.5000 203.4500
+SHMH Hinet 35.7934 140.0238 -2277.2000 2330.0000
+SHZH Hinet 42.8717 142.8868 319.0000 103.0000
+SIKH Hinet 32.9244 131.8719 -20.0000 103.0000
+SINH Hinet 33.9121 133.6523 204.5000 103.5000
+SISH Hinet 38.0061 140.6061 30.0000 103.0000
+SJOH Hinet 33.8617 133.1866 -35.0000 113.0000
+SKGH Hinet 35.3618 133.7513 35.0000 103.0000
+SKIH Hinet 34.3903 132.1636 250.0000 103.0000
+SKNH Hinet 43.3313 142.9486 265.0000 103.0000
+SKSH Hinet 43.1714 142.9214 48.0000 175.0000
+SKUH Hinet 35.6001 136.4164 154.0000 109.0000
+SKWH Hinet 38.1283 139.5461 -22.0000 103.0000
+SMAH Hinet 34.2514 136.8244 -197.0000 210.0000
+SMGH Hinet 37.2513 139.8758 390.5000 108.0000
+SMMH Hinet 42.7772 140.1593 -68.0000 103.0000
+SMNH Hinet 36.2325 138.7322 240.0000 103.0000
+SMPH Hinet 43.0381 142.6600 469.0000 103.0000
+SMSH Hinet 34.9706 138.4955 -219.0000 242.0000
+SMTH Hinet 39.1781 141.3944 514.0000 109.0000
+SNDH Hinet 38.2370 141.0003 -1204.0000 1236.0000
+SNIH Hinet 33.1272 131.3497 270.5000 232.5000
+SNNH Hinet 43.1578 143.8975 74.0000 103.0000
+SNSH Hinet 42.9831 143.9881 -73.0000 103.0000
+SNTH Hinet 35.2894 134.9098 -20.0000 203.0000
+SNWH Hinet 32.3117 130.1833 -142.0000 303.0000
+SOIH Hinet 42.5604 141.3533 -157.0000 180.0000
+SOJH Hinet 36.1153 137.9419 502.5000 220.5000
+SONH Hinet 35.3038 138.2003 778.0000 105.0000
+SOSH Hinet 35.0113 138.3557 -52.0000 105.0000
+SRIH Hinet 33.1772 130.1069 -185.0000 206.0000
+SRMH Hinet 44.0789 143.9494 -295.0000 303.0000
+SROH Hinet 37.9731 139.2819 -138.0000 150.0000
+SRUH Hinet 41.5951 140.4243 -145.0000 153.0000
+SRWH Hinet 36.2712 136.9009 326.8000 156.2000
+SSKH Hinet 33.3886 133.2892 -99.0000 107.0000
+SSMH Hinet 33.5525 135.5482 30.0000 103.0000
+SSRH Hinet 34.8943 137.4906 -45.0000 103.0000
+SSSH Hinet 36.5739 138.0510 403.0000 105.0000
+SSTH Hinet 43.2179 141.6561 -117.0000 130.0000
+SSWH Hinet 36.1056 138.1328 987.2000 103.0000
+SSYH Hinet 35.0676 135.2839 117.9000 103.0000
+ST1H Hinet 34.5922 139.9215 -2197.0000 0.0000
+ST2H Hinet 34.7363 139.8425 -2339.0000 0.0000
+ST3H Hinet 34.7950 139.6467 -902.0000 0.0000
+ST4H Hinet 34.8898 139.5743 -933.0000 0.0000
+ST5H Hinet 34.9380 139.4245 -1486.0000 0.0000
+ST6H Hinet 35.0933 139.3810 -1130.0000 0.0000
+STDH Hinet 37.5356 139.1311 -7.0000 103.0000
+STKH Hinet 43.8469 143.0900 572.0000 130.0000
+STNH Hinet 43.7825 145.0286 -30.5000 113.5000
+STRH Hinet 35.1511 137.5380 554.0000 104.0000
+STSH Hinet 43.6747 144.9658 62.0000 106.0000
+SUGH Hinet 43.5114 141.9128 -92.0000 125.0000
+SUKH Hinet 32.0386 131.0642 235.0000 103.0000
+SUZH Hinet 37.5236 137.2875 -152.5000 203.5000
+SWEH Hinet 44.3183 142.7694 100.0000 103.0000
+SWWH Hinet 44.2897 142.6342 -140.0000 303.0000
+SYKH Hinet 36.0622 136.9508 739.0000 103.0000
+SYNH Hinet 44.0619 144.9975 -40.0000 108.0000
+SYOH Hinet 35.0700 134.1189 -71.5000 203.5000
+SYSH Hinet 43.9247 144.8114 -117.0000 160.0000
+SYTH Hinet 34.0237 132.0651 75.0000 103.0000
+SZGH Hinet 38.6386 141.4463 -84.5000 105.5000
+SZJH Hinet 34.9723 138.9159 47.0000 206.0000
+SZKH Hinet 39.6408 140.9500 62.0000 153.0000
+SZNH Hinet 42.3472 142.3609 -105.0000 118.0000
+SZUH Hinet 35.1271 138.4273 421.5000 121.5000
+SZWH Hinet 37.0272 138.8553 -202.0000 390.0000
+TAGH Hinet 35.2353 136.3629 510.0000 103.0000
+TAJH Hinet 38.5878 141.0744 -80.0000 103.0000
+TAKH Hinet 32.9692 131.4008 156.9000 106.1000
+TAMH Hinet 34.5037 133.8931 -190.6000 203.5500
+TARH Hinet 33.3644 130.6378 -422.0000 440.0000
+TAYH Hinet 36.6181 138.9100 345.0000 113.0000
+TBEH Hinet 33.7079 132.8057 6.0000 137.0000
+TBRH Hinet 33.8990 133.0684 -185.0000 203.0000
+TBTH Hinet 36.7350 136.7936 19.0000 103.0000
+TBYH Hinet 36.2409 139.5476 -1183.0000 1233.0000
+TCKH Hinet 38.6328 140.0089 117.0000 206.0000
+TDEH Hinet 34.9479 137.4144 445.0000 103.0000
+TDMH Hinet 37.3392 139.3179 175.0000 203.0000
+TDOH Hinet 38.3811 140.3839 -94.0000 210.0000
+TGIH Hinet 37.1872 136.7206 -60.5000 119.5000
+TGKH Hinet 36.7044 138.0995 815.0000 123.0000
+TGOH Hinet 32.3572 131.4667 0.0000 103.0000
+TGUH Hinet 34.5684 132.2351 163.0000 105.0000
+THGH Hinet 36.7924 140.5784 405.0000 103.0000
+THNH Hinet 34.7821 137.4423 -170.0000 203.0000
+THTH Hinet 37.9603 140.1869 88.0000 148.0000
+TISH Hinet 34.5215 135.6636 29.0000 103.0000
+TJOH Hinet 34.9050 135.0872 40.0000 103.0000
+TJRH Hinet 34.3944 135.2864 -1500.0000 1535.0000
+TKBH Hinet 34.8652 133.8554 220.0000 103.0000
+TKEH Hinet 33.9658 135.8603 380.0000 103.0000
+TKGH Hinet 35.5111 137.8797 299.0000 127.0000
+TKHH Hinet 35.4875 135.4869 60.0000 103.0000
+TKIH Hinet 42.4847 143.1564 260.0000 103.0000
+TKJH Hinet 34.2058 131.6883 -80.0000 203.0000
+TKKH Hinet 32.9069 130.1431 -171.0000 203.0000
+TKNH Hinet 34.8854 136.8792 -351.0000 404.0000
+TKRH Hinet 35.7996 139.5385 -1970.0000 2034.0000
+TKSH Hinet 36.2828 138.2522 505.0000 103.0000
+TKTH Hinet 35.5006 136.7969 -162.7000 204.7000
+TKUH Hinet 33.9692 131.8174 -10.0000 113.0000
+TKWH Hinet 33.9633 135.6536 700.0000 103.0000
+TMAH Hinet 36.1306 137.2238 520.5000 107.5000
+TMGH Hinet 34.6225 131.6706 -90.0000 103.0000
+TMNH Hinet 32.9839 130.5632 -45.0000 103.0000
+TMOH Hinet 36.2831 138.9242 -49.0000 203.0000
+TMYH Hinet 39.8222 141.3861 572.5000 105.5000
+TNEH Hinet 36.6967 139.2136 446.0000 203.0000
+TNMH Hinet 35.5183 136.6156 -27.5000 105.5000
+TOBH Hinet 43.4063 141.5873 -120.0000 203.0000
+TOGH Hinet 36.4375 137.0422 570.0000 103.0000
+TOHH Hinet 33.9258 132.4071 -95.0000 103.0000
+TOIH Hinet 35.9933 139.2223 78.5000 104.5000
+TOKH Hinet 33.9869 134.5364 -90.0000 103.0000
+TOMH Hinet 43.0503 140.5053 -75.0000 103.0000
+TOUH Hinet 39.3311 141.3050 160.0000 103.0000
+TOWH Hinet 38.7831 141.3289 -65.0000 103.0000
+TOYH Hinet 36.7264 137.2656 -572.5000 583.5000
+TREH Hinet 43.2175 144.4325 -207.0000 240.0000
+TRGH Hinet 35.6361 136.0333 -112.0000 125.0000
+TRIH Hinet 34.5811 135.8569 30.0000 103.0000
+TROH Hinet 39.7406 141.9125 100.0000 103.0000
+TRSH Hinet 43.1333 144.3314 -184.0000 225.0000
+TRUH Hinet 35.5105 138.9439 567.6000 160.0000
+TRWH Hinet 43.2531 144.2378 -216.1000 333.1000
+TSMH Hinet 33.0522 132.5577 275.0000 103.0000
+TSOH Hinet 44.8925 141.9289 -97.0000 110.0000
+TSRH Hinet 40.2728 140.4631 -56.0000 104.0000
+TSSH Hinet 32.7763 132.9743 -95.0000 103.0000
+TSTH Hinet 37.6048 139.7566 98.0000 130.0000
+TSUH Hinet 35.9483 136.8762 510.0000 103.0000
+TSYH Hinet 33.2649 132.9916 170.0000 103.0000
+TT2H Hinet 35.0053 137.8439 222.0000 106.0000
+TTAH Hinet 34.9071 133.4081 330.0000 103.0000
+TTKH Hinet 40.2934 141.0180 135.0000 103.0000
+TTNH Hinet 36.0056 137.9336 720.0000 103.0000
+TU2H Hinet 35.5082 138.9707 760.0000 253.0000
+TUMH Hinet 36.4886 138.5275 890.0000 153.0000
+TUNH Hinet 44.1896 143.0806 -66.0000 203.0000
+TURH Hinet 42.6390 140.6686 111.5000 105.5000
+TUSH Hinet 44.1123 143.0149 149.0000 109.0000
+TWAH Hinet 37.6678 139.4681 -232.0000 303.0000
+TWEH Hinet 40.5819 141.1582 -15.0000 103.0000
+TWWH Hinet 40.5773 140.9986 140.0000 103.0000
+TY2H Hinet 34.9558 139.7917 -470.0000 503.0000
+TYEH Hinet 35.1808 137.7298 654.0000 104.0000
+TYHH Hinet 34.6610 137.3932 -300.0000 363.0000
+TYMH Hinet 34.9713 139.8483 60.0000 0.0000
+TYNH Hinet 32.6311 130.7544 -40.0000 113.0000
+TYOH Hinet 36.1156 140.5655 -1160.0000 1230.0000
+TYRH Hinet 42.8089 143.5242 -91.2000 103.0000
+TYTH Hinet 45.0997 141.7872 -120.0000 138.0000
+TYUH Hinet 34.1316 130.9347 -156.0000 204.0000
+TZWH Hinet 38.7469 140.1814 -135.0000 203.0000
+UBEH Hinet 33.9860 131.3036 -120.0000 203.0000
+UCNH Hinet 31.2547 131.0900 115.0000 153.0000
+UCUH Hinet 37.3428 137.2467 -188.0000 210.0000
+UJEH Hinet 36.6928 139.9875 42.0000 123.0000
+UKHH Hinet 33.2858 130.8194 -10.0000 203.0000
+UMEH Hinet 32.8452 131.6810 90.0000 103.0000
+UMIH Hinet 33.5575 130.5522 85.0000 103.0000
+UMWH Hinet 32.8357 131.5380 159.0000 104.0000
+UMYH Hinet 36.5564 139.8669 -175.0000 303.0000
+UNNH Hinet 44.8547 142.4907 -80.0000 103.0000
+UNSH Hinet 44.7410 142.6078 -27.0000 103.0000
+UOZH Hinet 36.7883 137.4719 54.0000 103.0000
+URSH Hinet 34.5438 136.3721 179.6000 103.4000
+USDH Hinet 36.1813 138.5642 970.0000 0.0000
+UWAH Hinet 33.4236 132.5080 100.0000 153.0000
+UWEH Hinet 32.2175 130.9119 -2.0000 180.0000
+WATH Hinet 34.3499 136.5895 -22.0000 115.0000
+WKMH Hinet 33.6931 130.5986 -25.8000 103.0000
+WKYH Hinet 34.2833 135.0744 -195.0000 203.0000
+WNEH Hinet 45.2281 141.8844 -173.0000 206.0000
+WNNH Hinet 45.4861 141.8889 -157.5000 205.5000
+WNWH Hinet 45.2508 141.6372 -129.0000 140.0000
+WSMH Hinet 43.9731 142.2872 90.0000 108.0000
+YABH Hinet 32.6467 131.0275 347.0000 106.0000
+YBKH Hinet 37.1976 140.3420 170.5000 118.2000
+YBNH Hinet 44.2122 143.6242 -93.0000 103.0000
+YBRH Hinet 35.1777 133.6792 305.0000 103.0000
+YFTH Hinet 35.3675 139.6289 -76.5000 116.5000
+YGDH Hinet 37.3617 137.0442 19.0000 105.0000
+YGNH Hinet 33.4089 131.0350 49.0000 203.0000
+YGTH Hinet 38.2664 140.2617 -20.0000 153.0000
+YHBH Hinet 39.6119 141.0964 73.0000 125.0000
+YITH Hinet 36.8594 139.8397 461.0000 106.0000
+YJMH Hinet 39.2194 140.1317 42.0000 106.0000
+YKHH Hinet 35.4959 139.5227 -1938.0000 2045.0000
+YKIH Hinet 35.7185 140.5088 -142.1000 180.6000
+YKWH Hinet 31.2031 130.6206 -122.6000 206.3000
+YM2H Hinet 35.4140 139.0468 230.0000 103.0000
+YMAH Hinet 36.6374 140.4009 -210.0000 303.0000
+YMDH Hinet 39.4706 141.9372 -87.0000 103.0000
+YMGH Hinet 33.4547 131.4453 65.0000 103.0000
+YMIH Hinet 36.0477 139.4396 -51.6000 104.1000
+YMMH Hinet 37.9381 140.8958 -187.0000 208.0000
+YMSH Hinet 35.0278 134.6736 66.0000 103.0000
+YMTH Hinet 35.8291 136.9651 415.0000 103.0000
+YNDH Hinet 33.5354 133.0042 355.0000 103.0000
+YNTH Hinet 37.2208 138.9853 0.0000 113.0000
+YNZH Hinet 37.8931 140.0311 152.0000 203.0000
+YOKH Hinet 34.9817 136.4592 150.0000 143.0000
+YOTH Hinet 35.4833 137.2494 463.0000 103.0000
+YROH Hinet 35.2834 140.1562 -1920.0000 2034.0000
+YSDH Hinet 35.1603 132.8583 279.2000 103.8000
+YSHH Hinet 34.6597 132.6715 180.0000 103.0000
+YSKH Hinet 35.2077 139.6996 -189.3000 216.0000
+YTOH Hinet 36.5681 137.1625 -90.0000 203.0000
+YUBH Hinet 42.9905 142.0123 -5.0000 203.0000
+YUZH Hinet 39.1883 140.4744 -105.0000 183.0000
+YWTH Hinet 38.9672 140.0367 8.7000 109.3000
+YZEH Hinet 34.6381 136.0540 175.6000 104.0000
+YZWH Hinet 36.8083 138.7881 885.0000 103.0000
+MAJO AS 36.5409 138.2083 431.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
+MDJ CD 44.6164 129.5919 250.0 0.0
+SSE CD 31.0956 121.1867 15.0 0.0
+INU G 35.3500 137.0290 132.0 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
+MDJ IC 44.6164 129.5919 250.0 0.0
+SSE IC 31.0951 121.1859 15.0 0.0
+XAN IC 34.0313 108.9237 630.0 0.0
+ERM II 42.0150 143.1572 40.0 0.0
+YSS IU 46.9583 142.7610 100.0 0.0
+TATO IU 24.9754 121.4881 53.0 0.0
+TATO SR 24.9754 121.4881 53.0 0.0
+INCN IU 37.4833 126.6333 420.0 0.0
+MAJO IU 36.5425 138.2073 405.0 0.0
+OGS PS 27.0570 142.2030 20.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
+BJI GB 40.0403 116.1750 0.0 0.0
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_SEBASTIEN
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_SEBASTIEN (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_SEBASTIEN 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,79 @@
+SA01 XS -34.294456 019.245956 220.0 0.
+SA02 XS -33.735100 020.266300 500.0 0.
+SA03 XS -33.661900 021.335400 500.0 0.
+SA04 XS -32.850500 019.620600 1200.0 0.
+SA05 XS -32.605000 021.534600 800.0 0.
+SA07 XS -31.977606 020.226201 1277.0 0.
+SA08 XS -31.910296 022.072947 1387.0 0.
+SA09 XS -30.922100 022.986100 1200.0 0.
+SA10 XS -30.972400 023.913600 1400.0 0.
+SA11 XS -29.965032 020.946637 1066.0 0.
+SA12 XS -29.848603 022.253285 1125.0 0.
+SA13 XS -29.978840 023.139586 1047.0 0.
+SA139 XS -25.851900 026.266200 1600.0 0.
+SA14 XS -29.868200 024.022600 1200.0 0.
+SA15 XS -29.903800 025.032300 1400.0 0.
+SA155 XS -22.878600 028.340200 900.0 0.
+SA16 XS -28.950316 022.195118 1026.0 0.
+SA169 XS -22.262315 029.213375 618.0 0.
+SA17 XS -28.932072 023.225711 1249.0 0.
+SA18 XS -28.632814 024.305628 1102.0 0.
+SA19 XS -28.905600 024.832800 1200.0 0.
+SA20 XS -29.022100 026.195300 1400.0 0.
+SA22 XS -27.966232 022.009117 1076.0 0.
+SA23 XS -27.930432 023.404610 1612.0 0.
+SA24 XS -27.883287 024.236487 1244.0 0.
+SA25 XS -27.845870 025.125923 1253.0 0.
+SA26 XS -27.545600 026.180300 1300.0 0.
+SA27 XS -27.862500 027.294300 1400.0 0.
+SA28 XS -27.898200 028.065600 1600.0 0.
+SA29 XS -26.931737 023.034920 1120.0 0.
+SA30 XS -27.071478 024.165050 1361.0 0.
+SA31 XS -26.995173 025.020914 1348.0 0.
+SA32 XS -26.865464 026.284484 1380.0 0.
+SA33 XS -26.898600 027.179300 1400.0 0.
+SA34 XS -26.800000 028.100000 1500.0 0.
+SA35 XS -27.018300 029.088300 1600.0 0.
+SA36 XS -26.877100 030.124900 1600.0 0.
+SA37 XS -25.970525 023.721191 1142.0 0.
+SA38 XS -25.933360 025.084628 1219.0 0.
+SA39 XS -25.895184 026.151431 1545.0 0.
+SA40 XS -25.898102 027.149003 1512.0 0.
+SA42 XS -25.665000 029.222300 1500.0 0.
+SA44 XS -26.032120 030.902200 1000.0 0.
+SA45 XS -24.879187 026.164376 1015.0 0.
+SA46 XS -24.838175 027.109197 1037.0 0.
+SA47 XS -24.846870 028.161824 1153.0 0.
+SA48 XS -24.894800 029.216300 1000.0 0.
+SA50 XS -23.872155 027.166184 976.0 0.
+SA51 XS -23.862775 028.156664 1233.0 0.
+SA52 XS -23.798342 028.897467 1321.0 0.
+SA53 XS -24.113400 029.332800 1300.0 0.
+SA54 XS -23.728800 030.668000 500.0 0.
+SA55 XS -22.979977 028.298102 918.0 0.
+SA56 XS -23.005909 029.074292 909.0 0.
+SA57 XS -22.981102 030.020153 787.0 0.
+SA59 XS -24.837265 024.464044 1137.0 0.
+SA60 XS -23.851930 024.959381 1043.0 0.
+SA61 XS -23.948131 024.022049 1069.0 0.
+SA62 XS -24.850534 025.134964 1214.0 0.
+SA63 XS -23.658299 026.081958 1008.0 0.
+SA64 XS -22.969449 026.201713 1151.0 0.
+SA65 XS -22.818254 027.221759 907.0 0.
+SA66 XS -21.900455 026.372742 1057.0 0.
+SA67 XS -21.885896 027.273599 913.0 0.
+SA68 XS -21.950409 028.187833 737.0 0.
+SA69 XS -22.304753 029.266073 651.0 0.
+SA70 XS -21.088251 026.335168 990.0 0.
+SA71 XS -20.925778 027.140787 1072.0 0.
+SA72 XS -20.142962 028.611309 1337.0 0.
+SA73 XS -21.853669 030.277610 590.0 0.
+SA74 XS -21.923031 030.935691 487.0 0.
+SA75 XS -20.860109 028.999072 971.0 0.
+SA76 XS -20.636092 029.846441 978.0 0.
+SA77 XS -20.755746 030.919113 576.0 0.
+SA78 XS -19.467072 030.772272 1401.0 0.
+SA79 XS -20.021103 030.517333 1078.0 0.
+SA80 XS -19.959257 031.317909 1064.0 0.
+SA81 XS -30.925116 021.268124 1270.0 0.
+SA82 XS -30.977112 022.246614 1452.0 0.
Property changes on: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_SEBASTIEN
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_SUBSET_35
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_SUBSET_35 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_SUBSET_35 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,35 @@
+BBSR IU +32.371200 -064.696200 6.0 0.0
+SAML IU -08.948800 -063.183200 130.0 0.0
+SFJD IU +66.995999 -050.621500 328.0 0.0
+TRIS G -37.068200 -012.315200 57.0 0.0
+RAO IU -29.251700 -177.918300 110.0 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
+PAS CI 34.1484 -118.1711 295.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
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_tsuboi_tokachi-oki
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_tsuboi_tokachi-oki (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/STATIONS_tsuboi_tokachi-oki 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,882 @@
+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
+ABU BO 34.8603 135.5734 138.0 0.0
+AMM BO 28.1534 129.3022 12.0 0.0
+ASI BO 36.6458 139.4153 664.0 0.0
+FUJ BO 35.2267 138.4217 640.0 0.0
+FUK BO 32.7144 128.7594 75.0 0.0
+GJM BO 39.9517 140.1167 105.0 0.0
+HID BO 42.8183 142.4183 109.0 0.0
+HRO BO 37.2215 140.8813 630.0 0.0
+HSS BO 42.9647 141.2328 230.0 0.0
+IGK BO 24.4060 124.1783 77.0 0.0
+IMG BO 42.3902 140.1440 80.0 0.0
+INN BO 33.4665 131.3086 215.0 0.0
+ISI BO 34.0572 134.4580 27.0 0.0
+IYG BO 40.1188 141.5863 427.0 0.0
+IZH BO 34.1325 129.2092 386.0 0.0
+JIZ BO 34.9129 138.9972 263.0 0.0
+KGM BO 26.7531 128.2168 102.0 0.0
+KIS BO 33.8627 135.8933 70.0 0.0
+KMU BO 42.2387 142.9670 185.0 0.0
+KNM BO 35.7136 137.1817 339.0 0.0
+KNP BO 43.7600 143.7120 190.0 0.0
+KNY BO 34.8706 138.0658 260.0 0.0
+KSK BO 38.2529 140.5868 317.0 0.0
+KSN BO 38.9733 141.5333 280.0 0.0
+KYK BO 30.3722 130.4133 320.0 0.0
+KZK BO 37.2951 138.5156 220.0 0.0
+MMA BO 41.1583 140.4133 90.0 0.0
+NAA BO 35.2217 137.3650 200.0 0.0
+NMR BO 43.3650 145.7420 20.0 0.0
+NOK BO 34.1625 135.3511 95.0 0.0
+NRW BO 34.7647 133.5355 199.0 0.0
+NSK BO 34.3381 132.0042 205.0 0.0
+ONS BO 36.1525 138.9848 477.0 0.0
+SBR BO 33.5024 130.2555 265.0 0.0
+SBT BO 37.9656 139.4538 160.0 0.0
+SGN BO 35.5054 138.9475 800.0 0.0
+TAS BO 31.1908 130.9119 506.0 0.0
+TGA BO 35.1814 136.3414 290.0 0.0
+TGW BO 33.9708 132.9339 300.0 0.0
+TKA BO 31.5125 130.7853 535.0 0.0
+TKD BO 32.8140 131.3900 751.0 0.0
+TKO BO 31.8894 131.2347 80.0 0.0
+TMC BO 32.6031 130.9169 285.0 0.0
+TMR BO 41.0990 141.3868 120.0 0.0
+TSA BO 33.1744 132.8229 141.0 0.0
+TTO BO 35.8332 138.1238 1150.0 0.0
+TYM BO 34.9708 139.8481 30.0 0.0
+UMJ BO 33.5760 134.0398 361.0 0.0
+URH BO 42.9270 143.6746 75.0 0.0
+WTR BO 34.3706 136.5778 95.0 0.0
+YAS BO 35.6542 135.1636 232.0 0.0
+YMZ BO 36.9241 140.2479 555.0 0.0
+YSI BO 35.1908 132.8892 386.0 0.0
+YTY BO 34.2803 131.0394 155.0 0.0
+YZK BO 35.0859 134.4621 328.0 0.0
+ZMM BO 26.2289 127.3058 22.0 0.0
+CHS BO 35.7022 140.8550 52.0 0.0
+HKW BO 35.0932 138.1380 449.0 0.0
+IWT BO 35.9258 139.7381 6.0 0.0
+KFU BO 35.7394 138.5689 590.0 0.0
+OHS BO 34.6825 138.0152 68.0 0.0
+SMZ BO 34.9871 138.5167 0.0 0.0
+TNK BO 44.7757 142.0830 60.0 0.0
+TNR BO 34.9078 137.8852 140.0 0.0
+WP2 PS 41.08 159.963 -5566.0 0.0
+WP1 PS 19.2975 135.09917 -5640.0 0.0
+NWP1 PS 41.1180 159.9344 -5599.0 0.0
+NWP2 PS 41.1185 159.9343 -5589.0 0.0
+NWP3 PS 41.1291 159.9442 -5600.0 0.0
+NOT1 PS 19.3423 135.1215 -5698.0 0.0
+BKOB PS 42.28235 144.8523 -2133.7 0.0
+PHS3 PS 13.479189 147.810356 -5570 0.0
+PHS4 PS 16.579678 144.696259 -3206 0.0
+PHS5 PS 17.787031 143.407408 -4083 0.0
+PHS8 PS 21.407732 139.442632 -4911 0.0
+PHS9 PS 22.560394 138.121841 -5007 0.0
+PHS11 PS 25.000119 135.138480 -5240 0.0
+PHS12 PS 26.136514 133.676446 -5153 0.0
+PHS13 PS 27.188867 132.415377 -5428 0.0
+ISG PS 24.3793 124.2347 27.0 0.0
+JAY PS -2.5147 140.7030 439.0 0.0
+KMS PS 62.4565 166.2105 100.0 0.0
+PALU PS 7.3436 134.4741 10.0 0.0
+PHN PS 36.03 129.36 0.0 0.0
+TJN PS 36.3772 127.3638 60.0 0.0
+AAI JI -3.687 128.195 0.0 0.0
+BKB JI -1.260 116.897 100.0 0.0
+BMI JI -8.540 118.693 60.0 0.0
+BRB JI -7.609 110.204 0.0 0.0
+BSI JI 5.496 95.296 100.0 0.0
+BWN JI -5.851 112.658 0.0 0.0
+JMB JI -1.633 103.642 0.0 0.0
+KDI JI -3.957 122.619 0.0 0.0
+KHK JI -8.363 115.610 150.0 0.0
+KOTA JI -4.864 104.858 0.0 0.0
+KSI JI -3.652 102.591 0.0 0.0
+LEM JI -6.817 107.621 0.0 0.0
+MNI JI 1.444 124.839 0.0 0.0
+PCI JI -0.905 119.837 0.0 0.0
+PKBI JI -2.705 111.666 0.0 0.0
+PLK JI -2.226 113.946 0.0 0.0
+PPI JI -0.457 100.397 0.0 0.0
+PTK JI -0.146 109.404 65.0 0.0
+SWH JI -7.790 111.755 0.0 0.0
+TARA JI 3.327 117.570 95.0 0.0
+TOLI JI 1.122 120.794 0.0 0.0
+TPI JI -2.757 107.653 0.0 0.0
+TPN JI 0.918 104.530 0.0 0.0
+LBSA SP -16.554 179.289 185.0 0.0
+MNHK SP -10.415 -161.033 1.0 0.0
+NIUE SP -19.075 -169.930 60.0 0.0
+NRFK SP -29.042 167.963 196.0 0.0
+TNGT SP -21.150 -175.183 10.0 0.0
+VAVA SP -18.664 -173.977 5.0 0.0
+PPT LG -17.569 -149.5760 340.0 0.0
+RKT LG -23.120 -134.97 0.0 0.0
+TBI LG -23.530 -149.46 0.0 0.0
+KOB1 PS 41.6847 144.399 -2481.0 0.0
+KOB2 PS 41.9396 145.062 -3337.0 0.0
+KOB3 PS 42.2504 144.814 -2138.0 0.0
+HKD1 BO 42.9819 144.386 3.0 0.0
+HKD2 BO 42.8061 143.663 17.1 0.0
+HKD3 BO 42.695 143.139 191.6 0.0
+HKD4 BO 42.2838 143.316 36.1 0.0
+HKD5 BO 42.1652 142.771 3.9 0.0
+HKD6 BO 41.9344 143.244 15.0 0.0
+HKD7 BO 42.1261 143.319 15.0 0.0
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/Specfem3DGlobe.cfg
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/Specfem3DGlobe.cfg (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/Specfem3DGlobe.cfg 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,11 @@
+# example preferences file for the Pyrized verion of Specfem 3D Globe
+# copy to ~/.pyre/Specfem3DGlobe/Specfem3DGlobe.cfg
+
+
+[Specfem3DGlobe]
+
+# path to store the local database files on each node
+scratch-dir = /scratch/DATABASES_MPI_DIMITRI
+
+
+# end of file
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/ori_Par_file
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/ori_Par_file (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/DATA/ori_Par_file 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,112 @@
+
+# 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 = 6
+
+# 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 # 96
+NEX_ETA = 64 # 96
+
+# 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 = 30.0d0
+
+# save AVS or OpenDX movies
+MOVIE_SURFACE = .false.
+MOVIE_VOLUME = .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_COARSE saves movie only at corners of elements
+MOVIE_VOLUME_TYPE = 2
+MOVIE_VOLUME_COARSE = .true.
+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 = not_used_any_more_ignored
+
+# interval at which we output time step info and max of norm of displacement
+NTSTEP_BETWEEN_OUTPUT_INFO = 1000
+
+# 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 = .true.
+
+# print source time function
+PRINT_SOURCE_TIME_FUNCTION = .false.
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/Makefile 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,490 @@
+#=====================================================================
+#
+# S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+# --------------------------------------------------
+#
+# Main authors: Dimitri Komatitsch and Jeroen Tromp
+# Seismological Laboratory, California Institute of Technology, USA
+# and University of Pau / CNRS / INRIA, France
+# (c) California Institute of Technology and University of Pau / CNRS / INRIA
+# February 2008
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, write to the Free Software Foundation, Inc.,
+# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+#
+#=====================================================================
+
+# Makefile. Generated from Makefile.in by configure.
+
+ FC = ifort
+#FC = /usr/bin/gfortran
+#FC = pgf90
+#FC = /opt/intel/fc/9.1.040/bin/ifort
+FCFLAGS = #-g
+MPIFC = mpif90
+#MPIFC = /home/r/geophy/dkomati1/bin/mpich2-1.0.7/bin/mpif90
+#MPIFC = /opt/mpich2_ifort/bin/mpif90
+MPILIBS =
+#FLAGS_CHECK = -O3 -e95 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nobounds -align sequence -assume byterecl -i-dynamic -ftrapuv -fpe0 -no-ftz -traceback
+FLAGS_CHECK = $(FLAGS_NO_CHECK)
+FLAGS_NO_CHECK = -O3 -e95 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nobounds -align sequence -assume byterecl -i-dynamic -fpe3 -no-ftz
+
+#FLAGS_NO_CHECK = -std=gnu -fimplicit-none -frange-check -O3 -Wunused-labels -Waliasing -Wampersand -Wsurprising -Wline-truncation -Wunderflow
+#FLAGS_NO_CHECK = -fast -Mnobounds -Minline -Mneginfo -Mdclchk -Knoieee -Minform=warn -Mstandard -fastsse -tp amd64e
+
+#FLAGS_NO_CHECK = -O3 -e95 -implicitnone -warn truncated_source -warn argument_checking -warn declarations -std95 -check all -align sequence -assume byterecl -warn unused
+#FLAGS_NO_CHECK2 = -O3 -e95 -implicitnone -warn truncated_source -warn argument_checking -warn declarations -std95 -CB -align sequence -assume byterecl # -warn unused
+FLAGS_NO_CHECK2 = $(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)
+MPIFCCOMPILE_NO_CHECK = ${MPIFC} ${FCFLAGS} $(FLAGS_NO_CHECK)
+MPIFCCOMPILE_NO_CHECK2 = ${MPIFC} ${FCFLAGS} $(FLAGS_NO_CHECK2)
+
+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/assemble_MPI_scalar.o \
+ $O/assemble_MPI_vector.o \
+ $O/attenuation_model.o \
+ $O/calc_jacobian.o \
+ $O/comp_source_spectrum.o \
+ $O/comp_source_time_function.o \
+ $O/compute_arrays_source.o \
+ $O/compute_coordinates_grid.o \
+ $O/compute_element_properties.o \
+ $O/count_number_of_sources.o \
+ $O/create_central_cube_buffers.o \
+ $O/create_chunk_buffers.o \
+ $O/create_header_file.o \
+ $O/create_name_database.o \
+ $O/create_regions_mesh.o \
+ $O/crustal_model.o \
+ $O/define_derivation_matrices.o \
+ $O/define_superbrick.o \
+ $O/euler_angles.o \
+ $O/get_MPI_1D_buffers.o \
+ $O/get_MPI_cutplanes_eta.o \
+ $O/get_MPI_cutplanes_xi.o \
+ $O/get_cmt.o \
+ $O/get_ellipticity.o \
+ $O/get_event_info.o \
+ $O/get_global.o \
+ $O/get_jacobian_boundaries.o \
+ $O/get_model.o \
+ $O/get_perm_cuthill_mckee.o \
+ $O/get_shape2D.o \
+ $O/get_shape3D.o \
+ $O/get_value_parameters.o \
+ $O/gll_library.o \
+ $O/hex_nodes.o \
+ $O/intgrl.o \
+ $O/lagrange_poly.o \
+ $O/lgndr.o \
+ $O/locate_receivers.o \
+ $O/locate_sources.o \
+ $O/make_ellipticity.o \
+ $O/make_gravity.o \
+ $O/mantle_model.o \
+ $O/jp3d1994_model.o \
+ $O/sea99_s_model.o \
+ $O/memory_eval.o \
+ $O/model_1066a.o \
+ $O/model_ak135.o \
+ $O/model_iasp91.o \
+ $O/model_prem.o \
+ $O/model_ref.o \
+ $O/model_jp1d.o \
+ $O/model_sea1d.o \
+ $O/moho_stretching.o \
+ $O/spline_routines.o \
+ $O/create_list_files_chunks.o \
+ $O/recompute_missing_arrays.o \
+ $O/netlib_specfun_erf.o \
+ $O/read_compute_parameters.o \
+ $O/read_value_parameters.o \
+ $O/auto_ner.o \
+ $O/recompute_jacobian.o \
+ $O/reduce.o \
+ $O/rthetaphi_xyz.o \
+ $O/s362ani.o \
+ $O/save_header_file.o \
+ $O/sort_array_coordinates.o \
+ $O/stretching_function.o \
+ $O/topo_bathy.o \
+ $O/write_seismograms.o \
+ $(EMPTY_MACRO)
+
+# solver objects with statically allocated arrays; dependent upon
+# values_from_mesher.h
+SOLVER_ARRAY_OBJECTS = \
+ $O/assemble_MPI_central_cube.o \
+ $O/compute_forces_crust_mantle.o \
+ $O/compute_forces_inner_core.o \
+ $O/compute_forces_outer_core.o \
+ $O/specfem3D.o \
+ $(EMPTY_MACRO)
+
+LIBSPECFEM = $O/libspecfem.a
+
+
+####
+#### targets
+####
+
+# default targets
+DEFAULT = \
+ xcreate_header_file \
+ OUTPUT_FILES/values_from_mesher.h \
+ xmeshfem3D \
+ $(EMPTY_MACRO)
+
+default: $(DEFAULT)
+
+all: clean default
+
+backup:
+ cp *f90 *h README_SPECFEM3D_GLOBE DATA/Par_file* Makefile go_mesher go_solver mymachines bak
+
+bak: backup
+
+
+####
+#### rules for executables
+####
+
+# rules for the main programs
+XMESHFEM_OBJECTS = $O/meshfem3D.o $O/exit_mpi.o $(SOLVER_ARRAY_OBJECTS) $(LIBSPECFEM)
+xmeshfem3D: $(XMESHFEM_OBJECTS)
+## use MPI here
+ ${MPIFCCOMPILE_CHECK} -o xmeshfem3D $(XMESHFEM_OBJECTS) $(MPILIBS)
+
+# solver also depends on values from mesher
+XSPECFEM_OBJECTS = $(SOLVER_ARRAY_OBJECTS) $O/exit_mpi.o $(LIBSPECFEM)
+
+xconvolve_source_timefunction: $O/convolve_source_timefunction.o
+ ${FCCOMPILE_CHECK} -o xconvolve_source_timefunction $O/convolve_source_timefunction.o
+
+xcreate_header_file: $O/create_header_file.o $O/exit_mpi.o $O/get_value_parameters.o $O/read_compute_parameters.o $O/memory_eval.o $O/save_header_file.o $O/count_number_of_sources.o $O/read_value_parameters.o $O/euler_angles.o $O/reduce.o $O/rthetaphi_xyz.o $O/auto_ner.o
+ ${MPIFCCOMPILE_CHECK} -o xcreate_header_file $O/create_header_file.o $O/exit_mpi.o $O/get_value_parameters.o $O/read_compute_parameters.o $O/memory_eval.o $O/save_header_file.o $O/count_number_of_sources.o $O/read_value_parameters.o $O/euler_angles.o $O/reduce.o $O/rthetaphi_xyz.o $O/auto_ner.o
+
+clean:
+ rm -f $O/* *.o work.pc* *.mod xmeshfem3D xconvolve_source_timefunction xcreate_header_file PI*
+
+
+###
+### rule for the archive library
+###
+
+$O/libspecfem.a: $(libspecfem_a_OBJECTS)
+ -rm -f $O/libspecfem.a
+ $(AR) $(ARFLAGS) $O/libspecfem.a $(libspecfem_a_OBJECTS)
+ $(RANLIB) $O/libspecfem.a
+
+####
+#### rule for each .o file below
+####
+
+###
+### optimized flags and dependence on values from mesher here
+###
+
+$O/specfem3D.o: constants.h OUTPUT_FILES/values_from_mesher.h $S/specfem3D.f90
+ ${MPIFCCOMPILE_NO_CHECK2} -c -o $O/specfem3D.o ${FCFLAGS_f90} $S/specfem3D.f90
+
+$O/compute_forces_crust_mantle.o: constants.h OUTPUT_FILES/values_from_mesher.h $S/compute_forces_crust_mantle.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_crust_mantle.o ${FCFLAGS_f90} $S/compute_forces_crust_mantle.f90
+
+$O/compute_forces_outer_core.o: constants.h OUTPUT_FILES/values_from_mesher.h $S/compute_forces_outer_core.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_outer_core.o ${FCFLAGS_f90} $S/compute_forces_outer_core.f90
+
+$O/compute_forces_inner_core.o: constants.h OUTPUT_FILES/values_from_mesher.h $S/compute_forces_inner_core.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_inner_core.o ${FCFLAGS_f90} $S/compute_forces_inner_core.f90
+
+### use MPI here
+$O/assemble_MPI_vector.o: constants.h $S/assemble_MPI_vector.f90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/assemble_MPI_vector.o ${FCFLAGS_f90} $S/assemble_MPI_vector.f90
+
+### use MPI here
+$O/assemble_MPI_scalar.o: constants.h $S/assemble_MPI_scalar.f90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/assemble_MPI_scalar.o ${FCFLAGS_f90} $S/assemble_MPI_scalar.f90
+
+$O/assemble_MPI_central_cube.o: constants.h OUTPUT_FILES/values_from_mesher.h $S/assemble_MPI_central_cube.f90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/assemble_MPI_central_cube.o ${FCFLAGS_f90} $S/assemble_MPI_central_cube.f90
+
+###
+### regular compilation options here
+###
+
+$O/convolve_source_timefunction.o: $S/convolve_source_timefunction.f90
+ ${FCCOMPILE_CHECK} -c -o $O/convolve_source_timefunction.o ${FCFLAGS_f90} $S/convolve_source_timefunction.f90
+
+$O/create_header_file.o: $S/create_header_file.f90
+ ${FCCOMPILE_CHECK} -c -o $O/create_header_file.o ${FCFLAGS_f90} $S/create_header_file.f90
+
+$O/comp_source_time_function.o: $S/comp_source_time_function.f90
+ ${FCCOMPILE_CHECK} -c -o $O/comp_source_time_function.o ${FCFLAGS_f90} $S/comp_source_time_function.f90
+
+## use MPI here
+$O/create_chunk_buffers.o: constants.h $S/create_chunk_buffers.f90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/create_chunk_buffers.o ${FCFLAGS_f90} $S/create_chunk_buffers.f90
+
+$O/sort_array_coordinates.o: constants.h $S/sort_array_coordinates.f90
+ ${FCCOMPILE_CHECK} -c -o $O/sort_array_coordinates.o ${FCFLAGS_f90} $S/sort_array_coordinates.f90
+
+### use MPI here
+$O/locate_sources.o: constants.h $S/locate_sources.f90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/locate_sources.o ${FCFLAGS_f90} $S/locate_sources.f90
+
+### use MPI here
+$O/locate_receivers.o: constants.h $S/locate_receivers.f90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/locate_receivers.o ${FCFLAGS_f90} $S/locate_receivers.f90
+
+## use MPI here
+$O/exit_mpi.o: constants.h $S/exit_mpi.f90
+ ${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_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_event_info.o: constants.h $S/get_event_info.f90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/get_event_info.o ${FCFLAGS_f90} $S/get_event_info.f90
+
+$O/get_ellipticity.o: constants.h $S/get_ellipticity.f90
+ ${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/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/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/create_list_files_chunks.o: constants.h $S/create_list_files_chunks.f90
+ ${FCCOMPILE_CHECK} -c -o $O/create_list_files_chunks.o ${FCFLAGS_f90} $S/create_list_files_chunks.f90
+
+$O/recompute_missing_arrays.o: constants.h $S/recompute_missing_arrays.f90
+ ${FCCOMPILE_CHECK} -c -o $O/recompute_missing_arrays.o ${FCFLAGS_f90} $S/recompute_missing_arrays.f90
+
+$O/netlib_specfun_erf.o: $S/netlib_specfun_erf.f90
+ ${FCCOMPILE_CHECK} -c -o $O/netlib_specfun_erf.o ${FCFLAGS_f90} $S/netlib_specfun_erf.f90
+
+$O/lgndr.o: constants.h $S/lgndr.f90
+ ${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_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/write_seismograms.o: constants.h $S/write_seismograms.f90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/write_seismograms.o ${FCFLAGS_f90} $S/write_seismograms.f90
+
+$O/lagrange_poly.o: constants.h $S/lagrange_poly.f90
+ ${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/create_regions_mesh.o: constants.h $S/create_regions_mesh.f90
+ ${FCCOMPILE_CHECK} -c -o $O/create_regions_mesh.o ${FCFLAGS_f90} $S/create_regions_mesh.f90
+
+$O/create_name_database.o: constants.h $S/create_name_database.f90
+ ${FCCOMPILE_CHECK} -c -o $O/create_name_database.o ${FCFLAGS_f90} $S/create_name_database.f90
+
+$O/get_perm_cuthill_mckee.o: constants.h $S/get_perm_cuthill_mckee.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_perm_cuthill_mckee.o ${FCFLAGS_f90} $S/get_perm_cuthill_mckee.f90
+
+$O/define_derivation_matrices.o: constants.h $S/define_derivation_matrices.f90
+ ${FCCOMPILE_CHECK} -c -o $O/define_derivation_matrices.o ${FCFLAGS_f90} $S/define_derivation_matrices.f90
+
+$O/compute_arrays_source.o: constants.h $S/compute_arrays_source.f90
+ ${FCCOMPILE_CHECK} -c -o $O/compute_arrays_source.o ${FCFLAGS_f90} $S/compute_arrays_source.f90
+
+$O/create_central_cube_buffers.o: constants.h $S/create_central_cube_buffers.f90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/create_central_cube_buffers.o ${FCFLAGS_f90} $S/create_central_cube_buffers.f90
+
+$O/attenuation_model.o: constants.h $S/attenuation_model.f90 $O/model_ak135.o $O/model_1066a.o $O/model_ref.o
+ ${MPIFCCOMPILE_CHECK} -c -o $O/attenuation_model.o ${FCFLAGS_f90} $S/attenuation_model.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
+ ${FCCOMPILE_CHECK} -c -o $O/read_compute_parameters.o ${FCFLAGS_f90} $S/read_compute_parameters.f90
+
+$O/auto_ner.o: constants.h $S/auto_ner.f90
+ ${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/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_GLOBE/trunk/version41_beta/OUTPUT_FILES/values_from_mesher.h
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/OUTPUT_FILES/values_from_mesher.h (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/OUTPUT_FILES/values_from_mesher.h 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,158 @@
+
+ !
+ ! this is the parameter file for static compilation of the solver
+ !
+ ! mesh statistics:
+ ! ---------------
+ !
+ !
+ ! number of chunks = 6
+ !
+ ! these statistics include the central cube
+ !
+ ! number of processors = 1944
+ !
+ ! maximum number of points per region = 3776989
+ !
+ ! on NEC SX and Earth Simulator, make sure "loopcnt=" parameter
+ ! in Makefile is greater than max vector length = 11330967
+ !
+ ! total elements per slice = 68976
+ ! total points per slice = 4563683
+ !
+ ! total for full 6-chunk mesh:
+ ! ---------------------------
+ !
+ ! exact total number of spectral elements in entire mesh =
+ ! 127790784.000000
+ ! approximate total number of points in entire mesh =
+ ! 8465886067.00000
+ ! approximate total number of degrees of freedom in entire mesh =
+ ! 23478661929.0000
+ !
+ ! resolution of the mesh at the surface:
+ ! -------------------------------------
+ !
+ ! spectral elements along a great circle = 3456
+ ! GLL points along a great circle = 13824
+ ! average distance between points in degrees = 2.6041666E-02
+ ! average distance between points in km = 2.895701
+ ! average size of a spectral element in km = 11.58280
+ !
+ ! number of time steps = 23700
+ !
+ ! number of seismic sources = 1
+ !
+
+ ! approximate static memory needed by the solver:
+ ! ----------------------------------------------
+ !
+ ! size of static arrays per slice = 0.592284619808197 GB
+ !
+ ! (should be below and typically equal to 80% of 1.5 GB = 1.2 GB on pangu
+ ! at Caltech, and below and typically equal to 85% of 2 GB = 1.7 GB
+ ! on Marenostrum in Barcelona)
+ ! (if significantly more, the job will not run by lack of memory)
+ ! (if significantly less, you waste a significant amount of memory)
+ !
+ ! size of static arrays for all slices = 1151.40130090714 GB
+ ! = 1.12441533291712 TB
+ !
+
+ integer, parameter :: NEX_XI_VAL = 864
+ integer, parameter :: NEX_ETA_VAL = 864
+
+ integer, parameter :: NSPEC_CRUST_MANTLE = 57456
+ integer, parameter :: NSPEC_OUTER_CORE = 7308
+ integer, parameter :: NSPEC_INNER_CORE = 4212
+
+ integer, parameter :: NGLOB_CRUST_MANTLE = 3776989
+ integer, parameter :: NGLOB_OUTER_CORE = 493569
+ integer, parameter :: NGLOB_INNER_CORE = 293125
+
+ integer, parameter :: NSPECMAX_ANISO_IC = 1
+
+ integer, parameter :: NSPECMAX_ISO_MANTLE = 57456
+ integer, parameter :: NSPECMAX_TISO_MANTLE = 1
+ integer, parameter :: NSPECMAX_ANISO_MANTLE = 1
+
+ integer, parameter :: NSPEC_CRUST_MANTLE_ATTENUAT = 1
+ integer, parameter :: NSPEC_INNER_CORE_ATTENUATION = 1
+
+ integer, parameter :: NSPEC_CRUST_MANTLE_STR_OR_ATT = 1
+ integer, parameter :: NSPEC_INNER_CORE_STR_OR_ATT = 1
+
+ integer, parameter :: NSPEC_CRUST_MANTLE_STR_AND_ATT = 1
+ integer, parameter :: NSPEC_INNER_CORE_STR_AND_ATT = 1
+
+ integer, parameter :: NSPEC_CRUST_MANTLE_STRAIN_ONLY = 1
+ integer, parameter :: NSPEC_INNER_CORE_STRAIN_ONLY = 1
+
+ integer, parameter :: NSPEC_CRUST_MANTLE_ADJOINT = 1
+ integer, parameter :: NSPEC_OUTER_CORE_ADJOINT = 1
+ integer, parameter :: NSPEC_INNER_CORE_ADJOINT = 1
+ integer, parameter :: NGLOB_CRUST_MANTLE_ADJOINT = 1
+ integer, parameter :: NGLOB_OUTER_CORE_ADJOINT = 1
+ integer, parameter :: NGLOB_INNER_CORE_ADJOINT = 1
+ integer, parameter :: NSPEC_OUTER_CORE_ROT_ADJOINT = 1
+
+ integer, parameter :: NSPEC_CRUST_MANTLE_STACEY = 1
+ integer, parameter :: NSPEC_OUTER_CORE_STACEY = 1
+
+ integer, parameter :: NGLOB_CRUST_MANTLE_OCEANS = 1
+
+ logical, parameter :: TRANSVERSE_ISOTROPY_VAL = .false.
+
+ logical, parameter :: ANISOTROPIC_3D_MANTLE_VAL = .false.
+
+ logical, parameter :: ANISOTROPIC_INNER_CORE_VAL = .false.
+
+ logical, parameter :: ATTENUATION_VAL = .false.
+
+ logical, parameter :: ATTENUATION_3D_VAL = .false.
+
+ logical, parameter :: ELLIPTICITY_VAL = .false.
+
+ logical, parameter :: GRAVITY_VAL = .false.
+
+ logical, parameter :: ROTATION_VAL = .false.
+ integer, parameter :: NSPEC_OUTER_CORE_ROTATION = 1
+
+ integer, parameter :: NGLOB1D_RADIAL_CM = 493
+ integer, parameter :: NGLOB1D_RADIAL_OC = 345
+ integer, parameter :: NGLOB1D_RADIAL_IC = 37
+ integer, parameter :: NGLOB2DMAX_XMIN_XMAX_CM = 62101
+ integer, parameter :: NGLOB2DMAX_XMIN_XMAX_OC = 18751
+ integer, parameter :: NGLOB2DMAX_XMIN_XMAX_IC = 17551
+ integer, parameter :: NGLOB2DMAX_YMIN_YMAX_CM = 62101
+ integer, parameter :: NGLOB2DMAX_YMIN_YMAX_OC = 18751
+ integer, parameter :: NGLOB2DMAX_YMIN_YMAX_IC = 17551
+ integer, parameter :: NPROC_XI_VAL = 18
+ integer, parameter :: NPROC_ETA_VAL = 18
+ integer, parameter :: NCHUNKS_VAL = 6
+ integer, parameter :: NPROCTOT_VAL = 1944
+ integer, parameter :: NGLOB2DMAX_XY_VAL = 62101
+ integer, parameter :: NUMMSGS_FACES_VAL = 216
+ integer, parameter :: NCORNERSCHUNKS_VAL = 8
+ integer, parameter :: ATT1 = 1
+ integer, parameter :: ATT2 = 1
+ integer, parameter :: ATT3 = 1
+ integer, parameter :: ATT4 = 1
+ integer, parameter :: ATT5 = 1
+ integer, parameter :: NSPEC2DMAX_XMIN_XMAX_CM = 2484
+ integer, parameter :: NSPEC2DMAX_YMIN_YMAX_CM = 2484
+ integer, parameter :: NSPEC2D_BOTTOM_CM = 144
+ integer, parameter :: NSPEC2D_TOP_CM = 2304
+ integer, parameter :: NSPEC2DMAX_XMIN_XMAX_IC = 702
+ integer, parameter :: NSPEC2DMAX_YMIN_YMAX_IC = 702
+ integer, parameter :: NSPEC2D_BOTTOM_IC = 36
+ integer, parameter :: NSPEC2D_TOP_IC = 36
+ integer, parameter :: NSPEC2DMAX_XMIN_XMAX_OC = 750
+ integer, parameter :: NSPEC2DMAX_YMIN_YMAX_OC = 750
+ integer, parameter :: NSPEC2D_BOTTOM_OC = 36
+ integer, parameter :: NSPEC2D_TOP_OC = 144
+ integer, parameter :: NSPEC2D_MOHO = 1
+ integer, parameter :: NSPEC2D_400 = 1
+ integer, parameter :: NSPEC2D_670 = 1
+ integer, parameter :: NSPEC2D_CMB = 1
+ integer, parameter :: NSPEC2D_ICB = 1
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_missing_nodes.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_missing_nodes.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_missing_nodes.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/add_topography.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/add_topography_410_650.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_410_650.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_410_650.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/add_topography_cmb.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_cmb.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_cmb.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/add_topography_icb.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_icb.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/add_topography_icb.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/allocate_after_1.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_after_1.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_after_1.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,228 @@
+
+ allocate(xstore_crust_mantle(NGLOB_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(ystore_crust_mantle(NGLOB_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(zstore_crust_mantle(NGLOB_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ allocate(xstore_outer_core(NGLOB_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+
+
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(ystore_outer_core(NGLOB_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(zstore_outer_core(NGLOB_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ allocate(xstore_inner_core(NGLOB_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(ystore_inner_core(NGLOB_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(zstore_inner_core(NGLOB_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+!---
+
+ allocate(xix_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(xiy_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(xiz_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etax_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etay_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etaz_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammax_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammay_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammaz_crust_mantle(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ allocate(xix_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(xiy_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(xiz_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etax_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etay_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etaz_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammax_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammay_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammaz_outer_core(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ allocate(xix_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(xiy_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(xiz_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etax_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etay_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(etaz_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammax_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammay_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(gammaz_inner_core(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_1 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_after_2.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_after_2.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_after_2.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,98 @@
+
+ allocate(rmass_ocean_load(NGLOB_CRUST_MANTLE_OCEANS),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+!---
+
+ allocate(displ_crust_mantle(NDIM,NGLOB_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(veloc_crust_mantle(NDIM,NGLOB_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(accel_crust_mantle(NDIM,NGLOB_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ allocate(displ_outer_core(NGLOB_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(veloc_outer_core(NGLOB_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(accel_outer_core(NGLOB_OUTER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ allocate(displ_inner_core(NDIM,NGLOB_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(veloc_inner_core(NDIM,NGLOB_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(accel_inner_core(NDIM,NGLOB_INNER_CORE),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+!---
+
+ allocate(R_memory_crust_mantle(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ allocate(R_memory_inner_core(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+!---
+
+ allocate(epsilondev_crust_mantle(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ allocate(epsilondev_inner_core(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT),stat=ier)
+ if(ier /= 0) then
+ print *,"ABORTING can not allocate in allocate_after_2 ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_before.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_before.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/allocate_before.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,23 @@
+
+!! DK DK added this for merged version
+ allocate(xelm_store_crust_mantle(NGNOD,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+ allocate(yelm_store_crust_mantle(NGNOD,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+ allocate(zelm_store_crust_mantle(NGNOD,NSPEC_CRUST_MANTLE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+
+ allocate(xelm_store_outer_core(NGNOD,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+ allocate(yelm_store_outer_core(NGNOD,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+ allocate(zelm_store_outer_core(NGNOD,NSPEC_OUTER_CORE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+
+ allocate(xelm_store_inner_core(NGNOD,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+ allocate(yelm_store_inner_core(NGNOD,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+ allocate(zelm_store_inner_core(NGNOD,NSPEC_INNER_CORE),stat=ier)
+ if(ier /= 0) stop 'error memory allocation merged version'
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/anisotropic_inner_core_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/anisotropic_inner_core_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/anisotropic_inner_core_model.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/anisotropic_mantle_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/anisotropic_mantle_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/anisotropic_mantle_model.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/assemble_MPI_central_cube.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_central_cube.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_central_cube.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,261 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+subroutine assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube, sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices, buffer_all_cube_from_slices, buffer_slices, buffer_slices2, ibool_central_cube, &
+ receiver_cube_from_slices, ibool_inner_core, idoubling_inner_core, NSPEC_INNER_CORE, &
+ ibelm_bottom_inner_core, NSPEC2D_BOTTOM_INNER_CORE,NGLOB_INNER_CORE,vector_assemble,ndim_assemble)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+ include 'constants.h'
+
+! for matching with central cube in inner core
+ integer ichunk, nb_msgs_theor_in_cube, npoin2D_cube_from_slices
+ integer, dimension(nb_msgs_theor_in_cube) :: sender_from_slices_to_cube
+ double precision, dimension(npoin2D_cube_from_slices,NDIM) :: buffer_slices,buffer_slices2
+ double precision, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM) :: buffer_all_cube_from_slices
+ integer, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices):: ibool_central_cube
+ integer receiver_cube_from_slices
+
+! local to global mapping
+ integer NSPEC_INNER_CORE,NSPEC2D_BOTTOM_INNER_CORE, NGLOB_INNER_CORE
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
+ integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
+ integer, dimension(NSPEC2D_BOTTOM_INNER_CORE) :: ibelm_bottom_inner_core
+
+! vector
+ integer ndim_assemble
+ real(kind=CUSTOM_REAL), dimension(ndim_assemble,NGLOB_INNER_CORE) :: vector_assemble
+
+ integer ipoin,idimension, ispec2D, ispec
+ integer i,j,k
+ integer sender,receiver,imsg
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: array_central_cube
+
+! MPI status of messages to be received
+ integer msg_status(MPI_STATUS_SIZE), ier
+
+! mask
+ logical, dimension(NGLOB_INNER_CORE) :: mask
+
+!---
+!--- now use buffers to assemble mass matrix with central cube once and for all
+!---
+
+! on chunks AB and AB_ANTIPODE, receive all the messages from slices
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+
+ do imsg = 1,nb_msgs_theor_in_cube-1
+
+! receive buffers from slices
+ sender = sender_from_slices_to_cube(imsg)
+ call MPI_RECV(buffer_slices, &
+ ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+
+! copy buffer in 2D array for each slice
+ buffer_all_cube_from_slices(imsg,:,1:ndim_assemble) = buffer_slices(:,1:ndim_assemble)
+
+ enddo
+ endif
+
+! send info to central cube from all the slices except those in CHUNK_AB & CHUNK_AB_ANTIPODE
+ if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE) then
+
+! for bottom elements in contact with central cube from the slices side
+ ipoin = 0
+ do ispec2D = 1,NSPEC2D_BOTTOM_INNER_CORE
+
+ ispec = ibelm_bottom_inner_core(ispec2D)
+
+! only for DOFs exactly on surface of central cube (bottom of these elements)
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ipoin = ipoin + 1
+ buffer_slices(ipoin,1:ndim_assemble) = dble(vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)))
+ enddo
+ enddo
+ enddo
+
+! send buffer to central cube
+ receiver = receiver_cube_from_slices
+ call MPI_SEND(buffer_slices,ndim_assemble*npoin2D_cube_from_slices, &
+ MPI_DOUBLE_PRECISION,receiver,itag,MPI_COMM_WORLD,ier)
+
+ endif ! end sending info to central cube
+
+
+! exchange of their bottom faces between chunks AB and AB_ANTIPODE
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+
+ ipoin = 0
+ do ispec = NSPEC_INNER_CORE, 1, -1
+ if (idoubling_inner_core(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE) then
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ipoin = ipoin + 1
+ buffer_slices(ipoin,1:ndim_assemble) = dble(vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)))
+ enddo
+ enddo
+ endif
+ enddo
+
+ sender = sender_from_slices_to_cube(nb_msgs_theor_in_cube)
+
+ call MPI_SENDRECV(buffer_slices,ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,receiver_cube_from_slices, &
+ itag,buffer_slices2,ndim_assemble*npoin2D_cube_from_slices,&
+ MPI_DOUBLE_PRECISION,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+
+ buffer_all_cube_from_slices(nb_msgs_theor_in_cube,:,1:ndim_assemble) = buffer_slices2(:,1:ndim_assemble)
+
+ endif
+
+!--- now we need to assemble the contributions
+
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+
+ do idimension = 1,ndim_assemble
+! erase contributions to central cube array
+ array_central_cube(:) = 0._CUSTOM_REAL
+
+! use indirect addressing to store contributions only once
+! distinguish between single and double precision for reals
+ do imsg = 1,nb_msgs_theor_in_cube-1
+ do ipoin = 1,npoin2D_cube_from_slices
+ if(CUSTOM_REAL == SIZE_REAL) then
+ array_central_cube(ibool_central_cube(imsg,ipoin)) = sngl(buffer_all_cube_from_slices(imsg,ipoin,idimension))
+ else
+ array_central_cube(ibool_central_cube(imsg,ipoin)) = buffer_all_cube_from_slices(imsg,ipoin,idimension)
+ endif
+ enddo
+ enddo
+! add the constribution of AB or AB_ANTIPODE to sum with the external slices on the edges
+! use a mask to avoid taking the same point into account several times.
+ mask(:) = .false.
+ do ipoin = 1,npoin2D_cube_from_slices
+ if (.not. mask(ibool_central_cube(nb_msgs_theor_in_cube,ipoin))) then
+ if(CUSTOM_REAL == SIZE_REAL) then
+ array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) = &
+ array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) + &
+ sngl(buffer_all_cube_from_slices(nb_msgs_theor_in_cube,ipoin,idimension))
+ else
+ array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) = &
+ array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) + &
+ buffer_all_cube_from_slices(nb_msgs_theor_in_cube,ipoin,idimension)
+ endif
+ mask(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) = .true.
+ endif
+ enddo
+
+! suppress degrees of freedom already assembled at top of cube on edges
+ do ispec = 1,NSPEC_INNER_CORE
+ if(idoubling_inner_core(ispec) == IFLAG_TOP_CENTRAL_CUBE) then
+ k = NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ array_central_cube(ibool_inner_core(i,j,k,ispec)) = 0._CUSTOM_REAL
+ enddo
+ enddo
+ endif
+ enddo
+
+! assemble contributions
+ vector_assemble(idimension,:) = vector_assemble(idimension,:) + array_central_cube(:)
+
+! copy sum back
+ do imsg = 1,nb_msgs_theor_in_cube-1
+ do ipoin = 1,npoin2D_cube_from_slices
+ buffer_all_cube_from_slices(imsg,ipoin,idimension) = vector_assemble(idimension,ibool_central_cube(imsg,ipoin))
+ enddo
+ enddo
+
+ enddo
+
+ endif
+
+!----------
+
+! receive info from central cube on all the slices except those in CHUNK_AB & CHUNK_AB_ANTIPODE
+ if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE) then
+
+! receive buffers from slices
+ sender = receiver_cube_from_slices
+ call MPI_RECV(buffer_slices, &
+ ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+
+! for bottom elements in contact with central cube from the slices side
+ ipoin = 0
+ do ispec2D = 1,NSPEC2D_BOTTOM_INNER_CORE
+
+ ispec = ibelm_bottom_inner_core(ispec2D)
+
+! only for DOFs exactly on surface of central cube (bottom of these elements)
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ipoin = ipoin + 1
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)) = sngl(buffer_slices(ipoin,1:ndim_assemble))
+ else
+ vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)) = buffer_slices(ipoin,1:ndim_assemble)
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ endif ! end receiving info from central cube
+
+!------- send info back from central cube to slices
+
+! on chunk AB & CHUNK_AB_ANTIPODE, send all the messages to slices
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+
+ do imsg = 1,nb_msgs_theor_in_cube-1
+
+! copy buffer in 2D array for each slice
+ buffer_slices(:,1:ndim_assemble) = buffer_all_cube_from_slices(imsg,:,1:ndim_assemble)
+
+! send buffers to slices
+ receiver = sender_from_slices_to_cube(imsg)
+ call MPI_SEND(buffer_slices,ndim_assemble*npoin2D_cube_from_slices, &
+ MPI_DOUBLE_PRECISION,receiver,itag,MPI_COMM_WORLD,ier)
+
+ enddo
+ endif
+
+end subroutine assemble_MPI_central_cube
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_scalar.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_scalar.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_scalar.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,437 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!----
+!---- assemble the contributions between slices and chunks using MPI
+!----
+
+ subroutine assemble_MPI_scalar(myrank,array_val,nglob, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta, &
+ npoin2D_faces,npoin2D_xi,npoin2D_eta, &
+ iboolfaces,iboolcorner, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces_scalar,buffer_received_faces_scalar,npoin2D_max_all, &
+ buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NCHUNKS)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer myrank,nglob,NCHUNKS
+
+! array to assemble
+ real(kind=CUSTOM_REAL), dimension(nglob) :: array_val
+
+ integer iproc_xi,iproc_eta,ichunk
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi,npoin2D_eta
+ integer npoin2D_faces(NUMFACES_SHARED)
+
+ integer NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY
+ integer NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL
+ integer NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS
+
+! for addressing of the slices
+ integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1) :: addressing
+
+! 2-D addressing and buffers for summation between slices
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
+
+! indirect addressing for each corner of the chunks
+ integer, dimension(NGLOB1D_RADIAL,NUMCORNERS_SHARED) :: iboolcorner
+ integer icount_corners
+
+ integer :: npoin2D_max_all
+ integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces
+ real(kind=CUSTOM_REAL), dimension(npoin2D_max_all) :: buffer_send_faces_scalar,buffer_received_faces_scalar
+
+! buffers for send and receive between corners of the chunks
+ real(kind=CUSTOM_REAL), dimension(NGLOB1D_RADIAL) :: buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar
+
+! ---- arrays to assemble between chunks
+
+! communication pattern for faces between chunks
+ integer, dimension(NUMMSGS_FACES) :: iprocfrom_faces,iprocto_faces,imsg_type
+
+! communication pattern for corners between chunks
+ integer, dimension(NCORNERSCHUNKS) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
+
+! MPI status of messages to be received
+ integer msg_status(MPI_STATUS_SIZE)
+
+ integer ipoin,ipoin2D,ipoin1D
+ integer sender,receiver,ier
+ integer imsg,imsg_loop
+ integer icount_faces,npoin2D_chunks
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! check flag to see if we need to assemble (might be turned off when debugging)
+ if (.not. ACTUALLY_ASSEMBLE_MPI_SLICES) return
+
+! here we have to assemble all the contributions between slices using MPI
+
+!----
+!---- assemble the contributions between slices using MPI
+!----
+
+!----
+!---- first assemble along xi using the 2-D topology
+!----
+
+! assemble along xi only if more than one slice
+ if(NPROC_XI > 1) then
+
+! slices copy the right face into the buffer
+ do ipoin=1,npoin2D_xi(2)
+ buffer_send_faces_scalar(ipoin) = array_val(iboolright_xi(ipoin))
+ enddo
+
+! send messages forward along each row
+ if(iproc_xi == 0) then
+ sender = MPI_PROC_NULL
+ else
+ sender = addressing(ichunk,iproc_xi - 1,iproc_eta)
+ endif
+ if(iproc_xi == NPROC_XI-1) then
+ receiver = MPI_PROC_NULL
+ else
+ receiver = addressing(ichunk,iproc_xi + 1,iproc_eta)
+ endif
+ call MPI_SENDRECV(buffer_send_faces_scalar,npoin2D_xi(2),CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_scalar,npoin2D_xi(1),CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+
+! all slices add the buffer received to the contributions on the left face
+ if(iproc_xi > 0) then
+ do ipoin=1,npoin2D_xi(1)
+ array_val(iboolleft_xi(ipoin)) = array_val(iboolleft_xi(ipoin)) + &
+ buffer_received_faces_scalar(ipoin)
+ enddo
+ endif
+
+! the contributions are correctly assembled on the left side of each slice
+! now we have to send the result back to the sender
+! all slices copy the left face into the buffer
+ do ipoin=1,npoin2D_xi(1)
+ buffer_send_faces_scalar(ipoin) = array_val(iboolleft_xi(ipoin))
+ enddo
+
+! send messages backward along each row
+ if(iproc_xi == NPROC_XI-1) then
+ sender = MPI_PROC_NULL
+ else
+ sender = addressing(ichunk,iproc_xi + 1,iproc_eta)
+ endif
+ if(iproc_xi == 0) then
+ receiver = MPI_PROC_NULL
+ else
+ receiver = addressing(ichunk,iproc_xi - 1,iproc_eta)
+ endif
+ call MPI_SENDRECV(buffer_send_faces_scalar,npoin2D_xi(1),CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_scalar,npoin2D_xi(2),CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+
+! all slices copy the buffer received to the contributions on the right face
+ if(iproc_xi < NPROC_XI-1) then
+ do ipoin=1,npoin2D_xi(2)
+ array_val(iboolright_xi(ipoin)) = buffer_received_faces_scalar(ipoin)
+ enddo
+ endif
+
+ endif
+
+!----
+!---- then assemble along eta using the 2-D topology
+!----
+
+! assemble along eta only if more than one slice
+ if(NPROC_ETA > 1) then
+
+! slices copy the right face into the buffer
+ do ipoin=1,npoin2D_eta(2)
+ buffer_send_faces_scalar(ipoin) = array_val(iboolright_eta(ipoin))
+ enddo
+
+! send messages forward along each row
+ if(iproc_eta == 0) then
+ sender = MPI_PROC_NULL
+ else
+ sender = addressing(ichunk,iproc_xi,iproc_eta - 1)
+ endif
+ if(iproc_eta == NPROC_ETA-1) then
+ receiver = MPI_PROC_NULL
+ else
+ receiver = addressing(ichunk,iproc_xi,iproc_eta + 1)
+ endif
+ call MPI_SENDRECV(buffer_send_faces_scalar,npoin2D_eta(2),CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_scalar,npoin2D_eta(1),CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+
+! all slices add the buffer received to the contributions on the left face
+ if(iproc_eta > 0) then
+ do ipoin=1,npoin2D_eta(1)
+ array_val(iboolleft_eta(ipoin)) = array_val(iboolleft_eta(ipoin)) + &
+ buffer_received_faces_scalar(ipoin)
+ enddo
+ endif
+
+! the contributions are correctly assembled on the left side of each slice
+! now we have to send the result back to the sender
+! all slices copy the left face into the buffer
+ do ipoin=1,npoin2D_eta(1)
+ buffer_send_faces_scalar(ipoin) = array_val(iboolleft_eta(ipoin))
+ enddo
+
+! send messages backward along each row
+ if(iproc_eta == NPROC_ETA-1) then
+ sender = MPI_PROC_NULL
+ else
+ sender = addressing(ichunk,iproc_xi,iproc_eta + 1)
+ endif
+ if(iproc_eta == 0) then
+ receiver = MPI_PROC_NULL
+ else
+ receiver = addressing(ichunk,iproc_xi,iproc_eta - 1)
+ endif
+ call MPI_SENDRECV(buffer_send_faces_scalar,npoin2D_eta(1),CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_scalar,npoin2D_eta(2),CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+
+! all slices copy the buffer received to the contributions on the right face
+ if(iproc_eta < NPROC_ETA-1) then
+ do ipoin=1,npoin2D_eta(2)
+ array_val(iboolright_eta(ipoin)) = buffer_received_faces_scalar(ipoin)
+ enddo
+ endif
+
+ endif
+
+!----
+!---- start MPI assembling phase between chunks
+!----
+
+! check flag to see if we need to assemble (might be turned off when debugging)
+! and do not assemble if only one chunk
+ if (.not. ACTUALLY_ASSEMBLE_MPI_CHUNKS .or. NCHUNKS == 1) return
+
+! ***************************************************************
+! transmit messages in forward direction (iprocfrom -> iprocto)
+! ***************************************************************
+
+!---- put slices in receive mode
+!---- a given slice can belong to at most two faces
+
+! use three step scheme that can never deadlock
+! scheme for faces cannot deadlock even if NPROC_XI = NPROC_ETA = 1
+ do imsg_loop = 1,NUM_MSG_TYPES
+
+ icount_faces = 0
+ do imsg = 1,NUMMSGS_FACES
+ if(myrank==iprocfrom_faces(imsg) .or. &
+ myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
+ if(myrank==iprocto_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
+ sender = iprocfrom_faces(imsg)
+ npoin2D_chunks = npoin2D_faces(icount_faces)
+ call MPI_RECV(buffer_received_faces_scalar, &
+ npoin2D_chunks,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+ do ipoin2D=1,npoin2D_chunks
+ array_val(iboolfaces(ipoin2D,icount_faces)) = &
+ array_val(iboolfaces(ipoin2D,icount_faces)) + buffer_received_faces_scalar(ipoin2D)
+ enddo
+ endif
+ enddo
+
+!---- put slices in send mode
+!---- a given slice can belong to at most two faces
+ icount_faces = 0
+ do imsg = 1,NUMMSGS_FACES
+ if(myrank==iprocfrom_faces(imsg) .or. &
+ myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
+ if(myrank==iprocfrom_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
+ receiver = iprocto_faces(imsg)
+ npoin2D_chunks = npoin2D_faces(icount_faces)
+ do ipoin2D=1,npoin2D_chunks
+ buffer_send_faces_scalar(ipoin2D) = array_val(iboolfaces(ipoin2D,icount_faces))
+ enddo
+ call MPI_SEND(buffer_send_faces_scalar,npoin2D_chunks, &
+ CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+ endif
+ enddo
+
+! *********************************************************************
+! transmit messages back in opposite direction (iprocto -> iprocfrom)
+! *********************************************************************
+
+!---- put slices in receive mode
+!---- a given slice can belong to at most two faces
+
+ icount_faces = 0
+ do imsg = 1,NUMMSGS_FACES
+ if(myrank==iprocfrom_faces(imsg) .or. &
+ myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
+ if(myrank==iprocfrom_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
+ sender = iprocto_faces(imsg)
+ npoin2D_chunks = npoin2D_faces(icount_faces)
+ call MPI_RECV(buffer_received_faces_scalar, &
+ npoin2D_chunks,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+ do ipoin2D=1,npoin2D_chunks
+ array_val(iboolfaces(ipoin2D,icount_faces)) = buffer_received_faces_scalar(ipoin2D)
+ enddo
+ endif
+ enddo
+
+!---- put slices in send mode
+!---- a given slice can belong to at most two faces
+ icount_faces = 0
+ do imsg = 1,NUMMSGS_FACES
+ if(myrank==iprocfrom_faces(imsg) .or. &
+ myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
+ if(myrank==iprocto_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
+ receiver = iprocfrom_faces(imsg)
+ npoin2D_chunks = npoin2D_faces(icount_faces)
+ do ipoin2D=1,npoin2D_chunks
+ buffer_send_faces_scalar(ipoin2D) = array_val(iboolfaces(ipoin2D,icount_faces))
+ enddo
+ call MPI_SEND(buffer_send_faces_scalar,npoin2D_chunks, &
+ CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+ endif
+ enddo
+
+! end of anti-deadlocking loop
+ enddo
+
+!----
+!---- start MPI assembling corners
+!----
+
+! scheme for corners cannot deadlock even if NPROC_XI = NPROC_ETA = 1
+
+! ***************************************************************
+! transmit messages in forward direction (two workers -> master)
+! ***************************************************************
+
+ icount_corners = 0
+
+ do imsg = 1,NCORNERSCHUNKS
+
+ if(myrank == iproc_master_corners(imsg) .or. &
+ myrank == iproc_worker1_corners(imsg) .or. &
+ (NCHUNKS /= 2 .and. myrank == iproc_worker2_corners(imsg))) icount_corners = icount_corners + 1
+
+!---- receive messages from the two workers on the master
+ if(myrank==iproc_master_corners(imsg)) then
+
+! receive from worker #1 and add to local array
+ sender = iproc_worker1_corners(imsg)
+ call MPI_RECV(buffer_recv_chunkcorners_scalar,NGLOB1D_RADIAL, &
+ CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+ do ipoin1D=1,NGLOB1D_RADIAL
+ array_val(iboolcorner(ipoin1D,icount_corners)) = array_val(iboolcorner(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_scalar(ipoin1D)
+ enddo
+
+! receive from worker #2 and add to local array
+ if(NCHUNKS /= 2) then
+ sender = iproc_worker2_corners(imsg)
+ call MPI_RECV(buffer_recv_chunkcorners_scalar,NGLOB1D_RADIAL, &
+ CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+ do ipoin1D=1,NGLOB1D_RADIAL
+ array_val(iboolcorner(ipoin1D,icount_corners)) = array_val(iboolcorner(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_scalar(ipoin1D)
+ enddo
+ endif
+
+ endif
+
+!---- send messages from the two workers to the master
+ if(myrank==iproc_worker1_corners(imsg) .or. &
+ (NCHUNKS /= 2 .and. myrank==iproc_worker2_corners(imsg))) then
+
+ receiver = iproc_master_corners(imsg)
+ do ipoin1D=1,NGLOB1D_RADIAL
+ buffer_send_chunkcorners_scalar(ipoin1D) = array_val(iboolcorner(ipoin1D,icount_corners))
+ enddo
+ call MPI_SEND(buffer_send_chunkcorners_scalar,NGLOB1D_RADIAL,CUSTOM_MPI_TYPE, &
+ receiver,itag,MPI_COMM_WORLD,ier)
+
+ endif
+
+! *********************************************************************
+! transmit messages back in opposite direction (master -> two workers)
+! *********************************************************************
+
+!---- receive messages from the master on the two workers
+ if(myrank==iproc_worker1_corners(imsg) .or. &
+ (NCHUNKS /= 2 .and. myrank==iproc_worker2_corners(imsg))) then
+
+! receive from master and copy to local array
+ sender = iproc_master_corners(imsg)
+ call MPI_RECV(buffer_recv_chunkcorners_scalar,NGLOB1D_RADIAL, &
+ CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+ do ipoin1D=1,NGLOB1D_RADIAL
+ array_val(iboolcorner(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_scalar(ipoin1D)
+ enddo
+
+ endif
+
+!---- send messages from the master to the two workers
+ if(myrank==iproc_master_corners(imsg)) then
+
+ do ipoin1D=1,NGLOB1D_RADIAL
+ buffer_send_chunkcorners_scalar(ipoin1D) = array_val(iboolcorner(ipoin1D,icount_corners))
+ enddo
+
+! send to worker #1
+ receiver = iproc_worker1_corners(imsg)
+ call MPI_SEND(buffer_send_chunkcorners_scalar,NGLOB1D_RADIAL,CUSTOM_MPI_TYPE, &
+ receiver,itag,MPI_COMM_WORLD,ier)
+
+! send to worker #2
+ if(NCHUNKS /= 2) then
+ receiver = iproc_worker2_corners(imsg)
+ call MPI_SEND(buffer_send_chunkcorners_scalar,NGLOB1D_RADIAL,CUSTOM_MPI_TYPE, &
+ receiver,itag,MPI_COMM_WORLD,ier)
+ endif
+
+ endif
+
+ enddo
+
+ end subroutine assemble_MPI_scalar
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_vector.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_vector.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/assemble_MPI_vector.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,694 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!----
+!---- assemble the contributions between slices and chunks using MPI
+!---- we handle two regions (crust/mantle and inner core) in the same MPI call
+!---- to reduce the total number of MPI calls
+!----
+
+ subroutine assemble_MPI_vector(myrank, &
+ accel_crust_mantle,NGLOB_CRUST_MANTLE, &
+ accel_inner_core,NGLOB_INNER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces_vector,buffer_received_faces_vector,npoin2D_max_all, &
+ buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA, &
+ NGLOB1D_RADIAL_crust_mantle, &
+ NGLOB2DMAX_XMIN_XMAX_CM,NGLOB2DMAX_YMIN_YMAX_CM, &
+ NGLOB1D_RADIAL_inner_core, &
+ NGLOB2DMAX_XMIN_XMAX_IC,NGLOB2DMAX_YMIN_YMAX_IC, &
+ NGLOB2DMAX_XY,NCHUNKS)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer myrank,NGLOB_CRUST_MANTLE,NGLOB_INNER_CORE,NCHUNKS
+
+! the two arrays to assemble
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: accel_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: accel_inner_core
+
+ integer iproc_xi,iproc_eta,ichunk
+ integer npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle
+ integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
+ integer npoin2D_xi_inner_core,npoin2D_eta_inner_core
+ integer npoin2D_faces_inner_core(NUMFACES_SHARED)
+
+ integer NGLOB2DMAX_XMIN_XMAX_CM,NGLOB2DMAX_YMIN_YMAX_CM,NGLOB1D_RADIAL_crust_mantle
+ integer NGLOB2DMAX_XMIN_XMAX_IC,NGLOB2DMAX_YMIN_YMAX_IC,NGLOB1D_RADIAL_inner_core
+ integer NPROC_XI,NPROC_ETA,NGLOB2DMAX_XY
+ integer NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS
+
+! for addressing of the slices
+ integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1) :: addressing
+
+! 2-D addressing and buffers for summation between slices
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_CM) :: iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_CM) :: iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_IC) :: iboolleft_xi_inner_core,iboolright_xi_inner_core
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_IC) :: iboolleft_eta_inner_core,iboolright_eta_inner_core
+
+! indirect addressing for each corner of the chunks
+ integer, dimension(NGLOB1D_RADIAL_crust_mantle,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
+ integer, dimension(NGLOB1D_RADIAL_inner_core,NUMCORNERS_SHARED) :: iboolcorner_inner_core
+ integer icount_corners
+
+ integer :: npoin2D_max_all
+ integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces_crust_mantle,iboolfaces_inner_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all) :: buffer_send_faces_vector,buffer_received_faces_vector
+
+! buffers for send and receive between corners of the chunks
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB1D_RADIAL_crust_mantle + NGLOB1D_RADIAL_inner_core) :: &
+ buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector
+
+! ---- arrays to assemble between chunks
+
+! communication pattern for faces between chunks
+ integer, dimension(NUMMSGS_FACES) :: iprocfrom_faces,iprocto_faces,imsg_type
+
+! communication pattern for corners between chunks
+ integer, dimension(NCORNERSCHUNKS) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
+
+! MPI status of messages to be received
+ integer msg_status(MPI_STATUS_SIZE)
+
+ integer ipoin,ipoin2D,ipoin1D
+ integer sender,receiver,ier
+ integer imsg,imsg_loop
+ integer icount_faces,npoin2D_chunks_all
+
+ integer :: npoin2D_xi_all,npoin2D_eta_all,NGLOB1D_RADIAL_all,ioffset
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! check flag to see if we need to assemble (might be turned off when debugging)
+ if (.not. ACTUALLY_ASSEMBLE_MPI_SLICES) return
+
+! here we have to assemble all the contributions between slices using MPI
+
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ npoin2D_xi_all = npoin2D_xi_crust_mantle + npoin2D_xi_inner_core
+ npoin2D_eta_all = npoin2D_eta_crust_mantle + npoin2D_eta_inner_core
+
+!----
+!---- assemble the contributions between slices using MPI
+!----
+
+!----
+!---- first assemble along xi using the 2-D topology
+!----
+
+! assemble along xi only if more than one slice
+ if(NPROC_XI > 1) then
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_xi_crust_mantle
+
+! slices copy the right face into the buffer
+ do ipoin = 1,npoin2D_xi_crust_mantle
+ buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(1,iboolright_xi_crust_mantle(ipoin))
+ buffer_send_faces_vector(2,ipoin) = accel_crust_mantle(2,iboolright_xi_crust_mantle(ipoin))
+ buffer_send_faces_vector(3,ipoin) = accel_crust_mantle(3,iboolright_xi_crust_mantle(ipoin))
+ enddo
+
+ do ipoin = 1,npoin2D_xi_inner_core
+ buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(1,iboolright_xi_inner_core(ipoin))
+ buffer_send_faces_vector(2,ioffset + ipoin) = accel_inner_core(2,iboolright_xi_inner_core(ipoin))
+ buffer_send_faces_vector(3,ioffset + ipoin) = accel_inner_core(3,iboolright_xi_inner_core(ipoin))
+ enddo
+
+! send messages forward along each row
+ if(iproc_xi == 0) then
+ sender = MPI_PROC_NULL
+ else
+ sender = addressing(ichunk,iproc_xi - 1,iproc_eta)
+ endif
+ if(iproc_xi == NPROC_XI-1) then
+ receiver = MPI_PROC_NULL
+ else
+ receiver = addressing(ichunk,iproc_xi + 1,iproc_eta)
+ endif
+ call MPI_SENDRECV(buffer_send_faces_vector,NDIM*npoin2D_xi_all,CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_vector,NDIM*npoin2D_xi_all,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+
+! all slices add the buffer received to the contributions on the left face
+ if(iproc_xi > 0) then
+
+ do ipoin = 1,npoin2D_xi_crust_mantle
+ accel_crust_mantle(1,iboolleft_xi_crust_mantle(ipoin)) = accel_crust_mantle(1,iboolleft_xi_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(1,ipoin)
+ accel_crust_mantle(2,iboolleft_xi_crust_mantle(ipoin)) = accel_crust_mantle(2,iboolleft_xi_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(2,ipoin)
+ accel_crust_mantle(3,iboolleft_xi_crust_mantle(ipoin)) = accel_crust_mantle(3,iboolleft_xi_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(3,ipoin)
+ enddo
+
+ do ipoin = 1,npoin2D_xi_inner_core
+ accel_inner_core(1,iboolleft_xi_inner_core(ipoin)) = accel_inner_core(1,iboolleft_xi_inner_core(ipoin)) + &
+ buffer_received_faces_vector(1,ioffset + ipoin)
+ accel_inner_core(2,iboolleft_xi_inner_core(ipoin)) = accel_inner_core(2,iboolleft_xi_inner_core(ipoin)) + &
+ buffer_received_faces_vector(2,ioffset + ipoin)
+ accel_inner_core(3,iboolleft_xi_inner_core(ipoin)) = accel_inner_core(3,iboolleft_xi_inner_core(ipoin)) + &
+ buffer_received_faces_vector(3,ioffset + ipoin)
+ enddo
+
+ endif
+
+! the contributions are correctly assembled on the left side of each slice
+! now we have to send the result back to the sender
+! all slices copy the left face into the buffer
+ do ipoin = 1,npoin2D_xi_crust_mantle
+ buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(1,iboolleft_xi_crust_mantle(ipoin))
+ buffer_send_faces_vector(2,ipoin) = accel_crust_mantle(2,iboolleft_xi_crust_mantle(ipoin))
+ buffer_send_faces_vector(3,ipoin) = accel_crust_mantle(3,iboolleft_xi_crust_mantle(ipoin))
+ enddo
+
+ do ipoin = 1,npoin2D_xi_inner_core
+ buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(1,iboolleft_xi_inner_core(ipoin))
+ buffer_send_faces_vector(2,ioffset + ipoin) = accel_inner_core(2,iboolleft_xi_inner_core(ipoin))
+ buffer_send_faces_vector(3,ioffset + ipoin) = accel_inner_core(3,iboolleft_xi_inner_core(ipoin))
+ enddo
+
+! send messages backward along each row
+ if(iproc_xi == NPROC_XI-1) then
+ sender = MPI_PROC_NULL
+ else
+ sender = addressing(ichunk,iproc_xi + 1,iproc_eta)
+ endif
+ if(iproc_xi == 0) then
+ receiver = MPI_PROC_NULL
+ else
+ receiver = addressing(ichunk,iproc_xi - 1,iproc_eta)
+ endif
+ call MPI_SENDRECV(buffer_send_faces_vector,NDIM*npoin2D_xi_all,CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_vector,NDIM*npoin2D_xi_all,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+
+! all slices copy the buffer received to the contributions on the right face
+ if(iproc_xi < NPROC_XI-1) then
+
+ do ipoin = 1,npoin2D_xi_crust_mantle
+ accel_crust_mantle(1,iboolright_xi_crust_mantle(ipoin)) = buffer_received_faces_vector(1,ipoin)
+ accel_crust_mantle(2,iboolright_xi_crust_mantle(ipoin)) = buffer_received_faces_vector(2,ipoin)
+ accel_crust_mantle(3,iboolright_xi_crust_mantle(ipoin)) = buffer_received_faces_vector(3,ipoin)
+ enddo
+
+ do ipoin = 1,npoin2D_xi_inner_core
+ accel_inner_core(1,iboolright_xi_inner_core(ipoin)) = buffer_received_faces_vector(1,ioffset + ipoin)
+ accel_inner_core(2,iboolright_xi_inner_core(ipoin)) = buffer_received_faces_vector(2,ioffset + ipoin)
+ accel_inner_core(3,iboolright_xi_inner_core(ipoin)) = buffer_received_faces_vector(3,ioffset + ipoin)
+ enddo
+
+ endif
+
+ endif
+
+!----
+!---- then assemble along eta using the 2-D topology
+!----
+
+! assemble along eta only if more than one slice
+ if(NPROC_ETA > 1) then
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_eta_crust_mantle
+
+! slices copy the right face into the buffer
+ do ipoin = 1,npoin2D_eta_crust_mantle
+ buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(1,iboolright_eta_crust_mantle(ipoin))
+ buffer_send_faces_vector(2,ipoin) = accel_crust_mantle(2,iboolright_eta_crust_mantle(ipoin))
+ buffer_send_faces_vector(3,ipoin) = accel_crust_mantle(3,iboolright_eta_crust_mantle(ipoin))
+ enddo
+
+ do ipoin = 1,npoin2D_eta_inner_core
+ buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(1,iboolright_eta_inner_core(ipoin))
+ buffer_send_faces_vector(2,ioffset + ipoin) = accel_inner_core(2,iboolright_eta_inner_core(ipoin))
+ buffer_send_faces_vector(3,ioffset + ipoin) = accel_inner_core(3,iboolright_eta_inner_core(ipoin))
+ enddo
+
+! send messages forward along each row
+ if(iproc_eta == 0) then
+ sender = MPI_PROC_NULL
+ else
+ sender = addressing(ichunk,iproc_xi,iproc_eta - 1)
+ endif
+ if(iproc_eta == NPROC_ETA-1) then
+ receiver = MPI_PROC_NULL
+ else
+ receiver = addressing(ichunk,iproc_xi,iproc_eta + 1)
+ endif
+ call MPI_SENDRECV(buffer_send_faces_vector,NDIM*npoin2D_eta_all,CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_vector,NDIM*npoin2D_eta_all,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+
+! all slices add the buffer received to the contributions on the left face
+ if(iproc_eta > 0) then
+
+ do ipoin = 1,npoin2D_eta_crust_mantle
+ accel_crust_mantle(1,iboolleft_eta_crust_mantle(ipoin)) = accel_crust_mantle(1,iboolleft_eta_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(1,ipoin)
+ accel_crust_mantle(2,iboolleft_eta_crust_mantle(ipoin)) = accel_crust_mantle(2,iboolleft_eta_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(2,ipoin)
+ accel_crust_mantle(3,iboolleft_eta_crust_mantle(ipoin)) = accel_crust_mantle(3,iboolleft_eta_crust_mantle(ipoin)) + &
+ buffer_received_faces_vector(3,ipoin)
+ enddo
+
+ do ipoin = 1,npoin2D_eta_inner_core
+ accel_inner_core(1,iboolleft_eta_inner_core(ipoin)) = accel_inner_core(1,iboolleft_eta_inner_core(ipoin)) + &
+ buffer_received_faces_vector(1,ioffset + ipoin)
+ accel_inner_core(2,iboolleft_eta_inner_core(ipoin)) = accel_inner_core(2,iboolleft_eta_inner_core(ipoin)) + &
+ buffer_received_faces_vector(2,ioffset + ipoin)
+ accel_inner_core(3,iboolleft_eta_inner_core(ipoin)) = accel_inner_core(3,iboolleft_eta_inner_core(ipoin)) + &
+ buffer_received_faces_vector(3,ioffset + ipoin)
+ enddo
+
+ endif
+
+! the contributions are correctly assembled on the left side of each slice
+! now we have to send the result back to the sender
+! all slices copy the left face into the buffer
+ do ipoin = 1,npoin2D_eta_crust_mantle
+ buffer_send_faces_vector(1,ipoin) = accel_crust_mantle(1,iboolleft_eta_crust_mantle(ipoin))
+ buffer_send_faces_vector(2,ipoin) = accel_crust_mantle(2,iboolleft_eta_crust_mantle(ipoin))
+ buffer_send_faces_vector(3,ipoin) = accel_crust_mantle(3,iboolleft_eta_crust_mantle(ipoin))
+ enddo
+
+ do ipoin = 1,npoin2D_eta_inner_core
+ buffer_send_faces_vector(1,ioffset + ipoin) = accel_inner_core(1,iboolleft_eta_inner_core(ipoin))
+ buffer_send_faces_vector(2,ioffset + ipoin) = accel_inner_core(2,iboolleft_eta_inner_core(ipoin))
+ buffer_send_faces_vector(3,ioffset + ipoin) = accel_inner_core(3,iboolleft_eta_inner_core(ipoin))
+ enddo
+
+! send messages backward along each row
+ if(iproc_eta == NPROC_ETA-1) then
+ sender = MPI_PROC_NULL
+ else
+ sender = addressing(ichunk,iproc_xi,iproc_eta + 1)
+ endif
+ if(iproc_eta == 0) then
+ receiver = MPI_PROC_NULL
+ else
+ receiver = addressing(ichunk,iproc_xi,iproc_eta - 1)
+ endif
+ call MPI_SENDRECV(buffer_send_faces_vector,NDIM*npoin2D_eta_all,CUSTOM_MPI_TYPE,receiver, &
+ itag2,buffer_received_faces_vector,NDIM*npoin2D_eta_all,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+
+! all slices copy the buffer received to the contributions on the right face
+ if(iproc_eta < NPROC_ETA-1) then
+
+ do ipoin = 1,npoin2D_eta_crust_mantle
+ accel_crust_mantle(1,iboolright_eta_crust_mantle(ipoin)) = buffer_received_faces_vector(1,ipoin)
+ accel_crust_mantle(2,iboolright_eta_crust_mantle(ipoin)) = buffer_received_faces_vector(2,ipoin)
+ accel_crust_mantle(3,iboolright_eta_crust_mantle(ipoin)) = buffer_received_faces_vector(3,ipoin)
+ enddo
+
+ do ipoin = 1,npoin2D_eta_inner_core
+ accel_inner_core(1,iboolright_eta_inner_core(ipoin)) = buffer_received_faces_vector(1,ioffset + ipoin)
+ accel_inner_core(2,iboolright_eta_inner_core(ipoin)) = buffer_received_faces_vector(2,ioffset + ipoin)
+ accel_inner_core(3,iboolright_eta_inner_core(ipoin)) = buffer_received_faces_vector(3,ioffset + ipoin)
+ enddo
+
+ endif
+
+ endif
+
+!----
+!---- start MPI assembling phase between chunks
+!----
+
+! check flag to see if we need to assemble (might be turned off when debugging)
+! and do not assemble if only one chunk
+ if (.not. ACTUALLY_ASSEMBLE_MPI_CHUNKS .or. NCHUNKS == 1) return
+
+! ***************************************************************
+! transmit messages in forward direction (iprocfrom -> iprocto)
+! ***************************************************************
+
+!---- put slices in receive mode
+!---- a given slice can belong to at most two faces
+
+! use three step scheme that can never deadlock
+! scheme for faces cannot deadlock even if NPROC_XI = NPROC_ETA = 1
+ do imsg_loop = 1,NUM_MSG_TYPES
+
+ icount_faces = 0
+ do imsg = 1,NUMMSGS_FACES
+ if(myrank==iprocfrom_faces(imsg) .or. &
+ myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
+ if(myrank==iprocto_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
+ sender = iprocfrom_faces(imsg)
+
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ npoin2D_chunks_all = npoin2D_faces_crust_mantle(icount_faces) + npoin2D_faces_inner_core(icount_faces)
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_faces_crust_mantle(icount_faces)
+
+ call MPI_RECV(buffer_received_faces_vector,NDIM*npoin2D_chunks_all,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+
+ do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
+ accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = &
+ accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) + buffer_received_faces_vector(1,ipoin2D)
+ accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = &
+ accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces)) + buffer_received_faces_vector(2,ipoin2D)
+ accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = &
+ accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces)) + buffer_received_faces_vector(3,ipoin2D)
+ enddo
+
+ do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
+ accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
+ accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) + buffer_received_faces_vector(1,ioffset + ipoin2D)
+ accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
+ accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces)) + buffer_received_faces_vector(2,ioffset + ipoin2D)
+ accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces)) = &
+ accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces)) + buffer_received_faces_vector(3,ioffset + ipoin2D)
+ enddo
+
+ endif
+ enddo
+
+!---- put slices in send mode
+!---- a given slice can belong to at most two faces
+ icount_faces = 0
+ do imsg = 1,NUMMSGS_FACES
+ if(myrank==iprocfrom_faces(imsg) .or. &
+ myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
+ if(myrank==iprocfrom_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
+ receiver = iprocto_faces(imsg)
+
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ npoin2D_chunks_all = npoin2D_faces_crust_mantle(icount_faces) + npoin2D_faces_inner_core(icount_faces)
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_faces_crust_mantle(icount_faces)
+
+ do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
+ buffer_send_faces_vector(1,ipoin2D) = accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ buffer_send_faces_vector(2,ipoin2D) = accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ buffer_send_faces_vector(3,ipoin2D) = accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ enddo
+
+ do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
+ buffer_send_faces_vector(1,ioffset + ipoin2D) = accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces))
+ buffer_send_faces_vector(2,ioffset + ipoin2D) = accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces))
+ buffer_send_faces_vector(3,ioffset + ipoin2D) = accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces))
+ enddo
+
+ call MPI_SEND(buffer_send_faces_vector,NDIM*npoin2D_chunks_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+
+ endif
+ enddo
+
+
+! *********************************************************************
+! transmit messages back in opposite direction (iprocto -> iprocfrom)
+! *********************************************************************
+
+!---- put slices in receive mode
+!---- a given slice can belong to at most two faces
+
+ icount_faces = 0
+ do imsg = 1,NUMMSGS_FACES
+ if(myrank==iprocfrom_faces(imsg) .or. &
+ myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
+ if(myrank==iprocfrom_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
+ sender = iprocto_faces(imsg)
+
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ npoin2D_chunks_all = npoin2D_faces_crust_mantle(icount_faces) + npoin2D_faces_inner_core(icount_faces)
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_faces_crust_mantle(icount_faces)
+
+ call MPI_RECV(buffer_received_faces_vector,NDIM*npoin2D_chunks_all,CUSTOM_MPI_TYPE,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+
+ do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
+ accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(1,ipoin2D)
+ accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(2,ipoin2D)
+ accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces)) = buffer_received_faces_vector(3,ipoin2D)
+ enddo
+
+ do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
+ accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces)) = buffer_received_faces_vector(1,ioffset + ipoin2D)
+ accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces)) = buffer_received_faces_vector(2,ioffset + ipoin2D)
+ accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces)) = buffer_received_faces_vector(3,ioffset + ipoin2D)
+ enddo
+
+ endif
+ enddo
+
+!---- put slices in send mode
+!---- a given slice can belong to at most two faces
+ icount_faces = 0
+ do imsg = 1,NUMMSGS_FACES
+ if(myrank==iprocfrom_faces(imsg) .or. &
+ myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
+ if(myrank==iprocto_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
+ receiver = iprocfrom_faces(imsg)
+
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ npoin2D_chunks_all = npoin2D_faces_crust_mantle(icount_faces) + npoin2D_faces_inner_core(icount_faces)
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = npoin2D_faces_crust_mantle(icount_faces)
+
+ do ipoin2D = 1,npoin2D_faces_crust_mantle(icount_faces)
+ buffer_send_faces_vector(1,ipoin2D) = accel_crust_mantle(1,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ buffer_send_faces_vector(2,ipoin2D) = accel_crust_mantle(2,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ buffer_send_faces_vector(3,ipoin2D) = accel_crust_mantle(3,iboolfaces_crust_mantle(ipoin2D,icount_faces))
+ enddo
+
+ do ipoin2D = 1,npoin2D_faces_inner_core(icount_faces)
+ buffer_send_faces_vector(1,ioffset + ipoin2D) = accel_inner_core(1,iboolfaces_inner_core(ipoin2D,icount_faces))
+ buffer_send_faces_vector(2,ioffset + ipoin2D) = accel_inner_core(2,iboolfaces_inner_core(ipoin2D,icount_faces))
+ buffer_send_faces_vector(3,ioffset + ipoin2D) = accel_inner_core(3,iboolfaces_inner_core(ipoin2D,icount_faces))
+ enddo
+
+ call MPI_SEND(buffer_send_faces_vector,NDIM*npoin2D_chunks_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+
+ endif
+ enddo
+
+! end of anti-deadlocking loop
+ enddo
+
+
+!----
+!---- start MPI assembling corners
+!----
+
+! scheme for corners cannot deadlock even if NPROC_XI = NPROC_ETA = 1
+
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ NGLOB1D_RADIAL_all = NGLOB1D_RADIAL_crust_mantle + NGLOB1D_RADIAL_inner_core
+
+! the buffer for the inner core starts right after the buffer for the crust and mantle
+ ioffset = NGLOB1D_RADIAL_crust_mantle
+
+! ***************************************************************
+! transmit messages in forward direction (two workers -> master)
+! ***************************************************************
+
+ icount_corners = 0
+
+ do imsg = 1,NCORNERSCHUNKS
+
+ if(myrank == iproc_master_corners(imsg) .or. &
+ myrank == iproc_worker1_corners(imsg) .or. &
+ (NCHUNKS /= 2 .and. myrank == iproc_worker2_corners(imsg))) icount_corners = icount_corners + 1
+
+!---- receive messages from the two workers on the master
+ if(myrank==iproc_master_corners(imsg)) then
+
+! receive from worker #1 and add to local array
+ sender = iproc_worker1_corners(imsg)
+
+ call MPI_RECV(buffer_recv_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all, &
+ CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_crust_mantle
+ accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
+ accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(1,ipoin1D)
+ accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
+ accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(2,ipoin1D)
+ accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
+ accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(3,ipoin1D)
+ enddo
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
+ accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
+ accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(1,ioffset + ipoin1D)
+ accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
+ accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(2,ioffset + ipoin1D)
+ accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
+ accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(3,ioffset + ipoin1D)
+ enddo
+
+! receive from worker #2 and add to local array
+ if(NCHUNKS /= 2) then
+
+ sender = iproc_worker2_corners(imsg)
+
+ call MPI_RECV(buffer_recv_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all, &
+ CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_crust_mantle
+ accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
+ accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(1,ipoin1D)
+ accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
+ accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(2,ipoin1D)
+ accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = &
+ accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(3,ipoin1D)
+ enddo
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
+ accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
+ accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(1,ioffset + ipoin1D)
+ accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
+ accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(2,ioffset + ipoin1D)
+ accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) = &
+ accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) + &
+ buffer_recv_chunkcorners_vector(3,ioffset + ipoin1D)
+ enddo
+
+ endif
+
+ endif
+
+!---- send messages from the two workers to the master
+ if(myrank==iproc_worker1_corners(imsg) .or. &
+ (NCHUNKS /= 2 .and. myrank==iproc_worker2_corners(imsg))) then
+
+ receiver = iproc_master_corners(imsg)
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_crust_mantle
+ buffer_send_chunkcorners_vector(1,ipoin1D) = accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ buffer_send_chunkcorners_vector(2,ipoin1D) = accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ buffer_send_chunkcorners_vector(3,ipoin1D) = accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ enddo
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
+ buffer_send_chunkcorners_vector(1,ioffset + ipoin1D) = accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners))
+ buffer_send_chunkcorners_vector(2,ioffset + ipoin1D) = accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners))
+ buffer_send_chunkcorners_vector(3,ioffset + ipoin1D) = accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners))
+ enddo
+
+ call MPI_SEND(buffer_send_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+
+ endif
+
+! *********************************************************************
+! transmit messages back in opposite direction (master -> two workers)
+! *********************************************************************
+
+!---- receive messages from the master on the two workers
+ if(myrank==iproc_worker1_corners(imsg) .or. &
+ (NCHUNKS /= 2 .and. myrank==iproc_worker2_corners(imsg))) then
+
+! receive from master and copy to local array
+ sender = iproc_master_corners(imsg)
+
+ call MPI_RECV(buffer_recv_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all, &
+ CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_crust_mantle
+ accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(1,ipoin1D)
+ accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(2,ipoin1D)
+ accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(3,ipoin1D)
+ enddo
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
+ accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(1,ioffset + ipoin1D)
+ accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(2,ioffset + ipoin1D)
+ accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners)) = buffer_recv_chunkcorners_vector(3,ioffset + ipoin1D)
+ enddo
+
+ endif
+
+!---- send messages from the master to the two workers
+ if(myrank==iproc_master_corners(imsg)) then
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_crust_mantle
+ buffer_send_chunkcorners_vector(1,ipoin1D) = accel_crust_mantle(1,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ buffer_send_chunkcorners_vector(2,ipoin1D) = accel_crust_mantle(2,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ buffer_send_chunkcorners_vector(3,ipoin1D) = accel_crust_mantle(3,iboolcorner_crust_mantle(ipoin1D,icount_corners))
+ enddo
+
+ do ipoin1D = 1,NGLOB1D_RADIAL_inner_core
+ buffer_send_chunkcorners_vector(1,ioffset + ipoin1D) = accel_inner_core(1,iboolcorner_inner_core(ipoin1D,icount_corners))
+ buffer_send_chunkcorners_vector(2,ioffset + ipoin1D) = accel_inner_core(2,iboolcorner_inner_core(ipoin1D,icount_corners))
+ buffer_send_chunkcorners_vector(3,ioffset + ipoin1D) = accel_inner_core(3,iboolcorner_inner_core(ipoin1D,icount_corners))
+ enddo
+
+! send to worker #1
+ receiver = iproc_worker1_corners(imsg)
+ call MPI_SEND(buffer_send_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+
+! send to worker #2
+ if(NCHUNKS /= 2) then
+ receiver = iproc_worker2_corners(imsg)
+ call MPI_SEND(buffer_send_chunkcorners_vector,NDIM*NGLOB1D_RADIAL_all,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+
+ endif
+
+ endif
+
+ enddo
+
+ end subroutine assemble_MPI_vector
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/attenuation_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/attenuation_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/attenuation_model.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,1904 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! This portion of the SPECFEM3D Code was written by:
+! Brian Savage while at
+! California Institute of Technology
+! Department of Terrestrial Magnetism / Carnegie Institute of Washington
+! Univeristy of Rhode Island
+!
+! <savage at uri.edu>.
+! <savage13 at gps.caltech.edu>
+! <savage13 at dtm.ciw.edu>
+!
+! It is based upon formulation in the following references:
+!
+! Dahlen and Tromp, 1998
+! Theoretical Global Seismology
+!
+! Liu et al. 1976
+! Velocity dispersion due to anelasticity: implications for seismology and mantle composition
+! Geophys, J. R. asts. Soc, Vol 47, pp. 41-58
+!
+! The methodology can be found in Savage and Tromp, 2006, unpublished
+!
+
+subroutine attenuation_lookup_value(i, r)
+
+ implicit none
+
+ include 'constants.h'
+
+ integer i
+ double precision r
+
+ r = dble(i) / TABLE_ATTENUATION
+
+end subroutine attenuation_lookup_value
+
+! This Subroutine is Hackish. It could probably all be moved to an input attenuation file.
+! Actually all the velocities, densities and attenuations could be moved to seperate input
+! files rather than be defined within the CODE
+!
+! All this subroutine does is define the Attenuation vs Radius and then Compute the Attenuation
+! Variables (tau_sigma and tau_epslion ( or tau_mu) )
+subroutine attenuation_model_setup(REFERENCE_1D_MODEL,RICB,RCMB,R670,R220,R80,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,AM_S,AS_V)
+
+ implicit none
+
+ include 'mpif.h'
+ include 'constants.h'
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+! model_1066a_variables
+ type model_1066a_variables
+ sequence
+ double precision, dimension(NR_1066A) :: radius_1066a
+ double precision, dimension(NR_1066A) :: density_1066a
+ double precision, dimension(NR_1066A) :: vp_1066a
+ double precision, dimension(NR_1066A) :: vs_1066a
+ double precision, dimension(NR_1066A) :: Qkappa_1066a
+ double precision, dimension(NR_1066A) :: Qmu_1066a
+ end type model_1066a_variables
+
+ type (model_1066a_variables) M1066a_V
+! model_1066a_variables
+
+! model_ak135_variables
+ type model_ak135_variables
+ sequence
+ double precision, dimension(NR_AK135) :: radius_ak135
+ double precision, dimension(NR_AK135) :: density_ak135
+ double precision, dimension(NR_AK135) :: vp_ak135
+ double precision, dimension(NR_AK135) :: vs_ak135
+ double precision, dimension(NR_AK135) :: Qkappa_ak135
+ double precision, dimension(NR_AK135) :: Qmu_ak135
+ end type model_ak135_variables
+
+ type (model_ak135_variables) Mak135_V
+! model_ak135_variables
+
+! model_ref_variables
+ type model_ref_variables
+ sequence
+ double precision, dimension(NR_REF) :: radius_ref
+ double precision, dimension(NR_REF) :: density_ref
+ double precision, dimension(NR_REF) :: vpv_ref
+ double precision, dimension(NR_REF) :: vph_ref
+ double precision, dimension(NR_REF) :: vsv_ref
+ double precision, dimension(NR_REF) :: vsh_ref
+ double precision, dimension(NR_REF) :: eta_ref
+ double precision, dimension(NR_REF) :: Qkappa_ref
+ double precision, dimension(NR_REF) :: Qmu_ref
+ end type model_ref_variables
+
+ type (model_ref_variables) Mref_V
+! model_ref_variables
+
+! sea1d_model_variables
+ type sea1d_model_variables
+ sequence
+ double precision, dimension(NR_SEA1D) :: radius_sea1d
+ double precision, dimension(NR_SEA1D) :: density_sea1d
+ double precision, dimension(NR_SEA1D) :: vp_sea1d
+ double precision, dimension(NR_SEA1D) :: vs_sea1d
+ double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
+ double precision, dimension(NR_SEA1D) :: Qmu_sea1d
+ end type sea1d_model_variables
+
+ type (sea1d_model_variables) SEA1DM_V
+! sea1d_model_variables
+
+! attenuation_model_storage
+ type attenuation_model_storage
+ sequence
+ integer Q_resolution
+ integer Q_max
+ double precision, dimension(:,:), pointer :: tau_e_storage
+ double precision, dimension(:), pointer :: Qmu_storage
+ end type attenuation_model_storage
+
+ type (attenuation_model_storage) AM_S
+! attenuation_model_storage
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+ integer myrank
+ integer REFERENCE_1D_MODEL
+ double precision RICB, RCMB, R670, R220, R80
+ double precision tau_e(N_SLS)
+
+ integer i,ier
+ double precision Qb
+ double precision R120
+
+ Qb = 57287.0d0
+ R120 = 6251.d3
+
+ call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ier)
+ if(myrank > 0) return
+
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
+ AM_V%Qn = 12
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
+ AM_V%Qn = 12
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
+ call define_model_ak135(.FALSE.,Mak135_V)
+ AM_V%Qn = NR_AK135
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
+ call define_model_1066a(.FALSE., M1066a_V)
+ AM_V%Qn = NR_1066A
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
+ call define_model_ref(Mref_V)
+ AM_V%Qn = NR_REF
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then
+ AM_V%Qn = 12
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
+ call define_model_sea1d(.FALSE., SEA1DM_V)
+ AM_V%Qn = NR_SEA1D
+ else
+ call exit_MPI(myrank, 'Reference 1D Model Not recognized')
+ endif
+
+ allocate(AM_V%Qr(AM_V%Qn))
+ allocate(AM_V%Qmu(AM_V%Qn))
+ allocate(AM_V%interval_Q(AM_V%Qn))
+ allocate(AM_V%Qtau_e(N_SLS,AM_V%Qn))
+
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
+ AM_V%Qr(:) = (/ 0.0d0, RICB, RICB, RCMB, RCMB, R670, R670, R220, R220, R80, R80, R_EARTH /)
+ AM_V%Qmu(:) = (/ 84.6d0, 84.6d0, 0.0d0, 0.0d0, 312.0d0, 312.0d0, 143.0d0, 143.0d0, 80.0d0, 80.0d0, 600.0d0, 600.0d0 /)
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
+ AM_V%Qr(:) = (/ 0.0d0, RICB, RICB, RCMB, RCMB, R670, R670, R220, R220, R120, R120, R_EARTH /)
+ AM_V%Qmu(:) = (/ 84.6d0, 84.6d0, 0.0d0, 0.0d0, 312.0d0, 312.0d0, 143.0d0, 143.0d0, 80.0d0, 80.0d0, 600.0d0, 600.0d0 /)
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
+ AM_V%Qr(:) = Mak135_V%radius_ak135(:)
+ AM_V%Qmu(:) = Mak135_V%Qmu_ak135(:)
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
+ AM_V%Qr(:) = M1066a_V%radius_1066a(:)
+ AM_V%Qmu(:) = M1066a_V%Qmu_1066a(:)
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_ref) then
+ AM_V%Qr(:) = Mref_V%radius_ref(:)
+ AM_V%Qmu(:) = Mref_V%Qmu_ref(:)
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then
+ AM_V%Qr(:) = (/ 0.0d0, RICB, RICB, RCMB, RCMB, R670, R670, R220, R220, R120, R120, R_EARTH /)
+ AM_V%Qmu(:) = (/ 84.6d0, 84.6d0, 0.0d0, 0.0d0, 312.0d0, 312.0d0, 143.0d0, 143.0d0, 80.0d0, 80.0d0, 600.0d0, 600.0d0 /)
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
+ AM_V%Qr(:) = SEA1DM_V%radius_sea1d(:)
+ AM_V%Qmu(:) = SEA1DM_V%Qmu_sea1d(:)
+ end if
+
+ do i = 1, AM_V%Qn
+ call attenuation_conversion(AM_V%Qmu(i), AM_V%QT_c_source, AM_V%Qtau_s, tau_e, AM_V, AM_S,AS_V)
+ AM_V%Qtau_e(:,i) = tau_e(:)
+ end do
+
+end subroutine attenuation_model_setup
+
+subroutine attenuation_save_arrays(prname, iregion_code, AM_V)
+
+ implicit none
+
+ include 'mpif.h'
+ include 'constants.h'
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+ integer iregion_code
+ character(len=150) prname
+ integer ier
+ integer myrank
+ integer, save :: first_time_called = 1
+
+ call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ier)
+ if(myrank == 0 .AND. iregion_code == IREGION_CRUST_MANTLE .AND. first_time_called == 1) then
+ first_time_called = 0
+ open(unit=27,file=prname(1:len_trim(prname))//'1D_Q.bin',status='unknown',form='unformatted')
+ write(27) AM_V%QT_c_source
+ write(27) AM_V%Qtau_s
+ write(27) AM_V%Qn
+ write(27) AM_V%Qr
+ write(27) AM_V%Qmu
+ write(27) AM_V%Qtau_e
+ close(27)
+ endif
+
+end subroutine attenuation_save_arrays
+
+subroutine attenuation_storage(Qmu, tau_e, rw, AM_S)
+
+ implicit none
+ include 'mpif.h'
+ include 'constants.h'
+
+! attenuation_model_storage
+ type attenuation_model_storage
+ sequence
+ integer Q_resolution
+ integer Q_max
+ double precision, dimension(:,:), pointer :: tau_e_storage
+ double precision, dimension(:), pointer :: Qmu_storage
+ end type attenuation_model_storage
+
+ type (attenuation_model_storage) AM_S
+! attenuation_model_storage
+
+ integer myrank, ier
+ double precision Qmu, Qmu_new
+ double precision, dimension(N_SLS) :: tau_e
+ integer rw
+
+ integer Qtmp
+ integer, save :: first_time_called = 1
+
+ if(first_time_called == 1) then
+ first_time_called = 0
+ AM_S%Q_resolution = 10**ATTENUATION_COMP_RESOLUTION
+ AM_S%Q_max = ATTENUATION_COMP_MAXIMUM
+ Qtmp = AM_S%Q_resolution * AM_S%Q_max
+ allocate(AM_S%tau_e_storage(N_SLS, Qtmp))
+ allocate(AM_S%Qmu_storage(Qtmp))
+ AM_S%Qmu_storage(:) = -1
+ endif
+
+ if(Qmu < 0.0d0 .OR. Qmu >= AM_S%Q_max) then
+ write(IMAIN,*) 'Error'
+ write(IMAIN,*) 'attenuation_conversion/storage()'
+ write(IMAIN,*) 'Attenuation Value out of Range: ', Qmu
+ write(IMAIN,*) 'Attenuation Value out of Range: Min, Max ', 0, AM_S%Q_max
+ call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ier)
+ call exit_MPI(myrank, 'Attenuation Value out of Range')
+ endif
+
+ if(rw > 0 .AND. Qmu == 0.0d0) then
+ Qmu = 0.0d0;
+ tau_e(:) = 0.0d0;
+ return
+ endif
+ ! Generate index for Storage Array
+ ! and Recast Qmu using this index
+ ! Accroding to Brian, use float
+ !Qtmp = Qmu * Q_resolution
+ !Qmu = Qtmp / Q_resolution;
+
+ !
+ Qtmp = Qmu * dble(AM_S%Q_resolution)
+ Qmu_new = dble(Qtmp) / dble(AM_S%Q_resolution)
+
+ if(rw > 0) then
+ ! READ
+ if(AM_S%Qmu_storage(Qtmp) > 0) then
+ ! READ SUCCESSFUL
+ tau_e(:) = AM_S%tau_e_storage(:, Qtmp)
+ Qmu = AM_S%Qmu_storage(Qtmp)
+ rw = 1
+ else
+ ! READ NOT SUCCESSFUL
+ rw = -1
+ endif
+ else
+ ! WRITE SUCCESSFUL
+ AM_S%tau_e_storage(:,Qtmp) = tau_e(:)
+ AM_S%Qmu_storage(Qtmp) = Qmu
+ rw = 1
+ endif
+
+end subroutine attenuation_storage
+
+subroutine attenuation_conversion(Qmu_in, T_c_source, tau_s, tau_e, AM_V, AM_S, AS_V)
+! includes min_period, max_period, and N_SLS
+
+ implicit none
+
+ include 'constants.h'
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+! attenuation_model_storage
+ type attenuation_model_storage
+ sequence
+ integer Q_resolution
+ integer Q_max
+ double precision, dimension(:,:), pointer :: tau_e_storage
+ double precision, dimension(:), pointer :: Qmu_storage
+ end type attenuation_model_storage
+
+ type (attenuation_model_storage) AM_S
+! attenuation_model_storage
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+ double precision Qmu_in, T_c_source
+ double precision, dimension(N_SLS) :: tau_s, tau_e
+
+ integer rw
+
+ ! READ
+ rw = 1
+ call attenuation_storage(Qmu_in, tau_e, rw, AM_S)
+ if(rw > 0) return
+
+ call attenuation_invert_by_simplex(AM_V%min_period, AM_V%max_period, N_SLS, Qmu_in, T_c_source, tau_s, tau_e, AS_V)
+
+ ! WRITE
+ rw = -1
+ call attenuation_storage(Qmu_in, tau_e, rw, AM_S)
+
+end subroutine attenuation_conversion
+
+subroutine read_attenuation_model(min, max, AM_V)
+
+ implicit none
+
+ include 'constants.h'
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+ integer min, max
+
+ AM_V%min_period = min * 1.0d0
+ AM_V%max_period = max * 1.0d0
+
+ allocate(AM_V%Qtau_s(N_SLS))
+
+ call attenuation_tau_sigma(AM_V%Qtau_s, N_SLS, AM_V%min_period, AM_V%max_period)
+ call attenuation_source_frequency(AM_V%QT_c_source, AM_V%min_period, AM_V%max_period)
+
+end subroutine read_attenuation_model
+
+subroutine attenuation_memory_values(tau_s, deltat, alphaval,betaval,gammaval)
+
+ implicit none
+
+ include 'constants.h'
+
+ double precision, dimension(N_SLS) :: tau_s, alphaval, betaval,gammaval
+ real(kind=CUSTOM_REAL) deltat
+
+ double precision, dimension(N_SLS) :: tauinv
+
+ tauinv(:) = - 1.0 / tau_s(:)
+
+ alphaval(:) = 1 + deltat*tauinv(:) + deltat**2*tauinv(:)**2 / 2. + &
+ deltat**3*tauinv(:)**3 / 6. + deltat**4*tauinv(:)**4 / 24.
+ betaval(:) = deltat / 2. + deltat**2*tauinv(:) / 3. + deltat**3*tauinv(:)**2 / 8. + deltat**4*tauinv(:)**3 / 24.
+ gammaval(:) = deltat / 2. + deltat**2*tauinv(:) / 6. + deltat**3*tauinv(:)**2 / 24.0
+
+end subroutine attenuation_memory_values
+
+subroutine attenuation_scale_factor(myrank, T_c_source, tau_mu, tau_sigma, Q_mu, scale_factor)
+
+ implicit none
+
+ include 'constants.h'
+
+ integer myrank
+ double precision scale_factor, Q_mu, T_c_source
+ double precision, dimension(N_SLS) :: tau_mu, tau_sigma
+
+ double precision scale_t
+ double precision f_c_source, w_c_source, f_0_prem
+ double precision factor_scale_mu0, factor_scale_mu
+ double precision a_val, b_val
+ double precision big_omega
+ integer i
+
+ scale_t = ONE/dsqrt(PI*GRAV*RHOAV)
+
+!--- compute central angular frequency of source (non dimensionalized)
+ f_c_source = ONE / T_c_source
+ w_c_source = TWO_PI * f_c_source
+
+!--- non dimensionalize PREM reference of 1 second
+ f_0_prem = ONE / ( ONE / scale_t)
+
+!--- quantity by which to scale mu_0 to get mu
+! this formula can be found for instance in
+! Liu, H. P., Anderson, D. L. and Kanamori, H., Velocity dispersion due to
+! anelasticity: implications for seismology and mantle composition,
+! Geophys. J. R. Astron. Soc., vol. 47, pp. 41-58 (1976)
+! and in Aki, K. and Richards, P. G., Quantitative seismology, theory and methods,
+! W. H. Freeman, (1980), second edition, sections 5.5 and 5.5.2, eq. (5.81) p. 170
+ factor_scale_mu0 = ONE + TWO * log(f_c_source / f_0_prem) / (PI * Q_mu)
+
+!--- compute a, b and Omega parameters, also compute one minus sum of betas
+ a_val = ONE
+ b_val = ZERO
+
+ do i = 1,N_SLS
+ a_val = a_val - w_c_source * w_c_source * tau_mu(i) * &
+ (tau_mu(i) - tau_sigma(i)) / (1.d0 + w_c_source * w_c_source * tau_mu(i) * tau_mu(i))
+ b_val = b_val + w_c_source * (tau_mu(i) - tau_sigma(i)) / &
+ (1.d0 + w_c_source * w_c_source * tau_mu(i) * tau_mu(i))
+ enddo
+
+ big_omega = a_val*(sqrt(1.d0 + b_val*b_val/(a_val*a_val))-1.d0)
+
+!--- quantity by which to scale mu to get mu_relaxed
+ factor_scale_mu = b_val * b_val / (TWO * big_omega)
+
+!--- total factor by which to scale mu0
+ scale_factor = factor_scale_mu * factor_scale_mu0
+
+!--- check that the correction factor is close to one
+ if(scale_factor < 0.9 .or. scale_factor > 1.1) then
+ write(*,*)'scale factor: ', scale_factor
+ call exit_MPI(myrank,'incorrect correction factor in attenuation model')
+ endif
+
+end subroutine attenuation_scale_factor
+
+!----
+
+subroutine attenuation_property_values(tau_s, tau_e, factor_common, one_minus_sum_beta)
+
+ implicit none
+
+ include 'constants.h'
+
+ double precision, dimension(N_SLS) :: tau_s, tau_e, beta, factor_common
+ double precision one_minus_sum_beta
+
+ double precision, dimension(N_SLS) :: tauinv
+ integer i
+
+ tauinv(:) = -1.0d0 / tau_s(:)
+
+ beta(:) = 1.0d0 - tau_e(:) / tau_s(:)
+ one_minus_sum_beta = 1.0d0
+
+ do i = 1,N_SLS
+ one_minus_sum_beta = one_minus_sum_beta - beta(i)
+ enddo
+
+ factor_common(:) = 2.0d0 * beta(:) * tauinv(:)
+
+end subroutine attenuation_property_values
+
+!---
+!---
+!---
+
+subroutine get_attenuation_model_1D(myrank, prname, iregion_code, tau_s, one_minus_sum_beta, &
+ factor_common, scale_factor, vn,vx,vy,vz, AM_V)
+
+ implicit none
+
+ include 'mpif.h'
+ include 'constants.h'
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+ integer myrank, iregion_code
+ character(len=150) prname
+ integer vn, vx,vy,vz
+ double precision, dimension(N_SLS) :: tau_s
+ double precision, dimension(vx,vy,vz,vn) :: scale_factor, one_minus_sum_beta
+ double precision, dimension(N_SLS, vx,vy,vz,vn) :: factor_common
+
+ integer i,j,ier,rmax
+ double precision scale_t
+ double precision Qp1, Qpn, radius, fctmp
+ double precision, dimension(:), allocatable :: Qfctmp, Qfc2tmp
+
+ integer, save :: first_time_called = 1
+
+ if(myrank == 0 .AND. iregion_code == IREGION_CRUST_MANTLE .AND. first_time_called == 1) then
+ first_time_called = 0
+ open(unit=27, file=prname(1:len_trim(prname))//'1D_Q.bin', status='unknown', form='unformatted')
+ read(27) AM_V%QT_c_source
+ read(27) tau_s
+ read(27) AM_V%Qn
+
+ allocate(AM_V%Qr(AM_V%Qn))
+ allocate(AM_V%Qmu(AM_V%Qn))
+ allocate(AM_V%Qtau_e(N_SLS,AM_V%Qn))
+
+ read(27) AM_V%Qr
+ read(27) AM_V%Qmu
+ read(27) AM_V%Qtau_e
+ close(27)
+ endif
+
+ ! Synch up after the Read
+ call MPI_BCAST(AM_V%QT_c_source,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(tau_s,N_SLS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(AM_V%Qn,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ if(myrank /= 0) then
+ allocate(AM_V%Qr(AM_V%Qn))
+ allocate(AM_V%Qmu(AM_V%Qn))
+ allocate(AM_V%Qtau_e(N_SLS,AM_V%Qn))
+ endif
+
+ call MPI_BCAST(AM_V%Qr,AM_V%Qn,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(AM_V%Qmu,AM_V%Qn,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(AM_V%Qtau_e,AM_V%Qn*N_SLS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ scale_t = ONE/dsqrt(PI*GRAV*RHOAV)
+
+ ! Scale the Attenuation Values
+ tau_s(:) = tau_s(:) / scale_t
+ AM_V%Qtau_e(:,:) = AM_V%Qtau_e(:,:) / scale_t
+ AM_V%QT_c_source = 1000.0d0 / AM_V%QT_c_source / scale_t
+ AM_V%Qr(:) = AM_V%Qr(:) / R_EARTH
+
+ allocate(AM_V%Qsf(AM_V%Qn))
+ allocate(AM_V%Qomsb(AM_V%Qn))
+ allocate(AM_V%Qfc(N_SLS,AM_V%Qn))
+
+ allocate(AM_V%Qsf2(AM_V%Qn))
+ allocate(AM_V%Qomsb2(AM_V%Qn))
+ allocate(AM_V%Qfc2(N_SLS,AM_V%Qn))
+
+ allocate(AM_V%interval_Q(AM_V%Qn))
+
+ allocate(Qfctmp(AM_V%Qn))
+ allocate(Qfc2tmp(AM_V%Qn))
+
+ do i = 1,AM_V%Qn
+ if(AM_V%Qmu(i) == 0.0d0) then
+ AM_V%Qomsb(i) = 0.0d0
+ AM_V%Qfc(:,i) = 0.0d0
+ AM_V%Qsf(i) = 0.0d0
+ else
+ call attenuation_property_values(tau_s, AM_V%Qtau_e(:,i), AM_V%Qfc(:,i), AM_V%Qomsb(i))
+ call attenuation_scale_factor(myrank, AM_V%QT_c_source, AM_V%Qtau_e(:,i), tau_s, AM_V%Qmu(i), AM_V%Qsf(i))
+ endif
+ enddo
+
+ ! Determine the Spline Coefficients or Second Derivatives
+ call pspline_construction(AM_V%Qr, AM_V%Qsf, AM_V%Qn, Qp1, Qpn, AM_V%Qsf2, AM_V%interval_Q)
+ call pspline_construction(AM_V%Qr, AM_V%Qomsb, AM_V%Qn, Qp1, Qpn, AM_V%Qomsb2, AM_V%interval_Q)
+ do i = 1,N_SLS
+! copy the sub-arrays to temporary arrays to avoid a warning by some compilers
+! about temporary arrays being created automatically when using this expression
+! directly in the call to the subroutine
+ Qfctmp(:) = AM_V%Qfc(i,:)
+ Qfc2tmp(:) = AM_V%Qfc2(i,:)
+ call pspline_construction(AM_V%Qr, Qfctmp, AM_V%Qn, Qp1, Qpn, Qfc2tmp, AM_V%interval_Q)
+! copy the arrays back to the sub-arrays, since these sub-arrays are used
+! as input and output
+ AM_V%Qfc(i,:) = Qfctmp(:)
+ AM_V%Qfc2(i,:) = Qfc2tmp(:)
+ enddo
+
+ radius = 0.0d0
+ rmax = nint(TABLE_ATTENUATION)
+ do i = 1,rmax
+ call attenuation_lookup_value(i, radius)
+ call pspline_evaluation(AM_V%Qr, AM_V%Qsf, AM_V%Qsf2, AM_V%Qn, radius, scale_factor(1,1,1,i), AM_V%interval_Q)
+ call pspline_evaluation(AM_V%Qr, AM_V%Qomsb, AM_V%Qomsb2, AM_V%Qn, radius, one_minus_sum_beta(1,1,1,i), AM_V%interval_Q)
+ do j = 1,N_SLS
+ Qfctmp = AM_V%Qfc(j,:)
+ Qfc2tmp = AM_V%Qfc2(j,:)
+ call pspline_evaluation(AM_V%Qr, Qfctmp, Qfc2tmp, AM_V%Qn, radius, fctmp, AM_V%interval_Q)
+ factor_common(j,1,1,1,i) = fctmp
+ enddo
+ enddo
+ do i = rmax+1,NRAD_ATTENUATION
+ scale_factor(1,1,1,i) = scale_factor(1,1,1,rmax)
+ one_minus_sum_beta(1,1,1,i) = one_minus_sum_beta(1,1,1,rmax)
+ factor_common(1,1,1,1,i) = factor_common(1,1,1,1,rmax)
+ factor_common(2,1,1,1,i) = factor_common(2,1,1,1,rmax)
+ factor_common(3,1,1,1,i) = factor_common(3,1,1,1,rmax)
+ enddo
+
+ deallocate(AM_V%Qfc2)
+ deallocate(AM_V%Qsf2)
+ deallocate(AM_V%Qomsb2)
+ deallocate(AM_V%Qfc)
+ deallocate(AM_V%Qsf)
+ deallocate(AM_V%Qomsb)
+ deallocate(AM_V%Qtau_e)
+ deallocate(Qfctmp)
+ deallocate(Qfc2tmp)
+
+ call MPI_BARRIER(MPI_COMM_WORLD, ier)
+
+end subroutine get_attenuation_model_1D
+
+subroutine set_attenuation_regions_1D(RICB, RCMB, R670, R220, R80, AM_V)
+
+ implicit none
+
+ include 'constants.h'
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+ double precision RICB, RCMB, R670, R220, R80
+ integer i
+
+ allocate(AM_V%Qrmin(6))
+ allocate(AM_V%Qrmax(6))
+ allocate(AM_V%QrDisc(5))
+
+ AM_V%QrDisc(1) = RICB
+ AM_V%QrDisc(2) = RCMB
+ AM_V%QrDisc(3) = R670
+ AM_V%QrDisc(4) = R220
+ AM_V%QrDisc(5) = R80
+
+ ! INNER CORE
+ AM_V%Qrmin(IREGION_ATTENUATION_INNER_CORE) = 1 ! Center of the Earth
+ i = nint(RICB / 100.d0) ! === BOUNDARY === INNER CORE / OUTER CORE
+ AM_V%Qrmax(IREGION_ATTENUATION_INNER_CORE) = i - 1 ! Inner Core Boundary (Inner)
+
+ ! OUTER_CORE
+ AM_V%Qrmin(6) = i ! Inner Core Boundary (Outer)
+ i = nint(RCMB / 100.d0) ! === BOUNDARY === INNER CORE / OUTER CORE
+ AM_V%Qrmax(6) = i - 1
+
+ ! LOWER MANTLE
+ AM_V%Qrmin(IREGION_ATTENUATION_CMB_670) = i
+ i = nint(R670 / 100.d0) ! === BOUNDARY === 670 km
+ AM_V%Qrmax(IREGION_ATTENUATION_CMB_670) = i - 1
+
+ ! UPPER MANTLE
+ AM_V%Qrmin(IREGION_ATTENUATION_670_220) = i
+ i = nint(R220 / 100.d0) ! === BOUNDARY === 220 km
+ AM_V%Qrmax(IREGION_ATTENUATION_670_220) = i - 1
+
+ ! MANTLE ISH LITHOSPHERE
+ AM_V%Qrmin(IREGION_ATTENUATION_220_80) = i
+ i = nint(R80 / 100.d0) ! === BOUNDARY === 80 km
+ AM_V%Qrmax(IREGION_ATTENUATION_220_80) = i - 1
+
+ ! CRUST ISH LITHOSPHERE
+ AM_V%Qrmin(IREGION_ATTENUATION_80_SURFACE) = i
+ AM_V%Qrmax(IREGION_ATTENUATION_80_SURFACE) = NRAD_ATTENUATION
+
+end subroutine set_attenuation_regions_1D
+
+subroutine get_attenuation_index(iflag, radius, index, inner_core, AM_V)
+
+ implicit none
+
+ include 'constants.h'
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+ integer iflag, iregion, index
+ double precision radius
+
+ ! Inner Core or not
+ logical inner_core
+
+ index = nint(radius * TABLE_ATTENUATION)
+
+!! DK DK this seems incorrect and is difficult to read anyway
+!! DK DK therefore let me rewrite it better
+! if(inner_core) then
+! if(iflag >= IFLAG_INNER_CORE_NORMAL) then
+! iregion = IREGION_ATTENUATION_INNER_CORE
+! else if(iflag >= IFLAG_OUTER_CORE_NORMAL) then
+! iregion = 6
+! endif
+! else
+! if(iflag >= IFLAG_MANTLE_NORMAL) then
+! iregion = IREGION_ATTENUATION_CMB_670
+! else if(iflag == IFLAG_670_220) then
+! iregion = IREGION_ATTENUATION_670_220
+! else if(iflag <= IFLAG_220_80) then
+! iregion = IREGION_ATTENUATION_220_80
+! else
+! iregion = IREGION_ATTENUATION_80_SURFACE
+! endif
+! endif
+ if(inner_core) then
+
+ if(iflag == IFLAG_INNER_CORE_NORMAL .or. iflag == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ iflag == IFLAG_BOTTOM_CENTRAL_CUBE .or. iflag == IFLAG_TOP_CENTRAL_CUBE .or. &
+ iflag == IFLAG_IN_FICTITIOUS_CUBE) then
+ iregion = IREGION_ATTENUATION_INNER_CORE
+ else
+! this is fictitious for the outer core, which has no Qmu attenuation since it is fluid
+! iregion = IREGION_ATTENUATION_80_SURFACE + 1
+ iregion = IREGION_ATTENUATION_UNDEFINED
+ endif
+
+ else
+
+ if(iflag == IFLAG_MANTLE_NORMAL) then
+ iregion = IREGION_ATTENUATION_CMB_670
+ else if(iflag == IFLAG_670_220) then
+ iregion = IREGION_ATTENUATION_670_220
+ else if(iflag == IFLAG_220_80) then
+ iregion = IREGION_ATTENUATION_220_80
+ else if(iflag == IFLAG_CRUST .or. iflag == IFLAG_80_MOHO) then
+ iregion = IREGION_ATTENUATION_80_SURFACE
+ else
+! this is fictitious for the outer core, which has no Qmu attenuation since it is fluid
+! iregion = IREGION_ATTENUATION_80_SURFACE + 1
+ iregion = IREGION_ATTENUATION_UNDEFINED
+ endif
+
+ endif
+
+! Clamp regions
+ if(index < AM_V%Qrmin(iregion)) index = AM_V%Qrmin(iregion)
+ if(index > AM_V%Qrmax(iregion)) index = AM_V%Qrmax(iregion)
+
+end subroutine get_attenuation_index
+
+subroutine get_attenuation_model_3D(myrank, prname, one_minus_sum_beta, factor_common, scale_factor, tau_s, vnspec)
+
+ implicit none
+
+ include 'constants.h'
+
+ integer myrank, vnspec
+ character(len=150) prname
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,vnspec) :: one_minus_sum_beta, scale_factor
+ double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,vnspec) :: factor_common
+ double precision, dimension(N_SLS) :: tau_s
+
+ integer i,j,k,ispec
+
+ double precision, dimension(N_SLS) :: tau_e, fc
+ double precision omsb, Q_mu, sf, T_c_source, scale_t
+
+ ! All of the following reads use the output parameters as their temporary arrays
+ ! use the filename to determine the actual contents of the read
+
+ open(unit=27, file=prname(1:len_trim(prname))//'attenuation3D.bin',status='old',action='read',form='unformatted')
+ read(27) tau_s
+ read(27) factor_common
+ read(27) scale_factor
+ read(27) T_c_source
+ close(27)
+
+ scale_t = ONE/dsqrt(PI*GRAV*RHOAV)
+
+ factor_common(:,:,:,:,:) = factor_common(:,:,:,:,:) / scale_t ! This is really tau_e, not factor_common
+ tau_s(:) = tau_s(:) / scale_t
+ T_c_source = 1000.0d0 / T_c_source
+ T_c_source = T_c_source / scale_t
+
+ do ispec = 1, vnspec
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ tau_e(:) = factor_common(:,i,j,k,ispec)
+ Q_mu = scale_factor(i,j,k,ispec)
+
+ ! Determine the factor_common and one_minus_sum_beta from tau_s and tau_e
+ call attenuation_property_values(tau_s, tau_e, fc, omsb)
+
+ factor_common(:,i,j,k,ispec) = fc(:)
+ one_minus_sum_beta(i,j,k,ispec) = omsb
+
+ ! Determine the "scale_factor" from tau_s, tau_e, central source frequency, and Q
+ call attenuation_scale_factor(myrank, T_c_source, tau_e, tau_s, Q_mu, sf)
+ scale_factor(i,j,k,ispec) = sf
+ enddo
+ enddo
+ enddo
+ enddo
+end subroutine get_attenuation_model_3D
+
+subroutine attenuation_source_frequency(omega_not, min_period, max_period)
+ ! Determine the Source Frequency
+
+ implicit none
+
+ double precision omega_not
+ double precision f1, f2
+ double precision min_period, max_period
+
+ f1 = 1.0d0 / max_period
+ f2 = 1.0d0 / min_period
+
+ omega_not = 1.0e+03 * 10.0d0**(0.5 * (log10(f1) + log10(f2)))
+
+end subroutine attenuation_source_frequency
+
+subroutine attenuation_tau_sigma(tau_s, n, min_period, max_period)
+ ! Set the Tau_sigma (tau_s) to be equally spaced in log10 frequency
+
+ implicit none
+
+ integer n
+ double precision tau_s(n)
+ double precision min_period, max_period
+ double precision f1, f2
+ double precision exp1, exp2
+ double precision dexp
+ integer i
+ double precision, parameter :: PI = 3.14159265358979d0
+
+ f1 = 1.0d0 / max_period
+ f2 = 1.0d0 / min_period
+
+ exp1 = log10(f1)
+ exp2 = log10(f2)
+
+ dexp = (exp2-exp1) / ((n*1.0d0) - 1)
+ do i = 1,n
+ tau_s(i) = 1.0 / (PI * 2.0d0 * 10**(exp1 + (i - 1)* 1.0d0 *dexp))
+ enddo
+
+end subroutine attenuation_tau_sigma
+
+subroutine attenuation_invert_by_simplex(t2, t1, n, Q_real, omega_not, tau_s, tau_e, AS_V)
+
+ implicit none
+
+ include 'mpif.h'
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+ ! Input / Output
+ integer myrank, ier
+ double precision t1, t2
+ double precision Q_real
+ double precision omega_not
+ integer n
+ double precision, dimension(n) :: tau_s, tau_e
+
+ ! Internal
+ integer i, iterations, err,prnt
+ double precision f1, f2, exp1,exp2,dexp, min_value
+ double precision, allocatable, dimension(:) :: f
+ double precision, parameter :: PI = 3.14159265358979d0
+ integer, parameter :: nf = 100
+ double precision, external :: attenuation_eval
+
+ ! Values to be passed into the simplex minimization routine
+ iterations = -1
+ min_value = -1.0e-4
+ err = 0
+ prnt = 0
+
+ allocate(f(nf))
+ ! Determine the min and max frequencies
+ f1 = 1.0d0 / t1
+ f2 = 1.0d0 / t2
+
+ ! Determine the exponents of the frequencies
+ exp1 = log10(f1)
+ exp2 = log10(f2)
+
+ if(f2 < f1 .OR. Q_real < 0.0d0 .OR. n < 1) then
+ call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ier)
+ call exit_MPI(myrank, 'frequencies flipped or Q less than zero or N_SLS < 0')
+ endif
+
+ ! Determine the Source frequency
+ omega_not = 1.0e+03 * 10.0d0**(0.5 * (log10(f1) + log10(f2)))
+
+ ! Determine the Frequencies at which to compare solutions
+ ! The frequencies should be equally spaced in log10 frequency
+ do i = 1,nf
+ f(i) = exp1 + ((i-1)*1.0d0 * (exp2-exp1) / ((nf-1)*1.0d0))
+ enddo
+
+ ! Set the Tau_sigma (tau_s) to be equally spaced in log10 frequency
+ dexp = (exp2-exp1) / ((n*1.0d0) - 1)
+ do i = 1,n
+ tau_s(i) = 1.0 / (PI * 2.0d0 * 10**(exp1 + (i - 1)* 1.0d0 *dexp))
+ enddo
+
+ ! Shove the paramters into the module
+ call attenuation_simplex_setup(nf,n,f,Q_real,tau_s,AS_V)
+
+ ! Set the Tau_epsilon (tau_e) to an initial value at omega*tau = 1
+ ! tan_delta = 1/Q = (tau_e - tau_s)/(2 * sqrt(tau e*tau_s))
+ ! if we assume tau_e =~ tau_s
+ ! we get the equation below
+ do i = 1,n
+ tau_e(i) = tau_s(i) + (tau_s(i) * 2.0d0/Q_real)
+ enddo
+
+ ! Run a simplex search to determine the optimum values of tau_e
+ call fminsearch(attenuation_eval, tau_e, n, iterations, min_value, prnt, err,AS_V)
+ if(err > 0) then
+ write(*,*)'Search did not converge for an attenuation of ', Q_real
+ write(*,*)' Iterations: ', iterations
+ write(*,*)' Min Value: ', min_value
+ write(*,*)' Aborting program'
+ call MPI_COMM_RANK(MPI_COMM_WORLD, myrank, ier)
+ call exit_MPI(myrank,'attenuation_simplex: Search for Strain relaxation times did not converge')
+ endif
+ deallocate(f)
+
+ call attenuation_simplex_finish(AS_V)
+
+end subroutine attenuation_invert_by_simplex
+
+subroutine attenuation_simplex_finish(AS_V)
+
+ implicit none
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+ deallocate(AS_V%f)
+ deallocate(AS_V%tau_s)
+
+end subroutine attenuation_simplex_finish
+
+! - Inserts necessary parameters into the module attenuation_simplex_variables
+! - See module for explaination
+subroutine attenuation_simplex_setup(nf_in,nsls_in,f_in,Q_in,tau_s_in,AS_V)
+
+ implicit none
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+ integer nf_in, nsls_in
+ double precision Q_in
+ double precision, dimension(nf_in) :: f_in
+ double precision, dimension(nsls_in) :: tau_s_in
+
+ allocate(AS_V%f(nf_in))
+ allocate(AS_V%tau_s(nsls_in))
+
+ AS_V%nf = nf_in
+ AS_V%nsls = nsls_in
+ AS_V%f = f_in
+ AS_V%Q = Q_in
+ AS_V%iQ = 1.0d0/AS_V%Q
+ AS_V%tau_s = tau_s_in
+
+end subroutine attenuation_simplex_setup
+
+! - Computes the Moduli (Maxwell Solid) for a series of
+! Standard Linear Solids
+! - Computes M1 and M2 parameters after Dahlen and Tromp pp.203
+! here called B and A after Liu et al. 1976
+! - Another formulation uses Kelvin-Voigt Solids and computes
+! Compliences J1 and J2 after Dahlen and Tromp pp.203
+!
+! Input
+! nf = Number of Frequencies
+! nsls = Number of Standard Linear Solids
+! f = Frequencies (in log10 of frequencies)
+! dimension(nf)
+! tau_s = Tau_sigma Stress relaxation time (see References)
+! dimension(nsls)
+! tau_e = Tau_epislon Strain relaxation time (see References)
+! dimension(nsls)!
+! Output
+! B = Real Moduli ( M2 Dahlen and Tromp pp.203 )
+! dimension(nf)
+! A = Imaginary Moduli ( M1 Dahlen and Tromp pp.203 )
+! dimension(nf)
+!
+! Dahlen and Tromp, 1998
+! Theoretical Global Seismology
+!
+! Liu et al. 1976
+! Velocity dispersion due to anelasticity: implications for seismology and mantle composition
+! Geophys, J. R. asts. Soc, Vol 47, pp. 41-58
+subroutine attenuation_maxwell(nf,nsls,f,tau_s,tau_e,B,A)
+
+ implicit none
+
+ ! Input
+ integer nf, nsls
+ double precision, dimension(nf) :: f
+ double precision, dimension(nsls) :: tau_s, tau_e
+ ! Output
+ double precision, dimension(nf) :: A,B
+
+ integer i,j
+ double precision w, pi, demon
+
+ PI = 3.14159265358979d0
+
+ A(:) = 1.0d0 - nsls*1.0d0
+ B(:) = 0.0d0
+ do i = 1,nf
+ w = 2.0d0 * PI * 10**f(i)
+ do j = 1,nsls
+! write(*,*)j,tau_s(j),tau_e(j)
+ demon = 1.0d0 + w**2 * tau_s(j)**2
+ A(i) = A(i) + ((1.0d0 + (w**2 * tau_e(j) * tau_s(j)))/ demon)
+ B(i) = B(i) + ((w * (tau_e(j) - tau_s(j))) / demon)
+ end do
+! write(*,*)A(i),B(i),10**f(i)
+ enddo
+
+end subroutine attenuation_maxwell
+
+! - Computes the misfit from a set of relaxation paramters
+! given a set of frequencies and target attenuation
+! - Evaluates only at the given frequencies
+! - Evaluation is done with an L2 norm
+!
+! Input
+! Xin = Tau_epsilon, Strain Relaxation Time
+! Note: Tau_sigma the Stress Relaxation Time is loaded
+! with attenuation_simplex_setup and stored in
+! attenuation_simplex_variables
+!
+! Xi = Sum_i^N sqrt [ (1/Qc_i - 1/Qt_i)^2 / 1/Qt_i^2 ]
+!
+! where Qc_i is the computed attenuation at a specific frequency
+! Qt_i is the desired attenuaiton at that frequency
+!
+! Uses attenuation_simplex_variables to store constant values
+!
+! See atteunation_simplex_setup
+!
+double precision function attenuation_eval(Xin,AS_V)
+
+ implicit none
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+ ! Input
+ double precision, dimension(AS_V%nsls) :: Xin
+ double precision, dimension(AS_V%nsls) :: tau_e
+
+ double precision, dimension(AS_V%nf) :: A, B, tan_delta
+
+ integer i
+ double precision xi, iQ2
+
+ tau_e = Xin
+
+ call attenuation_maxwell(AS_V%nf,AS_V%nsls,AS_V%f,AS_V%tau_s,tau_e,B,A)
+
+ tan_delta = B / A
+
+ attenuation_eval = 0.0d0
+ iQ2 = AS_V%iQ**2
+ do i = 1,AS_V%nf
+ xi = sqrt(( ( (tan_delta(i) - AS_V%iQ) ** 2 ) / iQ2 ))
+ attenuation_eval = attenuation_eval + xi
+ enddo
+
+end function attenuation_eval
+
+! subroutine fminsearch
+! - Computes the minimization of funk(x(n)) using the simplex method
+! - This subroutine is copied from Matlab fminsearch.m
+! and modified to suit my nefarious needs
+! Input
+! funk = double precision function with one input parameter
+! double precision function the_funk(x)
+! x = Input/Output
+! variables to be minimized
+! dimension(n)
+! Input: Initial Value
+! Output: Mimimized Value
+! n = number of variables
+! itercount = Input/Output
+! Input: maximum number of iterations
+! if < 0 default is used (200 * n)
+! Output: total number of iterations on output
+! tolf = Input/Output
+! Input: minimium tolerance of the function funk(x)
+! Output: minimium value of funk(x)(i.e. "a" solution)
+! prnt = Input
+! 3 => report every iteration
+! 4 => report every iteration, total simplex
+! err = Output
+! 0 => Normal exeecution, converged within desired range
+! 1 => Function Evaluation exceeded limit
+! 2 => Iterations exceeded limit
+!
+! See Matlab fminsearch
+subroutine fminsearch(funk, x, n, itercount, tolf, prnt, err, AS_V)
+
+ implicit none
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+ ! Input
+ double precision, external :: funk
+
+ integer n
+ double precision x(n) ! Also Output
+ integer itercount, prnt, err
+ double precision tolf
+
+ !Internal
+ integer i,j, how
+ integer, parameter :: none = 0
+ integer, parameter :: initial = 1
+ integer, parameter :: expand = 2
+ integer, parameter :: reflect = 3
+ integer, parameter :: contract_outside = 4
+ integer, parameter :: contract_inside = 5
+ integer, parameter :: shrink = 6
+
+ integer maxiter, maxfun
+ integer func_evals
+ double precision tolx
+
+ double precision rho, chi, psi, sigma
+ double precision xin(n), y(n), v(n,n+1), fv(n+1)
+ double precision vtmp(n,n+1)
+ double precision usual_delta, zero_term_delta
+ double precision xbar(n), xr(n), fxr, xe(n), fxe, xc(n), fxc, fxcc, xcc(n)
+ integer place(n+1)
+
+ double precision max_size_simplex, max_value
+
+ rho = 1.0d0
+ chi = 2.0d0
+ psi = 0.5d0
+ sigma = 0.5d0
+
+
+ if(itercount > 0) then
+ maxiter = itercount
+ else
+ maxiter = 200 * n
+ endif
+ itercount = 0
+ maxfun = 200 * n
+
+ if(tolf > 0.0d0) then
+ tolx = 1.0e-4
+ else
+ tolx = 1.0e-4
+ tolf = 1.0e-4
+ endif
+
+ err = 0
+
+ xin = x
+ v(:,:) = 0.0d0
+ fv(:) = 0.0d0
+
+ v(:,1) = xin
+ x = xin
+
+ fv(1) = funk(xin,AS_V)
+
+ usual_delta = 0.05
+ zero_term_delta = 0.00025
+
+ do j = 1,n
+ y = xin
+ if(y(j) /= 0.0d0) then
+ y(j) = (1.0d0 + usual_delta) * y(j)
+ else
+ y(j) = zero_term_delta
+ endif
+ v(:,j+1) = y
+ x(:) = y
+ fv(j+1) = funk(x,AS_V)
+ enddo
+
+ call qsort(fv,n+1,place)
+
+ do i = 1,n+1
+ vtmp(:,i) = v(:,place(i))
+ enddo
+ v = vtmp
+
+ how = initial
+ itercount = 1
+ func_evals = n+1
+ if(prnt == 3) then
+ write(*,*)'Iterations Funk Evals Value How'
+ write(*,*)itercount, func_evals, fv(1), how
+ endif
+ if(prnt == 4) then
+ write(*,*)'How: ',how
+ write(*,*)'V: ', v
+ write(*,*)'fv: ',fv
+ write(*,*)'evals: ',func_evals
+ endif
+
+ do while (func_evals < maxfun .AND. itercount < maxiter)
+
+ if(max_size_simplex(v,n) <= tolx .AND. &
+ max_value(fv,n+1) <= tolf) then
+ goto 666
+ endif
+ how = none
+
+ ! xbar = average of the n (NOT n+1) best points
+ ! xbar = sum(v(:,1:n), 2)/n
+ xbar(:) = 0.0d0
+ do i = 1,n
+ do j = 1,n
+ xbar(i) = xbar(i) + v(i,j)
+ enddo
+ xbar(i) = xbar(i) / (n*1.0d0)
+ enddo
+ xr = (1 + rho)*xbar - rho*v(:,n+1)
+ x(:) = xr
+ fxr = funk(x,AS_V)
+ func_evals = func_evals + 1
+ if (fxr < fv(1)) then
+ ! Calculate the expansion point
+ xe = (1 + rho*chi)*xbar - rho*chi*v(:,n+1)
+ x = xe
+ fxe = funk(x,AS_V)
+ func_evals = func_evals+1
+ if (fxe < fxr) then
+ v(:,n+1) = xe
+ fv(n+1) = fxe
+ how = expand
+ else
+ v(:,n+1) = xr
+ fv(n+1) = fxr
+ how = reflect
+ endif
+ else ! fv(:,1) <= fxr
+ if (fxr < fv(n)) then
+ v(:,n+1) = xr
+ fv(n+1) = fxr
+ how = reflect
+ else ! fxr >= fv(:,n)
+ ! Perform contraction
+ if (fxr < fv(n+1)) then
+ ! Perform an outside contraction
+ xc = (1 + psi*rho)*xbar - psi*rho*v(:,n+1)
+ x(:) = xc
+ fxc = funk(x,AS_V)
+ func_evals = func_evals+1
+
+ if (fxc <= fxr) then
+ v(:,n+1) = xc
+ fv(n+1) = fxc
+ how = contract_outside
+ else
+ ! perform a shrink
+ how = shrink
+ endif
+ else
+ ! Perform an inside contraction
+ xcc = (1-psi)*xbar + psi*v(:,n+1)
+ x(:) = xcc
+ fxcc = funk(x,AS_V)
+ func_evals = func_evals+1
+
+ if (fxcc < fv(n+1)) then
+ v(:,n+1) = xcc
+ fv(n+1) = fxcc
+ how = contract_inside
+ else
+ ! perform a shrink
+ how = shrink
+ endif
+ endif
+ if (how == shrink) then
+ do j=2,n+1
+ v(:,j)=v(:,1)+sigma*(v(:,j) - v(:,1))
+ x(:) = v(:,j)
+ fv(j) = funk(x,AS_V)
+ enddo
+ func_evals = func_evals + n
+ endif
+ endif
+ endif
+
+ call qsort(fv,n+1,place)
+ do i = 1,n+1
+ vtmp(:,i) = v(:,place(i))
+ enddo
+ v = vtmp
+
+ itercount = itercount + 1
+ if (prnt == 3) then
+ write(*,*)itercount, func_evals, fv(1), how
+ elseif (prnt == 4) then
+ write(*,*)
+ write(*,*)'How: ',how
+ write(*,*)'v: ',v
+ write(*,*)'fv: ',fv
+ write(*,*)'evals: ',func_evals
+ endif
+ enddo
+
+ if(func_evals > maxfun) then
+ write(*,*)'function evaluations exceeded prescribed limit', maxfun
+ err = 1
+ endif
+ if(itercount > maxiter) then
+ write(*,*)'iterations exceeded prescribed limit', maxiter
+ err = 2
+ endif
+
+666 continue
+ x = v(:,1)
+ tolf = fv(1)
+
+end subroutine fminsearch
+
+! - Finds the maximim value of the difference of between the first
+! value and the remaining values of a vector
+! Input
+! fv = Input
+! Vector
+! dimension(n)
+! n = Input
+! Length of fv
+!
+! Returns:
+! Xi = max( || fv(1)- fv(i) || ) for i=2:n
+!
+double precision function max_value(fv,n)
+ implicit none
+ integer n
+ double precision fv(n)
+
+ integer i
+ double precision m, z
+
+ m = 0.0d0
+ do i = 2,n
+ z = abs(fv(1) - fv(i))
+ if(z > m) then
+ m = z
+ endif
+ enddo
+
+ max_value = m
+
+end function max_value
+
+! - Determines the maximum distance between two point in a simplex
+! Input
+! v = Input
+! Simplex Verticies
+! dimension(n, n+1)
+! n = Pseudo Length of n
+!
+! Returns:
+! Xi = max( max( || v(:,1) - v(:,i) || ) ) for i=2:n+1
+!
+double precision function max_size_simplex(v,n)
+ implicit none
+ integer n
+ double precision v(n,n+1)
+
+ integer i,j
+ double precision m, z
+
+ m = 0.0d0
+ do i = 1,n
+ do j = 2,n+1
+ z = abs(v(i,j) - v(i,1))
+ if(z > m) then
+ m = z
+ endif
+ enddo
+ enddo
+
+ max_size_simplex = m
+
+end function max_size_simplex
+
+! - Implementation of a Bubble Sort Routine
+! Input
+! X = Input/Output
+! Vector to be sorted
+! dimension(n)
+! n = Input
+! Length of X
+! I = Output
+! Sorted Indicies of vecotr X
+!
+! Example:
+! X = [ 4 3 1 2 ] on Input
+! I = [ 1 2 3 4 ] Computed Internally (in order)
+!
+! X = [ 1 2 3 4 ] on Output
+! I = [ 3 4 2 1 ] on Output
+!
+subroutine qsort(X,n,I)
+
+ implicit none
+
+ integer n
+ double precision X(n)
+ integer I(n)
+
+ integer j,k
+ double precision rtmp
+ integer itmp
+
+ do j = 1,n
+ I(j) = j
+ enddo
+
+ do j = 1,n
+ do k = 1,n-j
+ if(X(k+1) < X(k)) then
+ rtmp = X(k)
+ X(k) = X(k+1)
+ X(k+1) = rtmp
+
+ itmp = I(k)
+ I(k) = I(k+1)
+ I(k+1) = itmp
+ endif
+ enddo
+ enddo
+
+end subroutine qsort
+
+! Piecewise Continuous Splines
+! - Added Steps which describes the discontinuities
+! - Steps must be repeats in the dependent variable, X
+! - Derivates at the steps are computed using the point
+! at the derivate and the closest point within that piece
+! - A point lying directly on the discontinuity will recieve the
+! value of the first or smallest piece in terms of X
+! - Beginning and Ending points of the Function become beginning
+! and ending points of the first and last splines
+! - A Step with a value of zero is undefined
+! - Works with functions with steps or no steps
+! See the comment below about the ScS bug
+subroutine pspline_evaluation(xa, ya, y2a, n, x, y, steps)
+
+ implicit none
+
+ integer n
+ double precision xa(n),ya(n),y2a(n)
+ integer steps(n)
+ double precision x, y
+
+ integer i, l, n1, n2
+
+ do i = 1,n-1,1
+ if(steps(i+1) == 0) return
+ if(x >= xa(steps(i)) .and. x <= xa(steps(i+1))) then
+ call pspline_piece(i,n1,n2,l,n,steps)
+ call spline_evaluation(xa(n1), ya(n1), y2a(n1), l, x, y)
+! return <-- Commented out to fix ScS bug
+ endif
+ enddo
+
+end subroutine pspline_evaluation
+
+subroutine pspline_piece(i,n1,n2,l,n,s)
+
+ implicit none
+
+ integer i, n1, n2, l, n, s(n)
+ n1 = s(i)+1
+ if(i == 1) n1 = s(i)
+ n2 = s(i+1)
+ l = n2 - n1 + 1
+
+end subroutine pspline_piece
+
+subroutine pspline_construction(x, y, n, yp1, ypn, y2, steps)
+
+ implicit none
+
+ integer n
+ double precision x(n),y(n),y2(n)
+ double precision yp1, ypn
+ integer steps(n)
+
+ integer i,r, l, n1,n2
+
+ steps(:) = 0
+
+ ! Find steps in x, defining pieces
+ steps(1) = 1
+ r = 2
+ do i = 2,n
+ if(x(i) == x(i-1)) then
+ steps(r) = i-1
+ r = r + 1
+ endif
+ end do
+ steps(r) = n
+
+ ! Run spline for each piece
+ do i = 1,r-1
+ call pspline_piece(i,n1,n2,l,n,steps)
+ ! Determine the First Derivates at Begin/End Points
+ yp1 = ( y(n1+1) - y(n1) ) / ( x(n1+1) - x(n1))
+ ypn = ( y(n2) - y(n2-1) ) / ( x(n2) - x(n2-1))
+ call spline_construction(x(n1),y(n1),l,yp1,ypn,y2(n1))
+ enddo
+
+end subroutine pspline_construction
+
+subroutine attenuation_model_1D_PREM(x, Qmu, iflag)
+
+! x in the radius from 0 to 1 where 0 is the center and 1 is the surface
+! This version is for 1D PREM.
+
+ implicit none
+
+ include 'constants.h'
+
+ integer iflag
+ double precision r, x, Qmu,RICB,RCMB, &
+ RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R80, ROCEAN, RMOHO, RMIDDLE_CRUST
+ double precision Qkappa
+
+ r = x * R_EARTH
+
+ ROCEAN = 6368000.d0
+ RMIDDLE_CRUST = 6356000.d0
+ RMOHO = 6346600.d0
+ R80 = 6291000.d0
+ R220 = 6151000.d0
+ R400 = 5971000.d0
+ R600 = 5771000.d0
+ R670 = 5701000.d0
+ R771 = 5600000.d0
+ RTOPDDOUBLEPRIME = 3630000.d0
+ RCMB = 3480000.d0
+ RICB = 1221000.d0
+
+! PREM
+!
+!--- inner core
+!
+ if(r >= 0.d0 .and. r <= RICB) then
+ Qmu=84.6d0
+ Qkappa=1327.7d0
+!
+!--- outer core
+!
+ else if(r > RICB .and. r <= RCMB) then
+ Qmu=0.0d0
+ Qkappa=57827.0d0
+ if(RCMB - r < r - RICB) then
+ Qmu = 312.0d0 ! CMB
+ else
+ Qmu = 84.6d0 ! ICB
+ endif
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+ else if(r > R771 .and. r <= R670) then
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: above d670
+!
+ else if(r > R670 .and. r <= R600) then
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R600 .and. r <= R400) then
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R400 .and. r <= R220) then
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R220 .and. r <= R80) then
+ Qmu=80.0d0
+ Qkappa=57827.0d0
+ else if(r > R80) then
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+
+ ! We determine the attenuation value here dependent on the doubling flag and
+ ! which region we are sitting in. The radius reported is not accurate for
+ ! determination of which region we are actually in, whereas the idoubling flag is
+ if(iflag == IFLAG_INNER_CORE_NORMAL .or. iflag == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ iflag == IFLAG_BOTTOM_CENTRAL_CUBE .or. iflag == IFLAG_TOP_CENTRAL_CUBE .or. &
+ iflag == IFLAG_IN_FICTITIOUS_CUBE) then
+ Qmu = 84.6d0
+ Qkappa = 1327.7d0
+ else if(iflag == IFLAG_OUTER_CORE_NORMAL) then
+ Qmu = 0.0d0
+ Qkappa = 57827.0d0
+ else if(iflag == IFLAG_MANTLE_NORMAL) then ! D'' to 670 km
+ Qmu = 312.0d0
+ Qkappa = 57827.0d0
+ else if(iflag == IFLAG_670_220) then
+ Qmu=143.0d0
+ Qkappa = 57827.0d0
+ else if(iflag == IFLAG_220_80) then
+ Qmu=80.0d0
+ Qkappa = 57827.0d0
+ else if(iflag == IFLAG_80_MOHO) then
+ Qmu=600.0d0
+ Qkappa = 57827.0d0
+ else if(iflag == IFLAG_CRUST) then
+ Qmu=600.0d0
+ Qkappa = 57827.0d0
+ else
+ write(*,*)'iflag:',iflag
+ call exit_MPI_without_rank('Invalid idoubling flag in attenuation_model_1D_prem from get_model()')
+ endif
+
+end subroutine attenuation_model_1D_PREM
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/auto_ner.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/auto_ner.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/auto_ner.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/calc_jacobian.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/calc_jacobian.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/calc_jacobian.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,145 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine calc_jacobian(myrank,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore, &
+ xstore,ystore,zstore, &
+ xelm,yelm,zelm,shape3D,dershape3D,ispec,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer ispec,nspec,myrank
+
+ double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
+ double precision dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ)
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+!! DK DK changed this for merged version: made it local
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer i,j,k,ia
+
+ double precision xxi,xeta,xgamma,yxi,yeta,ygamma,zxi,zeta,zgamma
+ double precision xmesh,ymesh,zmesh
+ double precision xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+ double precision jacobian
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ xxi = ZERO
+ xeta = ZERO
+ xgamma = ZERO
+ yxi = ZERO
+ yeta = ZERO
+ ygamma = ZERO
+ zxi = ZERO
+ zeta = ZERO
+ zgamma = ZERO
+ xmesh = ZERO
+ ymesh = ZERO
+ zmesh = ZERO
+
+ do ia=1,NGNOD
+ xxi = xxi + dershape3D(1,ia,i,j,k)*xelm(ia)
+ xeta = xeta + dershape3D(2,ia,i,j,k)*xelm(ia)
+ xgamma = xgamma + dershape3D(3,ia,i,j,k)*xelm(ia)
+ yxi = yxi + dershape3D(1,ia,i,j,k)*yelm(ia)
+ yeta = yeta + dershape3D(2,ia,i,j,k)*yelm(ia)
+ ygamma = ygamma + dershape3D(3,ia,i,j,k)*yelm(ia)
+ zxi = zxi + dershape3D(1,ia,i,j,k)*zelm(ia)
+ zeta = zeta + dershape3D(2,ia,i,j,k)*zelm(ia)
+ zgamma = zgamma + dershape3D(3,ia,i,j,k)*zelm(ia)
+ xmesh = xmesh + shape3D(ia,i,j,k)*xelm(ia)
+ ymesh = ymesh + shape3D(ia,i,j,k)*yelm(ia)
+ zmesh = zmesh + shape3D(ia,i,j,k)*zelm(ia)
+ enddo
+
+ jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
+ xeta*(yxi*zgamma-ygamma*zxi) + &
+ xgamma*(yxi*zeta-yeta*zxi)
+
+ if(jacobian <= ZERO) call exit_MPI(myrank,'3D Jacobian undefined')
+
+! invert the relation (Fletcher p. 50 vol. 2)
+ xix = (yeta*zgamma-ygamma*zeta) / jacobian
+ xiy = (xgamma*zeta-xeta*zgamma) / jacobian
+ xiz = (xeta*ygamma-xgamma*yeta) / jacobian
+ etax = (ygamma*zxi-yxi*zgamma) / jacobian
+ etay = (xxi*zgamma-xgamma*zxi) / jacobian
+ etaz = (xgamma*yxi-xxi*ygamma) / jacobian
+ gammax = (yxi*zeta-yeta*zxi) / jacobian
+ gammay = (xeta*zxi-xxi*zeta) / jacobian
+ gammaz = (xxi*yeta-xeta*yxi) / jacobian
+
+! save the derivatives and the jacobian
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ xixstore(i,j,k) = sngl(xix)
+ xiystore(i,j,k) = sngl(xiy)
+ xizstore(i,j,k) = sngl(xiz)
+ etaxstore(i,j,k) = sngl(etax)
+ etaystore(i,j,k) = sngl(etay)
+ etazstore(i,j,k) = sngl(etaz)
+ gammaxstore(i,j,k) = sngl(gammax)
+ gammaystore(i,j,k) = sngl(gammay)
+ gammazstore(i,j,k) = sngl(gammaz)
+ else
+ xixstore(i,j,k) = xix
+ xiystore(i,j,k) = xiy
+ xizstore(i,j,k) = xiz
+ etaxstore(i,j,k) = etax
+ etaystore(i,j,k) = etay
+ etazstore(i,j,k) = etaz
+ gammaxstore(i,j,k) = gammax
+ gammaystore(i,j,k) = gammay
+ gammazstore(i,j,k) = gammaz
+ endif
+
+! store mesh coordinates
+ xstore(i,j,k,ispec) = xmesh
+ ystore(i,j,k,ispec) = ymesh
+ zstore(i,j,k,ispec) = zmesh
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine calc_jacobian
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call1.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call1.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call1.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,45 @@
+
+!! DK DK created this for merged version
+
+ call specfem3D( &
+!! DK DK to do later, for attenuation only; not done yet by lack of time
+ omsb_crust_mantle_dble,factor_scale_crust_mantle_dble, omsb_inner_core_dble,factor_scale_inner_core_dble, &
+ one_minus_sum_beta_crust_mantle,factor_scale_crust_mantle, one_minus_sum_beta_inner_core,factor_scale_inner_core, &
+ factor_common_crust_mantle,factor_common_inner_core,factor_common_crust_mantle_dble, factor_common_inner_core_dble, &
+!! DK DK to do later, for oceans only
+ rmass_ocean_load, &
+!! DK DK already computed
+ myrank,sizeprocs,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,ibathy_topo, &
+ ibool_crust_mantle, ibool_outer_core, ibool_inner_core, idoubling_crust_mantle,idoubling_inner_core, &
+ibelm_bottom_crust_mantle, ibelm_bottom_outer_core, ibelm_top_outer_core, &
+ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
+ibelm_top_inner_core,iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, iboolleft_eta_crust_mantle, &
+iboolright_eta_crust_mantle,iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core, iboolleft_eta_inner_core,iboolright_eta_inner_core,&
+ jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
+ normal_bottom_outer_core, normal_top_outer_core,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle,kappavstore_inner_core,muvstore_inner_core, &
+ rmass_crust_mantle, rmass_outer_core, rmass_inner_core, &
+ nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
+iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces_crust_mantle,iboolfaces_outer_core,iboolfaces_inner_core, &
+ iboolcorner_crust_mantle,iboolcorner_outer_core,iboolcorner_inner_core, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+!! DK DK recomputed after the end of the mesher and before the beginning of the solver
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle,xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,etax_crust_mantle,etay_crust_mantle, &
+ etaz_crust_mantle,gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+xix_outer_core,xiy_outer_core,xiz_outer_core,etax_outer_core,etay_outer_core, &
+etaz_outer_core,gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core,etax_inner_core,etay_inner_core, &
+ etaz_inner_core,gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+!! DK DK do not need to be initialized
+ displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
+ displ_outer_core,veloc_outer_core,accel_outer_core,displ_inner_core,veloc_inner_core,accel_inner_core, &
+ buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
+ buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector, &
+R_memory_crust_mantle, epsilondev_crust_mantle, R_memory_inner_core, epsilondev_inner_core)
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call2.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call2.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/call2.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,45 @@
+
+!! DK DK created this for merged version
+
+ subroutine specfem3D( &
+!! DK DK to do later, for attenuation only; not done yet by lack of time
+ omsb_crust_mantle_dble,factor_scale_crust_mantle_dble, omsb_inner_core_dble,factor_scale_inner_core_dble, &
+ one_minus_sum_beta_crust_mantle,factor_scale_crust_mantle, one_minus_sum_beta_inner_core,factor_scale_inner_core, &
+ factor_common_crust_mantle,factor_common_inner_core,factor_common_crust_mantle_dble, factor_common_inner_core_dble, &
+!! DK DK to do later, for oceans only
+ rmass_ocean_load, &
+!! DK DK already computed
+ myrank,sizeprocs,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,ibathy_topo, &
+ ibool_crust_mantle, ibool_outer_core, ibool_inner_core, idoubling_crust_mantle,idoubling_inner_core, &
+ibelm_bottom_crust_mantle, ibelm_bottom_outer_core, ibelm_top_outer_core, &
+ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
+ibelm_top_inner_core,iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, iboolleft_eta_crust_mantle, &
+iboolright_eta_crust_mantle,iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core, iboolleft_eta_inner_core,iboolright_eta_inner_core,&
+ jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
+ normal_bottom_outer_core, normal_top_outer_core,kappavstore_crust_mantle,muvstore_crust_mantle, &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle,kappavstore_inner_core,muvstore_inner_core, &
+ rmass_crust_mantle, rmass_outer_core, rmass_inner_core, &
+ nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
+iprocfrom_faces,iprocto_faces,imsg_type,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces_crust_mantle,iboolfaces_outer_core,iboolfaces_inner_core, &
+ iboolcorner_crust_mantle,iboolcorner_outer_core,iboolcorner_inner_core, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+!! DK DK recomputed after the end of the mesher and before the beginning of the solver
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle,xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,etax_crust_mantle,etay_crust_mantle, &
+ etaz_crust_mantle,gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+xix_outer_core,xiy_outer_core,xiz_outer_core,etax_outer_core,etay_outer_core, &
+etaz_outer_core,gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core,etax_inner_core,etay_inner_core, &
+ etaz_inner_core,gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+!! DK DK do not need to be initialized
+ displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle, &
+ displ_outer_core,veloc_outer_core,accel_outer_core,displ_inner_core,veloc_inner_core,accel_inner_core, &
+ buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
+ buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector, &
+R_memory_crust_mantle, epsilondev_crust_mantle, R_memory_inner_core, epsilondev_inner_core)
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_mass_matrix_one_element.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_mass_matrix_one_element.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_mass_matrix_one_element.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,80 @@
+
+!! DK DK added this for merged version
+
+ if(ipass == 2) then
+
+! suppress fictitious elements in central cube
+! also take into account the fact that array idoubling is not allocated for the outer core
+ add_contrib_this_element = .true.
+ if(iregion_code == IREGION_INNER_CORE) then
+ if(idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) add_contrib_this_element = .false.
+ endif
+
+ if(add_contrib_this_element) then
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+
+!! DK DK changed this for merged version
+! if(PERFORM_CUTHILL_MCKEE) then
+! iglobnum = ibool(i,j,k,invperm(ispec))
+! iglobnum = ibool(i,j,k,perm(ispec))
+! else
+ iglobnum = ibool(i,j,k,ispec)
+! endif
+
+! compute the jacobian
+ xixl = xixstore(i,j,k)
+ xiyl = xiystore(i,j,k)
+ xizl = xizstore(i,j,k)
+ etaxl = etaxstore(i,j,k)
+ etayl = etaystore(i,j,k)
+ etazl = etazstore(i,j,k)
+ gammaxl = gammaxstore(i,j,k)
+ gammayl = gammaystore(i,j,k)
+ gammazl = gammazstore(i,j,k)
+
+ jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
+ - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl))
+
+! definition depends if region is fluid or solid
+ if(iregion_code == IREGION_CRUST_MANTLE .or. iregion_code == IREGION_INNER_CORE) then
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglobnum) = rmass(iglobnum) + &
+ sngl(dble(rhostore_local(i,j,k)) * dble(jacobianl) * weight)
+ else
+ rmass(iglobnum) = rmass(iglobnum) + rhostore_local(i,j,k) * jacobianl * weight
+ endif
+
+! fluid in outer core
+ else if(iregion_code == IREGION_OUTER_CORE) then
+
+! no anisotropy in the fluid, use kappav
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglobnum) = rmass(iglobnum) + &
+ sngl(dble(jacobianl) * weight * dble(rhostore_local(i,j,k)) / dble(kappavstore_local(i,j,k)))
+ else
+ rmass(iglobnum) = rmass(iglobnum) + &
+ jacobianl * weight * rhostore_local(i,j,k) / kappavstore_local(i,j,k)
+ endif
+
+ else
+ call exit_MPI(myrank,'wrong region code')
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ endif ! of exclusion of fictitious inner core elements
+
+ endif ! of ipass == 2
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_source_spectrum.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_source_spectrum.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_source_spectrum.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/comp_source_time_function.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_source_time_function.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/comp_source_time_function.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/compute_arrays_source.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_arrays_source.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_arrays_source.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,331 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine compute_arrays_source(ispec_selected_source, &
+ xi_source,eta_source,gamma_source,sourcearray, &
+ Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ xigll,yigll,zigll,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer ispec_selected_source,nspec
+
+ double precision xi_source,eta_source,gamma_source
+ double precision Mxx,Myy,Mzz,Mxy,Mxz,Myz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xix,xiy,xiz,etax,etay,etaz, &
+ gammax,gammay,gammaz
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
+
+ double precision xixd,xiyd,xizd,etaxd,etayd,etazd,gammaxd,gammayd,gammazd
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLY) :: yigll
+ double precision, dimension(NGLLZ) :: zigll
+
+! source arrays
+ double precision, dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrayd
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: G11,G12,G13,G21,G22,G23,G31,G32,G33
+ double precision, dimension(NGLLX) :: hxis,hpxis
+ double precision, dimension(NGLLY) :: hetas,hpetas
+ double precision, dimension(NGLLZ) :: hgammas,hpgammas
+
+ integer k,l,m
+
+! calculate G_ij for general source location
+! the source does not necessarily correspond to a Gauss-Lobatto point
+ do m=1,NGLLZ
+ do l=1,NGLLY
+ do k=1,NGLLX
+
+ xixd = dble(xix(k,l,m,ispec_selected_source))
+ xiyd = dble(xiy(k,l,m,ispec_selected_source))
+ xizd = dble(xiz(k,l,m,ispec_selected_source))
+ etaxd = dble(etax(k,l,m,ispec_selected_source))
+ etayd = dble(etay(k,l,m,ispec_selected_source))
+ etazd = dble(etaz(k,l,m,ispec_selected_source))
+ gammaxd = dble(gammax(k,l,m,ispec_selected_source))
+ gammayd = dble(gammay(k,l,m,ispec_selected_source))
+ gammazd = dble(gammaz(k,l,m,ispec_selected_source))
+
+ G11(k,l,m) = Mxx*xixd+Mxy*xiyd+Mxz*xizd
+ G12(k,l,m) = Mxx*etaxd+Mxy*etayd+Mxz*etazd
+ G13(k,l,m) = Mxx*gammaxd+Mxy*gammayd+Mxz*gammazd
+ G21(k,l,m) = Mxy*xixd+Myy*xiyd+Myz*xizd
+ G22(k,l,m) = Mxy*etaxd+Myy*etayd+Myz*etazd
+ G23(k,l,m) = Mxy*gammaxd+Myy*gammayd+Myz*gammazd
+ G31(k,l,m) = Mxz*xixd+Myz*xiyd+Mzz*xizd
+ G32(k,l,m) = Mxz*etaxd+Myz*etayd+Mzz*etazd
+ G33(k,l,m) = Mxz*gammaxd+Myz*gammayd+Mzz*gammazd
+
+ enddo
+ enddo
+ enddo
+
+! compute Lagrange polynomials at the source location
+ call lagrange_any(xi_source,NGLLX,xigll,hxis,hpxis)
+ call lagrange_any(eta_source,NGLLY,yigll,hetas,hpetas)
+ call lagrange_any(gamma_source,NGLLZ,zigll,hgammas,hpgammas)
+
+! calculate source array
+ do m=1,NGLLZ
+ do l=1,NGLLY
+ do k=1,NGLLX
+ call multiply_arrays_source(sourcearrayd,G11,G12,G13,G21,G22,G23, &
+ G31,G32,G33,hxis,hpxis,hetas,hpetas,hgammas,hpgammas,k,l,m)
+ enddo
+ enddo
+ enddo
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ sourcearray(:,:,:,:) = sngl(sourcearrayd(:,:,:,:))
+ else
+ sourcearray(:,:,:,:) = sourcearrayd(:,:,:,:)
+ endif
+
+ end subroutine compute_arrays_source
+
+!================================================================
+
+! we put these multiplications in a separate routine because otherwise
+! some compilers try to unroll the six loops above and take forever to compile
+ subroutine multiply_arrays_source(sourcearrayd,G11,G12,G13,G21,G22,G23, &
+ G31,G32,G33,hxis,hpxis,hetas,hpetas,hgammas,hpgammas,k,l,m)
+
+ implicit none
+
+ include "constants.h"
+
+! source arrays
+ double precision, dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrayd
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: G11,G12,G13,G21,G22,G23,G31,G32,G33
+ double precision, dimension(NGLLX) :: hxis,hpxis
+ double precision, dimension(NGLLY) :: hetas,hpetas
+ double precision, dimension(NGLLZ) :: hgammas,hpgammas
+
+ integer k,l,m
+
+ integer ir,it,iv
+
+ sourcearrayd(:,k,l,m) = ZERO
+
+ do iv=1,NGLLZ
+ do it=1,NGLLY
+ do ir=1,NGLLX
+
+ sourcearrayd(1,k,l,m) = sourcearrayd(1,k,l,m) + hxis(ir)*hetas(it)*hgammas(iv) &
+ *(G11(ir,it,iv)*hpxis(k)*hetas(l)*hgammas(m) &
+ +G12(ir,it,iv)*hxis(k)*hpetas(l)*hgammas(m) &
+ +G13(ir,it,iv)*hxis(k)*hetas(l)*hpgammas(m))
+
+ sourcearrayd(2,k,l,m) = sourcearrayd(2,k,l,m) + hxis(ir)*hetas(it)*hgammas(iv) &
+ *(G21(ir,it,iv)*hpxis(k)*hetas(l)*hgammas(m) &
+ +G22(ir,it,iv)*hxis(k)*hpetas(l)*hgammas(m) &
+ +G23(ir,it,iv)*hxis(k)*hetas(l)*hpgammas(m))
+
+ sourcearrayd(3,k,l,m) = sourcearrayd(3,k,l,m) + hxis(ir)*hetas(it)*hgammas(iv) &
+ *(G31(ir,it,iv)*hpxis(k)*hetas(l)*hgammas(m) &
+ +G32(ir,it,iv)*hxis(k)*hpetas(l)*hgammas(m) &
+ +G33(ir,it,iv)*hxis(k)*hetas(l)*hpgammas(m))
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine multiply_arrays_source
+
+!================================================================
+
+subroutine compute_arrays_adjoint_source(myrank, adj_source_file, &
+ xi_receiver,eta_receiver,gamma_receiver, nu,adj_sourcearray, &
+ xigll,yigll,zigll,NSTEP)
+
+ implicit none
+
+ include 'constants.h'
+
+! input
+ integer myrank, NSTEP
+
+ double precision xi_receiver, eta_receiver, gamma_receiver
+
+ character(len=*) adj_source_file
+
+! output
+ real(kind=CUSTOM_REAL) :: adj_sourcearray(NSTEP,NDIM,NGLLX,NGLLY,NGLLZ)
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLY) :: yigll
+ double precision, dimension(NGLLZ) :: zigll
+
+ double precision, dimension(NDIM,NDIM) :: nu
+
+ double precision scale_displ
+
+ double precision :: hxir(NGLLX), hpxir(NGLLX), hetar(NGLLY), hpetar(NGLLY), &
+ hgammar(NGLLZ), hpgammar(NGLLZ)
+ real(kind=CUSTOM_REAL) :: adj_src(NSTEP,NDIM),adj_src_u(NSTEP,NDIM)
+
+ integer icomp, itime, i, j, k, ios
+ double precision :: junk
+ character(len=3) :: comp(NDIM)
+ character(len=150) :: filename
+
+ scale_displ = R_EARTH
+
+ call lagrange_any(xi_receiver,NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(eta_receiver,NGLLY,yigll,hetar,hpetar)
+ call lagrange_any(gamma_receiver,NGLLZ,zigll,hgammar,hpgammar)
+
+ adj_sourcearray(:,:,:,:,:) = 0.
+
+ comp = (/"LHN", "LHE", "LHZ"/)
+
+ do icomp = 1, NDIM
+
+ filename = 'SEM/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
+ open(unit = IIN, file = trim(filename), iostat = ios)
+ if (ios /= 0) call exit_MPI(myrank, ' file '//trim(filename)//' does not exist')
+ do itime = 1, NSTEP
+ read(IIN,*) junk, adj_src(itime,icomp)
+ enddo
+ close(IIN)
+
+ enddo
+
+ adj_src = adj_src/scale_displ
+
+ do itime = 1, NSTEP
+ adj_src_u(itime,:) = nu(1,:) * adj_src(itime,1) + nu(2,:) * adj_src(itime,2) + nu(3,:) * adj_src(itime,3)
+ enddo
+
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ adj_sourcearray(:,:,i,j,k) = hxir(i) * hetar(j) * hgammar(k) * adj_src_u(:,:)
+ enddo
+ enddo
+ enddo
+
+
+end subroutine compute_arrays_adjoint_source
+
+!================================================================
+
+subroutine comp_subarrays_adjoint_src(myrank, adj_source_file, &
+ xi_receiver,eta_receiver,gamma_receiver, nu,adj_sourcearray, &
+ xigll,yigll,zigll,NSTEP,iadjsrc,it_sub_adj,NSTEP_SUB_ADJ, &
+ NTSTEP_BETWEEN_READ_ADJSRC)
+
+ implicit none
+
+ include 'constants.h'
+
+! input -- notice here NSTEP is different from the NSTEP in the main program
+! instead NSTEP = iadjsrc_len(it_sub_adj), the length of this specific block
+ integer myrank, NSTEP
+
+ double precision xi_receiver, eta_receiver, gamma_receiver
+
+ character(len=*) adj_source_file
+
+! Vala added
+ integer it_sub_adj,NSTEP_SUB_ADJ,NTSTEP_BETWEEN_READ_ADJSRC
+ integer, dimension(NSTEP_SUB_ADJ,2) :: iadjsrc
+
+! output
+ real(kind=CUSTOM_REAL) :: adj_sourcearray(NTSTEP_BETWEEN_READ_ADJSRC,NDIM,NGLLX,NGLLY,NGLLZ)
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLY) :: yigll
+ double precision, dimension(NGLLZ) :: zigll
+
+ double precision, dimension(NDIM,NDIM) :: nu
+
+ double precision scale_displ
+
+ double precision :: hxir(NGLLX), hpxir(NGLLX), hetar(NGLLY), hpetar(NGLLY), &
+ hgammar(NGLLZ), hpgammar(NGLLZ)
+ real(kind=CUSTOM_REAL) :: adj_src(NSTEP,NDIM),adj_src_u(NSTEP,NDIM)
+
+ integer icomp, itime, i, j, k, ios
+ double precision :: junk
+ character(len=3) :: comp(NDIM)
+ character(len=150) :: filename
+
+ scale_displ = R_EARTH
+
+ call lagrange_any(xi_receiver,NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(eta_receiver,NGLLY,yigll,hetar,hpetar)
+ call lagrange_any(gamma_receiver,NGLLZ,zigll,hgammar,hpgammar)
+
+ adj_sourcearray(:,:,:,:,:) = 0.
+
+ comp = (/"LHN", "LHE", "LHZ"/)
+
+ do icomp = 1, NDIM
+
+ filename = 'SEM/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
+ open(unit = IIN, file = trim(filename), iostat = ios)
+ if (ios /= 0) call exit_MPI(myrank, ' file '//trim(filename)//'does not exist')
+ do itime =1,iadjsrc(it_sub_adj,1)-1
+ read(IIN,*) junk,junk
+ enddo
+ do itime = iadjsrc(it_sub_adj,1), iadjsrc(it_sub_adj,1)+NSTEP-1
+ read(IIN,*) junk, adj_src(itime-iadjsrc(it_sub_adj,1)+1,icomp)
+ enddo
+ close(IIN)
+
+ enddo
+
+ adj_src = adj_src/scale_displ
+
+ do itime = 1, NSTEP
+ adj_src_u(itime,:) = nu(1,:) * adj_src(itime,1) + nu(2,:) * adj_src(itime,2) + nu(3,:) * adj_src(itime,3)
+ enddo
+
+
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ adj_sourcearray(1:NSTEP,:,i,j,k) = hxir(i) * hetar(j) * hgammar(k) * adj_src_u(:,:)
+ enddo
+ enddo
+ enddo
+
+
+end subroutine comp_subarrays_adjoint_src
+
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_coordinates_grid.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_coordinates_grid.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_coordinates_grid.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/compute_element_properties.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_element_properties.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_element_properties.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,473 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! compute several rheological and geometrical properties for a given spectral element
+ subroutine compute_element_properties(ispec,iregion_code,idoubling, &
+ xstore,ystore,zstore,nspec, &
+ nspl,rspl,espl,espl2,ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ myrank,ibathy_topo,ATTENUATION,ATTENUATION_3D, &
+ ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xelm,yelm,zelm,shape3D,dershape3D,rmin,rmax,rhostore_local,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+!! DK DK added this for the merged version
+ kappavstore_local, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ nspec_ani,nspec_stacey,Qmu_store,tau_e_store,tau_s,T_c_source,rho_vp,rho_vs,&
+ AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V,AM_S,AS_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+
+ implicit none
+
+ include "constants.h"
+
+! aniso_mantle_model_variables
+ type aniso_mantle_model_variables
+ sequence
+ double precision beta(14,34,37,73)
+ double precision pro(47)
+ integer npar1
+ end type aniso_mantle_model_variables
+
+ type (aniso_mantle_model_variables) AMM_V
+! aniso_mantle_model_variables
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+! model_1066a_variables
+ type model_1066a_variables
+ sequence
+ double precision, dimension(NR_1066A) :: radius_1066a
+ double precision, dimension(NR_1066A) :: density_1066a
+ double precision, dimension(NR_1066A) :: vp_1066a
+ double precision, dimension(NR_1066A) :: vs_1066a
+ double precision, dimension(NR_1066A) :: Qkappa_1066a
+ double precision, dimension(NR_1066A) :: Qmu_1066a
+ end type model_1066a_variables
+
+ type (model_1066a_variables) M1066a_V
+! model_1066a_variables
+
+! model_ak135_variables
+ type model_ak135_variables
+ sequence
+ double precision, dimension(NR_AK135) :: radius_ak135
+ double precision, dimension(NR_AK135) :: density_ak135
+ double precision, dimension(NR_AK135) :: vp_ak135
+ double precision, dimension(NR_AK135) :: vs_ak135
+ double precision, dimension(NR_AK135) :: Qkappa_ak135
+ double precision, dimension(NR_AK135) :: Qmu_ak135
+ end type model_ak135_variables
+
+ type (model_ak135_variables) Mak135_V
+! model_ak135_variables
+
+! model_ref_variables
+ type model_ref_variables
+ sequence
+ double precision, dimension(NR_REF) :: radius_ref
+ double precision, dimension(NR_REF) :: density_ref
+ double precision, dimension(NR_REF) :: vpv_ref
+ double precision, dimension(NR_REF) :: vph_ref
+ double precision, dimension(NR_REF) :: vsv_ref
+ double precision, dimension(NR_REF) :: vsh_ref
+ double precision, dimension(NR_REF) :: eta_ref
+ double precision, dimension(NR_REF) :: Qkappa_ref
+ double precision, dimension(NR_REF) :: Qmu_ref
+ end type model_ref_variables
+
+ type (model_ref_variables) Mref_V
+! model_ref_variables
+
+! sea1d_model_variables
+ type sea1d_model_variables
+ sequence
+ double precision, dimension(NR_SEA1D) :: radius_sea1d
+ double precision, dimension(NR_SEA1D) :: density_sea1d
+ double precision, dimension(NR_SEA1D) :: vp_sea1d
+ double precision, dimension(NR_SEA1D) :: vs_sea1d
+ double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
+ double precision, dimension(NR_SEA1D) :: Qmu_sea1d
+ end type sea1d_model_variables
+
+ type (sea1d_model_variables) SEA1DM_V
+! sea1d_model_variables
+
+! three_d_mantle_model_variables
+ type three_d_mantle_model_variables
+ sequence
+ double precision dvs_a(0:NK,0:NS,0:NS)
+ double precision dvs_b(0:NK,0:NS,0:NS)
+ double precision dvp_a(0:NK,0:NS,0:NS)
+ double precision dvp_b(0:NK,0:NS,0:NS)
+ double precision spknt(NK+1)
+ double precision qq0(NK+1,NK+1)
+ double precision qq(3,NK+1,NK+1)
+ end type three_d_mantle_model_variables
+
+ type (three_d_mantle_model_variables) D3MM_V
+! three_d_mantle_model_variables
+
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+! sea99_s_model_variables
+ type sea99_s_model_variables
+ sequence
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ end type sea99_s_model_variables
+
+ type (sea99_s_model_variables) SEA99M_V
+! sea99_s_model_variables
+
+! crustal_model_variables
+ type crustal_model_variables
+ sequence
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
+ character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+ character(len=2) code(NKEYS_CRUST)
+ end type crustal_model_variables
+
+ type (crustal_model_variables) CM_V
+! crustal_model_variables
+
+! attenuation_model_storage
+ type attenuation_model_storage
+ sequence
+ integer Q_resolution
+ integer Q_max
+ double precision, dimension(:,:), pointer :: tau_e_storage
+ double precision, dimension(:), pointer :: Qmu_storage
+ end type attenuation_model_storage
+
+ type (attenuation_model_storage) AM_S
+! attenuation_model_storage
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+! correct number of spectral elements in each block depending on chunk type
+ integer ispec,nspec,nspec_stacey
+
+ integer REFERENCE_1D_MODEL,THREE_D_MODEL
+
+ logical ELLIPTICITY,TOPOGRAPHY
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST
+
+ logical ATTENUATION,ATTENUATION_3D,ABSORBING_CONDITIONS
+
+ double precision RICB,RCMB,R670,RMOHO, &
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+! arrays with the mesh in double precision
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! code for the four regions of the mesh
+ integer iregion_code
+
+! 3D shape functions and their derivatives
+ double precision, dimension(NGNOD,NGLLX,NGLLY,NGLLZ) :: shape3D
+ double precision, dimension(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ) :: dershape3D
+
+! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+ double precision, dimension(NGNOD) :: xelm,yelm,zelm
+
+! parameters needed to store the radii of the grid points
+! in the spherically symmetric Earth
+ integer idoubling(nspec)
+ double precision rmin,rmax
+
+! for model density and anisotropy
+ integer nspec_ani
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: kappavstore,kappahstore,muvstore,muhstore,eta_anisostore
+!! DK DK added this for the merged version
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: kappavstore_local
+!! DK DK changed this for merged version
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: rhostore_local
+
+! the 21 coefficients for an anisotropic medium in reduced notation
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_ani) :: &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store
+
+!! DK DK added this for merged version
+ integer :: value_idoubling_to_send
+
+!! DK DK changed this for merged version: made it local
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+
+! proc numbers for MPI
+ integer myrank
+
+! Stacey, indices for Clayton-Engquist absorbing conditions
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_stacey) :: rho_vp,rho_vs
+
+! attenuation
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: Qmu_store
+ double precision, dimension(N_SLS,NGLLX,NGLLY,NGLLZ,nspec) :: tau_e_store
+ double precision, dimension(N_SLS) :: tau_s
+ double precision T_c_source
+
+ integer, parameter :: maxker=200
+ integer, parameter :: maxl=72
+ integer, parameter :: maxcoe=2000
+ integer, parameter :: maxver=1000
+ integer, parameter :: maxhpa=2
+
+ integer numker
+ integer numhpa,numcof
+ integer ihpa,lmax,nylm
+ integer lmxhpa(maxhpa)
+ integer itypehpa(maxhpa)
+ integer ihpakern(maxker)
+ integer numcoe(maxhpa)
+ integer ivarkern(maxker)
+
+ integer nconpt(maxhpa),iver
+ integer iconpt(maxver,maxhpa)
+ real(kind=4) conpt(maxver,maxhpa)
+
+ real(kind=4) xlaspl(maxcoe,maxhpa)
+ real(kind=4) xlospl(maxcoe,maxhpa)
+ real(kind=4) radspl(maxcoe,maxhpa)
+ real(kind=4) coe(maxcoe,maxker)
+ real(kind=4) vercof(maxker)
+ real(kind=4) vercofd(maxker)
+
+ real(kind=4) ylmcof((maxl+1)**2,maxhpa)
+ real(kind=4) wk1(maxl+1)
+ real(kind=4) wk2(maxl+1)
+ real(kind=4) wk3(maxl+1)
+
+ character(len=80) kerstr
+ character(len=40) varstr(maxker)
+
+! **************
+! add topography on the Moho *before* adding the 3D crustal model so that the streched
+! mesh gets assigned the right model values
+!! DK DK added this for merged version because array idoubling is not allocated in outer core
+ if(iregion_code /= IREGION_OUTER_CORE) then
+ if(THREE_D_MODEL/=0 .and. (idoubling(ispec)==IFLAG_CRUST .or. idoubling(ispec)==IFLAG_220_80 &
+ .or. idoubling(ispec)==IFLAG_80_MOHO)) call moho_stretching(myrank,xelm,yelm,zelm,RMOHO,R220)
+ endif
+
+! compute values for the Earth model
+!! DK DK added this for merged version because array idoubling is not allocated in outer core
+ if(iregion_code /= IREGION_OUTER_CORE) then
+ value_idoubling_to_send = idoubling(ispec)
+ else
+ value_idoubling_to_send = IFLAG_OUTER_CORE_NORMAL
+ endif
+ call get_model(myrank,iregion_code,nspec, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,rhostore_local, &
+!! DK DK added this for the merged version
+ kappavstore_local, &
+ nspec_ani, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ xelm,yelm,zelm,shape3D,ispec, &
+ rmin,rmax,value_idoubling_to_send,rho_vp,rho_vs,nspec_stacey, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ ATTENUATION, ATTENUATION_3D, tau_s, tau_e_store, Qmu_store, T_c_source, &
+ size(tau_e_store,2), size(tau_e_store,3), size(tau_e_store,4), size(tau_e_store,5), &
+ ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ RCMB,RICB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN,&
+ AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V,AM_S,AS_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+
+! add topography without the crustal model
+!! DK DK added this for merged version because array idoubling is not allocated in outer core
+ if(iregion_code /= IREGION_OUTER_CORE) then
+ if(TOPOGRAPHY .and. (idoubling(ispec)==IFLAG_CRUST .or. idoubling(ispec)==IFLAG_220_80 &
+ .or. idoubling(ispec)==IFLAG_80_MOHO)) call add_topography(myrank,xelm,yelm,zelm,ibathy_topo,R220)
+ endif
+
+! add topography on 410 km and 650 km discontinuity in model S362ANI
+ if(THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI &
+ .or. THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM .or. THREE_D_MODEL == THREE_D_MODEL_S29EA) &
+ call add_topography_410_650(myrank,xelm,yelm,zelm,R220,R400,R670,R771, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,ylmcof,wk1,wk2,wk3,varstr)
+
+! CMB topography
+!! DK DK merged version: this will not work anymore because idoubling not allocated in outer core
+! if(THREE_D_MODEL == THREE_D_MODEL_S362ANI .and. (idoubling(ispec)==IFLAG_MANTLE_NORMAL &
+! .or. idoubling(ispec)==IFLAG_OUTER_CORE_NORMAL)) &
+! call add_topography_cmb(myrank,xelm,yelm,zelm,RTOPDDOUBLEPRIME,RCMB)
+
+! ICB topography
+!! DK DK merged version: this will not work anymore because idoubling not allocated in outer core
+! if(THREE_D_MODEL == THREE_D_MODEL_S362ANI .and. (idoubling(ispec)==IFLAG_OUTER_CORE_NORMAL &
+! .or. idoubling(ispec)==IFLAG_INNER_CORE_NORMAL .or. idoubling(ispec)==IFLAG_MIDDLE_CENTRAL_CUBE &
+! .or. idoubling(ispec)==IFLAG_BOTTOM_CENTRAL_CUBE .or. idoubling(ispec)==IFLAG_TOP_CENTRAL_CUBE &
+! .or. idoubling(ispec)==IFLAG_IN_FICTITIOUS_CUBE)) &
+! call add_topography_icb(myrank,xelm,yelm,zelm,RICB,RCMB)
+
+! make the Earth elliptical
+ if(ELLIPTICITY) call get_ellipticity(xelm,yelm,zelm,nspl,rspl,espl,espl2)
+
+! recompute coordinates and jacobian for real 3-D model
+ call calc_jacobian(myrank,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ xstore,ystore,zstore,xelm,yelm,zelm,shape3D,dershape3D,ispec,nspec)
+
+ end subroutine compute_element_properties
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_crust_mantle.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_crust_mantle.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_crust_mantle.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,632 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine compute_forces_crust_mantle(displ,accel,xstore,ystore,zstore, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ ibool,idoubling,R_memory,epsilondev,one_minus_sum_beta, &
+ alphaval,betaval,gammaval,factor_common,vx,vy,vz,vnspec,COMPUTE_AND_STORE_STRAIN, AM_V)
+
+ implicit none
+
+ include "constants.h"
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+! for forward or backward simulations
+ logical COMPUTE_AND_STORE_STRAIN
+
+! array with the local to global mapping per slice
+ integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling
+
+! displacement and acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: displ,accel
+
+! memory variables for attenuation
+! memory variables R_ij are stored at the local rather than global level
+! to allow for optimization of cache access by compiler
+ integer i_sls,i_memory
+! variable sized array variables for one_minus_sum_beta and factor_common
+ integer vx, vy, vz, vnspec
+
+ real(kind=CUSTOM_REAL) one_minus_sum_beta_use,minus_sum_beta
+ real(kind=CUSTOM_REAL), dimension(vx, vy, vz, vnspec) :: one_minus_sum_beta
+
+ integer iregion_selected
+
+! for attenuation
+ real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: R_memory
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: epsilondev
+
+! [alpha,beta,gamma]val reduced to N_SLS and factor_common to N_SLS*NUM_NODES
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
+ real(kind=CUSTOM_REAL), dimension(N_SLS, vx, vy, vz, vnspec) :: factor_common
+
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+
+! x y and z contain r theta and phi
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: xstore,ystore,zstore
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
+ kappavstore,muvstore
+
+! store anisotropic properties only where needed to save memory
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
+ kappahstore,muhstore,eta_anisostore
+
+ integer ispec,iglob
+ integer i,j,k,l
+
+! the 21 coefficients for an anisotropic medium in reduced notation
+ real(kind=CUSTOM_REAL) c11,c22,c33,c44,c55,c66,c12,c13,c23,c14,c24,c34,c15,c25,c35,c45,c16,c26,c36,c46,c56
+
+ real(kind=CUSTOM_REAL) rhovphsq,sinphifour,cosphisq,sinphisq,costhetasq,rhovsvsq,sinthetasq, &
+ cosphifour,costhetafour,rhovpvsq,sinthetafour,rhovshsq,cosfourphi, &
+ costwotheta,cosfourtheta,sintwophisq,costheta,sinphi,sintheta,cosphi, &
+ sintwotheta,costwophi,sintwophi,costwothetasq,costwophisq,phi,theta
+
+ real(kind=CUSTOM_REAL) two_rhovpvsq,two_rhovphsq,two_rhovsvsq,two_rhovshsq
+ real(kind=CUSTOM_REAL) four_rhovpvsq,four_rhovphsq,four_rhovsvsq,four_rhovshsq
+
+ real(kind=CUSTOM_REAL) twoetaminone,etaminone,eta_aniso
+ real(kind=CUSTOM_REAL) two_eta_aniso,four_eta_aniso,six_eta_aniso
+
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+
+ real(kind=CUSTOM_REAL) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=CUSTOM_REAL) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+
+ real(kind=CUSTOM_REAL) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
+
+ real(kind=CUSTOM_REAL) hp1,hp2,hp3
+ real(kind=CUSTOM_REAL) fac1,fac2,fac3
+ real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
+ real(kind=CUSTOM_REAL) kappal,kappavl,kappahl,muvl,muhl
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sum_terms
+
+ real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
+ real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
+ real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
+
+! for gravity
+ real(kind=CUSTOM_REAL) radius_cr
+
+! ****************************************************
+! big loop over all spectral elements in the solid
+! ****************************************************
+
+! set acceleration to zero
+ accel(:,:) = 0._CUSTOM_REAL
+
+ do ispec = 1,NSPEC_CRUST_MANTLE
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
+
+ tempy1l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
+
+ tempz1l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ hp1 = hprime_xx(i,l)
+ iglob = ibool(l,j,k,ispec)
+ tempx1l = tempx1l + displ(1,iglob)*hp1
+ tempy1l = tempy1l + displ(2,iglob)*hp1
+ tempz1l = tempz1l + displ(3,iglob)*hp1
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ hp2 = hprime_yy(j,l)
+ iglob = ibool(i,l,k,ispec)
+ tempx2l = tempx2l + displ(1,iglob)*hp2
+ tempy2l = tempy2l + displ(2,iglob)*hp2
+ tempz2l = tempz2l + displ(3,iglob)*hp2
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ hp3 = hprime_zz(k,l)
+ iglob = ibool(i,j,l,ispec)
+ tempx3l = tempx3l + displ(1,iglob)*hp3
+ tempy3l = tempy3l + displ(2,iglob)*hp3
+ tempz3l = tempz3l + displ(3,iglob)*hp3
+ enddo
+
+! get derivatives of ux, uy and uz with respect to x, y and z
+
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+
+! compute the jacobian
+ jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
+ - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl))
+
+ duxdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ duxdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ duxdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+
+ duydxl = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
+ duydyl = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
+ duydzl = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
+
+ duzdxl = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
+ duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
+ duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
+
+! precompute some sums to save CPU time
+ duxdxl_plus_duydyl = duxdxl + duydyl
+ duxdxl_plus_duzdzl = duxdxl + duzdzl
+ duydyl_plus_duzdzl = duydyl + duzdzl
+ duxdyl_plus_duydxl = duxdyl + duydxl
+ duzdxl_plus_duxdzl = duzdxl + duxdzl
+ duzdyl_plus_duydzl = duzdyl + duydzl
+
+! compute deviatoric strain
+ if (COMPUTE_AND_STORE_STRAIN) then
+ epsilondev_loc(1,i,j,k) = duxdxl - ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilondev_loc(2,i,j,k) = duydyl - ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
+ epsilondev_loc(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl
+ epsilondev_loc(5,i,j,k) = 0.5 * duzdyl_plus_duydzl
+ endif
+
+! precompute terms for attenuation if needed
+ if(ATTENUATION_VAL) then
+ radius_cr = xstore(ibool(i,j,k,ispec))
+ call get_attenuation_index(idoubling(ispec), dble(radius_cr), iregion_selected, .FALSE., AM_V)
+ one_minus_sum_beta_use = one_minus_sum_beta(1,1,1,iregion_selected)
+ minus_sum_beta = one_minus_sum_beta_use - 1.0
+ endif
+
+!
+! compute either isotropic or anisotropic elements
+!
+
+ if(ANISOTROPIC_3D_MANTLE_VAL) then
+
+ else
+
+! do not use transverse isotropy except if element is between d220 and Moho
+ if(.not. (TRANSVERSE_ISOTROPY_VAL .and. (idoubling(ispec)==IFLAG_220_80 .or. idoubling(ispec)==IFLAG_80_MOHO))) then
+
+! layer with no transverse isotropy, use kappav and muv
+ kappal = kappavstore(i,j,k,ispec)
+ mul = muvstore(i,j,k,ispec)
+
+! use unrelaxed parameters if attenuation
+ if(ATTENUATION_VAL) mul = mul * one_minus_sum_beta_use
+
+ lambdalplus2mul = kappal + FOUR_THIRDS * mul
+ lambdal = lambdalplus2mul - 2.*mul
+
+! compute stress sigma
+
+ sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
+ sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
+ sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
+
+ sigma_xy = mul*duxdyl_plus_duydxl
+ sigma_xz = mul*duzdxl_plus_duxdzl
+ sigma_yz = mul*duzdyl_plus_duydzl
+
+ else
+
+! use Kappa and mu from transversely isotropic model
+ kappavl = kappavstore(i,j,k,ispec)
+ muvl = muvstore(i,j,k,ispec)
+
+ kappahl = kappahstore(i,j,k,ispec)
+ muhl = muhstore(i,j,k,ispec)
+
+! use unrelaxed parameters if attenuation
+! eta does not need to be shifted since it is a ratio
+ if(ATTENUATION_VAL) then
+ muvl = muvl * one_minus_sum_beta_use
+ muhl = muhl * one_minus_sum_beta_use
+ endif
+
+ rhovpvsq = kappavl + FOUR_THIRDS * muvl !!! that is C
+ rhovphsq = kappahl + FOUR_THIRDS * muhl !!! that is A
+
+ rhovsvsq = muvl !!! that is L
+ rhovshsq = muhl !!! that is N
+
+ eta_aniso = eta_anisostore(i,j,k,ispec) !!! that is F / (A - 2 L)
+
+! use mesh coordinates to get theta and phi
+! ystore and zstore contain theta and phi
+
+ iglob = ibool(i,j,k,ispec)
+ theta = ystore(iglob)
+ phi = zstore(iglob)
+
+ costheta = cos(theta)
+ sintheta = sin(theta)
+ cosphi = cos(phi)
+ sinphi = sin(phi)
+
+ costhetasq = costheta * costheta
+ sinthetasq = sintheta * sintheta
+ cosphisq = cosphi * cosphi
+ sinphisq = sinphi * sinphi
+
+ costhetafour = costhetasq * costhetasq
+ sinthetafour = sinthetasq * sinthetasq
+ cosphifour = cosphisq * cosphisq
+ sinphifour = sinphisq * sinphisq
+
+ costwotheta = cos(2.*theta)
+ sintwotheta = sin(2.*theta)
+ costwophi = cos(2.*phi)
+ sintwophi = sin(2.*phi)
+
+ cosfourtheta = cos(4.*theta)
+ cosfourphi = cos(4.*phi)
+
+ costwothetasq = costwotheta * costwotheta
+
+ costwophisq = costwophi * costwophi
+ sintwophisq = sintwophi * sintwophi
+
+ etaminone = eta_aniso - 1.
+ twoetaminone = 2. * eta_aniso - 1.
+
+! precompute some products to reduce the CPU time
+
+ two_eta_aniso = 2.*eta_aniso
+ four_eta_aniso = 4.*eta_aniso
+ six_eta_aniso = 6.*eta_aniso
+
+ two_rhovpvsq = 2.*rhovpvsq
+ two_rhovphsq = 2.*rhovphsq
+ two_rhovsvsq = 2.*rhovsvsq
+ two_rhovshsq = 2.*rhovshsq
+
+ four_rhovpvsq = 4.*rhovpvsq
+ four_rhovphsq = 4.*rhovphsq
+ four_rhovsvsq = 4.*rhovsvsq
+ four_rhovshsq = 4.*rhovshsq
+
+! the 21 anisotropic coefficients computed using Mathematica
+
+ c11 = rhovphsq*sinphifour + 2.*cosphisq*sinphisq* &
+ (rhovphsq*costhetasq + (eta_aniso*rhovphsq + two_rhovsvsq - two_eta_aniso*rhovsvsq)* &
+ sinthetasq) + cosphifour* &
+ (rhovphsq*costhetafour + 2.*(eta_aniso*rhovphsq + two_rhovsvsq - two_eta_aniso*rhovsvsq)* &
+ costhetasq*sinthetasq + rhovpvsq*sinthetafour)
+
+ c12 = ((rhovphsq - two_rhovshsq)*(3. + cosfourphi)*costhetasq)/4. - &
+ four_rhovshsq*cosphisq*costhetasq*sinphisq + &
+ (rhovphsq*(11. + 4.*costwotheta + cosfourtheta)*sintwophisq)/32. + &
+ eta_aniso*(rhovphsq - two_rhovsvsq)*(cosphifour + &
+ 2.*cosphisq*costhetasq*sinphisq + sinphifour)*sinthetasq + &
+ rhovpvsq*cosphisq*sinphisq*sinthetafour - &
+ rhovsvsq*sintwophisq*sinthetafour
+
+ c13 = (cosphisq*(rhovphsq + six_eta_aniso*rhovphsq + rhovpvsq - four_rhovsvsq - &
+ 12.*eta_aniso*rhovsvsq + (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - &
+ four_eta_aniso*rhovsvsq)*cosfourtheta))/8. + &
+ sinphisq*(eta_aniso*(rhovphsq - two_rhovsvsq)*costhetasq + &
+ (rhovphsq - two_rhovshsq)*sinthetasq)
+
+ c14 = costheta*sinphi*((cosphisq* &
+ (-rhovphsq + rhovpvsq + four_rhovshsq - four_rhovsvsq + &
+ (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + four_rhovsvsq - &
+ four_eta_aniso*rhovsvsq)*costwotheta))/2. + &
+ (etaminone*rhovphsq + 2.*(rhovshsq - eta_aniso*rhovsvsq))*sinphisq)* sintheta
+
+ c15 = cosphi*costheta*((cosphisq* (-rhovphsq + rhovpvsq + &
+ (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - four_eta_aniso*rhovsvsq)* &
+ costwotheta))/2. + etaminone*(rhovphsq - two_rhovsvsq)*sinphisq)*sintheta
+
+ c16 = (cosphi*sinphi*(cosphisq* (-rhovphsq + rhovpvsq + &
+ (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + four_rhovsvsq - &
+ four_eta_aniso*rhovsvsq)*costwotheta) + &
+ 2.*etaminone*(rhovphsq - two_rhovsvsq)*sinphisq)*sinthetasq)/2.
+
+ c22 = rhovphsq*cosphifour + 2.*cosphisq*sinphisq* &
+ (rhovphsq*costhetasq + (eta_aniso*rhovphsq + two_rhovsvsq - two_eta_aniso*rhovsvsq)* &
+ sinthetasq) + sinphifour* &
+ (rhovphsq*costhetafour + 2.*(eta_aniso*rhovphsq + two_rhovsvsq - two_eta_aniso*rhovsvsq)* &
+ costhetasq*sinthetasq + rhovpvsq*sinthetafour)
+
+ c23 = ((rhovphsq + six_eta_aniso*rhovphsq + rhovpvsq - four_rhovsvsq - 12.*eta_aniso*rhovsvsq + &
+ (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - four_eta_aniso*rhovsvsq)* &
+ cosfourtheta)*sinphisq)/8. + &
+ cosphisq*(eta_aniso*(rhovphsq - two_rhovsvsq)*costhetasq + &
+ (rhovphsq - two_rhovshsq)*sinthetasq)
+
+ c24 = costheta*sinphi*(etaminone*(rhovphsq - two_rhovsvsq)*cosphisq + &
+ ((-rhovphsq + rhovpvsq + (twoetaminone*rhovphsq - rhovpvsq + &
+ four_rhovsvsq - four_eta_aniso*rhovsvsq)*costwotheta)*sinphisq)/2.)*sintheta
+
+ c25 = cosphi*costheta*((etaminone*rhovphsq + 2.*(rhovshsq - eta_aniso*rhovsvsq))* &
+ cosphisq + ((-rhovphsq + rhovpvsq + four_rhovshsq - four_rhovsvsq + &
+ (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + four_rhovsvsq - &
+ four_eta_aniso*rhovsvsq)*costwotheta)*sinphisq)/2.)*sintheta
+
+ c26 = (cosphi*sinphi*(2.*etaminone*(rhovphsq - two_rhovsvsq)*cosphisq + &
+ (-rhovphsq + rhovpvsq + (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + four_rhovsvsq - &
+ four_eta_aniso*rhovsvsq)*costwotheta)*sinphisq)*sinthetasq)/2.
+
+ c33 = rhovpvsq*costhetafour + 2.*(eta_aniso*(rhovphsq - two_rhovsvsq) + two_rhovsvsq)* &
+ costhetasq*sinthetasq + rhovphsq*sinthetafour
+
+ c34 = -((rhovphsq - rhovpvsq + (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq &
+ - four_eta_aniso*rhovsvsq)*costwotheta)*sinphi*sintwotheta)/4.
+
+ c35 = -(cosphi*(rhovphsq - rhovpvsq + &
+ (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - four_eta_aniso*rhovsvsq)* &
+ costwotheta)*sintwotheta)/4.
+
+ c36 = -((rhovphsq - rhovpvsq - four_rhovshsq + four_rhovsvsq + &
+ (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - four_eta_aniso*rhovsvsq)* &
+ costwotheta)*sintwophi*sinthetasq)/4.
+
+ c44 = cosphisq*(rhovsvsq*costhetasq + rhovshsq*sinthetasq) + &
+ sinphisq*(rhovsvsq*costwothetasq + &
+ (rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq + four_eta_aniso*rhovsvsq)*costhetasq* sinthetasq)
+
+ c45 = ((rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq - two_rhovshsq - two_rhovsvsq + &
+ four_eta_aniso*rhovsvsq + (rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq + &
+ 4.*etaminone*rhovsvsq)*costwotheta)*sintwophi*sinthetasq)/4.
+
+ c46 = -(cosphi*costheta*((rhovshsq - rhovsvsq)*cosphisq - &
+ ((rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq - two_rhovshsq - two_rhovsvsq + &
+ four_eta_aniso*rhovsvsq + (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + &
+ four_rhovsvsq - four_eta_aniso*rhovsvsq)*costwotheta)*sinphisq)/2.)* sintheta)
+
+ c55 = sinphisq*(rhovsvsq*costhetasq + rhovshsq*sinthetasq) + &
+ cosphisq*(rhovsvsq*costwothetasq + &
+ (rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq + four_eta_aniso*rhovsvsq)*costhetasq* sinthetasq)
+
+ c56 = costheta*sinphi*((cosphisq* &
+ (rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq - two_rhovshsq - two_rhovsvsq + &
+ four_eta_aniso*rhovsvsq + (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + &
+ four_rhovsvsq - four_eta_aniso*rhovsvsq)*costwotheta))/2. + &
+ (-rhovshsq + rhovsvsq)*sinphisq)*sintheta
+
+ c66 = rhovshsq*costwophisq*costhetasq - &
+ 2.*(rhovphsq - two_rhovshsq)*cosphisq*costhetasq*sinphisq + &
+ (rhovphsq*(11. + 4.*costwotheta + cosfourtheta)*sintwophisq)/32. - &
+ (rhovsvsq*(-6. - 2.*cosfourphi + cos(4.*phi - 2.*theta) - 2.*costwotheta + &
+ cos(2.*(2.*phi + theta)))*sinthetasq)/8. + &
+ rhovpvsq*cosphisq*sinphisq*sinthetafour - &
+ (eta_aniso*(rhovphsq - two_rhovsvsq)*sintwophisq*sinthetafour)/2.
+
+! general expression of stress tensor for full Cijkl with 21 coefficients
+
+ sigma_xx = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
+ c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
+
+ sigma_yy = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
+ c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
+
+ sigma_zz = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
+ c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
+
+ sigma_xy = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
+ c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
+
+ sigma_xz = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
+ c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
+
+ sigma_yz = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
+ c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
+
+ endif
+
+ endif ! end of test whether isotropic or anisotropic element
+
+! subtract memory variables if attenuation
+ if(ATTENUATION_VAL) then
+ do i_sls = 1,N_SLS
+ R_xx_val = R_memory(1,i_sls,i,j,k,ispec)
+ R_yy_val = R_memory(2,i_sls,i,j,k,ispec)
+ sigma_xx = sigma_xx - R_xx_val
+ sigma_yy = sigma_yy - R_yy_val
+ sigma_zz = sigma_zz + R_xx_val + R_yy_val
+ sigma_xy = sigma_xy - R_memory(3,i_sls,i,j,k,ispec)
+ sigma_xz = sigma_xz - R_memory(4,i_sls,i,j,k,ispec)
+ sigma_yz = sigma_yz - R_memory(5,i_sls,i,j,k,ispec)
+ enddo
+ endif
+
+! form dot product with test vector, symmetric form
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+
+ enddo
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0._CUSTOM_REAL
+ tempy1l = 0._CUSTOM_REAL
+ tempz1l = 0._CUSTOM_REAL
+
+ tempx2l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
+
+ tempx3l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ fac1 = hprimewgll_xx(l,i)
+ tempx1l = tempx1l + tempx1(l,j,k)*fac1
+ tempy1l = tempy1l + tempy1(l,j,k)*fac1
+ tempz1l = tempz1l + tempz1(l,j,k)*fac1
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ fac2 = hprimewgll_yy(l,j)
+ tempx2l = tempx2l + tempx2(i,l,k)*fac2
+ tempy2l = tempy2l + tempy2(i,l,k)*fac2
+ tempz2l = tempz2l + tempz2(i,l,k)*fac2
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ fac3 = hprimewgll_zz(l,k)
+ tempx3l = tempx3l + tempx3(i,j,l)*fac3
+ tempy3l = tempy3l + tempy3(i,j,l)*fac3
+ tempz3l = tempz3l + tempz3(i,j,l)*fac3
+ enddo
+
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
+
+ sum_terms(1,i,j,k) = - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
+ sum_terms(2,i,j,k) = - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
+ sum_terms(3,i,j,k) = - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
+
+ enddo
+ enddo
+ enddo
+
+! sum contributions from each element to the global mesh and add gravity terms
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ accel(1,iglob) = accel(1,iglob) + sum_terms(1,i,j,k)
+ accel(2,iglob) = accel(2,iglob) + sum_terms(2,i,j,k)
+ accel(3,iglob) = accel(3,iglob) + sum_terms(3,i,j,k)
+ enddo
+ enddo
+ enddo
+
+! update memory variables based upon the Runge-Kutta scheme
+! convention for attenuation
+! term in xx = 1
+! term in yy = 2
+! term in xy = 3
+! term in xz = 4
+! term in yz = 5
+! term in zz not computed since zero trace
+
+ if(ATTENUATION_VAL) then
+
+! use Runge-Kutta scheme to march in time
+ do i_sls = 1,N_SLS
+ do i_memory = 1,5
+
+! get coefficients for that standard linear solid
+! IMPROVE we use mu_v here even if there is some anisotropy
+! IMPROVE we should probably use an average value instead
+
+ R_memory(i_memory,i_sls,:,:,:,ispec) = alphaval(i_sls) * &
+ R_memory(i_memory,i_sls,:,:,:,ispec) + &
+ factor_common(i_sls,1,1,1,iregion_selected) * muvstore(:,:,:,ispec) * &
+ (betaval(i_sls) * epsilondev(i_memory,:,:,:,ispec) + &
+ gammaval(i_sls) * epsilondev_loc(i_memory,:,:,:))
+ enddo
+ enddo
+
+ endif
+
+! save deviatoric strain for Runge-Kutta scheme
+ if(COMPUTE_AND_STORE_STRAIN) epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
+
+ enddo ! spectral element loop
+
+ end subroutine compute_forces_crust_mantle
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_inner_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_inner_core.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_inner_core.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,399 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine compute_forces_inner_core(displ,accel,xstore, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappavstore,muvstore,ibool,idoubling, &
+ R_memory,epsilondev,&
+ one_minus_sum_beta,alphaval,betaval,gammaval,factor_common, &
+ vx,vy,vz,vnspec,COMPUTE_AND_STORE_STRAIN, AM_V)
+
+ implicit none
+
+ include "constants.h"
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+! for forward or backward simulations
+ logical COMPUTE_AND_STORE_STRAIN
+
+! displacement and acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: displ,accel
+
+! for attenuation
+! memory variables R_ij are stored at the local rather than global level
+! to allow for optimization of cache access by compiler
+ integer i_sls,i_memory
+ real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
+
+! variable lengths for factor_common and one_minus_sum_beta
+ integer vx, vy, vz, vnspec
+
+ real(kind=CUSTOM_REAL), dimension(vx, vy, vz, vnspec) :: one_minus_sum_beta
+
+ real(kind=CUSTOM_REAL), dimension(N_SLS, vx, vy, vz, vnspec) :: factor_common
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: R_memory
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilondev
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
+
+! array with the local to global mapping per slice
+ integer, dimension(NSPEC_INNER_CORE) :: idoubling
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: xix,xiy,xiz, &
+ etax,etay,etaz,gammax,gammay,gammaz
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: kappavstore,muvstore
+
+ integer ispec,iglob
+ integer i,j,k,l
+
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+
+ real(kind=CUSTOM_REAL) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=CUSTOM_REAL) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+
+ real(kind=CUSTOM_REAL) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
+
+ real(kind=CUSTOM_REAL) hp1,hp2,hp3
+ real(kind=CUSTOM_REAL) fac1,fac2,fac3
+ real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
+ real(kind=CUSTOM_REAL) kappal
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sum_terms
+
+ real(kind=CUSTOM_REAL) minus_sum_beta
+
+ real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
+ real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
+ real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
+
+! for gravity
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: xstore
+ integer iregion_selected
+
+ real(kind=CUSTOM_REAL) radius_cr
+
+! ****************************************************
+! big loop over all spectral elements in the solid
+! ****************************************************
+
+! set acceleration to zero
+ accel(:,:) = 0._CUSTOM_REAL
+
+ do ispec = 1,NSPEC_INNER_CORE
+
+! exclude fictitious elements in central cube
+ if(idoubling(ispec) /= IFLAG_IN_FICTITIOUS_CUBE) then
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
+
+ tempy1l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
+
+ tempz1l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ hp1 = hprime_xx(i,l)
+ iglob = ibool(l,j,k,ispec)
+ tempx1l = tempx1l + displ(1,iglob)*hp1
+ tempy1l = tempy1l + displ(2,iglob)*hp1
+ tempz1l = tempz1l + displ(3,iglob)*hp1
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ hp2 = hprime_yy(j,l)
+ iglob = ibool(i,l,k,ispec)
+ tempx2l = tempx2l + displ(1,iglob)*hp2
+ tempy2l = tempy2l + displ(2,iglob)*hp2
+ tempz2l = tempz2l + displ(3,iglob)*hp2
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ hp3 = hprime_zz(k,l)
+ iglob = ibool(i,j,l,ispec)
+ tempx3l = tempx3l + displ(1,iglob)*hp3
+ tempy3l = tempy3l + displ(2,iglob)*hp3
+ tempz3l = tempz3l + displ(3,iglob)*hp3
+ enddo
+
+! get derivatives of ux, uy and uz with respect to x, y and z
+
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+
+! compute the jacobian
+ jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
+ - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl))
+
+ duxdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ duxdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ duxdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+
+ duydxl = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
+ duydyl = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
+ duydzl = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
+
+ duzdxl = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
+ duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
+ duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
+
+! precompute some sums to save CPU time
+ duxdxl_plus_duydyl = duxdxl + duydyl
+ duxdxl_plus_duzdzl = duxdxl + duzdzl
+ duydyl_plus_duzdzl = duydyl + duzdzl
+ duxdyl_plus_duydxl = duxdyl + duydxl
+ duzdxl_plus_duxdzl = duzdxl + duxdzl
+ duzdyl_plus_duydzl = duzdyl + duydzl
+
+! compute deviatoric strain
+ if (COMPUTE_AND_STORE_STRAIN) then
+ epsilondev_loc(1,i,j,k) = duxdxl - ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilondev_loc(2,i,j,k) = duydyl - ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
+ epsilondev_loc(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl
+ epsilondev_loc(5,i,j,k) = 0.5 * duzdyl_plus_duydzl
+ endif
+
+ if(ATTENUATION_VAL) then
+ radius_cr = xstore(ibool(i,j,k,ispec))
+ call get_attenuation_index(idoubling(ispec), dble(radius_cr), iregion_selected, .TRUE., AM_V)
+ minus_sum_beta = one_minus_sum_beta(1,1,1,iregion_selected) - 1.0
+ endif ! ATTENUATION_VAL
+
+ if(ANISOTROPIC_INNER_CORE_VAL) then
+
+ else
+
+! inner core with no anisotropy, use kappav and muv for instance
+! layer with no anisotropy, use kappav and muv for instance
+ kappal = kappavstore(i,j,k,ispec)
+ mul = muvstore(i,j,k,ispec)
+
+! use unrelaxed parameters if attenuation
+ if(ATTENUATION_VAL) then
+ mul = mul * one_minus_sum_beta(1,1,1,iregion_selected)
+ endif
+
+ lambdalplus2mul = kappal + FOUR_THIRDS * mul
+ lambdal = lambdalplus2mul - 2.*mul
+
+! compute stress sigma
+
+ sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
+ sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
+ sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
+
+ sigma_xy = mul*duxdyl_plus_duydxl
+ sigma_xz = mul*duzdxl_plus_duxdzl
+ sigma_yz = mul*duzdyl_plus_duydzl
+
+ endif
+
+! subtract memory variables if attenuation
+ if(ATTENUATION_VAL) then
+ do i_sls = 1,N_SLS
+ R_xx_val = R_memory(1,i_sls,i,j,k,ispec)
+ R_yy_val = R_memory(2,i_sls,i,j,k,ispec)
+ sigma_xx = sigma_xx - R_xx_val
+ sigma_yy = sigma_yy - R_yy_val
+ sigma_zz = sigma_zz + R_xx_val + R_yy_val
+ sigma_xy = sigma_xy - R_memory(3,i_sls,i,j,k,ispec)
+ sigma_xz = sigma_xz - R_memory(4,i_sls,i,j,k,ispec)
+ sigma_yz = sigma_yz - R_memory(5,i_sls,i,j,k,ispec)
+ enddo
+ endif
+
+! form dot product with test vector, symmetric form
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+
+ enddo
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0._CUSTOM_REAL
+ tempy1l = 0._CUSTOM_REAL
+ tempz1l = 0._CUSTOM_REAL
+
+ tempx2l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
+
+ tempx3l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ fac1 = hprimewgll_xx(l,i)
+ tempx1l = tempx1l + tempx1(l,j,k)*fac1
+ tempy1l = tempy1l + tempy1(l,j,k)*fac1
+ tempz1l = tempz1l + tempz1(l,j,k)*fac1
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ fac2 = hprimewgll_yy(l,j)
+ tempx2l = tempx2l + tempx2(i,l,k)*fac2
+ tempy2l = tempy2l + tempy2(i,l,k)*fac2
+ tempz2l = tempz2l + tempz2(i,l,k)*fac2
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ fac3 = hprimewgll_zz(l,k)
+ tempx3l = tempx3l + tempx3(i,j,l)*fac3
+ tempy3l = tempy3l + tempy3(i,j,l)*fac3
+ tempz3l = tempz3l + tempz3(i,j,l)*fac3
+ enddo
+
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
+
+ sum_terms(1,i,j,k) = - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
+ sum_terms(2,i,j,k) = - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
+ sum_terms(3,i,j,k) = - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
+
+ enddo
+ enddo
+ enddo
+
+! sum contributions from each element to the global mesh and add gravity terms
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ accel(:,iglob) = accel(:,iglob) + sum_terms(:,i,j,k)
+ enddo
+ enddo
+ enddo
+
+! use Runge-Kutta scheme to march memory variables in time
+! convention for attenuation
+! term in xx = 1
+! term in yy = 2
+! term in xy = 3
+! term in xz = 4
+! term in yz = 5
+! term in zz not computed since zero trace
+
+ if(ATTENUATION_VAL) then
+
+ do i_sls = 1,N_SLS
+ do i_memory = 1,5
+ R_memory(i_memory,i_sls,:,:,:,ispec) = &
+ alphaval(i_sls) * &
+ R_memory(i_memory,i_sls,:,:,:,ispec) + muvstore(:,:,:,ispec) * &
+ factor_common(i_sls,1,1,1,iregion_selected) * &
+ (betaval(i_sls) * &
+ epsilondev(i_memory,:,:,:,ispec) + gammaval(i_sls) * epsilondev_loc(i_memory,:,:,:))
+ enddo
+ enddo
+
+ endif
+
+ if (COMPUTE_AND_STORE_STRAIN) then
+! save deviatoric strain for Runge-Kutta scheme
+ epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
+ endif
+
+ endif ! end test to exclude fictitious elements in central cube
+
+ enddo ! spectral element loop
+
+ end subroutine compute_forces_inner_core
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_outer_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_outer_core.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/compute_forces_outer_core.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,224 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine compute_forces_outer_core(d_ln_density_dr_table, &
+ displfluid,accelfluid,xstore,ystore,zstore, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,ibool)
+
+ implicit none
+
+ include "constants.h"
+
+! include values created by the mesher
+! done for performance only using static allocation to allow for loop unrolling
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+! displacement and acceleration
+ real(kind=CUSTOM_REAL), dimension(nglob_outer_core) :: displfluid,accelfluid
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec_outer_core) :: ibool
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_outer_core) :: xix,xiy,xiz, &
+ etax,etay,etaz,gammax,gammay,gammaz
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: tempx1,tempx2,tempx3
+
+! for gravity
+ integer int_radius
+ double precision radius,theta,phi
+ double precision cos_theta,sin_theta,cos_phi,sin_phi
+ double precision, dimension(NRAD_GRAVITY) :: d_ln_density_dr_table
+ real(kind=CUSTOM_REAL), dimension(nglob_outer_core) :: xstore,ystore,zstore
+
+ integer ispec,iglob
+ integer i,j,k,l
+
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) dpotentialdxl,dpotentialdyl,dpotentialdzl
+ real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
+
+ double precision grad_x_ln_rho,grad_y_ln_rho,grad_z_ln_rho
+! ****************************************************
+! big loop over all spectral elements in the fluid
+! ****************************************************
+
+! set acceleration to zero
+ accelfluid(:) = 0._CUSTOM_REAL
+
+ do ispec = 1,NSPEC_OUTER_CORE
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ iglob = ibool(i,j,k,ispec)
+
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ tempx1l = tempx1l + displfluid(ibool(l,j,k,ispec)) * hprime_xx(i,l)
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ tempx2l = tempx2l + displfluid(ibool(i,l,k,ispec)) * hprime_yy(j,l)
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ tempx3l = tempx3l + displfluid(ibool(i,j,l,ispec)) * hprime_zz(k,l)
+ enddo
+
+! get derivatives of velocity potential with respect to x, y and z
+
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+
+! compute the jacobian
+ jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
+ - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl))
+
+ dpotentialdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ dpotentialdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ dpotentialdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+
+! add (chi/rho)grad(rho) term in no gravity case
+
+! With regards to the non-gravitating case: we cannot set N^2 = 0 *and* let g = 0.
+! We can *either* assume N^2 = 0 but keep gravity g, *or* we can assume that gravity
+! is negligible to begin with, as in our GJI 2002a, in which case N does not arise.
+! We get:
+!
+! \ddot\chi = \rho^{-1}\kappa\bdel\cdot(\bdel\chi+\chi\bdel\ln\rho)
+!
+! Then the displacement is
+!
+! \bu = \bdel\chi+\chi\bdel\ln\rho = \rho^{-1}\bdel(\rho\chi)
+!
+! and the pressure is
+!
+! p = -\rho\ddot{\chi}
+!
+! Thus in our 2002b GJI paper eqn (21) is wrong, and equation (41)
+! in our AGU monograph is incorrect; these equations should be replaced by
+!
+! \ddot\chi = \rho^{-1}\kappa\bdel\cdot(\bdel\chi+\chi\bdel\ln\rho)
+!
+! Note that the fluid potential we use in GJI 2002a differs from the one used here:
+!
+! \chi_GJI2002a = \rho\partial\t\chi
+!
+! such that
+!
+! \bv = \partial_t\bu=\rho^{-1}\bdel\chi_GJI2002a (GJI 2002a eqn 20)
+!
+! p = - \partial_t\chi_GJI2002a (GJI 2002a eqn 19)
+
+! use mesh coordinates to get theta and phi
+! x y z contain r theta phi
+
+ radius = dble(xstore(iglob))
+ theta = dble(ystore(iglob))
+ phi = dble(zstore(iglob))
+
+ cos_theta = dcos(theta)
+ sin_theta = dsin(theta)
+ cos_phi = dcos(phi)
+ sin_phi = dsin(phi)
+
+ int_radius = nint(radius * R_EARTH_KM * 10.d0)
+
+! grad(rho)/rho in Cartesian components
+ grad_x_ln_rho = sin_theta * cos_phi * d_ln_density_dr_table(int_radius)
+ grad_y_ln_rho = sin_theta * sin_phi * d_ln_density_dr_table(int_radius)
+ grad_z_ln_rho = cos_theta * d_ln_density_dr_table(int_radius)
+
+! adding (chi/rho)grad(rho)
+ dpotentialdxl = dpotentialdxl + displfluid(iglob) * grad_x_ln_rho
+ dpotentialdyl = dpotentialdyl + displfluid(iglob) * grad_y_ln_rho
+ dpotentialdzl = dpotentialdzl + displfluid(iglob) * grad_z_ln_rho
+
+ tempx1(i,j,k) = jacobianl*(xixl*dpotentialdxl + xiyl*dpotentialdyl + xizl*dpotentialdzl)
+ tempx2(i,j,k) = jacobianl*(etaxl*dpotentialdxl + etayl*dpotentialdyl + etazl*dpotentialdzl)
+ tempx3(i,j,k) = jacobianl*(gammaxl*dpotentialdxl + gammayl*dpotentialdyl + gammazl*dpotentialdzl)
+
+ enddo
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ tempx1l = tempx1l + tempx1(l,j,k) * hprimewgll_xx(l,i)
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ tempx2l = tempx2l + tempx2(i,l,k) * hprimewgll_yy(l,j)
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ tempx3l = tempx3l + tempx3(i,j,l) * hprimewgll_zz(l,k)
+ enddo
+
+! sum contributions from each element to the global mesh and add gravity term
+
+ iglob = ibool(i,j,k,ispec)
+ accelfluid(iglob) = accelfluid(iglob) - (wgllwgll_yz(j,k)*tempx1l + wgllwgll_xz(i,k)*tempx2l + wgllwgll_xy(i,j)*tempx3l)
+
+ enddo
+ enddo
+ enddo
+
+ enddo ! spectral element loop
+
+ end subroutine compute_forces_outer_core
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/constants.h
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/constants.h (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/constants.h 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,497 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public 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 = .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
+
+! R_EARTH is the radius of the bottom of the oceans (radius of Earth in m)
+ double precision, parameter :: R_EARTH = 6371000.d0
+! uncomment line below for PREM with oceans
+! double precision, parameter :: R_EARTH = 6368000.d0
+
+! average density in the full Earth to normalize equation
+ double precision, parameter :: RHOAV = 5514.3d0
+
+! for topography/bathymetry model
+
+!!--- ETOPO5 5-minute model, smoothed Harvard version
+!! size of topography and bathymetry file
+! integer, parameter :: NX_BATHY = 4320,NY_BATHY = 2160
+!! resolution of topography file in minutes
+! integer, parameter :: RESOLUTION_TOPO_FILE = 5
+!! pathname of the topography file
+! character (len=*), parameter :: PATHNAME_TOPO_FILE = 'DATA/topo_bathy/topo_bathy_etopo5_smoothed_Harvard.dat'
+
+!--- ETOPO4 4-minute model created by subsampling and smoothing etopo-2
+! size of topography and bathymetry file
+ integer, parameter :: NX_BATHY = 5400,NY_BATHY = 2700
+! resolution of topography file in minutes
+ integer, parameter :: RESOLUTION_TOPO_FILE = 4
+! pathname of the topography file
+ character (len=*), parameter :: PATHNAME_TOPO_FILE = 'DATA/topo_bathy/topo_bathy_etopo4_smoothed_window_7.dat'
+
+!!--- ETOPO2 2-minute model, not implemented yet
+!! size of topography and bathymetry file
+! integer, parameter :: NX_BATHY = 10800,NY_BATHY = 5400
+!! resolution of topography file in minutes
+! integer, parameter :: RESOLUTION_TOPO_FILE = 2
+!! pathname of the topography file
+! character (len=*), parameter :: PATHNAME_TOPO_FILE = 'DATA/topo_bathy/topo_bathy_etopo2_smoothed_window7.dat'
+
+! maximum depth of the oceans in trenches and height of topo in mountains
+! to avoid taking into account spurious oscillations in global model ETOPO
+ logical, parameter :: USE_MAXIMUM_HEIGHT_TOPO = .false.
+ integer, parameter :: MAXIMUM_HEIGHT_TOPO = +20000
+ logical, parameter :: USE_MAXIMUM_DEPTH_OCEANS = .false.
+ integer, parameter :: MAXIMUM_DEPTH_OCEANS = -20000
+
+! minimum thickness in meters to include the effect of the oceans and topo
+ double precision, parameter :: MINIMUM_THICKNESS_3D_OCEANS = 100.d0
+
+! number of GLL points in each direction of an element (degree plus one)
+ integer, parameter :: NGLLX = 5
+ integer, parameter :: NGLLY = NGLLX
+ integer, parameter :: NGLLZ = NGLLX
+
+! flag to exclude elements that are too far from target in source detection
+ logical, parameter :: USE_DISTANCE_CRITERION = .true.
+
+! flag to display detailed information about location of stations
+ logical, parameter :: DISPLAY_DETAILS_STATIONS = .false.
+
+! maximum length of station and network name for receivers
+ integer, parameter :: MAX_LENGTH_STATION_NAME = 32
+ integer, parameter :: MAX_LENGTH_NETWORK_NAME = 8
+
+! we mimic a triangle of half duration equal to half_duration_triangle
+! using a Gaussian having a very close shape, as explained in Figure 4.2
+! of the manual. This source decay rate to mimic an equivalent triangle
+! was found by trial and error
+ double precision, parameter :: SOURCE_DECAY_MIMIC_TRIANGLE = 1.628d0
+
+! maximum number of sources to locate simultaneously
+ integer, parameter :: NSOURCES_SUBSET_MAX = 1000
+
+! distance threshold (in km) above which we consider that a receiver
+! is located outside the mesh and therefore excluded from the station list
+ double precision, parameter :: THRESHOLD_EXCLUDE_STATION = 50.d0
+
+! the first doubling is implemented right below the Moho
+! it seems optimal to implement the three other doublings at these depths
+! in the mantle
+ double precision, parameter :: DEPTH_SECOND_DOUBLING_OPTIMAL = 1650000.d0
+! in the outer core
+ double precision, parameter :: DEPTH_THIRD_DOUBLING_OPTIMAL = 3860000.d0
+! in the outer core
+ double precision, parameter :: DEPTH_FOURTH_DOUBLING_OPTIMAL = 5000000.d0
+
+! Boundary Mesh -- save Moho, 400, 670 km discontinuity topology files (in
+! the mesher) and use them for the computation of boundary kernel (in the solver)
+ logical, parameter :: SAVE_BOUNDARY_MESH = .false.
+
+! this parameter must be set to .true. to compute anisotropic kernels
+! in crust and mantle (related to the 21 Cij in geographical coordinates)
+! default is .false. to compute isotropic kernels (related to alpha and beta)
+ logical, parameter :: ANISOTROPIC_KL = .false.
+
+! print date and time estimate of end of run in another country,
+! in addition to local time.
+! For instance: the code runs at Caltech in California but the person
+! running the code is connected remotely from France, which has 9 hours more.
+! The time difference with that remote location can be positive or negative
+ logical, parameter :: ADD_TIME_ESTIMATE_ELSEWHERE = .false.
+ integer, parameter :: HOURS_TIME_DIFFERENCE = +9
+ integer, parameter :: MINUTES_TIME_DIFFERENCE = +0
+
+!
+!--- debugging flags
+!
+
+! flags to actually assemble with MPI or not
+! and to actually match fluid and solid regions of the Earth or not
+! should always be set to true except when debugging code
+ logical, parameter :: ACTUALLY_ASSEMBLE_MPI_SLICES = .true.
+ logical, parameter :: ACTUALLY_ASSEMBLE_MPI_CHUNKS = .true.
+ logical, parameter :: ACTUALLY_COUPLE_FLUID_CMB = .true.
+ logical, parameter :: ACTUALLY_COUPLE_FLUID_ICB = .true.
+
+!! DK DK UGLY added this in case we are running on MareNostrum in Barcelona
+!! DK DK UGLY because we then need some calls to the system to use GPFS
+ logical, parameter :: RUN_ON_MARENOSTRUM_BARCELONA = .false.
+
+!------------------------------------------------------
+!----------- do not modify anything below -------------
+!------------------------------------------------------
+
+! on some processors (e.g. Pentiums) it is necessary to suppress underflows
+! by using a small initial field instead of zero
+ logical, parameter :: FIX_UNDERFLOW_PROBLEM = .true.
+
+! some useful constants
+ double precision, parameter :: PI = 3.141592653589793d0
+ double precision, parameter :: TWO_PI = 2.d0 * PI
+ double precision, parameter :: PI_OVER_FOUR = PI / 4.d0
+
+! to convert angles from degrees to radians
+ double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0
+
+! 3-D simulation
+ integer, parameter :: NDIM = 3
+
+! dimension of the boundaries of the slices
+ integer, parameter :: NDIM2D = 2
+
+! number of nodes for 2D and 3D shape functions for hexahedra with 27 nodes
+ integer, parameter :: NGNOD = 27, NGNOD2D = 9
+
+! gravitational constant
+ double precision, parameter :: GRAV = 6.6723d-11
+
+! a few useful constants
+ double precision, parameter :: ZERO = 0.d0,ONE = 1.d0,TWO = 2.d0,HALF = 0.5d0
+
+ real(kind=CUSTOM_REAL), parameter :: &
+ ONE_THIRD = 1._CUSTOM_REAL/3._CUSTOM_REAL, &
+ TWO_THIRDS = 2._CUSTOM_REAL/3._CUSTOM_REAL, &
+ FOUR_THIRDS = 4._CUSTOM_REAL/3._CUSTOM_REAL
+
+! very large and very small values
+ double precision, parameter :: HUGEVAL = 1.d+30,TINYVAL = 1.d-9
+
+! very large real value declared independently of the machine
+ real(kind=CUSTOM_REAL), parameter :: HUGEVAL_SNGL = 1.e+30_CUSTOM_REAL
+
+! very large integer value
+ integer, parameter :: HUGEINT = 100000000
+
+! normalized radius of free surface
+ double precision, parameter :: R_UNIT_SPHERE = ONE
+
+! same radius in km
+ double precision, parameter :: R_EARTH_KM = R_EARTH / 1000.d0
+
+! fixed thickness of 3 km for PREM oceans
+ double precision, parameter :: THICKNESS_OCEANS_PREM = 3000.d0 / R_EARTH
+
+! shortest radius at which crust is implemented (80 km depth)
+! to be constistent with the D80 discontinuity, we impose the crust only above it
+ double precision, parameter :: R_DEEPEST_CRUST = (R_EARTH - 80000.d0) / R_EARTH
+
+! maximum number of chunks (full sphere)
+ integer, parameter :: NCHUNKS_MAX = 6
+
+! define block type based upon chunk number (between 1 and 6)
+! do not change this numbering, chunk AB must be number 1 for central cube
+ integer, parameter :: CHUNK_AB = 1
+ integer, parameter :: CHUNK_AC = 2
+ integer, parameter :: CHUNK_BC = 3
+ integer, parameter :: CHUNK_AC_ANTIPODE = 4
+ integer, parameter :: CHUNK_BC_ANTIPODE = 5
+ integer, parameter :: CHUNK_AB_ANTIPODE = 6
+
+! maximum number of regions in the mesh
+ integer, parameter :: MAX_NUM_REGIONS = 3
+
+! define flag for regions of the global Earth mesh
+ integer, parameter :: IREGION_CRUST_MANTLE = 1
+ integer, parameter :: IREGION_OUTER_CORE = 2
+ integer, parameter :: IREGION_INNER_CORE = 3
+
+! define flag for elements
+ integer, parameter :: IFLAG_CRUST = 1
+
+ integer, parameter :: IFLAG_80_MOHO = 2
+ integer, parameter :: IFLAG_220_80 = 3
+ integer, parameter :: IFLAG_670_220 = 4
+ integer, parameter :: IFLAG_MANTLE_NORMAL = 5
+
+ integer, parameter :: IFLAG_OUTER_CORE_NORMAL = 6
+
+ integer, parameter :: IFLAG_INNER_CORE_NORMAL = 7
+ integer, parameter :: IFLAG_MIDDLE_CENTRAL_CUBE = 8
+ integer, parameter :: IFLAG_BOTTOM_CENTRAL_CUBE = 9
+ integer, parameter :: IFLAG_TOP_CENTRAL_CUBE = 10
+ integer, parameter :: IFLAG_IN_FICTITIOUS_CUBE = 11
+
+ integer, parameter :: NSPEC2D_XI_SUPERBRICK = 8
+ integer, parameter :: NSPEC2D_ETA_SUPERBRICK = 8
+ integer, parameter :: NSPEC2D_XI_SUPERBRICK_1L = 6
+ integer, parameter :: NSPEC2D_ETA_SUPERBRICK_1L = 6
+
+! dummy flag used for mesh display purposes only
+ integer, parameter :: IFLAG_DUMMY = 100
+
+! max number of layers that are used in the radial direction to build the full mesh
+ integer, parameter :: MAX_NUMBER_OF_MESH_LAYERS = 15
+
+! define number of spectral elements and points in basic symmetric mesh doubling superbrick
+ integer, parameter :: NSPEC_DOUBLING_SUPERBRICK = 32
+ integer, parameter :: NGLOB_DOUBLING_SUPERBRICK = 67
+ integer, parameter :: NSPEC_SUPERBRICK_1L = 28
+ integer, parameter :: NGLOB_SUPERBRICK_1L = 58
+ integer, parameter :: NGNOD_EIGHT_CORNERS = 8
+
+! define flag for reference 1D Earth model
+ integer, parameter :: REFERENCE_MODEL_PREM = 1
+ integer, parameter :: REFERENCE_MODEL_IASP91 = 2
+ integer, parameter :: REFERENCE_MODEL_1066A = 3
+ integer, parameter :: REFERENCE_MODEL_AK135 = 4
+ integer, parameter :: REFERENCE_MODEL_REF = 5
+ integer, parameter :: REFERENCE_MODEL_JP1D = 6
+ integer, parameter :: REFERENCE_MODEL_SEA1D = 7
+
+! define flag for 3D Earth model
+ integer, parameter :: THREE_D_MODEL_S20RTS = 1
+ integer, parameter :: THREE_D_MODEL_S362ANI = 2
+ integer, parameter :: THREE_D_MODEL_S362WMANI = 3
+ integer, parameter :: THREE_D_MODEL_S362ANI_PREM = 4
+ integer, parameter :: THREE_D_MODEL_S29EA = 5
+ integer, parameter :: THREE_D_MODEL_SEA99_JP3D = 6
+ integer, parameter :: THREE_D_MODEL_SEA99 = 7
+ integer, parameter :: THREE_D_MODEL_JP3D = 8
+
+! define flag for regions of the global Earth for attenuation
+ integer, parameter :: NUM_REGIONS_ATTENUATION = 5
+
+ integer, parameter :: IREGION_ATTENUATION_INNER_CORE = 1
+ integer, parameter :: IREGION_ATTENUATION_CMB_670 = 2
+ integer, parameter :: IREGION_ATTENUATION_670_220 = 3
+ integer, parameter :: IREGION_ATTENUATION_220_80 = 4
+ integer, parameter :: IREGION_ATTENUATION_80_SURFACE = 5
+ integer, parameter :: IREGION_ATTENUATION_UNDEFINED = 6
+
+! number of standard linear solids for attenuation
+ integer, parameter :: N_SLS = 3
+
+! computation of standard linear solids in meshfem3D
+! ATTENUATION_COMP_RESOLUTION: Number of Digits after decimal
+! ATTENUATION_COMP_MAXIMUM: Maximum Q Value
+ integer, parameter :: ATTENUATION_COMP_RESOLUTION = 1
+ integer, parameter :: ATTENUATION_COMP_MAXIMUM = 5000
+
+! for lookup table for attenuation every 100 m in radial direction of Earth model
+ integer, parameter :: NRAD_ATTENUATION = 70000
+ double precision, parameter :: TABLE_ATTENUATION = R_EARTH_KM * 10.0d0
+
+! for determination of the attenuation period range
+! if this is set to .true. then the hardcoded values will be used
+! otherwise they are computed automatically from the Number of elements
+! This *may* be a useful parameter for Benchmarking against older versions
+ logical, parameter :: ATTENUATION_RANGE_PREDEFINED = .false.
+
+! flag for the four edges of each slice and for the bottom edge
+ integer, parameter :: XI_MIN = 1
+ integer, parameter :: XI_MAX = 2
+ integer, parameter :: ETA_MIN = 3
+ integer, parameter :: ETA_MAX = 4
+ integer, parameter :: BOTTOM = 5
+
+! flags to select the right corner in each slice
+ integer, parameter :: ILOWERLOWER = 1
+ integer, parameter :: ILOWERUPPER = 2
+ integer, parameter :: IUPPERLOWER = 3
+ integer, parameter :: IUPPERUPPER = 4
+
+! number of points in each AVS or OpenDX quadrangular cell for movies
+ integer, parameter :: NGNOD2D_AVS_DX = 4
+
+! number of faces a given slice can share with other slices
+! this is at most 2, except when there is only once slice per chunk
+! in which case it is 4
+ integer, parameter :: NUMFACES_SHARED = 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 Cuthill-McKee (1969) permutation
+ logical, parameter :: PERFORM_CUTHILL_MCKEE = .false.
+ integer, parameter :: NGNOD_HEXAHEDRA = 8
+! perform classical or multi-level Cuthill-McKee ordering
+ logical, parameter :: CMcK_MULTI = .false.
+! maximum size if multi-level Cuthill-McKee ordering
+ integer, parameter :: LIMIT_MULTI_CUTHILL = 50
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/convolve_source_timefunction.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/convolve_source_timefunction.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/convolve_source_timefunction.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,135 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ program convolve_source_time_function
+
+!
+! convolve seismograms computed for a Heaviside with given source time function
+!
+
+! we mimic a triangle of half duration equal to half_duration_triangle
+! using a Gaussian having a very close shape, as explained in Figure 4.2
+! of the manual
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: i,j,N_j,number_remove,nlines
+
+ double precision :: alpha,dt,tau_j,source,exponent,t1,t2,displ1,displ2,gamma,height,half_duration_triangle
+
+ logical :: triangle
+
+ double precision, dimension(:), allocatable :: time,sem,sem_fil
+
+! read file with number of lines in input
+ open(unit=33,file='input_convolve_code.txt',status='old',action='read')
+ read(33,*) nlines
+ read(33,*) half_duration_triangle
+ read(33,*) triangle
+ close(33)
+
+! allocate arrays
+ allocate(time(nlines),sem(nlines),sem_fil(nlines))
+
+! read the input seismogram
+ do i = 1,nlines
+ read(5,*) time(i),sem(i)
+ enddo
+
+! define a Gaussian with the right exponent to mimic a triangle of equivalent half duration
+ alpha = SOURCE_DECAY_MIMIC_TRIANGLE/half_duration_triangle
+
+! compute the time step
+ dt = time(2) - time(1)
+
+! number of integers for which the source wavelet is different from zero
+ if(triangle) then
+ N_j = ceiling(half_duration_triangle/dt)
+ else
+ N_j = ceiling(1.5d0*half_duration_triangle/dt)
+ endif
+
+ do i = 1,nlines
+
+ sem_fil(i) = 0.d0
+
+ do j = -N_j,N_j
+
+ if(i > j .and. i-j <= nlines) then
+
+ tau_j = dble(j)*dt
+
+! convolve with a triangle
+ if(triangle) then
+ height = 1.d0 / half_duration_triangle
+ if(abs(tau_j) > half_duration_triangle) then
+ source = 0.d0
+ else if (tau_j < 0.d0) then
+ t1 = - N_j * dt
+ displ1 = 0.d0
+ t2 = 0.d0
+ displ2 = height
+ gamma = (tau_j - t1) / (t2 - t1)
+ source= (1.d0 - gamma) * displ1 + gamma * displ2
+ else
+ t1 = 0.d0
+ displ1 = height
+ t2 = + N_j * dt
+ displ2 = 0.d0
+ gamma = (tau_j - t1) / (t2 - t1)
+ source= (1.d0 - gamma) * displ1 + gamma * displ2
+ endif
+
+ else
+
+! convolve with a Gaussian
+ exponent = alpha**2 * tau_j**2
+ if(exponent < 50.d0) then
+ source = alpha*exp(-exponent)/sqrt(PI)
+ else
+ source = 0.d0
+ endif
+
+ endif
+
+ sem_fil(i) = sem_fil(i) + sem(i-j)*source*dt
+
+ endif
+
+ enddo
+ enddo
+
+! compute number of samples to remove from end of seismograms
+ number_remove = N_j + 1
+ do i=1,nlines - number_remove
+ write(*,*) sngl(time(i)),' ',sngl(sem_fil(i))
+ enddo
+
+ end program convolve_source_time_function
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/count_number_of_sources.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/count_number_of_sources.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/count_number_of_sources.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/create_central_cube_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_central_cube_buffers.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_central_cube_buffers.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,541 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!
+!--- create buffers to assemble with central cube
+!
+
+ subroutine create_central_cube_buffers(myrank,iproc_xi,iproc_eta,ichunk, &
+ NPROC_XI,NPROC_ETA,NCHUNKS,NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
+ NSPEC2DMAX_XMIN_XMAX_INNER_CORE,NSPEC2DMAX_YMIN_YMAX_INNER_CORE,NSPEC2D_BOTTOM_INNER_CORE, &
+ addressing,ibool_inner_core,idoubling_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
+ ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
+ nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices, &
+ receiver_cube_from_slices,sender_from_slices_to_cube,ibool_central_cube, &
+ buffer_slices,buffer_slices2,buffer_all_cube_from_slices)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+
+ integer, intent(in) :: myrank,iproc_xi,iproc_eta,ichunk, &
+ NPROC_XI,NPROC_ETA,NCHUNKS,NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
+ NSPEC2DMAX_XMIN_XMAX_INNER_CORE,NSPEC2DMAX_YMIN_YMAX_INNER_CORE,NSPEC2D_BOTTOM_INNER_CORE
+
+! for addressing of the slices
+ integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1), intent(in) :: addressing
+
+! mesh parameters
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE), intent(in) :: ibool_inner_core
+
+! local to global mapping
+ integer, dimension(NSPEC_INNER_CORE), intent(in) :: idoubling_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE), intent(in) :: xstore_inner_core,ystore_inner_core,zstore_inner_core
+
+! boundary parameters locator
+ integer, intent(in) :: nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_INNER_CORE), intent(in) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_INNER_CORE), intent(in) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
+ integer, dimension(NSPEC2D_BOTTOM_INNER_CORE), intent(in) :: ibelm_bottom_inner_core
+
+ integer, intent(in) :: nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices
+
+! for matching with central cube in inner core
+ integer, intent(out) :: receiver_cube_from_slices
+
+ integer, dimension(non_zero_nb_msgs_theor_in_cube), intent(out) :: sender_from_slices_to_cube
+ integer, dimension(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices), intent(out) :: ibool_central_cube
+ double precision, dimension(npoin2D_cube_from_slices,NDIM), intent(out) :: buffer_slices,buffer_slices2
+ double precision, dimension(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM), intent(out) :: &
+ buffer_all_cube_from_slices
+
+! local variables below
+ integer i,j,k,ispec,ispec2D,iglob,ier
+ integer sender,receiver,imsg,ipoin,iproc_xi_loop
+
+ double precision x_target,y_target,z_target
+ double precision x_current,y_current,z_current
+
+! MPI status of messages to be received
+ integer msg_status(MPI_STATUS_SIZE)
+
+!--- processor to send information to in cube from slices
+
+! four vertical sides first
+ if(ichunk == CHUNK_AC) then
+ if (iproc_xi < floor(NPROC_XI/2.d0)) then
+ receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1,iproc_eta)
+ else
+ receiver_cube_from_slices = addressing(CHUNK_AB,0,iproc_eta)
+ endif
+ else if(ichunk == CHUNK_BC) then
+ if (iproc_xi < floor(NPROC_XI/2.d0)) then
+ receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1-iproc_eta,NPROC_ETA-1)
+ else
+ receiver_cube_from_slices = addressing(CHUNK_AB,iproc_eta,NPROC_ETA-1)
+ endif
+ else if(ichunk == CHUNK_AC_ANTIPODE) then
+ if (iproc_xi <= ceiling((NPROC_XI/2.d0)-1)) then
+ receiver_cube_from_slices = addressing(CHUNK_AB,NPROC_XI-1,iproc_eta)
+ else
+ receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,0,iproc_eta)
+ endif
+ else if(ichunk == CHUNK_BC_ANTIPODE) then
+ if (iproc_xi < floor(NPROC_XI/2.d0)) then
+ receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,iproc_eta,0)
+ else
+ receiver_cube_from_slices = addressing(CHUNK_AB,NPROC_XI-1-iproc_eta,0)
+ endif
+! bottom of cube, direct correspondance but with inverted xi axis
+ else if(ichunk == CHUNK_AB_ANTIPODE) then
+ receiver_cube_from_slices = addressing(CHUNK_AB,NPROC_XI-1-iproc_xi,iproc_eta)
+ else if(ichunk == CHUNK_AB) then
+ receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1-iproc_xi,iproc_eta)
+ endif
+
+
+!--- list of processors to receive information from in cube
+
+! only for slices in central cube
+ if(ichunk == CHUNK_AB) then
+
+! initialize index of sender
+ imsg = 0
+
+! define sender for xi = xi_min edge
+ if(iproc_xi == 0) then
+ do iproc_xi_loop = floor(NPROC_XI/2.d0),NPROC_XI-1
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC,iproc_xi_loop,iproc_eta)
+ enddo
+ endif
+
+! define sender for xi = xi_max edge
+ if(iproc_xi == NPROC_XI-1) then
+ do iproc_xi_loop = 0, floor((NPROC_XI-1)/2.d0)
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC_ANTIPODE,iproc_xi_loop,iproc_eta)
+ enddo
+ endif
+
+! define sender for eta = eta_min edge
+ if(iproc_eta == 0) then
+ do iproc_xi_loop = floor(NPROC_XI/2.d0),NPROC_XI-1
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC_ANTIPODE,iproc_xi_loop,NPROC_ETA-1-iproc_xi)
+ enddo
+ endif
+
+! define sender for eta = eta_max edge
+ if(iproc_eta == NPROC_ETA-1) then
+ do iproc_xi_loop = floor(NPROC_XI/2.d0),NPROC_XI-1
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC,iproc_xi_loop,iproc_xi)
+ enddo
+ endif
+
+! define sender for bottom edge
+! bottom of cube, direct correspondence but with inverted xi axis
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1-iproc_xi,iproc_eta)
+
+! check that total number of faces found is correct
+ if(imsg /= nb_msgs_theor_in_cube) call exit_MPI(myrank,'wrong number of faces found for central cube')
+
+ else if(ichunk == CHUNK_AB_ANTIPODE) then
+
+! initialize index of sender
+ imsg = 0
+
+! define sender for xi = xi_min edge
+ if(iproc_xi == 0) then
+ do iproc_xi_loop = ceiling(NPROC_XI/2.d0),NPROC_XI-1
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC_ANTIPODE,iproc_xi_loop,iproc_eta)
+ enddo
+ endif
+
+! define sender for xi = xi_max edge
+ if(iproc_xi == NPROC_XI-1) then
+ do iproc_xi_loop = 0, floor((NPROC_XI/2.d0)-1.d0)
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC,iproc_xi_loop,iproc_eta)
+ enddo
+ endif
+
+! define sender for eta = eta_min edge
+ if(iproc_eta == 0) then
+ do iproc_xi_loop = 0, floor((NPROC_XI/2.d0)-1.d0)
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC_ANTIPODE,iproc_xi_loop,iproc_xi)
+ enddo
+ endif
+
+! define sender for eta = eta_max edge
+ if(iproc_eta == NPROC_ETA-1) then
+ do iproc_xi_loop = 0, floor((NPROC_XI/2.d0)-1.d0)
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC,iproc_xi_loop,NPROC_ETA-1-iproc_xi)
+ enddo
+ endif
+
+! define sender for bottom edge
+! bottom of cube, direct correspondence but with inverted xi axis
+ imsg = imsg + 1
+ sender_from_slices_to_cube(imsg) = addressing(CHUNK_AB,NPROC_XI-1-iproc_xi,iproc_eta)
+
+! check that total number of faces found is correct
+ if(imsg /= nb_msgs_theor_in_cube) call exit_MPI(myrank,'wrong number of faces found for central cube')
+
+ else
+
+! dummy value in slices
+ sender_from_slices_to_cube(1) = -1
+
+ endif
+
+
+! on chunk AB & AB ANTIPODE, receive all (except bottom) the messages from slices
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+
+ do imsg = 1,nb_msgs_theor_in_cube-1
+
+! receive buffers from slices
+ sender = sender_from_slices_to_cube(imsg)
+ call MPI_RECV(buffer_slices, &
+ NDIM*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+
+! copy buffer in 2D array for each slice
+ buffer_all_cube_from_slices(imsg,:,:) = buffer_slices(:,:)
+
+ enddo
+ endif
+
+! send info to central cube from all the slices except those in CHUNK_AB & CHUNK_AB_ANTIPODE
+ if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE ) then
+
+! for bottom elements in contact with central cube from the slices side
+ ipoin = 0
+ do ispec2D = 1,NSPEC2D_BOTTOM_INNER_CORE
+
+ ispec = ibelm_bottom_inner_core(ispec2D)
+
+! only for DOFs exactly on surface of central cube (bottom of these elements)
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ipoin = ipoin + 1
+ iglob = ibool_inner_core(i,j,k,ispec)
+ buffer_slices(ipoin,1) = dble(xstore_inner_core(iglob))
+ buffer_slices(ipoin,2) = dble(ystore_inner_core(iglob))
+ buffer_slices(ipoin,3) = dble(zstore_inner_core(iglob))
+ enddo
+ enddo
+ enddo
+
+! send buffer to central cube
+ receiver = receiver_cube_from_slices
+ call MPI_SEND(buffer_slices,NDIM*npoin2D_cube_from_slices, &
+ MPI_DOUBLE_PRECISION,receiver,itag,MPI_COMM_WORLD,ier)
+
+ endif ! end sending info to central cube
+
+
+! exchange of their bottom faces between chunks AB and AB_ANTIPODE
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+ ipoin = 0
+ do ispec = NSPEC_INNER_CORE, 1, -1
+ if (idoubling_inner_core(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE) then
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ipoin = ipoin + 1
+ iglob = ibool_inner_core(i,j,k,ispec)
+ buffer_slices(ipoin,1) = dble(xstore_inner_core(iglob))
+ buffer_slices(ipoin,2) = dble(ystore_inner_core(iglob))
+ buffer_slices(ipoin,3) = dble(zstore_inner_core(iglob))
+ enddo
+ enddo
+ endif
+ enddo
+ if (ipoin /= npoin2D_cube_from_slices) call exit_MPI(myrank,'wrong number of points found for bottom CC AB or !AB')
+
+ sender = sender_from_slices_to_cube(nb_msgs_theor_in_cube)
+
+ call MPI_SENDRECV(buffer_slices,NDIM*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,receiver_cube_from_slices, &
+ itag,buffer_slices2,NDIM*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
+ itag,MPI_COMM_WORLD,msg_status,ier)
+
+ buffer_all_cube_from_slices(nb_msgs_theor_in_cube,:,:) = buffer_slices2(:,:)
+
+ endif
+
+!--- now we need to find the points received and create indirect addressing
+
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+
+ do imsg = 1,nb_msgs_theor_in_cube
+
+ do ipoin = 1,npoin2D_cube_from_slices
+
+ x_target = buffer_all_cube_from_slices(imsg,ipoin,1)
+ y_target = buffer_all_cube_from_slices(imsg,ipoin,2)
+ z_target = buffer_all_cube_from_slices(imsg,ipoin,3)
+
+! x = x_min
+ do ispec2D = 1,nspec2D_xmin_inner_core
+
+ ispec = ibelm_xmin_inner_core(ispec2D)
+
+! do not loop on elements outside of the central cube
+ if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
+
+ i = 1
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+
+ iglob = ibool_inner_core(i,j,k,ispec)
+ x_current = dble(xstore_inner_core(iglob))
+ y_current = dble(ystore_inner_core(iglob))
+ z_current = dble(zstore_inner_core(iglob))
+
+! look for matching point
+ if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
+ ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
+ goto 100
+ endif
+
+ enddo
+ enddo
+
+ enddo
+
+! x = x_max
+ do ispec2D = 1,nspec2D_xmax_inner_core
+
+ ispec = ibelm_xmax_inner_core(ispec2D)
+
+! do not loop on elements outside of the central cube
+ if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
+
+ i = NGLLX
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+
+ iglob = ibool_inner_core(i,j,k,ispec)
+ x_current = dble(xstore_inner_core(iglob))
+ y_current = dble(ystore_inner_core(iglob))
+ z_current = dble(zstore_inner_core(iglob))
+
+! look for matching point
+ if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
+ ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
+ goto 100
+ endif
+
+ enddo
+ enddo
+
+ enddo
+
+! y = y_min
+ do ispec2D = 1,nspec2D_ymin_inner_core
+
+ ispec = ibelm_ymin_inner_core(ispec2D)
+
+! do not loop on elements outside of the central cube
+ if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
+
+ j = 1
+ do k = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool_inner_core(i,j,k,ispec)
+ x_current = dble(xstore_inner_core(iglob))
+ y_current = dble(ystore_inner_core(iglob))
+ z_current = dble(zstore_inner_core(iglob))
+
+! look for matching point
+ if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
+ ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
+ goto 100
+ endif
+
+ enddo
+ enddo
+
+ enddo
+
+! y = y_max
+ do ispec2D = 1,nspec2D_ymax_inner_core
+
+ ispec = ibelm_ymax_inner_core(ispec2D)
+
+! do not loop on elements outside of the central cube
+ if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
+
+ j = NGLLY
+ do k = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool_inner_core(i,j,k,ispec)
+ x_current = dble(xstore_inner_core(iglob))
+ y_current = dble(ystore_inner_core(iglob))
+ z_current = dble(zstore_inner_core(iglob))
+
+! look for matching point
+ if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
+ ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
+ goto 100
+ endif
+
+ enddo
+ enddo
+
+ enddo
+
+! bottom of cube
+ do ispec = 1,NSPEC_INNER_CORE
+
+! loop on elements at the bottom of the cube only
+ if(idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE) cycle
+
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ iglob = ibool_inner_core(i,j,k,ispec)
+ x_current = dble(xstore_inner_core(iglob))
+ y_current = dble(ystore_inner_core(iglob))
+ z_current = dble(zstore_inner_core(iglob))
+
+! look for matching point
+ if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
+ ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
+ goto 100
+ endif
+
+ enddo
+ enddo
+
+ enddo
+
+! check that a matching point is found in all cases
+ call exit_MPI(myrank,'point never found in central cube')
+
+ 100 continue
+
+ enddo
+ enddo
+ endif
+
+ end subroutine create_central_cube_buffers
+
+!
+!----------------------------------
+!
+
+ subroutine comp_central_cube_buffer_size(iproc_xi,iproc_eta,ichunk,NPROC_XI,NPROC_ETA,NSPEC2D_BOTTOM_INNER_CORE, &
+ nb_msgs_theor_in_cube,npoin2D_cube_from_slices)
+
+!--- compute number of messages to expect in cube as well as their size
+!--- take into account vertical sides and bottom side
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: iproc_xi,iproc_eta,ichunk,NPROC_XI,NPROC_ETA,NSPEC2D_BOTTOM_INNER_CORE
+
+ integer, intent(out) :: nb_msgs_theor_in_cube,npoin2D_cube_from_slices
+
+! only for slices in central cube
+ if(ichunk == CHUNK_AB) then
+ if(NPROC_XI == 1) then
+! five sides if only one processor in cube
+ nb_msgs_theor_in_cube = 5
+ else
+! case of a corner
+ if((iproc_xi == 0 .or. iproc_xi == NPROC_XI-1).and. &
+ (iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1)) then
+! slices on both "vertical" faces plus one slice at the bottom
+ nb_msgs_theor_in_cube = 2*(ceiling(NPROC_XI/2.d0)) + 1
+! case of an edge
+ else if(iproc_xi == 0 .or. iproc_xi == NPROC_XI-1 .or. &
+ iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1) then
+! slices on the "vertical" face plus one slice at the bottom
+ nb_msgs_theor_in_cube = ceiling(NPROC_XI/2.d0) + 1
+ else
+! bottom element only
+ nb_msgs_theor_in_cube = 1
+ endif
+ endif
+ else if(ichunk == CHUNK_AB_ANTIPODE) then
+ if(NPROC_XI == 1) then
+! five sides if only one processor in cube
+ nb_msgs_theor_in_cube = 5
+ else
+! case of a corner
+ if((iproc_xi == 0 .or. iproc_xi == NPROC_XI-1).and. &
+ (iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1)) then
+! slices on both "vertical" faces plus one slice at the bottom
+ nb_msgs_theor_in_cube = 2*(floor(NPROC_XI/2.d0)) + 1
+! case of an edge
+ else if(iproc_xi == 0 .or. iproc_xi == NPROC_XI-1 .or. &
+ iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1) then
+! slices on the "vertical" face plus one slice at the bottom
+ nb_msgs_theor_in_cube = floor(NPROC_XI/2.d0) + 1
+ else
+! bottom element only
+ nb_msgs_theor_in_cube = 1
+ endif
+ endif
+ else
+! not in chunk AB
+ nb_msgs_theor_in_cube = 0
+ endif
+
+! number of points to send or receive (bottom of slices)
+ npoin2D_cube_from_slices = NSPEC2D_BOTTOM_INNER_CORE * NGLLX * NGLLY
+
+ end subroutine comp_central_cube_buffer_size
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_chunk_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_chunk_buffers.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_chunk_buffers.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,1126 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! subroutine to create MPI buffers to assemble between chunks
+
+ subroutine create_chunk_buffers(iregion_code,nspec,ibool,idoubling,xstore,ystore,zstore, &
+ nglob_ori, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
+ NPROC_XI,NPROC_ETA,NPROC,NPROCTOT,NGLOB1D_RADIAL_CORNER,NGLOB1D_RADIAL_MAX, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ myrank,LOCAL_PATH, &
+ addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS, &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax, &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
+ iprocfrom_faces,iprocto_faces,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces,npoin2D_faces,iboolcorner,NGLOB1D_RADIAL)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+!! DK DK for the merged version
+! include values created by the mesher
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+!! DK DK added this for the merged version
+ integer :: NGLOB1D_RADIAL
+ integer :: imsg2,icount_faces,icount_corners
+ integer, dimension(NUMFACES_SHARED) :: npoin2D_faces
+ integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces
+ integer, dimension(NGLOB1D_RADIAL,NUMCORNERS_SHARED) :: iboolcorner
+
+!! DK DK added this for the merged version
+!---- arrays to assemble between chunks
+
+! communication pattern for faces between chunks
+ integer, dimension(NUMMSGS_FACES_VAL) :: iprocfrom_faces,iprocto_faces
+
+! communication pattern for corners between chunks
+ integer, dimension(NCORNERSCHUNKS_VAL) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
+
+
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_CORNER
+
+ integer nglob,nglob_ori
+ integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
+ integer NPROC,NPROC_XI,NPROC_ETA,NPROCTOT,NGLOB1D_RADIAL_MAX,NGLOB1D_RADIAL_my_corner
+ integer NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
+ integer nspec
+ integer myrank,NCHUNKS
+
+! arrays with the mesh
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+ character(len=150) OUTPUT_FILES,LOCAL_PATH,ERR_MSG
+
+! array with the local to global mapping per slice
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer idoubling(nspec)
+
+! mask for ibool to mark points already found
+ logical, dimension(:), allocatable :: mask_ibool
+
+! array to store points selected for the chunk face buffer
+ integer NGLOB2DMAX_XY
+ integer, dimension(:), allocatable :: ibool_selected
+
+ double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
+
+! arrays for sorting routine
+ integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: work
+
+! pairs generated theoretically
+! four sides for each of the three types of messages
+ integer, dimension(:), allocatable :: iproc_sender,iproc_receiver,npoin2D_send,npoin2D_receive
+
+! 1D buffers to remove points belonging to corners
+ integer ibool1D_leftxi_lefteta(NGLOB1D_RADIAL_MAX)
+ integer ibool1D_rightxi_lefteta(NGLOB1D_RADIAL_MAX)
+ integer ibool1D_leftxi_righteta(NGLOB1D_RADIAL_MAX)
+ integer ibool1D_rightxi_righteta(NGLOB1D_RADIAL_MAX)
+ integer ibool1D(NGLOB1D_RADIAL_MAX)
+ integer ipoin1D
+
+!! DK DK changed this for merged version
+ double precision, dimension(NGLOB1D_RADIAL_MAX) :: &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta
+
+ double precision, dimension(NGLOB1D_RADIAL_MAX) :: xread1D,yread1D,zread1D
+
+! arrays to assemble the corners (3 processors for each corner)
+ integer, dimension(:,:), allocatable :: iprocscorners,itypecorner
+
+ integer ichunk_send,iproc_xi_send,iproc_eta_send
+ integer ichunk_receive,iproc_xi_receive,iproc_eta_receive
+ integer iproc_loop,iproc_xi_loop,iproc_eta_loop
+ integer iproc_xi_loop_inv,iproc_eta_loop_inv
+ integer imember_corner
+
+ integer iregion_code
+
+ integer iproc_edge_send,iproc_edge_receive
+ integer imsg_type,iside,imode_comm,iedge
+
+! boundary parameters per slice
+ integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
+ integer ibelm_xmin(NSPEC2DMAX_XMIN_XMAX),ibelm_xmax(NSPEC2DMAX_XMIN_XMAX)
+ integer ibelm_ymin(NSPEC2DMAX_YMIN_YMAX),ibelm_ymax(NSPEC2DMAX_YMIN_YMAX)
+
+ integer npoin2D,npoin2D_send_local,npoin2D_receive_local
+
+ integer i,j,k,ispec,ispec2D,ipoin2D,ier
+
+! current message number
+ integer imsg
+
+! names of the data files for all the processors in MPI
+ character(len=150) prname
+
+! for addressing of the slices
+ integer ichunk,iproc_xi,iproc_eta,iproc
+ integer addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1)
+ integer ichunk_slice(0:NPROCTOT-1)
+ integer iproc_xi_slice(0:NPROCTOT-1)
+
+ integer iproc_eta_slice(0:NPROCTOT-1)
+
+! this to avoid problem at compile time if less than six chunks
+ integer addressing_big(NCHUNKS_MAX,0:NPROC_XI-1,0:NPROC_ETA-1)
+
+! number of faces between chunks
+ integer NUM_FACES,NUMMSGS_FACES
+
+! number of corners between chunks
+ integer NCORNERSCHUNKS
+
+! number of message types
+ integer NUM_MSG_TYPES
+
+ integer NPROC_ONE_DIRECTION
+
+! ************** subroutine starts here **************
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '----- creating chunk buffers -----'
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',NPROC_XI,' slices along xi in each chunk'
+ write(IMAIN,*) 'There are ',NPROC_ETA,' slices along eta in each chunk'
+ write(IMAIN,*) 'There is a total of ',NPROC,' slices in each chunk'
+ write(IMAIN,*) 'There are ',NCHUNKS,' chunks'
+ write(IMAIN,*) 'There is a total of ',NPROCTOT,' slices in all the chunks'
+ write(IMAIN,*)
+ endif
+
+! number of corners and faces shared between chunks and number of message types
+ if(NCHUNKS == 1 .or. NCHUNKS == 2) then
+ NCORNERSCHUNKS = 1
+ NUM_FACES = 1
+ NUM_MSG_TYPES = 1
+ else if(NCHUNKS == 3) then
+ NCORNERSCHUNKS = 1
+ NUM_FACES = 1
+ NUM_MSG_TYPES = 3
+ else if(NCHUNKS == 6) then
+ NCORNERSCHUNKS = 8
+ NUM_FACES = 4
+ NUM_MSG_TYPES = 3
+ else
+ call exit_MPI(myrank,'number of chunks must be either 1, 2, 3 or 6')
+ endif
+
+! if more than one chunk then same number of processors in each direction
+ NPROC_ONE_DIRECTION = NPROC_XI
+
+! total number of messages corresponding to these common faces
+ NUMMSGS_FACES = NPROC_ONE_DIRECTION*NUM_FACES*NUM_MSG_TYPES
+
+! check that there is more than one chunk, otherwise nothing to do
+ if(NCHUNKS == 1) return
+
+! same number of GLL points in each direction for several chunks
+ if(NGLLY /= NGLLX) call exit_MPI(myrank,'must have NGLLY = NGLLX for several chunks')
+
+! allocate arrays for faces
+ allocate(iproc_sender(NUMMSGS_FACES))
+ allocate(iproc_receiver(NUMMSGS_FACES))
+ allocate(npoin2D_send(NUMMSGS_FACES))
+ allocate(npoin2D_receive(NUMMSGS_FACES))
+
+! allocate array for corners
+ allocate(iprocscorners(3,NCORNERSCHUNKS))
+ allocate(itypecorner(3,NCORNERSCHUNKS))
+
+! clear arrays allocated
+ iproc_sender(:) = 0
+ iproc_receiver(:) = 0
+ npoin2D_send(:) = 0
+ npoin2D_receive(:) = 0
+ iprocscorners(:,:) = 0
+ itypecorner(:,:) = 0
+
+ if(myrank == 0) then
+ write(IMAIN,*) 'There is a total of ',NUMMSGS_FACES,' messages to assemble faces between chunks'
+ write(IMAIN,*)
+ endif
+
+! define maximum size for message buffers
+ NGLOB2DMAX_XY = max(NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX)
+
+! allocate arrays for message buffers with maximum size
+ allocate(ibool_selected(NGLOB2DMAX_XY))
+ allocate(xstore_selected(NGLOB2DMAX_XY))
+ allocate(ystore_selected(NGLOB2DMAX_XY))
+ allocate(zstore_selected(NGLOB2DMAX_XY))
+ allocate(ind(NGLOB2DMAX_XY))
+ allocate(ninseg(NGLOB2DMAX_XY))
+ allocate(iglob(NGLOB2DMAX_XY))
+ allocate(locval(NGLOB2DMAX_XY))
+ allocate(ifseg(NGLOB2DMAX_XY))
+ allocate(iwork(NGLOB2DMAX_XY))
+ allocate(work(NGLOB2DMAX_XY))
+
+
+! allocate mask for ibool
+ allocate(mask_ibool(nglob_ori))
+
+ imsg = 0
+
+ if(myrank == 0) then
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! file to store the list of processors for each message for faces
+!!! DK DK for merged open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_faces.txt',status='unknown')
+
+ endif
+
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+
+! create theoretical communication pattern
+ do imsg_type = 1,NUM_MSG_TYPES
+ do iside = 1,NUM_FACES
+ do iproc_loop = 0,NPROC_ONE_DIRECTION-1
+
+! create a new message
+! we know there can be no deadlock with this scheme
+! because the three types of messages are independent
+ imsg = imsg + 1
+
+! check that current message number is correct
+ if(imsg > NUMMSGS_FACES) call exit_MPI(myrank,'incorrect message number')
+
+ if(myrank == 0) write(IMAIN,*) 'Generating message ',imsg,' for faces out of ',NUMMSGS_FACES
+
+! we know there is the same number of slices in both directions
+ iproc_xi_loop = iproc_loop
+ iproc_eta_loop = iproc_loop
+
+! take care of local frame inversions between chunks
+ iproc_xi_loop_inv = NPROC_ONE_DIRECTION - iproc_loop - 1
+ iproc_eta_loop_inv = NPROC_ONE_DIRECTION - iproc_loop - 1
+
+
+! define the 12 different messages
+
+! message type M1
+ if(imsg_type == 1) then
+
+ if(iside == 1) then
+ ichunk_send = CHUNK_AB
+ iproc_xi_send = 0
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MIN
+ ichunk_receive = CHUNK_AC
+ iproc_xi_receive = NPROC_XI-1
+ iproc_eta_receive = iproc_eta_loop
+ iproc_edge_receive = XI_MAX
+ endif
+
+ if(iside == 2) then
+ ichunk_send = CHUNK_AB
+ iproc_xi_send = NPROC_XI-1
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MAX
+ ichunk_receive = CHUNK_AC_ANTIPODE
+ iproc_xi_receive = 0
+ iproc_eta_receive = iproc_eta_loop
+ iproc_edge_receive = XI_MIN
+ endif
+
+ if(iside == 3) then
+ ichunk_send = CHUNK_AC_ANTIPODE
+ iproc_xi_send = NPROC_XI-1
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MAX
+ ichunk_receive = CHUNK_AB_ANTIPODE
+ iproc_xi_receive = 0
+ iproc_eta_receive = iproc_eta_loop
+ iproc_edge_receive = XI_MIN
+ endif
+
+ if(iside == 4) then
+ ichunk_send = CHUNK_AC
+ iproc_xi_send = 0
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MIN
+ ichunk_receive = CHUNK_AB_ANTIPODE
+ iproc_xi_receive = NPROC_XI-1
+ iproc_eta_receive = iproc_eta_loop
+ iproc_edge_receive = XI_MAX
+ endif
+
+ endif
+
+! message type M2
+ if(imsg_type == 2) then
+
+ if(iside == 1) then
+ ichunk_send = CHUNK_AB
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = NPROC_ETA-1
+ iproc_edge_send = ETA_MAX
+ ichunk_receive = CHUNK_BC
+ iproc_xi_receive = NPROC_XI-1
+ iproc_eta_receive = iproc_eta_loop
+ iproc_edge_receive = XI_MAX
+ endif
+
+ if(iside == 2) then
+ ichunk_send = CHUNK_AB
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = 0
+ iproc_edge_send = ETA_MIN
+ ichunk_receive = CHUNK_BC_ANTIPODE
+ iproc_xi_receive = NPROC_XI-1
+ iproc_eta_receive = iproc_eta_loop_inv
+ iproc_edge_receive = XI_MAX
+ endif
+
+ if(iside == 3) then
+ ichunk_send = CHUNK_BC
+ iproc_xi_send = 0
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MIN
+ ichunk_receive = CHUNK_AB_ANTIPODE
+ iproc_xi_receive = iproc_xi_loop_inv
+ iproc_eta_receive = NPROC_ETA-1
+ iproc_edge_receive = ETA_MAX
+ endif
+
+ if(iside == 4) then
+ ichunk_send = CHUNK_BC_ANTIPODE
+ iproc_xi_send = 0
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MIN
+ ichunk_receive = CHUNK_AB_ANTIPODE
+ iproc_xi_receive = iproc_xi_loop
+ iproc_eta_receive = 0
+ iproc_edge_receive = ETA_MIN
+ endif
+
+ endif
+
+! message type M3
+ if(imsg_type == 3) then
+
+ if(iside == 1) then
+ ichunk_send = CHUNK_AC
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = NPROC_ETA-1
+ iproc_edge_send = ETA_MAX
+ ichunk_receive = CHUNK_BC
+ iproc_xi_receive = iproc_xi_loop
+ iproc_eta_receive = 0
+ iproc_edge_receive = ETA_MIN
+ endif
+
+ if(iside == 2) then
+ ichunk_send = CHUNK_BC
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = NPROC_ETA-1
+ iproc_edge_send = ETA_MAX
+ ichunk_receive = CHUNK_AC_ANTIPODE
+ iproc_xi_receive = iproc_xi_loop_inv
+ iproc_eta_receive = NPROC_ETA-1
+ iproc_edge_receive = ETA_MAX
+ endif
+
+ if(iside == 3) then
+ ichunk_send = CHUNK_AC_ANTIPODE
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = 0
+ iproc_edge_send = ETA_MIN
+ ichunk_receive = CHUNK_BC_ANTIPODE
+ iproc_xi_receive = iproc_xi_loop_inv
+ iproc_eta_receive = 0
+ iproc_edge_receive = ETA_MIN
+ endif
+
+ if(iside == 4) then
+ ichunk_send = CHUNK_AC
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = 0
+ iproc_edge_send = ETA_MIN
+ ichunk_receive = CHUNK_BC_ANTIPODE
+ iproc_xi_receive = iproc_xi_loop
+ iproc_eta_receive = NPROC_ETA-1
+ iproc_edge_receive = ETA_MAX
+ endif
+
+ endif
+
+
+! store addressing generated
+ iproc_sender(imsg) = addressing(ichunk_send,iproc_xi_send,iproc_eta_send)
+ iproc_receiver(imsg) = addressing(ichunk_receive,iproc_xi_receive,iproc_eta_receive)
+
+! check that sender/receiver pair is ordered
+ if(iproc_sender(imsg) > iproc_receiver(imsg)) call exit_MPI(myrank,'incorrect order in sender/receiver pair')
+
+! save message type and pair of processors in list of messages
+!!! DK DK for merged if(myrank == 0) write(IOUT,*) imsg_type,iproc_sender(imsg),iproc_receiver(imsg)
+
+! loop on sender/receiver (1=sender 2=receiver)
+ do imode_comm=1,2
+
+ if(imode_comm == 1) then
+ iproc = iproc_sender(imsg)
+ iedge = iproc_edge_send
+!! DK DK commented this out for the merged version
+! write(filename_out,"('buffer_faces_chunks_sender_msg',i6.6,'.txt')") imsg
+
+ else if(imode_comm == 2) then
+ iproc = iproc_receiver(imsg)
+ iedge = iproc_edge_receive
+!! DK DK commented this out for the merged version
+! write(filename_out,"('buffer_faces_chunks_receiver_msg',i6.6,'.txt')") imsg
+
+ else
+ call exit_MPI(myrank,'incorrect communication mode')
+ endif
+
+! only do this if current processor is the right one for MPI version
+ if(iproc == myrank) then
+
+!---------------------------------------------------------------------
+
+!! DK DK added this for the merged version, modified from the old read_arrays_buffers_solver.f90
+!! DK DK the goal here is to determine the right value of icount_faces
+
+!---- read indirect addressing for each message for faces of the chunks
+!---- a given slice can belong to at most two faces
+! check that we have found the right correspondance
+ if(imode_comm == 1 .and. myrank /= iprocfrom_faces(imsg)) call exit_MPI(myrank,'this message should be for a sender')
+ if(imode_comm == 2 .and. myrank /= iprocto_faces(imsg)) call exit_MPI(myrank,'this message should be for a receiver')
+ icount_faces = 0
+ do imsg2 = 1,imsg
+ if(myrank == iprocfrom_faces(imsg2) .or. myrank == iprocto_faces(imsg2)) then
+ icount_faces = icount_faces + 1
+ if(icount_faces>NUMFACES_SHARED) call exit_MPI(myrank,'more than NUMFACES_SHARED faces for this slice')
+ if(icount_faces>2 .and. (NPROC_XI > 1 .or. NPROC_ETA > 1)) call exit_MPI(myrank,'more than two faces for this slice')
+ endif
+ enddo
+
+!---------------------------------------------------------------------
+
+! create the name of the database for each slice
+ call create_name_database(prname,iproc,iregion_code,LOCAL_PATH)
+
+! open file for 2D buffer
+!! DK DK suppressed in the merged version
+! open(unit=IOUT_BUFFERS,file=prname(1:len_trim(prname))//filename_out,status='unknown')
+
+! determine chunk number and local slice coordinates using addressing
+ ichunk = ichunk_slice(iproc)
+ iproc_xi = iproc_xi_slice(iproc)
+ iproc_eta = iproc_eta_slice(iproc)
+
+! problem if not on edges
+ if(iproc_xi /= 0 .and. iproc_xi /= NPROC_XI-1 .and. &
+ iproc_eta /= 0 .and. iproc_eta /= NPROC_ETA-1) call exit_MPI(myrank,'slice not on any edge')
+
+ nglob=nglob_ori
+! check that iboolmax=nglob
+
+ if(minval(ibool(:,:,:,1:nspec)) /= 1 .or. maxval(ibool(:,:,:,1:nspec)) /= nglob) &
+ call exit_MPI(myrank,ERR_MSG)
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! read boundary parameters
+!! DK DK suppressed in the merged version
+! open(unit=IIN,file=prname(1:len_trim(prname))//'boundary.bin',status='old',action='read',form='unformatted')
+!! DK DK suppressed in the merged version read(IIN) nspec2D_xmin
+!! DK DK suppressed in the merged version read(IIN) nspec2D_xmax
+!! DK DK suppressed in the merged version read(IIN) nspec2D_ymin
+!! DK DK suppressed in the merged version read(IIN) nspec2D_ymax
+!! DK DK suppressed in the merged version read(IIN) njunk
+!! DK DK suppressed in the merged version read(IIN) njunk
+!! DK DK suppressed in the merged version
+!! DK DK suppressed in the merged version read(IIN) ibelm_xmin
+!! DK DK suppressed in the merged version read(IIN) ibelm_xmax
+!! DK DK suppressed in the merged version read(IIN) ibelm_ymin
+!! DK DK suppressed in the merged version read(IIN) ibelm_ymax
+!! DK DK suppressed in the merged version close(IIN)
+
+! read 1D buffers to remove corner points
+!! DK DK suppressed in the merged version
+! open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt',status='old',action='read')
+!! DK DK suppressed in the merged version do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,1)
+!! DK DK suppressed in the merged version read(IIN,*) ibool1D_leftxi_lefteta(ipoin1D),xdummy,ydummy,zdummy
+!! DK DK suppressed in the merged version enddo
+!! DK DK suppressed in the merged version close(IIN)
+
+!! DK DK suppressed in the merged version
+! open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt',status='old',action='read')
+!! DK DK suppressed in the merged version do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,2)
+!! DK DK suppressed in the merged version read(IIN,*) ibool1D_rightxi_lefteta(ipoin1D),xdummy,ydummy,zdummy
+!! DK DK suppressed in the merged version enddo
+!! DK DK suppressed in the merged version close(IIN)
+
+!! DK DK suppressed in the merged version
+! open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt',status='old',action='read')
+!! DK DK suppressed in the merged version do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,4)
+!! DK DK suppressed in the merged version read(IIN,*) ibool1D_leftxi_righteta(ipoin1D),xdummy,ydummy,zdummy
+!! DK DK suppressed in the merged version enddo
+!! DK DK suppressed in the merged version close(IIN)
+
+!! DK DK suppressed in the merged version
+! open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt',status='old',action='read')
+!! DK DK suppressed in the merged version do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,3)
+!! DK DK suppressed in the merged version read(IIN,*) ibool1D_rightxi_righteta(ipoin1D),xdummy,ydummy,zdummy
+!! DK DK suppressed in the merged version enddo
+!! DK DK suppressed in the merged version close(IIN)
+
+! erase logical mask
+ mask_ibool(:) = .false.
+
+ npoin2D = 0
+
+! create all the points on each face (no duplicates, but not sorted)
+
+! xmin
+ if(iedge == XI_MIN) then
+
+! mark corner points to remove them if needed
+ if(iproc_eta == 0) then
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,1)
+ mask_ibool(ibool1D_leftxi_lefteta(ipoin1D)) = .true.
+ enddo
+ endif
+
+ if(iproc_eta == NPROC_ETA-1) then
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,4)
+ mask_ibool(ibool1D_leftxi_righteta(ipoin1D)) = .true.
+ enddo
+ endif
+
+ do ispec2D=1,nspec2D_xmin
+ ispec=ibelm_xmin(ispec2D)
+
+! remove central cube for chunk buffers
+ if(iregion_code == IREGION_INNER_CORE) then
+ if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
+ endif
+
+ i=1
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ if(.not. mask_ibool(ibool(i,j,k,ispec))) then
+! mask and store points found
+ mask_ibool(ibool(i,j,k,ispec)) = .true.
+ npoin2D = npoin2D + 1
+ if(npoin2D > NGLOB2DMAX_XMIN_XMAX) call exit_MPI(myrank,'incorrect 2D point number in xmin')
+ ibool_selected(npoin2D) = ibool(i,j,k,ispec)
+
+ xstore_selected(npoin2D) = xstore(i,j,k,ispec)
+ ystore_selected(npoin2D) = ystore(i,j,k,ispec)
+ zstore_selected(npoin2D) = zstore(i,j,k,ispec)
+ endif
+ enddo
+ enddo
+ enddo
+
+! xmax
+ else if(iedge == XI_MAX) then
+
+! mark corner points to remove them if needed
+
+ if(iproc_eta == 0) then
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,2)
+ mask_ibool(ibool1D_rightxi_lefteta(ipoin1D)) = .true.
+ enddo
+ endif
+
+ if(iproc_eta == NPROC_ETA-1) then
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,3)
+ mask_ibool(ibool1D_rightxi_righteta(ipoin1D)) = .true.
+ enddo
+ endif
+
+ do ispec2D=1,nspec2D_xmax
+ ispec=ibelm_xmax(ispec2D)
+
+! remove central cube for chunk buffers
+ if(iregion_code == IREGION_INNER_CORE) then
+ if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
+ endif
+
+ i=NGLLX
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ if(.not. mask_ibool(ibool(i,j,k,ispec))) then
+! mask and store points found
+ mask_ibool(ibool(i,j,k,ispec)) = .true.
+ npoin2D = npoin2D + 1
+ if(npoin2D > NGLOB2DMAX_XMIN_XMAX) call exit_MPI(myrank,'incorrect 2D point number in xmax')
+ ibool_selected(npoin2D) = ibool(i,j,k,ispec)
+
+ xstore_selected(npoin2D) = xstore(i,j,k,ispec)
+ ystore_selected(npoin2D) = ystore(i,j,k,ispec)
+ zstore_selected(npoin2D) = zstore(i,j,k,ispec)
+ endif
+ enddo
+ enddo
+ enddo
+
+! ymin
+ else if(iedge == ETA_MIN) then
+
+! mark corner points to remove them if needed
+
+ if(iproc_xi == 0) then
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,1)
+ mask_ibool(ibool1D_leftxi_lefteta(ipoin1D)) = .true.
+ enddo
+ endif
+
+ if(iproc_xi == NPROC_XI-1) then
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,2)
+ mask_ibool(ibool1D_rightxi_lefteta(ipoin1D)) = .true.
+ enddo
+ endif
+
+ do ispec2D=1,nspec2D_ymin
+ ispec=ibelm_ymin(ispec2D)
+
+! remove central cube for chunk buffers
+ if(iregion_code == IREGION_INNER_CORE) then
+ if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
+ endif
+
+ j=1
+ do k=1,NGLLZ
+ do i=1,NGLLX
+ if(.not. mask_ibool(ibool(i,j,k,ispec))) then
+! mask and store points found
+ mask_ibool(ibool(i,j,k,ispec)) = .true.
+ npoin2D = npoin2D + 1
+ if(npoin2D > NGLOB2DMAX_YMIN_YMAX) call exit_MPI(myrank,'incorrect 2D point number in ymin')
+ ibool_selected(npoin2D) = ibool(i,j,k,ispec)
+
+ xstore_selected(npoin2D) = xstore(i,j,k,ispec)
+ ystore_selected(npoin2D) = ystore(i,j,k,ispec)
+ zstore_selected(npoin2D) = zstore(i,j,k,ispec)
+ endif
+ enddo
+ enddo
+ enddo
+
+! ymax
+ else if(iedge == ETA_MAX) then
+
+! mark corner points to remove them if needed
+
+ if(iproc_xi == 0) then
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,4)
+ mask_ibool(ibool1D_leftxi_righteta(ipoin1D)) = .true.
+ enddo
+ endif
+
+ if(iproc_xi == NPROC_XI-1) then
+ do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,3)
+ mask_ibool(ibool1D_rightxi_righteta(ipoin1D)) = .true.
+ enddo
+ endif
+
+ do ispec2D=1,nspec2D_ymax
+ ispec=ibelm_ymax(ispec2D)
+
+! remove central cube for chunk buffers
+ if(iregion_code == IREGION_INNER_CORE) then
+ if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
+ endif
+
+ j=NGLLY
+ do k=1,NGLLZ
+ do i=1,NGLLX
+ if(.not. mask_ibool(ibool(i,j,k,ispec))) then
+! mask and store points found
+ mask_ibool(ibool(i,j,k,ispec)) = .true.
+ npoin2D = npoin2D + 1
+ if(npoin2D > NGLOB2DMAX_YMIN_YMAX) call exit_MPI(myrank,'incorrect 2D point number in ymax')
+ ibool_selected(npoin2D) = ibool(i,j,k,ispec)
+
+ xstore_selected(npoin2D) = xstore(i,j,k,ispec)
+ ystore_selected(npoin2D) = ystore(i,j,k,ispec)
+ zstore_selected(npoin2D) = zstore(i,j,k,ispec)
+ endif
+ enddo
+ enddo
+ enddo
+
+ else
+
+ call exit_MPI(myrank,'incorrect edge code')
+ endif
+
+! sort buffer obtained to be conforming with neighbor in other chunk
+! sort on x, y and z, the other arrays will be swapped as well
+ call sort_array_coordinates(npoin2D,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+! check that no duplicate has been detected
+ if(nglob /= npoin2D) call exit_MPI(myrank,'duplicates detected in buffer')
+
+! write list of selected points to output buffer
+!! DK DK suppressed in the merged version write(IOUT_BUFFERS,*) npoin2D
+
+!! DK DK added this for the merged version
+ npoin2D_faces(icount_faces) = npoin2D
+
+!! DK DK suppressed in the merged version do ipoin2D = 1,npoin2D
+ do ipoin2D = 1,npoin2D
+!! DK DK suppressed in the merged version write(IOUT_BUFFERS,*) ibool_selected(ipoin2D), &
+!! DK DK suppressed in the merged version
+! xstore_selected(ipoin2D),ystore_selected(ipoin2D),zstore_selected(ipoin2D)
+
+!! DK DK added this for the merged version
+ iboolfaces(ipoin2D,icount_faces) = ibool_selected(ipoin2D)
+
+ enddo
+!! DK DK suppressed in the merged version enddo
+
+!! DK DK suppressed in the merged version close(IOUT_BUFFERS)
+
+! store result to compare number of points for sender and for receiver
+ if(imode_comm == 1) then
+ npoin2D_send(imsg) = npoin2D
+ else
+ npoin2D_receive(imsg) = npoin2D
+ endif
+
+! end of section done only if right processor for MPI
+ endif
+
+! end of loop on sender/receiver
+ enddo
+
+! end of loops on all the messages
+ enddo
+ enddo
+ enddo
+
+!!! DK DK for merged if(myrank == 0) close(IOUT)
+
+! check that total number of messages is correct
+ if(imsg /= NUMMSGS_FACES) call exit_MPI(myrank,'incorrect total number of messages')
+
+!
+!---- check that number of points detected is the same for sender and receiver
+!
+
+! synchronize all the processes to make sure all the buffers are ready
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+! gather information about all the messages on all processes
+ do imsg = 1,NUMMSGS_FACES
+
+! gather number of points for sender
+ npoin2D_send_local = npoin2D_send(imsg)
+ call MPI_BCAST(npoin2D_send_local,1,MPI_INTEGER,iproc_sender(imsg),MPI_COMM_WORLD,ier)
+ if(myrank /= iproc_sender(imsg)) npoin2D_send(imsg) = npoin2D_send_local
+
+! gather number of points for receiver
+ npoin2D_receive_local = npoin2D_receive(imsg)
+ call MPI_BCAST(npoin2D_receive_local,1,MPI_INTEGER,iproc_receiver(imsg),MPI_COMM_WORLD,ier)
+ if(myrank /= iproc_receiver(imsg)) npoin2D_receive(imsg) = npoin2D_receive_local
+
+ enddo
+
+! check the number of points
+ do imsg = 1,NUMMSGS_FACES
+ if(npoin2D_send(imsg) /= npoin2D_receive(imsg)) &
+ call exit_MPI(myrank,'incorrect number of points for sender/receiver pair detected')
+ enddo
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'all the messages for chunk faces have the right size'
+ write(IMAIN,*)
+ endif
+
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+
+!
+!---- generate the 8 message patterns sharing a corner of valence 3
+!
+
+! to avoid problem at compile time, use bigger array with fixed dimension
+ addressing_big(:,:,:) = 0
+ addressing_big(1:NCHUNKS,:,:) = addressing(1:NCHUNKS,:,:)
+
+ ichunk = 1
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AB,0,NPROC_ETA-1)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_AC,NPROC_XI-1,NPROC_ETA-1)
+! this line is ok even for NCHUNKS = 2
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_BC,NPROC_XI-1,0)
+
+ itypecorner(1,ichunk) = ILOWERUPPER
+ itypecorner(2,ichunk) = IUPPERUPPER
+ itypecorner(3,ichunk) = IUPPERLOWER
+
+!! DK DK UGLY in the future, should also assemble second corner when NCHUNKS = 2
+!! DK DK UGLY for now we only assemble one corner for simplicity
+!! DK DK UGLY formally this is incorrect and should be changed in the future
+!! DK DK UGLY in practice this trick works fine
+
+! this only if more than 3 chunks
+ if(NCHUNKS > 3) then
+
+ ichunk = 2
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AB,NPROC_XI-1,0)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_AC_ANTIPODE,0,0)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_BC_ANTIPODE,NPROC_XI-1,0)
+
+ itypecorner(1,ichunk) = IUPPERLOWER
+ itypecorner(2,ichunk) = ILOWERLOWER
+ itypecorner(3,ichunk) = IUPPERLOWER
+
+ ichunk = 3
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AB,0,0)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_AC,NPROC_XI-1,0)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_BC_ANTIPODE,NPROC_XI-1,NPROC_ETA-1)
+
+ itypecorner(1,ichunk) = ILOWERLOWER
+ itypecorner(2,ichunk) = IUPPERLOWER
+ itypecorner(3,ichunk) = IUPPERUPPER
+
+ ichunk = 4
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AB,NPROC_XI-1,NPROC_ETA-1)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_BC,NPROC_XI-1,NPROC_ETA-1)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_AC_ANTIPODE,0,NPROC_ETA-1)
+
+ itypecorner(1,ichunk) = IUPPERUPPER
+ itypecorner(2,ichunk) = IUPPERUPPER
+ itypecorner(3,ichunk) = ILOWERUPPER
+
+ ichunk = 5
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AC,0,0)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_BC_ANTIPODE,0,NPROC_ETA-1)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_AB_ANTIPODE,NPROC_XI-1,0)
+
+ itypecorner(1,ichunk) = ILOWERLOWER
+ itypecorner(2,ichunk) = ILOWERUPPER
+ itypecorner(3,ichunk) = IUPPERLOWER
+
+ ichunk = 6
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AC_ANTIPODE,NPROC_XI-1,0)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_BC_ANTIPODE,0,0)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_AB_ANTIPODE,0,0)
+
+ itypecorner(1,ichunk) = IUPPERLOWER
+ itypecorner(2,ichunk) = ILOWERLOWER
+ itypecorner(3,ichunk) = ILOWERLOWER
+
+ ichunk = 7
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AC,0,NPROC_ETA-1)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_BC,0,0)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_AB_ANTIPODE,NPROC_XI-1,NPROC_ETA-1)
+
+ itypecorner(1,ichunk) = ILOWERUPPER
+ itypecorner(2,ichunk) = ILOWERLOWER
+ itypecorner(3,ichunk) = IUPPERUPPER
+
+ ichunk = 8
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_BC,0,NPROC_ETA-1)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_AC_ANTIPODE,NPROC_XI-1,NPROC_ETA-1)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_AB_ANTIPODE,0,NPROC_ETA-1)
+
+ itypecorner(1,ichunk) = ILOWERUPPER
+ itypecorner(2,ichunk) = IUPPERUPPER
+ itypecorner(3,ichunk) = ILOWERUPPER
+
+ endif
+
+! file to store the list of processors for each message for corners
+!!! DK DK for merged if(myrank == 0) open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_corners.txt',status='unknown')
+
+! loop over all the messages to create the addressing
+ do imsg = 1,NCORNERSCHUNKS
+
+ if(myrank == 0) write(IMAIN,*) 'Generating message ',imsg,' for corners out of ',NCORNERSCHUNKS
+
+! save triplet of processors in list of messages
+!!! DK DK for merged if(myrank == 0) write(IOUT,*) iprocscorners(1,imsg),iprocscorners(2,imsg),iprocscorners(3,imsg)
+
+! loop on the three processors of a given corner
+ do imember_corner = 1,3
+
+ if(imember_corner == 1) then
+! write(filename_out,"('buffer_corners_chunks_master_msg',i6.6,'.txt')") imsg
+ else if(imember_corner == 2) then
+! write(filename_out,"('buffer_corners_chunks_worker1_msg',i6.6,'.txt')") imsg
+ else
+! write(filename_out,"('buffer_corners_chunks_worker2_msg',i6.6,'.txt')") imsg
+ endif
+
+! only do this if current processor is the right one for MPI version
+! this line is ok even for NCHUNKS = 2
+ if(iprocscorners(imember_corner,imsg) == myrank) then
+
+!---------------------------------------------------------------------
+
+!! DK DK added this for the merged version, modified from the old read_arrays_buffers_solver.f90
+!! DK DK the goal here is to determine the right value of icount_corners
+
+!---- read indirect addressing for each message for corners of the chunks
+!---- a given slice can belong to at most one corner
+! check that we have found the right correspondance
+ if(imember_corner == 1 .and. myrank /= iproc_master_corners(imsg)) call exit_MPI(myrank,'this message should be for a master')
+ if(imember_corner == 2 .and. myrank /= iproc_worker1_corners(imsg)) call exit_MPI(myrank,'this message should be for a worker1')
+ if(imember_corner == 3 .and. myrank /= iproc_worker2_corners(imsg)) call exit_MPI(myrank,'this message should be for a worker2')
+ icount_corners = 0
+ do imsg2 = 1,imsg
+ if(myrank == iproc_master_corners(imsg2) .or. &
+ myrank == iproc_worker1_corners(imsg2) .or. &
+ myrank == iproc_worker2_corners(imsg2)) then
+ icount_corners = icount_corners + 1
+ if(icount_corners>1 .and. (NPROC_XI > 1 .or. NPROC_ETA > 1)) &
+ call exit_MPI(myrank,'more than one corner for this slice')
+ if(icount_corners>4) call exit_MPI(myrank,'more than four corners for this slice')
+ endif
+ enddo
+
+!---- read indirect addressing for each message for faces of the chunks
+!---- a given slice can belong to at most two faces
+ if(imode_comm == 1 .and. myrank /= iprocfrom_faces(imsg)) call exit_MPI(myrank,'this message should be for a sender')
+ if(imode_comm == 2 .and. myrank /= iprocto_faces(imsg)) call exit_MPI(myrank,'this message should be for a receiver')
+
+!---------------------------------------------------------------------
+
+! pick the correct 1D buffer
+! this scheme works fine even if NPROC_XI = NPROC_ETA = 1
+ if(itypecorner(imember_corner,imsg) == ILOWERLOWER) then
+!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt'
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,1)
+ else if(itypecorner(imember_corner,imsg) == ILOWERUPPER) then
+!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt'
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,4)
+ else if(itypecorner(imember_corner,imsg) == IUPPERLOWER) then
+!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt'
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,2)
+ else if(itypecorner(imember_corner,imsg) == IUPPERUPPER) then
+!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt'
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,3)
+ else
+ call exit_MPI(myrank,'incorrect corner coordinates')
+ endif
+
+! read 1D buffer for corner
+!! DK DK suppressed in the merged version open(unit=IIN,file=filename_in,status='old',action='read')
+ do ipoin1D = 1,NGLOB1D_RADIAL_my_corner
+!! DK DK suppressed in the merged version read(IIN,*) ibool1D(ipoin1D), &
+!! DK DK suppressed in the merged version xread1D(ipoin1D),yread1D(ipoin1D),zread1D(ipoin1D)
+
+!! DK DK added this for merged
+! pick the correct 1D buffer
+! this scheme works fine even if NPROC_XI = NPROC_ETA = 1
+ if(itypecorner(imember_corner,imsg) == ILOWERLOWER) then
+ ibool1D(ipoin1D) = ibool1D_leftxi_lefteta(ipoin1D)
+ xread1D(ipoin1D) = xread1D_leftxi_lefteta(ipoin1D)
+ yread1D(ipoin1D) = yread1D_leftxi_lefteta(ipoin1D)
+ zread1D(ipoin1D) = zread1D_leftxi_lefteta(ipoin1D)
+ else if(itypecorner(imember_corner,imsg) == ILOWERUPPER) then
+ ibool1D(ipoin1D) = ibool1D_leftxi_righteta(ipoin1D)
+ xread1D(ipoin1D) = xread1D_leftxi_righteta(ipoin1D)
+ yread1D(ipoin1D) = yread1D_leftxi_righteta(ipoin1D)
+ zread1D(ipoin1D) = zread1D_leftxi_righteta(ipoin1D)
+ else if(itypecorner(imember_corner,imsg) == IUPPERLOWER) then
+ ibool1D(ipoin1D) = ibool1D_rightxi_lefteta(ipoin1D)
+ xread1D(ipoin1D) = xread1D_rightxi_lefteta(ipoin1D)
+ yread1D(ipoin1D) = yread1D_rightxi_lefteta(ipoin1D)
+ zread1D(ipoin1D) = zread1D_rightxi_lefteta(ipoin1D)
+ else if(itypecorner(imember_corner,imsg) == IUPPERUPPER) then
+ ibool1D(ipoin1D) = ibool1D_rightxi_righteta(ipoin1D)
+ xread1D(ipoin1D) = xread1D_rightxi_righteta(ipoin1D)
+ yread1D(ipoin1D) = yread1D_rightxi_righteta(ipoin1D)
+ zread1D(ipoin1D) = zread1D_rightxi_righteta(ipoin1D)
+ else
+ call exit_MPI(myrank,'incorrect corner coordinates')
+ endif
+
+ enddo
+!! DK DK suppressed in the merged version close(IIN)
+
+! sort array read based upon the coordinates of the points
+! to ensure conforming matching with other buffers from neighbors
+ call sort_array_coordinates(NGLOB1D_RADIAL_my_corner,xread1D,yread1D,zread1D, &
+ ibool1D,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+! check that no duplicates have been found
+ if(nglob /= NGLOB1D_RADIAL_my_corner) call exit_MPI(myrank,'duplicates found for corners')
+
+! write file with 1D buffer for corner
+!! DK DK suppressed in the merged version open(unit=IOUT_BUFFERS,file=prname(1:len_trim(prname))//filename_out,status='unknown')
+!! DK DK suppressed in the merged version write(IOUT_BUFFERS,*) NGLOB1D_RADIAL_my_corner
+ do ipoin1D = 1,NGLOB1D_RADIAL_my_corner
+!! DK DK suppressed in the merged version write(IOUT_BUFFERS,*) ibool1D(ipoin1D), &
+!! DK DK suppressed in the merged version xread1D(ipoin1D),yread1D(ipoin1D),zread1D(ipoin1D)
+
+!! DK DK added this for merged version
+ iboolcorner(ipoin1D,icount_corners) = ibool1D(ipoin1D)
+
+ enddo
+!! DK DK suppressed in the merged version close(IOUT_BUFFERS)
+
+! end of section done only if right processor for MPI
+ endif
+
+ enddo
+
+ enddo
+
+!!! DK DK for merged if(myrank == 0) close(IOUT)
+
+! deallocate arrays
+ deallocate(iproc_sender)
+ deallocate(iproc_receiver)
+ deallocate(npoin2D_send)
+ deallocate(npoin2D_receive)
+
+ deallocate(iprocscorners)
+ deallocate(itypecorner)
+
+ deallocate(ibool_selected)
+ deallocate(xstore_selected)
+ deallocate(ystore_selected)
+ deallocate(zstore_selected)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iglob)
+ deallocate(locval)
+ deallocate(ifseg)
+ deallocate(iwork)
+ deallocate(work)
+
+ deallocate(mask_ibool)
+
+ end subroutine create_chunk_buffers
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_header_file.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_header_file.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,238 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! create file OUTPUT_FILES/values_from_mesher.h based upon DATA/Par_file
+! in order to compile the solver with the right array sizes
+
+ program xcreate_header_file
+
+ implicit none
+
+ include "constants.h"
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_VOLUME_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_VOLUME_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.)
+
+! count the total number of sources in the CMTSOLUTION file
+ call count_number_of_sources(NSOURCES)
+
+ do iregion=1,MAX_NUM_REGIONS
+ NGLOB1D_RADIAL_CORNER(iregion,:) = NGLOB1D_RADIAL(iregion)
+ enddo
+
+ if (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA) then
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + &
+ maxval(DIFF_NSPEC1D_RADIAL(:,:))*(NGLLZ-1)
+ endif
+
+! evaluate the amount of static memory needed by the solver
+ call memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MANTLE,&
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_INNER_CORE,ROTATION,&
+ ONE_CRUST,doubling_index,this_region_has_a_doubling,&
+ ner,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_sampling_array,&
+ NSPEC,nglob,SIMULATION_TYPE,MOVIE_VOLUME,SAVE_FORWARD, &
+ NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION,static_memory_size)
+
+ NGLOB1D_RADIAL_TEMP(:) = &
+ (/maxval(NGLOB1D_RADIAL_CORNER(1,:)),maxval(NGLOB1D_RADIAL_CORNER(2,:)),maxval(NGLOB1D_RADIAL_CORNER(3,:))/)
+
+! create include file for the solver
+ call save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ ELLIPTICITY,GRAVITY,ROTATION,ATTENUATION,ATTENUATION_3D, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,NCHUNKS, &
+ INCLUDE_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,NSOURCES,NSTEP,&
+ static_memory_size,&
+ NGLOB1D_RADIAL_TEMP,&
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NSPEC2D_TOP,NSPEC2D_BOTTOM, &
+ NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX, &
+ NPROC_XI,NPROC_ETA, &
+ NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION)
+
+ print *
+ print *,'edit file OUTPUT_FILES/values_from_mesher.h to see some statistics about the mesh'
+ print *
+
+ print *,'number of processors = ',NPROCTOT
+ print *
+ print *,'maximum number of points per region = ',nglob(IREGION_CRUST_MANTLE)
+ print *
+ print *,'total elements per slice = ',sum(NSPEC)
+ print *,'total points per slice = ',sum(nglob)
+ print *
+ print *,'number of time steps = ',NSTEP
+ print *
+
+ print *,'on NEC SX and Earth Simulator, make sure "loopcnt=" parameter'
+! use fused loops on the ES
+ print *,'in Makefile is greater than max vector length = ',nglob(IREGION_CRUST_MANTLE)*NDIM
+ print *
+
+ print *,'approximate static memory needed by the solver:'
+ print *,'----------------------------------------------'
+ print *
+ print *,'size of static arrays per slice = ',static_memory_size/1073741824.d0,' GB'
+ print *
+ print *,' (should be below and typically equal to 80% of 1.5 GB = 1.2 GB on pangu'
+ print *,' at Caltech, and below and typically equal to 85% of 2 GB = 1.7 GB'
+ print *,' on Marenostrum in Barcelona)'
+ print *,' (if significantly more, the job will not run by lack of memory)'
+ print *,' (if significantly less, you waste a significant amount of memory)'
+ print *
+ print *,'size of static arrays for all slices = ',static_memory_size*dble(NPROCTOT)/1073741824.d0,' GB'
+ print *,' = ',static_memory_size*dble(NPROCTOT)/1099511627776.d0,' TB'
+ print *
+
+ end program xcreate_header_file
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_list_files_chunks.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_list_files_chunks.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_list_files_chunks.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,566 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! subroutine to create the list of messages to assemble between chunks in files if more than one chunk
+
+!! DK DK for merged version: a lot of useless code / useless lines car probably be suppressed
+!! DK DK in this new routine below
+
+ subroutine create_list_files_chunks(iregion_code, &
+ nglob_ori,NPROC_XI,NPROC_ETA,NPROCTOT,NGLOB1D_RADIAL_CORNER, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ myrank,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+!! DK DK for the merged version
+! include values created by the mesher
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_CORNER
+
+ integer nglob,nglob_ori
+ integer NPROC_XI,NPROC_ETA,NPROCTOT,NGLOB1D_RADIAL_my_corner
+ integer NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
+ integer myrank,NCHUNKS
+
+ character(len=150) OUTPUT_FILES
+
+! array to store points selected for the chunk face buffer
+ integer NGLOB2DMAX_XY
+
+! pairs generated theoretically
+! four sides for each of the three types of messages
+ integer, dimension(:), allocatable :: iproc_sender,iproc_receiver,npoin2D_send,npoin2D_receive
+
+! arrays to assemble the corners (3 processors for each corner)
+ integer, dimension(:,:), allocatable :: iprocscorners,itypecorner
+
+ integer ichunk_send,iproc_xi_send,iproc_eta_send
+ integer ichunk_receive,iproc_xi_receive,iproc_eta_receive
+ integer iproc_loop,iproc_xi_loop,iproc_eta_loop
+ integer iproc_xi_loop_inv,iproc_eta_loop_inv
+ integer imember_corner
+
+ integer iregion_code
+
+ integer iproc_edge_send,iproc_edge_receive
+ integer imsg_type,iside,imode_comm,iedge
+
+ integer ier
+
+! current message number
+ integer imsg
+
+! for addressing of the slices
+ integer ichunk,iproc_xi,iproc_eta,iproc
+ integer addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1)
+ integer ichunk_slice(0:NPROCTOT-1)
+ integer iproc_xi_slice(0:NPROCTOT-1)
+
+ integer iproc_eta_slice(0:NPROCTOT-1)
+
+! this to avoid problem at compile time if less than six chunks
+ integer addressing_big(NCHUNKS_MAX,0:NPROC_XI-1,0:NPROC_ETA-1)
+
+! number of faces between chunks
+ integer NUM_FACES,NUMMSGS_FACES
+
+! number of corners between chunks
+ integer NCORNERSCHUNKS
+
+! number of message types
+ integer NUM_MSG_TYPES
+
+ integer NPROC_ONE_DIRECTION
+
+! ************** subroutine starts here **************
+
+! number of corners and faces shared between chunks and number of message types
+ if(NCHUNKS == 1 .or. NCHUNKS == 2) then
+ NCORNERSCHUNKS = 1
+ NUM_FACES = 1
+ NUM_MSG_TYPES = 1
+ else if(NCHUNKS == 3) then
+ NCORNERSCHUNKS = 1
+ NUM_FACES = 1
+ NUM_MSG_TYPES = 3
+ else if(NCHUNKS == 6) then
+ NCORNERSCHUNKS = 8
+ NUM_FACES = 4
+ NUM_MSG_TYPES = 3
+ else
+ call exit_MPI(myrank,'number of chunks must be either 1, 2, 3 or 6')
+ endif
+
+! if more than one chunk then same number of processors in each direction
+ NPROC_ONE_DIRECTION = NPROC_XI
+
+! total number of messages corresponding to these common faces
+ NUMMSGS_FACES = NPROC_ONE_DIRECTION*NUM_FACES*NUM_MSG_TYPES
+
+! check that there is more than one chunk, otherwise nothing to do
+ if(NCHUNKS == 1) return
+
+! same number of GLL points in each direction for several chunks
+ if(NGLLY /= NGLLX) call exit_MPI(myrank,'must have NGLLY = NGLLX for several chunks')
+
+! allocate arrays for faces
+ allocate(iproc_sender(NUMMSGS_FACES))
+ allocate(iproc_receiver(NUMMSGS_FACES))
+ allocate(npoin2D_send(NUMMSGS_FACES))
+ allocate(npoin2D_receive(NUMMSGS_FACES))
+
+! allocate array for corners
+ allocate(iprocscorners(3,NCORNERSCHUNKS))
+ allocate(itypecorner(3,NCORNERSCHUNKS))
+
+! clear arrays allocated
+ iproc_sender(:) = 0
+ iproc_receiver(:) = 0
+ npoin2D_send(:) = 0
+ npoin2D_receive(:) = 0
+ iprocscorners(:,:) = 0
+ itypecorner(:,:) = 0
+
+ if(myrank == 0) then
+ write(IMAIN,*) 'There is a total of ',NUMMSGS_FACES,' messages to assemble faces between chunks'
+ write(IMAIN,*)
+ endif
+
+! define maximum size for message buffers
+ NGLOB2DMAX_XY = max(NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX)
+
+ imsg = 0
+
+ if(myrank == 0) then
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! file to store the list of processors for each message for faces
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_faces.txt',status='unknown')
+
+ endif
+
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+!!!!!!!!!! DK DK for merged version: beginning of "faces" section here
+
+! create theoretical communication pattern
+ do imsg_type = 1,NUM_MSG_TYPES
+ do iside = 1,NUM_FACES
+ do iproc_loop = 0,NPROC_ONE_DIRECTION-1
+
+! create a new message
+! we know there can be no deadlock with this scheme
+! because the three types of messages are independent
+ imsg = imsg + 1
+
+! check that current message number is correct
+ if(imsg > NUMMSGS_FACES) call exit_MPI(myrank,'incorrect message number')
+
+ if(myrank == 0) write(IMAIN,*) 'Generating message ',imsg,' for faces out of ',NUMMSGS_FACES
+
+! we know there is the same number of slices in both directions
+ iproc_xi_loop = iproc_loop
+ iproc_eta_loop = iproc_loop
+
+! take care of local frame inversions between chunks
+ iproc_xi_loop_inv = NPROC_ONE_DIRECTION - iproc_loop - 1
+ iproc_eta_loop_inv = NPROC_ONE_DIRECTION - iproc_loop - 1
+
+
+! define the 12 different messages
+
+! message type M1
+ if(imsg_type == 1) then
+
+ if(iside == 1) then
+ ichunk_send = CHUNK_AB
+ iproc_xi_send = 0
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MIN
+ ichunk_receive = CHUNK_AC
+ iproc_xi_receive = NPROC_XI-1
+ iproc_eta_receive = iproc_eta_loop
+ iproc_edge_receive = XI_MAX
+ endif
+
+ if(iside == 2) then
+ ichunk_send = CHUNK_AB
+ iproc_xi_send = NPROC_XI-1
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MAX
+ ichunk_receive = CHUNK_AC_ANTIPODE
+ iproc_xi_receive = 0
+ iproc_eta_receive = iproc_eta_loop
+ iproc_edge_receive = XI_MIN
+ endif
+
+ if(iside == 3) then
+ ichunk_send = CHUNK_AC_ANTIPODE
+ iproc_xi_send = NPROC_XI-1
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MAX
+ ichunk_receive = CHUNK_AB_ANTIPODE
+ iproc_xi_receive = 0
+ iproc_eta_receive = iproc_eta_loop
+ iproc_edge_receive = XI_MIN
+ endif
+
+ if(iside == 4) then
+ ichunk_send = CHUNK_AC
+ iproc_xi_send = 0
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MIN
+ ichunk_receive = CHUNK_AB_ANTIPODE
+ iproc_xi_receive = NPROC_XI-1
+ iproc_eta_receive = iproc_eta_loop
+ iproc_edge_receive = XI_MAX
+ endif
+
+ endif
+
+! message type M2
+ if(imsg_type == 2) then
+
+ if(iside == 1) then
+ ichunk_send = CHUNK_AB
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = NPROC_ETA-1
+ iproc_edge_send = ETA_MAX
+ ichunk_receive = CHUNK_BC
+ iproc_xi_receive = NPROC_XI-1
+ iproc_eta_receive = iproc_eta_loop
+ iproc_edge_receive = XI_MAX
+ endif
+
+ if(iside == 2) then
+ ichunk_send = CHUNK_AB
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = 0
+ iproc_edge_send = ETA_MIN
+ ichunk_receive = CHUNK_BC_ANTIPODE
+ iproc_xi_receive = NPROC_XI-1
+ iproc_eta_receive = iproc_eta_loop_inv
+ iproc_edge_receive = XI_MAX
+ endif
+
+ if(iside == 3) then
+ ichunk_send = CHUNK_BC
+ iproc_xi_send = 0
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MIN
+ ichunk_receive = CHUNK_AB_ANTIPODE
+ iproc_xi_receive = iproc_xi_loop_inv
+ iproc_eta_receive = NPROC_ETA-1
+ iproc_edge_receive = ETA_MAX
+ endif
+
+ if(iside == 4) then
+ ichunk_send = CHUNK_BC_ANTIPODE
+ iproc_xi_send = 0
+ iproc_eta_send = iproc_eta_loop
+ iproc_edge_send = XI_MIN
+ ichunk_receive = CHUNK_AB_ANTIPODE
+ iproc_xi_receive = iproc_xi_loop
+ iproc_eta_receive = 0
+ iproc_edge_receive = ETA_MIN
+ endif
+
+ endif
+
+! message type M3
+ if(imsg_type == 3) then
+
+ if(iside == 1) then
+ ichunk_send = CHUNK_AC
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = NPROC_ETA-1
+ iproc_edge_send = ETA_MAX
+ ichunk_receive = CHUNK_BC
+ iproc_xi_receive = iproc_xi_loop
+ iproc_eta_receive = 0
+ iproc_edge_receive = ETA_MIN
+ endif
+
+ if(iside == 2) then
+ ichunk_send = CHUNK_BC
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = NPROC_ETA-1
+ iproc_edge_send = ETA_MAX
+ ichunk_receive = CHUNK_AC_ANTIPODE
+ iproc_xi_receive = iproc_xi_loop_inv
+ iproc_eta_receive = NPROC_ETA-1
+ iproc_edge_receive = ETA_MAX
+ endif
+
+ if(iside == 3) then
+ ichunk_send = CHUNK_AC_ANTIPODE
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = 0
+ iproc_edge_send = ETA_MIN
+ ichunk_receive = CHUNK_BC_ANTIPODE
+ iproc_xi_receive = iproc_xi_loop_inv
+ iproc_eta_receive = 0
+ iproc_edge_receive = ETA_MIN
+ endif
+
+ if(iside == 4) then
+ ichunk_send = CHUNK_AC
+ iproc_xi_send = iproc_xi_loop
+ iproc_eta_send = 0
+ iproc_edge_send = ETA_MIN
+ ichunk_receive = CHUNK_BC_ANTIPODE
+ iproc_xi_receive = iproc_xi_loop
+ iproc_eta_receive = NPROC_ETA-1
+ iproc_edge_receive = ETA_MAX
+ endif
+
+ endif
+
+
+! store addressing generated
+ iproc_sender(imsg) = addressing(ichunk_send,iproc_xi_send,iproc_eta_send)
+ iproc_receiver(imsg) = addressing(ichunk_receive,iproc_xi_receive,iproc_eta_receive)
+
+! check that sender/receiver pair is ordered
+ if(iproc_sender(imsg) > iproc_receiver(imsg)) call exit_MPI(myrank,'incorrect order in sender/receiver pair')
+
+! save message type and pair of processors in list of messages
+ if(myrank == 0) write(IOUT,*) imsg_type,iproc_sender(imsg),iproc_receiver(imsg)
+
+! loop on sender/receiver (1=sender 2=receiver)
+ do imode_comm=1,2
+
+ if(imode_comm == 1) then
+ iproc = iproc_sender(imsg)
+ iedge = iproc_edge_send
+
+ else if(imode_comm == 2) then
+ iproc = iproc_receiver(imsg)
+ iedge = iproc_edge_receive
+
+ else
+ call exit_MPI(myrank,'incorrect communication mode')
+ endif
+
+! only do this if current processor is the right one for MPI version
+ if(iproc == myrank) then
+
+! determine chunk number and local slice coordinates using addressing
+ ichunk = ichunk_slice(iproc)
+ iproc_xi = iproc_xi_slice(iproc)
+ iproc_eta = iproc_eta_slice(iproc)
+
+! problem if not on edges
+ if(iproc_xi /= 0 .and. iproc_xi /= NPROC_XI-1 .and. &
+ iproc_eta /= 0 .and. iproc_eta /= NPROC_ETA-1) call exit_MPI(myrank,'slice not on any edge')
+
+ nglob=nglob_ori
+! check that iboolmax=nglob
+
+! end of section done only if right processor for MPI
+ endif
+
+! end of loop on sender/receiver
+ enddo
+
+! end of loops on all the messages
+ enddo
+ enddo
+ enddo
+
+ if(myrank == 0) close(IOUT)
+
+! check that total number of messages is correct
+ if(imsg /= NUMMSGS_FACES) call exit_MPI(myrank,'incorrect total number of messages')
+
+!
+!---- check that number of points detected is the same for sender and receiver
+!
+
+! synchronize all the processes to make sure all the buffers are ready
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+!!!!!!!!!! DK DK for merged version: beginning of "corner" section here
+
+!
+!---- generate the 8 message patterns sharing a corner of valence 3
+!
+
+! to avoid problem at compile time, use bigger array with fixed dimension
+ addressing_big(:,:,:) = 0
+ addressing_big(1:NCHUNKS,:,:) = addressing(1:NCHUNKS,:,:)
+
+ ichunk = 1
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AB,0,NPROC_ETA-1)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_AC,NPROC_XI-1,NPROC_ETA-1)
+! this line is ok even for NCHUNKS = 2
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_BC,NPROC_XI-1,0)
+
+ itypecorner(1,ichunk) = ILOWERUPPER
+ itypecorner(2,ichunk) = IUPPERUPPER
+ itypecorner(3,ichunk) = IUPPERLOWER
+
+!! DK DK UGLY in the future, should also assemble second corner when NCHUNKS = 2
+!! DK DK UGLY for now we only assemble one corner for simplicity
+!! DK DK UGLY formally this is incorrect and should be changed in the future
+!! DK DK UGLY in practice this trick works fine
+
+! this only if more than 3 chunks
+ if(NCHUNKS > 3) then
+
+ ichunk = 2
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AB,NPROC_XI-1,0)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_AC_ANTIPODE,0,0)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_BC_ANTIPODE,NPROC_XI-1,0)
+
+ itypecorner(1,ichunk) = IUPPERLOWER
+ itypecorner(2,ichunk) = ILOWERLOWER
+ itypecorner(3,ichunk) = IUPPERLOWER
+
+ ichunk = 3
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AB,0,0)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_AC,NPROC_XI-1,0)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_BC_ANTIPODE,NPROC_XI-1,NPROC_ETA-1)
+
+ itypecorner(1,ichunk) = ILOWERLOWER
+ itypecorner(2,ichunk) = IUPPERLOWER
+ itypecorner(3,ichunk) = IUPPERUPPER
+
+ ichunk = 4
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AB,NPROC_XI-1,NPROC_ETA-1)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_BC,NPROC_XI-1,NPROC_ETA-1)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_AC_ANTIPODE,0,NPROC_ETA-1)
+
+ itypecorner(1,ichunk) = IUPPERUPPER
+ itypecorner(2,ichunk) = IUPPERUPPER
+ itypecorner(3,ichunk) = ILOWERUPPER
+
+ ichunk = 5
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AC,0,0)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_BC_ANTIPODE,0,NPROC_ETA-1)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_AB_ANTIPODE,NPROC_XI-1,0)
+
+ itypecorner(1,ichunk) = ILOWERLOWER
+ itypecorner(2,ichunk) = ILOWERUPPER
+ itypecorner(3,ichunk) = IUPPERLOWER
+
+ ichunk = 6
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AC_ANTIPODE,NPROC_XI-1,0)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_BC_ANTIPODE,0,0)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_AB_ANTIPODE,0,0)
+
+ itypecorner(1,ichunk) = IUPPERLOWER
+ itypecorner(2,ichunk) = ILOWERLOWER
+ itypecorner(3,ichunk) = ILOWERLOWER
+
+ ichunk = 7
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_AC,0,NPROC_ETA-1)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_BC,0,0)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_AB_ANTIPODE,NPROC_XI-1,NPROC_ETA-1)
+
+ itypecorner(1,ichunk) = ILOWERUPPER
+ itypecorner(2,ichunk) = ILOWERLOWER
+ itypecorner(3,ichunk) = IUPPERUPPER
+
+ ichunk = 8
+ iprocscorners(1,ichunk) = addressing_big(CHUNK_BC,0,NPROC_ETA-1)
+ iprocscorners(2,ichunk) = addressing_big(CHUNK_AC_ANTIPODE,NPROC_XI-1,NPROC_ETA-1)
+ iprocscorners(3,ichunk) = addressing_big(CHUNK_AB_ANTIPODE,0,NPROC_ETA-1)
+
+ itypecorner(1,ichunk) = ILOWERUPPER
+ itypecorner(2,ichunk) = IUPPERUPPER
+ itypecorner(3,ichunk) = ILOWERUPPER
+
+ endif
+
+! file to store the list of processors for each message for corners
+ if(myrank == 0) open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_corners.txt',status='unknown')
+
+! loop over all the messages to create the addressing
+ do imsg = 1,NCORNERSCHUNKS
+
+ if(myrank == 0) write(IMAIN,*) 'Generating message ',imsg,' for corners out of ',NCORNERSCHUNKS
+
+! save triplet of processors in list of messages
+ if(myrank == 0) write(IOUT,*) iprocscorners(1,imsg),iprocscorners(2,imsg),iprocscorners(3,imsg)
+
+! loop on the three processors of a given corner
+ do imember_corner = 1,3
+
+! only do this if current processor is the right one for MPI version
+! this line is ok even for NCHUNKS = 2
+ if(iprocscorners(imember_corner,imsg) == myrank) then
+
+! pick the correct 1D buffer
+! this scheme works fine even if NPROC_XI = NPROC_ETA = 1
+ if(itypecorner(imember_corner,imsg) == ILOWERLOWER) then
+!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt'
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,1)
+ else if(itypecorner(imember_corner,imsg) == ILOWERUPPER) then
+!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt'
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,4)
+ else if(itypecorner(imember_corner,imsg) == IUPPERLOWER) then
+!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt'
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,2)
+ else if(itypecorner(imember_corner,imsg) == IUPPERUPPER) then
+!! DK DK suppressed for merged filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt'
+ NGLOB1D_RADIAL_my_corner = NGLOB1D_RADIAL_CORNER(iregion_code,3)
+ else
+ call exit_MPI(myrank,'incorrect corner coordinates')
+ endif
+
+! end of section done only if right processor for MPI
+ endif
+
+ enddo
+
+ enddo
+
+ if(myrank == 0) close(IOUT)
+
+ end subroutine create_list_files_chunks
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_name_database.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_name_database.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_name_database.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/create_regions_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_regions_mesh.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/create_regions_mesh.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,2644 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine create_regions_mesh(iregion_code,ibool,idoubling, &
+ xstore,ystore,zstore,rmins,rmaxs,iproc_xi,iproc_eta,ichunk,nspec,nspec_tiso, &
+ volume_local,area_local_bottom,area_local_top, &
+ nspl,rspl,espl,espl2,nglob_theor,npointot, &
+ NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
+ NGLOB2DMAX_XY, &
+ myrank,LOCAL_PATH,OCEANS,ibathy_topo,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,&
+ ATTENUATION,ATTENUATION_3D, &
+ NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ ner,ratio_sampling_array,doubling_index,r_bottom,r_top,this_region_has_a_doubling,CASE_3D, &
+ AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V, AM_S, AS_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ipass,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,&
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,offset_proc_xi,offset_proc_eta, &
+ iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta,NGLOB1D_RADIAL_MAX, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
+ jacobian2D_xmin,jacobian2D_xmax, &
+ jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom,jacobian2D_top, &
+ normal_xmin,normal_xmax,normal_ymin, &
+ normal_ymax,normal_bottom,normal_top, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,rmass,xelm_store,yelm_store,zelm_store, &
+ npoin2D_xi,npoin2D_eta,perm,invperm)
+
+! create the different regions of the mesh
+
+ implicit none
+
+ include "mpif.h"
+ include "constants.h"
+
+!! DK DK for the merged version
+! include values created by the mesher
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+!! DK DK added this for merged version
+ integer :: npoin2D_xi,npoin2D_eta
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(nglob_theor) :: rmass
+
+ real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl
+
+! the jacobian
+ real(kind=CUSTOM_REAL) jacobianl
+
+!! DK DK changed this for merged version: made it local
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+
+!! DK DK added this for merged version
+ logical :: add_contrib_this_element
+
+!! DK DK for merged version
+ integer :: NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
+
+!! DK DK added this for merged version
+ double precision, dimension(NGLOB1D_RADIAL_MAX) :: &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta
+
+ integer :: NGLOB1D_RADIAL_MAX
+ integer ibool1D_leftxi_lefteta(NGLOB1D_RADIAL_MAX)
+ integer ibool1D_rightxi_lefteta(NGLOB1D_RADIAL_MAX)
+ integer ibool1D_leftxi_righteta(NGLOB1D_RADIAL_MAX)
+ integer ibool1D_rightxi_righteta(NGLOB1D_RADIAL_MAX)
+
+! this to cut the doubling brick
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer :: step_mult,offset_proc_xi,offset_proc_eta
+ integer :: case_xi,case_eta,subblock_num
+
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+
+ integer :: ignod,ner_without_doubling,ispec_superbrick,ilayer,ilayer_loop,ix_elem,iy_elem,iz_elem, &
+ ifirst_region,ilast_region,ratio_divide_central_cube
+ integer, dimension(:), allocatable :: perm_layer
+
+! mesh doubling superbrick
+ integer, dimension(NGNOD_EIGHT_CORNERS,NSPEC_DOUBLING_SUPERBRICK) :: ibool_superbrick
+
+ double precision, dimension(NGLOB_DOUBLING_SUPERBRICK) :: x_superbrick,y_superbrick,z_superbrick
+
+! aniso_mantle_model_variables
+ type aniso_mantle_model_variables
+ sequence
+ double precision beta(14,34,37,73)
+ double precision pro(47)
+ integer npar1
+ end type aniso_mantle_model_variables
+
+ type (aniso_mantle_model_variables) AMM_V
+! aniso_mantle_model_variables
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+! model_1066a_variables
+ type model_1066a_variables
+ sequence
+ double precision, dimension(NR_1066A) :: radius_1066a
+ double precision, dimension(NR_1066A) :: density_1066a
+ double precision, dimension(NR_1066A) :: vp_1066a
+ double precision, dimension(NR_1066A) :: vs_1066a
+ double precision, dimension(NR_1066A) :: Qkappa_1066a
+ double precision, dimension(NR_1066A) :: Qmu_1066a
+ end type model_1066a_variables
+
+ type (model_1066a_variables) M1066a_V
+! model_1066a_variables
+
+! model_ak135_variables
+ type model_ak135_variables
+ sequence
+ double precision, dimension(NR_AK135) :: radius_ak135
+ double precision, dimension(NR_AK135) :: density_ak135
+ double precision, dimension(NR_AK135) :: vp_ak135
+ double precision, dimension(NR_AK135) :: vs_ak135
+ double precision, dimension(NR_AK135) :: Qkappa_ak135
+ double precision, dimension(NR_AK135) :: Qmu_ak135
+ end type model_ak135_variables
+
+ type (model_ak135_variables) Mak135_V
+! model_ak135_variables
+
+! model_ref_variables
+ type model_ref_variables
+ sequence
+ double precision, dimension(NR_REF) :: radius_ref
+ double precision, dimension(NR_REF) :: density_ref
+ double precision, dimension(NR_REF) :: vpv_ref
+ double precision, dimension(NR_REF) :: vph_ref
+ double precision, dimension(NR_REF) :: vsv_ref
+ double precision, dimension(NR_REF) :: vsh_ref
+ double precision, dimension(NR_REF) :: eta_ref
+ double precision, dimension(NR_REF) :: Qkappa_ref
+ double precision, dimension(NR_REF) :: Qmu_ref
+ end type model_ref_variables
+
+ type (model_ref_variables) Mref_V
+! model_ref_variables
+
+! sea1d_model_variables
+ type sea1d_model_variables
+ sequence
+ double precision, dimension(NR_SEA1D) :: radius_sea1d
+ double precision, dimension(NR_SEA1D) :: density_sea1d
+ double precision, dimension(NR_SEA1D) :: vp_sea1d
+ double precision, dimension(NR_SEA1D) :: vs_sea1d
+ double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
+ double precision, dimension(NR_SEA1D) :: Qmu_sea1d
+ end type sea1d_model_variables
+
+ type (sea1d_model_variables) SEA1DM_V
+! sea1d_model_variables
+
+! three_d_mantle_model_variables
+ type three_d_mantle_model_variables
+ sequence
+ double precision dvs_a(0:NK,0:NS,0:NS)
+ double precision dvs_b(0:NK,0:NS,0:NS)
+ double precision dvp_a(0:NK,0:NS,0:NS)
+ double precision dvp_b(0:NK,0:NS,0:NS)
+ double precision spknt(NK+1)
+ double precision qq0(NK+1,NK+1)
+ double precision qq(3,NK+1,NK+1)
+ end type three_d_mantle_model_variables
+
+ type (three_d_mantle_model_variables) D3MM_V
+! three_d_mantle_model_variables
+
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+! sea99_s_model_variables
+ type sea99_s_model_variables
+ sequence
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ end type sea99_s_model_variables
+
+ type (sea99_s_model_variables) SEA99M_V
+! sea99_s_model_variables
+
+! crustal_model_variables
+ type crustal_model_variables
+ sequence
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
+ character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+ character(len=2) code(NKEYS_CRUST)
+ end type crustal_model_variables
+
+ type (crustal_model_variables) CM_V
+! crustal_model_variables
+
+! attenuation_model_storage
+ type attenuation_model_storage
+ sequence
+ integer Q_resolution
+ integer Q_max
+ double precision, dimension(:,:), pointer :: tau_e_storage
+ double precision, dimension(:), pointer :: Qmu_storage
+ end type attenuation_model_storage
+
+ type (attenuation_model_storage) AM_S
+! attenuation_model_storage
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+! correct number of spectral elements in each block depending on chunk type
+ integer nspec,nspec_tiso,nspec_stacey
+
+ integer NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NCHUNKS,REFERENCE_1D_MODEL,THREE_D_MODEL
+
+ integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP
+
+ integer NPROC_XI,NPROC_ETA
+
+ integer npointot
+
+ logical ELLIPTICITY,TOPOGRAPHY
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST,OCEANS
+
+ logical ATTENUATION,ATTENUATION_3D, &
+ INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS,HONOR_1D_SPHERICAL_MOHO
+
+ double precision R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO, &
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
+
+ character(len=150) LOCAL_PATH,errmsg
+
+! use integer array to store values
+ integer ibathy_topo(NX_BATHY,NY_BATHY)
+
+! arrays with the mesh in double precision
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! meshing parameters
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+! to define the central cube in the inner core
+ integer nx_central_cube,ny_central_cube,nz_central_cube
+ double precision radius_cube
+ double precision :: xgrid_central_cube,ygrid_central_cube,zgrid_central_cube
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+! auxiliary variables to generate the mesh
+ integer ix,iy,iz
+
+! topology of the elements
+ integer, dimension(NGNOD) :: iaddx,iaddy,iaddz
+
+! code for the four regions of the mesh
+ integer iregion_code
+
+! Gauss-Lobatto-Legendre points and weights of integration
+ double precision, dimension(:), allocatable :: xigll,yigll,zigll,wxgll,wygll,wzgll
+
+! 3D shape functions and their derivatives
+ double precision, dimension(:,:,:,:), allocatable :: shape3D
+ double precision, dimension(:,:,:,:,:), allocatable :: dershape3D
+
+! 2D shape functions and their derivatives
+ double precision, dimension(:,:,:), allocatable :: shape2D_x,shape2D_y,shape2D_bottom,shape2D_top
+ double precision, dimension(:,:,:,:), allocatable :: dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top
+
+! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+!! DK DK added this for merged version
+!! DK DK stored in single precision for merged version, check if it precise enough (probably yes)
+ real(kind=CUSTOM_REAL), dimension(NGNOD,nspec) :: xelm_store,yelm_store,zelm_store
+
+ double precision, dimension(NGNOD) :: xelm,yelm,zelm,offset_x,offset_y,offset_z
+
+ integer idoubling(nspec)
+
+! parameters needed to store the radii of the grid points in the spherically symmetric Earth
+ double precision rmin,rmax,r1,r2,r3,r4,r5,r6,r7,r8
+
+! for model density and anisotropy
+ integer nspec_ani
+!! DK DK changed this for the merged version
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: rhostore_local,kappavstore_local
+!! DK DK added this for merged version
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: kappavstore,kappahstore,muvstore,muhstore,eta_anisostore
+
+! the 21 coefficients for an anisotropic medium in reduced notation
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store
+
+! boundary locator
+ logical, dimension(:,:), allocatable :: iboun
+
+! proc numbers for MPI
+ integer myrank
+
+! check area and volume of the final mesh
+ double precision weight
+ double precision area_local_bottom,area_local_top
+ double precision volume_local
+
+! variables for creating array ibool (some arrays also used for AVS or DX files)
+ integer, dimension(:), allocatable :: locval
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: xp,yp,zp
+
+ integer nglob,nglob_theor,ieoff,ilocnum,ier,errorcode
+
+! mass matrix and bathymetry for ocean load
+ integer ix_oceans,iy_oceans,iz_oceans,ispec_oceans
+ integer ispec2D_top_crust
+ integer nglob_oceans
+ double precision xval,yval,zval,rval,thetaval,phival
+ double precision lat,lon,colat
+ double precision elevation,height_oceans
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_ocean_load
+
+! mask to sort ibool
+ integer, dimension(:), allocatable :: mask_ibool
+ integer, dimension(:,:,:,:), allocatable :: copy_ibool_ori
+ integer :: inumber
+
+! boundary parameters locator
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX) :: ibelm_xmin,ibelm_xmax
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX) :: ibelm_ymin,ibelm_ymax
+ integer, dimension(NSPEC2D_BOTTOM) :: ibelm_bottom
+ integer, dimension(NSPEC2D_TOP) :: ibelm_top
+
+! MPI cut-planes parameters along xi and along eta
+ logical, dimension(:,:), allocatable :: iMPIcut_xi,iMPIcut_eta
+
+! Stacey, indices for Clayton-Engquist absorbing conditions
+ integer, dimension(:,:), allocatable :: nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_vp,rho_vs
+
+! name of the database file
+ character(len=150) prname
+
+! number of elements on the boundaries
+ integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
+
+ integer i,j,k,ia,ispec,iglobnum
+ integer iproc_xi,iproc_eta,ichunk
+
+ double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
+
+! rotation matrix from Euler angles
+ double precision, dimension(NDIM,NDIM) :: rotation_matrix
+
+! attenuation
+ double precision, dimension(:,:,:,:), allocatable :: Qmu_store
+ double precision, dimension(:,:,:,:,:), allocatable :: tau_e_store
+ double precision, dimension(N_SLS) :: tau_s
+ double precision T_c_source
+
+! **************
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ logical, dimension(NSPEC_DOUBLING_SUPERBRICK,6) :: iboun_sb
+ logical :: USE_ONE_LAYER_SB,CASE_3D
+ integer :: nspec_sb
+
+ integer NUMBER_OF_MESH_LAYERS,layer_shift,cpt,first_layer_aniso,last_layer_aniso,FIRST_ELT_NON_ANISO
+ double precision, dimension(:,:), allocatable :: stretch_tab
+
+ integer :: NGLOB2DMAX_XY
+
+ integer :: nb_layer_above_aniso,FIRST_ELT_ABOVE_ANISO
+
+ integer, parameter :: maxker=200
+ integer, parameter :: maxl=72
+ integer, parameter :: maxcoe=2000
+ integer, parameter :: maxver=1000
+ integer, parameter :: maxhpa=2
+
+ integer numker
+ integer numhpa,numcof
+ integer ihpa,lmax,nylm
+ integer lmxhpa(maxhpa)
+ integer itypehpa(maxhpa)
+ integer ihpakern(maxker)
+ integer numcoe(maxhpa)
+ integer ivarkern(maxker)
+
+ integer nconpt(maxhpa),iver
+ integer iconpt(maxver,maxhpa)
+ real(kind=4) conpt(maxver,maxhpa)
+
+ real(kind=4) xlaspl(maxcoe,maxhpa)
+ real(kind=4) xlospl(maxcoe,maxhpa)
+ real(kind=4) radspl(maxcoe,maxhpa)
+ real(kind=4) coe(maxcoe,maxker)
+ real(kind=4) vercof(maxker)
+ real(kind=4) vercofd(maxker)
+
+ real(kind=4) ylmcof((maxl+1)**2,maxhpa)
+ real(kind=4) wk1(maxl+1)
+ real(kind=4) wk2(maxl+1)
+ real(kind=4) wk3(maxl+1)
+
+ character(len=80) kerstr
+ character(len=40) varstr(maxker)
+
+! now perform two passes in this part to be able to save memory
+ integer :: ipass
+
+! Boundary Mesh
+ integer nex_eta_moho
+ integer, dimension(:), allocatable :: ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot, &
+ ibelm_670_top,ibelm_670_bot
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_moho,normal_400,normal_670
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_moho,jacobian2D_400,jacobian2D_670
+ integer ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot
+ double precision r_moho,r_400,r_670
+ logical :: is_superbrick
+
+! added for Cuthill McKee permutation
+! integer, dimension(:), allocatable :: perm,perm_tmp,temp_array_1D_int
+!! DK DK added this for merged version, as a quick patch
+ integer, dimension(nspec) :: perm,invperm
+ integer, dimension(:), allocatable :: perm_tmp,temp_array_1D_int
+ logical, dimension(:,:), allocatable :: temp_array_2D_log
+ integer, dimension(:,:,:,:), allocatable :: temp_array_int
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: temp_array_real
+ double precision, dimension(:,:,:,:), allocatable :: temp_array_dble
+ double precision, dimension(:,:,:,:,:), allocatable :: temp_array_dble_5dim
+!! DK DK added this for merged version
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: temp_array_xelm_yelm_zelm
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: temp_rmass
+
+! the height at which the central cube is cut
+ integer :: nz_inf_limit
+
+!! DK DK added this for the merged version
+! 2-D jacobians and normals
+ real(kind=CUSTOM_REAL) :: jacobian2D_xmin(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ real(kind=CUSTOM_REAL) :: jacobian2D_xmax(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ real(kind=CUSTOM_REAL) :: jacobian2D_ymin(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ real(kind=CUSTOM_REAL) :: jacobian2D_ymax(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ real(kind=CUSTOM_REAL) :: jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM)
+ real(kind=CUSTOM_REAL) :: jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP)
+
+ real(kind=CUSTOM_REAL) :: normal_xmin(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ real(kind=CUSTOM_REAL) :: normal_xmax(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ real(kind=CUSTOM_REAL) :: normal_ymin(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ real(kind=CUSTOM_REAL) :: normal_ymax(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ real(kind=CUSTOM_REAL) :: normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM)
+ real(kind=CUSTOM_REAL) :: normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP)
+
+! create the name for the database of the current slide and region
+ call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
+
+! Attenuation
+ if(ATTENUATION .and. ATTENUATION_3D) then
+ T_c_source = AM_V%QT_c_source
+ tau_s(:) = AM_V%Qtau_s(:)
+ allocate(Qmu_store(NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(tau_e_store(N_SLS,NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ else
+ allocate(Qmu_store(1,1,1,1),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(tau_e_store(N_SLS,1,1,1,1),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ Qmu_store(1,1,1,1) = 0.0d0
+ tau_e_store(:,1,1,1,1) = 0.0d0
+ endif
+
+! Gauss-Lobatto-Legendre points of integration
+ allocate(xigll(NGLLX),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(yigll(NGLLY),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(zigll(NGLLZ),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+! Gauss-Lobatto-Legendre weights of integration
+ allocate(wxgll(NGLLX),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(wygll(NGLLY),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(wzgll(NGLLZ),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+! 3D shape functions and their derivatives
+ allocate(shape3D(NGNOD,NGLLX,NGLLY,NGLLZ),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+! 2D shape functions and their derivatives
+ allocate(shape2D_x(NGNOD2D,NGLLY,NGLLZ),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(shape2D_y(NGNOD2D,NGLLX,NGLLZ),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(shape2D_bottom(NGNOD2D,NGLLX,NGLLY),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(shape2D_top(NGNOD2D,NGLLX,NGLLY),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+! array with model density
+!! DK DK changed this for the merged version
+ allocate(rhostore_local(NGLLX,NGLLY,NGLLZ),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+!! DK DK added this for the merged version
+ allocate(kappavstore_local(NGLLX,NGLLY,NGLLZ),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+! Stacey
+ if(NCHUNKS /= 6) then
+ nspec_stacey = nspec
+ else
+ nspec_stacey = 1
+ endif
+ allocate(rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ nspec_ani = 1
+ if((ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) .or. &
+ (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE)) nspec_ani = nspec
+
+ allocate(c11store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c12store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c13store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c14store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c15store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c16store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c22store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c23store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c24store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c25store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c26store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c33store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c34store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c35store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c36store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c44store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c45store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c46store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c55store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c56store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(c66store(NGLLX,NGLLY,NGLLZ,nspec_ani),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+! boundary locator
+ allocate(iboun(6,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+! Stacey
+ allocate(nimin(2,NSPEC2DMAX_YMIN_YMAX),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(nimax(2,NSPEC2DMAX_YMIN_YMAX),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(njmin(2,NSPEC2DMAX_XMIN_XMAX),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(njmax(2,NSPEC2DMAX_XMIN_XMAX),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+! MPI cut-planes parameters along xi and along eta
+ allocate(iMPIcut_xi(2,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(iMPIcut_eta(2,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+! set up coordinates of the Gauss-Lobatto-Legendre points
+ call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
+
+! if number of points is odd, the middle abscissa is exactly zero
+ if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO
+ if(mod(NGLLY,2) /= 0) yigll((NGLLY-1)/2+1) = ZERO
+ if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO
+
+! get the 3-D shape functions
+ call get_shape3D(myrank,shape3D,dershape3D,xigll,yigll,zigll)
+
+! get the 2-D shape functions
+ call get_shape2D(myrank,shape2D_x,dershape2D_x,yigll,zigll,NGLLY,NGLLZ)
+ call get_shape2D(myrank,shape2D_y,dershape2D_y,xigll,zigll,NGLLX,NGLLZ)
+ call get_shape2D(myrank,shape2D_bottom,dershape2D_bottom,xigll,yigll,NGLLX,NGLLY)
+ call get_shape2D(myrank,shape2D_top,dershape2D_top,xigll,yigll,NGLLX,NGLLY)
+
+! define models 1066a and ak135 and ref
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
+ call define_model_1066a(CRUSTAL, M1066a_V)
+ elseif(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
+ call define_model_ak135(CRUSTAL, Mak135_V)
+ elseif(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
+ call define_model_ref(Mref_V)
+ elseif(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
+ call define_model_sea1d(CRUSTAL, SEA1DM_V)
+ endif
+
+!------------------------------------------------------------------------
+
+! create the shape of the corner nodes of a regular mesh element
+ call hex_nodes(iaddx,iaddy,iaddz)
+
+! reference element has size one here, not two
+ iaddx(:) = iaddx(:) / 2
+ iaddy(:) = iaddy(:) / 2
+ iaddz(:) = iaddz(:) / 2
+
+ if (ONE_CRUST) then
+ NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS - 1
+ layer_shift = 0
+ else
+ NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS
+ layer_shift = 1
+ endif
+
+ if (.not. ADD_4TH_DOUBLING) NUMBER_OF_MESH_LAYERS = NUMBER_OF_MESH_LAYERS - 1
+
+! define the first and last layers that define this region
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+ ifirst_region = 1
+ ilast_region = 10 + layer_shift
+
+ else if(iregion_code == IREGION_OUTER_CORE) then
+ ifirst_region = 11 + layer_shift
+ ilast_region = NUMBER_OF_MESH_LAYERS - 1
+
+ else if(iregion_code == IREGION_INNER_CORE) then
+ ifirst_region = NUMBER_OF_MESH_LAYERS
+ ilast_region = NUMBER_OF_MESH_LAYERS
+
+ else
+ call exit_MPI(myrank,'incorrect region code detected')
+
+ endif
+
+! to consider anisotropic elements first and to build the mesh from the bottom to the top of the region
+ if (ONE_CRUST) then
+ first_layer_aniso=2
+ last_layer_aniso=3
+ nb_layer_above_aniso = 1
+ else
+ first_layer_aniso=3
+ last_layer_aniso=4
+ nb_layer_above_aniso = 2
+ endif
+ allocate (perm_layer(ifirst_region:ilast_region),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ perm_layer = (/ (i, i=ilast_region,ifirst_region,-1) /)
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+ cpt=3
+ perm_layer(1)=first_layer_aniso
+ perm_layer(2)=last_layer_aniso
+ do i = ilast_region,ifirst_region,-1
+ if (i/=first_layer_aniso .and. i/=last_layer_aniso) then
+ perm_layer(cpt) = i
+ cpt=cpt+1
+ endif
+ enddo
+ endif
+
+! initialize mesh arrays
+!! DK DK merged version: we exclude the outer core because the doubling array is useless there and therefore not allocated
+ if(iregion_code /= IREGION_OUTER_CORE) idoubling(:) = 0
+
+ xstore(:,:,:,:) = 0.d0
+ ystore(:,:,:,:) = 0.d0
+ zstore(:,:,:,:) = 0.d0
+
+ if(ipass == 1) ibool(:,:,:,:) = 0
+
+! initialize boundary arrays
+ iboun(:,:) = .false.
+ iMPIcut_xi(:,:) = .false.
+ iMPIcut_eta(:,:) = .false.
+
+!! DK DK added this for merged version
+! creating mass matrix in this slice (will be fully assembled in the solver)
+ if(ipass == 2) rmass(:) = 0._CUSTOM_REAL
+
+ if (CASE_3D .and. iregion_code == IREGION_CRUST_MANTLE .and. .not. SUPPRESS_CRUSTAL_MESH) then
+ allocate(stretch_tab(2,ner(1)),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ call stretching_function(r_top(1),r_bottom(1),ner(1),stretch_tab)
+ endif
+
+! boundary mesh
+ if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
+ allocate(ibelm_moho_top(NSPEC2D_MOHO),ibelm_moho_bot(NSPEC2D_MOHO),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(ibelm_400_top(NSPEC2D_400),ibelm_400_bot(NSPEC2D_400),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(ibelm_670_top(NSPEC2D_670),ibelm_670_bot(NSPEC2D_670),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(normal_moho(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(normal_400(NDIM,NGLLX,NGLLY,NSPEC2D_400),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(normal_670(NDIM,NGLLX,NGLLY,NSPEC2D_670),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(jacobian2D_moho(NGLLX,NGLLY,NSPEC2D_MOHO),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(jacobian2D_400(NGLLX,NGLLY,NSPEC2D_400),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(jacobian2D_670(NGLLX,NGLLY,NSPEC2D_670),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ ispec2D_moho_top = 0; ispec2D_moho_bot = 0
+ ispec2D_400_top = 0; ispec2D_400_bot = 0
+ ispec2D_670_top = 0; ispec2D_670_bot = 0
+
+ nex_eta_moho = NEX_PER_PROC_ETA
+
+ r_moho = RMOHO/R_EARTH; r_400 = R400 / R_EARTH; r_670 = R670/R_EARTH
+
+ endif
+
+! generate and count all the elements in this region of the mesh
+ ispec = 0
+
+! loop on all the layers in this region of the mesh
+ do ilayer_loop = ifirst_region,ilast_region
+
+ ilayer = perm_layer(ilayer_loop)
+
+! determine the radii that define the shell
+ rmin = rmins(ilayer)
+ rmax = rmaxs(ilayer)
+
+ if(iregion_code == IREGION_CRUST_MANTLE .and. ilayer_loop==3) then
+ FIRST_ELT_NON_ANISO = ispec+1
+ endif
+ if(iregion_code == IREGION_CRUST_MANTLE .and. ilayer_loop==(ilast_region-nb_layer_above_aniso+1)) then
+ FIRST_ELT_ABOVE_ANISO = ispec+1
+ endif
+
+ ner_without_doubling = ner(ilayer)
+
+! if there is a doubling at the top of this region, we implement it in the last two layers of elements
+! and therefore we suppress two layers of regular elements here
+ USE_ONE_LAYER_SB = .false.
+ if(this_region_has_a_doubling(ilayer)) then
+ if (ner(ilayer) == 1) then
+ ner_without_doubling = ner_without_doubling - 1
+ USE_ONE_LAYER_SB = .true.
+ else
+ ner_without_doubling = ner_without_doubling - 2
+ USE_ONE_LAYER_SB = .false.
+ endif
+ endif
+
+!----
+!---- regular mesh elements
+!----
+
+! loop on all the elements
+ do ix_elem = 1,NEX_PER_PROC_XI,ratio_sampling_array(ilayer)
+ do iy_elem = 1,NEX_PER_PROC_ETA,ratio_sampling_array(ilayer)
+ do iz_elem = 1,ner_without_doubling
+! loop on all the corner nodes of this element
+ do ignod = 1,NGNOD_EIGHT_CORNERS
+! define topological coordinates of this mesh point
+ offset_x(ignod) = (ix_elem - 1) + iaddx(ignod) * ratio_sampling_array(ilayer)
+ offset_y(ignod) = (iy_elem - 1) + iaddy(ignod) * ratio_sampling_array(ilayer)
+ if (ilayer == 1 .and. CASE_3D) then
+ offset_z(ignod) = iaddz(ignod)
+ else
+ offset_z(ignod) = (iz_elem - 1) + iaddz(ignod)
+ endif
+ enddo
+ call add_missing_nodes(offset_x,offset_y,offset_z)
+
+! compute the actual position of all the grid points of that element
+ if (ilayer == 1 .and. CASE_3D .and. .not. SUPPRESS_CRUSTAL_MESH) then
+! crustal elements are stretched to be thinner in the upper crust than in lower crust in the 3D case
+! max ratio between size of upper crust elements and lower crust elements is given by the param MAX_RATIO_STRETCHING
+! to avoid stretching, set MAX_RATIO_STRETCHING = 1.0d in constants.h
+ call compute_coord_main_mesh(offset_x,offset_y,offset_z,xelm,yelm,zelm, &
+ ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
+ NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ stretch_tab(1,ner_without_doubling-iz_elem+1),&
+ stretch_tab(2,ner_without_doubling-iz_elem+1),1,ilayer,ichunk,rotation_matrix, &
+ NCHUNKS,INCLUDE_CENTRAL_CUBE,NUMBER_OF_MESH_LAYERS)
+ else
+ call compute_coord_main_mesh(offset_x,offset_y,offset_z,xelm,yelm,zelm, &
+ ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
+ NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ r_top(ilayer),r_bottom(ilayer),ner(ilayer),ilayer,ichunk,rotation_matrix, &
+ NCHUNKS,INCLUDE_CENTRAL_CUBE,NUMBER_OF_MESH_LAYERS)
+ endif
+! add one spectral element to the list
+ ispec = ispec + 1
+ if(ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in mesh creation')
+
+! new get_flag_boundaries
+! xmin & xmax
+ if (ix_elem == 1) then
+ iMPIcut_xi(1,ispec) = .true.
+ if (iproc_xi == 0) iboun(1,ispec)= .true.
+ endif
+ if (ix_elem == (NEX_PER_PROC_XI-ratio_sampling_array(ilayer)+1)) then
+ iMPIcut_xi(2,ispec) = .true.
+ if (iproc_xi == NPROC_XI-1) iboun(2,ispec)= .true.
+ endif
+! ymin & ymax
+ if (iy_elem == 1) then
+ iMPIcut_eta(1,ispec) = .true.
+ if (iproc_eta == 0) iboun(3,ispec)= .true.
+ endif
+ if (iy_elem == (NEX_PER_PROC_ETA-ratio_sampling_array(ilayer)+1)) then
+ iMPIcut_eta(2,ispec) = .true.
+ if (iproc_eta == NPROC_ETA-1) iboun(4,ispec)= .true.
+ endif
+! zmin & zmax
+ if (iz_elem == ner(ilayer) .and. ilayer == ifirst_region) then
+ iboun(6,ispec)= .true.
+ endif
+ if (iz_elem == 1 .and. ilayer == ilast_region) then ! defined if no doubling in this layer
+ iboun(5,ispec)= .true.
+ endif
+
+! define the doubling flag of this element
+ if(iregion_code /= IREGION_OUTER_CORE) idoubling(ispec) = doubling_index(ilayer)
+
+! save the radii of the nodes before modified through compute_element_properties()
+ if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
+ r1=sqrt(xelm(1)**2+yelm(1)**2+zelm(1)**2)
+ r2=sqrt(xelm(2)**2+yelm(2)**2+zelm(2)**2)
+ r3=sqrt(xelm(3)**2+yelm(3)**2+zelm(3)**2)
+ r4=sqrt(xelm(4)**2+yelm(4)**2+zelm(4)**2)
+ r5=sqrt(xelm(5)**2+yelm(5)**2+zelm(5)**2)
+ r6=sqrt(xelm(6)**2+yelm(6)**2+zelm(6)**2)
+ r7=sqrt(xelm(7)**2+yelm(7)**2+zelm(7)**2)
+ r8=sqrt(xelm(8)**2+yelm(8)**2+zelm(8)**2)
+ endif
+
+! compute several rheological and geometrical properties for this spectral element
+ call compute_element_properties(ispec,iregion_code,idoubling, &
+ xstore,ystore,zstore,nspec, &
+ nspl,rspl,espl,espl2,ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ myrank,ibathy_topo,ATTENUATION,ATTENUATION_3D, &
+ ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xelm,yelm,zelm,shape3D,dershape3D,rmin,rmax,rhostore_local,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+!! DK DK added this for the merged version
+ kappavstore_local, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ nspec_ani,nspec_stacey,Qmu_store,tau_e_store,tau_s,T_c_source,rho_vp,rho_vs,&
+ AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V,AM_S,AS_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+
+!! DK DK added this for merged version
+ include "comp_mass_matrix_one_element.f90"
+ include "store_xelm_yelm_zelm.f90"
+
+! boundary mesh
+ if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
+ is_superbrick=.false.
+ ispec_superbrick=0
+ call get_jacobian_discontinuities(myrank,ispec,ix_elem,iy_elem,rmin,rmax,r1,r2,r3,r4,r5,r6,r7,r8, &
+ xstore(:,:,:,ispec),ystore(:,:,:,ispec),zstore(:,:,:,ispec),dershape2D_bottom, &
+ ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot,ibelm_670_top,ibelm_670_bot, &
+ normal_moho,normal_400,normal_670,jacobian2D_moho,jacobian2D_400,jacobian2D_670, &
+ ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot, &
+ NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,r_moho,r_400,r_670, &
+ is_superbrick,USE_ONE_LAYER_SB,ispec_superbrick,nex_eta_moho,HONOR_1D_SPHERICAL_MOHO)
+ endif
+
+! end of loop on all the regular elements
+ enddo
+ enddo
+ enddo
+!----
+!---- mesh doubling elements
+!----
+! If there is a doubling at the top of this region, let us add these elements.
+! The superbrick implements a symmetric four-to-two doubling and therefore replaces
+! a basic regular block of 2 x 2 = 4 elements.
+! We have imposed that NEX be a multiple of 16 therefore we know that we can always create
+! these 2 x 2 blocks because NEX_PER_PROC_XI / ratio_sampling_array(ilayer) and
+! NEX_PER_PROC_ETA / ratio_sampling_array(ilayer) are always divisible by 2.
+ if(this_region_has_a_doubling(ilayer)) then
+ if (USE_ONE_LAYER_SB) then
+ call define_superbrick_one_layer(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb)
+ nspec_sb = NSPEC_SUPERBRICK_1L
+ iz_elem = ner(ilayer)
+ step_mult = 2
+ else
+ if(iregion_code==IREGION_OUTER_CORE .and. ilayer==ilast_region .and. (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA)) then
+ nspec_sb = NSPEC_DOUBLING_BASICBRICK
+ step_mult = 1
+ else
+ call define_superbrick(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb)
+ nspec_sb = NSPEC_DOUBLING_SUPERBRICK
+ step_mult = 2
+ endif
+! the doubling is implemented in the last two radial elements
+! therefore we start one element before the last one
+ iz_elem = ner(ilayer) - 1
+ endif
+
+! loop on all the elements in the 2 x 2 blocks
+ do ix_elem = 1,NEX_PER_PROC_XI,step_mult*ratio_sampling_array(ilayer)
+ do iy_elem = 1,NEX_PER_PROC_ETA,step_mult*ratio_sampling_array(ilayer)
+
+ if (step_mult == 1) then
+! for xi direction
+ if (.not. CUT_SUPERBRICK_XI) then
+ if (mod((ix_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))==0) then
+ case_xi = 1
+ else
+ case_xi = 2
+ endif
+ else
+ if (offset_proc_xi == 0) then
+ if (mod((ix_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))==0) then
+ case_xi = 1
+ else
+ case_xi = 2
+ endif
+ else
+ if (mod((ix_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))/=0) then
+ case_xi = 1
+ else
+ case_xi = 2
+ endif
+ endif
+ endif
+! for eta direction
+ if (.not. CUT_SUPERBRICK_ETA) then
+ if (mod((iy_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))==0) then
+ case_eta = 1
+ else
+ case_eta = 2
+ endif
+ else
+ if (offset_proc_eta == 0) then
+ if (mod((iy_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))==0) then
+ case_eta = 1
+ else
+ case_eta = 2
+ endif
+ else
+ if (mod((iy_elem-1),(2*step_mult*ratio_sampling_array(ilayer)))/=0) then
+ case_eta = 1
+ else
+ case_eta = 2
+ endif
+ endif
+ endif
+! determine the current sub-block
+ if (case_xi == 1) then
+ if (case_eta == 1) then
+ subblock_num = 1
+ else
+ subblock_num = 2
+ endif
+ else
+ if (case_eta == 1) then
+ subblock_num = 3
+ else
+ subblock_num = 4
+ endif
+ endif
+! then define the geometry for this sub-block
+ call define_basic_doubling_brick(x_superbrick,y_superbrick,z_superbrick,ibool_superbrick,iboun_sb,subblock_num)
+ endif
+! loop on all the elements in the mesh doubling superbrick
+ do ispec_superbrick = 1,nspec_sb
+! loop on all the corner nodes of this element
+ do ignod = 1,NGNOD_EIGHT_CORNERS
+
+! define topological coordinates of this mesh point
+ offset_x(ignod) = (ix_elem - 1) + &
+ x_superbrick(ibool_superbrick(ignod,ispec_superbrick)) * ratio_sampling_array(ilayer)
+ offset_y(ignod) = (iy_elem - 1) + &
+ y_superbrick(ibool_superbrick(ignod,ispec_superbrick)) * ratio_sampling_array(ilayer)
+ offset_z(ignod) = (iz_elem - 1) + &
+ z_superbrick(ibool_superbrick(ignod,ispec_superbrick))
+
+ enddo
+! the rest of the 27 nodes are missing, therefore add them
+ call add_missing_nodes(offset_x,offset_y,offset_z)
+
+! compute the actual position of all the grid points of that element
+ call compute_coord_main_mesh(offset_x,offset_y,offset_z,xelm,yelm,zelm, &
+ ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
+ NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ r_top(ilayer),r_bottom(ilayer),ner(ilayer),ilayer,ichunk,rotation_matrix, &
+ NCHUNKS,INCLUDE_CENTRAL_CUBE,NUMBER_OF_MESH_LAYERS)
+
+! add one spectral element to the list
+ ispec = ispec + 1
+ if(ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in mesh creation')
+
+! new get_flag_boundaries
+! xmin & xmax
+ if (ix_elem == 1) then
+ iMPIcut_xi(1,ispec) = iboun_sb(ispec_superbrick,1)
+ if (iproc_xi == 0) iboun(1,ispec)= iboun_sb(ispec_superbrick,1)
+ endif
+ if (ix_elem == (NEX_PER_PROC_XI-step_mult*ratio_sampling_array(ilayer)+1)) then
+ iMPIcut_xi(2,ispec) = iboun_sb(ispec_superbrick,2)
+ if (iproc_xi == NPROC_XI-1) iboun(2,ispec)= iboun_sb(ispec_superbrick,2)
+ endif
+!! ymin & ymax
+ if (iy_elem == 1) then
+ iMPIcut_eta(1,ispec) = iboun_sb(ispec_superbrick,3)
+ if (iproc_eta == 0) iboun(3,ispec)= iboun_sb(ispec_superbrick,3)
+ endif
+ if (iy_elem == (NEX_PER_PROC_ETA-step_mult*ratio_sampling_array(ilayer)+1)) then
+ iMPIcut_eta(2,ispec) = iboun_sb(ispec_superbrick,4)
+ if (iproc_eta == NPROC_ETA-1) iboun(4,ispec)= iboun_sb(ispec_superbrick,4)
+ endif
+! zmax only
+ if (ilayer==ifirst_region) then
+ iboun(6,ispec)= iboun_sb(ispec_superbrick,6)
+ endif
+ if (ilayer==ilast_region .and. iz_elem==1) then
+ iboun(5,ispec)= iboun_sb(ispec_superbrick,5)
+ endif
+
+! define the doubling flag of this element
+ if(iregion_code /= IREGION_OUTER_CORE) idoubling(ispec) = doubling_index(ilayer)
+
+! save the radii of the nodes before modified through compute_element_properties()
+ if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
+ r1=sqrt(xelm(1)**2+yelm(1)**2+zelm(1)**2)
+ r2=sqrt(xelm(2)**2+yelm(2)**2+zelm(2)**2)
+ r3=sqrt(xelm(3)**2+yelm(3)**2+zelm(3)**2)
+ r4=sqrt(xelm(4)**2+yelm(4)**2+zelm(4)**2)
+ r5=sqrt(xelm(5)**2+yelm(5)**2+zelm(5)**2)
+ r6=sqrt(xelm(6)**2+yelm(6)**2+zelm(6)**2)
+ r7=sqrt(xelm(7)**2+yelm(7)**2+zelm(7)**2)
+ r8=sqrt(xelm(8)**2+yelm(8)**2+zelm(8)**2)
+ endif
+
+! compute several rheological and geometrical properties for this spectral element
+ call compute_element_properties(ispec,iregion_code,idoubling, &
+ xstore,ystore,zstore,nspec, &
+ nspl,rspl,espl,espl2,ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ myrank,ibathy_topo,ATTENUATION,ATTENUATION_3D, &
+ ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xelm,yelm,zelm,shape3D,dershape3D,rmin,rmax,rhostore_local,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+!! DK DK added this for the merged version
+ kappavstore_local, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ nspec_ani,nspec_stacey,Qmu_store,tau_e_store,tau_s,T_c_source,rho_vp,rho_vs,&
+ AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V,AM_S,AS_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+
+!! DK DK added this for merged version
+ include "comp_mass_matrix_one_element.f90"
+ include "store_xelm_yelm_zelm.f90"
+
+! boundary mesh
+ if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
+ is_superbrick=.true.
+ call get_jacobian_discontinuities(myrank,ispec,ix_elem,iy_elem,rmin,rmax,r1,r2,r3,r4,r5,r6,r7,r8, &
+ xstore(:,:,:,ispec),ystore(:,:,:,ispec),zstore(:,:,:,ispec),dershape2D_bottom, &
+ ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot,ibelm_670_top,ibelm_670_bot, &
+ normal_moho,normal_400,normal_670,jacobian2D_moho,jacobian2D_400,jacobian2D_670, &
+ ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot, &
+ NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,r_moho,r_400,r_670, &
+ is_superbrick,USE_ONE_LAYER_SB,ispec_superbrick,nex_eta_moho,HONOR_1D_SPHERICAL_MOHO)
+ endif
+
+! end of loops on the mesh doubling elements
+ enddo
+ enddo
+ enddo
+ endif
+
+! end of loop on all the layers of the mesh
+ enddo
+
+ if (CASE_3D .and. iregion_code == IREGION_CRUST_MANTLE .and. .not. SUPPRESS_CRUSTAL_MESH) then
+ deallocate(stretch_tab,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate stretch_tab in create_regions_mesh ier=",ier
+ endif
+
+ endif
+ deallocate (perm_layer,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate perm_layer in create_regions_mesh ier=",ier
+ endif
+
+!---
+
+! define central cube in inner core
+
+ if(INCLUDE_CENTRAL_CUBE .and. iregion_code == IREGION_INNER_CORE) then
+
+! create the shape of a regular mesh element in the inner core
+ call hex_nodes(iaddx,iaddy,iaddz)
+
+! define vertical slice in central cube on current processor
+! we can assume that NEX_XI = NEX_ETA, otherwise central cube cannot be defined
+ nx_central_cube = NEX_PER_PROC_XI / ratio_divide_central_cube
+ ny_central_cube = NEX_PER_PROC_ETA / ratio_divide_central_cube
+ nz_central_cube = NEX_XI / ratio_divide_central_cube
+
+! size of the cube along cartesian axes before rotation
+ radius_cube = (R_CENTRAL_CUBE / R_EARTH) / sqrt(3.d0)
+
+! define spectral elements in central cube
+ do iz = 0,2*nz_central_cube-2,2
+ do iy = 0,2*ny_central_cube-2,2
+ do ix = 0,2*nx_central_cube-2,2
+
+! radii that define the shell, we know that we are in the central cube
+ rmin = 0.d0
+ rmax = R_CENTRAL_CUBE / R_EARTH
+
+! loop over the NGNOD nodes
+ do ia=1,NGNOD
+
+! flat cubed sphere with correct mapping
+ call compute_coord_central_cube(ix+iaddx(ia),iy+iaddy(ia),iz+iaddz(ia), &
+ xgrid_central_cube,ygrid_central_cube,zgrid_central_cube, &
+ iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,nx_central_cube,ny_central_cube,nz_central_cube,radius_cube)
+
+ if(ichunk == CHUNK_AB) then
+ xelm(ia) = - ygrid_central_cube
+ yelm(ia) = + xgrid_central_cube
+ zelm(ia) = + zgrid_central_cube
+
+ else if(ichunk == CHUNK_AB_ANTIPODE) then
+ xelm(ia) = - ygrid_central_cube
+ yelm(ia) = - xgrid_central_cube
+ zelm(ia) = - zgrid_central_cube
+
+ else if(ichunk == CHUNK_AC) then
+ xelm(ia) = - ygrid_central_cube
+ yelm(ia) = - zgrid_central_cube
+ zelm(ia) = + xgrid_central_cube
+
+ else if(ichunk == CHUNK_AC_ANTIPODE) then
+ xelm(ia) = - ygrid_central_cube
+ yelm(ia) = + zgrid_central_cube
+ zelm(ia) = - xgrid_central_cube
+
+ else if(ichunk == CHUNK_BC) then
+ xelm(ia) = - zgrid_central_cube
+ yelm(ia) = + ygrid_central_cube
+ zelm(ia) = + xgrid_central_cube
+
+ else if(ichunk == CHUNK_BC_ANTIPODE) then
+ xelm(ia) = + zgrid_central_cube
+ yelm(ia) = - ygrid_central_cube
+ zelm(ia) = + xgrid_central_cube
+
+ else
+ call exit_MPI(myrank,'wrong chunk number in flat cubed sphere definition')
+ endif
+
+ enddo
+
+! add one spectral element to the list
+ ispec = ispec + 1
+ if(ispec > nspec) call exit_MPI(myrank,'ispec greater than nspec in central cube creation')
+
+! new get_flag_boundaries
+! xmin & xmax
+ if (ix == 0) then
+ iMPIcut_xi(1,ispec) = .true.
+ if (iproc_xi == 0) iboun(1,ispec)= .true.
+ endif
+ if (ix == 2*nx_central_cube-2) then
+ iMPIcut_xi(2,ispec) = .true.
+ if (iproc_xi == NPROC_XI-1) iboun(2,ispec)= .true.
+ endif
+! ymin & ymax
+ if (iy == 0) then
+ iMPIcut_eta(1,ispec) = .true.
+ if (iproc_eta == 0) iboun(3,ispec)= .true.
+ endif
+ if (iy == 2*ny_central_cube-2) then
+ iMPIcut_eta(2,ispec) = .true.
+ if (iproc_eta == NPROC_ETA-1) iboun(4,ispec)= .true.
+ endif
+
+! define the doubling flag of this element
+! only two active central cubes, the four others are fictitious
+
+! determine where we cut the central cube to share it between CHUNK_AB & CHUNK_AB_ANTIPODE
+! in the case of mod(NPROC_XI,2)/=0, the cut is asymetric and the bigger part is for CHUNK_AB
+ if (mod(NPROC_XI,2)/=0) then
+ if (ichunk == CHUNK_AB) then
+ nz_inf_limit = ((nz_central_cube*2)/NPROC_XI)*floor(NPROC_XI/2.d0)
+ elseif (ichunk == CHUNK_AB_ANTIPODE) then
+ nz_inf_limit = ((nz_central_cube*2)/NPROC_XI)*ceiling(NPROC_XI/2.d0)
+ endif
+ else
+ nz_inf_limit = nz_central_cube
+ endif
+
+ if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
+ if(iz == nz_inf_limit) then
+ idoubling(ispec) = IFLAG_BOTTOM_CENTRAL_CUBE
+ else if(iz == 2*nz_central_cube-2) then
+ idoubling(ispec) = IFLAG_TOP_CENTRAL_CUBE
+ else if (iz > nz_inf_limit .and. iz < 2*nz_central_cube-2) then
+ idoubling(ispec) = IFLAG_MIDDLE_CENTRAL_CUBE
+ else
+ idoubling(ispec) = IFLAG_IN_FICTITIOUS_CUBE
+ endif
+ else
+ idoubling(ispec) = IFLAG_IN_FICTITIOUS_CUBE
+ endif
+
+
+! compute several rheological and geometrical properties for this spectral element
+ call compute_element_properties(ispec,iregion_code,idoubling, &
+ xstore,ystore,zstore,nspec, &
+ nspl,rspl,espl,espl2,ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY, &
+ ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ myrank,ibathy_topo,ATTENUATION,ATTENUATION_3D, &
+ ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xelm,yelm,zelm,shape3D,dershape3D,rmin,rmax,rhostore_local,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+!! DK DK added this for the merged version
+ kappavstore_local, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ nspec_ani,nspec_stacey,Qmu_store,tau_e_store,tau_s,T_c_source,rho_vp,rho_vs,&
+ AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V,AM_S,AS_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+
+!! DK DK added this for merged version
+ include "comp_mass_matrix_one_element.f90"
+ include "store_xelm_yelm_zelm.f90"
+
+ enddo
+ enddo
+ enddo
+
+ endif ! end of definition of central cube in inner core
+
+!---
+
+! check total number of spectral elements created
+ if(ispec /= nspec) call exit_MPI(myrank,'ispec should equal nspec')
+
+! only create global addressing and the MPI buffers in the first pass
+ if(ipass == 1) then
+
+ ! allocate memory for arrays
+ allocate(locval(npointot),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(ifseg(npointot),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(xp(npointot),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(yp(npointot),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(zp(npointot),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ locval = 0
+ ifseg = .false.
+ xp = 0.d0
+ yp = 0.d0
+ zp = 0.d0
+
+ ! we need to create a copy of the x, y and z arrays because sorting in get_global will swap
+ ! these arrays and therefore destroy them
+ do ispec=1,nspec
+ ieoff = NGLLX * NGLLY * NGLLZ * (ispec-1)
+ ilocnum = 0
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ilocnum = ilocnum + 1
+ xp(ilocnum+ieoff) = xstore(i,j,k,ispec)
+ yp(ilocnum+ieoff) = ystore(i,j,k,ispec)
+ zp(ilocnum+ieoff) = zstore(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ call get_global(nspec,xp,yp,zp,ibool,locval,ifseg,nglob,npointot)
+
+ deallocate(xp,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate xp in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(yp,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate yp in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(zp,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate zp in create_regions_mesh ier=",ier
+ endif
+
+
+ ! check that number of points found equals theoretical value
+ if(nglob /= nglob_theor) then
+ write(errmsg,*) 'incorrect total number of points found: myrank,nglob,nglob_theor,ipass,iregion_code = ',&
+ myrank,nglob,nglob_theor,ipass,iregion_code
+ call exit_MPI(myrank,errmsg)
+ endif
+
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) call exit_MPI(myrank,'incorrect global numbering')
+
+ ! create a new indirect addressing to reduce cache misses in memory access in the solver
+ ! this is *critical* to improve performance in the solver
+ allocate(copy_ibool_ori(NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate copy_ibool_ori in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(mask_ibool(nglob),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate mask_ibool in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+
+ mask_ibool(:) = -1
+ copy_ibool_ori(:,:,:,:) = ibool(:,:,:,:)
+
+ inumber = 0
+ do ispec=1,nspec
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if(mask_ibool(copy_ibool_ori(i,j,k,ispec)) == -1) then
+ ! create a new point
+ inumber = inumber + 1
+ ibool(i,j,k,ispec) = inumber
+ mask_ibool(copy_ibool_ori(i,j,k,ispec)) = inumber
+ else
+ ! use an existing point created previously
+ ibool(i,j,k,ispec) = mask_ibool(copy_ibool_ori(i,j,k,ispec))
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+ deallocate(copy_ibool_ori,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate copy_ibool_ori in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(mask_ibool,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate mask_ibool in create_regions_mesh ier=",ier
+ endif
+
+
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) call exit_MPI(myrank,'incorrect global numbering after sorting')
+
+ ! create MPI buffers
+ ! arrays locval(npointot) and ifseg(npointot) used to save memory
+ call get_MPI_cutplanes_xi(myrank,nspec,iMPIcut_xi,ibool, &
+ xstore,ystore,zstore,ifseg,npointot, &
+ NSPEC2D_ETA_FACE,iregion_code,NGLOB2DMAX_XY,nglob,iboolleft_xi,iboolright_xi,NGLOB2DMAX_XMIN_XMAX,npoin2D_xi)
+ call get_MPI_cutplanes_eta(myrank,nspec,iMPIcut_eta,ibool, &
+ xstore,ystore,zstore,ifseg,npointot, &
+ NSPEC2D_XI_FACE,iregion_code,NGLOB2DMAX_XY,nglob,iboolleft_eta,iboolright_eta,NGLOB2DMAX_YMIN_YMAX,npoin2D_eta)
+ call get_MPI_1D_buffers(myrank,nspec,iMPIcut_xi,iMPIcut_eta,ibool,idoubling, &
+ xstore,ystore,zstore,ifseg,npointot, &
+ NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion_code,nglob, &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta,NGLOB1D_RADIAL_MAX, &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
+ iregion_code)
+
+ deallocate(locval,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate locval in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(ifseg,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate ifseg in create_regions_mesh ier=",ier
+ endif
+
+!! DK DK for merged code, copied here to be able to create mass matrix in right order
+ if (PERFORM_CUTHILL_MCKEE) then
+!!!!!!!!!!!!!!!!!!!! allocate(perm(nspec))
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+ ! do not permute anisotropic elements
+ perm(1:FIRST_ELT_NON_ANISO-1) = (/ (i,i=1,FIRST_ELT_NON_ANISO-1) /)
+
+ ! no more connectivity between layers below and above the anisotropic layers => 2 permutations
+ ! permute the bottom of the region : below the aniso layers
+ allocate(perm_tmp(FIRST_ELT_ABOVE_ANISO-FIRST_ELT_NON_ANISO),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate perm_tmp in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ call get_perm(ibool(:,:,:,FIRST_ELT_NON_ANISO:FIRST_ELT_ABOVE_ANISO-1),perm_tmp,LIMIT_MULTI_CUTHILL,&
+ (FIRST_ELT_ABOVE_ANISO-FIRST_ELT_NON_ANISO),nglob,.true.,.false.)
+ perm(FIRST_ELT_NON_ANISO:FIRST_ELT_ABOVE_ANISO-1) = perm_tmp(:)+(FIRST_ELT_NON_ANISO-1)
+ deallocate(perm_tmp,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate perm_tmp in create_regions_mesh ier=",ier
+ endif
+
+ ! permute the top of the region : above the aniso layers
+ allocate(perm_tmp(nspec-FIRST_ELT_ABOVE_ANISO+1),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate perm_tmp in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ call get_perm(ibool(:,:,:,FIRST_ELT_ABOVE_ANISO:nspec),perm_tmp,LIMIT_MULTI_CUTHILL,&
+ (nspec-FIRST_ELT_ABOVE_ANISO+1),nglob,.true.,.false.)
+ perm(FIRST_ELT_ABOVE_ANISO:nspec) = perm_tmp(:)+(FIRST_ELT_ABOVE_ANISO-1)
+ deallocate(perm_tmp,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate perm_tmp in create_regions_mesh ier=",ier
+ endif
+ else
+ ! the 3 last parameters are : PERFORM_CUTHILL_MCKEE,INVERSE,FACE
+ call get_perm(ibool,perm,LIMIT_MULTI_CUTHILL,nspec,nglob,.true.,.false.)
+ endif
+!!!!!!!!!!!!!!!!!!!! deallocate(perm)
+!! DK DK create inverse permutation
+ if(minval(perm) /= 1) stop 'minval of perm must be 1'
+ if(maxval(perm) /= nspec) stop 'maxval of perm must be nspec'
+ invperm(:) = -1
+ do ispec=1,nspec
+ if(invperm(perm(ispec)) == -1) then
+ invperm(perm(ispec)) = ispec
+ else
+ stop 'value already found, permutation is not bijective'
+ endif
+ enddo
+ if(minval(invperm) /= 1) stop 'minval of invperm must be 1'
+ if(maxval(invperm) /= nspec) stop 'maxval of invperm must be nspec'
+ endif
+!! DK DK for merged code, copied here to be able to create mass matrix in right order
+
+! only create mass matrix and save all the final arrays in the second pass
+ else if(ipass == 2) then
+
+! copy the theoretical number of points for the second pass
+ nglob = nglob_theor
+
+! count number of anisotropic elements in current region
+! should be zero in all the regions except in the mantle
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+ nspec_tiso = count(idoubling(1:nspec) == IFLAG_220_80) + count(idoubling(1:nspec) == IFLAG_80_MOHO)
+ else
+ nspec_tiso = 0
+ endif
+
+! ***************************************************
+! Cuthill McKee permutation
+! ***************************************************
+ if (PERFORM_CUTHILL_MCKEE) then
+!!!!!!!!!!!!!!!!!!! allocate(perm(nspec))
+! if(iregion_code == IREGION_CRUST_MANTLE) then
+! ! do not permute anisotropic elements
+! perm(1:FIRST_ELT_NON_ANISO-1) = (/ (i,i=1,FIRST_ELT_NON_ANISO-1) /)
+
+! ! no more connectivity between layers below and above the anisotropic layers => 2 permutations
+! ! permute the bottom of the region : below the aniso layers
+! allocate(perm_tmp(FIRST_ELT_ABOVE_ANISO-FIRST_ELT_NON_ANISO))
+! call get_perm(ibool(:,:,:,FIRST_ELT_NON_ANISO:FIRST_ELT_ABOVE_ANISO-1),perm_tmp,LIMIT_MULTI_CUTHILL,&
+! (FIRST_ELT_ABOVE_ANISO-FIRST_ELT_NON_ANISO),nglob,.true.,.false.)
+! perm(FIRST_ELT_NON_ANISO:FIRST_ELT_ABOVE_ANISO-1) = perm_tmp(:)+(FIRST_ELT_NON_ANISO-1)
+! deallocate(perm_tmp)
+
+! ! permute the top of the region : above the aniso layers
+! allocate(perm_tmp(nspec-FIRST_ELT_ABOVE_ANISO+1))
+! call get_perm(ibool(:,:,:,FIRST_ELT_ABOVE_ANISO:nspec),perm_tmp,LIMIT_MULTI_CUTHILL,&
+! (nspec-FIRST_ELT_ABOVE_ANISO+1),nglob,.true.,.false.)
+! perm(FIRST_ELT_ABOVE_ANISO:nspec) = perm_tmp(:)+(FIRST_ELT_ABOVE_ANISO-1)
+! deallocate(perm_tmp)
+! else
+! ! the 3 last parameters are : PERFORM_CUTHILL_MCKEE,INVERSE,FACE
+! call get_perm(ibool,perm,LIMIT_MULTI_CUTHILL,nspec,nglob,.true.,.false.)
+! endif
+
+ ! permutation of xstore, ystore, zstore, rhostore, kappavstore, kappahstore,
+ ! muvstore, muhstore, eta_anisostore
+
+ allocate(temp_array_dble(NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate temp_array_dble in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ if(ATTENUATION .and. ATTENUATION_3D) then
+ call permute_elements_dble(Qmu_store,temp_array_dble,perm,nspec)
+ allocate(temp_array_dble_5dim(N_SLS,NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate permute_elements_dble in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ temp_array_dble_5dim(:,:,:,:,:) = tau_e_store(:,:,:,:,:)
+ do i = 1,nspec
+ tau_e_store(:,:,:,:,perm(i)) = temp_array_dble_5dim(:,:,:,:,i)
+ enddo
+ deallocate(temp_array_dble_5dim,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_array_dble_5dim in create_regions_mesh ier=",ier
+ endif
+
+ endif
+ call permute_elements_dble(xstore,temp_array_dble,perm,nspec)
+ call permute_elements_dble(ystore,temp_array_dble,perm,nspec)
+ call permute_elements_dble(zstore,temp_array_dble,perm,nspec)
+ deallocate(temp_array_dble,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_array_dble in create_regions_mesh ier=",ier
+ endif
+
+!! DK DK added this for merged code
+ allocate(temp_array_xelm_yelm_zelm(NGNOD,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate temp_array_xelm_yelm_zelm in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ call permute_elements_xelm_yelm_zelm(xelm_store,temp_array_xelm_yelm_zelm,perm,nspec)
+ call permute_elements_xelm_yelm_zelm(yelm_store,temp_array_xelm_yelm_zelm,perm,nspec)
+ call permute_elements_xelm_yelm_zelm(zelm_store,temp_array_xelm_yelm_zelm,perm,nspec)
+
+ deallocate(temp_array_xelm_yelm_zelm,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_array_xelm_yelm_zelm in create_regions_mesh ier=",ier
+ endif
+
+ allocate(temp_array_real(NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate temp_array_real in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ if(ABSORBING_CONDITIONS .and. NCHUNKS /= 6) then
+ call permute_elements_real(rho_vp,temp_array_real,perm,nspec)
+ call permute_elements_real(rho_vs,temp_array_real,perm,nspec)
+ endif
+ if((ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) .or. &
+ (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE)) then
+ call permute_elements_real(c11store,temp_array_real,perm,nspec)
+ call permute_elements_real(c12store,temp_array_real,perm,nspec)
+ call permute_elements_real(c13store,temp_array_real,perm,nspec)
+ call permute_elements_real(c14store,temp_array_real,perm,nspec)
+ call permute_elements_real(c15store,temp_array_real,perm,nspec)
+ call permute_elements_real(c16store,temp_array_real,perm,nspec)
+ call permute_elements_real(c22store,temp_array_real,perm,nspec)
+ call permute_elements_real(c23store,temp_array_real,perm,nspec)
+ call permute_elements_real(c24store,temp_array_real,perm,nspec)
+ call permute_elements_real(c25store,temp_array_real,perm,nspec)
+ call permute_elements_real(c26store,temp_array_real,perm,nspec)
+ call permute_elements_real(c33store,temp_array_real,perm,nspec)
+ call permute_elements_real(c34store,temp_array_real,perm,nspec)
+ call permute_elements_real(c35store,temp_array_real,perm,nspec)
+ call permute_elements_real(c36store,temp_array_real,perm,nspec)
+ call permute_elements_real(c44store,temp_array_real,perm,nspec)
+ call permute_elements_real(c45store,temp_array_real,perm,nspec)
+ call permute_elements_real(c46store,temp_array_real,perm,nspec)
+ call permute_elements_real(c55store,temp_array_real,perm,nspec)
+ call permute_elements_real(c56store,temp_array_real,perm,nspec)
+ call permute_elements_real(c66store,temp_array_real,perm,nspec)
+ endif
+!! DK DK added this for merged version
+ if(iregion_code /= IREGION_OUTER_CORE) then
+ call permute_elements_real(kappavstore,temp_array_real,perm,nspec)
+ call permute_elements_real(muvstore,temp_array_real,perm,nspec)
+ if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) then
+ if(minval(perm(1:NSPECMAX_TISO_MANTLE)) /= 1) stop 'minval perm for aniso should be 1'
+ if(maxval(perm(1:NSPECMAX_TISO_MANTLE)) /= NSPECMAX_TISO_MANTLE) &
+ stop 'maxval perm for aniso should be NSPECMAX_TISO_MANTLE'
+ call permute_elements_real(kappahstore,temp_array_real,perm,NSPECMAX_TISO_MANTLE)
+ call permute_elements_real(muhstore,temp_array_real,perm,NSPECMAX_TISO_MANTLE)
+ call permute_elements_real(eta_anisostore,temp_array_real,perm,NSPECMAX_TISO_MANTLE)
+ endif
+ endif
+
+!! DK DK added this for merged version: attempt to permute mass matrix
+! 333333333333333
+ allocate(temp_rmass(NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate temp_rmass in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+! allocate(temp_rmass(nglob))
+ do ispec = 1,nspec
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+! temp_rmass(ibool(i,j,k,perm(ispec))) = rmass(ibool(i,j,k,ispec))
+ temp_rmass(i,j,k,ispec) = rmass(ibool(i,j,k,ispec))
+ enddo
+ enddo
+ enddo
+ enddo
+! rmass(:) = temp_rmass(:)
+ call permute_elements_real(temp_rmass,temp_array_real,perm,nspec)
+! do ispec = 1,nspec
+! do k = 1,NGLLZ
+! do j = 1,NGLLY
+! do i = 1,NGLLX
+! rmass(ibool(i,j,k,ispec)) = temp_rmass(i,j,k,ispec)
+! enddo
+! enddo
+! enddo
+! enddo
+! deallocate(temp_rmass)
+
+ deallocate(temp_array_real,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_array_real in create_regions_mesh ier=",ier
+ endif
+
+ ! permutation of ibool
+ allocate(temp_array_int(NGLLX,NGLLY,NGLLZ,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate temp_array_int in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ call permute_elements_integer(ibool,temp_array_int,perm,nspec)
+ deallocate(temp_array_int,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_array_int in create_regions_mesh ier=",ier
+ endif
+
+!! DK DK added this for merged version: attempt to permute mass matrix
+! 333333333333333
+ do ispec = 1,nspec
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ rmass(ibool(i,j,k,ispec)) = temp_rmass(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+ deallocate(temp_rmass,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_rmass in create_regions_mesh ier=",ier
+ endif
+
+! deallocate(temp_array_real)
+
+ ! permutation of iMPIcut_*
+ allocate(temp_array_2D_log(2,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate temp_array_2D_log in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ temp_array_2D_log(:,:) = iMPIcut_xi(:,:)
+ do i = 1,nspec
+ iMPIcut_xi(:,perm(i)) = temp_array_2D_log(:,i)
+ enddo
+ temp_array_2D_log(:,:) = iMPIcut_eta(:,:)
+ do i = 1,nspec
+ iMPIcut_eta(:,perm(i)) = temp_array_2D_log(:,i)
+ enddo
+
+ deallocate(temp_array_2D_log,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_array_2D_log in create_regions_mesh ier=",ier
+ endif
+
+ ! permutation of iboun
+ allocate(temp_array_2D_log(6,nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate temp_array_2D_log in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ temp_array_2D_log(:,:) = iboun(:,:)
+ do i = 1,nspec
+ iboun(:,perm(i)) = temp_array_2D_log(:,i)
+ enddo
+
+ deallocate(temp_array_2D_log,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_array_2D_log in create_regions_mesh ier=",ier
+ endif
+
+
+ ! permutation of idoubling
+!! DK DK added this for merged version because array not allocated in the outer core
+ if(iregion_code /= IREGION_OUTER_CORE) then
+ allocate(temp_array_1D_int(nspec),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate temp_array_1D_int in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ temp_array_1D_int(:) = idoubling(:)
+ do i = 1,nspec
+ idoubling(perm(i)) = temp_array_1D_int(i)
+ enddo
+ deallocate(temp_array_1D_int,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate temp_array_1D_int in create_regions_mesh ier=",ier
+ endif
+ endif
+
+!!!!!!!!!!!!!!!!!!! deallocate(perm)
+ endif
+
+! ***************************************************
+! end of Cuthill McKee permutation
+! ***************************************************
+
+ call get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ jacobian2D_xmin,jacobian2D_xmax, &
+ jacobian2D_ymin,jacobian2D_ymax, &
+ jacobian2D_bottom,jacobian2D_top, &
+ normal_xmin,normal_xmax, &
+ normal_ymin,normal_ymax, &
+ normal_bottom,normal_top, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX)
+
+! save the binary files
+! save ocean load mass matrix as well if oceans
+ if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) then
+
+! adding ocean load mass matrix at the top of the crust for oceans
+ nglob_oceans = nglob
+ allocate(rmass_ocean_load(nglob_oceans),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate rmass_ocean_load in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+! create ocean load mass matrix for degrees of freedom at ocean bottom
+ rmass_ocean_load(:) = 0._CUSTOM_REAL
+
+! add contribution of the oceans
+! for surface elements exactly at the top of the crust (ocean bottom)
+ do ispec2D_top_crust = 1,NSPEC2D_TOP
+
+ ispec_oceans = ibelm_top(ispec2D_top_crust)
+
+ iz_oceans = NGLLZ
+
+ do ix_oceans = 1,NGLLX
+ do iy_oceans = 1,NGLLY
+
+ iglobnum=ibool(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+
+! compute local height of oceans
+ if(ISOTROPIC_3D_MANTLE) then
+
+! get coordinates of current point
+ xval = xstore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+ yval = ystore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+ zval = zstore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+
+! map to latitude and longitude for bathymetry routine
+ call xyz_2_rthetaphi_dble(xval,yval,zval,rval,thetaval,phival)
+ call reduce(thetaval,phival)
+
+! convert the geocentric colatitude to a geographic colatitude
+ colat = PI/2.0d0 - datan(1.006760466d0*dcos(thetaval)/dmax1(TINYVAL,dsin(thetaval)))
+
+! get geographic latitude and longitude in degrees
+ lat = 90.0d0 - colat*180.0d0/PI
+ lon = phival*180.0d0/PI
+ elevation = 0.d0
+
+! compute elevation at current point
+ call get_topo_bathy(lat,lon,elevation,ibathy_topo)
+
+! non-dimensionalize the elevation, which is in meters
+! and suppress positive elevation, which means no oceans
+ if(elevation >= - MINIMUM_THICKNESS_3D_OCEANS) then
+ height_oceans = 0.d0
+ else
+ height_oceans = dabs(elevation) / R_EARTH
+ endif
+
+ else
+ height_oceans = THICKNESS_OCEANS_PREM
+ endif
+
+! take into account inertia of water column
+ weight = wxgll(ix_oceans)*wygll(iy_oceans)*dble(jacobian2D_top(ix_oceans,iy_oceans,ispec2D_top_crust)) &
+ * dble(RHO_OCEANS) * height_oceans
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + sngl(weight)
+ else
+ rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + weight
+ endif
+
+ enddo
+ enddo
+
+ enddo
+
+! add regular mass matrix to ocean load contribution
+ rmass_ocean_load(:) = rmass_ocean_load(:) + rmass(:)
+
+ else
+
+! allocate dummy array if no oceans
+ nglob_oceans = 1
+ allocate(rmass_ocean_load(nglob_oceans),STAT=ier )
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate rmass_ocean_load in create_regions_mesh ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ endif
+
+! save the binary files
+!! DK DK MERGED UGLY this is the only thing we are going to have to save
+! call save_arrays_solver(rho_vp,rho_vs,nspec_stacey, &
+! prname,iregion_code,xixstore,xiystore,xizstore, &
+! etaxstore,etaystore,etazstore, &
+! gammaxstore,gammaystore,gammazstore, &
+! xstore,ystore,zstore, rhostore, &
+! kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+! nspec_ani, &
+! c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+! c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+! c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+! ibool,idoubling,rmass,rmass_ocean_load,nglob_oceans, &
+! ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+! nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+! normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top, &
+! jacobian2D_xmin,jacobian2D_xmax, &
+! jacobian2D_ymin,jacobian2D_ymax, &
+! jacobian2D_bottom,jacobian2D_top, &
+! nspec,nglob, &
+! NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+! TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS, &
+! tau_s,tau_e_store,Qmu_store,T_c_source, &
+! ATTENUATION,ATTENUATION_3D, &
+! size(tau_e_store,2),size(tau_e_store,3),size(tau_e_store,4),size(tau_e_store,5),&
+! NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NEX_XI,ichunk,NCHUNKS,ABSORBING_CONDITIONS,AM_V)
+
+! boundary mesh
+ if (SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
+! first check the number of surface elements are the same for Moho, 400, 670
+ if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
+ if (ispec2D_moho_top /= NSPEC2D_MOHO .or. ispec2D_moho_bot /= NSPEC2D_MOHO) &
+ call exit_mpi(myrank, 'Not the same number of Moho surface elements')
+ endif
+ if (ispec2D_400_top /= NSPEC2D_400 .or. ispec2D_400_bot /= NSPEC2D_400) &
+ call exit_mpi(myrank,'Not the same number of 400 surface elements')
+ if (ispec2D_670_top /= NSPEC2D_670 .or. ispec2D_670_bot /= NSPEC2D_670) &
+ call exit_mpi(myrank,'Not the same number of 670 surface elements')
+
+! writing surface topology databases
+ open(unit=27,file=prname(1:len_trim(prname))//'boundary_disc.bin',status='unknown',form='unformatted')
+ write(27) NSPEC2D_MOHO, NSPEC2D_400, NSPEC2D_670
+ write(27) ibelm_moho_top
+ write(27) ibelm_moho_bot
+ write(27) ibelm_400_top
+ write(27) ibelm_400_bot
+ write(27) ibelm_670_top
+ write(27) ibelm_670_bot
+ write(27) normal_moho
+ write(27) normal_400
+ write(27) normal_670
+ close(27)
+
+ deallocate(ibelm_moho_top,ibelm_moho_bot,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate ibelm_moho_top in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(ibelm_400_top,ibelm_400_bot,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate ibelm_400_top in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(ibelm_670_top,ibelm_670_bot,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate ibelm_670_top,ibelm_670_bot in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(normal_moho,normal_400,normal_670,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate normal_moho,normal_400,normal_670 in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(jacobian2D_moho,jacobian2D_400,jacobian2D_670,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate jacobian2D_moho,jacobian2D_400,jacobian2D_670 in create_regions_mesh ier=",ier
+ endif
+
+ endif
+
+! compute volume, bottom and top area of that part of the slice
+ volume_local = ZERO
+ area_local_bottom = ZERO
+ area_local_top = ZERO
+
+ do ispec = 1,nspec
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+
+! compute the jacobian
+!! DK DK for merged version the jacobian is not stored anymore and therefore not valid anymore
+ goto 777
+ xixl = xixstore(i,j,k)
+ xiyl = xiystore(i,j,k)
+ xizl = xizstore(i,j,k)
+ etaxl = etaxstore(i,j,k)
+ etayl = etaystore(i,j,k)
+ etazl = etazstore(i,j,k)
+ gammaxl = gammaxstore(i,j,k)
+ gammayl = gammaystore(i,j,k)
+ gammazl = gammazstore(i,j,k)
+
+ jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
+ - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl))
+
+ volume_local = volume_local + dble(jacobianl)*weight
+!! DK DK for merged version the jacobian is not stored anymore and therefore not valid anymore
+ 777 continue
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do ispec = 1,NSPEC2D_BOTTOM
+ do i=1,NGLLX
+ do j=1,NGLLY
+ weight=wxgll(i)*wygll(j)
+ area_local_bottom = area_local_bottom + dble(jacobian2D_bottom(i,j,ispec))*weight
+ enddo
+ enddo
+ enddo
+
+ do ispec = 1,NSPEC2D_TOP
+ do i=1,NGLLX
+ do j=1,NGLLY
+ weight=wxgll(i)*wygll(j)
+ area_local_top = area_local_top + dble(jacobian2D_top(i,j,ispec))*weight
+ enddo
+ enddo
+ enddo
+
+ else
+ stop 'there cannot be more than two passes in mesh creation'
+
+ endif ! end of test if first or second pass
+
+! deallocate arrays
+ deallocate(rhostore_local,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate rhostore_local in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(kappavstore_local,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate kappavstore_local in create_regions_mesh ier=",ier
+ endif
+
+
+ deallocate(c11store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c11store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c12store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c12store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c13store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c13store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c14store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c14store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c15store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c15store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c16store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c16store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c22store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c22store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c23store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c23store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c24store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c24store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c25store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c25store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c26store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c26store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c33store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c33store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c34store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c34store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c35store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c35store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c36store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c36store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c44store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c44store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c45store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c45store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c46store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c46store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c55store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c55store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c56store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c56store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(c66store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate c66store in create_regions_mesh ier=",ier
+ endif
+
+
+ deallocate(iboun,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate iboun in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(xigll,yigll,zigll,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate xigll,yigll,zigll in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(wxgll,wygll,wzgll,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate wxgll,wygll,wzgll in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(shape3D,dershape3D,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate shape3D,dershape3D in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(shape2D_x,shape2D_y,shape2D_bottom,shape2D_top,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate shape2D_x,shape2D_y,shape2D_bottom,shape2D_top in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top" &
+ ," in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(iMPIcut_xi,iMPIcut_eta,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate iMPIcut_xi,iMPIcut_eta in create_regions_mesh ier=",ier
+ endif
+
+
+ deallocate(nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta ",&
+ "in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(rho_vp,rho_vs,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate rho_vp,rho_vs in create_regions_mesh ier=",ier
+ endif
+
+
+ deallocate(Qmu_store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate Qmu_store in create_regions_mesh ier=",ier
+ endif
+
+ deallocate(tau_e_store,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate tau_e_store in create_regions_mesh ier=",ier
+ endif
+
+ if (allocated(rmass_ocean_load) ) then
+ deallocate(rmass_ocean_load,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate rmass_ocean_load in create_regions_mesh ier=",ier
+ endif
+ endif
+
+
+ end subroutine create_regions_mesh
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/crustal_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/crustal_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/crustal_model.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/deallocate.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/deallocate.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/deallocate.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,275 @@
+
+!! DK DK this for the new merged version
+
+ deallocate(xstore_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(ystore_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(zstore_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(xstore_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(ystore_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(zstore_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(xstore_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(ystore_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(zstore_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+!---
+
+ deallocate(xix_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(xiy_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(xiz_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etax_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etay_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etaz_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammax_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammay_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammaz_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(xix_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(xiy_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(xiz_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etax_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etay_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etaz_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammax_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammay_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammaz_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(xix_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(xiy_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(xiz_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etax_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etay_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(etaz_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammax_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammay_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(gammaz_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(rmass_ocean_load,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+!---
+
+ deallocate(displ_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(veloc_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(accel_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(displ_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(veloc_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(accel_outer_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(displ_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(veloc_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+ deallocate(accel_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+!---
+
+ deallocate(R_memory_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(R_memory_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+!---
+
+ deallocate(epsilondev_crust_mantle,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
+ deallocate(epsilondev_inner_core,STAT=ier )
+ if (ier /= 0) then
+ print *,"ERROR can not deallocate in deallocate.f90 ier=",ier
+ endif
+
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/declar.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/declar.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/declar.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,176 @@
+
+!! DK DK added this temporarily
+!!!!!!!!!!!!! integer, dimension(NSPEC_CRUST_MANTLE) :: perm,invperm
+!! DK DK suppressed for now because useless when CUTHILL-MCKEE is off
+ integer, dimension(1) :: perm,invperm
+
+!! DK DK added this for merged version
+!! DK DK stored in single precision for merged version, check if it precise enough (probably yes)
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
+ xelm_store_crust_mantle,yelm_store_crust_mantle,zelm_store_crust_mantle, &
+ xelm_store_outer_core,yelm_store_outer_core,zelm_store_outer_core, &
+ xelm_store_inner_core,yelm_store_inner_core,zelm_store_inner_core
+
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:,:,:) :: R_memory_crust_mantle
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:,:) :: epsilondev_crust_mantle
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:,:,:) :: R_memory_inner_core
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:,:) :: epsilondev_inner_core
+ real(kind=CUSTOM_REAL), allocatable, dimension(:) :: rmass_ocean_load
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:) :: &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,&
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle
+ real(kind=CUSTOM_REAL), allocatable, dimension(:) :: xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:) :: &
+ displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:) :: &
+ xix_outer_core,xiy_outer_core,xiz_outer_core,&
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core
+ real(kind=CUSTOM_REAL), allocatable, dimension(:) :: xstore_outer_core,ystore_outer_core,zstore_outer_core
+ real(kind=CUSTOM_REAL), allocatable, dimension(:) :: displ_outer_core,veloc_outer_core,accel_outer_core
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:,:,:) :: &
+ xix_inner_core,xiy_inner_core,xiz_inner_core,&
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core
+
+ real(kind=CUSTOM_REAL), allocatable, dimension(:) :: xstore_inner_core,ystore_inner_core,zstore_inner_core
+ real(kind=CUSTOM_REAL), allocatable, dimension(:,:) :: displ_inner_core,veloc_inner_core,accel_inner_core
+
+!!!!!!!!!!!!!!!! DK DK for merged version, all the arrays below are allocated statically instead
+!!!!!!!!!!!!!!!! DK DK for merged version, all the arrays below are allocated statically instead
+!!!!!!!!!!!!!!!! DK DK for merged version, all the arrays below are allocated statically instead
+!!!!!!!!!!!!!!!! DK DK for merged version, all the arrays below are allocated statically instead
+!!!!!!!!!!!!!!!! DK DK for merged version, all the arrays below are allocated statically instead
+!!!!!!!!!!!!!!!! DK DK for merged version, all the arrays below are allocated statically instead
+!!!!!!!!!!!!!!!! DK DK for merged version, all the arrays below are allocated statically instead
+
+ integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
+ integer npoin2D_faces_outer_core(NUMFACES_SHARED)
+ integer npoin2D_faces_inner_core(NUMFACES_SHARED)
+
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ npoin2D_xi_inner_core,npoin2D_eta_inner_core
+
+! number of elements on the boundaries
+ integer :: nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle,nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle
+ integer :: nspec2D_xmin_outer_core,nspec2D_xmax_outer_core,nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
+ integer :: nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: rmass_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: rmass_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: rmass_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: kappavstore_crust_mantle,muvstore_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: kappavstore_inner_core,muvstore_inner_core
+
+!! DK DK added this for the merged version
+!! DK DK these arrays are useless in the solver and will therefore be allocated with a dummy size of 1
+ real(kind=CUSTOM_REAL), dimension(1,1,1,1) :: kappahstore_inner_core,muhstore_inner_core,eta_anisostore_inner_core
+ real(kind=CUSTOM_REAL), dimension(1,1,1,1) :: kappavstore_outer_core,muvstore_outer_core
+ real(kind=CUSTOM_REAL), dimension(1,1,1,1) :: kappahstore_outer_core,muhstore_outer_core,eta_anisostore_outer_core
+
+! 2-D jacobians and normals
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_IC) :: jacobian2D_xmin_inner_core,jacobian2D_xmax_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_IC) :: jacobian2D_ymin_inner_core,jacobian2D_ymax_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_IC) :: jacobian2D_bottom_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_IC) :: jacobian2D_top_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_IC) :: normal_xmin_inner_core,normal_xmax_inner_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_IC) :: normal_ymin_inner_core,normal_ymax_inner_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_IC) :: normal_bottom_inner_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_IC) :: normal_top_inner_core
+
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_CM) :: ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_CM) :: ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle
+ integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
+ integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_CM) :: &
+ jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_CM) :: jacobian2D_bottom_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_CM) :: jacobian2D_top_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_CM) :: normal_xmin_crust_mantle,normal_xmax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2DMAX_YMIN_YMAX_CM) :: normal_ymin_crust_mantle,normal_ymax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_CM) :: normal_bottom_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_CM) :: normal_top_crust_mantle
+
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_OC) :: ibelm_xmin_outer_core,ibelm_xmax_outer_core
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_OC) :: ibelm_ymin_outer_core,ibelm_ymax_outer_core
+ integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
+ integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_OC) :: normal_xmin_outer_core,normal_xmax_outer_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_OC) :: normal_ymin_outer_core,normal_ymax_outer_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: normal_bottom_outer_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_OC) :: normal_top_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX_OC) :: jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX_OC) :: jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
+
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_IC) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_IC) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
+ integer, dimension(NSPEC2D_BOTTOM_IC) :: ibelm_bottom_inner_core
+ integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
+
+ integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle,iboolfaces_outer_core,iboolfaces_inner_core
+
+!!!! real(kind=CUSTOM_REAL), dimension(NGLOB2DMAX_XY_VAL) :: buffer_send_faces_scalar,buffer_received_faces_scalar
+
+!!!! real(kind=CUSTOM_REAL), dimension(NDIM,2*NGLOB2DMAX_XY_VAL) :: buffer_send_faces_vector,buffer_received_faces_vector
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+
+ integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling_crust_mantle
+
+!! DK DK this array is useless in the solver and is therefore allocated with a dummy size of 1
+ integer, dimension(1) :: idoubling_outer_core
+
+ integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
+
+ integer, dimension(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
+ integer, dimension(NGLOB1D_RADIAL_OC,NUMCORNERS_SHARED) :: iboolcorner_outer_core
+ integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB1D_RADIAL_CM) :: buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB1D_RADIAL_CM + NGLOB1D_RADIAL_IC) :: &
+ buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector
+
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_CM) :: iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_CM) :: iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_OC) :: iboolleft_xi_outer_core,iboolright_xi_outer_core
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_OC) :: iboolleft_eta_outer_core,iboolright_eta_outer_core
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_IC) :: iboolleft_xi_inner_core,iboolright_xi_inner_core
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_IC) :: iboolleft_eta_inner_core,iboolright_eta_inner_core
+
+ double precision, dimension(ATT1,ATT2,ATT3,ATT4) :: omsb_crust_mantle_dble, factor_scale_crust_mantle_dble
+
+ double precision, dimension(ATT1,ATT2,ATT3,ATT5) :: omsb_inner_core_dble, factor_scale_inner_core_dble
+
+ real(kind=CUSTOM_REAL), dimension(ATT1,ATT2,ATT3,ATT4) :: one_minus_sum_beta_crust_mantle, factor_scale_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(ATT1,ATT2,ATT3,ATT5) :: one_minus_sum_beta_inner_core, factor_scale_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(N_SLS,ATT1,ATT2,ATT3,ATT4) :: factor_common_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(N_SLS,ATT1,ATT2,ATT3,ATT5) :: factor_common_inner_core
+
+ double precision, dimension(N_SLS,ATT1,ATT2,ATT3,ATT4) :: factor_common_crust_mantle_dble
+
+ double precision, dimension(N_SLS,ATT1,ATT2,ATT3,ATT5) :: factor_common_inner_core_dble
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/define_derivation_matrices.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/define_derivation_matrices.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/define_derivation_matrices.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/define_superbrick.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/define_superbrick.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/define_superbrick.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/euler_angles.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/euler_angles.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/euler_angles.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/exit_mpi.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/exit_mpi.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/exit_mpi.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,98 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! end the simulation and exit MPI
+
+! version with rank number printed in the error message
+ subroutine exit_MPI(myrank,error_msg)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+
+! identifier for error message file
+ integer, parameter :: IERROR = 30
+
+ integer myrank
+ character(len=*) error_msg
+
+ integer ier
+ character(len=80) outputname
+ character(len=150) OUTPUT_FILES
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI... proc ',myrank
+
+! write error message to file
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+ write(outputname,"('/error_message',i6.6,'.txt')") myrank
+ open(unit=IERROR,file=trim(OUTPUT_FILES)//outputname,status='unknown')
+ write(IERROR,*) error_msg(1:len(error_msg))
+ write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
+ close(IERROR)
+
+! close output file
+ if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN)
+
+! stop all the MPI processes, and exit
+ call MPI_ABORT(MPI_COMM_WORLD,30,ier)
+ stop 'error, program ended in exit_MPI'
+
+ end subroutine exit_MPI
+
+!
+!----
+!
+
+! version without rank number printed in the error message
+ subroutine exit_MPI_without_rank(error_msg)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+
+ character(len=*) error_msg
+
+ integer ier
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI...'
+
+! stop all the MPI processes, and exit
+ call MPI_ABORT(MPI_COMM_WORLD,30,ier)
+ stop 'error, program ended in exit_MPI'
+
+ end subroutine exit_MPI_without_rank
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/flags.guess
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/flags.guess (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/flags.guess 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,183 @@
+#!/bin/sh
+
+# Attempt to guess suitable flags for the Fortran compiler.
+
+# Use AC_CANONICAL_BUILD (and package config.guess, etc.) in the future?
+if test x"$UNAME_MS" = x; then
+ UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown
+ UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown
+ UNAME_MS="${UNAME_MACHINE}:${UNAME_SYSTEM}"
+fi
+
+case $FC in
+ pgf90|*/pgf90)
+ #
+ # Beowulf Portland pgf90
+ #
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="-fast -Mnobounds -Mneginfo -Mdclchk -Knoieee" # -mcmodel=medium
+ fi
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="-fast -Mnobounds -Mneginfo -Mdclchk -Knoieee -Ktrap=none -Minline" # -mcmodel=medium
+ fi
+ ;;
+ ifort|*/ifort)
+ #
+ # Intel ifort Fortran90 for Linux
+ #
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="-O3 -e95 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nobounds -align sequence -assume byterecl -i-dynamic -ftrapuv -fpe0 -no-ftz -traceback" # -mcmodel=medium
+ fi
+ if test x"$FLAGS_NO_CHECK" = x; then
+ # standard options
+ FLAGS_NO_CHECK="-O3 -e95 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nobounds -align sequence -assume byterecl -i-dynamic -fpe3 -no-ftz" # -mcmodel=medium
+ # Pangu at Caltech
+ #FLAGS_NO_CHECK = $(IFORT_PROF) -vec_report0 -O2 -static -ip -xP -Wl,--allow-multiple-definition -L $$IFORT_ROOT/lib -limf -lirc
+ # debug with range checking
+ #FLAGS_NO_CHECK = -O0 -static -e95 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check bounds
+ fi
+ #MPI_LIBS = -Vaxlib
+ ;;
+ gfortran|*/gfortran|f95|*/f95)
+ #
+ # GNU gfortran
+ #
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="-std=gnu -fimplicit-none -frange-check -O3 -Wunused-labels -Waliasing -Wampersand -Wsurprising -Wline-truncation -Wunderflow -fno-trapping-math" # -mcmodel=medium
+ fi
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="\$(FLAGS_NO_CHECK)" # -fbounds-check
+ fi
+ ;;
+ g95|*/g95)
+ #
+ # g95 (free f95 compiler from http://www.g95.org)
+ #
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="-O"
+ fi
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="-O"
+ fi
+ ;;
+ f90|*/f90)
+ case $UNAME_MS in
+ i*86:Linux | x86_64:Linux)
+ ################ PC Linux #################
+ #
+ # AbSoft
+ #
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="-s -O2 -cpu:p7 -v -YDEALLOC=ALL"
+ fi
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="\$(FLAGS_CHECK)"
+ fi
+ ;;
+ *:IRIX*)
+ ################ SGI Irix #################
+ if test x"$MPIFC" = x; then
+ MPIFC=$FC
+ if test x"$MPILIBS" = x; then
+ MPILIBS="-lmpi -lfastm -lfpe"
+ fi
+ fi
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="\$(FLAGS_NO_CHECK) -check_bounds"
+ fi
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="-ansi -u -64 -O3 -OPT:Olimit=0 -OPT:roundoff=3 -OPT:IEEE_arithmetic=3 -r10000 -mips4"
+ fi
+ ;;
+ alpha:OSF1)
+ ################## Compaq Dec Alpha #################
+ if test x"$MPIFC" = x; then
+ MPIFC=$FC
+ if test x"$MPILIBS" = x; then
+ MPILIBS="-lfmpi -lmpi"
+ fi
+ fi
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="\$(FLAGS_NO_CHECK) -check bounds"
+ fi
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="-fast -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nounderflow"
+ fi
+ ;;
+ SX-*:SUPER-UX | ES:ESOS)
+ ################## Earth Simulator and NEC SX-5 ##################
+ if test x"$MPIFC" = x; then
+ MPIFC=$FC
+ fi
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="-C hopt -R2 -Wf\" -L nostdout noinclist mrgmsg noeject -msg b -pvctl loopcnt=14000000 expand=10 fullmsg vecthreshold=20 -s\" -pi auto line=100 exp=swap_all,rank"
+ fi
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="\$(FLAGS_CHECK)"
+ fi
+ ;;
+ esac
+ ;;
+ lf95|*/lf95)
+ #
+ # Lahey f90
+ #
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="--warn --wo --tpp --f95 --dal -O --chk"
+ fi
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="--warn --wo --tpp --f95 --dal -O"
+ fi
+ ;;
+ ######## IBM ######
+ mpxlf*|*/mpxlf*)
+ if test x"$MPIFC" = x; then
+ MPIFC=$FC
+ fi
+ ;;
+ *xlf*|*/*xlf*)
+ #
+ # do NOT remove option -qsave otherwise the IBM compiler allocates the
+ # arrays in the stack and the code crashes if the stack size is too
+ # small (which is often the case)
+ #
+ # on IBM with xlf one should also set
+ #
+ # CC = xlc_r
+ # CFLAGS = -O2 -q64
+ #
+ # or
+ #
+ # CC = gcc
+ # CFLAGS = -O2 -m64
+ #
+ # for the C compiler when using -q64 for the Fortran compiler
+ #
+ if test x"$FLAGS_NO_CHECK" = x; then
+ FLAGS_NO_CHECK="-O3 -qsave -qstrict -q64 -qtune=auto -qarch=auto -qcache=auto -qfree=f90 -Q -qsuffix=f=f90 -qhalt=w -qlanglvl=2003pure" # -qflttrap=en:ov:zero:inv
+ # on MareNostrum at the Barcelona SuperComputing Center (Spain) use
+ # -qtune=ppc970 -qarch=ppc64v instead of -qtune=auto -qarch=auto
+ fi
+ if test x"$FLAGS_CHECK" = x; then
+ FLAGS_CHECK="\$(FLAGS_NO_CHECK) -C"
+ fi
+ ;;
+esac
+
+case $UNAME_MS in
+ *:IRIX*)
+ ################ SGI Irix #################
+ ##
+ ## CAUTION: always define setenv TRAP_FPE OFF on SGI before compiling
+ ##
+ FCENV="TRAP_FPE=OFF"
+ ;;
+esac
+
+echo MPIFC=\"$MPIFC\" | sed 's/\$/\\\$/g'
+echo MPILIBS=\"$MPILIBS\" | sed 's/\$/\\\$/g'
+echo FLAGS_CHECK=\"$FLAGS_CHECK\" | sed 's/\$/\\\$/g'
+echo FLAGS_NO_CHECK=\"$FLAGS_NO_CHECK\" | sed 's/\$/\\\$/g'
+echo FCENV=\"$FCENV\" | sed 's/\$/\\\$/g'
+
+# end of file
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_1D_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_1D_buffers.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_1D_buffers.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,482 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_MPI_1D_buffers(myrank,nspec,iMPIcut_xi,iMPIcut_eta,ibool, &
+ idoubling,xstore,ystore,zstore,mask_ibool,npointot, &
+ NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion,nglob_ori, &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta,NGLOB1D_RADIAL_MAX, &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
+ iregion_code)
+
+! routine to create the MPI 1D chunk buffers for edges
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: NGLOB1D_RADIAL_MAX
+ integer ibool1D_leftxi_lefteta(NGLOB1D_RADIAL_MAX)
+ integer ibool1D_rightxi_lefteta(NGLOB1D_RADIAL_MAX)
+ integer ibool1D_leftxi_righteta(NGLOB1D_RADIAL_MAX)
+ integer ibool1D_rightxi_righteta(NGLOB1D_RADIAL_MAX)
+
+!! DK DK added this for merged version
+ integer :: iregion_code
+ double precision, dimension(NGLOB1D_RADIAL_MAX) :: &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta
+
+ integer nspec,myrank,nglob_ori,nglob,ipoin1D,iregion
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
+
+ logical iMPIcut_xi(2,nspec)
+ logical iMPIcut_eta(2,nspec)
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer idoubling(nspec)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! logical mask used to create arrays ibool1D
+ integer npointot
+ logical mask_ibool(npointot)
+
+! global element numbering
+ integer ispec
+
+! MPI 1D buffer element numbering
+ integer ispeccount,npoin1D,ix,iy,iz
+
+! arrays for sorting routine
+ integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: work
+ integer, dimension(:), allocatable :: ibool_selected
+ double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
+
+! allocate arrays for message buffers with maximum size
+! define maximum size for message buffers
+ if (PERFORM_CUTHILL_MCKEE) then
+ allocate(ibool_selected(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(xstore_selected(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(ystore_selected(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(zstore_selected(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(ind(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(ninseg(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(iglob(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(locval(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(ifseg(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(iwork(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ allocate(work(maxval(NGLOB1D_RADIAL_CORNER(iregion,:))))
+ endif
+
+! write the MPI buffers for the left and right edges of the slice
+! and the position of the points to check that the buffers are fine
+
+! *****************************************************************
+! ****************** generate for eta = eta_min *******************
+! *****************************************************************
+
+! determine if the element falls on the left MPI cut plane
+
+! global point number and coordinates left MPI 1D buffer
+!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin1D = 0
+
+! nb of elements in this 1D buffer
+ ispeccount=0
+
+ do ispec=1,nspec
+ ! remove central cube for chunk buffers
+!! DK DK added this for merged version because array idoubling is not allocated in outer core
+ if(iregion_code == IREGION_INNER_CORE) then
+ if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
+ endif
+ ! corner detection here
+ if(iMPIcut_xi(1,ispec) .and. iMPIcut_eta(1,ispec)) then
+ ispeccount=ispeccount+1
+ ! loop on all the points
+ ix = 1
+ iy = 1
+ do iz=1,NGLLZ
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin1D = npoin1D + 1
+!! DK DK added this for merged version
+ if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
+ if (PERFORM_CUTHILL_MCKEE) then
+ ibool_selected(npoin1D) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin1D) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin1D) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin1D) = zstore(ix,iy,iz,ispec)
+ else
+!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+!! DK DK added this for merged
+ ibool1D_leftxi_lefteta(npoin1D) = ibool(ix,iy,iz,ispec)
+ xread1D_leftxi_lefteta(npoin1D) = xstore(ix,iy,iz,ispec)
+ yread1D_leftxi_lefteta(npoin1D) = ystore(ix,iy,iz,ispec)
+ zread1D_leftxi_lefteta(npoin1D) = zstore(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ endif
+ enddo
+
+ nglob=nglob_ori
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_array_coordinates(npoin1D,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+!! DK DK added this for merged version
+ if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
+
+ do ipoin1D=1,npoin1D
+!! DK DK suppressed merged write(10,*) ibool_selected(ipoin1D), xstore_selected(ipoin1D), &
+!! DK DK suppressed merged ystore_selected(ipoin1D),zstore_selected(ipoin1D)
+!! DK DK added this for merged
+ ibool1D_leftxi_lefteta(ipoin1D) = ibool_selected(ipoin1D)
+ xread1D_leftxi_lefteta(ipoin1D) = xstore_selected(ipoin1D)
+ yread1D_leftxi_lefteta(ipoin1D) = ystore_selected(ipoin1D)
+ zread1D_leftxi_lefteta(ipoin1D) = zstore_selected(ipoin1D)
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+!! DK DK suppressed merged write(10,*) npoin1D
+
+!! DK DK suppressed merged close(10)
+
+! compare number of edge elements detected to analytical value
+ if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,1) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,1)) &
+ call exit_MPI(myrank,'error MPI 1D buffer detection in xi=left')
+
+! determine if the element falls on the right MPI cut plane
+
+! global point number and coordinates right MPI 1D buffer
+!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin1D = 0
+
+! nb of elements in this 1D buffer
+ ispeccount=0
+ do ispec=1,nspec
+ ! remove central cube for chunk buffers
+!! DK DK added this for merged version because array idoubling is not allocated in outer core
+ if(iregion_code == IREGION_INNER_CORE) then
+ if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
+ endif
+ ! corner detection here
+ if(iMPIcut_xi(2,ispec) .and. iMPIcut_eta(1,ispec)) then
+ ispeccount=ispeccount+1
+ ! loop on all the points
+ ix = NGLLX
+ iy = 1
+ do iz=1,NGLLZ
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin1D = npoin1D + 1
+!! DK DK added this for merged version
+ if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
+ if (PERFORM_CUTHILL_MCKEE) then
+ ibool_selected(npoin1D) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin1D) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin1D) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin1D) = zstore(ix,iy,iz,ispec)
+ else
+!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+!! DK DK added this for merged
+ ibool1D_rightxi_lefteta(npoin1D) = ibool(ix,iy,iz,ispec)
+ xread1D_rightxi_lefteta(npoin1D) = xstore(ix,iy,iz,ispec)
+ yread1D_rightxi_lefteta(npoin1D) = ystore(ix,iy,iz,ispec)
+ zread1D_rightxi_lefteta(npoin1D) = zstore(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ endif
+ enddo
+
+ nglob=nglob_ori
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_array_coordinates(npoin1D,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+!! DK DK added this for merged version
+ if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
+
+ do ipoin1D=1,npoin1D
+!! DK DK suppressed merged write(10,*) ibool_selected(ipoin1D), xstore_selected(ipoin1D), &
+!! DK DK suppressed merged ystore_selected(ipoin1D),zstore_selected(ipoin1D)
+!! DK DK added this for merged
+ ibool1D_rightxi_lefteta(ipoin1D) = ibool_selected(ipoin1D)
+ xread1D_rightxi_lefteta(ipoin1D) = xstore_selected(ipoin1D)
+ yread1D_rightxi_lefteta(ipoin1D) = ystore_selected(ipoin1D)
+ zread1D_rightxi_lefteta(ipoin1D) = zstore_selected(ipoin1D)
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+!! DK DK suppressed merged write(10,*) npoin1D
+
+!! DK DK suppressed merged close(10)
+
+! compare number of edge elements and points detected to analytical value
+ if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,2) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,2)) &
+ call exit_MPI(myrank,'error MPI 1D buffer detection in xi=right')
+
+! *****************************************************************
+! ****************** generate for eta = eta_max *******************
+! *****************************************************************
+
+! determine if the element falls on the left MPI cut plane
+
+! global point number and coordinates left MPI 1D buffer
+!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin1D = 0
+
+! nb of elements in this 1D buffer
+ ispeccount=0
+
+ do ispec=1,nspec
+
+! remove central cube for chunk buffers
+!! DK DK added this for merged version because array idoubling is not allocated in outer core
+ if(iregion_code == IREGION_INNER_CORE) then
+ if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
+ endif
+
+! corner detection here
+ if(iMPIcut_xi(1,ispec) .and. iMPIcut_eta(2,ispec)) then
+
+ ispeccount=ispeccount+1
+
+! loop on all the points
+ ix = 1
+ iy = NGLLY
+ do iz=1,NGLLZ
+
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin1D = npoin1D + 1
+!! DK DK added this for merged version
+ if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
+ if (PERFORM_CUTHILL_MCKEE) then
+ ibool_selected(npoin1D) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin1D) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin1D) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin1D) = zstore(ix,iy,iz,ispec)
+ else
+!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+!! DK DK added this for merged
+ ibool1D_leftxi_righteta(npoin1D) = ibool(ix,iy,iz,ispec)
+ xread1D_leftxi_righteta(npoin1D) = xstore(ix,iy,iz,ispec)
+ yread1D_leftxi_righteta(npoin1D) = ystore(ix,iy,iz,ispec)
+ zread1D_leftxi_righteta(npoin1D) = zstore(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ endif
+ enddo
+
+ nglob=nglob_ori
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_array_coordinates(npoin1D,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+!! DK DK added this for merged version
+ if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
+
+ do ipoin1D=1,npoin1D
+!! DK DK suppressed merged write(10,*) ibool_selected(ipoin1D), xstore_selected(ipoin1D), &
+!! DK DK suppressed merged ystore_selected(ipoin1D),zstore_selected(ipoin1D)
+!! DK DK added this for merged
+ ibool1D_leftxi_righteta(ipoin1D) = ibool_selected(ipoin1D)
+ xread1D_leftxi_righteta(ipoin1D) = xstore_selected(ipoin1D)
+ yread1D_leftxi_righteta(ipoin1D) = ystore_selected(ipoin1D)
+ zread1D_leftxi_righteta(ipoin1D) = zstore_selected(ipoin1D)
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+!! DK DK suppressed merged write(10,*) npoin1D
+
+!! DK DK suppressed merged close(10)
+
+! compare number of edge elements detected to analytical value
+ if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,4) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,4)) &
+ call exit_MPI(myrank,'error MPI 1D buffer detection in xi=left')
+
+! determine if the element falls on the right MPI cut plane
+
+! global point number and coordinates right MPI 1D buffer
+!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin1D = 0
+
+! nb of elements in this 1D buffer
+ ispeccount=0
+
+ do ispec=1,nspec
+
+! remove central cube for chunk buffers
+!! DK DK added this for merged version because array idoubling is not allocated in outer core
+ if(iregion_code == IREGION_INNER_CORE) then
+ if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
+ endif
+
+! corner detection here
+ if(iMPIcut_xi(2,ispec) .and. iMPIcut_eta(2,ispec)) then
+
+ ispeccount=ispeccount+1
+
+! loop on all the points
+ ix = NGLLX
+ iy = NGLLY
+ do iz=1,NGLLZ
+
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin1D = npoin1D + 1
+!! DK DK added this for merged version
+ if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
+ if (PERFORM_CUTHILL_MCKEE) then
+ ibool_selected(npoin1D) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin1D) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin1D) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin1D) = zstore(ix,iy,iz,ispec)
+ else
+!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ ibool1D_rightxi_righteta(npoin1D) = ibool(ix,iy,iz,ispec)
+ xread1D_rightxi_righteta(npoin1D) = xstore(ix,iy,iz,ispec)
+ yread1D_rightxi_righteta(npoin1D) = ystore(ix,iy,iz,ispec)
+ zread1D_rightxi_righteta(npoin1D) = zstore(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ endif
+ enddo
+
+ nglob=nglob_ori
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_array_coordinates(npoin1D,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+!! DK DK added this for merged version
+ if(npoin1D > NGLOB1D_RADIAL_MAX) stop 'DK DK error merged NGLOB1D_RADIAL_MAX'
+
+ do ipoin1D=1,npoin1D
+!! DK DK suppressed merged write(10,*) ibool_selected(ipoin1D), xstore_selected(ipoin1D), &
+!! DK DK suppressed merged ystore_selected(ipoin1D),zstore_selected(ipoin1D)
+!! DK DK added this for merged
+ ibool1D_rightxi_righteta(ipoin1D) = ibool_selected(ipoin1D)
+ xread1D_rightxi_righteta(ipoin1D) = xstore_selected(ipoin1D)
+ yread1D_rightxi_righteta(ipoin1D) = ystore_selected(ipoin1D)
+ zread1D_rightxi_righteta(ipoin1D) = zstore_selected(ipoin1D)
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+!! DK DK suppressed merged write(10,*) npoin1D
+
+!! DK DK suppressed merged close(10)
+
+! compare number of edge elements and points detected to analytical value
+ if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,3) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,3)) &
+ call exit_MPI(myrank,'error MPI 1D buffer detection in xi=right')
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ deallocate(ibool_selected)
+ deallocate(xstore_selected)
+ deallocate(ystore_selected)
+ deallocate(zstore_selected)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iglob)
+ deallocate(locval)
+ deallocate(ifseg)
+ deallocate(iwork)
+ deallocate(work)
+ endif
+
+ end subroutine get_MPI_1D_buffers
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_eta.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_eta.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_eta.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,267 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_MPI_cutplanes_eta(myrank,nspec,iMPIcut_eta,ibool, &
+ xstore,ystore,zstore,mask_ibool,npointot, &
+ NSPEC2D_XI_FACE,iregion,NGLOB2DMAX_XY,nglob_ori,iboolleft_eta,iboolright_eta,NGLOB2DMAX_YMIN_YMAX,npoin2D_eta)
+
+! this routine detects cut planes along eta
+! In principle the left cut plane of the first slice
+! and the right cut plane of the last slice are not used
+! in the solver except if we want to have periodic conditions
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: NGLOB2DMAX_YMIN_YMAX
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
+
+ integer nspec,myrank,nglob_ori,nglob,ipoin2D,NGLOB2DMAX_XY,iregion
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE
+
+ logical iMPIcut_eta(2,nspec)
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! logical mask used to create arrays iboolleft_eta and iboolright_eta
+ integer npointot
+ logical mask_ibool(npointot)
+
+! global element numbering
+ integer ispec
+
+! MPI cut-plane element numbering
+ integer ispecc1,ispecc2,npoin2D_eta,ix,iy,iz
+ integer nspec2Dtheor
+
+! arrays for sorting routine
+ integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: work
+ integer, dimension(:), allocatable :: ibool_selected
+ double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
+
+
+! allocate arrays for message buffers with maximum size
+! define maximum size for message buffers
+ if (PERFORM_CUTHILL_MCKEE) then
+ allocate(ibool_selected(NGLOB2DMAX_XY))
+ allocate(xstore_selected(NGLOB2DMAX_XY))
+ allocate(ystore_selected(NGLOB2DMAX_XY))
+ allocate(zstore_selected(NGLOB2DMAX_XY))
+ allocate(ind(NGLOB2DMAX_XY))
+ allocate(ninseg(NGLOB2DMAX_XY))
+ allocate(iglob(NGLOB2DMAX_XY))
+ allocate(locval(NGLOB2DMAX_XY))
+ allocate(ifseg(NGLOB2DMAX_XY))
+ allocate(iwork(NGLOB2DMAX_XY))
+ allocate(work(NGLOB2DMAX_XY))
+ endif
+
+! theoretical number of surface elements in the buffers
+! cut planes along eta=constant correspond to XI faces
+ nspec2Dtheor = NSPEC2D_XI_FACE(iregion,1)
+
+! write the MPI buffers for the left and right edges of the slice
+! and the position of the points to check that the buffers are fine
+
+!
+! determine if the element falls on the left MPI cut plane
+!
+
+! global point number and coordinates left MPI cut-plane
+!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'iboolleft_eta.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin2D_eta = 0
+
+! nb of elements in this cut-plane
+ ispecc1=0
+
+ do ispec=1,nspec
+ if(iMPIcut_eta(1,ispec)) then
+ ispecc1=ispecc1+1
+ ! loop on all the points in that 2-D element, including edges
+ iy = 1
+ do ix=1,NGLLX
+ do iz=1,NGLLZ
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_eta = npoin2D_eta + 1
+!! DK DK added this for merged
+ if(npoin2D_eta > NGLOB2DMAX_YMIN_YMAX) stop 'DK DK error points merged'
+ if (PERFORM_CUTHILL_MCKEE) then
+ ibool_selected(npoin2D_eta) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin2D_eta) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin2D_eta) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin2D_eta) = zstore(ix,iy,iz,ispec)
+ else
+!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+!! DK DK added this for merged
+!! DK DK merged ces deux tableaux sont les memes donc on pourrait n'en declarer qu'un seul
+!! DK DK merged mais en fait non car on le reutilise ci-dessous pour ibool_right
+ iboolleft_eta(npoin2D_eta) = ibool(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+ nglob=nglob_ori
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_array_coordinates(npoin2D_eta,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+!! DK DK added this for merged
+ if(npoin2D_eta > NGLOB2DMAX_YMIN_YMAX) stop 'DK DK error points merged'
+
+ do ipoin2D=1,npoin2D_eta
+!! DK DK suppressed merged write(10,*) ibool_selected(ipoin2D), xstore_selected(ipoin2D), &
+!! DK DK suppressed merged ystore_selected(ipoin2D),zstore_selected(ipoin2D)
+!! DK DK added this for merged
+!! DK DK merged ces deux tableaux sont les memes donc on pourrait n'en declarer qu'un seul
+!! DK DK merged mais en fait non car on le reutilise ci-dessous pour ibool_right
+ iboolleft_eta(ipoin2D) = ibool_selected(ipoin2D)
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+!! DK DK suppressed merged write(10,*) npoin2D_eta
+
+!! DK DK suppressed merged close(10)
+
+! compare number of surface elements detected to analytical value
+ if(ispecc1 /= nspec2Dtheor) call exit_MPI(myrank,'error MPI cut-planes detection in eta=left')
+
+!
+! determine if the element falls on the right MPI cut plane
+!
+ nspec2Dtheor = NSPEC2D_XI_FACE(iregion,2)
+
+! global point number and coordinates right MPI cut-plane
+!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'iboolright_eta.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin2D_eta = 0
+
+! nb of elements in this cut-plane
+ ispecc2=0
+
+ do ispec=1,nspec
+ if(iMPIcut_eta(2,ispec)) then
+ ispecc2=ispecc2+1
+ ! loop on all the points in that 2-D element, including edges
+ iy = NGLLY
+ do ix=1,NGLLX
+ do iz=1,NGLLZ
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_eta = npoin2D_eta + 1
+!! DK DK added this for merged
+ if(npoin2D_eta > NGLOB2DMAX_YMIN_YMAX) stop 'DK DK error points merged'
+ if (PERFORM_CUTHILL_MCKEE) then
+ ibool_selected(npoin2D_eta) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin2D_eta) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin2D_eta) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin2D_eta) = zstore(ix,iy,iz,ispec)
+ else
+!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+!! DK DK added this for merged
+!! DK DK merged ces deux tableaux sont les memes donc on pourrait n'en declarer qu'un seul
+!! DK DK merged mais en fait non car on le reutilise ci-dessous pour ibool_right
+ iboolright_eta(npoin2D_eta) = ibool(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+ nglob=nglob_ori
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_array_coordinates(npoin2D_eta,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+!! DK DK added this for merged
+ if(npoin2D_eta > NGLOB2DMAX_YMIN_YMAX) stop 'DK DK error points merged'
+
+ do ipoin2D=1,npoin2D_eta
+!! DK DK suppressed merged write(10,*) ibool_selected(ipoin2D), xstore_selected(ipoin2D), &
+!! DK DK suppressed merged ystore_selected(ipoin2D),zstore_selected(ipoin2D)
+!! DK DK added this for merged
+!! DK DK merged ces deux tableaux sont les memes donc on pourrait n'en declarer qu'un seul
+!! DK DK merged mais en fait non car on le reutilise ci-dessous pour ibool_right
+ iboolright_eta(ipoin2D) = ibool_selected(ipoin2D)
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+!! DK DK suppressed merged write(10,*) npoin2D_eta
+
+!! DK DK suppressed merged close(10)
+
+! compare number of surface elements detected to analytical value
+ if(ispecc2 /= nspec2Dtheor) call exit_MPI(myrank,'error MPI cut-planes detection in eta=right')
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ deallocate(ibool_selected)
+ deallocate(xstore_selected)
+ deallocate(ystore_selected)
+ deallocate(zstore_selected)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iglob)
+ deallocate(locval)
+ deallocate(ifseg)
+ deallocate(iwork)
+ deallocate(work)
+ endif
+
+ end subroutine get_MPI_cutplanes_eta
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_xi.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_xi.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_MPI_cutplanes_xi.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,266 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_MPI_cutplanes_xi(myrank,nspec,iMPIcut_xi,ibool, &
+ xstore,ystore,zstore,mask_ibool,npointot, &
+ NSPEC2D_ETA_FACE,iregion,NGLOB2DMAX_XY,nglob_ori,iboolleft_xi,iboolright_xi,NGLOB2DMAX_XMIN_XMAX,npoin2D_xi)
+
+! this routine detects cut planes along xi
+! In principle the left cut plane of the first slice
+! and the right cut plane of the last slice are not used
+! in the solver except if we want to have periodic conditions
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: NGLOB2DMAX_XMIN_XMAX
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
+
+ integer nspec,myrank,nglob_ori,nglob,ipoin2D,iregion
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_ETA_FACE
+
+ logical iMPIcut_xi(2,nspec)
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! logical mask used to create arrays iboolleft_xi and iboolright_xi
+ integer npointot
+ logical mask_ibool(npointot)
+
+! global element numbering
+ integer ispec
+
+! MPI cut-plane element numbering
+ integer ispecc1,ispecc2,npoin2D_xi,ix,iy,iz
+ integer nspec2Dtheor
+
+ character(len=150) errmsg
+
+! arrays for sorting routine
+ integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: work
+ integer NGLOB2DMAX_XY
+ integer, dimension(:), allocatable :: ibool_selected
+ double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
+
+! allocate arrays for message buffers with maximum size
+! define maximum size for message buffers
+ if (PERFORM_CUTHILL_MCKEE) then
+ allocate(ibool_selected(NGLOB2DMAX_XY))
+ allocate(xstore_selected(NGLOB2DMAX_XY))
+ allocate(ystore_selected(NGLOB2DMAX_XY))
+ allocate(zstore_selected(NGLOB2DMAX_XY))
+ allocate(ind(NGLOB2DMAX_XY))
+ allocate(ninseg(NGLOB2DMAX_XY))
+ allocate(iglob(NGLOB2DMAX_XY))
+ allocate(locval(NGLOB2DMAX_XY))
+ allocate(ifseg(NGLOB2DMAX_XY))
+ allocate(iwork(NGLOB2DMAX_XY))
+ allocate(work(NGLOB2DMAX_XY))
+ endif
+
+
+! theoretical number of surface elements in the buffers
+! cut planes along xi=constant correspond to ETA faces
+ nspec2Dtheor = NSPEC2D_ETA_FACE(iregion,1)
+! write the MPI buffers for the left and right edges of the slice
+! and the position of the points to check that the buffers are fine
+
+!
+! determine if the element falls on the left MPI cut plane
+!
+
+! global point number and coordinates left MPI cut-plane
+!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'iboolleft_xi.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin2D_xi = 0
+
+! nb of elements in this cut-plane
+ ispecc1=0
+
+ do ispec=1,nspec
+ if(iMPIcut_xi(1,ispec)) then
+ ispecc1=ispecc1+1
+ ! loop on all the points in that 2-D element, including edges
+ ix = 1
+ do iy=1,NGLLY
+ do iz=1,NGLLZ
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_xi = npoin2D_xi + 1
+!! DK DK added this for merged
+ if(npoin2D_xi > NGLOB2DMAX_XMIN_XMAX) stop 'DK DK error points merged'
+ if (PERFORM_CUTHILL_MCKEE) then
+ ibool_selected(npoin2D_xi) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin2D_xi) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin2D_xi) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin2D_xi) = zstore(ix,iy,iz,ispec)
+ else
+!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+!! DK DK added this for merged
+ iboolleft_xi(npoin2D_xi) = ibool(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+ nglob=nglob_ori
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_array_coordinates(npoin2D_xi,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+!! DK DK added this for merged
+ if(npoin2D_xi > NGLOB2DMAX_XMIN_XMAX) stop 'DK DK error points merged'
+
+ do ipoin2D=1,npoin2D_xi
+!! DK DK suppressed merged write(10,*) ibool_selected(ipoin2D), xstore_selected(ipoin2D), &
+!! DK DK suppressed merged ystore_selected(ipoin2D),zstore_selected(ipoin2D)
+!! DK DK added this for merged
+!! DK DK merged ces deux tableaux sont les memes donc on pourrait n'en declarer qu'un seul
+!! DK DK merged mais en fait non car on le reutilise ci-dessous pour ibool_right
+ iboolleft_xi(ipoin2D) = ibool_selected(ipoin2D)
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+!! DK DK suppressed merged write(10,*) npoin2D_xi
+
+!! DK DK suppressed merged close(10)
+
+! compare number of surface elements detected to analytical value
+ if(ispecc1 /= nspec2Dtheor) then
+ write(errmsg,*) 'error MPI cut-planes detection in xi=left T=',nspec2Dtheor,' C=',ispecc1
+ call exit_MPI(myrank,errmsg)
+ endif
+!
+! determine if the element falls on the right MPI cut plane
+!
+ nspec2Dtheor = NSPEC2D_ETA_FACE(iregion,2)
+
+! global point number and coordinates right MPI cut-plane
+!! DK DK suppressed merged open(unit=10,file=prname(1:len_trim(prname))//'iboolright_xi.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin2D_xi = 0
+
+! nb of elements in this cut-plane
+ ispecc2=0
+
+ do ispec=1,nspec
+ if(iMPIcut_xi(2,ispec)) then
+ ispecc2=ispecc2+1
+ ! loop on all the points in that 2-D element, including edges
+ ix = NGLLX
+ do iy=1,NGLLY
+ do iz=1,NGLLZ
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_xi = npoin2D_xi + 1
+!! DK DK added this for merged
+ if(npoin2D_xi > NGLOB2DMAX_XMIN_XMAX) stop 'DK DK error points merged'
+ if (PERFORM_CUTHILL_MCKEE) then
+ ibool_selected(npoin2D_xi) = ibool(ix,iy,iz,ispec)
+ xstore_selected(npoin2D_xi) = xstore(ix,iy,iz,ispec)
+ ystore_selected(npoin2D_xi) = ystore(ix,iy,iz,ispec)
+ zstore_selected(npoin2D_xi) = zstore(ix,iy,iz,ispec)
+ else
+!! DK DK suppressed merged write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
+!! DK DK suppressed merged ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ iboolright_xi(npoin2D_xi) = ibool(ix,iy,iz,ispec)
+ endif
+ endif
+ enddo
+ enddo
+ endif
+ enddo
+
+ nglob=nglob_ori
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_array_coordinates(npoin2D_xi,xstore_selected,ystore_selected,zstore_selected, &
+ ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+
+!! DK DK added this for merged
+ if(npoin2D_xi > NGLOB2DMAX_XMIN_XMAX) stop 'DK DK error points merged'
+
+ do ipoin2D=1,npoin2D_xi
+!! DK DK suppressed merged write(10,*) ibool_selected(ipoin2D), xstore_selected(ipoin2D), &
+!! DK DK suppressed merged ystore_selected(ipoin2D),zstore_selected(ipoin2D)
+ iboolright_xi(ipoin2D) = ibool_selected(ipoin2D)
+ enddo
+ endif
+
+! put flag to indicate end of the list of points
+!! DK DK suppressed merged write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+!! DK DK suppressed merged write(10,*) npoin2D_xi
+
+!! DK DK suppressed merged close(10)
+
+! compare number of surface elements detected to analytical value
+ if(ispecc2 /= nspec2Dtheor) then
+ write(errmsg,*) 'error MPI cut-planes detection in xi=right T=',nspec2Dtheor,' C=',ispecc2
+ call exit_MPI(myrank,errmsg)
+ endif
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ deallocate(ibool_selected)
+ deallocate(xstore_selected)
+ deallocate(ystore_selected)
+ deallocate(zstore_selected)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iglob)
+ deallocate(locval)
+ deallocate(ifseg)
+ deallocate(iwork)
+ deallocate(work)
+ endif
+
+ end subroutine get_MPI_cutplanes_xi
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_cmt.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_cmt.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_cmt.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/get_ellipticity.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_ellipticity.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_ellipticity.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/get_event_info.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_event_info.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_event_info.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,193 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! get information about event name and location for SAC seismograms: MPI version by Dimitri Komatitsch
+
+ subroutine get_event_info_parallel(myrank,yr,jda,ho,mi,sec,t_cmt, &
+ elat,elon,depth,mb,ename,cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+
+!--- input or output arguments of the subroutine below
+
+ integer, intent(in) :: myrank
+
+ integer, intent(out) :: NSOURCES,yr,jda,ho,mi
+ real, intent(out) :: mb
+ double precision, intent(out) :: t_cmt,elat,elon,depth,cmt_lat,cmt_lon,cmt_depth,cmt_hdur,sec
+ character(len=12), intent(out) :: ename
+
+!--- local variables below
+
+ integer i,ier
+
+ integer, parameter :: LENGTH_REGION_NAME = 150
+ character(len=LENGTH_REGION_NAME) region
+
+! get event information for SAC header on the master
+ if(myrank == 0) then
+
+ call get_event_info_serial(yr,jda,ho,mi,sec,t_cmt,elat,elon,depth,mb,region, &
+ cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES,LENGTH_REGION_NAME)
+
+! create the event name
+ write(ename(1:12),'(a12)') region(1:12)
+
+! replace white spaces with underscores in event name
+ do i=1,len_trim(ename)
+ if (ename(i:i) == ' ') ename(i:i) = '_'
+ enddo
+
+ endif
+
+! broadcast the information read on the master to the nodes
+ call MPI_BCAST(yr,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(jda,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ho,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(mi,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSOURCES,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(sec,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(t_cmt,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(elat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(elon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(depth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(cmt_lat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(cmt_lon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(cmt_depth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(cmt_hdur,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(ename,12,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+
+ end subroutine get_event_info_parallel
+
+!=====================================================================
+
+! get information about event name and location for SAC seismograms: MPI version by Bernhard Schuberth
+! This subroutine reads the first line of the DATA/CMTSOLUTION file
+! and extracts event information needed for SAC or PITSA headers
+
+ subroutine get_event_info_serial(yr,jda,ho,mi,sec,t_cmt,elat,elon,depth,mb,region,&
+ cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES,LENGTH_REGION_NAME)
+
+ implicit none
+
+ include "constants.h"
+
+!--- arguments of the subroutine below
+
+ integer, intent(out) :: NSOURCES,yr,jda,ho,mi
+
+ real, intent(out) :: mb
+
+ double precision, intent(out) :: sec,t_cmt,elat,elon,depth,cmt_lat,cmt_lon,cmt_depth,cmt_hdur
+
+ integer, intent(in) :: LENGTH_REGION_NAME
+ character(len=LENGTH_REGION_NAME), intent(out) :: region ! event name for SAC header
+
+!--- local variables here
+
+ integer ios,icounter,mo,da,julian_day
+
+ real ms
+
+ character(len=5) datasource
+ character(len=150) string,dummystring,CMTSOLUTION
+
+!
+!---- read hypocenter info
+!
+ call get_value_string(CMTSOLUTION, 'solver.CMTSOLUTION','DATA/CMTSOLUTION')
+
+ open(unit=821,file=CMTSOLUTION,iostat=ios,status='old',action='read')
+ if(ios /= 0) stop 'error opening CMTSOLUTION file (in get_event_info_serial)'
+
+ icounter = 0
+ do while(ios == 0)
+ read(821,"(a)",iostat=ios) dummystring
+ if(ios == 0) icounter = icounter + 1
+ enddo
+ close(821)
+ if(mod(icounter,NLINES_PER_CMTSOLUTION_SOURCE) /= 0) &
+ stop 'total number of lines in CMTSOLUTION file should be a multiple of NLINES_PER_CMTSOLUTION_SOURCE'
+ NSOURCES = icounter / NLINES_PER_CMTSOLUTION_SOURCE
+ if(NSOURCES < 1) stop 'need at least one source in CMTSOLUTION file'
+
+ open(unit=821,file=CMTSOLUTION,status='old',action='read')
+
+ ! example header line of CMTSOLUTION file
+ !PDE 2003 09 25 19 50 08.93 41.78 144.08 18.0 7.9 8.0 Hokkaido, Japan
+ !event_id, date,origin time,latitude,longitude,depth, mb, MS, region
+
+ ! read header with event information
+ read(821,*) datasource,yr,mo,da,ho,mi,sec,elat,elon,depth,mb,ms,region
+
+ jda=julian_day(yr,mo,da)
+
+ ! ignore line with event name
+ read(821,"(a)") string
+
+ ! read time shift
+ read(821,"(a)") string
+ read(string(12:len_trim(string)),*) t_cmt
+
+ if (NSOURCES == 1) then
+
+ ! read half duration
+ read(821,"(a)") string
+ read(string(15:len_trim(string)),*) cmt_hdur
+
+ ! read latitude
+ read(821,"(a)") string
+ read(string(10:len_trim(string)),*) cmt_lat
+
+ ! read longitude
+ read(821,"(a)") string
+ read(string(11:len_trim(string)),*) cmt_lon
+
+ ! read depth
+ read(821,"(a)") string
+ read(string(7:len_trim(string)),*) cmt_depth
+
+ else
+
+ cmt_hdur=-1e8
+ cmt_lat=-1e8
+ cmt_lon=-1e8
+ cmt_depth=-1e8
+
+ endif
+
+ close(821)
+
+ end subroutine get_event_info_serial
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_global.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_global.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_global.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/get_jacobian_boundaries.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_jacobian_boundaries.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_jacobian_boundaries.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,541 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ jacobian2D_xmin,jacobian2D_xmax, &
+ jacobian2D_ymin,jacobian2D_ymax, &
+ jacobian2D_bottom,jacobian2D_top, &
+ normal_xmin,normal_xmax, &
+ normal_ymin,normal_ymax, &
+ normal_bottom,normal_top, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank
+ integer NSPEC2D_BOTTOM,NSPEC2D_TOP,NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
+
+ integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
+ integer ibelm_xmin(NSPEC2DMAX_XMIN_XMAX),ibelm_xmax(NSPEC2DMAX_XMIN_XMAX)
+ integer ibelm_ymin(NSPEC2DMAX_YMIN_YMAX),ibelm_ymax(NSPEC2DMAX_YMIN_YMAX)
+ integer ibelm_bottom(NSPEC2D_BOTTOM),ibelm_top(NSPEC2D_TOP)
+
+ logical iboun(6,nspec)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+ real(kind=CUSTOM_REAL) jacobian2D_xmin(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ real(kind=CUSTOM_REAL) jacobian2D_xmax(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ real(kind=CUSTOM_REAL) jacobian2D_ymin(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ real(kind=CUSTOM_REAL) jacobian2D_ymax(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ real(kind=CUSTOM_REAL) jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM)
+ real(kind=CUSTOM_REAL) jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP)
+
+ real(kind=CUSTOM_REAL) normal_xmin(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ real(kind=CUSTOM_REAL) normal_xmax(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+ real(kind=CUSTOM_REAL) normal_ymin(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ real(kind=CUSTOM_REAL) normal_ymax(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+ real(kind=CUSTOM_REAL) normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM)
+ real(kind=CUSTOM_REAL) normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP)
+
+ double precision dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ)
+ double precision dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ)
+ double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY)
+ double precision dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY)
+
+! global element numbering
+ integer ispec
+
+! counters to keep track of number of elements on each of the boundaries
+ integer ispecb1,ispecb2,ispecb3,ispecb4,ispecb5,ispecb6
+
+ double precision xelm(NGNOD2D),yelm(NGNOD2D),zelm(NGNOD2D)
+
+! check that the parameter file is correct
+ if(NGNOD /= 27) call exit_MPI(myrank,'elements should have 27 control nodes')
+ if(NGNOD2D /= 9) call exit_MPI(myrank,'surface elements should have 9 control nodes')
+
+ ispecb1 = 0
+ ispecb2 = 0
+ ispecb3 = 0
+ ispecb4 = 0
+ ispecb5 = 0
+ ispecb6 = 0
+
+ do ispec=1,nspec
+
+! determine if the element falls on a boundary
+
+! on boundary: xmin
+
+ if(iboun(1,ispec)) then
+
+ ispecb1=ispecb1+1
+ ibelm_xmin(ispecb1)=ispec
+
+! specify the 9 nodes for the 2-D boundary element
+ xelm(1)=xstore(1,1,1,ispec)
+ yelm(1)=ystore(1,1,1,ispec)
+ zelm(1)=zstore(1,1,1,ispec)
+ xelm(2)=xstore(1,NGLLY,1,ispec)
+ yelm(2)=ystore(1,NGLLY,1,ispec)
+ zelm(2)=zstore(1,NGLLY,1,ispec)
+ xelm(3)=xstore(1,NGLLY,NGLLZ,ispec)
+ yelm(3)=ystore(1,NGLLY,NGLLZ,ispec)
+ zelm(3)=zstore(1,NGLLY,NGLLZ,ispec)
+ xelm(4)=xstore(1,1,NGLLZ,ispec)
+ yelm(4)=ystore(1,1,NGLLZ,ispec)
+ zelm(4)=zstore(1,1,NGLLZ,ispec)
+ xelm(5)=xstore(1,(NGLLY+1)/2,1,ispec)
+ yelm(5)=ystore(1,(NGLLY+1)/2,1,ispec)
+ zelm(5)=zstore(1,(NGLLY+1)/2,1,ispec)
+ xelm(6)=xstore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ yelm(6)=ystore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ zelm(6)=zstore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ xelm(7)=xstore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ yelm(7)=ystore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ zelm(7)=zstore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ xelm(8)=xstore(1,1,(NGLLZ+1)/2,ispec)
+ yelm(8)=ystore(1,1,(NGLLZ+1)/2,ispec)
+ zelm(8)=zstore(1,1,(NGLLZ+1)/2,ispec)
+ xelm(9)=xstore(1,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+ yelm(9)=ystore(1,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+ zelm(9)=zstore(1,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb1,xelm,yelm,zelm,dershape2D_x, &
+ jacobian2D_xmin,normal_xmin,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_arrays_for_cuthill (ispecb1,xstore,ystore,zstore,ibelm_xmin,normal_xmin,&
+ jacobian2D_xmin,NSPEC2DMAX_XMIN_XMAX,NGLLY,NGLLZ,nspec)
+ endif
+ endif
+
+! on boundary: xmax
+
+ if(iboun(2,ispec)) then
+
+ ispecb2=ispecb2+1
+ ibelm_xmax(ispecb2)=ispec
+
+! specify the 9 nodes for the 2-D boundary element
+ xelm(1)=xstore(NGLLX,1,1,ispec)
+ yelm(1)=ystore(NGLLX,1,1,ispec)
+ zelm(1)=zstore(NGLLX,1,1,ispec)
+ xelm(2)=xstore(NGLLX,NGLLY,1,ispec)
+ yelm(2)=ystore(NGLLX,NGLLY,1,ispec)
+ zelm(2)=zstore(NGLLX,NGLLY,1,ispec)
+ xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
+ yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
+ zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
+ xelm(4)=xstore(NGLLX,1,NGLLZ,ispec)
+ yelm(4)=ystore(NGLLX,1,NGLLZ,ispec)
+ zelm(4)=zstore(NGLLX,1,NGLLZ,ispec)
+ xelm(5)=xstore(NGLLX,(NGLLY+1)/2,1,ispec)
+ yelm(5)=ystore(NGLLX,(NGLLY+1)/2,1,ispec)
+ zelm(5)=zstore(NGLLX,(NGLLY+1)/2,1,ispec)
+ xelm(6)=xstore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ yelm(6)=ystore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ zelm(6)=zstore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ xelm(7)=xstore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ yelm(7)=ystore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ zelm(7)=zstore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ xelm(8)=xstore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ yelm(8)=ystore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ zelm(8)=zstore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ xelm(9)=xstore(NGLLX,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+ yelm(9)=ystore(NGLLX,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+ zelm(9)=zstore(NGLLX,(NGLLY+1)/2,(NGLLZ+1)/2,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb2,xelm,yelm,zelm,dershape2D_x, &
+ jacobian2D_xmax,normal_xmax,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_arrays_for_cuthill (ispecb2,xstore,ystore,zstore,ibelm_xmax,normal_xmax,&
+ jacobian2D_xmax,NSPEC2DMAX_XMIN_XMAX,NGLLY,NGLLZ,nspec)
+ endif
+ endif
+
+! on boundary: ymin
+
+ if(iboun(3,ispec)) then
+
+ ispecb3=ispecb3+1
+ ibelm_ymin(ispecb3)=ispec
+
+! specify the 9 nodes for the 2-D boundary element
+ xelm(1)=xstore(1,1,1,ispec)
+ yelm(1)=ystore(1,1,1,ispec)
+ zelm(1)=zstore(1,1,1,ispec)
+ xelm(2)=xstore(NGLLX,1,1,ispec)
+ yelm(2)=ystore(NGLLX,1,1,ispec)
+ zelm(2)=zstore(NGLLX,1,1,ispec)
+ xelm(3)=xstore(NGLLX,1,NGLLZ,ispec)
+ yelm(3)=ystore(NGLLX,1,NGLLZ,ispec)
+ zelm(3)=zstore(NGLLX,1,NGLLZ,ispec)
+ xelm(4)=xstore(1,1,NGLLZ,ispec)
+ yelm(4)=ystore(1,1,NGLLZ,ispec)
+ zelm(4)=zstore(1,1,NGLLZ,ispec)
+ xelm(5)=xstore((NGLLX+1)/2,1,1,ispec)
+ yelm(5)=ystore((NGLLX+1)/2,1,1,ispec)
+ zelm(5)=zstore((NGLLX+1)/2,1,1,ispec)
+ xelm(6)=xstore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ yelm(6)=ystore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ zelm(6)=zstore(NGLLX,1,(NGLLZ+1)/2,ispec)
+ xelm(7)=xstore((NGLLX+1)/2,1,NGLLZ,ispec)
+ yelm(7)=ystore((NGLLX+1)/2,1,NGLLZ,ispec)
+ zelm(7)=zstore((NGLLX+1)/2,1,NGLLZ,ispec)
+ xelm(8)=xstore(1,1,(NGLLZ+1)/2,ispec)
+ yelm(8)=ystore(1,1,(NGLLZ+1)/2,ispec)
+ zelm(8)=zstore(1,1,(NGLLZ+1)/2,ispec)
+ xelm(9)=xstore((NGLLX+1)/2,1,(NGLLZ+1)/2,ispec)
+ yelm(9)=ystore((NGLLX+1)/2,1,(NGLLZ+1)/2,ispec)
+ zelm(9)=zstore((NGLLX+1)/2,1,(NGLLZ+1)/2,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb3,xelm,yelm,zelm,dershape2D_y, &
+ jacobian2D_ymin,normal_ymin,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_arrays_for_cuthill (ispecb3,xstore,ystore,zstore,ibelm_ymin,normal_ymin,&
+ jacobian2D_ymin,NSPEC2DMAX_YMIN_YMAX,NGLLX,NGLLZ,nspec)
+ endif
+ endif
+
+! on boundary: ymax
+
+ if(iboun(4,ispec)) then
+
+ ispecb4=ispecb4+1
+ ibelm_ymax(ispecb4)=ispec
+
+! specify the 9 nodes for the 2-D boundary element
+ xelm(1)=xstore(1,NGLLY,1,ispec)
+ yelm(1)=ystore(1,NGLLY,1,ispec)
+ zelm(1)=zstore(1,NGLLY,1,ispec)
+ xelm(2)=xstore(NGLLX,NGLLY,1,ispec)
+ yelm(2)=ystore(NGLLX,NGLLY,1,ispec)
+ zelm(2)=zstore(NGLLX,NGLLY,1,ispec)
+ xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
+ yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
+ zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
+ xelm(4)=xstore(1,NGLLY,NGLLZ,ispec)
+ yelm(4)=ystore(1,NGLLY,NGLLZ,ispec)
+ zelm(4)=zstore(1,NGLLY,NGLLZ,ispec)
+ xelm(5)=xstore((NGLLX+1)/2,NGLLY,1,ispec)
+ yelm(5)=ystore((NGLLX+1)/2,NGLLY,1,ispec)
+ zelm(5)=zstore((NGLLX+1)/2,NGLLY,1,ispec)
+ xelm(6)=xstore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ yelm(6)=ystore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ zelm(6)=zstore(NGLLX,NGLLY,(NGLLZ+1)/2,ispec)
+ xelm(7)=xstore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ yelm(7)=ystore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ zelm(7)=zstore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ xelm(8)=xstore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ yelm(8)=ystore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ zelm(8)=zstore(1,NGLLY,(NGLLZ+1)/2,ispec)
+ xelm(9)=xstore((NGLLX+1)/2,NGLLY,(NGLLZ+1)/2,ispec)
+ yelm(9)=ystore((NGLLX+1)/2,NGLLY,(NGLLZ+1)/2,ispec)
+ zelm(9)=zstore((NGLLX+1)/2,NGLLY,(NGLLZ+1)/2,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb4,xelm,yelm,zelm,dershape2D_y, &
+ jacobian2D_ymax,normal_ymax,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_arrays_for_cuthill (ispecb4,xstore,ystore,zstore,ibelm_ymax,normal_ymax,&
+ jacobian2D_ymax,NSPEC2DMAX_YMIN_YMAX,NGLLX,NGLLZ,nspec)
+ endif
+ endif
+
+! on boundary: bottom
+
+ if(iboun(5,ispec)) then
+
+ ispecb5=ispecb5+1
+ ibelm_bottom(ispecb5)=ispec
+
+ xelm(1)=xstore(1,1,1,ispec)
+ yelm(1)=ystore(1,1,1,ispec)
+ zelm(1)=zstore(1,1,1,ispec)
+ xelm(2)=xstore(NGLLX,1,1,ispec)
+ yelm(2)=ystore(NGLLX,1,1,ispec)
+ zelm(2)=zstore(NGLLX,1,1,ispec)
+ xelm(3)=xstore(NGLLX,NGLLY,1,ispec)
+ yelm(3)=ystore(NGLLX,NGLLY,1,ispec)
+ zelm(3)=zstore(NGLLX,NGLLY,1,ispec)
+ xelm(4)=xstore(1,NGLLY,1,ispec)
+ yelm(4)=ystore(1,NGLLY,1,ispec)
+ zelm(4)=zstore(1,NGLLY,1,ispec)
+ xelm(5)=xstore((NGLLX+1)/2,1,1,ispec)
+ yelm(5)=ystore((NGLLX+1)/2,1,1,ispec)
+ zelm(5)=zstore((NGLLX+1)/2,1,1,ispec)
+ xelm(6)=xstore(NGLLX,(NGLLY+1)/2,1,ispec)
+ yelm(6)=ystore(NGLLX,(NGLLY+1)/2,1,ispec)
+ zelm(6)=zstore(NGLLX,(NGLLY+1)/2,1,ispec)
+ xelm(7)=xstore((NGLLX+1)/2,NGLLY,1,ispec)
+ yelm(7)=ystore((NGLLX+1)/2,NGLLY,1,ispec)
+ zelm(7)=zstore((NGLLX+1)/2,NGLLY,1,ispec)
+ xelm(8)=xstore(1,(NGLLY+1)/2,1,ispec)
+ yelm(8)=ystore(1,(NGLLY+1)/2,1,ispec)
+ zelm(8)=zstore(1,(NGLLY+1)/2,1,ispec)
+ xelm(9)=xstore((NGLLX+1)/2,(NGLLY+1)/2,1,ispec)
+ yelm(9)=ystore((NGLLX+1)/2,(NGLLY+1)/2,1,ispec)
+ zelm(9)=zstore((NGLLX+1)/2,(NGLLY+1)/2,1,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb5,xelm,yelm,zelm,dershape2D_bottom, &
+ jacobian2D_bottom,normal_bottom,NGLLX,NGLLY,NSPEC2D_BOTTOM)
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_arrays_for_cuthill (ispecb5,xstore,ystore,zstore,ibelm_bottom,normal_bottom,&
+ jacobian2D_bottom,NSPEC2D_BOTTOM,NGLLX,NGLLY,nspec)
+ endif
+ endif
+
+! on boundary: top
+
+ if(iboun(6,ispec)) then
+
+ ispecb6=ispecb6+1
+ ibelm_top(ispecb6)=ispec
+
+ xelm(1)=xstore(1,1,NGLLZ,ispec)
+ yelm(1)=ystore(1,1,NGLLZ,ispec)
+ zelm(1)=zstore(1,1,NGLLZ,ispec)
+ xelm(2)=xstore(NGLLX,1,NGLLZ,ispec)
+ yelm(2)=ystore(NGLLX,1,NGLLZ,ispec)
+ zelm(2)=zstore(NGLLX,1,NGLLZ,ispec)
+ xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
+ yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
+ zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
+ xelm(4)=xstore(1,NGLLY,NGLLZ,ispec)
+ yelm(4)=ystore(1,NGLLY,NGLLZ,ispec)
+ zelm(4)=zstore(1,NGLLY,NGLLZ,ispec)
+ xelm(5)=xstore((NGLLX+1)/2,1,NGLLZ,ispec)
+ yelm(5)=ystore((NGLLX+1)/2,1,NGLLZ,ispec)
+ zelm(5)=zstore((NGLLX+1)/2,1,NGLLZ,ispec)
+ xelm(6)=xstore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ yelm(6)=ystore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ zelm(6)=zstore(NGLLX,(NGLLY+1)/2,NGLLZ,ispec)
+ xelm(7)=xstore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ yelm(7)=ystore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ zelm(7)=zstore((NGLLX+1)/2,NGLLY,NGLLZ,ispec)
+ xelm(8)=xstore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ yelm(8)=ystore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ zelm(8)=zstore(1,(NGLLY+1)/2,NGLLZ,ispec)
+ xelm(9)=xstore((NGLLX+1)/2,(NGLLY+1)/2,NGLLZ,ispec)
+ yelm(9)=ystore((NGLLX+1)/2,(NGLLY+1)/2,NGLLZ,ispec)
+ zelm(9)=zstore((NGLLX+1)/2,(NGLLY+1)/2,NGLLZ,ispec)
+
+ call compute_jacobian_2D(myrank,ispecb6,xelm,yelm,zelm,dershape2D_top, &
+ jacobian2D_top,normal_top,NGLLX,NGLLY,NSPEC2D_TOP)
+
+ if (PERFORM_CUTHILL_MCKEE) then
+ call sort_arrays_for_cuthill (ispecb6,xstore,ystore,zstore,ibelm_top,normal_top,&
+ jacobian2D_top,NSPEC2D_TOP,NGLLX,NGLLY,nspec)
+ endif
+ endif
+
+ enddo
+
+
+! check theoretical value of elements at the bottom
+ if(ispecb5 /= NSPEC2D_BOTTOM) then
+ call exit_MPI(myrank,'ispecb5 should equal NSPEC2D_BOTTOM')
+ endif
+
+! check theoretical value of elements at the top
+ if(ispecb6 /= NSPEC2D_TOP) call exit_MPI(myrank,'ispecb6 should equal NSPEC2D_TOP')
+
+ nspec2D_xmin = ispecb1
+ nspec2D_xmax = ispecb2
+ nspec2D_ymin = ispecb3
+ nspec2D_ymax = ispecb4
+
+ end subroutine get_jacobian_boundaries
+
+! -------------------------------------------------------
+
+ subroutine compute_jacobian_2D(myrank,ispecb,xelm,yelm,zelm,dershape2D,jacobian2D,normal,NGLLA,NGLLB,NSPEC2DMAX_AB)
+
+ implicit none
+
+ include "constants.h"
+
+! generic routine that accepts any polynomial degree in each direction
+
+ integer ispecb,NGLLA,NGLLB,NSPEC2DMAX_AB,myrank
+
+ double precision xelm(NGNOD2D),yelm(NGNOD2D),zelm(NGNOD2D)
+ double precision dershape2D(NDIM2D,NGNOD2D,NGLLA,NGLLB)
+
+ real(kind=CUSTOM_REAL) jacobian2D(NGLLA,NGLLB,NSPEC2DMAX_AB)
+ real(kind=CUSTOM_REAL) normal(3,NGLLA,NGLLB,NSPEC2DMAX_AB)
+
+ integer i,j,ia
+ double precision xxi,xeta,yxi,yeta,zxi,zeta
+ double precision unx,uny,unz,jacobian
+
+ do j=1,NGLLB
+ do i=1,NGLLA
+
+ xxi=ZERO
+ xeta=ZERO
+ yxi=ZERO
+ yeta=ZERO
+ zxi=ZERO
+ zeta=ZERO
+ do ia=1,NGNOD2D
+ xxi=xxi+dershape2D(1,ia,i,j)*xelm(ia)
+ xeta=xeta+dershape2D(2,ia,i,j)*xelm(ia)
+ yxi=yxi+dershape2D(1,ia,i,j)*yelm(ia)
+ yeta=yeta+dershape2D(2,ia,i,j)*yelm(ia)
+ zxi=zxi+dershape2D(1,ia,i,j)*zelm(ia)
+ zeta=zeta+dershape2D(2,ia,i,j)*zelm(ia)
+ enddo
+
+! calculate the unnormalized normal to the boundary
+ unx=yxi*zeta-yeta*zxi
+ uny=zxi*xeta-zeta*xxi
+ unz=xxi*yeta-xeta*yxi
+ jacobian=dsqrt(unx**2+uny**2+unz**2)
+ if(jacobian == ZERO) call exit_MPI(myrank,'2D Jacobian undefined')
+
+! normalize normal vector and store surface jacobian
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ jacobian2D(i,j,ispecb)=sngl(jacobian)
+ normal(1,i,j,ispecb)=sngl(unx/jacobian)
+ normal(2,i,j,ispecb)=sngl(uny/jacobian)
+ normal(3,i,j,ispecb)=sngl(unz/jacobian)
+ else
+ jacobian2D(i,j,ispecb)=jacobian
+ normal(1,i,j,ispecb)=unx/jacobian
+ normal(2,i,j,ispecb)=uny/jacobian
+ normal(3,i,j,ispecb)=unz/jacobian
+ endif
+
+ enddo
+ enddo
+
+ end subroutine compute_jacobian_2D
+
+
+
+subroutine sort_arrays_for_cuthill (ispecb,xstore,ystore,zstore,ibelm,normal,jacobian2D,nspec2D,NGLL1,NGLL2,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: ispecb,nspec2D,NGLL1,NGLL2,nspec,ispec_tmp,dummy_var,i
+
+ integer ibelm(nspec2D)
+ real(kind=CUSTOM_REAL) jacobian2D(NGLL1,NGLL2,NSPEC2D)
+ real(kind=CUSTOM_REAL) normal(NDIM,NGLL1,NGLL2,NSPEC2D)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! arrays for sorting routine
+ integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: work
+ double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
+ integer, dimension(:), allocatable :: perm
+ integer, dimension(:), allocatable :: ibelm_tmp
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_tmp
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_tmp
+
+! get permutation
+ allocate (xstore_selected(ispecb))
+ allocate (ystore_selected(ispecb))
+ allocate (zstore_selected(ispecb))
+ allocate(ind(ispecb))
+ allocate(ninseg(ispecb))
+ allocate(iglob(ispecb))
+ allocate(locval(ispecb))
+ allocate(ifseg(ispecb))
+ allocate(iwork(ispecb))
+ allocate(work(ispecb))
+ allocate(perm(ispecb))
+
+ do ispec_tmp=1,ispecb
+ xstore_selected(ispec_tmp) = xstore(1,1,1,ibelm(ispec_tmp))
+ ystore_selected(ispec_tmp) = ystore(1,1,1,ibelm(ispec_tmp))
+ zstore_selected(ispec_tmp) = zstore(1,1,1,ibelm(ispec_tmp))
+ perm(ispec_tmp) = ispec_tmp
+ enddo
+
+ call sort_array_coordinates(ispecb,xstore_selected,ystore_selected,zstore_selected, &
+ perm,iglob,locval,ifseg,dummy_var,ind,ninseg,iwork,work)
+
+ deallocate (xstore_selected)
+ deallocate (ystore_selected)
+ deallocate (zstore_selected)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iglob)
+ deallocate(locval)
+ deallocate(ifseg)
+ deallocate(iwork)
+ deallocate(work)
+
+! permutation of ibelm
+ allocate(ibelm_tmp(ispecb))
+ ibelm_tmp(1:ispecb) = ibelm(1:ispecb)
+ do i = 1,ispecb
+ ibelm(perm(i)) = ibelm_tmp(i)
+ enddo
+ deallocate(ibelm_tmp)
+
+! permutation of normal
+ allocate(normal_tmp(NDIM,NGLL1,NGLL2,ispecb))
+ normal_tmp(:,:,:,1:ispecb) = normal(:,:,:,1:ispecb)
+ do i = 1,ispecb
+ normal(:,:,:,perm(i)) = normal_tmp(:,:,:,i)
+ enddo
+ deallocate(normal_tmp)
+
+! permutation of jacobian2D
+ allocate(jacobian2D_tmp(NGLL1,NGLL2,ispecb))
+ jacobian2D_tmp(:,:,1:ispecb) = jacobian2D(:,:,1:ispecb)
+ do i = 1,ispecb
+ jacobian2D(:,:,perm(i)) = jacobian2D_tmp(:,:,i)
+ enddo
+ deallocate(jacobian2D_tmp)
+ deallocate(perm)
+
+end subroutine sort_arrays_for_cuthill
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_model.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,997 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine get_model(myrank,iregion_code,nspec, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,rhostore_local, &
+!! DK DK added this for the merged version
+ kappavstore_local, &
+ nspec_ani, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ xelm,yelm,zelm,shape3D,ispec, &
+ rmin,rmax,idoubling, &
+ rho_vp,rho_vs,nspec_stacey, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE, &
+ CRUSTAL,ONE_CRUST,ATTENUATION,ATTENUATION_3D,tau_s,tau_e_store,Qmu_store,T_c_source,vx,vy,vz,vnspec, &
+ ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ RCMB,RICB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN,&
+ AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V,AM_S,AS_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+
+ implicit none
+
+ include "constants.h"
+
+!! DK DK for the merged version
+! include values created by the mesher
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+! aniso_mantle_model_variables
+ type aniso_mantle_model_variables
+ sequence
+ double precision beta(14,34,37,73)
+ double precision pro(47)
+ integer npar1
+ end type aniso_mantle_model_variables
+
+ type (aniso_mantle_model_variables) AMM_V
+! aniso_mantle_model_variables
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+! model_1066a_variables
+ type model_1066a_variables
+ sequence
+ double precision, dimension(NR_1066A) :: radius_1066a
+ double precision, dimension(NR_1066A) :: density_1066a
+ double precision, dimension(NR_1066A) :: vp_1066a
+ double precision, dimension(NR_1066A) :: vs_1066a
+ double precision, dimension(NR_1066A) :: Qkappa_1066a
+ double precision, dimension(NR_1066A) :: Qmu_1066a
+ end type model_1066a_variables
+
+ type (model_1066a_variables) M1066a_V
+! model_1066a_variables
+
+! model_ak135_variables
+ type model_ak135_variables
+ sequence
+ double precision, dimension(NR_AK135) :: radius_ak135
+ double precision, dimension(NR_AK135) :: density_ak135
+ double precision, dimension(NR_AK135) :: vp_ak135
+ double precision, dimension(NR_AK135) :: vs_ak135
+ double precision, dimension(NR_AK135) :: Qkappa_ak135
+ double precision, dimension(NR_AK135) :: Qmu_ak135
+ end type model_ak135_variables
+
+ type (model_ak135_variables) Mak135_V
+! model_ak135_variables
+
+! model_ref_variables
+ type model_ref_variables
+ sequence
+ double precision, dimension(NR_REF) :: radius_ref
+ double precision, dimension(NR_REF) :: density_ref
+ double precision, dimension(NR_REF) :: vpv_ref
+ double precision, dimension(NR_REF) :: vph_ref
+ double precision, dimension(NR_REF) :: vsv_ref
+ double precision, dimension(NR_REF) :: vsh_ref
+ double precision, dimension(NR_REF) :: eta_ref
+ double precision, dimension(NR_REF) :: Qkappa_ref
+ double precision, dimension(NR_REF) :: Qmu_ref
+ end type model_ref_variables
+
+ type (model_ref_variables) Mref_V
+! model_ref_variables
+
+! sea1d_model_variables
+ type sea1d_model_variables
+ sequence
+ double precision, dimension(NR_SEA1D) :: radius_sea1d
+ double precision, dimension(NR_SEA1D) :: density_sea1d
+ double precision, dimension(NR_SEA1D) :: vp_sea1d
+ double precision, dimension(NR_SEA1D) :: vs_sea1d
+ double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
+ double precision, dimension(NR_SEA1D) :: Qmu_sea1d
+ end type sea1d_model_variables
+
+ type (sea1d_model_variables) SEA1DM_V
+! sea1d_model_variables
+
+! three_d_mantle_model_variables
+
+! three_d_mantle_model_variables
+ type three_d_mantle_model_variables
+ sequence
+ double precision dvs_a(0:NK,0:NS,0:NS)
+ double precision dvs_b(0:NK,0:NS,0:NS)
+ double precision dvp_a(0:NK,0:NS,0:NS)
+ double precision dvp_b(0:NK,0:NS,0:NS)
+ double precision spknt(NK+1)
+ double precision qq0(NK+1,NK+1)
+ double precision qq(3,NK+1,NK+1)
+ end type three_d_mantle_model_variables
+
+ type (three_d_mantle_model_variables) D3MM_V
+! three_d_mantle_model_variables
+
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+! sea99_s_model_variables
+ type sea99_s_model_variables
+ sequence
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ end type sea99_s_model_variables
+
+ type (sea99_s_model_variables) SEA99M_V
+! sea99_s_model_variables
+
+! crustal_model_variables
+ type crustal_model_variables
+ sequence
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
+ character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+ character(len=2) code(NKEYS_CRUST)
+ end type crustal_model_variables
+
+ type (crustal_model_variables) CM_V
+! crustal_model_variables
+
+! attenuation_model_storage
+ type attenuation_model_storage
+ sequence
+ integer Q_resolution
+ integer Q_max
+ double precision, dimension(:,:), pointer :: tau_e_storage
+ double precision, dimension(:), pointer :: Qmu_storage
+ end type attenuation_model_storage
+
+ type (attenuation_model_storage) AM_S
+! attenuation_model_storage
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+ integer ispec,nspec,idoubling,iregion_code,myrank,nspec_stacey
+ integer REFERENCE_1D_MODEL,THREE_D_MODEL
+
+ logical ATTENUATION,ATTENUATION_3D,ABSORBING_CONDITIONS
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST
+
+ double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
+
+ double precision xelm(NGNOD)
+ double precision yelm(NGNOD)
+ double precision zelm(NGNOD)
+
+ double precision rmin,rmax,RCMB,RICB,R670,RMOHO, &
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
+
+ real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) kappahstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) muhstore(NGLLX,NGLLY,NGLLZ,nspec)
+ real(kind=CUSTOM_REAL) eta_anisostore(NGLLX,NGLLY,NGLLZ,nspec)
+
+!! DK DK added this for the merged version
+ real(kind=CUSTOM_REAL) kappavstore_local(NGLLX,NGLLY,NGLLZ)
+
+!! DK DK changed this for merged version
+ real(kind=CUSTOM_REAL) rhostore_local(NGLLX,NGLLY,NGLLZ)
+
+ real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey),rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey)
+
+ integer nspec_ani
+
+! the 21 coefficients for an anisotropic medium in reduced notation
+ double precision c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,c33, &
+ c34,c35,c36,c44,c45,c46,c55,c56,c66
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_ani) :: &
+ c11store,c12store,c13store,c14store,c15store,c16store, &
+ c22store,c23store,c24store,c25store,c26store, &
+ c33store,c34store,c35store,c36store, &
+ c44store,c45store,c46store,c55store,c56store,c66store
+
+ double precision xmesh,ymesh,zmesh
+
+ integer i,j,k,ia
+ double precision rho,drhodr,vp,vs,Qkappa,Qmu
+ double precision vpv,vph,vsv,vsh,eta_aniso
+ double precision dvp,dvs,drho
+ real(kind=4) xcolat,xlon,xrad,dvpv,dvph,dvsv,dvsh
+ double precision xstore(NGLLX,NGLLY,NGLLZ)
+ double precision ystore(NGLLX,NGLLY,NGLLZ)
+ double precision zstore(NGLLX,NGLLY,NGLLZ)
+ double precision r,r_prem,r_moho,r_dummy,theta,phi
+ double precision lat,lon
+ double precision vpc,vsc,rhoc,moho
+
+! attenuation values
+ integer vx, vy, vz, vnspec
+ double precision, dimension(N_SLS) :: tau_s, tau_e
+ double precision, dimension(vx, vy, vz, vnspec) :: Qmu_store
+ double precision, dimension(N_SLS, vx, vy, vz, vnspec) :: tau_e_store
+ double precision T_c_source
+
+ logical found_crust
+
+ integer, parameter :: maxker=200
+ integer, parameter :: maxl=72
+ integer, parameter :: maxcoe=2000
+ integer, parameter :: maxver=1000
+ integer, parameter :: maxhpa=2
+
+ integer numker
+ integer numhpa,numcof
+ integer ihpa,lmax,nylm
+ integer lmxhpa(maxhpa)
+ integer itypehpa(maxhpa)
+ integer ihpakern(maxker)
+ integer numcoe(maxhpa)
+ integer ivarkern(maxker)
+
+ integer nconpt(maxhpa),iver
+ integer iconpt(maxver,maxhpa)
+ real(kind=4) conpt(maxver,maxhpa)
+
+ real(kind=4) xlaspl(maxcoe,maxhpa)
+ real(kind=4) xlospl(maxcoe,maxhpa)
+ real(kind=4) radspl(maxcoe,maxhpa)
+ real(kind=4) coe(maxcoe,maxker)
+ real(kind=4) vercof(maxker)
+ real(kind=4) vercofd(maxker)
+
+ real(kind=4) ylmcof((maxl+1)**2,maxhpa)
+ real(kind=4) wk1(maxl+1)
+ real(kind=4) wk2(maxl+1)
+ real(kind=4) wk3(maxl+1)
+
+ character(len=80) kerstr
+ character(len=40) varstr(maxker)
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ xmesh = ZERO
+ ymesh = ZERO
+ zmesh = ZERO
+ do ia=1,NGNOD
+ xmesh = xmesh + shape3D(ia,i,j,k)*xelm(ia)
+ ymesh = ymesh + shape3D(ia,i,j,k)*yelm(ia)
+ zmesh = zmesh + shape3D(ia,i,j,k)*zelm(ia)
+ enddo
+ r = dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*zmesh)
+
+ xstore(i,j,k) = xmesh
+ ystore(i,j,k) = ymesh
+ zstore(i,j,k) = zmesh
+
+! make sure we are within the right shell in PREM to honor discontinuities
+! use small geometrical tolerance
+ r_prem = r
+ if(r <= rmin*1.000001d0) r_prem = rmin*1.000001d0
+ if(r >= rmax*0.999999d0) r_prem = rmax*0.999999d0
+
+! get the anisotropic PREM parameters
+ if(TRANSVERSE_ISOTROPY) then
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
+ call prem_aniso(myrank,r_prem,rho,vpv,vph,vsv,vsh,eta_aniso, &
+ Qkappa,Qmu,idoubling,CRUSTAL,ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
+ call model_ref(r_prem,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V)
+
+ else
+ stop 'unknown 1D transversely isotropic reference Earth model in get_model'
+ endif
+
+ else
+
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
+ call model_iasp91(myrank,r_prem,rho,vp,vs,Qkappa,Qmu,idoubling, &
+ ONE_CRUST,.true.,RICB,RCMB,RTOPDDOUBLEPRIME,R771,R670,R400,R220,R120,RMOHO,RMIDDLE_CRUST)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
+ call prem_iso(myrank,r_prem,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, &
+ ONE_CRUST,.true.,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
+ call model_1066a(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,M1066a_V)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
+ call model_ak135(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,Mak135_V)
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
+ call model_ref(r_prem,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V)
+ if(.not. ISOTROPIC_3D_MANTLE) then
+ vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
+ endif
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then
+ call model_jp1d(myrank,r_prem,rho,vp,vs,Qkappa,Qmu,idoubling, &
+ .true.,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST)
+ vpv = vp
+ vph = vp
+ vsv = vs
+ vsh = vs
+ eta_aniso = 1.d0
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
+ call model_sea1d(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,SEA1DM_V)
+ vpv = vp
+ vph = vp
+ vsv = vs
+ vsh = vs
+ eta_aniso = 1.d0
+ else
+ stop 'unknown 1D reference Earth model in get_model'
+ endif
+
+ ! in the case of s362iso we want to save the anisotropic constants for the Voight average
+ if(.not. (REFERENCE_1D_MODEL == REFERENCE_MODEL_REF .and. ISOTROPIC_3D_MANTLE)) then
+ vpv = vp
+ vph = vp
+ vsv = vs
+ vsh = vs
+ eta_aniso = 1.d0
+ endif
+ endif
+
+! get the 3-D model parameters
+ if(ISOTROPIC_3D_MANTLE) then
+ if(r_prem > RCMB/R_EARTH .and. r_prem < RMOHO/R_EARTH) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+ if(THREE_D_MODEL == THREE_D_MODEL_S20RTS) then
+! s20rts
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call mantle_model(r,theta,phi,dvs,dvp,drho,D3MM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then
+! sea99 + jp3d1994
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call sea99_s_model(r,theta,phi,dvs,SEA99M_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+! use Lebedev model as background and add vp & vs perturbation from Zhao 1994 model
+ if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
+ .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
+ if(r_prem > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
+ call iso3d_dpzhao_model(r,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ endif
+ endif
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99) then
+! sea99
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call sea99_s_model(r,theta,phi,dvs,SEA99M_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+ elseif(THREE_D_MODEL == THREE_D_MODEL_JP3D) then
+! jp3d1994
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
+ .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
+ if(r_prem > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
+ call iso3d_dpzhao_model(r,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ endif
+ endif
+ elseif(THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI &
+ .or. THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM .or. THREE_D_MODEL == THREE_D_MODEL_S29EA) then
+! 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
+ dvpv = 0.
+ dvph = 0.
+ dvsv = 0.
+ dvsh = 0.
+ xcolat = sngl(theta*180.0d0/PI)
+ xlon = sngl(phi*180.0d0/PI)
+ xrad = sngl(r*R_EARTH_KM)
+ call subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+ if(TRANSVERSE_ISOTROPY) then
+ vpv=vpv*(1.0d0+dble(dvpv))
+ vph=vph*(1.0d0+dble(dvph))
+ vsv=vsv*(1.0d0+dble(dvsv))
+ vsh=vsh*(1.0d0+dble(dvsh))
+ else
+ vpv=vpv+dvpv
+ vph=vph+dvph
+ vsv=vsv+dvsv
+ vsh=vsh+dvsh
+ vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vpv=vp
+ vph=vp
+ vsv=vs
+ vsh=vs
+ eta_aniso=1.0d0
+ endif
+ else
+ stop 'unknown 3D Earth model in get_model'
+ endif
+
+! extend 3-D mantle model above the Moho to the surface before adding the crust
+ else if(r_prem >= RMOHO/R_EARTH) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+ r_moho = 0.999999d0*RMOHO/R_EARTH
+ if(THREE_D_MODEL == THREE_D_MODEL_S20RTS) then
+! s20rts
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call mantle_model(r_moho,theta,phi,dvs,dvp,drho,D3MM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then
+! sea99 + jp3d1994
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call sea99_s_model(r_moho,theta,phi,dvs,SEA99M_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+! use Lebedev's model as background and add vp & vs perturbation from Zhao's 1994 model
+ if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
+ .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
+ call iso3d_dpzhao_model(r_moho,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ endif
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99) then
+! sea99
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ call sea99_s_model(r_moho,theta,phi,dvs,SEA99M_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ rho=rho*(1.0d0+drho)
+ elseif(THREE_D_MODEL == THREE_D_MODEL_JP3D) then
+! jp3d1994
+ dvs = ZERO
+ dvp = ZERO
+ drho = ZERO
+ if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
+ .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
+ call iso3d_dpzhao_model(r_moho,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ vpv=vpv*(1.0d0+dvp)
+ vph=vph*(1.0d0+dvp)
+ vsv=vsv*(1.0d0+dvs)
+ vsh=vsh*(1.0d0+dvs)
+ endif
+ elseif(THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI &
+ .or. THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM .or. THREE_D_MODEL == THREE_D_MODEL_S29EA) then
+! 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
+ dvpv = 0.
+ dvph = 0.
+ dvsv = 0.
+ dvsh = 0.
+ xcolat = sngl(theta*180.0d0/PI)
+ xlon = sngl(phi*180.0d0/PI)
+ xrad = sngl(r_moho*R_EARTH_KM)
+ call subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+ if(TRANSVERSE_ISOTROPY) then
+ vpv=vpv*(1.0d0+dble(dvpv))
+ vph=vph*(1.0d0+dble(dvph))
+ vsv=vsv*(1.0d0+dble(dvsv))
+ vsh=vsh*(1.0d0+dble(dvsh))
+ else
+ vpv=vpv+dvpv
+ vph=vph+dvph
+ vsv=vsv+dvsv
+ vsh=vsh+dvsh
+ vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv + (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv + 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
+ vpv=vp
+ vph=vp
+ vsv=vs
+ vsh=vs
+ eta_aniso=1.0d0
+ endif
+ else
+ stop 'unknown 3D Earth model in get_model'
+ endif
+
+ endif
+ endif
+
+ if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) &
+ call aniso_inner_core_model(r_prem,c11,c33,c12,c13,c44,REFERENCE_1D_MODEL)
+
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+
+! anisotropic model between the Moho and 670 km (change to CMB if desired)
+ if(r_prem < RMOHO/R_EARTH .and. r_prem > R670/R_EARTH) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+ call aniso_mantle_model(r_prem,theta,phi,rho,c11,c12,c13,c14,c15,c16, &
+ c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66,AMM_V)
+! extend 3-D mantle model above the Moho to the surface before adding the crust
+ elseif(r_prem >= RMOHO/R_EARTH) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+ r_moho = RMOHO/R_EARTH
+ call aniso_mantle_model(r_moho,theta,phi,rho,c11,c12,c13,c14,c15,c16, &
+ c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66,AMM_V)
+! fill the rest of the mantle with the isotropic model
+ else
+ c11 = rho*vpv*vpv
+ c12 = rho*(vpv*vpv-2.*vsv*vsv)
+ c13 = c12
+ c14 = 0.
+ c15 = 0.
+ c16 = 0.
+ c22 = c11
+ c23 = c12
+ c24 = 0.
+ c25 = 0.
+ c26 = 0.
+ c33 = c11
+ c34 = 0.
+ c35 = 0.
+ c36 = 0.
+ c44 = rho*vsv*vsv
+ c45 = 0.
+ c46 = 0.
+ c55 = c44
+ c56 = 0.
+ c66 = c44
+ endif
+ endif
+
+! This is here to identify how and where to include 3D attenuation
+ if(ATTENUATION .and. ATTENUATION_3D) then
+ tau_e(:) = 0.0d0
+ ! Get the value of Qmu (Attenuation) dependedent on
+ ! the radius (r_prem) and idoubling flag
+ call attenuation_model_1D_PREM(r_prem, Qmu, idoubling)
+ ! Get tau_e from tau_s and Qmu
+ call attenuation_conversion(Qmu, T_c_source, tau_s, tau_e, AM_V, AM_S, AS_V)
+ endif
+
+! get the 3-D crustal model
+ if(CRUSTAL) then
+ if(r > R_DEEPEST_CRUST) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
+ call reduce(theta,phi)
+
+ if(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D .or. THREE_D_MODEL == THREE_D_MODEL_JP3D) then
+ if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
+ .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
+ if(r > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
+ call iso3d_dpzhao_model(r,theta,phi,vpc,vsc,dvp,dvs,rhoc,found_crust,JP3DM_V)
+ if(found_crust) then
+ vpv=vpc
+ vph=vpc
+ vsv=vsc
+ vsh=vsc
+! rho=rhoc
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+ c11 = rho*vpv*vpv
+ c12 = rho*(vpv*vpv-2.*vsv*vsv)
+ c13 = c12
+ c14 = 0.
+ c15 = 0.
+ c16 = 0.
+ c22 = c11
+ c23 = c12
+ c24 = 0.
+ c25 = 0.
+ c26 = 0.
+ c33 = c11
+ c34 = 0.
+ c35 = 0.
+ c36 = 0.
+ c44 = rho*vsv*vsv
+ c45 = 0.
+ c46 = 0.
+ c55 = c44
+ c56 = 0.
+ c66 = c44
+ endif
+ endif
+ endif
+ else
+ lat=(PI/2.0d0-theta)*180.0d0/PI
+ lon=phi*180.0d0/PI
+ if(lon>180.0d0) lon=lon-360.0d0
+ call crustal_model(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,CM_V)
+ if (found_crust) then
+ vpv=vpc
+ vph=vpc
+ vsv=vsc
+ vsh=vsc
+ rho=rhoc
+ eta_aniso=1.0d0
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+ c11 = rho*vpv*vpv
+ c12 = rho*(vpv*vpv-2.*vsv*vsv)
+ c13 = c12
+ c14 = 0.
+ c15 = 0.
+ c16 = 0.
+ c22 = c11
+ c23 = c12
+ c24 = 0.
+ c25 = 0.
+ c26 = 0.
+ c33 = c11
+ c34 = 0.
+ c35 = 0.
+ c36 = 0.
+ c44 = rho*vsv*vsv
+ c45 = 0.
+ c46 = 0.
+ c55 = c44
+ c56 = 0.
+ c66 = c44
+ endif
+ endif
+ endif
+ else
+ lat=(PI/2.0d0-theta)*180.0d0/PI
+ lon=phi*180.0d0/PI
+ if(lon>180.0d0) lon=lon-360.0d0
+ call crustal_model(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,CM_V)
+ if (found_crust) then
+ vpv=vpc
+ vph=vpc
+ vsv=vsc
+ vsh=vsc
+ rho=rhoc
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+ c11 = rho*vpv*vpv
+ c12 = rho*(vpv*vpv-2.*vsv*vsv)
+ c13 = c12
+ c14 = 0.
+ c15 = 0.
+ c16 = 0.
+ c22 = c11
+ c23 = c12
+ c24 = 0.
+ c25 = 0.
+ c26 = 0.
+ c33 = c11
+ c34 = 0.
+ c35 = 0.
+ c36 = 0.
+ c44 = rho*vsv*vsv
+ c45 = 0.
+ c46 = 0.
+ c55 = c44
+ c56 = 0.
+ c66 = c44
+ endif
+ endif
+ endif
+ endif
+ endif
+
+! define elastic parameters in the model
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+
+!! DK DK changed this for merged version
+ rhostore_local(i,j,k) = sngl(rho)
+
+!! DK DK added this for merged version
+ if(iregion_code /= IREGION_OUTER_CORE) then
+ kappavstore(i,j,k,ispec) = sngl(rho*(vpv*vpv - 4.d0*vsv*vsv/3.d0))
+ if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) &
+ kappahstore(i,j,k,ispec) = sngl(rho*(vph*vph - 4.d0*vsh*vsh/3.d0))
+ muvstore(i,j,k,ispec) = sngl(rho*vsv*vsv)
+ if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) muhstore(i,j,k,ispec) = sngl(rho*vsh*vsh)
+ if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) eta_anisostore(i,j,k,ispec) = sngl(eta_aniso)
+ else
+!! DK DK added this for merged version
+ kappavstore_local(i,j,k) = sngl(rho*(vpv*vpv - 4.d0*vsv*vsv/3.d0))
+ endif
+
+ if(ABSORBING_CONDITIONS) then
+
+ if(iregion_code == IREGION_OUTER_CORE) then
+
+! we need just vp in the outer core for Stacey conditions
+ rho_vp(i,j,k,ispec) = sngl(vph)
+ rho_vs(i,j,k,ispec) = sngl(0.d0)
+ else
+
+ rho_vp(i,j,k,ispec) = sngl(rho*vph)
+ rho_vs(i,j,k,ispec) = sngl(rho*vsh)
+ endif
+ endif
+
+ if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then
+
+ c11store(i,j,k,ispec) = sngl(c11)
+ c33store(i,j,k,ispec) = sngl(c33)
+ c12store(i,j,k,ispec) = sngl(c12)
+ c13store(i,j,k,ispec) = sngl(c13)
+ c44store(i,j,k,ispec) = sngl(c44)
+ endif
+
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+
+ c11store(i,j,k,ispec) = sngl(c11)
+ c12store(i,j,k,ispec) = sngl(c12)
+ c13store(i,j,k,ispec) = sngl(c13)
+ c14store(i,j,k,ispec) = sngl(c14)
+ c15store(i,j,k,ispec) = sngl(c15)
+ c16store(i,j,k,ispec) = sngl(c16)
+ c22store(i,j,k,ispec) = sngl(c22)
+ c23store(i,j,k,ispec) = sngl(c23)
+ c24store(i,j,k,ispec) = sngl(c24)
+ c25store(i,j,k,ispec) = sngl(c25)
+ c26store(i,j,k,ispec) = sngl(c26)
+ c33store(i,j,k,ispec) = sngl(c33)
+ c34store(i,j,k,ispec) = sngl(c34)
+ c35store(i,j,k,ispec) = sngl(c35)
+ c36store(i,j,k,ispec) = sngl(c36)
+ c44store(i,j,k,ispec) = sngl(c44)
+ c45store(i,j,k,ispec) = sngl(c45)
+ c46store(i,j,k,ispec) = sngl(c46)
+ c55store(i,j,k,ispec) = sngl(c55)
+ c56store(i,j,k,ispec) = sngl(c56)
+ c66store(i,j,k,ispec) = sngl(c66)
+ endif
+
+ else
+
+!! DK DK changed this for merged version
+ rhostore_local(i,j,k) = rho
+
+!! DK DK added this for merged version
+ if(iregion_code /= IREGION_OUTER_CORE) then
+ kappavstore(i,j,k,ispec) = rho*(vpv*vpv - 4.d0*vsv*vsv/3.d0)
+ if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) &
+ kappahstore(i,j,k,ispec) = rho*(vph*vph - 4.d0*vsh*vsh/3.d0)
+ muvstore(i,j,k,ispec) = rho*vsv*vsv
+ if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) muhstore(i,j,k,ispec) = rho*vsh*vsh
+ if(iregion_code == IREGION_CRUST_MANTLE .and. NSPECMAX_TISO_MANTLE > 1) eta_anisostore(i,j,k,ispec) = eta_aniso
+ else
+!! DK DK added this for merged version
+ kappavstore_local(i,j,k) = rho*(vpv*vpv - 4.d0*vsv*vsv/3.d0)
+ endif
+
+ if(ABSORBING_CONDITIONS) then
+ if(iregion_code == IREGION_OUTER_CORE) then
+! we need just vp in the outer core for Stacey conditions
+ rho_vp(i,j,k,ispec) = vph
+ rho_vs(i,j,k,ispec) = 0.d0
+ else
+ rho_vp(i,j,k,ispec) = rho*vph
+ rho_vs(i,j,k,ispec) = rho*vsh
+ endif
+ endif
+
+ if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then
+ c11store(i,j,k,ispec) = c11
+ c33store(i,j,k,ispec) = c33
+ c12store(i,j,k,ispec) = c12
+ c13store(i,j,k,ispec) = c13
+ c44store(i,j,k,ispec) = c44
+ endif
+
+ if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+ c11store(i,j,k,ispec) = c11
+ c12store(i,j,k,ispec) = c12
+ c13store(i,j,k,ispec) = c13
+ c14store(i,j,k,ispec) = c14
+ c15store(i,j,k,ispec) = c15
+ c16store(i,j,k,ispec) = c16
+ c22store(i,j,k,ispec) = c22
+ c23store(i,j,k,ispec) = c23
+ c24store(i,j,k,ispec) = c24
+ c25store(i,j,k,ispec) = c25
+ c26store(i,j,k,ispec) = c26
+ c33store(i,j,k,ispec) = c33
+ c34store(i,j,k,ispec) = c34
+ c35store(i,j,k,ispec) = c35
+ c36store(i,j,k,ispec) = c36
+ c44store(i,j,k,ispec) = c44
+ c45store(i,j,k,ispec) = c45
+ c46store(i,j,k,ispec) = c46
+ c55store(i,j,k,ispec) = c55
+ c56store(i,j,k,ispec) = c56
+ c66store(i,j,k,ispec) = c66
+ endif
+
+ endif
+
+ if(ATTENUATION .and. ATTENUATION_3D) then
+ tau_e_store(:,i,j,k,ispec) = tau_e(:)
+ Qmu_store(i,j,k,ispec) = Qmu
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine get_model
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_perm_cuthill_mckee.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_perm_cuthill_mckee.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_perm_cuthill_mckee.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,804 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! implement reverse Cuthill-McKee (1969) ordering, introduced in
+! E. Cuthill and J. McKee. Reducing the bandwidth of sparse symmetric matrices.
+! In Proceedings of the 1969 24th national conference, pages 157-172,
+! New-York, New-York, USA, 1969. ACM Press.
+! see for instance http://en.wikipedia.org/wiki/Cuthill%E2%80%93McKee_algorithm
+
+ subroutine get_perm(ibool,perm,limit,nspec,nglob,INVERSE,FACE)
+
+ implicit none
+
+ include "constants.h"
+
+ logical :: INVERSE,FACE
+
+! input
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+! output
+ integer, dimension(nspec) :: perm
+
+! local variables
+ integer nspec,nglob_GLL_full
+
+! a neighbor of a hexahedral node is a hexahedra which share a face whith it -> max degre of a node = 6
+ integer, parameter :: MAX_NUMBER_OF_NEIGHBORS = 100
+
+! global corner numbers that need to be created
+ integer, dimension(nglob) :: global_corner_number
+
+ integer mn(nspec*NGNOD_HEXAHEDRA),mp(nspec+1)
+ integer, dimension(:), allocatable :: ne,np,adj
+ integer xadj(nspec+1)
+
+! arrays to store the permutation and inverse permutation of the Cuthill-McKee algorithm
+ integer, dimension(nspec) :: invperm
+
+ logical maskel(nspec)
+
+ integer i,istart,istop,number_of_neighbors
+
+ integer nglob_eight_corners_only,nglob
+
+! only count the total size of the array that will be created, or actually create it
+ logical count_only
+ integer total_size_ne,total_size_adj,limit
+
+!
+!-----------------------------------------------------------------------
+!
+ if(PERFORM_CUTHILL_MCKEE) then
+
+ ! total number of points in the mesh
+ nglob_GLL_full = nglob
+
+ !---- call Charbel Farhat's routines
+ call form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number,nglob_GLL_full,ibool,nglob_eight_corners_only)
+ do i=1,nspec
+ istart = mp(i)
+ istop = mp(i+1) - 1
+ enddo
+
+ allocate(np(nglob_eight_corners_only+1))
+ count_only = .true.
+ total_size_ne = 1
+ allocate(ne(total_size_ne))
+ call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_eight_corners_only,nspec,count_only,total_size_ne)
+ deallocate(ne)
+ allocate(ne(total_size_ne))
+ count_only = .false.
+ call form_node_connectivity_fonoco(mn,mp,ne,np,nglob_eight_corners_only,nspec,count_only,total_size_ne)
+ do i=1,nglob_eight_corners_only
+ istart = np(i)
+ istop = np(i+1) - 1
+ enddo
+
+ count_only = .true.
+ total_size_adj = 1
+ allocate(adj(total_size_adj))
+ call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_eight_corners_only,&
+ count_only,total_size_ne,total_size_adj,FACE)
+ deallocate(adj)
+ allocate(adj(total_size_adj))
+ count_only = .false.
+ call create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec,nglob_eight_corners_only,&
+ count_only,total_size_ne,total_size_adj,FACE)
+ do i=1,nspec
+ istart = xadj(i)
+ istop = xadj(i+1) - 1
+ number_of_neighbors = istop-istart+1
+ if(number_of_neighbors < 1 .or. number_of_neighbors > MAX_NUMBER_OF_NEIGHBORS) stop 'incorrect number of neighbors'
+ enddo
+ deallocate(ne,np)
+
+! call the Cuthill-McKee sorting algorithm
+ call cuthill_mckee(adj,xadj,perm,invperm,nspec,total_size_adj,limit,INVERSE)
+ deallocate(adj)
+ else
+! create identity permutation in order to do nothing
+ do i=1,nspec
+ perm(i) = i
+ enddo
+ endif
+
+ end subroutine get_perm
+
+!=======================================================================
+!
+! Charbel Farhat's FEM topology routines
+!
+! Dimitri Komatitsch, February 1996 - Code based on Farhat's original version
+! described in his technical report from 1987
+!
+! modified and adapted by Dimitri Komatitsch, May 2006
+!
+!=======================================================================
+
+ subroutine form_elt_connectivity_foelco(mn,mp,nspec,global_corner_number, &
+ nglob_GLL_full,ibool,nglob_eight_corners_only)
+
+!-----------------------------------------------------------------------
+!
+! Forms the MN and MP arrays
+!
+! Input :
+! -------
+! ibool Array needed to build the element connectivity table
+! nspec Number of elements in the domain
+! NGNOD_HEXAHEDRA number of nodes per hexahedron (brick with 8 corners)
+!
+! Output :
+! --------
+! MN, MP This is the element connectivity array pair.
+! Array MN contains the list of the element
+! connectivity, that is, the nodes contained in each
+! element. They are stored in a stacked fashion.
+!
+! Pointer array MP stores the location of each
+! element list. Its length is equal to the number
+! of elements plus one.
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,nglob_GLL_full
+
+! arrays with mesh parameters per slice
+ integer, intent(in), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+! global corner numbers that need to be created
+ integer, intent(out), dimension(nglob_GLL_full) :: global_corner_number
+ integer, intent(out) :: mn(nspec*NGNOD_HEXAHEDRA),mp(nspec+1)
+ integer, intent(out) :: nglob_eight_corners_only
+
+ integer ninter,nsum,ispec,node,k,inumcorner,ix,iy,iz
+
+ ninter = 1
+ nsum = 1
+ mp(1) = 1
+
+!---- define topology of the elements in the mesh
+!---- we need to define adjacent numbers from the sub-mesh consisting of the corners only
+ nglob_eight_corners_only = 0
+ global_corner_number(:) = -1
+
+ do ispec=1,nspec
+
+ inumcorner = 0
+ do iz = 1,NGLLZ,NGLLZ-1
+ do iy = 1,NGLLY,NGLLY-1
+ do ix = 1,NGLLX,NGLLX-1
+
+ inumcorner = inumcorner + 1
+ if(inumcorner > NGNOD_HEXAHEDRA) stop 'corner number too large'
+
+! check if this point was already assigned a number previously, otherwise create one and store it
+ if(global_corner_number(ibool(ix,iy,iz,ispec)) == -1) then
+ nglob_eight_corners_only = nglob_eight_corners_only + 1
+ global_corner_number(ibool(ix,iy,iz,ispec)) = nglob_eight_corners_only
+ endif
+
+ node = global_corner_number(ibool(ix,iy,iz,ispec))
+ do k=nsum,ninter-1
+ if(node == mn(k)) goto 200
+ enddo
+
+ mn(ninter) = node
+ ninter = ninter + 1
+ 200 continue
+
+ enddo
+ enddo
+ enddo
+
+ nsum = ninter
+ mp(ispec + 1) = nsum
+
+ enddo
+
+ end subroutine form_elt_connectivity_foelco
+
+!
+!----------------------------------------------------
+!
+
+ subroutine form_node_connectivity_fonoco(mn,mp,ne,np,nglob_eight_corners_only, &
+ nspec,count_only,total_size_ne)
+
+!-----------------------------------------------------------------------
+!
+! Forms the NE and NP arrays
+!
+! Input :
+! -------
+! MN, MP, nspec
+! nglob_eight_corners_only Number of nodes in the domain
+!
+! Output :
+! --------
+! NE, NP This is the node-connected element array pair.
+! Integer array NE contains a list of the
+! elements connected to each node, stored in stacked fashion.
+!
+! Array NP is the pointer array for the
+! location of a node's element list in the NE array.
+! Its length is equal to the number of points plus one.
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+
+ include "constants.h"
+
+! only count the total size of the array that will be created, or actually create it
+ logical count_only
+ integer total_size_ne
+
+ integer nglob_eight_corners_only,nspec
+
+ integer, intent(in) :: mn(nspec*NGNOD_HEXAHEDRA),mp(nspec+1)
+
+ integer, intent(out) :: ne(total_size_ne),np(nglob_eight_corners_only+1)
+
+ integer nsum,inode,ispec,j
+
+ nsum = 1
+ np(1) = 1
+
+ do inode=1,nglob_eight_corners_only
+ do 200 ispec=1,nspec
+
+ do j=mp(ispec),mp(ispec + 1) - 1
+ if (mn(j) == inode) then
+ if(count_only) then
+ total_size_ne = nsum
+ else
+ ne(nsum) = ispec
+ endif
+ nsum = nsum + 1
+ goto 200
+ endif
+ enddo
+ 200 continue
+
+ np(inode + 1) = nsum
+
+ enddo
+
+ end subroutine form_node_connectivity_fonoco
+
+!
+!----------------------------------------------------
+!
+
+ subroutine create_adjacency_table_adjncy(mn,mp,ne,np,adj,xadj,maskel,nspec, &
+ nglob_eight_corners_only,count_only,total_size_ne,total_size_adj,face)
+
+!-----------------------------------------------------------------------
+!
+! Establishes the element adjacency information of the mesh
+! Two elements are considered adjacent if they share a face.
+!
+! Input :
+! -------
+! MN, MP, NE, NP, nspec
+! MASKEL logical mask (length = nspec)
+!
+! Output :
+! --------
+! ADJ, XADJ This is the element adjacency array pair. Array
+! ADJ contains the list of the elements adjacent to
+! element i. They are stored in a stacked fashion.
+! Pointer array XADJ stores the location of each element list.
+!
+!-----------------------------------------------------------------------
+
+ implicit none
+
+ include "constants.h"
+
+! only count the total size of the array that will be created, or actually create it
+ logical count_only,face
+ integer total_size_ne,total_size_adj
+
+ integer nglob_eight_corners_only
+
+ integer, intent(in) :: mn(nspec*NGNOD_HEXAHEDRA),mp(nspec+1),ne(total_size_ne),np(nglob_eight_corners_only+1)
+
+ integer, intent(out) :: adj(total_size_adj),xadj(nspec+1)
+
+ logical maskel(nspec)
+ integer countel(nspec)
+
+ integer nspec,iad,ispec,istart,istop,ino,node,jstart,jstop,nelem,jel
+
+ xadj(1) = 1
+ iad = 1
+
+ do ispec=1,nspec
+
+! reset mask
+ maskel(:) = .false.
+
+! mask current element
+ maskel(ispec) = .true.
+ if (face) countel(:) = 0
+
+ istart = mp(ispec)
+ istop = mp(ispec+1) - 1
+ do ino=istart,istop
+ node = mn(ino)
+ jstart = np(node)
+ jstop = np(node + 1) - 1
+ do 120 jel=jstart,jstop
+ nelem = ne(jel)
+ if(maskel(nelem)) goto 120
+ if (face) then
+ ! if 2 elements share at least 3 corners, therefore they share a face
+ countel(nelem) = countel(nelem) + 1
+ if (countel(nelem)>=3) then
+ if(count_only) then
+ total_size_adj = iad
+ else
+ adj(iad) = nelem
+ endif
+ maskel(nelem) = .true.
+ iad = iad + 1
+ endif
+ else
+ if(count_only) then
+ total_size_adj = iad
+ else
+ adj(iad) = nelem
+ endif
+ maskel(nelem) = .true.
+ iad = iad + 1
+ endif
+ 120 continue
+ enddo
+
+ xadj(ispec+1) = iad
+
+ enddo
+
+ end subroutine create_adjacency_table_adjncy
+
+!
+!----------------------------------------------------
+!
+
+ subroutine cuthill_mckee(adj,xadj,mask,invperm_all,nspec,total_size_adj,limit,INVERSE)
+
+ implicit none
+ include "constants.h"
+
+ integer, intent(in) :: nspec,total_size_adj, limit
+ integer, intent(in) :: adj(total_size_adj),xadj(nspec+1)
+
+ integer, intent(out), dimension(nspec) :: mask,invperm_all
+ integer, dimension(nspec) :: invperm_sub
+ logical :: INVERSE
+ integer ispec,gsize,counter,nspec_sub,root,total_ordered_elts, next_root
+
+! fill the mask with ones
+ mask(:) = 1
+ invperm_all(:) = 0
+ counter = 0
+ nspec_sub = limit
+ root = 1
+ total_ordered_elts = 0
+
+ do while(total_ordered_elts < nspec)
+ ! creation of a sublist of sorted elements which fit in the cache (the criterion of size is limit)
+ ! limit = nb of element that can fit in the L2 cache
+ call Cut_McK( root, nspec, total_size_adj, xadj, adj, mask, gsize, invperm_sub, limit, nspec_sub, next_root)
+ ! add the sublist in the main permutation list
+ invperm_all(total_ordered_elts+1:total_ordered_elts+nspec_sub) = invperm_sub(1:nspec_sub)
+ total_ordered_elts = total_ordered_elts + nspec_sub
+ ! seek for a new root to build the new sublist
+ if (next_root > 0) then
+ root = next_root
+ else
+ if (total_ordered_elts /= nspec) &
+ call find_next_root(next_root,xadj,adj,total_size_adj,mask,invperm_all,total_ordered_elts,nspec)
+ root = next_root
+ endif
+ enddo
+
+ if (INVERSE) then
+ do ispec=1,nspec
+ mask(invperm_all(ispec)) = ispec
+ enddo
+ else
+ mask(:) = invperm_all(:)
+ endif
+
+ end subroutine cuthill_mckee
+
+
+!*******************************************************************************
+! Objective: Cuthill-McKee ordering
+! The algorithm is:
+!
+! X(1) = ROOT.
+! for ( I = 1 to N-1)
+! Find all unlabeled neighbors of X(I),
+! assign them the next available labels, in order of increasing degree.
+!
+! Parameters:
+! root the starting point for the cm ordering.
+! nbnodes the number of nodes.
+! nnz the number of adjacency entries.
+!
+! xadj/adj the graph
+! mask only those nodes with nonzero mask are considered
+!
+! gsize the number of the connected component
+! invp Inverse invputation (from new order to old order)
+!*******************************************************************************
+
+subroutine find_next_root(next_root,xadj,adj,total_size_adj,mask,invperm_all,total_ordered_elts,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+! input
+ integer, intent(in) :: total_size_adj,total_ordered_elts,nspec
+ integer, intent(in) :: adj(total_size_adj),xadj(nspec+1)
+ integer, intent(in), dimension(nspec) :: mask,invperm_all
+! output
+ integer, intent(out) :: next_root
+! variables
+ integer :: cur_node,neighbor_node,i,j
+
+ do i=total_ordered_elts, 1, -1
+ cur_node = invperm_all(i)
+ do j= xadj(cur_node), xadj(cur_node+1)-1
+ neighbor_node = adj(j)
+ if (mask(neighbor_node)/=0) then
+ next_root=neighbor_node
+ return
+ endif
+ enddo
+ enddo
+
+end subroutine find_next_root
+
+!*******************************************************************************
+! Objective: Cuthill-McKee ordering
+! The algorithm is:
+!
+! X(1) = ROOT.
+! for ( I = 1 to N-1)
+! Find all unlabeled neighbors of X(I),
+! assign them the next available labels, in order of increasing degree.
+!
+! Parameters:
+! root the starting point for the cm ordering.
+! nbnodes the number of nodes.
+! nnz the number of adjacency entries.
+!
+! xadj/adj the graph
+! mask only those nodes with nonzero mask are considered
+!
+! gsize the number of the connected component
+! invp Inverse invputation (from new order to old order)
+!*******************************************************************************
+
+subroutine Cut_McK( root, nbnodes, nnz, xadj, adj, mask, gsize, invp, limit, nspec_sub, next_root)
+
+ implicit none
+
+ include "constants.h"
+
+!--------------------------------------------------------------- Input Variables
+ integer root, nnz, nbnodes, limit, nspec_sub, next_root
+
+ integer xadj(nbnodes+1), adj(nnz), mask(nbnodes)
+
+!-------------------------------------------------------------- Output Variables
+ integer gsize
+ integer invp(nbnodes)
+
+!--------------------------------------------------------------- Local Variables
+ integer i, j, k, l, lbegin, lnbr, linvp, lvlend, nbr, node, fnbr
+ integer deg(nbnodes)
+
+! Find the degrees of the nodes in the subgraph specified by mask and root
+! Here invp is used to store a levelization of the subgraph
+ invp(:)=0
+ deg(:)=0
+ call degree ( root, nbnodes, nnz, xadj, adj, mask, gsize, deg, invp)
+
+ mask(root) = 0
+
+ IF (gsize > 1) THEN
+ !If there is at least 2 nodes in the subgraph
+ lvlend = 0
+ lnbr = 1
+
+ DO while (lvlend < lnbr)
+ !lbegin/lvlend point to the begin/end of the present level
+ lbegin = lvlend + 1
+ lvlend = lnbr
+
+ do i= lbegin, lvlend
+ node = invp(i)
+
+ !Find the unnumbered neighbours of node.
+ !fnbr/lnbr point to the first/last neighbors of node
+ fnbr = lnbr + 1
+ do j= xadj(node), xadj(node+1)-1
+ nbr = adj(j)
+
+ if (mask(nbr) /= 0) then
+ lnbr = lnbr + 1
+ mask(nbr) = 0
+ invp(lnbr) = nbr
+ endif
+ enddo
+
+ !If no neighbors, go to next node in this level.
+ IF (lnbr > fnbr) THEN
+ !Sort the neighbors of NODE in increasing order by degree.
+ !Linear insertion is used.
+ k = fnbr
+ do while (k < lnbr)
+ l = k
+ k = k + 1
+ nbr = invp(k)
+
+ DO WHILE (fnbr < l)
+ linvp = invp(l)
+
+ if (deg(linvp) <= deg(nbr)) then
+ exit
+ endif
+
+ invp(l+1) = linvp
+ l = l-1
+ ENDDO
+
+ invp(l+1) = nbr
+ enddo
+ ENDIF
+ enddo
+ ENDDO
+
+ ENDIF
+
+ if (gsize > limit) then
+ do i = limit + 1 , nbnodes
+ node=invp(i)
+ if (node /=0) mask(node) = 1
+ enddo
+ next_root = invp(limit +1)
+ nspec_sub = limit
+ else
+ next_root = -1
+ nspec_sub = gsize
+ endif
+
+END subroutine Cut_McK
+
+
+!*******************************************************************************
+! Objective: computes the degrees of the nodes in the connected graph
+!
+! Parameters:
+! root the root node
+! nbnodes the number of nodes in the graph
+! nnz the graph size
+! xadj/adj the whole graph
+! mask Only nodes with mask == 0 are considered
+!
+! gsize the number of nodes in the connected graph
+! deg degree for all the nodes in the connected graph
+! level levelization of the connected graph
+!
+!*******************************************************************************
+
+subroutine degree( root, nbnodes, nnz, xadj, adj, mask, gsize, deg, level )
+
+ implicit none
+
+!--------------------------------------------------------------- Input Variables
+ integer root, nbnodes, nnz
+ integer xadj(nbnodes+1), adj(nnz), mask(nbnodes)
+
+!-------------------------------------------------------------- Output Variables
+ integer gsize
+ integer deg(nbnodes), level(nbnodes)
+
+!--------------------------------------------------------------- Local Variables
+ integer i, j, ideg, lbegin, lvlend, lvsize, nxt, nbr, node
+
+! The sign of xadj(I) is used to indicate if node i has been considered
+ xadj(root) = -xadj(root)
+ level(1) = root
+ nxt = 1
+ lvlend = 0
+ lvsize = 1
+
+ DO WHILE (lvsize > 0)
+ ! lbegin/lvlend points the begin/end of the present level
+ lbegin = lvlend + 1
+ lvlend = nxt
+
+ ! Find the degrees of nodes in the present level and generate the next level
+ DO i= lbegin, lvlend
+ node = level(i)
+ ideg = 0
+ do j= ABS( xadj(node) ), ABS( xadj(node+1) )-1
+ nbr = adj(j)
+
+ if (mask(nbr) /= 0) then
+ ideg = ideg + 1
+
+ if (xadj(nbr) >= 0) then
+ xadj(nbr) = -xadj(nbr)
+ nxt = nxt + 1
+ level(nxt) = nbr
+ endif
+ endif
+ enddo
+
+ deg(node) = ideg
+ ENDDO
+
+ !Compute the level size of the next level
+ lvsize = nxt - lvlend
+ ENDDO
+
+ !Reset xadj to its correct sign
+ do i = 1, nxt
+ node = level(i)
+ xadj(node) = -xadj(node)
+ enddo
+
+ gsize = nxt
+
+END subroutine degree
+
+!
+!-----------------------------------------------------------------------
+!
+
+ subroutine permute_elements_real(array_to_permute,temp_array,perm,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nspec
+ integer, intent(in), dimension(nspec) :: perm
+
+ real(kind=CUSTOM_REAL), intent(inout), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: array_to_permute,temp_array
+
+ integer old_ispec,new_ispec
+
+! copy the original array
+ temp_array(:,:,:,:) = array_to_permute(:,:,:,:)
+
+ do old_ispec = 1,nspec
+ new_ispec = perm(old_ispec)
+ array_to_permute(:,:,:,new_ispec) = temp_array(:,:,:,old_ispec)
+ enddo
+
+ end subroutine permute_elements_real
+
+!
+!-----------------------------------------------------------------------
+!
+
+!! DK DK added this for merged version
+ subroutine permute_elements_xelm_yelm_zelm(array_to_permute,temp_array,perm,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nspec
+ integer, intent(in), dimension(nspec) :: perm
+
+ real(kind=CUSTOM_REAL), intent(inout), dimension(NGNOD,nspec) :: array_to_permute,temp_array
+
+ integer old_ispec,new_ispec
+
+! copy the original array
+ temp_array(:,:) = array_to_permute(:,:)
+
+ do old_ispec = 1,nspec
+ new_ispec = perm(old_ispec)
+ array_to_permute(:,new_ispec) = temp_array(:,old_ispec)
+ enddo
+
+ end subroutine permute_elements_xelm_yelm_zelm
+
+!
+!-----------------------------------------------------------------------
+!
+
+! implement permutation of elements for arrays of integer type
+ subroutine permute_elements_integer(array_to_permute,temp_array,perm,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nspec
+ integer, intent(in), dimension(nspec) :: perm
+
+ integer, intent(inout), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: array_to_permute,temp_array
+
+ integer old_ispec,new_ispec
+
+! copy the original array
+ temp_array(:,:,:,:) = array_to_permute(:,:,:,:)
+
+ do old_ispec = 1,nspec
+ new_ispec = perm(old_ispec)
+ array_to_permute(:,:,:,new_ispec) = temp_array(:,:,:,old_ispec)
+ enddo
+
+ end subroutine permute_elements_integer
+
+!
+!-----------------------------------------------------------------------
+!
+
+! implement permutation of elements for arrays of double precision type
+ subroutine permute_elements_dble(array_to_permute,temp_array,perm,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nspec
+ integer, intent(in), dimension(nspec) :: perm
+
+ double precision, intent(inout), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: array_to_permute,temp_array
+
+ integer old_ispec,new_ispec
+
+! copy the original array
+ temp_array(:,:,:,:) = array_to_permute(:,:,:,:)
+
+ do old_ispec = 1,nspec
+ new_ispec = perm(old_ispec)
+ array_to_permute(:,:,:,new_ispec) = temp_array(:,:,:,old_ispec)
+ enddo
+
+ end subroutine permute_elements_dble
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_shape2D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_shape2D.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_shape2D.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/get_shape3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_shape3D.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_shape3D.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/get_value_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_value_parameters.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/get_value_parameters.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/gll_library.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/gll_library.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/gll_library.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/go_mesher_solver_lsf_globe.bash
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/go_mesher_solver_lsf_globe.bash (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/go_mesher_solver_lsf_globe.bash 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,50 @@
+#!/bin/bash
+#BSUB -o OUTPUT_FILES/%J.o
+#BSUB -a mpich_gm
+#BSUB -J go_mesher_solver_lsf
+
+if [ -z $USER ]; then
+ echo "could not run go_mesher_solver_...bash as no USER env is set"
+ exit 2
+fi
+
+BASEMPIDIR=/scratch/$USER/DATABASES_MPI
+
+# script to run the mesher and the solver
+
+# read DATA/Par_file to get information about the run
+
+# compute total number of nodes needed
+NPROC_XI=`grep NPROC_XI DATA/Par_file | cut -d = -f 2 `
+NPROC_ETA=`grep NPROC_ETA DATA/Par_file | cut -d = -f 2`
+NCHUNKS=`grep NCHUNKS DATA/Par_file | cut -d = -f 2 `
+
+# total number of nodes is the product of the values read
+numnodes=$(( $NCHUNKS * $NPROC_XI * $NPROC_ETA ))
+
+rm -r -f OUTPUT_FILES
+mkdir OUTPUT_FILES
+
+#rm -r -f DATABASES_MPI
+#mkdir DATABASES_MPI
+
+# obtain lsf job information
+echo "$LSB_MCPU_HOSTS" > OUTPUT_FILES/lsf_machines
+echo "$LSB_JOBID" > OUTPUT_FILES/jobid
+
+./remap_lsf_machines.pl OUTPUT_FILES/lsf_machines >OUTPUT_FILES/machines
+
+shmux -M 50 -S all -c "rm -r -f /scratch/$USER ; mkdir -p /scratch/$USER ; mkdir -p $BASEMPIDIR" - < OUTPUT_FILES/machines >/dev/null
+
+echo starting MPI mesher on $numnodes processors
+echo " "
+echo starting run in current directory $PWD
+echo " "
+
+# wait for 10 minutes to try to avoid slow runs (let the load of the machine decrease)
+sleep 20
+
+#### use this on LSF
+mpirun.lsf --gm-no-shmem --gm-copy-env $PWD/xmeshfem3D
+####mpirun.lsf --gm-no-shmem --gm-copy-env $PWD/xspecfem3D
+
Property changes on: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/go_mesher_solver_lsf_globe.bash
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/hex_nodes.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/hex_nodes.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/hex_nodes.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/intgrl.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/intgrl.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/intgrl.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/jp3d1994_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/jp3d1994_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/jp3d1994_model.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/lagrange_poly.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/lagrange_poly.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/lagrange_poly.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/lgndr.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/lgndr.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/lgndr.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/locate_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/locate_receivers.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/locate_receivers.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,680 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!----
+!---- locate_receivers finds the correct position of the receivers
+!----
+
+ subroutine locate_receivers(myrank,DT,NSTEP,nspec,nglob,ibool, &
+ xstore,ystore,zstore,xigll,yigll,zigll,rec_filename, &
+ nrec,islice_selected_rec,ispec_selected_rec, &
+ xi_receiver,eta_receiver,gamma_receiver,station_name,network_name,stlat,stlon,stele,nu, &
+ yr,jda,ho,mi,sec,NPROCTOT,ELLIPTICITY,TOPOGRAPHY, &
+ theta_source,phi_source, &
+ rspl,espl,espl2,nspl,ibathy_topo,RECEIVERS_CAN_BE_BURIED,NCHUNKS)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer NPROCTOT,NCHUNKS
+
+ logical ELLIPTICITY,TOPOGRAPHY,RECEIVERS_CAN_BE_BURIED
+
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+ integer nspec,nglob,nrec,myrank,nrec_found
+
+ integer yr,jda,ho,mi
+ double precision sec
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+ integer NSTEP
+ double precision DT
+
+! arrays containing coordinates of the points
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ)
+
+ character(len=*) rec_filename
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+ integer, allocatable, dimension(:) :: ix_initial_guess,iy_initial_guess,iz_initial_guess
+
+ integer iorientation
+ integer iprocloop
+ double precision stazi,stdip
+
+ double precision, allocatable, dimension(:) :: x_target,y_target,z_target
+ double precision, allocatable, dimension(:) :: epidist
+ double precision, allocatable, dimension(:) :: x_found,y_found,z_found
+ double precision, allocatable, dimension(:,:) :: x_found_all,y_found_all,z_found_all
+
+ integer irec
+ integer i,j,k,ispec,iglob
+ integer ier
+
+ double precision ell
+ double precision elevation
+ double precision n(3)
+ double precision thetan,phin
+ double precision sint,cost,sinp,cosp
+ double precision r0,p20
+ double precision theta,phi
+ double precision theta_source,phi_source
+ double precision dist
+ double precision xi,eta,gamma,dx,dy,dz,dxi,deta,dgamma
+
+! topology of the control points of the surface element
+ integer iax,iay,iaz
+ integer iaddx(NGNOD),iaddy(NGNOD),iaddr(NGNOD)
+
+! coordinates of the control points of the surface element
+ double precision xelm(NGNOD),yelm(NGNOD),zelm(NGNOD)
+
+ integer iter_loop,ispec_iterate
+
+ integer ia
+ double precision x,y,z
+ double precision xix,xiy,xiz
+ double precision etax,etay,etaz
+ double precision gammax,gammay,gammaz
+
+! timer MPI
+ double precision time_start,tCPU
+
+! use dynamic allocation
+ double precision, dimension(:), allocatable :: final_distance
+ double precision, dimension(:,:), allocatable :: final_distance_all
+ double precision distmin,final_distance_max
+
+! receiver information
+! timing information for the stations
+! station information for writing the seismograms
+ integer nsamp
+ integer, dimension(nrec) :: islice_selected_rec,ispec_selected_rec
+ double precision, dimension(nrec) :: xi_receiver,eta_receiver,gamma_receiver
+ double precision, dimension(3,3,nrec) :: nu
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+
+ integer, dimension(nrec) :: islice_selected_rec_found,ispec_selected_rec_found
+ double precision, dimension(nrec) :: xi_receiver_found,eta_receiver_found,gamma_receiver_found
+ double precision, dimension(3,3,nrec) :: nu_found
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name_found
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name_found
+ double precision, dimension(nrec) :: stlat_found,stlon_found,stele_found, epidist_found
+ character(len=150) STATIONS
+
+ integer, allocatable, dimension(:,:) :: ispec_selected_rec_all
+ double precision, dimension(nrec) :: stlat,stlon,stele
+ double precision, allocatable, dimension(:) :: stbur
+ double precision, allocatable, dimension(:,:) :: xi_receiver_all,eta_receiver_all,gamma_receiver_all
+
+ character(len=150) OUTPUT_FILES
+
+! **************
+
+! make sure we clean the array before the gather
+ ispec_selected_rec(:) = 0
+
+! get MPI starting time
+ time_start = MPI_WTIME()
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '********************'
+ write(IMAIN,*) ' locating receivers'
+ write(IMAIN,*) '********************'
+ write(IMAIN,*)
+ endif
+
+! define topology of the control element
+ call hex_nodes(iaddx,iaddy,iaddr)
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '****************************'
+ write(IMAIN,*) 'reading receiver information'
+ write(IMAIN,*) '****************************'
+ write(IMAIN,*)
+ endif
+
+! allocate memory for arrays using number of stations
+ allocate(stbur(nrec))
+ allocate(epidist(nrec))
+
+ allocate(ix_initial_guess(nrec))
+ allocate(iy_initial_guess(nrec))
+ allocate(iz_initial_guess(nrec))
+ allocate(x_target(nrec))
+ allocate(y_target(nrec))
+ allocate(z_target(nrec))
+ allocate(x_found(nrec))
+ allocate(y_found(nrec))
+ allocate(z_found(nrec))
+ allocate(final_distance(nrec))
+
+ allocate(ispec_selected_rec_all(nrec,0:NPROCTOT-1))
+ allocate(xi_receiver_all(nrec,0:NPROCTOT-1))
+ allocate(eta_receiver_all(nrec,0:NPROCTOT-1))
+ allocate(gamma_receiver_all(nrec,0:NPROCTOT-1))
+ allocate(x_found_all(nrec,0:NPROCTOT-1))
+ allocate(y_found_all(nrec,0:NPROCTOT-1))
+ allocate(z_found_all(nrec,0:NPROCTOT-1))
+ allocate(final_distance_all(nrec,0:NPROCTOT-1))
+
+! read that STATIONS file on the master
+ if(myrank == 0) then
+ call get_value_string(STATIONS, 'solver.STATIONS', rec_filename)
+ open(unit=1,file=STATIONS,status='old',action='read')
+! loop on all the stations to read station information
+ do irec = 1,nrec
+ read(1,*) station_name(irec),network_name(irec),stlat(irec),stlon(irec),stele(irec),stbur(irec)
+ enddo
+! close receiver file
+ close(1)
+ endif
+
+! broadcast the information read on the master to the nodes
+ call MPI_BCAST(station_name,nrec*MAX_LENGTH_STATION_NAME,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(network_name,nrec*MAX_LENGTH_NETWORK_NAME,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(stlat,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(stlon,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(stele,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(stbur,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+! loop on all the stations to locate them in the mesh
+ do irec=1,nrec
+
+! set distance to huge initial value
+ distmin=HUGEVAL
+
+! convert geographic latitude stlat (degrees)
+! to geocentric colatitude theta (radians)
+ theta=PI/2.0d0-atan(0.99329534d0*dtan(stlat(irec)*PI/180.0d0))
+ phi=stlon(irec)*PI/180.0d0
+ call reduce(theta,phi)
+
+! compute epicentral distance
+ epidist(irec) = acos(cos(theta)*cos(theta_source) + &
+ sin(theta)*sin(theta_source)*cos(phi-phi_source))*180.0d0/PI
+
+! print some information about stations
+ if(myrank == 0) &
+ write(IMAIN,*) 'Station #',irec,': ',station_name(irec)(1:len_trim(station_name(irec))), &
+ '.',network_name(irec)(1:len_trim(network_name(irec))), &
+ ' epicentral distance: ',sngl(epidist(irec)),' degrees'
+
+! record three components for each station
+ do iorientation = 1,3
+
+! North
+ if(iorientation == 1) then
+ stazi = 0.d0
+ stdip = 0.d0
+! East
+ else if(iorientation == 2) then
+ stazi = 90.d0
+ stdip = 0.d0
+! Vertical
+ else if(iorientation == 3) then
+ stazi = 0.d0
+ stdip = - 90.d0
+ else
+ call exit_MPI(myrank,'incorrect orientation')
+ endif
+
+! get the orientation of the seismometer
+ thetan=(90.0d0+stdip)*PI/180.0d0
+ phin=stazi*PI/180.0d0
+
+! we use the same convention as in Harvard normal modes for the orientation
+
+! vertical component
+ n(1) = cos(thetan)
+! N-S component
+ n(2) = - sin(thetan)*cos(phin)
+! E-W component
+ n(3) = sin(thetan)*sin(phin)
+
+! get the Cartesian components of n in the model: nu
+ sint = sin(theta)
+ cost = cos(theta)
+ sinp = sin(phi)
+ cosp = cos(phi)
+ nu(iorientation,1,irec) = n(1)*sint*cosp+n(2)*cost*cosp-n(3)*sinp
+ nu(iorientation,2,irec) = n(1)*sint*sinp+n(2)*cost*sinp+n(3)*cosp
+ nu(iorientation,3,irec) = n(1)*cost-n(2)*sint
+
+ enddo
+
+! ellipticity
+ r0=1.0d0
+ if(ELLIPTICITY) then
+ if(TOPOGRAPHY) then
+ call get_topo_bathy(stlat(irec),stlon(irec),elevation,ibathy_topo)
+ r0 = r0 + elevation/R_EARTH
+ endif
+ cost=cos(theta)
+ p20=0.5d0*(3.0d0*cost*cost-1.0d0)
+ call spline_evaluation(rspl,espl,espl2,nspl,r0,ell)
+ r0=r0*(1.0d0-(2.0d0/3.0d0)*ell*p20)
+ endif
+
+! subtract station burial depth (in meters)
+ r0 = r0 - stbur(irec)/R_EARTH
+
+! compute the Cartesian position of the receiver
+ x_target(irec) = r0*sin(theta)*cos(phi)
+ y_target(irec) = r0*sin(theta)*sin(phi)
+ z_target(irec) = r0*cos(theta)
+
+! examine top of the elements only (receivers always at the surface)
+! k = NGLLZ
+
+ do ispec=1,nspec
+
+! loop only on points inside the element
+! exclude edges to ensure this point is not shared with other elements
+ do k=2,NGLLZ-1
+ do j=2,NGLLY-1
+ do i=2,NGLLX-1
+
+ iglob = ibool(i,j,k,ispec)
+ dist = dsqrt((x_target(irec)-dble(xstore(iglob)))**2 &
+ +(y_target(irec)-dble(ystore(iglob)))**2 &
+ +(z_target(irec)-dble(zstore(iglob)))**2)
+
+! keep this point if it is closer to the receiver
+ if(dist < distmin) then
+ distmin = dist
+ ispec_selected_rec(irec) = ispec
+ ix_initial_guess(irec) = i
+ iy_initial_guess(irec) = j
+ iz_initial_guess(irec) = k
+ endif
+
+ enddo
+ enddo
+ enddo
+
+! end of loop on all the spectral elements in current slice
+ enddo
+
+! end of loop on all the stations
+ enddo
+
+! create RECORDHEADER file with usual format for normal-mode codes
+ if(myrank == 0) then
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! create file for QmX Harvard
+! Harvard format does not support the network name
+! therefore only the station name is included below
+! compute total number of samples for normal modes with 1 sample per second
+ open(unit=1,file=trim(OUTPUT_FILES)//'/RECORDHEADERS',status='unknown')
+ nsamp = nint(dble(NSTEP-1)*DT)
+ do irec = 1,nrec
+
+ if(stele(irec) >= -999.9999) then
+ write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,f6.1,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
+ station_name(irec),'LHN',stlat(irec),stlon(irec),stele(irec),stbur(irec), &
+ 0.,0.,1.,nsamp,yr,jda,ho,mi,sec
+ write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,f6.1,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
+ station_name(irec),'LHE',stlat(irec),stlon(irec),stele(irec),stbur(irec), &
+ 90.,0.,1.,nsamp,yr,jda,ho,mi,sec
+ write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,f6.1,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
+ station_name(irec),'LHZ',stlat(irec),stlon(irec),stele(irec),stbur(irec), &
+ 0.,-90.,1.,nsamp,yr,jda,ho,mi,sec
+ else
+! very deep ocean-bottom stations such as H2O are not compatible
+! with the standard RECORDHEADERS format because of the f6.1 format
+! therefore suppress decimals for depth in that case
+ write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,i6,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
+ station_name(irec),'LHN',stlat(irec),stlon(irec),nint(stele(irec)),stbur(irec), &
+ 0.,0.,1.,nsamp,yr,jda,ho,mi,sec
+ write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,i6,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
+ station_name(irec),'LHE',stlat(irec),stlon(irec),nint(stele(irec)),stbur(irec), &
+ 90.,0.,1.,nsamp,yr,jda,ho,mi,sec
+ write(1,"(a8,1x,a3,6x,f8.4,1x,f9.4,1x,i6,1x,f6.1,f6.1,1x,f6.1,1x,f12.4,1x,i7,1x,i4,1x,i3,1x,i2,1x,i2,1x,f6.3)") &
+ station_name(irec),'LHZ',stlat(irec),stlon(irec),nint(stele(irec)),stbur(irec), &
+ 0.,-90.,1.,nsamp,yr,jda,ho,mi,sec
+ endif
+ enddo
+ close(1)
+
+ endif
+
+! ****************************************
+! find the best (xi,eta) for each receiver
+! ****************************************
+
+! loop on all the receivers to iterate in that slice
+ do irec = 1,nrec
+
+ ispec_iterate = ispec_selected_rec(irec)
+
+! use initial guess in xi and eta
+ xi = xigll(ix_initial_guess(irec))
+ eta = yigll(iy_initial_guess(irec))
+ gamma = zigll(iz_initial_guess(irec))
+
+! define coordinates of the control points of the element
+
+ do ia=1,NGNOD
+
+ if(iaddx(ia) == 0) then
+ iax = 1
+ else if(iaddx(ia) == 1) then
+ iax = (NGLLX+1)/2
+ else if(iaddx(ia) == 2) then
+ iax = NGLLX
+ else
+ call exit_MPI(myrank,'incorrect value of iaddx')
+ endif
+
+ if(iaddy(ia) == 0) then
+ iay = 1
+ else if(iaddy(ia) == 1) then
+ iay = (NGLLY+1)/2
+ else if(iaddy(ia) == 2) then
+ iay = NGLLY
+ else
+ call exit_MPI(myrank,'incorrect value of iaddy')
+ endif
+
+ if(iaddr(ia) == 0) then
+ iaz = 1
+ else if(iaddr(ia) == 1) then
+ iaz = (NGLLZ+1)/2
+ else if(iaddr(ia) == 2) then
+ iaz = NGLLZ
+ else
+ call exit_MPI(myrank,'incorrect value of iaddr')
+ endif
+
+ iglob = ibool(iax,iay,iaz,ispec_iterate)
+ xelm(ia) = dble(xstore(iglob))
+ yelm(ia) = dble(ystore(iglob))
+ zelm(ia) = dble(zstore(iglob))
+
+ enddo
+
+! iterate to solve the non linear system
+ do iter_loop = 1,NUM_ITER
+
+! impose receiver exactly at the surface
+ if(.not. RECEIVERS_CAN_BE_BURIED) gamma = 1.d0
+
+! recompute jacobian for the new point
+ call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
+
+! compute distance to target location
+ dx = - (x - x_target(irec))
+ dy = - (y - y_target(irec))
+ dz = - (z - z_target(irec))
+
+! compute increments
+! gamma does not change since we know the receiver is exactly on the surface
+ dxi = xix*dx + xiy*dy + xiz*dz
+ deta = etax*dx + etay*dy + etaz*dz
+ if(RECEIVERS_CAN_BE_BURIED) dgamma = gammax*dx + gammay*dy + gammaz*dz
+
+! update values
+ xi = xi + dxi
+ eta = eta + deta
+ if(RECEIVERS_CAN_BE_BURIED) gamma = gamma + dgamma
+
+! impose that we stay in that element
+! (useful if user gives a receiver outside the mesh for instance)
+! we can go slightly outside the [1,1] segment since with finite elements
+! the polynomial solution is defined everywhere
+! can be useful for convergence of iterative scheme with distorted elements
+ if (xi > 1.10d0) xi = 1.10d0
+ if (xi < -1.10d0) xi = -1.10d0
+ if (eta > 1.10d0) eta = 1.10d0
+ if (eta < -1.10d0) eta = -1.10d0
+ if (gamma > 1.10d0) gamma = 1.10d0
+ if (gamma < -1.10d0) gamma = -1.10d0
+
+! end of non linear iterations
+ enddo
+
+! impose receiver exactly at the surface after final iteration
+ if(.not. RECEIVERS_CAN_BE_BURIED) gamma = 1.d0
+
+! compute final coordinates of point found
+ call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
+
+! store xi,eta and x,y,z of point found
+ xi_receiver(irec) = xi
+ eta_receiver(irec) = eta
+ gamma_receiver(irec) = gamma
+ x_found(irec) = x
+ y_found(irec) = y
+ z_found(irec) = z
+
+! compute final distance between asked and found (converted to km)
+ final_distance(irec) = dsqrt((x_target(irec)-x_found(irec))**2 + &
+ (y_target(irec)-y_found(irec))**2 + (z_target(irec)-z_found(irec))**2)*R_EARTH/1000.d0
+
+ enddo
+
+! for MPI version, gather information from all the nodes
+ ispec_selected_rec_all(:,:) = -1
+ call MPI_GATHER(ispec_selected_rec,nrec,MPI_INTEGER,ispec_selected_rec_all,nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_GATHER(xi_receiver,nrec,MPI_DOUBLE_PRECISION,xi_receiver_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(eta_receiver,nrec,MPI_DOUBLE_PRECISION,eta_receiver_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(gamma_receiver,nrec,MPI_DOUBLE_PRECISION,gamma_receiver_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(final_distance,nrec,MPI_DOUBLE_PRECISION,final_distance_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(x_found,nrec,MPI_DOUBLE_PRECISION,x_found_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(y_found,nrec,MPI_DOUBLE_PRECISION,y_found_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(z_found,nrec,MPI_DOUBLE_PRECISION,z_found_all,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+! this is executed by main process only
+ if(myrank == 0) then
+
+! check that the gather operation went well
+ if(any(ispec_selected_rec_all(:,:) == -1)) call exit_MPI(myrank,'gather operation failed for receivers')
+
+! MPI loop on all the results to determine the best slice
+ islice_selected_rec(:) = -1
+ do irec = 1,nrec
+ distmin = HUGEVAL
+ do iprocloop = 0,NPROCTOT-1
+ if(final_distance_all(irec,iprocloop) < distmin) then
+ distmin = final_distance_all(irec,iprocloop)
+ islice_selected_rec(irec) = iprocloop
+ ispec_selected_rec(irec) = ispec_selected_rec_all(irec,iprocloop)
+ xi_receiver(irec) = xi_receiver_all(irec,iprocloop)
+ eta_receiver(irec) = eta_receiver_all(irec,iprocloop)
+ gamma_receiver(irec) = gamma_receiver_all(irec,iprocloop)
+ x_found(irec) = x_found_all(irec,iprocloop)
+ y_found(irec) = y_found_all(irec,iprocloop)
+ z_found(irec) = z_found_all(irec,iprocloop)
+ endif
+ enddo
+ final_distance(irec) = distmin
+ enddo
+
+ nrec_found = 0
+ do irec=1,nrec
+
+ if(final_distance(irec) == HUGEVAL) call exit_MPI(myrank,'error locating receiver')
+
+ if(DISPLAY_DETAILS_STATIONS) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'station # ',irec,' ',station_name(irec),network_name(irec)
+ write(IMAIN,*) ' original latitude: ',sngl(stlat(irec))
+ write(IMAIN,*) ' original longitude: ',sngl(stlon(irec))
+ write(IMAIN,*) ' epicentral distance: ',sngl(epidist(irec))
+ write(IMAIN,*) 'closest estimate found: ',sngl(final_distance(irec)),' km away'
+ write(IMAIN,*) ' in slice ',islice_selected_rec(irec),' in element ',ispec_selected_rec(irec)
+ write(IMAIN,*) ' at xi,eta,gamma coordinates = ',xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec)
+ endif
+
+! add warning if estimate is poor
+! (usually means receiver outside the mesh given by the user)
+ if(final_distance(irec) > THRESHOLD_EXCLUDE_STATION) then
+ write(IMAIN,*) 'station # ',irec,' ',station_name(irec),network_name(irec)
+ write(IMAIN,*) '*****************************************************************'
+ if(NCHUNKS == 6) then
+ write(IMAIN,*) '***** WARNING: receiver location estimate is poor, therefore receiver excluded *****'
+ else
+ write(IMAIN,*) '***** WARNING: receiver is located outside the mesh, therefore excluded *****'
+ endif
+ write(IMAIN,*) '*****************************************************************'
+ else
+ nrec_found = nrec_found + 1
+ islice_selected_rec_found(nrec_found) = islice_selected_rec(irec)
+ ispec_selected_rec_found(nrec_found) = ispec_selected_rec(irec)
+ xi_receiver_found(nrec_found) = xi_receiver(irec)
+ eta_receiver_found(nrec_found) = eta_receiver(irec)
+ gamma_receiver_found(nrec_found) = gamma_receiver(irec)
+ station_name_found(nrec_found) = station_name(irec)
+ network_name_found(nrec_found) = network_name(irec)
+ stlat_found(nrec_found) = stlat(irec)
+ stlon_found(nrec_found) = stlon(irec)
+ stele_found(nrec_found) = stele(irec)
+ nu_found(:,:,nrec_found) = nu(:,:,irec)
+ epidist_found(nrec_found) = epidist(irec)
+ endif
+
+ enddo
+
+! compute maximal distance for all the receivers
+ final_distance_max = maxval(final_distance(:))
+
+! display maximum error for all the receivers
+ write(IMAIN,*)
+ write(IMAIN,*) 'maximum error in location of all the receivers: ',sngl(final_distance_max),' km'
+
+! add warning if estimate is poor
+! (usually means receiver outside the mesh given by the user)
+ if(final_distance_max > THRESHOLD_EXCLUDE_STATION) then
+ write(IMAIN,*)
+ write(IMAIN,*) '************************************************************'
+ write(IMAIN,*) '************************************************************'
+ write(IMAIN,*) '***** WARNING: at least one receiver was excluded from the station list *****'
+ write(IMAIN,*) '************************************************************'
+ write(IMAIN,*) '************************************************************'
+ endif
+
+ nrec = nrec_found
+ islice_selected_rec(1:nrec) = islice_selected_rec_found(1:nrec)
+ ispec_selected_rec(1:nrec) = ispec_selected_rec_found(1:nrec)
+ xi_receiver(1:nrec) = xi_receiver_found(1:nrec)
+ eta_receiver(1:nrec) = eta_receiver_found(1:nrec)
+ gamma_receiver(1:nrec) = gamma_receiver_found(1:nrec)
+ station_name(1:nrec) = station_name_found(1:nrec)
+ network_name(1:nrec) = network_name_found(1:nrec)
+ stlat(1:nrec) = stlat_found(1:nrec)
+ stlon(1:nrec) = stlon_found(1:nrec)
+ stele(1:nrec) = stele_found(1:nrec)
+ nu(:,:,1:nrec) = nu_found(:,:,1:nrec)
+ epidist(1:nrec) = epidist_found(1:nrec)
+
+! write the list of stations and associated epicentral distance
+ open(unit=27,file=trim(OUTPUT_FILES)//'/output_list_stations.txt',status='unknown')
+ write(27,*)
+ write(27,*) 'total number of stations: ',nrec
+ write(27,*)
+ do irec=1,nrec
+ write(27,*) station_name(irec)(1:len_trim(station_name(irec))), &
+ '.',network_name(irec)(1:len_trim(network_name(irec))), &
+ ' epicentral distance ',sngl(epidist(irec)),' deg'
+ enddo
+ close(27)
+
+! elapsed time since beginning of mesh generation
+ tCPU = MPI_WTIME() - time_start
+ write(IMAIN,*)
+ write(IMAIN,*) 'Elapsed time for receiver detection in seconds = ',tCPU
+ write(IMAIN,*)
+ write(IMAIN,*) 'End of receiver detection - done'
+ write(IMAIN,*)
+
+ endif ! end of section executed by main process only
+
+! main process broadcasts the results to all the slices
+ call MPI_BCAST(nrec,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(islice_selected_rec,nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ispec_selected_rec,nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(xi_receiver,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(eta_receiver,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(gamma_receiver,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(station_name,nrec*MAX_LENGTH_STATION_NAME,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(network_name,nrec*MAX_LENGTH_NETWORK_NAME,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(stlat,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(stlon,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(stele,nrec,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(nu,nrec*3*3,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+! deallocate arrays
+ deallocate(stbur)
+ deallocate(epidist)
+ deallocate(ix_initial_guess)
+ deallocate(iy_initial_guess)
+ deallocate(iz_initial_guess)
+ deallocate(x_target)
+ deallocate(y_target)
+ deallocate(z_target)
+ deallocate(x_found)
+ deallocate(y_found)
+ deallocate(z_found)
+ deallocate(final_distance)
+ deallocate(ispec_selected_rec_all)
+ deallocate(xi_receiver_all)
+ deallocate(eta_receiver_all)
+ deallocate(gamma_receiver_all)
+ deallocate(x_found_all)
+ deallocate(y_found_all)
+ deallocate(z_found_all)
+ deallocate(final_distance_all)
+
+ end subroutine locate_receivers
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/locate_sources.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/locate_sources.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/locate_sources.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,706 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!----
+!---- locate_sources finds the correct position of the sources
+!----
+
+ subroutine locate_sources(NSOURCES,myrank,nspec,nglob,ibool,&
+ xstore,ystore,zstore,xigll,yigll,zigll, &
+ NPROCTOT,ELLIPTICITY,TOPOGRAPHY, &
+ sec,t_cmt,yr,jda,ho,mi,theta_source,phi_source, &
+ NSTEP,DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ islice_selected_source,ispec_selected_source, &
+ xi_source,eta_source,gamma_source, nu_source, &
+ rspl,espl,espl2,nspl,ibathy_topo,NEX_XI,PRINT_SOURCE_TIME_FUNCTION)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer NPROCTOT
+ integer NSTEP,NSOURCES,NEX_XI
+
+ logical ELLIPTICITY,TOPOGRAPHY,PRINT_SOURCE_TIME_FUNCTION
+
+ double precision DT
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+ integer nspec,nglob,myrank,isource
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+! arrays containing coordinates of the points
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ)
+
+ double precision nu_source(NDIM,NDIM,NSOURCES)
+
+ integer yr,jda,ho,mi
+
+ double precision sec
+ double precision t_cmt(NSOURCES)
+ double precision t0, hdur_gaussian(NSOURCES)
+
+ integer iprocloop
+
+ integer i,j,k,ispec,iglob
+ integer ier
+
+ double precision ell
+ double precision elevation
+ double precision r0,dcost,p20
+ double precision theta,phi
+ double precision, dimension(NSOURCES) :: theta_source,phi_source
+ double precision dist,typical_size
+ double precision xi,eta,gamma,dx,dy,dz,dxi,deta
+
+! topology of the control points of the surface element
+ integer iax,iay,iaz
+ integer iaddx(NGNOD),iaddy(NGNOD),iaddr(NGNOD)
+
+! coordinates of the control points of the surface element
+ double precision xelm(NGNOD),yelm(NGNOD),zelm(NGNOD)
+
+ integer iter_loop
+
+ integer ia
+ double precision x,y,z
+ double precision xix,xiy,xiz
+ double precision etax,etay,etaz
+ double precision gammax,gammay,gammaz
+ double precision dgamma
+
+ double precision final_distance_source(NSOURCES)
+ double precision, dimension(:), allocatable :: final_distance_source_subset
+
+ double precision x_target_source,y_target_source,z_target_source
+ double precision r_target_source
+
+ integer islice_selected_source(NSOURCES)
+
+! timer MPI
+ double precision time_start,tCPU
+
+ integer isources_already_done,isource_in_this_subset
+ integer ispec_selected_source(NSOURCES)
+ integer, dimension(:), allocatable :: ispec_selected_source_subset
+
+ integer, dimension(:,:), allocatable :: ispec_selected_source_all
+ double precision, dimension(:,:), allocatable :: xi_source_all,eta_source_all,gamma_source_all, &
+ final_distance_source_all,x_found_source_all,y_found_source_all,z_found_source_all
+
+ double precision hdur(NSOURCES)
+
+ double precision, dimension(NSOURCES) :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
+ double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
+ double precision, dimension(:), allocatable :: xi_source_subset,eta_source_subset,gamma_source_subset
+
+ double precision, dimension(NSOURCES) :: lat,long,depth
+ double precision scalar_moment
+ double precision moment_tensor(6,NSOURCES)
+ double precision radius
+
+ character(len=150) OUTPUT_FILES,plot_file
+
+ double precision, dimension(:), allocatable :: x_found_source,y_found_source,z_found_source
+ double precision r_found_source
+ double precision st,ct,sp,cp
+ double precision Mrr,Mtt,Mpp,Mrt,Mrp,Mtp
+ double precision colat_source
+ double precision distmin
+
+ integer :: ix_initial_guess_source,iy_initial_guess_source,iz_initial_guess_source,NSOURCES_SUBSET_current_size
+
+ logical located_target
+
+! for calculation of source time function and spectrum
+ integer it,iom
+ double precision time_source,om
+ double precision, external :: comp_source_time_function,comp_source_spectrum
+
+! number of points to plot the source time function and spectrum
+ integer, parameter :: NSAMP_PLOT_SOURCE = 1000
+
+ integer iorientation
+ double precision stazi,stdip,thetan,phin,n(3)
+
+! **************
+
+! make sure we clean the future final array
+ ispec_selected_source(:) = 0
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! read all the sources
+ if(myrank == 0) call get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,DT,NSOURCES)
+! broadcast the information read on the master to the nodes
+ call MPI_BCAST(yr,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(jda,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ho,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(mi,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(sec,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(t_cmt,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(hdur,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(lat,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(long,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(depth,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(moment_tensor,6*NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+! define topology of the control element
+ call hex_nodes(iaddx,iaddy,iaddr)
+
+! get MPI starting time for all sources
+ time_start = MPI_WTIME()
+
+! convert the half duration for triangle STF to the one for gaussian STF
+ hdur_gaussian = hdur/SOURCE_DECAY_MIMIC_TRIANGLE
+
+! define t0 as the earliest start time
+ t0 = - 1.5d0*minval(t_cmt-hdur)
+
+! loop on all the sources
+! gather source information in subsets to reduce memory requirements
+
+! loop over subsets of sources
+ do isources_already_done = 0, NSOURCES, NSOURCES_SUBSET_MAX
+
+! the size of the subset can be the maximum size, or less (if we are in the last subset,
+! or if there are fewer sources than the maximum size of a subset)
+ NSOURCES_SUBSET_current_size = min(NSOURCES_SUBSET_MAX, NSOURCES - isources_already_done)
+
+! allocate arrays specific to each subset
+ allocate(final_distance_source_subset(NSOURCES_SUBSET_current_size))
+
+ allocate(ispec_selected_source_subset(NSOURCES_SUBSET_current_size))
+
+ allocate(ispec_selected_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
+
+ allocate(xi_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
+ allocate(eta_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
+ allocate(gamma_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
+
+ allocate(final_distance_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
+
+ allocate(x_found_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
+ allocate(y_found_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
+ allocate(z_found_source_all(NSOURCES_SUBSET_current_size,0:NPROCTOT-1))
+
+ allocate(xi_source_subset(NSOURCES_SUBSET_current_size))
+ allocate(eta_source_subset(NSOURCES_SUBSET_current_size))
+ allocate(gamma_source_subset(NSOURCES_SUBSET_current_size))
+
+ allocate(x_found_source(NSOURCES_SUBSET_current_size))
+ allocate(y_found_source(NSOURCES_SUBSET_current_size))
+ allocate(z_found_source(NSOURCES_SUBSET_current_size))
+
+! make sure we clean the subset array before the gather
+ ispec_selected_source_subset(:) = 0
+
+! loop over sources within this subset
+ do isource_in_this_subset = 1,NSOURCES_SUBSET_current_size
+
+! mapping from source number in current subset to real source number in all the subsets
+ isource = isource_in_this_subset + isources_already_done
+
+! convert geographic latitude lat (degrees)
+! to geocentric colatitude theta (radians)
+ theta=PI/2.0d0-atan(0.99329534d0*dtan(lat(isource)*PI/180.0d0))
+ phi=long(isource)*PI/180.0d0
+ call reduce(theta,phi)
+
+! get the moment tensor
+ Mrr = moment_tensor(1,isource)
+ Mtt = moment_tensor(2,isource)
+ Mpp = moment_tensor(3,isource)
+ Mrt = moment_tensor(4,isource)
+ Mrp = moment_tensor(5,isource)
+ Mtp = moment_tensor(6,isource)
+
+! convert from a spherical to a Cartesian representation of the moment tensor
+ st=dsin(theta)
+ ct=dcos(theta)
+ sp=dsin(phi)
+ cp=dcos(phi)
+
+ Mxx(isource)=st*st*cp*cp*Mrr+ct*ct*cp*cp*Mtt+sp*sp*Mpp &
+ +2.0d0*st*ct*cp*cp*Mrt-2.0d0*st*sp*cp*Mrp-2.0d0*ct*sp*cp*Mtp
+ Myy(isource)=st*st*sp*sp*Mrr+ct*ct*sp*sp*Mtt+cp*cp*Mpp &
+ +2.0d0*st*ct*sp*sp*Mrt+2.0d0*st*sp*cp*Mrp+2.0d0*ct*sp*cp*Mtp
+ Mzz(isource)=ct*ct*Mrr+st*st*Mtt-2.0d0*st*ct*Mrt
+ Mxy(isource)=st*st*sp*cp*Mrr+ct*ct*sp*cp*Mtt-sp*cp*Mpp &
+ +2.0d0*st*ct*sp*cp*Mrt+st*(cp*cp-sp*sp)*Mrp+ct*(cp*cp-sp*sp)*Mtp
+ Mxz(isource)=st*ct*cp*Mrr-st*ct*cp*Mtt &
+ +(ct*ct-st*st)*cp*Mrt-ct*sp*Mrp+st*sp*Mtp
+ Myz(isource)=st*ct*sp*Mrr-st*ct*sp*Mtt &
+ +(ct*ct-st*st)*sp*Mrt+ct*cp*Mrp-st*cp*Mtp
+
+! record three components for each station
+ do iorientation = 1,3
+
+! North
+ if(iorientation == 1) then
+ stazi = 0.d0
+ stdip = 0.d0
+! East
+ else if(iorientation == 2) then
+ stazi = 90.d0
+ stdip = 0.d0
+! Vertical
+ else if(iorientation == 3) then
+ stazi = 0.d0
+ stdip = - 90.d0
+ else
+ call exit_MPI(myrank,'incorrect orientation')
+ endif
+
+! get the orientation of the seismometer
+ thetan=(90.0d0+stdip)*PI/180.0d0
+ phin=stazi*PI/180.0d0
+
+! we use the same convention as in Harvard normal modes for the orientation
+
+! vertical component
+ n(1) = dcos(thetan)
+! N-S component
+ n(2) = - dsin(thetan)*dcos(phin)
+! E-W component
+ n(3) = dsin(thetan)*dsin(phin)
+
+! get the Cartesian components of n in the model: nu
+ nu_source(iorientation,1,isource) = n(1)*st*cp+n(2)*ct*cp-n(3)*sp
+ nu_source(iorientation,2,isource) = n(1)*st*sp+n(2)*ct*sp+n(3)*cp
+ nu_source(iorientation,3,isource) = n(1)*ct-n(2)*st
+
+ enddo
+
+! normalized source radius
+ r0 = R_UNIT_SPHERE
+
+ if(ELLIPTICITY) then
+ if(TOPOGRAPHY) then
+ call get_topo_bathy(lat(isource),long(isource),elevation,ibathy_topo)
+ r0 = r0 + elevation/R_EARTH
+ endif
+ dcost = dcos(theta)
+ p20 = 0.5d0*(3.0d0*dcost*dcost-1.0d0)
+ radius = r0 - depth(isource)*1000.0d0/R_EARTH
+ call spline_evaluation(rspl,espl,espl2,nspl,radius,ell)
+ r0 = r0*(1.0d0-(2.0d0/3.0d0)*ell*p20)
+ endif
+
+! compute the Cartesian position of the source
+ r_target_source = r0 - depth(isource)*1000.0d0/R_EARTH
+ x_target_source = r_target_source*dsin(theta)*dcos(phi)
+ y_target_source = r_target_source*dsin(theta)*dsin(phi)
+ z_target_source = r_target_source*dcos(theta)
+
+! set distance to huge initial value
+ distmin = HUGEVAL
+
+! compute typical size of elements at the surface
+ typical_size = TWO_PI * R_UNIT_SPHERE / (4.*NEX_XI)
+
+! use 10 times the distance as a criterion for source detection
+ typical_size = 10. * typical_size
+
+! flag to check that we located at least one target element
+ located_target = .false.
+
+ do ispec = 1,nspec
+
+! exclude elements that are too far from target
+ iglob = ibool(1,1,1,ispec)
+ dist = dsqrt((x_target_source - dble(xstore(iglob)))**2 &
+ + (y_target_source - dble(ystore(iglob)))**2 &
+ + (z_target_source - dble(zstore(iglob)))**2)
+ if(USE_DISTANCE_CRITERION .and. dist > typical_size) cycle
+
+ located_target = .true.
+
+! loop only on points inside the element
+! exclude edges to ensure this point is not shared with other elements
+ do k = 2,NGLLZ-1
+ do j = 2,NGLLY-1
+ do i = 2,NGLLX-1
+
+! keep this point if it is closer to the receiver
+ iglob = ibool(i,j,k,ispec)
+ dist = dsqrt((x_target_source - dble(xstore(iglob)))**2 &
+ +(y_target_source - dble(ystore(iglob)))**2 &
+ +(z_target_source - dble(zstore(iglob)))**2)
+ if(dist < distmin) then
+ distmin = dist
+ ispec_selected_source_subset(isource_in_this_subset) = ispec
+ ix_initial_guess_source = i
+ iy_initial_guess_source = j
+ iz_initial_guess_source = k
+ endif
+
+ enddo
+ enddo
+ enddo
+
+! end of loop on all the elements in current slice
+ enddo
+
+! *******************************************
+! find the best (xi,eta,gamma) for the source
+! *******************************************
+
+! if we have not located a target element, the source is not in this slice
+! therefore use first element only for fictitious iterative search
+ if(.not. located_target) then
+ ispec_selected_source_subset(isource_in_this_subset)=1
+ ix_initial_guess_source = 2
+ iy_initial_guess_source = 2
+ iz_initial_guess_source = 2
+ endif
+
+! use initial guess in xi, eta and gamma
+ xi = xigll(ix_initial_guess_source)
+ eta = yigll(iy_initial_guess_source)
+ gamma = zigll(iz_initial_guess_source)
+
+! define coordinates of the control points of the element
+
+ do ia=1,NGNOD
+
+ if(iaddx(ia) == 0) then
+ iax = 1
+ else if(iaddx(ia) == 1) then
+ iax = (NGLLX+1)/2
+ else if(iaddx(ia) == 2) then
+ iax = NGLLX
+ else
+ call exit_MPI(myrank,'incorrect value of iaddx')
+ endif
+
+ if(iaddy(ia) == 0) then
+ iay = 1
+ else if(iaddy(ia) == 1) then
+ iay = (NGLLY+1)/2
+ else if(iaddy(ia) == 2) then
+ iay = NGLLY
+ else
+ call exit_MPI(myrank,'incorrect value of iaddy')
+ endif
+
+ if(iaddr(ia) == 0) then
+ iaz = 1
+ else if(iaddr(ia) == 1) then
+ iaz = (NGLLZ+1)/2
+ else if(iaddr(ia) == 2) then
+ iaz = NGLLZ
+ else
+ call exit_MPI(myrank,'incorrect value of iaddr')
+ endif
+
+ iglob = ibool(iax,iay,iaz,ispec_selected_source_subset(isource_in_this_subset))
+ xelm(ia) = dble(xstore(iglob))
+ yelm(ia) = dble(ystore(iglob))
+ zelm(ia) = dble(zstore(iglob))
+
+ enddo
+
+! iterate to solve the non linear system
+ do iter_loop = 1,NUM_ITER
+
+! recompute jacobian for the new point
+ call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
+
+! compute distance to target location
+ dx = - (x - x_target_source)
+ dy = - (y - y_target_source)
+ dz = - (z - z_target_source)
+
+! compute increments
+ dxi = xix*dx + xiy*dy + xiz*dz
+ deta = etax*dx + etay*dy + etaz*dz
+ dgamma = gammax*dx + gammay*dy + gammaz*dz
+
+! update values
+ xi = xi + dxi
+ eta = eta + deta
+ gamma = gamma + dgamma
+
+! impose that we stay in that element
+! (useful if user gives a source outside the mesh for instance)
+ if (xi > 1.d0) xi = 1.d0
+ if (xi < -1.d0) xi = -1.d0
+ if (eta > 1.d0) eta = 1.d0
+ if (eta < -1.d0) eta = -1.d0
+ if (gamma > 1.d0) gamma = 1.d0
+ if (gamma < -1.d0) gamma = -1.d0
+
+ enddo
+
+! compute final coordinates of point found
+ call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
+
+! store xi,eta,gamma and x,y,z of point found
+ xi_source_subset(isource_in_this_subset) = xi
+ eta_source_subset(isource_in_this_subset) = eta
+ gamma_source_subset(isource_in_this_subset) = gamma
+ x_found_source(isource_in_this_subset) = x
+ y_found_source(isource_in_this_subset) = y
+ z_found_source(isource_in_this_subset) = z
+
+! compute final distance between asked and found (converted to km)
+ final_distance_source_subset(isource_in_this_subset) = dsqrt((x_target_source-x_found_source(isource_in_this_subset))**2 + &
+ (y_target_source-y_found_source(isource_in_this_subset))**2 + &
+ (z_target_source-z_found_source(isource_in_this_subset))**2)*R_EARTH/1000.d0
+
+! end of loop on all the sources
+ enddo
+
+! now gather information from all the nodes
+! use -1 as a flag to detect if gather fails for some reason
+ ispec_selected_source_all(:,:) = -1
+ call MPI_GATHER(ispec_selected_source_subset,NSOURCES_SUBSET_current_size,MPI_INTEGER, &
+ ispec_selected_source_all,NSOURCES_SUBSET_current_size,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(xi_source_subset,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
+ xi_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(eta_source_subset,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
+ eta_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(gamma_source_subset,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
+ gamma_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(final_distance_source_subset,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
+ final_distance_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(x_found_source,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
+ x_found_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(y_found_source,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
+ y_found_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_GATHER(z_found_source,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION, &
+ z_found_source_all,NSOURCES_SUBSET_current_size,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+! this is executed by main process only
+ if(myrank == 0) then
+
+! check that the gather operation went well
+ if(minval(ispec_selected_source_all) <= 0) call exit_MPI(myrank,'gather operation failed for source')
+
+! loop on all the sources within subsets
+ do isource_in_this_subset = 1,NSOURCES_SUBSET_current_size
+
+! mapping from source number in current subset to real source number in all the subsets
+ isource = isources_already_done + isource_in_this_subset
+
+! loop on all the results to determine the best slice
+ distmin = HUGEVAL
+ do iprocloop = 0,NPROCTOT-1
+ if(final_distance_source_all(isource_in_this_subset,iprocloop) < distmin) then
+ distmin = final_distance_source_all(isource_in_this_subset,iprocloop)
+ islice_selected_source(isource) = iprocloop
+ ispec_selected_source(isource) = ispec_selected_source_all(isource_in_this_subset,iprocloop)
+ xi_source(isource) = xi_source_all(isource_in_this_subset,iprocloop)
+ eta_source(isource) = eta_source_all(isource_in_this_subset,iprocloop)
+ gamma_source(isource) = gamma_source_all(isource_in_this_subset,iprocloop)
+ x_found_source(isource_in_this_subset) = x_found_source_all(isource_in_this_subset,iprocloop)
+ y_found_source(isource_in_this_subset) = y_found_source_all(isource_in_this_subset,iprocloop)
+ z_found_source(isource_in_this_subset) = z_found_source_all(isource_in_this_subset,iprocloop)
+ endif
+ enddo
+ final_distance_source(isource) = distmin
+
+ write(IMAIN,*)
+ write(IMAIN,*) '*************************************'
+ write(IMAIN,*) ' locating source ',isource
+ write(IMAIN,*) '*************************************'
+ write(IMAIN,*)
+ write(IMAIN,*) 'source located in slice ',islice_selected_source(isource_in_this_subset)
+ write(IMAIN,*) ' in element ',ispec_selected_source(isource_in_this_subset)
+ write(IMAIN,*)
+ write(IMAIN,*) ' xi coordinate of source in that element: ',xi_source(isource)
+ write(IMAIN,*) ' eta coordinate of source in that element: ',eta_source(isource)
+ write(IMAIN,*) 'gamma coordinate of source in that element: ',gamma_source(isource)
+
+! add message if source is a Heaviside
+ if(hdur(isource) < 5.*DT) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Source time function is a Heaviside, convolve later'
+ write(IMAIN,*)
+ endif
+
+ write(IMAIN,*)
+ write(IMAIN,*) ' half duration: ',hdur(isource),' seconds'
+ write(IMAIN,*) ' time shift: ',t_cmt(isource),' seconds'
+
+! get latitude, longitude and depth of the source that will be used
+ call xyz_2_rthetaphi_dble(x_found_source(isource_in_this_subset),y_found_source(isource_in_this_subset), &
+ z_found_source(isource_in_this_subset),r_found_source,theta_source(isource),phi_source(isource))
+ call reduce(theta_source(isource),phi_source(isource))
+
+! convert geocentric to geographic colatitude
+ colat_source = PI/2.0d0-datan(1.006760466d0*dcos(theta_source(isource))/dmax1(TINYVAL,dsin(theta_source(isource))))
+ if(phi_source(isource)>PI) phi_source(isource)=phi_source(isource)-TWO_PI
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'original (requested) position of the source:'
+ write(IMAIN,*)
+ write(IMAIN,*) ' latitude: ',lat(isource)
+ write(IMAIN,*) ' longitude: ',long(isource)
+ write(IMAIN,*) ' depth: ',depth(isource),' km'
+ write(IMAIN,*)
+
+! compute real position of the source
+ write(IMAIN,*) 'position of the source that will be used:'
+ write(IMAIN,*)
+ write(IMAIN,*) ' latitude: ',(PI/2.0d0-colat_source)*180.0d0/PI
+ write(IMAIN,*) ' longitude: ',phi_source(isource)*180.0d0/PI
+ write(IMAIN,*) ' depth: ',(r0-r_found_source)*R_EARTH/1000.0d0,' km'
+ write(IMAIN,*)
+
+! display error in location estimate
+ write(IMAIN,*) 'error in location of the source: ',sngl(final_distance_source(isource)),' km'
+
+! add warning if estimate is poor
+! (usually means source outside the mesh given by the user)
+ if(final_distance_source(isource) > 50.d0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '*****************************************************'
+ write(IMAIN,*) '*****************************************************'
+ write(IMAIN,*) '***** WARNING: source location estimate is poor *****'
+ write(IMAIN,*) '*****************************************************'
+ write(IMAIN,*) '*****************************************************'
+ endif
+
+! print source time function and spectrum
+ if(PRINT_SOURCE_TIME_FUNCTION) then
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'printing the source-time function'
+
+! print the source-time function
+ if(NSOURCES == 1) then
+ plot_file = '/plot_source_time_function.txt'
+ else
+ if(isource < 10) then
+ write(plot_file,"('/plot_source_time_function',i1,'.txt')") isource
+ elseif(isource < 100) then
+ write(plot_file,"('/plot_source_time_function',i2,'.txt')") isource
+ else
+ write(plot_file,"('/plot_source_time_function',i3,'.txt')") isource
+ endif
+ endif
+ open(unit=27,file=trim(OUTPUT_FILES)//plot_file,status='unknown')
+
+ scalar_moment = 0.
+ do i = 1,6
+ scalar_moment = scalar_moment + moment_tensor(i,isource)**2
+ enddo
+ scalar_moment = dsqrt(scalar_moment/2.)
+
+ do it=1,NSTEP
+ time_source = dble(it-1)*DT-t0-t_cmt(isource)
+ write(27,*) sngl(dble(it-1)*DT-t0),sngl(scalar_moment*comp_source_time_function(time_source,hdur_gaussian(isource)))
+ enddo
+ close(27)
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'printing the source spectrum'
+
+! print the spectrum of the derivative of the source from 0 to 1/8 Hz
+ if(NSOURCES == 1) then
+ plot_file = '/plot_source_spectrum.txt'
+ else
+ if(isource < 10) then
+ write(plot_file,"('/plot_source_spectrum',i1,'.txt')") isource
+ elseif(isource < 100) then
+ write(plot_file,"('/plot_source_spectrum',i2,'.txt')") isource
+ else
+ write(plot_file,"('/plot_source_spectrum',i3,'.txt')") isource
+ endif
+ endif
+ open(unit=27,file=trim(OUTPUT_FILES)//plot_file,status='unknown')
+
+ do iom=1,NSAMP_PLOT_SOURCE
+ om=TWO_PI*(1.0d0/8.0d0)*(iom-1)/dble(NSAMP_PLOT_SOURCE-1)
+ write(27,*) sngl(om/TWO_PI),sngl(scalar_moment*om*comp_source_spectrum(om,hdur(isource)))
+ enddo
+ close(27)
+
+ endif
+
+ enddo ! end of loop on all the sources within current source subset
+
+ endif ! end of section executed by main process only
+
+! deallocate arrays specific to each subset
+ deallocate(final_distance_source_subset)
+ deallocate(ispec_selected_source_subset)
+ deallocate(ispec_selected_source_all)
+ deallocate(xi_source_all,eta_source_all,gamma_source_all,final_distance_source_all)
+ deallocate(x_found_source_all,y_found_source_all,z_found_source_all)
+ deallocate(xi_source_subset,eta_source_subset,gamma_source_subset)
+ deallocate(x_found_source,y_found_source,z_found_source)
+
+ enddo ! end of loop over all source subsets
+
+! display maximum error in location estimate
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'maximum error in location of the sources: ',sngl(maxval(final_distance_source)),' km'
+ write(IMAIN,*)
+ endif
+
+
+! main process broadcasts the results to all the slices
+ call MPI_BCAST(islice_selected_source,NSOURCES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ispec_selected_source,NSOURCES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(xi_source,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(eta_source,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(gamma_source,NSOURCES,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+! elapsed time since beginning of source detection
+ if(myrank == 0) then
+ tCPU = MPI_WTIME() - time_start
+ write(IMAIN,*)
+ write(IMAIN,*) 'Elapsed time for detection of sources in seconds = ',tCPU
+ write(IMAIN,*)
+ write(IMAIN,*) 'End of source detection - done'
+ write(IMAIN,*)
+ endif
+
+ end subroutine locate_sources
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/make_ellipticity.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/make_ellipticity.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/make_ellipticity.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/make_gravity.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/make_gravity.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/make_gravity.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/mantle_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/mantle_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/mantle_model.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/memory_eval.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/memory_eval.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/memory_eval.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,351 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! compute the approximate amount of static memory needed to run the solver
+
+ subroutine memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MANTLE,&
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_INNER_CORE,ROTATION,&
+ ONE_CRUST,doubling_index,this_region_has_a_doubling,&
+ ner,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_sampling_array,&
+ NSPEC,nglob,SIMULATION_TYPE,MOVIE_VOLUME,SAVE_FORWARD, &
+ NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION,static_memory_size)
+
+ implicit none
+
+ include "constants.h"
+
+! input
+ logical, intent(in) :: TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ ROTATION,ATTENUATION,ONE_CRUST,OCEANS,ABSORBING_CONDITIONS,MOVIE_VOLUME,SAVE_FORWARD
+ integer, dimension(MAX_NUM_REGIONS), intent(in) :: NSPEC, nglob
+ integer, intent(in) :: NEX_PER_PROC_XI,NEX_PER_PROC_ETA,SIMULATION_TYPE
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS), intent(in) :: doubling_index
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS), intent(in) :: this_region_has_a_doubling
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS), intent(in) :: ner,ratio_sampling_array
+
+! output
+ double precision, intent(out) :: static_memory_size
+
+! variables
+ integer :: ilayer,NUMBER_OF_MESH_LAYERS,ner_without_doubling,ispec_aniso
+
+ integer, intent(out) :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION
+
+! generate the elements in all the regions of the mesh
+ ispec_aniso = 0
+
+ if (ONE_CRUST) then
+ NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS - 1
+ else
+ NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS
+ endif
+
+! count anisotropic elements
+ do ilayer = 1, NUMBER_OF_MESH_LAYERS
+ if(doubling_index(ilayer) == IFLAG_220_80 .or. doubling_index(ilayer) == IFLAG_80_MOHO) then
+ ner_without_doubling = ner(ilayer)
+ if(this_region_has_a_doubling(ilayer)) then
+ ner_without_doubling = ner_without_doubling - 2
+ ispec_aniso = ispec_aniso + &
+ (NSPEC_DOUBLING_SUPERBRICK*(NEX_PER_PROC_XI/ratio_sampling_array(ilayer)/2)* &
+ (NEX_PER_PROC_ETA/ratio_sampling_array(ilayer)/2))
+ endif
+ ispec_aniso = ispec_aniso + &
+ ((NEX_PER_PROC_XI/ratio_sampling_array(ilayer))*(NEX_PER_PROC_ETA/ratio_sampling_array(ilayer))*ner_without_doubling)
+ endif
+ enddo
+
+! define static size of the arrays whose size depends on logical tests
+
+ if(ANISOTROPIC_INNER_CORE) then
+ NSPECMAX_ANISO_IC = NSPEC(IREGION_INNER_CORE)
+ else
+ NSPECMAX_ANISO_IC = 1
+ endif
+
+ if(ANISOTROPIC_3D_MANTLE) then
+ NSPECMAX_ISO_MANTLE = 1
+ NSPECMAX_TISO_MANTLE = 1
+ NSPECMAX_ANISO_MANTLE = NSPEC(IREGION_CRUST_MANTLE)
+ else
+
+ NSPECMAX_ISO_MANTLE = NSPEC(IREGION_CRUST_MANTLE)
+ if(TRANSVERSE_ISOTROPY) then
+ NSPECMAX_TISO_MANTLE = ispec_aniso
+ else
+ NSPECMAX_TISO_MANTLE = 1
+ endif
+
+ NSPECMAX_ANISO_MANTLE = 1
+ endif
+
+! if attenuation is off, set dummy size of arrays to one
+ if(ATTENUATION) then
+ NSPEC_CRUST_MANTLE_ATTENUAT = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_INNER_CORE_ATTENUATION = NSPEC(IREGION_INNER_CORE)
+ else
+ NSPEC_CRUST_MANTLE_ATTENUAT = 1
+ NSPEC_INNER_CORE_ATTENUATION = 1
+ endif
+
+ if(ATTENUATION .or. SIMULATION_TYPE /= 1 .or. SAVE_FORWARD .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then
+ NSPEC_CRUST_MANTLE_STR_OR_ATT = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_INNER_CORE_STR_OR_ATT = NSPEC(IREGION_INNER_CORE)
+ else
+ NSPEC_CRUST_MANTLE_STR_OR_ATT = 1
+ NSPEC_INNER_CORE_STR_OR_ATT = 1
+ endif
+
+ if(ATTENUATION .and. SIMULATION_TYPE == 3) then
+ NSPEC_CRUST_MANTLE_STR_AND_ATT = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_INNER_CORE_STR_AND_ATT = NSPEC(IREGION_INNER_CORE)
+ else
+ NSPEC_CRUST_MANTLE_STR_AND_ATT = 1
+ NSPEC_INNER_CORE_STR_AND_ATT = 1
+ endif
+
+
+ if(SIMULATION_TYPE /= 1 .or. SAVE_FORWARD .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_INNER_CORE_STRAIN_ONLY = NSPEC(IREGION_INNER_CORE)
+ else
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY = 1
+ NSPEC_INNER_CORE_STRAIN_ONLY = 1
+ endif
+
+ if ((SIMULATION_TYPE == 1 .and. SAVE_FORWARD) .or. SIMULATION_TYPE == 3) then
+ NSPEC_CRUST_MANTLE_ADJOINT = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_OUTER_CORE_ADJOINT = NSPEC(IREGION_OUTER_CORE)
+ NSPEC_INNER_CORE_ADJOINT = NSPEC(IREGION_INNER_CORE)
+
+ NGLOB_CRUST_MANTLE_ADJOINT = NGLOB(IREGION_CRUST_MANTLE)
+ NGLOB_OUTER_CORE_ADJOINT = NGLOB(IREGION_OUTER_CORE)
+ NGLOB_INNER_CORE_ADJOINT = NGLOB(IREGION_INNER_CORE)
+
+ if(ROTATION) then
+ NSPEC_OUTER_CORE_ROT_ADJOINT = NSPEC(IREGION_OUTER_CORE)
+ else
+ NSPEC_OUTER_CORE_ROT_ADJOINT = 1
+ endif
+ else
+ NSPEC_CRUST_MANTLE_ADJOINT = 1
+ NSPEC_OUTER_CORE_ADJOINT = 1
+ NSPEC_INNER_CORE_ADJOINT = 1
+
+ NGLOB_CRUST_MANTLE_ADJOINT = 1
+ NGLOB_OUTER_CORE_ADJOINT = 1
+ NGLOB_INNER_CORE_ADJOINT = 1
+
+ NSPEC_OUTER_CORE_ROT_ADJOINT = 1
+ endif
+
+! if absorbing conditions are off, set dummy size of arrays to one
+ if(ABSORBING_CONDITIONS) then
+ NSPEC_CRUST_MANTLE_STACEY = NSPEC(IREGION_CRUST_MANTLE)
+ NSPEC_OUTER_CORE_STACEY = NSPEC(IREGION_OUTER_CORE)
+ else
+ NSPEC_CRUST_MANTLE_STACEY = 1
+ NSPEC_OUTER_CORE_STACEY = 1
+ endif
+
+! if oceans are off, set dummy size of arrays to one
+ if(OCEANS) then
+ NGLOB_CRUST_MANTLE_OCEANS = NGLOB(IREGION_CRUST_MANTLE)
+ else
+ NGLOB_CRUST_MANTLE_OCEANS = 1
+ endif
+
+ if(ROTATION) then
+ NSPEC_OUTER_CORE_ROTATION = NSPEC(IREGION_OUTER_CORE)
+ else
+ NSPEC_OUTER_CORE_ROTATION = 1
+ endif
+
+! add size of each set of static arrays multiplied by the number of such arrays
+
+ static_memory_size = 0.d0
+
+! R_memory_crust_mantle
+ static_memory_size = static_memory_size + 5.d0*dble(N_SLS)*dble(NGLLX)* &
+ dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_ATTENUAT*dble(CUSTOM_REAL)
+
+! R_memory_inner_core
+ static_memory_size = static_memory_size + 5.d0*dble(N_SLS)*dble(NGLLX)* &
+ dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_ATTENUATION*dble(CUSTOM_REAL)
+
+! xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle
+! etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle,
+! gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_CRUST_MANTLE)*9.d0*dble(CUSTOM_REAL)
+
+! ibool_crust_mantle
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_CRUST_MANTLE)*dble(SIZE_INTEGER)
+
+! xix_outer_core,xiy_outer_core,xiz_outer_core,
+! etax_outer_core,etay_outer_core,etaz_outer_core,
+! gammax_outer_core,gammay_outer_core,gammaz_outer_core
+! kappavstore_outer_core
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_OUTER_CORE)*10.d0*dble(CUSTOM_REAL)
+
+! ibool_outer_core
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_OUTER_CORE)*dble(SIZE_INTEGER)
+
+! idoubling_crust_mantle
+ static_memory_size = static_memory_size + NSPEC(IREGION_CRUST_MANTLE)*dble(SIZE_INTEGER)
+
+! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle,rmass_crust_mantle
+ static_memory_size = static_memory_size + NGLOB(IREGION_CRUST_MANTLE)*4.d0*dble(CUSTOM_REAL)
+
+! kappavstore_crust_mantle,muvstore_crust_mantle
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPECMAX_ISO_MANTLE*2.d0*dble(CUSTOM_REAL)
+
+! kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPECMAX_TISO_MANTLE*3.d0*dble(CUSTOM_REAL)
+
+! c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle,
+! c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle,
+! c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle,
+! c25store_crust_mantle,c26store_crust_mantle,c33store_crust_mantle,
+! c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle,
+! c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle,
+! c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPECMAX_ANISO_MANTLE*21.d0*dble(CUSTOM_REAL)
+
+! displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle
+ static_memory_size = static_memory_size + dble(NDIM)*NGLOB(IREGION_CRUST_MANTLE)*3.d0*dble(CUSTOM_REAL)
+
+! xstore_outer_core, ystore_outer_core, zstore_outer_core, rmass_outer_core, displ_outer_core, veloc_outer_core, accel_outer_core
+ static_memory_size = static_memory_size + NGLOB(IREGION_OUTER_CORE)*7.d0*dble(CUSTOM_REAL)
+
+! ibool_inner_core
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_INNER_CORE)*dble(SIZE_INTEGER)
+
+! xix_inner_core,xiy_inner_core,xiz_inner_core,
+! etax_inner_core,etay_inner_core,etaz_inner_core,
+! gammax_inner_core,gammay_inner_core,gammaz_inner_core,
+! kappavstore_inner_core,muvstore_inner_core
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_INNER_CORE)*11.d0*dble(CUSTOM_REAL)
+
+! xstore_inner_core,ystore_inner_core,zstore_inner_core,rmass_inner_core
+ static_memory_size = static_memory_size + NGLOB(IREGION_INNER_CORE)*4.d0*dble(CUSTOM_REAL)
+
+! c11store_inner_core,c33store_inner_core,c12store_inner_core,c13store_inner_core,c44store_inner_core
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPECMAX_ANISO_IC*5.d0*dble(CUSTOM_REAL)
+
+! displ_inner_core,veloc_inner_core,accel_inner_core
+ static_memory_size = static_memory_size + dble(NDIM)*NGLOB(IREGION_INNER_CORE)*3.d0*dble(CUSTOM_REAL)
+
+! A_array_rotation,B_array_rotation
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_OUTER_CORE_ROTATION*2.d0*dble(CUSTOM_REAL)
+
+ if(ABSORBING_CONDITIONS) then
+
+! rho_vp_crust_mantle,rho_vs_crust_mantle
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_CRUST_MANTLE)*2.d0*dble(CUSTOM_REAL)
+
+! vp_outer_core
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC(IREGION_OUTER_CORE)*dble(CUSTOM_REAL)
+
+ endif
+
+ if(OCEANS) then
+
+! rmass_ocean_load
+ static_memory_size = static_memory_size + NGLOB(IREGION_CRUST_MANTLE)*dble(CUSTOM_REAL)
+
+ endif
+
+! add arrays used to save strain for attenuation or for adjoint runs
+
+! epsilondev_crust_mantle
+ static_memory_size = static_memory_size + 5.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_STR_OR_ATT*dble(CUSTOM_REAL)
+
+! eps_trace_over_3_crust_mantle
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_STR_OR_ATT*dble(CUSTOM_REAL)
+
+! epsilondev_inner_core
+ static_memory_size = static_memory_size + 5.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_STR_OR_ATT*dble(CUSTOM_REAL)
+
+! eps_trace_over_3_inner_core
+ static_memory_size = static_memory_size + dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_STR_OR_ATT*dble(CUSTOM_REAL)
+
+! add arrays used for adjoint runs only (LQY: not very accurate)
+
+! b_R_memory_crust_mantle
+! b_epsilondev_crust_mantle
+! b_eps_trace_over_3_crust_mantle
+! rho_kl_crust_mantle,beta_kl_crust_mantle, alpha_kl_crust_mantle
+ static_memory_size = static_memory_size + (5.d0*dble(N_SLS) + 9.d0)* &
+ dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_CRUST_MANTLE_ADJOINT*dble(CUSTOM_REAL)
+
+! b_div_displ_outer_core
+! rho_kl_outer_core,alpha_kl_outer_core
+ static_memory_size = static_memory_size + 3.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_OUTER_CORE_ADJOINT*dble(CUSTOM_REAL)
+
+! b_R_memory_inner_core
+! b_epsilondev_inner_core
+! b_eps_trace_over_3_inner_core
+! rho_kl_inner_core,beta_kl_inner_core, alpha_kl_inner_core
+ static_memory_size = static_memory_size + (5.d0*dble(N_SLS) + 9.d0)* &
+ dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_INNER_CORE_ADJOINT*dble(CUSTOM_REAL)
+
+! b_displ_crust_mantle,b_veloc_crust_mantle,b_accel_crust_mantle
+ static_memory_size = static_memory_size + 3.d0*dble(NDIM)*NGLOB_CRUST_MANTLE_ADJOINT*dble(CUSTOM_REAL)
+
+! b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core
+ static_memory_size = static_memory_size + 3.d0*NGLOB_OUTER_CORE_ADJOINT*dble(CUSTOM_REAL)
+
+! b_displ_inner_core,b_veloc_inner_core,b_accel_inner_core
+ static_memory_size = static_memory_size + 3.d0*dble(NDIM)*NGLOB_INNER_CORE_ADJOINT*dble(CUSTOM_REAL)
+
+! b_A_array_rotation,b_B_array_rotation
+ static_memory_size = static_memory_size + 2.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_OUTER_CORE_ROT_ADJOINT*dble(CUSTOM_REAL)
+
+ end subroutine memory_eval
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/meshfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/meshfem3D.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/meshfem3D.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,2148 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+!
+! United States Government Sponsorship Acknowledged.
+
+ program xmeshfem3D
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+!! DK DK for the merged version
+! include values created by the mesher
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+!=====================================================================!
+! !
+! meshfem3D produces a spectral element grid for the Earth. !
+! This is accomplished based upon a mapping of the face of a cube !
+! to a portion of the sphere (Ronchi et al., The Cubed Sphere). !
+! Grid density is decreased by a factor of two !
+! three times in the radial direction. !
+! !
+!=====================================================================!
+!
+! If you use this code for your own research, please cite some of these articles:
+!
+! @ARTICLE{KoRiTr02,
+! author={D. Komatitsch and J. Ritsema and J. Tromp},
+! year=2002,
+! title={The Spectral-Element Method, {B}eowulf Computing, and Global Seismology},
+! journal={Science},
+! volume=298,
+! number=5599,
+! pages={1737-1742},
+! doi={10.1126/science.1076024}}
+!
+! @ARTICLE{KoTr02a,
+! author={D. Komatitsch and J. Tromp},
+! year=2002,
+! title={Spectral-Element Simulations of Global Seismic Wave Propagation{-I. V}alidation},
+! journal={Geophys. J. Int.},
+! volume=149,
+! number=2,
+! pages={390-412},
+! doi={10.1046/j.1365-246X.2002.01653.x}}
+!
+! @ARTICLE{KoTr02b,
+! author={D. Komatitsch and J. Tromp},
+! year=2002,
+! title={Spectral-Element Simulations of Global Seismic Wave Propagation{-II. 3-D} Models, Oceans, Rotation, and Self-Gravitation},
+! journal={Geophys. J. Int.},
+! volume=150,
+! pages={303-318},
+! number=1,
+! doi={10.1046/j.1365-246X.2002.01716.x}}
+!
+! @ARTICLE{KoTr99,
+! author={D. Komatitsch and J. Tromp},
+! year=1999,
+! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
+! journal={Geophys. J. Int.},
+! volume=139,
+! number=3,
+! pages={806-822},
+! doi={10.1046/j.1365-246x.1999.00967.x}}
+!
+! @ARTICLE{KoVi98,
+! author={D. Komatitsch and J. P. Vilotte},
+! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
+! journal={Bull. Seismol. Soc. Am.},
+! year=1998,
+! volume=88,
+! number=2,
+! pages={368-392}}
+!
+! If you use the kernel capabilities of the code, please cite
+!
+! @ARTICLE{LiTr06,
+! author={Qinya Liu and Jeroen Tromp},
+! title={Finite-frequency kernels based on adjoint methods},
+! journal={Bull. Seismol. Soc. Am.},
+! year=2006,
+! volume=96,
+! number=6,
+! pages={2383-2397},
+! doi={10.1785/0120060041}}
+!
+! If you use 3-D model S20RTS, please cite
+!
+! @ARTICLE{RiVa00,
+! author={J. Ritsema and H. J. {Van Heijst}},
+! year=2000,
+! title={Seismic imaging of structural heterogeneity in {E}arth's mantle: Evidence for large-scale mantle flow},
+! journal={Science Progress},
+! volume=83,
+! pages={243-259}}
+!
+! Reference frame - convention:
+! ----------------------------
+!
+! The code uses the following convention for the reference frame:
+!
+! - X axis is East
+! - Y axis is North
+! - Z axis is up
+!
+! Note that this convention is different from both the Aki-Richards convention
+! and the Harvard CMT convention.
+!
+! Let us recall that the Aki-Richards convention is:
+!
+! - X axis is North
+! - Y axis is East
+! - Z axis is down
+!
+! and that the Harvard CMT convention is:
+!
+! - X axis is South
+! - Y axis is East
+! - Z axis is up
+!
+! To report bugs or suggest improvements to the code, please send an email
+! to Jeroen Tromp <jtromp AT caltech.edu> and/or use our online
+! bug tracking system at http://www.geodynamics.org/roundup .
+!
+! Evolution of the code:
+! ---------------------
+!
+! v. 4.0 David Michea and Dimitri Komatitsch, University of Pau, France, February 2008:
+! new doubling brick in the mesh, new perfectly load-balanced mesh,
+! more flexible routines for mesh design, new inflated central cube
+! with optimized shape, far fewer mesh files saved by the mesher,
+! global arrays sorted to speed up the simulation, seismos can be
+! written by the master
+! v. 3.6 Many people, many affiliations, September 2006:
+! adjoint and kernel calculations, fixed IASP91 model,
+! added AK135 and 1066a, fixed topography/bathymetry routine,
+! new attenuation routines, faster and better I/Os on very large
+! systems, many small improvements and bug fixes, new "configure"
+! script, new Pyre version, new user's manual etc.
+! v. 3.5 Dimitri Komatitsch, Brian Savage and Jeroen Tromp, Caltech, July 2004:
+! any size of chunk, 3D attenuation, case of two chunks,
+! more precise topography/bathymetry model, new Par_file structure
+! v. 3.4 Dimitri Komatitsch and Jeroen Tromp, Caltech, August 2003:
+! merged global and regional codes, no iterations in fluid, better movies
+! v. 3.3 Dimitri Komatitsch, Caltech, September 2002:
+! flexible mesh doubling in outer core, inlined code, OpenDX support
+! v. 3.2 Jeroen Tromp, Caltech, July 2002:
+! multiple sources and flexible PREM reading
+! v. 3.1 Dimitri Komatitsch, Caltech, June 2002:
+! vectorized loops in solver and merged central cube
+! v. 3.0 Dimitri Komatitsch and Jeroen Tromp, Caltech, May 2002:
+! ported to SGI and Compaq, double precision solver, more general anisotropy
+! v. 2.3 Dimitri Komatitsch and Jeroen Tromp, Caltech, August 2001:
+! gravity, rotation, oceans and 3-D models
+! v. 2.2 Dimitri Komatitsch and Jeroen Tromp, Caltech, March 2001:
+! final MPI package
+! v. 2.0 Dimitri Komatitsch, Harvard, January 2000: MPI code for the globe
+! v. 1.0 Dimitri Komatitsch, Mexico, June 1999: first MPI code for a chunk
+! Jeroen Tromp, Harvard, July 1998: first chunk solver using OpenMP on Sun
+! Dimitri Komatitsch, IPG Paris, December 1996: first 3-D solver for the CM5
+!
+
+! aniso_mantle_model_variables
+ type aniso_mantle_model_variables
+ sequence
+ double precision beta(14,34,37,73)
+ double precision pro(47)
+ integer npar1
+ end type aniso_mantle_model_variables
+
+ type (aniso_mantle_model_variables) AMM_V
+! aniso_mantle_model_variables
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: Qs ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+! model_1066a_variables
+ type model_1066a_variables
+ sequence
+ double precision, dimension(NR_1066A) :: radius_1066a
+ double precision, dimension(NR_1066A) :: density_1066a
+ double precision, dimension(NR_1066A) :: vp_1066a
+ double precision, dimension(NR_1066A) :: vs_1066a
+ double precision, dimension(NR_1066A) :: Qkappa_1066a
+ double precision, dimension(NR_1066A) :: Qmu_1066a
+ end type model_1066a_variables
+
+ type (model_1066a_variables) M1066a_V
+! model_1066a_variables
+
+! model_ak135_variables
+ type model_ak135_variables
+ sequence
+ double precision, dimension(NR_AK135) :: radius_ak135
+ double precision, dimension(NR_AK135) :: density_ak135
+ double precision, dimension(NR_AK135) :: vp_ak135
+ double precision, dimension(NR_AK135) :: vs_ak135
+ double precision, dimension(NR_AK135) :: Qkappa_ak135
+ double precision, dimension(NR_AK135) :: Qmu_ak135
+ end type model_ak135_variables
+
+ type (model_ak135_variables) Mak135_V
+! model_ak135_variables
+
+! three_d_mantle_model_variables
+ type three_d_mantle_model_variables
+ sequence
+ double precision dvs_a(0:NK,0:NS,0:NS)
+ double precision dvs_b(0:NK,0:NS,0:NS)
+ double precision dvp_a(0:NK,0:NS,0:NS)
+ double precision dvp_b(0:NK,0:NS,0:NS)
+ double precision spknt(NK+1)
+ double precision qq0(NK+1,NK+1)
+ double precision qq(3,NK+1,NK+1)
+ end type three_d_mantle_model_variables
+
+! model_ref_variables
+ type model_ref_variables
+ sequence
+ double precision, dimension(NR_REF) :: radius_ref
+ double precision, dimension(NR_REF) :: density_ref
+ double precision, dimension(NR_REF) :: vpv_ref
+ double precision, dimension(NR_REF) :: vph_ref
+ double precision, dimension(NR_REF) :: vsv_ref
+ double precision, dimension(NR_REF) :: vsh_ref
+ double precision, dimension(NR_REF) :: eta_ref
+ double precision, dimension(NR_REF) :: Qkappa_ref
+ double precision, dimension(NR_REF) :: Qmu_ref
+ end type model_ref_variables
+
+ type (model_ref_variables) Mref_V
+! model_ref_variables
+
+ type (three_d_mantle_model_variables) D3MM_V
+! three_d_mantle_model_variables
+
+! sea1d_model_variables
+ type sea1d_model_variables
+ sequence
+ double precision, dimension(NR_SEA1D) :: radius_sea1d
+ double precision, dimension(NR_SEA1D) :: density_sea1d
+ double precision, dimension(NR_SEA1D) :: vp_sea1d
+ double precision, dimension(NR_SEA1D) :: vs_sea1d
+ double precision, dimension(NR_SEA1D) :: Qkappa_sea1d
+ double precision, dimension(NR_SEA1D) :: Qmu_sea1d
+ end type sea1d_model_variables
+
+ type (sea1d_model_variables) SEA1DM_V
+! sea1d_model_variables
+
+! jp3d_model_variables
+ type jp3d_model_variables
+ sequence
+! vmod3d
+ integer :: NPA
+ integer :: NRA
+ integer :: NHA
+ integer :: NPB
+ integer :: NRB
+ integer :: NHB
+ double precision :: PNA(MPA)
+ double precision :: RNA(MRA)
+ double precision :: HNA(MHA)
+ double precision :: PNB(MPB)
+ double precision :: RNB(MRB)
+ double precision :: HNB(MHB)
+ double precision :: VELAP(MPA,MRA,MHA)
+ double precision :: VELBP(MPB,MRB,MHB)
+! discon
+ double precision :: PN(51)
+ double precision :: RRN(63)
+ double precision :: DEPA(51,63)
+ double precision :: DEPB(51,63)
+ double precision :: DEPC(51,63)
+! locate
+ integer :: IPLOCA(MKA)
+ integer :: IRLOCA(MKA)
+ integer :: IHLOCA(MKA)
+ integer :: IPLOCB(MKB)
+ integer :: IRLOCB(MKB)
+ integer :: IHLOCB(MKB)
+ double precision :: PLA
+ double precision :: RLA
+ double precision :: HLA
+ double precision :: PLB
+ double precision :: RLB
+ double precision :: HLB
+! weight
+ integer :: IP
+ integer :: JP
+ integer :: KP
+ integer :: IP1
+ integer :: JP1
+ integer :: KP1
+ double precision :: WV(8)
+! prhfd
+ double precision :: P
+ double precision :: R
+ double precision :: H
+ double precision :: PF
+ double precision :: RF
+ double precision :: HF
+ double precision :: PF1
+ double precision :: RF1
+ double precision :: HF1
+ double precision :: PD
+ double precision :: RD
+ double precision :: HD
+! jpmodv
+ double precision :: VP(29)
+ double precision :: VS(29)
+ double precision :: RA(29)
+ double precision :: DEPJ(29)
+ end type jp3d_model_variables
+
+ type (jp3d_model_variables) JP3DM_V
+! jp3d_model_variables
+
+! sea99_s_model_variables
+ type sea99_s_model_variables
+ sequence
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ end type sea99_s_model_variables
+
+ type (sea99_s_model_variables) SEA99M_V
+! sea99_s_model_variables
+
+! crustal_model_variables
+ type crustal_model_variables
+ sequence
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
+ double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
+ character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+ character(len=2) code(NKEYS_CRUST)
+ end type crustal_model_variables
+
+ type (crustal_model_variables) CM_V
+! crustal_model_variables
+
+! attenuation_model_storage
+ type attenuation_model_storage
+ sequence
+ integer Q_resolution
+ integer Q_max
+ double precision, dimension(:,:), pointer :: tau_e_storage
+ double precision, dimension(:), pointer :: Qmu_storage
+ end type attenuation_model_storage
+
+ type (attenuation_model_storage) AM_S
+! attenuation_model_storage
+
+! attenuation_simplex_variables
+ type attenuation_simplex_variables
+ sequence
+ integer nf ! nf = Number of Frequencies
+ integer nsls ! nsls = Number of Standard Linear Solids
+ double precision Q ! Q = Desired Value of Attenuation or Q
+ double precision iQ ! iQ = 1/Q
+ double precision, dimension(:), pointer :: f
+ ! f = Frequencies at which to evaluate the solution
+ double precision, dimension(:), pointer :: tau_s
+ ! tau_s = Tau_sigma defined by the frequency range and
+ ! number of standard linear solids
+ end type attenuation_simplex_variables
+
+ type(attenuation_simplex_variables) AS_V
+! attenuation_simplex_variables
+
+! correct number of spectral elements in each block depending on chunk type
+
+ integer nspec_aniso,npointot
+
+! parameters needed to store the radii of the grid points
+! in the spherically symmetric Earth
+!! DK DK suppressed this for merged version
+! integer, dimension(:), allocatable :: idoubling
+! integer, dimension(:,:,:,:), allocatable :: ibool
+
+! arrays with the mesh in double precision
+ double precision, dimension(:,:,:,:), allocatable :: xstore,ystore,zstore
+
+! proc numbers for MPI
+ integer myrank,sizeprocs,ier,errorcode
+
+! check area and volume of the final mesh
+ double precision area_local_bottom,area_total_bottom
+ double precision area_local_top,area_total_top
+ double precision volume_local,volume_total,volume_total_region
+
+ integer iprocnum
+
+! for loop on all the slices
+ integer iregion_code,iregion
+ integer iproc_xi,iproc_eta,ichunk
+
+!! DK DK for the merged version
+ integer, dimension(:), allocatable :: ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta
+ double precision, dimension(:), allocatable :: xread1D_leftxi_lefteta,xread1D_rightxi_lefteta, &
+ xread1D_leftxi_righteta,xread1D_rightxi_righteta
+ double precision, dimension(:), allocatable :: yread1D_leftxi_lefteta,yread1D_rightxi_lefteta, &
+ yread1D_leftxi_righteta,yread1D_rightxi_righteta
+ double precision, dimension(:), allocatable :: zread1D_leftxi_lefteta,zread1D_rightxi_lefteta, &
+ zread1D_leftxi_righteta,zread1D_rightxi_righteta
+
+! rotation matrix from Euler angles
+ double precision, dimension(NDIM,NDIM) :: rotation_matrix
+
+ double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+! for some statistics for the mesh
+ integer numelem_crust_mantle,numelem_outer_core,numelem_inner_core
+ integer numelem_total
+
+! timer MPI
+ double precision time_start,tCPU
+
+! addressing for all the slices
+ integer, dimension(:), allocatable :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
+ integer, dimension(:,:,:), allocatable :: addressing
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH
+
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_VOLUME_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
+
+ character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL
+
+! parameters deduced from parameters read from file
+ integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+
+ integer, external :: err_occurred
+
+! this for all the regions
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ nglob
+
+! DK DK UGLY if running on MareNostrum in Barcelona
+ integer :: sender, receiver, dummy1, dummy2
+ integer msg_status(MPI_STATUS_SIZE)
+ character(len=400) system_command
+
+! computed in read_compute_parameters
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+! memory size of all the static arrays
+! double precision :: static_memory_size
+
+! arrays for BCAST
+ integer, dimension(38) :: bcast_integer
+ double precision, dimension(30) :: bcast_double_precision
+ logical, dimension(26) :: bcast_logical
+
+ integer, parameter :: maxker=200
+ integer, parameter :: maxl=72
+ integer, parameter :: maxcoe=2000
+ integer, parameter :: maxver=1000
+ integer, parameter :: maxhpa=2
+
+ integer numker
+ integer numhpa,numcof
+ integer ihpa,lmax,nylm
+ integer lmxhpa(maxhpa)
+ integer itypehpa(maxhpa)
+ integer ihpakern(maxker)
+ integer numcoe(maxhpa)
+ integer ivarkern(maxker)
+ integer itpspl(maxcoe,maxhpa)
+
+ integer nconpt(maxhpa),iver
+ integer iconpt(maxver,maxhpa)
+ real(kind=4) conpt(maxver,maxhpa)
+
+ real(kind=4) xlaspl(maxcoe,maxhpa)
+ real(kind=4) xlospl(maxcoe,maxhpa)
+ real(kind=4) radspl(maxcoe,maxhpa)
+ real(kind=4) coe(maxcoe,maxker)
+ character(len=80) hsplfl(maxhpa)
+ character(len=40) dskker(maxker)
+ real(kind=4) vercof(maxker)
+ real(kind=4) vercofd(maxker)
+
+ real(kind=4) ylmcof((maxl+1)**2,maxhpa)
+ real(kind=4) wk1(maxl+1)
+ real(kind=4) wk2(maxl+1)
+ real(kind=4) wk3(maxl+1)
+
+ character(len=80) kerstr
+ character(len=80) refmdl
+ character(len=40) varstr(maxker)
+
+ integer :: ipass
+
+!! DK DK suppressed this for the merged version
+! integer :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+! NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+! NSPEC_INNER_CORE_ATTENUATION, &
+! NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+! NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+! NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+! NSPEC_CRUST_MANTLE_ADJOINT, &
+! NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+! NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+! NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+! NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+! NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION
+
+! this for the different corners of the slice (which are different if the superbrick is cut)
+! 1 : xi_min, eta_min
+! 2 : xi_max, eta_min
+! 3 : xi_max, eta_max
+! 4 : xi_min, eta_max
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
+
+! 1 -> min, 2 -> max
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE
+
+ integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+! integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL_TEMP
+
+!! DK DK for the merged version
+ include 'declar.f90'
+
+!! DK DK added this for the merged version
+!---- arrays to assemble between chunks
+
+ integer :: imsg
+
+! communication pattern for faces between chunks
+ integer, dimension(NUMMSGS_FACES_VAL) :: iprocfrom_faces,iprocto_faces,imsg_type
+
+! communication pattern for corners between chunks
+ integer, dimension(NCORNERSCHUNKS_VAL) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
+
+ logical :: not_done_yet
+
+! ************** PROGRAM STARTS HERE **************
+
+! initialize the MPI communicator and start the NPROCTOT MPI processes.
+ call MPI_INIT(ier)
+
+! sizeprocs returns number of processes started (should be equal to NPROCTOT).
+! myrank is the rank of each process, between 0 and NPROCTOT-1.
+! as usual in MPI, process 0 is in charge of coordinating everything
+! and also takes care of the main output
+! do not create anything for the inner core here, will be done in solver
+ call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
+ call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! open main output file, only written to by process 0
+ if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) &
+ open(unit=IMAIN,file=trim(OUTPUT_FILES)//'/output_mesher.txt',status='unknown')
+
+! get MPI starting time
+ time_start = MPI_WTIME()
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '****************************'
+ write(IMAIN,*) '*** Specfem3D MPI Mesher ***'
+ write(IMAIN,*) '****************************'
+ write(IMAIN,*)
+ endif
+
+ if (myrank==0) then
+! read the parameter file and compute additional parameters
+ call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_VOLUME_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.)
+
+ if(err_occurred() /= 0) then
+ call exit_MPI(myrank,'an error occurred while reading the parameter file')
+ endif
+
+! count the total number of sources in the CMTSOLUTION file
+ call count_number_of_sources(NSOURCES)
+
+ bcast_integer = (/MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,&
+ SIMULATION_TYPE,REFERENCE_1D_MODEL,THREE_D_MODEL,NPROC,NPROCTOT, &
+ NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube,&
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP/)
+
+ bcast_logical = (/TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD,CASE_3D,&
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,SAVE_ALL_SEISMOS_IN_ONE_FILE/)
+
+ bcast_double_precision = (/DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH/)
+
+ endif
+
+! broadcast the information read on the master to the nodes
+ call MPI_BCAST(NSOURCES,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(bcast_integer,38,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(bcast_double_precision,30,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(bcast_logical,25,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(LOCAL_PATH,150,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(MODEL,150,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(ner,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ratio_sampling_array,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(doubling_index,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(r_bottom,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(r_top,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(rmins,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(rmaxs,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(rmaxs,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(this_region_has_a_doubling,MAX_NUMBER_OF_MESH_LAYERS,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(NSPEC,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_XI,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_ETA,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2DMAX_XMIN_XMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2DMAX_YMIN_YMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_BOTTOM,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_TOP,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC1D_RADIAL,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB1D_RADIAL,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB2DMAX_XMIN_XMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB2DMAX_YMIN_YMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(DIFF_NSPEC1D_RADIAL,NB_SQUARE_CORNERS*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(DIFF_NSPEC2D_ETA,NB_SQUARE_EDGES_ONEDIR*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(DIFF_NSPEC2D_XI,NB_SQUARE_EDGES_ONEDIR*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ if (myrank /=0) then
+
+ MIN_ATTENUATION_PERIOD = bcast_integer(1)
+ MAX_ATTENUATION_PERIOD = bcast_integer(2)
+ NER_CRUST = bcast_integer(3)
+ NER_80_MOHO = bcast_integer(4)
+ NER_220_80 = bcast_integer(5)
+ NER_400_220 = bcast_integer(6)
+ NER_600_400 = bcast_integer(7)
+ NER_670_600 = bcast_integer(8)
+ NER_771_670 = bcast_integer(9)
+ NER_TOPDDOUBLEPRIME_771 = bcast_integer(10)
+ NER_CMB_TOPDDOUBLEPRIME = bcast_integer(11)
+ NER_OUTER_CORE = bcast_integer(12)
+ NER_TOP_CENTRAL_CUBE_ICB = bcast_integer(13)
+ NEX_XI = bcast_integer(14)
+ NEX_ETA = bcast_integer(15)
+ RMOHO_FICTITIOUS_IN_MESHER = bcast_integer(16)
+ NPROC_XI = bcast_integer(17)
+ NPROC_ETA = bcast_integer(18)
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS = bcast_integer(19)
+ NTSTEP_BETWEEN_READ_ADJSRC = bcast_integer(20)
+ NSTEP = bcast_integer(21)
+ NSOURCES = bcast_integer(22)
+ NTSTEP_BETWEEN_FRAMES = bcast_integer(23)
+ NTSTEP_BETWEEN_OUTPUT_INFO = bcast_integer(24)
+ NUMBER_OF_RUNS = bcast_integer(25)
+ NUMBER_OF_THIS_RUN = bcast_integer(26)
+ NCHUNKS = bcast_integer(27)
+ SIMULATION_TYPE = bcast_integer(28)
+ REFERENCE_1D_MODEL = bcast_integer(29)
+ THREE_D_MODEL = bcast_integer(30)
+ NPROC = bcast_integer(31)
+ NPROCTOT = bcast_integer(32)
+ NEX_PER_PROC_XI = bcast_integer(33)
+ NEX_PER_PROC_ETA = bcast_integer(34)
+ ratio_divide_central_cube = bcast_integer(35)
+ MOVIE_VOLUME_TYPE = bcast_integer(36)
+ MOVIE_START = bcast_integer(37)
+ MOVIE_STOP = bcast_integer(38)
+
+ TRANSVERSE_ISOTROPY = bcast_logical(1)
+ ANISOTROPIC_3D_MANTLE = bcast_logical(2)
+ ANISOTROPIC_INNER_CORE = bcast_logical(3)
+ CRUSTAL = bcast_logical(4)
+ ELLIPTICITY = bcast_logical(5)
+ GRAVITY = bcast_logical(6)
+ ONE_CRUST = bcast_logical(7)
+ ROTATION = bcast_logical(8)
+ ISOTROPIC_3D_MANTLE = bcast_logical(9)
+ TOPOGRAPHY = bcast_logical(10)
+ OCEANS = bcast_logical(11)
+ MOVIE_SURFACE = bcast_logical(12)
+ MOVIE_VOLUME = bcast_logical(13)
+ ATTENUATION_3D = bcast_logical(14)
+ RECEIVERS_CAN_BE_BURIED = bcast_logical(15)
+ PRINT_SOURCE_TIME_FUNCTION = bcast_logical(16)
+ SAVE_MESH_FILES = bcast_logical(17)
+ ATTENUATION = bcast_logical(18)
+ ABSORBING_CONDITIONS = bcast_logical(19)
+ INCLUDE_CENTRAL_CUBE = bcast_logical(20)
+ INFLATE_CENTRAL_CUBE = bcast_logical(21)
+ SAVE_FORWARD = bcast_logical(22)
+ CASE_3D = bcast_logical(23)
+ CUT_SUPERBRICK_XI = bcast_logical(24)
+ CUT_SUPERBRICK_ETA = bcast_logical(25)
+ SAVE_ALL_SEISMOS_IN_ONE_FILE = bcast_logical(26)
+
+ DT = bcast_double_precision(1)
+ ANGULAR_WIDTH_XI_IN_DEGREES = bcast_double_precision(2)
+ ANGULAR_WIDTH_ETA_IN_DEGREES = bcast_double_precision(3)
+ CENTER_LONGITUDE_IN_DEGREES = bcast_double_precision(4)
+ CENTER_LATITUDE_IN_DEGREES = bcast_double_precision(5)
+ GAMMA_ROTATION_AZIMUTH = bcast_double_precision(6)
+ ROCEAN = bcast_double_precision(7)
+ RMIDDLE_CRUST = bcast_double_precision(8)
+ RMOHO = bcast_double_precision(9)
+ R80 = bcast_double_precision(10)
+ R120 = bcast_double_precision(11)
+ R220 = bcast_double_precision(12)
+ R400 = bcast_double_precision(13)
+ R600 = bcast_double_precision(14)
+ R670 = bcast_double_precision(15)
+ R771 = bcast_double_precision(16)
+ RTOPDDOUBLEPRIME = bcast_double_precision(17)
+ RCMB = bcast_double_precision(18)
+ RICB = bcast_double_precision(19)
+ R_CENTRAL_CUBE = bcast_double_precision(20)
+ RHO_TOP_OC = bcast_double_precision(21)
+ RHO_BOTTOM_OC = bcast_double_precision(22)
+ RHO_OCEANS = bcast_double_precision(23)
+ HDUR_MOVIE = bcast_double_precision(24)
+ MOVIE_TOP = bcast_double_precision(25)
+ MOVIE_BOTTOM = bcast_double_precision(26)
+ MOVIE_WEST = bcast_double_precision(27)
+ MOVIE_EAST = bcast_double_precision(28)
+ MOVIE_NORTH = bcast_double_precision(29)
+ MOVIE_SOUTH = bcast_double_precision(30)
+
+ endif
+
+! DK DK UGLY if running on MareNostrum in Barcelona
+ if(RUN_ON_MARENOSTRUM_BARCELONA) then
+
+! check that we combine the seismograms in one large file to avoid GPFS overloading
+ if(.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) call exit_MPI(myrank,'should use SAVE_ALL_SEISMOS_IN_ONE_FILE for GPFS in Barcelona')
+
+! clean the local scratch space using a cascade (serial removal, one process after the other)
+ if(myrank == 0) then
+
+ receiver = myrank + 1
+ call system('rm -f -r /scratch/komatits_new* > /dev/null')
+ call MPI_SEND(dummy1,1,MPI_INTEGER,receiver,itag,MPI_COMM_WORLD,ier)
+
+ else
+
+ sender = myrank - 1
+ receiver = myrank + 1
+ call MPI_RECV(dummy2,1,MPI_INTEGER,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+ call system('rm -f -r /scratch/komatits_new* > /dev/null')
+ if(myrank < sizeprocs - 1) call MPI_SEND(dummy1,1,MPI_INTEGER,receiver,itag,MPI_COMM_WORLD,ier)
+
+ endif
+
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+! use the local scratch disk to save all the files, ignore the path that is given in the Par_file
+ LOCAL_PATH = '/scratch/komatits_new'
+
+! add processor name to local /scratch/komatits_new path
+ write(system_command,"('_proc',i4.4)") myrank
+ LOCAL_PATH = trim(LOCAL_PATH) // trim(system_command)
+
+! create a local directory to store all the local files
+ write(system_command,"('mkdir /scratch/komatits_new_proc',i4.4)") myrank
+ call system(system_command)
+
+ endif
+
+! check that the code is running with the requested number of processes
+ if(sizeprocs /= NPROCTOT) call exit_MPI(myrank,'wrong number of MPI processes')
+
+! dynamic allocation of mesh arrays
+ allocate(addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(ichunk_slice(0:NPROCTOT-1),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(iproc_xi_slice(0:NPROCTOT-1),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(iproc_eta_slice(0:NPROCTOT-1),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ addressing(:,:,:) = 0
+ ichunk_slice(:) = 0
+ iproc_xi_slice(:) = 0
+ iproc_eta_slice(:) = 0
+
+! loop on all the chunks to create global slice addressing for solver
+ if(myrank == 0) then
+!! DK DK suppressed this for merged
+!! DK DK suppressed this for merged open(unit=IOUT,file=trim(OUTPUT_FILES)//'/addressing.txt',status='unknown')
+ write(IMAIN,*) 'creating global slice addressing'
+ write(IMAIN,*)
+ endif
+ do ichunk = 1,NCHUNKS
+ do iproc_eta=0,NPROC_ETA-1
+ do iproc_xi=0,NPROC_XI-1
+ iprocnum = (ichunk-1)*NPROC + iproc_eta * NPROC_XI + iproc_xi
+ addressing(ichunk,iproc_xi,iproc_eta) = iprocnum
+ ichunk_slice(iprocnum) = ichunk
+ iproc_xi_slice(iprocnum) = iproc_xi
+ iproc_eta_slice(iprocnum) = iproc_eta
+!! DK DK suppressed this for merged
+!! DK DK suppressed this for merged if(myrank == 0) write(IOUT,*) iprocnum,ichunk,iproc_xi,iproc_eta
+ enddo
+ enddo
+ enddo
+!! DK DK suppressed this for merged
+!! DK DK suppressed this for merged if(myrank == 0) close(IOUT)
+
+!! DK DK added this for the merged version
+ not_done_yet = .true.
+
+! this for the different counters (which are now different if the superbrick is cut in the outer core)
+ do iregion=1,MAX_NUM_REGIONS
+ NSPEC1D_RADIAL_CORNER(iregion,:) = NSPEC1D_RADIAL(iregion)
+ NSPEC2D_XI_FACE(iregion,:) = NSPEC2D_XI(iregion)
+ NSPEC2D_ETA_FACE(iregion,:) = NSPEC2D_ETA(iregion)
+ NGLOB1D_RADIAL_CORNER(iregion,:) = NGLOB1D_RADIAL(iregion)
+ enddo
+
+ if (CUT_SUPERBRICK_XI) then
+ if (CUT_SUPERBRICK_ETA) then
+ if (mod(iproc_xi_slice(myrank),2) == 0) then
+ if (mod(iproc_eta_slice(myrank),2) == 0) then
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ else
+ if (mod(iproc_eta_slice(myrank),2) == 0) then
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,3)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,3)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,3)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,3)*(NGLLZ-1))
+ else
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,4)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,4)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,4)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,4)*(NGLLZ-1))
+ endif
+ endif
+ else
+ if (mod(iproc_xi_slice(myrank),2) == 0) then
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ endif
+ else
+ if (CUT_SUPERBRICK_ETA) then
+ if (mod(iproc_eta_slice(myrank),2) == 0) then
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ endif
+ endif
+
+ if(myrank == 0) then
+ write(IMAIN,*) 'This is process ',myrank
+ write(IMAIN,*) 'There are ',sizeprocs,' MPI processes'
+ write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',NEX_XI,' elements along xi in each chunk'
+ write(IMAIN,*) 'There are ',NEX_ETA,' elements along eta in each chunk'
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',NPROC_XI,' slices along xi in each chunk'
+ write(IMAIN,*) 'There are ',NPROC_ETA,' slices along eta in each chunk'
+ write(IMAIN,*) 'There is a total of ',NPROC,' slices in each chunk'
+ write(IMAIN,*) 'There are ',NCHUNKS,' chunks in the global mesh'
+ write(IMAIN,*) 'There is a total of ',NPROCTOT,' slices in the global mesh'
+ write(IMAIN,*)
+ write(IMAIN,*) 'NGLLX = ',NGLLX
+ write(IMAIN,*) 'NGLLY = ',NGLLY
+ write(IMAIN,*) 'NGLLZ = ',NGLLZ
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'Shape functions defined by NGNOD = ',NGNOD,' control nodes'
+ write(IMAIN,*) 'Surface shape functions defined by NGNOD2D = ',NGNOD2D,' control nodes'
+ write(IMAIN,*)
+ write(IMAIN,*)
+ endif
+
+ if(myrank == 0) then
+
+ write(IMAIN,*)
+ if(ELLIPTICITY) then
+ write(IMAIN,*) 'incorporating ellipticity'
+ else
+ write(IMAIN,*) 'no ellipticity'
+ endif
+
+ write(IMAIN,*)
+ if(TOPOGRAPHY) then
+ write(IMAIN,*) 'incorporating surface topography'
+ else
+ write(IMAIN,*) 'no surface topography'
+ endif
+
+ write(IMAIN,*)
+ if(ISOTROPIC_3D_MANTLE) then
+ write(IMAIN,*) 'incorporating 3-D lateral variations'
+ else
+ write(IMAIN,*) 'no 3-D lateral variations'
+ endif
+
+ write(IMAIN,*)
+ if(CRUSTAL) then
+ write(IMAIN,*) 'incorporating crustal variations'
+ else
+ write(IMAIN,*) 'no crustal variations'
+ endif
+
+ write(IMAIN,*)
+ if(ONE_CRUST) then
+ write(IMAIN,*) 'using one layer only in PREM crust'
+ else
+ write(IMAIN,*) 'using unmodified 1D crustal model with two layers'
+ endif
+
+ write(IMAIN,*)
+ if(GRAVITY) then
+ write(IMAIN,*) 'incorporating self-gravitation (Cowling approximation)'
+ else
+ write(IMAIN,*) 'no self-gravitation'
+ endif
+
+ write(IMAIN,*)
+ if(ROTATION) then
+ write(IMAIN,*) 'incorporating rotation'
+ else
+ write(IMAIN,*) 'no rotation'
+ endif
+
+ write(IMAIN,*)
+ if(TRANSVERSE_ISOTROPY) then
+ write(IMAIN,*) 'incorporating anisotropy'
+ else
+ write(IMAIN,*) 'no anisotropy'
+ endif
+
+ write(IMAIN,*)
+ if(ATTENUATION) then
+ write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids'
+ if(ATTENUATION_3D) write(IMAIN,*)'using 3D attenuation'
+ else
+ write(IMAIN,*) 'no attenuation'
+ endif
+
+ write(IMAIN,*)
+ if(OCEANS) then
+ write(IMAIN,*) 'incorporating the oceans using equivalent load'
+ else
+ write(IMAIN,*) 'no oceans'
+ endif
+
+ write(IMAIN,*)
+
+ endif
+ if(ELLIPTICITY) call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
+
+ if(ISOTROPIC_3D_MANTLE) then
+ if(THREE_D_MODEL /= 0) call read_smooth_moho
+ if(THREE_D_MODEL == THREE_D_MODEL_S20RTS) then
+! the variables read are declared and stored in structure D3MM_V
+ if(myrank == 0) call read_mantle_model(D3MM_V)
+! broadcast the information read on the master to the nodes
+ call MPI_BCAST(D3MM_V%dvs_a,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%dvs_b,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%dvp_a,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%dvp_b,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%spknt,NK+1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%qq0,(NK+1)*(NK+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(D3MM_V%qq,3*(NK+1)*(NK+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99_JP3D) then
+! the variables read are declared and stored in structure SEA99M_V and JP3DM_V
+ if(myrank == 0) then
+ call read_sea99_s_model(SEA99M_V)
+ call read_iso3d_dpzhao_model(JP3DM_V)
+ endif
+! broadcast the information read on the master to the nodes
+! SEA99M_V
+ call MPI_BCAST(SEA99M_V%sea99_ndep,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_nlat,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_nlon,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_ddeg,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alatmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alatmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alonmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alonmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_vs,100*100*100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_depth,100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+! JP3DM_V
+ call MPI_BCAST(JP3DM_V%NPA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NRA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NHA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NPB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NRB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NHB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PNA,MPA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RNA,MRA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HNA,MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PNB,MPB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RNB,MRB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HNB,MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VELAP,MPA*MRA*MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VELBP,MPB*MRB*MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PN,51,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RRN,63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPA,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPB,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPC,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IPLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IRLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IHLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IPLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IRLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IHLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%JP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%KP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%JP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%KP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%WV,8,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%P,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%R,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%H,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VP,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VS,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RA,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPJ,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ elseif(THREE_D_MODEL == THREE_D_MODEL_SEA99) then
+! the variables read are declared and stored in structure SEA99M_V
+ if(myrank == 0) call read_sea99_s_model(SEA99M_V)
+! broadcast the information read on the master to the nodes
+! SEA99M_V
+ call MPI_BCAST(SEA99M_V%sea99_ndep,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_nlat,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_nlon,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_ddeg,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alatmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alatmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alonmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%alonmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_vs,100*100*100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(SEA99M_V%sea99_depth,100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ elseif(THREE_D_MODEL == THREE_D_MODEL_JP3D) then
+! the variables read are declared and stored in structure JP3DM_V
+ if(myrank == 0) call read_iso3d_dpzhao_model(JP3DM_V)
+! JP3DM_V
+ call MPI_BCAST(JP3DM_V%NPA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NRA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NHA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NPB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NRB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%NHB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PNA,MPA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RNA,MRA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HNA,MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PNB,MPB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RNB,MRB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HNB,MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VELAP,MPA*MRA*MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VELBP,MPB*MRB*MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PN,51,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RRN,63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPA,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPB,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPC,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IPLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IRLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IHLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IPLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IRLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IHLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%JP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%KP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%IP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%JP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%KP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%WV,8,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%P,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%R,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%H,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%PD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%HD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VP,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%VS,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%RA,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_V%DEPJ,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ elseif(THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI &
+ .or. THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM .or. THREE_D_MODEL == THREE_D_MODEL_S29EA) then
+ if(myrank == 0) call read_model_s362ani(THREE_D_MODEL,THREE_D_MODEL_S362ANI,THREE_D_MODEL_S362WMANI, &
+ THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA, &
+ numker,numhpa,ihpa,lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,itpspl, &
+ xlaspl,xlospl,radspl,coe,hsplfl,dskker,kerstr,varstr,refmdl)
+ call MPI_BCAST(numker,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(numhpa,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ihpa,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(lmxhpa,maxhpa,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(itypehpa,maxhpa,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ihpakern,maxker,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(numcoe,maxhpa,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ivarkern,maxker,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(itpspl,maxcoe*maxhpa,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(xlaspl,maxcoe*maxhpa,MPI_REAL,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(xlospl,maxcoe*maxhpa,MPI_REAL,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(radspl,maxcoe*maxhpa,MPI_REAL,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(coe,maxcoe*maxker,MPI_REAL,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(hsplfl,80*maxhpa,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(dskker,40*maxker,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(kerstr,80,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(refmdl,80,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(varstr,40*maxker,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+
+ else
+ call exit_MPI(myrank,'3D model not defined')
+ endif
+ endif
+
+ if(ANISOTROPIC_3D_MANTLE) then
+! the variables read are declared and stored in structure AMM_V
+ if(myrank == 0) call read_aniso_mantle_model(AMM_V)
+! broadcast the information read on the master to the nodes
+ call MPI_BCAST(AMM_V%npar1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(AMM_V%beta,14*34*37*73,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(AMM_V%pro,47,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ endif
+
+ if(CRUSTAL) then
+! the variables read are declared and stored in structure CM_V
+ if(myrank == 0) call read_crustal_model(CM_V)
+! broadcast the information read on the master to the nodes
+ call MPI_BCAST(CM_V%thlr,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(CM_V%velocp,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(CM_V%velocs,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(CM_V%dens,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(CM_V%abbreviation,NCAP_CRUST*NCAP_CRUST,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(CM_V%code,2*NKEYS_CRUST,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ endif
+
+ if(ANISOTROPIC_INNER_CORE) then
+ if(myrank == 0) call read_aniso_inner_core_model
+! one should add an MPI_BCAST here if one adds a read_aniso_inner_core_model subroutine
+ endif
+
+ if(ATTENUATION .and. ATTENUATION_3D) then
+ if(myrank == 0) call read_attenuation_model(MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD, AM_V)
+
+ if(myrank /= 0) then
+ allocate(AM_V%Qtau_s(N_SLS),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ endif
+ call MPI_BCAST(AM_V%min_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%max_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%QT_c_source, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%Qtau_s(1), 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%Qtau_s(2), 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%Qtau_s(3), 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ endif
+
+ if(ATTENUATION .and. .not. ATTENUATION_3D) then
+ if(myrank == 0) call read_attenuation_model(MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD, AM_V)
+
+ call MPI_BCAST(AM_V%min_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+ call MPI_BCAST(AM_V%max_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
+
+ call attenuation_model_setup(REFERENCE_1D_MODEL, RICB, RCMB, R670, R220, R80,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,AM_S,AS_V)
+ endif
+
+! read topography and bathymetry file
+ if(TOPOGRAPHY .or. OCEANS) then
+ if(myrank == 0) call read_topo_bathy_file(ibathy_topo)
+! broadcast the information read on the master to the nodes
+ call MPI_BCAST(ibathy_topo,NX_BATHY*NY_BATHY,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ endif
+
+! get addressing for this process
+ ichunk = ichunk_slice(myrank)
+ iproc_xi = iproc_xi_slice(myrank)
+ iproc_eta = iproc_eta_slice(myrank)
+
+ if(myrank == 0) then
+ write(IMAIN,*) 'Reference radius of the Earth used is ',R_EARTH_KM,' km'
+ write(IMAIN,*)
+ write(IMAIN,*) 'Central cube is at a radius of ',R_CENTRAL_CUBE/1000.d0,' km'
+ endif
+
+! compute rotation matrix from Euler angles
+ ANGULAR_WIDTH_XI_RAD = ANGULAR_WIDTH_XI_IN_DEGREES * PI / 180.d0
+ ANGULAR_WIDTH_ETA_RAD = ANGULAR_WIDTH_ETA_IN_DEGREES * PI / 180.d0
+ if(NCHUNKS /= 6) call euler_angles(rotation_matrix,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH)
+
+! volume of the slice
+ volume_total = ZERO
+
+! make sure everybody is synchronized
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+!----
+!---- loop on all the regions of the mesh
+!----
+
+!! DK DK for the merged version
+ include 'allocate_before.f90'
+
+!! DK DK for the merged version
+ allocate(ibool1D_leftxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(ibool1D_rightxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(ibool1D_leftxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(ibool1D_rightxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(xread1D_leftxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(xread1D_rightxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(xread1D_leftxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(xread1D_rightxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(yread1D_leftxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(yread1D_rightxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(yread1D_leftxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(yread1D_rightxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+ allocate(zread1D_leftxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(zread1D_rightxi_lefteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(zread1D_leftxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(zread1D_rightxi_righteta(maxval(NGLOB1D_RADIAL_CORNER)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+! number of regions in full Earth
+ do iregion_code = 1,MAX_NUM_REGIONS
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '*******************************************'
+ write(IMAIN,*) 'creating mesh in region ',iregion_code
+
+ select case(iregion_code)
+
+ case(IREGION_CRUST_MANTLE)
+ write(IMAIN,*) 'this region is the crust and mantle'
+
+ case(IREGION_OUTER_CORE)
+ write(IMAIN,*) 'this region is the outer core'
+
+ case(IREGION_INNER_CORE)
+ write(IMAIN,*) 'this region is the inner core'
+
+ case default
+ call exit_MPI(myrank,'incorrect region code')
+ end select
+ write(IMAIN,*) '*******************************************'
+ write(IMAIN,*)
+ endif
+
+! compute maximum number of points
+ npointot = NSPEC(iregion_code) * NGLLX * NGLLY * NGLLZ
+
+! use dynamic allocation to allocate memory for arrays
+!! DK DK suppressed this for merged version
+! allocate(idoubling(NSPEC(iregion_code)),STAT=ier)
+! allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)),STAT=ier)
+ allocate(xstore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(ystore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+ allocate(zstore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)),STAT=ier)
+ if (ier /= 0) then
+ print *,"ABORTING can not allocate in meshfem3D ier=",ier
+ call MPI_Abort(MPI_COMM_WORLD,errorcode,ier)
+ endif
+
+! create all the regions of the mesh
+! perform two passes in this part to be able to save memory
+ do ipass = 1,2
+
+!! DK DK for merged version
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+! crust_mantle
+ call create_regions_mesh(iregion_code,ibool_crust_mantle,idoubling_crust_mantle, &
+ xstore,ystore,zstore,rmins,rmaxs,iproc_xi,iproc_eta,ichunk,NSPEC(iregion_code),nspec_aniso, &
+ volume_local,area_local_bottom,area_local_top, &
+ nspl,rspl,espl,espl2,nglob(iregion_code),npointot, &
+ NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC2DMAX_XMIN_XMAX(iregion_code),NSPEC2DMAX_YMIN_YMAX(iregion_code), &
+ NSPEC2D_BOTTOM(iregion_code),NSPEC2D_TOP(iregion_code), &
+ ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
+ max(NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code)), &
+ myrank,LOCAL_PATH,OCEANS,ibathy_topo,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD, &
+ ATTENUATION,ATTENUATION_3D, &
+ NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ ner,ratio_sampling_array,doubling_index,r_bottom, r_top,this_region_has_a_doubling,CASE_3D, &
+ AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V, AM_S, AS_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ipass,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,&
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,mod(iproc_xi_slice(myrank),2),mod(iproc_eta_slice(myrank),2), &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ NGLOB2DMAX_XMIN_XMAX_CM,NGLOB2DMAX_YMIN_YMAX_CM, &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
+ nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle,nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+ ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle,ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+ ibelm_bottom_crust_mantle, ibelm_top_crust_mantle, &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
+ jacobian2D_xmin_crust_mantle,jacobian2D_xmax_crust_mantle, &
+ jacobian2D_ymin_crust_mantle,jacobian2D_ymax_crust_mantle,jacobian2D_bottom_crust_mantle,jacobian2D_top_crust_mantle, &
+ normal_xmin_crust_mantle,normal_xmax_crust_mantle,normal_ymin_crust_mantle, &
+ normal_ymax_crust_mantle,normal_bottom_crust_mantle,normal_top_crust_mantle, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ rmass_crust_mantle,xelm_store_crust_mantle,yelm_store_crust_mantle,zelm_store_crust_mantle, &
+!! DK DK this will have to change to fully support David's code to cut the superbrick
+ npoin2D_xi_crust_mantle(1),npoin2D_eta_crust_mantle(1),perm,invperm)
+
+ else if(iregion_code == IREGION_OUTER_CORE) then
+! outer_core
+ call create_regions_mesh(iregion_code,ibool_outer_core,idoubling_outer_core, &
+ xstore,ystore,zstore,rmins,rmaxs,iproc_xi,iproc_eta,ichunk,NSPEC(iregion_code),nspec_aniso, &
+ volume_local,area_local_bottom,area_local_top, &
+ nspl,rspl,espl,espl2,nglob(iregion_code),npointot, &
+ NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NSPEC2DMAX_XMIN_XMAX(iregion_code), &
+ NSPEC2DMAX_YMIN_YMAX(iregion_code),NSPEC2D_BOTTOM(iregion_code),NSPEC2D_TOP(iregion_code), &
+ ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
+ max(NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code)), &
+ myrank,LOCAL_PATH,OCEANS,ibathy_topo,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD, &
+ ATTENUATION,ATTENUATION_3D, &
+ NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ ner,ratio_sampling_array,doubling_index,r_bottom, r_top,this_region_has_a_doubling,CASE_3D, &
+ AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V, AM_S, AS_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ipass,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,&
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,mod(iproc_xi_slice(myrank),2),mod(iproc_eta_slice(myrank),2), &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ NGLOB2DMAX_XMIN_XMAX_OC,NGLOB2DMAX_YMIN_YMAX_OC, &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core,nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core,ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ ibelm_bottom_outer_core, ibelm_top_outer_core, &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
+ jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core, &
+ jacobian2D_ymin_outer_core,jacobian2D_ymax_outer_core,jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
+ normal_xmin_outer_core,normal_xmax_outer_core,normal_ymin_outer_core, &
+ normal_ymax_outer_core,normal_bottom_outer_core,normal_top_outer_core, &
+ kappavstore_outer_core,kappahstore_outer_core,muvstore_outer_core,muhstore_outer_core,eta_anisostore_outer_core, &
+ rmass_outer_core,xelm_store_outer_core,yelm_store_outer_core,zelm_store_outer_core, &
+!! DK DK this will have to change to fully support David's code to cut the superbrick
+ npoin2D_xi_outer_core(1),npoin2D_eta_outer_core(1),perm,invperm)
+
+ else if(iregion_code == IREGION_INNER_CORE) then
+! inner_core
+ call create_regions_mesh(iregion_code,ibool_inner_core,idoubling_inner_core, &
+ xstore,ystore,zstore,rmins,rmaxs,iproc_xi,iproc_eta,ichunk,NSPEC(iregion_code),nspec_aniso, &
+ volume_local,area_local_bottom,area_local_top, &
+ nspl,rspl,espl,espl2,nglob(iregion_code),npointot, &
+ NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NSPEC2DMAX_XMIN_XMAX(iregion_code), &
+ NSPEC2DMAX_YMIN_YMAX(iregion_code),NSPEC2D_BOTTOM(iregion_code),NSPEC2D_TOP(iregion_code), &
+ ELLIPTICITY,TOPOGRAPHY,TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,ISOTROPIC_3D_MANTLE,CRUSTAL,ONE_CRUST, &
+ NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
+ max(NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code)), &
+ myrank,LOCAL_PATH,OCEANS,ibathy_topo,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD, &
+ ATTENUATION,ATTENUATION_3D, &
+ NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
+ R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ ner,ratio_sampling_array,doubling_index,r_bottom, r_top,this_region_has_a_doubling,CASE_3D, &
+ AMM_V,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,D3MM_V,JP3DM_V,SEA99M_V,CM_V, AM_S, AS_V, &
+ numker,numhpa,numcof,ihpa,lmax,nylm, &
+ lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
+ nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
+ coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr,ipass,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,&
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,mod(iproc_xi_slice(myrank),2),mod(iproc_eta_slice(myrank),2), &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ NGLOB2DMAX_XMIN_XMAX_IC,NGLOB2DMAX_YMIN_YMAX_IC, &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
+ nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
+ ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core, &
+ ibelm_bottom_inner_core, ibelm_top_inner_core, &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
+ jacobian2D_xmin_inner_core,jacobian2D_xmax_inner_core, &
+ jacobian2D_ymin_inner_core,jacobian2D_ymax_inner_core,jacobian2D_bottom_inner_core,jacobian2D_top_inner_core, &
+ normal_xmin_inner_core,normal_xmax_inner_core,normal_ymin_inner_core, &
+ normal_ymax_inner_core,normal_bottom_inner_core,normal_top_inner_core, &
+ kappavstore_inner_core,kappahstore_inner_core,muvstore_inner_core,muhstore_inner_core,eta_anisostore_inner_core, &
+ rmass_inner_core,xelm_store_inner_core,yelm_store_inner_core,zelm_store_inner_core, &
+!! DK DK this will have to change to fully support David's code to cut the superbrick
+ npoin2D_xi_inner_core(1),npoin2D_eta_inner_core(1),perm,invperm)
+
+ else
+ stop 'DK DK incorrect region in merged code'
+ endif
+
+ enddo ! of loop on ipass = 1,2
+
+! store number of anisotropic elements found in the mantle
+ if(nspec_aniso /= 0 .and. iregion_code /= IREGION_CRUST_MANTLE) &
+ call exit_MPI(myrank,'found anisotropic elements outside of the mantle')
+
+ if(iregion_code == IREGION_CRUST_MANTLE .and. nspec_aniso == 0) &
+ call exit_MPI(myrank,'found no anisotropic elements in the mantle')
+
+! use MPI reduction to compute total area and volume
+ volume_total_region = ZERO
+ area_total_bottom = ZERO
+ area_total_top = ZERO
+ call MPI_REDUCE(area_local_bottom,area_total_bottom,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
+ MPI_COMM_WORLD,ier)
+ call MPI_REDUCE(area_local_top,area_total_top,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
+ MPI_COMM_WORLD,ier)
+ call MPI_REDUCE(volume_local,volume_total_region,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
+ MPI_COMM_WORLD,ier)
+
+ if(myrank == 0) then
+! sum volume over all the regions
+ volume_total = volume_total + volume_total_region
+
+! check volume of chunk, and bottom and top area
+
+ write(IMAIN,*)
+ write(IMAIN,*) ' calculated top area: ',area_total_top
+
+! compare to exact theoretical value
+ if(NCHUNKS == 6 .and. .not. TOPOGRAPHY) then
+ select case(iregion_code)
+
+ case(IREGION_CRUST_MANTLE)
+ write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*R_UNIT_SPHERE**2
+
+ case(IREGION_OUTER_CORE)
+ write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RCMB/R_EARTH)**2
+
+ case(IREGION_INNER_CORE)
+ write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RICB/R_EARTH)**2
+
+ case default
+ call exit_MPI(myrank,'incorrect region code')
+ end select
+ endif
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'calculated bottom area: ',area_total_bottom
+
+! compare to exact theoretical value
+ if(NCHUNKS == 6 .and. .not. TOPOGRAPHY) then
+
+ select case(iregion_code)
+
+ case(IREGION_CRUST_MANTLE)
+ write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RCMB/R_EARTH)**2
+
+ case(IREGION_OUTER_CORE)
+ write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RICB/R_EARTH)**2
+
+ case(IREGION_INNER_CORE)
+ write(IMAIN,*) ' exact area (central cube): ',dble(NCHUNKS)*(2.*(R_CENTRAL_CUBE / R_EARTH)/sqrt(3.))**2
+
+ case default
+ call exit_MPI(myrank,'incorrect region code')
+ end select
+ endif
+
+ endif
+
+!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+!! DK DK added this for merged version
+
+! create the list of messages in files to assemble between chunks if more than one chunk
+! create it only once (and for all) therefore for first region only, because stored in disk files
+!! DK DK this could probably be simplified or merged with create_chunk_buffers, but no time to do it for now
+ if(NCHUNKS > 1 .and. iregion_code == IREGION_CRUST_MANTLE) &
+! crust_mantle
+ call create_list_files_chunks(iregion_code, &
+ nglob(iregion_code),NPROC_XI,NPROC_ETA,NPROCTOT,NGLOB1D_RADIAL_CORNER, &
+ NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code), &
+ myrank,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS)
+
+!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+!! DK DK added this for merged version
+
+! read chunk messages only if more than one chunk
+ if(NCHUNKS_VAL /= 1 .and. myrank == 0 .and. not_done_yet) then
+
+! do this only once in the mesher, because these arrays do not change
+ not_done_yet = .false.
+
+! read messages to assemble between chunks with MPI
+
+! file with the list of processors for each message for faces
+ open(unit=IIN,file=trim(OUTPUT_FILES)//'/list_messages_faces.txt',status='old',action='read')
+ do imsg = 1,NUMMSGS_FACES_VAL
+ read(IIN,*) imsg_type(imsg),iprocfrom_faces(imsg),iprocto_faces(imsg)
+ if (iprocfrom_faces(imsg) < 0 &
+ .or. iprocto_faces(imsg) < 0 &
+ .or. iprocfrom_faces(imsg) > NPROCTOT-1 &
+ .or. iprocto_faces(imsg) > NPROCTOT-1) &
+ call exit_MPI(myrank,'incorrect chunk faces numbering')
+ if (imsg_type(imsg) < 1 .or. imsg_type(imsg) > 3) &
+ call exit_MPI(myrank,'incorrect message type labeling')
+ enddo
+ close(IIN)
+
+! file with the list of processors for each message for corners
+ open(unit=IIN,file=trim(OUTPUT_FILES)//'/list_messages_corners.txt',status='old',action='read')
+ do imsg = 1,NCORNERSCHUNKS_VAL
+ read(IIN,*) iproc_master_corners(imsg),iproc_worker1_corners(imsg), &
+ iproc_worker2_corners(imsg)
+ if (iproc_master_corners(imsg) < 0 &
+ .or. iproc_worker1_corners(imsg) < 0 &
+ .or. iproc_worker2_corners(imsg) < 0 &
+ .or. iproc_master_corners(imsg) > NPROCTOT-1 &
+ .or. iproc_worker1_corners(imsg) > NPROCTOT-1 &
+ .or. iproc_worker2_corners(imsg) > NPROCTOT-1) &
+ call exit_MPI(myrank,'incorrect chunk corner numbering')
+ enddo
+ close(IIN)
+
+ endif
+
+! broadcast the information read on the master to the nodes
+ if(NCHUNKS_VAL /= 1) then
+ call MPI_BCAST(imsg_type,NUMMSGS_FACES_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iprocfrom_faces,NUMMSGS_FACES_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iprocto_faces,NUMMSGS_FACES_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(iproc_master_corners,NCORNERSCHUNKS_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iproc_worker1_corners,NCORNERSCHUNKS_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iproc_worker2_corners,NCORNERSCHUNKS_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ endif
+
+!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+ ! create chunk buffers if more than one chunk
+ if(NCHUNKS > 1) then
+
+!! DK DK added this for merged version
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+! crust_mantle
+ call create_chunk_buffers(iregion_code,NSPEC(iregion_code),ibool_crust_mantle,idoubling_crust_mantle,xstore,ystore,zstore, &
+ nglob(iregion_code), &
+ NSPEC2DMAX_XMIN_XMAX(iregion_code),NSPEC2DMAX_YMIN_YMAX(iregion_code), &
+ NPROC_XI,NPROC_ETA,NPROC,NPROCTOT,NGLOB1D_RADIAL_CORNER,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
+ NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code), &
+ myrank,LOCAL_PATH,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS, &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta, &
+ nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle,nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
+ ibelm_xmin_crust_mantle,ibelm_xmax_crust_mantle,ibelm_ymin_crust_mantle,ibelm_ymax_crust_mantle, &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
+ iprocfrom_faces,iprocto_faces,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces_crust_mantle,npoin2D_faces_crust_mantle,iboolcorner_crust_mantle,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE))
+
+ else if(iregion_code == IREGION_OUTER_CORE) then
+! outer_core
+ call create_chunk_buffers(iregion_code,NSPEC(iregion_code),ibool_outer_core,idoubling_outer_core,xstore,ystore,zstore, &
+ nglob(iregion_code), &
+ NSPEC2DMAX_XMIN_XMAX(iregion_code),NSPEC2DMAX_YMIN_YMAX(iregion_code), &
+ NPROC_XI,NPROC_ETA,NPROC,NPROCTOT,NGLOB1D_RADIAL_CORNER,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
+ NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code), &
+ myrank,LOCAL_PATH,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS, &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta, &
+ nspec2D_xmin_outer_core,nspec2D_xmax_outer_core,nspec2D_ymin_outer_core,nspec2D_ymax_outer_core, &
+ ibelm_xmin_outer_core,ibelm_xmax_outer_core,ibelm_ymin_outer_core,ibelm_ymax_outer_core, &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
+ iprocfrom_faces,iprocto_faces,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces_outer_core,npoin2D_faces_outer_core,iboolcorner_outer_core,NGLOB1D_RADIAL(IREGION_OUTER_CORE))
+
+ else if(iregion_code == IREGION_INNER_CORE) then
+! inner_core
+ call create_chunk_buffers(iregion_code,NSPEC(iregion_code),ibool_inner_core,idoubling_inner_core,xstore,ystore,zstore, &
+ nglob(iregion_code), &
+ NSPEC2DMAX_XMIN_XMAX(iregion_code),NSPEC2DMAX_YMIN_YMAX(iregion_code), &
+ NPROC_XI,NPROC_ETA,NPROC,NPROCTOT,NGLOB1D_RADIAL_CORNER,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
+ NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code), &
+ myrank,LOCAL_PATH,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS, &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta, &
+ nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
+ ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core, &
+ xread1D_leftxi_lefteta, xread1D_rightxi_lefteta, xread1D_leftxi_righteta, xread1D_rightxi_righteta, &
+ yread1D_leftxi_lefteta, yread1D_rightxi_lefteta, yread1D_leftxi_righteta, yread1D_rightxi_righteta, &
+ zread1D_leftxi_lefteta, zread1D_rightxi_lefteta, zread1D_leftxi_righteta, zread1D_rightxi_righteta, &
+ iprocfrom_faces,iprocto_faces,iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces_inner_core,npoin2D_faces_inner_core,iboolcorner_inner_core,NGLOB1D_RADIAL(IREGION_INNER_CORE))
+
+ else
+ stop 'DK DK incorrect region in merged code'
+ endif
+
+ else
+ if(myrank == 0) then
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'only one chunk, no need to create chunk buffers'
+ write(IMAIN,*)
+ endif
+ endif
+
+! deallocate arrays used for that region
+!! DK DK suppressed this for merged version
+! deallocate(idoubling)
+! deallocate(ibool)
+ deallocate(xstore)
+ deallocate(ystore)
+ deallocate(zstore)
+
+! make sure everybody is synchronized
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+! end of loop on all the regions
+ enddo
+
+!! DK DK for the merged version
+ deallocate(ibool1D_leftxi_lefteta)
+ deallocate(ibool1D_rightxi_lefteta)
+ deallocate(ibool1D_leftxi_righteta)
+ deallocate(ibool1D_rightxi_righteta)
+
+ deallocate(xread1D_leftxi_lefteta)
+ deallocate(xread1D_rightxi_lefteta)
+ deallocate(xread1D_leftxi_righteta)
+ deallocate(xread1D_rightxi_righteta)
+
+ deallocate(yread1D_leftxi_lefteta)
+ deallocate(yread1D_rightxi_lefteta)
+ deallocate(yread1D_leftxi_righteta)
+ deallocate(yread1D_rightxi_righteta)
+
+ deallocate(zread1D_leftxi_lefteta)
+ deallocate(zread1D_rightxi_lefteta)
+ deallocate(zread1D_leftxi_righteta)
+ deallocate(zread1D_rightxi_righteta)
+
+ if(myrank == 0) then
+! check volume of chunk
+ write(IMAIN,*)
+ write(IMAIN,*) 'calculated volume: ',volume_total
+ if(.not. TOPOGRAPHY) then
+! take the central cube into account
+! it is counted 6 times because of the fictitious elements
+ if(INCLUDE_CENTRAL_CUBE) then
+ write(IMAIN,*) ' exact volume: ', &
+ dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)+5.*(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0
+ else
+ write(IMAIN,*) ' exact volume: ', &
+ dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)-(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0
+ endif
+ endif
+ endif
+
+!--- print number of points and elements in the mesh for each region
+
+ if(myrank == 0) then
+
+ numelem_crust_mantle = NSPEC(IREGION_CRUST_MANTLE)
+ numelem_outer_core = NSPEC(IREGION_OUTER_CORE)
+ numelem_inner_core = NSPEC(IREGION_INNER_CORE)
+
+ numelem_total = numelem_crust_mantle + numelem_outer_core + numelem_inner_core
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'Repartition of elements in regions:'
+ write(IMAIN,*) '----------------------------------'
+ write(IMAIN,*)
+ write(IMAIN,*) 'total number of elements in each slice: ',numelem_total
+ write(IMAIN,*)
+ write(IMAIN,*) ' - crust and mantle: ',sngl(100.d0*dble(numelem_crust_mantle)/dble(numelem_total)),' %'
+ write(IMAIN,*) ' - outer core: ',sngl(100.d0*dble(numelem_outer_core)/dble(numelem_total)),' %'
+ write(IMAIN,*) ' - inner core: ',sngl(100.d0*dble(numelem_inner_core)/dble(numelem_total)),' %'
+ write(IMAIN,*)
+ write(IMAIN,*) 'for some mesh statistics, see comments in file OUTPUT_FILES/values_from_mesher.h'
+ write(IMAIN,*)
+
+! load balancing
+ write(IMAIN,*) 'Load balancing = 100 % by definition'
+ write(IMAIN,*)
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'total number of time steps in the solver will be: ',NSTEP
+ write(IMAIN,*)
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'time-stepping of the solver will be: ',DT
+ write(IMAIN,*)
+
+! write information about precision used for floating-point operations
+ if(CUSTOM_REAL == SIZE_REAL) then
+ write(IMAIN,*) 'using single precision for the calculations'
+ else
+ write(IMAIN,*) 'using double precision for the calculations'
+ endif
+ write(IMAIN,*)
+ write(IMAIN,*) 'smallest and largest possible floating-point numbers are: ',tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
+ write(IMAIN,*)
+
+! evaluate the amount of static memory needed by the solver
+!! DK DK suppressed in the merged version because useless
+! call memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MANTLE,&
+! TRANSVERSE_ISOTROPY,ANISOTROPIC_INNER_CORE,ROTATION,&
+! ONE_CRUST,doubling_index,this_region_has_a_doubling,&
+! ner,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_sampling_array,&
+! NSPEC,nglob,SIMULATION_TYPE,MOVIE_VOLUME,SAVE_FORWARD, &
+! NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+! NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+! NSPEC_INNER_CORE_ATTENUATION, &
+! NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+! NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+! NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+! NSPEC_CRUST_MANTLE_ADJOINT, &
+! NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+! NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+! NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+! NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+! NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION,static_memory_size)
+
+!! DK DK suppressed in the merged version because useless
+! NGLOB1D_RADIAL_TEMP(:) = &
+! (/maxval(NGLOB1D_RADIAL_CORNER(1,:)),maxval(NGLOB1D_RADIAL_CORNER(2,:)),maxval(NGLOB1D_RADIAL_CORNER(3,:))/)
+
+! create include file for the solver
+!! DK DK suppressed in the merged version because useless
+! call save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, &
+! TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+! ELLIPTICITY,GRAVITY,ROTATION,ATTENUATION,ATTENUATION_3D, &
+! ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,NCHUNKS, &
+! INCLUDE_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,NSOURCES,NSTEP, &
+! static_memory_size,NGLOB1D_RADIAL_TEMP, &
+! NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NSPEC2D_TOP,NSPEC2D_BOTTOM, &
+! NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX, &
+! NPROC_XI,NPROC_ETA, &
+! NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+! NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+! NSPEC_INNER_CORE_ATTENUATION, &
+! NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+! NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+! NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+! NSPEC_CRUST_MANTLE_ADJOINT, &
+! NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+! NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+! NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+! NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+! NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION)
+
+ endif ! end of section executed by main process only
+
+! deallocate arrays used for mesh generation
+!! DK DK suppressed in the merged version because these arrays will be transmitted to the solver
+! deallocate(addressing)
+! deallocate(ichunk_slice)
+! deallocate(iproc_xi_slice)
+! deallocate(iproc_eta_slice)
+
+! elapsed time since beginning of mesh generation
+ if(myrank == 0) then
+ tCPU = MPI_WTIME() - time_start
+ write(IMAIN,*)
+ write(IMAIN,*) 'Elapsed time for mesh generation and buffer creation in seconds = ',tCPU
+ write(IMAIN,*) 'End of mesh generation'
+ write(IMAIN,*)
+! close main output file
+ close(IMAIN)
+ endif
+
+! synchronize all the processes to make sure everybody has finished
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+!!!!!!!! DK DK solver inserted here
+!!!!!!!! DK DK solver inserted here
+!!!!!!!! DK DK solver inserted here
+
+!! DK DK for merged version, temporary patch for David's code to cut the superbrick
+!! DK DK which I have not fully ported to the merged version yet: I do not
+!! DK DK yet distinguish the two values of each array, therefore let me set them
+!! DK DK equal here
+ npoin2D_xi_crust_mantle(2) = npoin2D_xi_crust_mantle(1)
+ npoin2D_eta_crust_mantle(2) = npoin2D_eta_crust_mantle(1)
+
+ npoin2D_xi_outer_core(2) = npoin2D_xi_outer_core(1)
+ npoin2D_eta_outer_core(2) = npoin2D_eta_outer_core(1)
+
+ npoin2D_xi_inner_core(2) = npoin2D_xi_inner_core(1)
+ npoin2D_eta_inner_core(2) = npoin2D_eta_inner_core(1)
+
+!! DK DK for the merged version
+ include 'allocate_after_1.f90'
+
+!! DK DK recompute arrays here for merged version
+ call recompute_missing_arrays(myrank, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xelm_store_crust_mantle,yelm_store_crust_mantle,zelm_store_crust_mantle, &
+ ibool_crust_mantle,NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE)
+
+ call recompute_missing_arrays(myrank, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xelm_store_outer_core,yelm_store_outer_core,zelm_store_outer_core, &
+ ibool_outer_core,NSPEC_OUTER_CORE,NGLOB_OUTER_CORE)
+
+ call recompute_missing_arrays(myrank, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ xelm_store_inner_core,yelm_store_inner_core,zelm_store_inner_core, &
+ ibool_inner_core,NSPEC_INNER_CORE,NGLOB_INNER_CORE)
+
+!! DK DK for merged version, deallocate arrays that have become useless
+ deallocate(xelm_store_crust_mantle)
+ deallocate(yelm_store_crust_mantle)
+ deallocate(zelm_store_crust_mantle)
+
+ deallocate(xelm_store_outer_core)
+ deallocate(yelm_store_outer_core)
+ deallocate(zelm_store_outer_core)
+
+ deallocate(xelm_store_inner_core)
+ deallocate(yelm_store_inner_core)
+ deallocate(zelm_store_inner_core)
+
+!! DK DK for the merged version
+ include 'allocate_after_2.f90'
+
+!! DK DK for the merged version
+ include 'call1.f90'
+!! DK DK for now use variables just to make sure we don't get warning about unused variables
+! include 'oldstuff/dummy_use_variables.f90'
+
+!! DK DK for the merged version
+ include 'deallocate.f90'
+
+!!!!!!!! DK DK solver inserted here
+!!!!!!!! DK DK solver inserted here
+!!!!!!!! DK DK solver inserted here
+
+! synchronize all the processes to make sure everybody has finished
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+! stop all the MPI processes, and exit
+ call MPI_FINALIZE(ier)
+
+ end program xmeshfem3D
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_1066a.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_1066a.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_1066a.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/model_ak135.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_ak135.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_ak135.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/model_iasp91.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_iasp91.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_iasp91.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/model_jp1d.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_jp1d.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_jp1d.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/model_prem.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_prem.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_prem.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,612 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine prem_iso(myrank,x,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,CRUSTAL, &
+ ONE_CRUST,check_doubling_flag,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ implicit none
+
+ include "constants.h"
+
+! given a normalized radius x, gives the non-dimesionalized density rho,
+! speeds vp and vs, and the quality factors Qkappa and Qmu
+
+ logical CRUSTAL,ONE_CRUST,check_doubling_flag
+
+ integer idoubling,myrank
+
+ double precision x,rho,drhodr,vp,vs,Qkappa,Qmu,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
+
+ double precision r,scaleval
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+! check flags to make sure we correctly honor the discontinuities
+! we use strict inequalities since r has been slighly changed in mesher
+
+ if(check_doubling_flag) then
+
+!
+!--- inner core
+!
+
+ if(r >= 0.d0 .and. r < RICB) then
+ if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. &
+ idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_IN_FICTITIOUS_CUBE) &
+ call exit_MPI(myrank,'wrong doubling flag for inner core point')
+!
+!--- outer core
+!
+ else if(r > RICB .and. r < RCMB) then
+ if(idoubling /= IFLAG_OUTER_CORE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for outer core point')
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for D" point')
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r < R670) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point')
+
+!
+!--- mantle: from d670 to d220
+!
+ else if(r > R670 .and. r < R220) then
+ if(idoubling /= IFLAG_670_220) &
+ call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point')
+
+!
+!--- mantle and crust: from d220 to MOHO and then to surface
+!
+ else if(r > R220) then
+ if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) &
+ call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point')
+
+ endif
+
+ endif
+
+!
+!--- inner core
+!
+ if(r >= 0.d0 .and. r <= RICB) then
+ drhodr=-2.0d0*8.8381d0*x
+ rho=13.0885d0-8.8381d0*x*x
+ vp=11.2622d0-6.3640d0*x*x
+ vs=3.6678d0-4.4475d0*x*x
+ Qmu=84.6d0
+ Qkappa=1327.7d0
+!
+!--- outer core
+!
+ else if(r > RICB .and. r <= RCMB) then
+ drhodr=-1.2638d0-2.0d0*3.6426d0*x-3.0d0*5.5281d0*x*x
+ rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
+ vp=11.0487d0-4.0362d0*x+4.8023d0*x*x-13.5732d0*x*x*x
+ vs=0.0d0
+ Qmu=0.0d0
+ Qkappa=57827.0d0
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
+ drhodr=-6.4761d0+2.0d0*5.5283d0*x-3.0d0*3.0807d0*x*x
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=15.3891d0-5.3181d0*x+5.5242d0*x*x-2.5514d0*x*x*x
+ vs=6.9254d0+1.4672d0*x-2.0834d0*x*x+0.9783d0*x*x*x
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
+ drhodr=-6.4761d0+2.0d0*5.5283d0*x-3.0d0*3.0807d0*x*x
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=24.9520d0-40.4673d0*x+51.4832d0*x*x-26.6419d0*x*x*x
+ vs=11.1671d0-13.7818d0*x+17.4575d0*x*x-9.2777d0*x*x*x
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+ else if(r > R771 .and. r <= R670) then
+ drhodr=-6.4761d0+2.0d0*5.5283d0*x-3.0d0*3.0807d0*x*x
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vp=29.2766d0-23.6027d0*x+5.5242d0*x*x-2.5514d0*x*x*x
+ vs=22.3459d0-17.2473d0*x-2.0834d0*x*x+0.9783d0*x*x*x
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: above d670
+!
+ else if(r > R670 .and. r <= R600) then
+ drhodr=-1.4836d0
+ rho=5.3197d0-1.4836d0*x
+ vp=19.0957d0-9.8672d0*x
+ vs=9.9839d0-4.9324d0*x
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R600 .and. r <= R400) then
+ drhodr=-8.0298d0
+ rho=11.2494d0-8.0298d0*x
+ vp=39.7027d0-32.6166d0*x
+ vs=22.3512d0-18.5856d0*x
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R400 .and. r <= R220) then
+ drhodr=-3.8045d0
+ rho=7.1089d0-3.8045d0*x
+ vp=20.3926d0-12.2569d0*x
+ vs=8.9496d0-4.4597d0*x
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R220 .and. r <= R80) then
+ drhodr=0.6924d0
+ rho=2.6910d0+0.6924d0*x
+ vp=4.1875d0+3.9382d0*x
+ vs=2.1519d0+2.3481d0*x
+ Qmu=80.0d0
+ Qkappa=57827.0d0
+ else
+ if(CRUSTAL .and. .not. SUPPRESS_CRUSTAL_MESH) then
+! fill with PREM mantle and later add CRUST2.0
+ if(r > R80) then
+ drhodr=0.6924d0
+ rho=2.6910d0+0.6924d0*x
+ vp=4.1875d0+3.9382d0*x
+ vs=2.1519d0+2.3481d0*x
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+ else
+! use PREM crust
+ if(r > R80 .and. r <= RMOHO) then
+ drhodr=0.6924d0
+ rho=2.6910d0+0.6924d0*x
+ vp=4.1875d0+3.9382d0*x
+ vs=2.1519d0+2.3481d0*x
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+
+ else if (SUPPRESS_CRUSTAL_MESH) then
+!! DK DK extend the Moho up to the surface instead of the crust
+ drhodr=0.6924d0
+ rho = 2.6910d0+0.6924d0*(RMOHO / R_EARTH)
+ vp = 4.1875d0+3.9382d0*(RMOHO / R_EARTH)
+ vs = 2.1519d0+2.3481d0*(RMOHO / R_EARTH)
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+ else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
+ drhodr=0.0d0
+ rho=2.9d0
+ vp=6.8d0
+ vs=3.9d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+! same properties everywhere in PREM crust if we decide to define only one layer in the crust
+ if(ONE_CRUST) then
+ drhodr=0.0d0
+ rho=2.6d0
+ vp=5.8d0
+ vs=3.2d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+
+ else if(r > RMIDDLE_CRUST .and. r <= ROCEAN) then
+ drhodr=0.0d0
+ rho=2.6d0
+ vp=5.8d0
+ vs=3.2d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+! for density profile for gravity, we do not check that r <= R_EARTH
+ else if(r > ROCEAN) then
+ drhodr=0.0d0
+ rho=2.6d0
+ vp=5.8d0
+ vs=3.2d0
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+ endif
+ endif
+ endif
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ drhodr=drhodr*1000.0d0/RHOAV
+ rho=rho*1000.0d0/RHOAV
+ vp=vp*1000.0d0/(R_EARTH*scaleval)
+ vs=vs*1000.0d0/(R_EARTH*scaleval)
+
+ end subroutine prem_iso
+
+!
+!=====================================================================
+!
+
+ subroutine prem_aniso(myrank,x,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu, &
+ idoubling,CRUSTAL,ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ implicit none
+
+ include "constants.h"
+
+! given a normalized radius x, gives the non-dimesionalized density rho,
+! speeds vp and vs, and the quality factors Qkappa and Qmu
+
+ logical CRUSTAL,ONE_CRUST
+
+ integer idoubling,myrank
+
+ double precision x,rho,Qkappa,Qmu,vpv,vph,vsv,vsh,eta_aniso,RICB,RCMB, &
+ RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
+
+ double precision r
+ double precision scaleval
+
+! compute real physical radius in meters
+ r = x * R_EARTH
+
+! check flags to make sure we correctly honor the discontinuities
+! we use strict inequalities since r has been slighly changed in mesher
+
+!
+!--- inner core
+!
+ if(r >= 0.d0 .and. r < RICB) then
+ if(idoubling /= IFLAG_INNER_CORE_NORMAL .and. &
+ idoubling /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_TOP_CENTRAL_CUBE .and. &
+ idoubling /= IFLAG_IN_FICTITIOUS_CUBE) &
+ call exit_MPI(myrank,'wrong doubling flag for inner core point')
+!
+!--- outer core
+!
+ else if(r > RICB .and. r < RCMB) then
+ if(idoubling /= IFLAG_OUTER_CORE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for outer core point')
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for D" point')
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r < R670) then
+ if(idoubling /= IFLAG_MANTLE_NORMAL) &
+ call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point')
+
+!
+!--- mantle: from d670 to d220
+!
+ else if(r > R670 .and. r < R220) then
+ if(idoubling /= IFLAG_670_220) &
+ call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point')
+
+!
+!--- mantle and crust: from d220 to MOHO and then to surface
+!
+ else if(r > R220) then
+ if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) &
+ call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point')
+
+ endif
+
+! no anisotropy by default
+ eta_aniso = 1.d0
+
+!
+!--- inner core
+!
+ if(r >= 0.d0 .and. r <= RICB) then
+ rho=13.0885d0-8.8381d0*x*x
+ vpv=11.2622d0-6.3640d0*x*x
+ vsv=3.6678d0-4.4475d0*x*x
+ vph=vpv
+ vsh=vsv
+ Qmu=84.6d0
+ Qkappa=1327.7d0
+!
+!--- outer core
+!
+ else if(r > RICB .and. r <= RCMB) then
+ rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
+ vpv=11.0487d0-4.0362d0*x+4.8023d0*x*x-13.5732d0*x*x*x
+ vsv=0.0d0
+ vph=vpv
+ vsh=vsv
+ Qmu=0.0d0
+ Qkappa=57827.0d0
+!
+!--- D" at the base of the mantle
+!
+ else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vpv=15.3891d0-5.3181d0*x+5.5242d0*x*x-2.5514d0*x*x*x
+ vsv=6.9254d0+1.4672d0*x-2.0834d0*x*x+0.9783d0*x*x*x
+ vph=vpv
+ vsh=vsv
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: from top of D" to d670
+!
+ else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vpv=24.9520d0-40.4673d0*x+51.4832d0*x*x-26.6419d0*x*x*x
+ vsv=11.1671d0-13.7818d0*x+17.4575d0*x*x-9.2777d0*x*x*x
+ vph=vpv
+ vsh=vsv
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+ else if(r > R771 .and. r <= R670) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ vpv=29.2766d0-23.6027d0*x+5.5242d0*x*x-2.5514d0*x*x*x
+ vsv=22.3459d0-17.2473d0*x-2.0834d0*x*x+0.9783d0*x*x*x
+ vph=vpv
+ vsh=vsv
+ Qmu=312.0d0
+ Qkappa=57827.0d0
+!
+!--- mantle: above d670
+!
+ else if(r > R670 .and. r <= R600) then
+ rho=5.3197d0-1.4836d0*x
+ vpv=19.0957d0-9.8672d0*x
+ vsv=9.9839d0-4.9324d0*x
+ vph=vpv
+ vsh=vsv
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R600 .and. r <= R400) then
+ rho=11.2494d0-8.0298d0*x
+ vpv=39.7027d0-32.6166d0*x
+ vsv=22.3512d0-18.5856d0*x
+ vph=vpv
+ vsh=vsv
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R400 .and. r <= R220) then
+ rho=7.1089d0-3.8045d0*x
+ vpv=20.3926d0-12.2569d0*x
+ vsv=8.9496d0-4.4597d0*x
+ vph=vpv
+ vsh=vsv
+ Qmu=143.0d0
+ Qkappa=57827.0d0
+ else if(r > R220 .and. r <= R80) then
+
+! anisotropy in PREM only above 220 km
+
+ rho=2.6910d0+0.6924d0*x
+ vpv=0.8317d0+7.2180d0*x
+ vph=3.5908d0+4.6172d0*x
+ vsv=5.8582d0-1.4678d0*x
+ vsh=-1.0839d0+5.7176d0*x
+ eta_aniso=3.3687d0-2.4778d0*x
+ Qmu=80.0d0
+ Qkappa=57827.0d0
+
+ else
+ if(CRUSTAL) then
+! fill with PREM mantle and later add CRUST2.0
+ if(r > R80) then
+ rho=2.6910d0+0.6924d0*x
+ vpv=0.8317d0+7.2180d0*x
+ vph=3.5908d0+4.6172d0*x
+ vsv=5.8582d0-1.4678d0*x
+ vsh=-1.0839d0+5.7176d0*x
+ eta_aniso=3.3687d0-2.4778d0*x
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+ else
+! use PREM crust
+ if(r > R80 .and. r <= RMOHO) then
+
+! anisotropy in PREM only above 220 km
+
+ rho=2.6910d0+0.6924d0*x
+ vpv=0.8317d0+7.2180d0*x
+ vph=3.5908d0+4.6172d0*x
+ vsv=5.8582d0-1.4678d0*x
+ vsh=-1.0839d0+5.7176d0*x
+ eta_aniso=3.3687d0-2.4778d0*x
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+! no anisotropy in the crust in PREM
+
+ else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
+ rho=2.9d0
+ vpv=6.8d0
+ vsv=3.9d0
+ vph=vpv
+ vsh=vsv
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+
+! same properties everywhere in PREM crust (only one layer in the crust)
+ if(ONE_CRUST) then
+ rho=2.6d0
+ vpv=5.8d0
+ vsv=3.2d0
+ vph=vpv
+ vsh=vsv
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+
+ else if(r > RMIDDLE_CRUST .and. r <= ROCEAN) then
+ rho=2.6d0
+ vpv=5.8d0
+ vsv=3.2d0
+ vph=vpv
+ vsh=vsv
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ else if(r > ROCEAN) then
+ rho=2.6d0
+ vpv=5.8d0
+ vsv=3.2d0
+ vph=vpv
+ vsh=vsv
+ Qmu=600.0d0
+ Qkappa=57827.0d0
+ endif
+ endif
+ endif
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+! do not scale anisotropy parameter eta_aniso, which is dimensionless
+ scaleval=dsqrt(PI*GRAV*RHOAV)
+ rho=rho*1000.0d0/RHOAV
+ vpv=vpv*1000.0d0/(R_EARTH*scaleval)
+ vsv=vsv*1000.0d0/(R_EARTH*scaleval)
+ vph=vph*1000.0d0/(R_EARTH*scaleval)
+ vsh=vsh*1000.0d0/(R_EARTH*scaleval)
+
+ end subroutine prem_aniso
+
+!
+!=====================================================================
+!
+
+ subroutine prem_display_outer_core(myrank,x,rho,vp,vs,Qkappa,Qmu,idoubling)
+
+! routine used for AVS or DX display of stability condition
+! and number of points per wavelength only in the fluid outer core
+
+ implicit none
+
+ include "constants.h"
+
+! given a normalized radius x, gives the non-dimesionalized density rho,
+! speeds vp and vs, and the quality factors Qkappa and Qmu
+
+ integer idoubling,myrank
+ double precision x,rho,vp,vs,Qkappa,Qmu
+
+ double precision scaleval
+
+ if(idoubling /= IFLAG_OUTER_CORE_NORMAL) call exit_MPI(myrank,'wrong doubling flag for outer core point')
+
+!
+!--- outer core
+!
+ rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
+ vp=11.0487d0-4.0362d0*x+4.8023d0*x*x-13.5732d0*x*x*x
+ vs=0.0d0
+ Qmu=0.0d0
+ Qkappa=57827.0d0
+
+! non-dimensionalize
+! time scaling (s^{-1}) is done with scaleval
+ scaleval = dsqrt(PI*GRAV*RHOAV)
+ rho = rho*1000.0d0/RHOAV
+ vp = vp*1000.0d0/(R_EARTH*scaleval)
+ vs = vs*1000.0d0/(R_EARTH*scaleval)
+
+ end subroutine prem_display_outer_core
+
+!
+!=====================================================================
+!
+
+ subroutine prem_density(x,rho,ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision x,rho,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
+
+ logical ONE_CRUST
+
+ double precision r
+
+ r = x * R_EARTH
+
+ if(r <= RICB) then
+ rho=13.0885d0-8.8381d0*x*x
+ else if(r > RICB .and. r <= RCMB) then
+ rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
+ else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ else if(r > R771 .and. r <= R670) then
+ rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
+ else if(r > R670 .and. r <= R600) then
+ rho=5.3197d0-1.4836d0*x
+ else if(r > R600 .and. r <= R400) then
+ rho=11.2494d0-8.0298d0*x
+ else if(r > R400 .and. r <= R220) then
+ rho=7.1089d0-3.8045d0*x
+ else if(r > R220 .and. r <= R80) then
+ rho=2.6910d0+0.6924d0*x
+ else
+ if(r > R80 .and. r <= RMOHO) then
+ rho=2.6910d0+0.6924d0*x
+ else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
+ if(ONE_CRUST) then
+ rho=2.6d0
+ else
+ rho=2.9d0
+ endif
+ else if(r > RMIDDLE_CRUST .and. r <= ROCEAN) then
+ rho=2.6d0
+ else if(r > ROCEAN) then
+ rho=2.6d0
+ endif
+ endif
+
+ rho=rho*1000.0d0/RHOAV
+
+ end subroutine prem_density
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_ref.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_ref.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_ref.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/model_sea1d.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_sea1d.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/model_sea1d.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/moho_stretching.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/moho_stretching.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/moho_stretching.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/mpif.h
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/mpif.h (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/mpif.h 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,265 @@
+! mpif.h. Generated from /opt/mpich/myrinet/intel//include/mpif.h by configure.
+
+!
+!
+! (C) 1993 by Argonne National Laboratory and Mississipi State University.
+! All rights reserved. See COPYRIGHT in top-level directory.
+!
+!
+! user include file for MPI programs, with no dependencies
+!
+! It really is not possible to make a perfect include file that can
+! be used by both F77 and F90 compilers, but this is close. We have removed
+! continuation lines (allows free form input in F90); systems whose
+! Fortran compilers support ! instead of just C or * for comments can
+! globally replace a C in the first column with !; the resulting file
+! should work for both Fortran 77 and Fortran 90.
+!
+! If your Fortran compiler supports ! for comments, you can run this
+! through sed with
+! sed -e 's/^C/\!/g'
+!
+! We have also removed the use of contractions (involving the single quote)
+! character because some users use .F instead of .f files (to invoke the
+! cpp preprocessor) and further, their preprocessor is determined to find
+! matching single quote pairs (and probably double quotes; given the
+! different rules in C and Fortran, this sounds like a disaster). Rather than
+! take the position that the poor users should get a better system, we
+! have removed the text that caused problems. Of course, the users SHOULD
+! get a better system...
+!
+! return codes
+ INTEGER MPI_SUCCESS,MPI_ERR_BUFFER,MPI_ERR_COUNT,MPI_ERR_TYPE
+ INTEGER MPI_ERR_TAG,MPI_ERR_COMM,MPI_ERR_RANK,MPI_ERR_ROOT
+ INTEGER MPI_ERR_GROUP
+ INTEGER MPI_ERR_OP,MPI_ERR_TOPOLOGY,MPI_ERR_DIMS,MPI_ERR_ARG
+ INTEGER MPI_ERR_UNKNOWN,MPI_ERR_TRUNCATE,MPI_ERR_OTHER
+ INTEGER MPI_ERR_INTERN,MPI_ERR_IN_STATUS,MPI_ERR_PENDING
+ INTEGER MPI_ERR_REQUEST, MPI_ERR_LASTCODE
+ PARAMETER (MPI_SUCCESS=0,MPI_ERR_BUFFER=1,MPI_ERR_COUNT=2)
+ PARAMETER (MPI_ERR_TYPE=3,MPI_ERR_TAG=4,MPI_ERR_COMM=5)
+ PARAMETER (MPI_ERR_RANK=6,MPI_ERR_ROOT=7,MPI_ERR_GROUP=8)
+ PARAMETER (MPI_ERR_OP=9,MPI_ERR_TOPOLOGY=10,MPI_ERR_DIMS=11)
+ PARAMETER (MPI_ERR_ARG=12,MPI_ERR_UNKNOWN=13)
+ PARAMETER (MPI_ERR_TRUNCATE=14,MPI_ERR_OTHER=15)
+ PARAMETER (MPI_ERR_INTERN=16,MPI_ERR_IN_STATUS=17)
+ PARAMETER (MPI_ERR_PENDING=18,MPI_ERR_REQUEST=19)
+ PARAMETER (MPI_ERR_LASTCODE=1073741823)
+!
+ INTEGER MPI_UNDEFINED
+ parameter (MPI_UNDEFINED = (-32766))
+!
+ INTEGER MPI_GRAPH, MPI_CART
+ PARAMETER (MPI_GRAPH = 1, MPI_CART = 2)
+ INTEGER MPI_PROC_NULL
+ PARAMETER ( MPI_PROC_NULL = (-1) )
+!
+ INTEGER MPI_BSEND_OVERHEAD
+ PARAMETER ( MPI_BSEND_OVERHEAD = 512 )
+
+ INTEGER MPI_SOURCE, MPI_TAG, MPI_ERROR
+ PARAMETER(MPI_SOURCE=2, MPI_TAG=3, MPI_ERROR=4)
+ INTEGER MPI_STATUS_SIZE
+ PARAMETER (MPI_STATUS_SIZE=4)
+ INTEGER MPI_MAX_PROCESSOR_NAME, MPI_MAX_ERROR_STRING
+ PARAMETER (MPI_MAX_PROCESSOR_NAME=256)
+ PARAMETER (MPI_MAX_ERROR_STRING=512)
+ INTEGER MPI_MAX_NAME_STRING
+ PARAMETER (MPI_MAX_NAME_STRING=63)
+ INTEGER MPI_MAX_PORT_NAME
+ PARAMETER (MPI_MAX_PORT_NAME=256)
+!
+ INTEGER MPI_COMM_NULL
+ PARAMETER (MPI_COMM_NULL=0)
+!
+ INTEGER MPI_DATATYPE_NULL
+ PARAMETER (MPI_DATATYPE_NULL = 0)
+
+ INTEGER MPI_ERRHANDLER_NULL
+ PARAMETER (MPI_ERRHANDLER_NULL = 0)
+
+ INTEGER MPI_GROUP_NULL
+ PARAMETER (MPI_GROUP_NULL = 0)
+
+ INTEGER MPI_KEYVAL_INVALID
+ PARAMETER (MPI_KEYVAL_INVALID = 0)
+
+ INTEGER MPI_REQUEST_NULL
+ PARAMETER (MPI_REQUEST_NULL = 0)
+!
+ INTEGER MPI_IDENT, MPI_CONGRUENT, MPI_SIMILAR, MPI_UNEQUAL
+ PARAMETER (MPI_IDENT=0, MPI_CONGRUENT=1, MPI_SIMILAR=2)
+ PARAMETER (MPI_UNEQUAL=3)
+!
+! MPI_BOTTOM needs to be a known address; here we put it at the
+! beginning of the common block. The point-to-point and collective
+! routines know about MPI_BOTTOM, but MPI_TYPE_STRUCT as yet does not.
+!
+! MPI_STATUS_IGNORE and MPI_STATUSES_IGNORE are similar objects
+! Until the underlying MPI library implements the C version of these
+! (a null pointer), these are declared as arrays of MPI_STATUS_SIZE
+!
+! The types MPI_INTEGER1,2,4 and MPI_REAL4,8 are OPTIONAL.
+! Their values are zero if they are not available. Note that
+! using these reduces the portability of code (though may enhance
+! portability between Crays and other systems)
+!
+ INTEGER MPI_TAG_UB, MPI_HOST, MPI_IO
+ INTEGER MPI_BOTTOM
+ INTEGER MPI_STATUS_IGNORE(MPI_STATUS_SIZE)
+ INTEGER MPI_STATUSES_IGNORE(MPI_STATUS_SIZE)
+ INTEGER MPI_INTEGER, MPI_REAL, MPI_DOUBLE_PRECISION
+ INTEGER MPI_COMPLEX, MPI_DOUBLE_COMPLEX,MPI_LOGICAL
+ INTEGER MPI_CHARACTER, MPI_BYTE, MPI_2INTEGER, MPI_2REAL
+ INTEGER MPI_2DOUBLE_PRECISION, MPI_2COMPLEX, MPI_2DOUBLE_COMPLEX
+ INTEGER MPI_UB, MPI_LB
+ INTEGER MPI_PACKED, MPI_WTIME_IS_GLOBAL
+ INTEGER MPI_COMM_WORLD, MPI_COMM_SELF, MPI_GROUP_EMPTY
+ INTEGER MPI_SUM, MPI_MAX, MPI_MIN, MPI_PROD, MPI_LAND, MPI_BAND
+ INTEGER MPI_LOR, MPI_BOR, MPI_LXOR, MPI_BXOR, MPI_MINLOC
+ INTEGER MPI_MAXLOC
+ INTEGER MPI_OP_NULL
+ INTEGER MPI_ERRORS_ARE_FATAL, MPI_ERRORS_RETURN
+!
+ PARAMETER (MPI_ERRORS_ARE_FATAL=119)
+ PARAMETER (MPI_ERRORS_RETURN=120)
+!
+ PARAMETER (MPI_COMPLEX=23,MPI_DOUBLE_COMPLEX=24,MPI_LOGICAL=25)
+ PARAMETER (MPI_REAL=26,MPI_DOUBLE_PRECISION=27,MPI_INTEGER=28)
+ PARAMETER (MPI_2INTEGER=29,MPI_2COMPLEX=30,MPI_2DOUBLE_COMPLEX=31)
+ PARAMETER (MPI_2REAL=32,MPI_2DOUBLE_PRECISION=33,MPI_CHARACTER=1)
+ PARAMETER (MPI_BYTE=3,MPI_UB=16,MPI_LB=15,MPI_PACKED=14)
+
+ INTEGER MPI_ORDER_C, MPI_ORDER_FORTRAN
+ PARAMETER (MPI_ORDER_C=56, MPI_ORDER_FORTRAN=57)
+ INTEGER MPI_DISTRIBUTE_BLOCK, MPI_DISTRIBUTE_CYCLIC
+ INTEGER MPI_DISTRIBUTE_NONE, MPI_DISTRIBUTE_DFLT_DARG
+ PARAMETER (MPI_DISTRIBUTE_BLOCK=121, MPI_DISTRIBUTE_CYCLIC=122)
+ PARAMETER (MPI_DISTRIBUTE_NONE=123)
+ PARAMETER (MPI_DISTRIBUTE_DFLT_DARG=-49767)
+ INTEGER MPI_MAX_INFO_KEY, MPI_MAX_INFO_VAL
+ PARAMETER (MPI_MAX_INFO_KEY=255, MPI_MAX_INFO_VAL=1024)
+ INTEGER MPI_INFO_NULL
+ PARAMETER (MPI_INFO_NULL=0)
+
+!
+! Optional Fortran Types. Configure attempts to determine these.
+!
+ INTEGER MPI_INTEGER1, MPI_INTEGER2, MPI_INTEGER4, MPI_INTEGER8
+ INTEGER MPI_INTEGER16
+ INTEGER MPI_REAL4, MPI_REAL8, MPI_REAL16
+ INTEGER MPI_COMPLEX8, MPI_COMPLEX16, MPI_COMPLEX32
+ PARAMETER (MPI_INTEGER1=1,MPI_INTEGER2=4)
+ PARAMETER (MPI_INTEGER4=6)
+ PARAMETER (MPI_INTEGER8=8)
+ PARAMETER (MPI_INTEGER16=0)
+ PARAMETER (MPI_REAL4=10)
+ PARAMETER (MPI_REAL8=11)
+ PARAMETER (MPI_REAL16=12)
+ PARAMETER (MPI_COMPLEX8=23)
+ PARAMETER (MPI_COMPLEX16=24)
+ PARAMETER (MPI_COMPLEX32=0)
+!
+! This is now handled with either the "pointer" extension or this same
+! code, appended at the end.
+! COMMON /MPIPRIV/ MPI_BOTTOM,MPI_STATUS_IGNORE,MPI_STATUSES_IGNORE
+!C
+!C Without this save, some Fortran implementations may make the common
+!C dynamic!
+!C
+!C For a Fortran90 module, we might replace /MPIPRIV/ with a simple
+!C SAVE MPI_BOTTOM
+!C
+! SAVE /MPIPRIV/
+!
+ PARAMETER (MPI_MAX=100,MPI_MIN=101,MPI_SUM=102,MPI_PROD=103)
+ PARAMETER (MPI_LAND=104,MPI_BAND=105,MPI_LOR=106,MPI_BOR=107)
+ PARAMETER (MPI_LXOR=108,MPI_BXOR=109,MPI_MINLOC=110)
+ PARAMETER (MPI_MAXLOC=111, MPI_OP_NULL=0)
+!
+ PARAMETER (MPI_GROUP_EMPTY=90,MPI_COMM_WORLD=91,MPI_COMM_SELF=92)
+ PARAMETER (MPI_TAG_UB=80,MPI_HOST=82,MPI_IO=84)
+ PARAMETER (MPI_WTIME_IS_GLOBAL=86)
+!
+ INTEGER MPI_ANY_SOURCE
+ PARAMETER (MPI_ANY_SOURCE = (-2))
+ INTEGER MPI_ANY_TAG
+ PARAMETER (MPI_ANY_TAG = (-1))
+!
+ INTEGER MPI_VERSION, MPI_SUBVERSION
+ PARAMETER (MPI_VERSION = 1, MPI_SUBVERSION = 2)
+!
+! There are additional MPI-2 constants
+ INTEGER MPI_ADDRESS_KIND, MPI_OFFSET_KIND
+ PARAMETER (MPI_ADDRESS_KIND=8)
+ PARAMETER (MPI_OFFSET_KIND=8)
+!
+! All other MPI routines are subroutines
+! This may cause some Fortran compilers to complain about defined and
+! not used. Such compilers should be improved.
+!
+! Some Fortran compilers will not link programs that contain
+! external statements to routines that are not provided, even if
+! the routine is never called. Remove PMPI_WTIME and PMPI_WTICK
+! if you have trouble with them.
+!
+ DOUBLE PRECISION MPI_WTIME, MPI_WTICK,PMPI_WTIME,PMPI_WTICK
+ EXTERNAL MPI_WTIME, MPI_WTICK,PMPI_WTIME,PMPI_WTICK
+!
+! The attribute copy/delete subroutines are symbols that can be passed
+! to MPI routines
+!
+ EXTERNAL MPI_NULL_COPY_FN, MPI_NULL_DELETE_FN, MPI_DUP_FN
+ COMMON /MPIPRIV/ MPI_BOTTOM,MPI_STATUS_IGNORE,MPI_STATUSES_IGNORE
+!
+! Without this save, some Fortran implementations may make the common
+! dynamic!
+!
+! For a Fortran90 module, we might replace /MPIPRIV/ with a simple
+! SAVE MPI_BOTTOM
+!
+ SAVE /MPIPRIV/
+!
+! $Id: mpiof.h.in,v 1.3 1999/08/06 18:33:09 thakur Exp $
+!
+! Copyright (C) 1997 University of Chicago.
+! See COPYRIGHT notice in top-level directory.
+!
+!
+! user include file for Fortran MPI-IO programs
+!
+ INTEGER MPI_MODE_RDONLY, MPI_MODE_RDWR, MPI_MODE_WRONLY
+ INTEGER MPI_MODE_DELETE_ON_CLOSE, MPI_MODE_UNIQUE_OPEN
+ INTEGER MPI_MODE_CREATE, MPI_MODE_EXCL
+ INTEGER MPI_MODE_APPEND, MPI_MODE_SEQUENTIAL
+ PARAMETER (MPI_MODE_RDONLY=2, MPI_MODE_RDWR=8, MPI_MODE_WRONLY=4)
+ PARAMETER (MPI_MODE_CREATE=1, MPI_MODE_DELETE_ON_CLOSE=16)
+ PARAMETER (MPI_MODE_UNIQUE_OPEN=32, MPI_MODE_EXCL=64)
+ PARAMETER (MPI_MODE_APPEND=128, MPI_MODE_SEQUENTIAL=256)
+!
+ INTEGER MPI_FILE_NULL
+ PARAMETER (MPI_FILE_NULL=0)
+!
+ INTEGER MPI_MAX_DATAREP_STRING
+ PARAMETER (MPI_MAX_DATAREP_STRING=128)
+!
+ INTEGER MPI_SEEK_SET, MPI_SEEK_CUR, MPI_SEEK_END
+ PARAMETER (MPI_SEEK_SET=600, MPI_SEEK_CUR=602, MPI_SEEK_END=604)
+!
+ INTEGER MPIO_REQUEST_NULL
+ PARAMETER (MPIO_REQUEST_NULL=0)
+!
+!
+!
+
+
+
+
+
+
+
+!
+!
+!
+!
+!
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/netlib_specfun_erf.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/netlib_specfun_erf.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/netlib_specfun_erf.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/precision.h
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/precision.h (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/precision.h 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/read_compute_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/read_compute_parameters.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/read_compute_parameters.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,2440 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License 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_VOLUME_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_VOLUME_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
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+ call open_parameter_file
+
+ call read_value_integer(SIMULATION_TYPE, 'solver.SIMULATION_TYPE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(SAVE_FORWARD, 'solver.SAVE_FORWARD')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+ call read_value_integer(NCHUNKS, 'mesher.NCHUNKS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ if(NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) &
+ stop 'NCHUNKS must be either 1, 2, 3 or 6'
+
+ call read_value_double_precision(ANGULAR_WIDTH_XI_IN_DEGREES, 'mesher.ANGULAR_WIDTH_XI_IN_DEGREES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(ANGULAR_WIDTH_ETA_IN_DEGREES, 'mesher.ANGULAR_WIDTH_ETA_IN_DEGREES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(CENTER_LATITUDE_IN_DEGREES, 'mesher.CENTER_LATITUDE_IN_DEGREES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(CENTER_LONGITUDE_IN_DEGREES, 'mesher.CENTER_LONGITUDE_IN_DEGREES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(GAMMA_ROTATION_AZIMUTH, 'mesher.GAMMA_ROTATION_AZIMUTH')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+! this MUST be 90 degrees for two chunks or more to match geometrically
+ if(NCHUNKS > 1 .and. abs(ANGULAR_WIDTH_XI_IN_DEGREES - 90.d0) > 0.00000001d0) &
+ stop 'ANGULAR_WIDTH_XI_IN_DEGREES must be 90 for more than one chunk'
+
+! this can be any value in the case of two chunks
+ if(NCHUNKS > 2 .and. abs(ANGULAR_WIDTH_ETA_IN_DEGREES - 90.d0) > 0.00000001d0) &
+ stop 'ANGULAR_WIDTH_ETA_IN_DEGREES must be 90 for more than two chunks'
+
+! include central cube or not
+! use regular cubed sphere instead of cube for large distances
+ if(NCHUNKS == 6) then
+ INCLUDE_CENTRAL_CUBE = .true.
+ INFLATE_CENTRAL_CUBE = .false.
+ else
+ INCLUDE_CENTRAL_CUBE = .false.
+ INFLATE_CENTRAL_CUBE = .true.
+ endif
+
+! number of elements at the surface along the two sides of the first chunk
+ call read_value_integer(NEX_XI_read, 'mesher.NEX_XI')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NEX_ETA_read, 'mesher.NEX_ETA')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NPROC_XI_read, 'mesher.NPROC_XI')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NPROC_ETA_read, 'mesher.NPROC_ETA')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+ if(.not. EMULATE_ONLY) then
+ NEX_XI = NEX_XI_read
+ NEX_ETA = NEX_ETA_read
+ NPROC_XI = NPROC_XI_read
+ NPROC_ETA = NPROC_ETA_read
+ else
+! this is used in UTILS/estimate_best_values_runs.f90 only, to estimate memory use
+ NEX_ETA = NEX_XI
+ NPROC_ETA = NPROC_XI
+ endif
+
+! define the velocity model
+ call read_value_string(MODEL, 'model.name')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+! use PREM as the 1D reference model by default
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM
+
+! HONOR_1D_SPHERICAL_MOHO: honor PREM Moho or not: doing so drastically reduces
+! the stability condition and therefore the time step, resulting in expensive
+! calculations. If not, honor a fictitious Moho at the depth of 40 km
+! in order to have even radial sampling from the d220 to the Earth surface.
+
+! ONE_CRUST: in order to increase stability and therefore to allow cheaper
+! simulations (larger time step), 1D models can be run with just one average crustal
+! layer instead of two.
+
+! CASE_3D : this flag allows the stretching of the elements in the crustal
+! layers in the case of 3D models. The purpose of this stretching is to squeeze more
+! GLL points per km in the upper part of the crust than in the lower part.
+ HONOR_1D_SPHERICAL_MOHO = .false.
+ ONE_CRUST = .false.
+ CASE_3D = .false.
+
+! default is no 3D model
+ THREE_D_MODEL = 0
+
+ if(MODEL == '1D_isotropic_prem') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+
+ else if(MODEL == '1D_transversely_isotropic_prem') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+
+ else if(MODEL == '1D_iasp91' .or. MODEL == '1D_1066a' .or. &
+ MODEL == '1D_ak135' .or. MODEL == '1D_jp3d' .or. &
+ MODEL == '1D_sea99') then
+ if(MODEL == '1D_iasp91') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_IASP91
+ else if(MODEL == '1D_1066a') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1066A
+ else if(MODEL == '1D_ak135') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_AK135
+ else if(MODEL == '1D_jp3d') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_JP1D
+ else if(MODEL == '1D_sea99') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
+ else
+ stop 'reference 1D Earth model unknown'
+ endif
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+
+ else if(MODEL == '1D_ref') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+
+ else if(MODEL == '1D_ref_iso') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+
+ else if(MODEL == '1D_isotropic_prem_onecrust') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ ONE_CRUST = .true.
+
+ else if(MODEL == '1D_transversely_isotropic_prem_onecrust') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ ONE_CRUST = .true.
+
+ else if(MODEL == '1D_iasp91_onecrust' .or. MODEL == '1D_1066a_onecrust' .or. MODEL == '1D_ak135_onecrust') then
+ if(MODEL == '1D_iasp91_onecrust') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_IASP91
+ else if(MODEL == '1D_1066a_onecrust') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_1066A
+ else if(MODEL == '1D_ak135_onecrust') then
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_AK135
+ else
+ stop 'reference 1D Earth model unknown'
+ endif
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ HONOR_1D_SPHERICAL_MOHO = .true.
+ ONE_CRUST = .true.
+
+ else if(MODEL == 'transversely_isotropic_prem_plus_3D_crust_2.0') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+
+ else if(MODEL == 's20rts') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM
+ THREE_D_MODEL = THREE_D_MODEL_S20RTS
+
+ else if(MODEL == 'sea99_jp3d1994') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
+ THREE_D_MODEL = THREE_D_MODEL_SEA99_JP3D
+
+ else if(MODEL == 'sea99') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_SEA1D
+ THREE_D_MODEL = THREE_D_MODEL_SEA99
+
+
+ else if(MODEL == 'jp3d1994') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_JP1D
+ THREE_D_MODEL = THREE_D_MODEL_JP3D
+
+ else if(MODEL == 's362ani') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+ THREE_D_MODEL = THREE_D_MODEL_S362ANI
+
+ else if(MODEL == 's362iso') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+ THREE_D_MODEL = THREE_D_MODEL_S362ANI
+
+ else if(MODEL == 's362wmani') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+ THREE_D_MODEL = THREE_D_MODEL_S362WMANI
+
+ else if(MODEL == 's362ani_prem') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_PREM
+ THREE_D_MODEL = THREE_D_MODEL_S362ANI_PREM
+
+ else if(MODEL == 's29ea') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .true.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+ REFERENCE_1D_MODEL = REFERENCE_MODEL_REF
+ THREE_D_MODEL = THREE_D_MODEL_S29EA
+
+ else if(MODEL == '3D_attenuation') then
+ TRANSVERSE_ISOTROPY = .false.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .true.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+
+ else if(MODEL == '3D_anisotropic') then
+ TRANSVERSE_ISOTROPY = .true.
+ ISOTROPIC_3D_MANTLE = .false.
+ ANISOTROPIC_3D_MANTLE = .true.
+ ANISOTROPIC_INNER_CORE = .false.
+ CRUSTAL = .false.
+ ATTENUATION_3D = .false.
+ ONE_CRUST = .true.
+ CASE_3D = .true.
+
+ else
+ stop 'model not implemented, edit read_compute_parameters.f90 and recompile'
+ endif
+
+! set time step, radial distribution of elements, and attenuation period range
+! right distribution is determined based upon maximum value of NEX
+ NEX_MAX = max(NEX_XI,NEX_ETA)
+
+!----
+!---- case prem_onecrust by default
+!----
+ if (SUPPRESS_CRUSTAL_MESH) then
+ multiplication_factor=2
+ else
+ multiplication_factor=1
+ endif
+
+ ! element width = 0.5625000 degrees = 62.54715 km
+ if(NEX_MAX*multiplication_factor <= 160) then
+ DT = 0.252d0
+
+ MIN_ATTENUATION_PERIOD = 30
+ MAX_ATTENUATION_PERIOD = 1500
+
+ NER_CRUST = 1
+ NER_80_MOHO = 1
+ NER_220_80 = 2
+ NER_400_220 = 2
+ NER_600_400 = 2
+ NER_670_600 = 1
+ NER_771_670 = 1
+ NER_TOPDDOUBLEPRIME_771 = 15
+ NER_CMB_TOPDDOUBLEPRIME = 1
+ NER_OUTER_CORE = 16
+ NER_TOP_CENTRAL_CUBE_ICB = 2
+ R_CENTRAL_CUBE = 950000.d0
+
+ ! element width = 0.3515625 degrees = 39.09196 km
+ else if(NEX_MAX*multiplication_factor <= 256) then
+ DT = 0.225d0
+
+ MIN_ATTENUATION_PERIOD = 20
+ MAX_ATTENUATION_PERIOD = 1000
+
+ NER_CRUST = 1
+ NER_80_MOHO = 1
+ NER_220_80 = 2
+ NER_400_220 = 3
+ NER_600_400 = 3
+ NER_670_600 = 1
+ NER_771_670 = 1
+ NER_TOPDDOUBLEPRIME_771 = 22
+ NER_CMB_TOPDDOUBLEPRIME = 2
+ NER_OUTER_CORE = 24
+ NER_TOP_CENTRAL_CUBE_ICB = 3
+ R_CENTRAL_CUBE = 965000.d0
+
+ ! element width = 0.2812500 degrees = 31.27357 km
+ else if(NEX_MAX*multiplication_factor <= 320) then
+ DT = 0.16d0
+
+ MIN_ATTENUATION_PERIOD = 15
+ MAX_ATTENUATION_PERIOD = 750
+
+ NER_CRUST = 1
+ NER_80_MOHO = 1
+ NER_220_80 = 3
+ NER_400_220 = 4
+ NER_600_400 = 4
+ NER_670_600 = 1
+ NER_771_670 = 2
+ NER_TOPDDOUBLEPRIME_771 = 29
+ NER_CMB_TOPDDOUBLEPRIME = 2
+ NER_OUTER_CORE = 32
+ NER_TOP_CENTRAL_CUBE_ICB = 4
+ R_CENTRAL_CUBE = 940000.d0
+
+ ! element width = 0.1875000 degrees = 20.84905 km
+ else if(NEX_MAX*multiplication_factor <= 480) then
+ DT = 0.11d0
+
+ MIN_ATTENUATION_PERIOD = 10
+ MAX_ATTENUATION_PERIOD = 500
+
+ NER_CRUST = 1
+ NER_80_MOHO = 2
+ NER_220_80 = 4
+ NER_400_220 = 5
+ NER_600_400 = 6
+ NER_670_600 = 2
+ NER_771_670 = 2
+ NER_TOPDDOUBLEPRIME_771 = 44
+ NER_CMB_TOPDDOUBLEPRIME = 3
+ NER_OUTER_CORE = 48
+ NER_TOP_CENTRAL_CUBE_ICB = 5
+ R_CENTRAL_CUBE = 988000.d0
+
+ ! element width = 0.1757812 degrees = 19.54598 km
+ else if(NEX_MAX*multiplication_factor <= 512) then
+ DT = 0.1125d0
+
+ MIN_ATTENUATION_PERIOD = 9
+ MAX_ATTENUATION_PERIOD = 500
+
+ NER_CRUST = 1
+ NER_80_MOHO = 2
+ NER_220_80 = 4
+ NER_400_220 = 6
+ NER_600_400 = 6
+ NER_670_600 = 2
+ NER_771_670 = 3
+ NER_TOPDDOUBLEPRIME_771 = 47
+ NER_CMB_TOPDDOUBLEPRIME = 3
+ NER_OUTER_CORE = 51
+ NER_TOP_CENTRAL_CUBE_ICB = 5
+ R_CENTRAL_CUBE = 1010000.d0
+
+ ! element width = 0.1406250 degrees = 15.63679 km
+ else if(NEX_MAX*multiplication_factor <= 640) then
+ DT = 0.09d0
+
+ MIN_ATTENUATION_PERIOD = 8
+ MAX_ATTENUATION_PERIOD = 400
+
+ NER_CRUST = 2
+ NER_80_MOHO = 3
+ NER_220_80 = 5
+ NER_400_220 = 7
+ NER_600_400 = 8
+ NER_670_600 = 3
+ NER_771_670 = 3
+ NER_TOPDDOUBLEPRIME_771 = 59
+ NER_CMB_TOPDDOUBLEPRIME = 4
+ NER_OUTER_CORE = 64
+ NER_TOP_CENTRAL_CUBE_ICB = 6
+ R_CENTRAL_CUBE = 1020000.d0
+
+ ! element width = 0.1041667 degrees = 11.58280 km
+ else if(NEX_MAX*multiplication_factor <= 864) then
+ DT = 0.0667d0
+
+ MIN_ATTENUATION_PERIOD = 6
+ MAX_ATTENUATION_PERIOD = 300
+
+ NER_CRUST = 2
+ NER_80_MOHO = 4
+ NER_220_80 = 6
+ NER_400_220 = 10
+ NER_600_400 = 10
+ NER_670_600 = 3
+ NER_771_670 = 4
+ NER_TOPDDOUBLEPRIME_771 = 79
+ NER_CMB_TOPDDOUBLEPRIME = 5
+ NER_OUTER_CORE = 86
+ NER_TOP_CENTRAL_CUBE_ICB = 9
+ R_CENTRAL_CUBE = 990000.d0
+
+ ! element width = 7.8125000E-02 degrees = 8.687103 km
+ else if(NEX_MAX*multiplication_factor <= 1152) then
+ DT = 0.05d0
+
+ MIN_ATTENUATION_PERIOD = 4
+ MAX_ATTENUATION_PERIOD = 200
+
+ NER_CRUST = 3
+ NER_80_MOHO = 6
+ NER_220_80 = 8
+ NER_400_220 = 13
+ NER_600_400 = 13
+ NER_670_600 = 4
+ NER_771_670 = 6
+ NER_TOPDDOUBLEPRIME_771 = 106
+ NER_CMB_TOPDDOUBLEPRIME = 7
+ NER_OUTER_CORE = 116
+ NER_TOP_CENTRAL_CUBE_ICB = 12
+ R_CENTRAL_CUBE = 985000.d0
+
+ ! element width = 7.2115384E-02 degrees = 8.018865 km
+ else if(NEX_MAX*multiplication_factor <= 1248) then
+ DT = 0.0462d0
+
+ MIN_ATTENUATION_PERIOD = 4
+ MAX_ATTENUATION_PERIOD = 200
+
+ NER_CRUST = 3
+ NER_80_MOHO = 6
+ NER_220_80 = 9
+ NER_400_220 = 14
+ NER_600_400 = 14
+ NER_670_600 = 5
+ NER_771_670 = 6
+ NER_TOPDDOUBLEPRIME_771 = 114
+ NER_CMB_TOPDDOUBLEPRIME = 8
+ NER_OUTER_CORE = 124
+ NER_TOP_CENTRAL_CUBE_ICB = 13
+ R_CENTRAL_CUBE = 985000.d0
+
+ else
+
+! scale with respect to 1248 if above that limit
+ DT = 0.0462d0 * 1248.d0 / (2.d0*NEX_MAX)
+
+ MIN_ATTENUATION_PERIOD = 4
+ MAX_ATTENUATION_PERIOD = 200
+
+ NER_CRUST = nint(3 * 2.d0*NEX_MAX / 1248.d0)
+ NER_80_MOHO = nint(6 * 2.d0*NEX_MAX / 1248.d0)
+ NER_220_80 = nint(9 * 2.d0*NEX_MAX / 1248.d0)
+ NER_400_220 = nint(14 * 2.d0*NEX_MAX / 1248.d0)
+ NER_600_400 = nint(14 * 2.d0*NEX_MAX / 1248.d0)
+ NER_670_600 = nint(5 * 2.d0*NEX_MAX / 1248.d0)
+ NER_771_670 = nint(6 * 2.d0*NEX_MAX / 1248.d0)
+ NER_TOPDDOUBLEPRIME_771 = nint(114 * 2.d0*NEX_MAX / 1248.d0)
+ NER_CMB_TOPDDOUBLEPRIME = nint(8 * 2.d0*NEX_MAX / 1248.d0)
+ NER_OUTER_CORE = nint(124 * 2.d0*NEX_MAX / 1248.d0)
+ NER_TOP_CENTRAL_CUBE_ICB = nint(13 * 2.d0*NEX_MAX / 1248.d0)
+ R_CENTRAL_CUBE = 985000.d0
+
+!! removed this limit else
+!! removed this limit stop 'problem with this value of NEX_MAX'
+ endif
+
+!----
+!---- change some values in the case of regular PREM with two crustal layers or of 3D models
+!----
+
+! case of regular PREM with two crustal layers: change the time step for small meshes
+! because of a different size of elements in the radial direction in the crust
+ if (HONOR_1D_SPHERICAL_MOHO) then
+ if (.not. ONE_CRUST) then
+ ! case 1D + two crustal layers
+ if (NER_CRUST<2) NER_CRUST=2
+ if(NEX_MAX*multiplication_factor <= 160) then
+ DT = 0.20d0
+ else if(NEX_MAX*multiplication_factor <= 256) then
+ DT = 0.20d0
+ endif
+ endif
+ else
+ ! case 3D
+ if (NER_CRUST<2) NER_CRUST=2
+ if(NEX_MAX*multiplication_factor <= 160) then
+ DT = 0.15d0
+ else if(NEX_MAX*multiplication_factor <= 256) then
+ DT = 0.17d0
+ else if(NEX_MAX*multiplication_factor <= 320) then
+ DT = 0.155d0
+ endif
+ endif
+
+ if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
+ DT = DT*0.20d0
+ endif
+
+
+ if( .not. ATTENUATION_RANGE_PREDEFINED ) then
+ call auto_attenuation_periods(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
+ MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD)
+ endif
+
+ if(ANGULAR_WIDTH_XI_IN_DEGREES < 90.0d0 .or. &
+ ANGULAR_WIDTH_ETA_IN_DEGREES < 90.0d0 .or. &
+ NEX_MAX > 1248) then
+
+ call auto_ner(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
+ NER_CRUST, NER_80_MOHO, NER_220_80, NER_400_220, NER_600_400, &
+ NER_670_600, NER_771_670, NER_TOPDDOUBLEPRIME_771, &
+ NER_CMB_TOPDDOUBLEPRIME, NER_OUTER_CORE, NER_TOP_CENTRAL_CUBE_ICB, &
+ R_CENTRAL_CUBE, CASE_3D)
+
+ call auto_attenuation_periods(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
+ MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD)
+
+ call auto_time_stepping(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, DT)
+
+!! DK DK suppressed because this routine should not write anything to the screen
+! write(*,*)'##############################################################'
+! write(*,*)
+! write(*,*)' Auto Radial Meshing Code '
+! write(*,*)' Consult read_compute_parameters.f90 and auto_ner.f90 '
+! write(*,*)' This should only be invoked for chunks less than 90 degrees'
+! write(*,*)' and for chunks greater than 1248 elements wide'
+! write(*,*)
+! write(*,*)'CHUNK WIDTH: ', ANGULAR_WIDTH_XI_IN_DEGREES
+! write(*,*)'NEX: ', NEX_MAX
+! write(*,*)'NER_CRUST: ', NER_CRUST
+! write(*,*)'NER_80_MOHO: ', NER_80_MOHO
+! write(*,*)'NER_220_80: ', NER_220_80
+! write(*,*)'NER_400_220: ', NER_400_220
+! write(*,*)'NER_600_400: ', NER_600_400
+! write(*,*)'NER_670_600: ', NER_670_600
+! write(*,*)'NER_771_670: ', NER_771_670
+! write(*,*)'NER_TOPDDOUBLEPRIME_771: ', NER_TOPDDOUBLEPRIME_771
+! write(*,*)'NER_CMB_TOPDDOUBLEPRIME: ', NER_CMB_TOPDDOUBLEPRIME
+! write(*,*)'NER_OUTER_CORE: ', NER_OUTER_CORE
+! write(*,*)'NER_TOP_CENTRAL_CUBE_ICB: ', NER_TOP_CENTRAL_CUBE_ICB
+! write(*,*)'R_CENTRAL_CUBE: ', R_CENTRAL_CUBE
+! write(*,*)'multiplication factor: ', multiplication_factor
+! write(*,*)
+! write(*,*)'DT: ',DT
+! write(*,*)'MIN_ATTENUATION_PERIOD ',MIN_ATTENUATION_PERIOD
+! write(*,*)'MAX_ATTENUATION_PERIOD ',MAX_ATTENUATION_PERIOD
+! write(*,*)
+! write(*,*)'##############################################################'
+
+ if (HONOR_1D_SPHERICAL_MOHO) then
+ if (.not. ONE_CRUST) then
+ ! case 1D + two crustal layers
+ if (NER_CRUST<2) NER_CRUST=2
+ endif
+ else
+ ! case 3D
+ if (NER_CRUST<2) NER_CRUST=2
+ endif
+ endif
+
+
+! take a 5% safety margin on the maximum stable time step
+! which was obtained by trial and error
+ DT = DT * (1.d0 - 0.05d0)
+
+ call read_value_logical(OCEANS, 'model.OCEANS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(ELLIPTICITY, 'model.ELLIPTICITY')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(TOPOGRAPHY, 'model.TOPOGRAPHY')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(GRAVITY, 'model.GRAVITY')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(ROTATION, 'model.ROTATION')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(ATTENUATION, 'model.ATTENUATION')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+ call read_value_logical(ABSORBING_CONDITIONS, 'solver.ABSORBING_CONDITIONS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+ if(ABSORBING_CONDITIONS .and. NCHUNKS == 6) stop 'cannot have absorbing conditions in the full Earth'
+
+ if(ABSORBING_CONDITIONS .and. NCHUNKS == 3) stop 'absorbing conditions not supported for three chunks yet'
+
+ if(ATTENUATION_3D .and. .not. ATTENUATION) stop 'need ATTENUATION to use ATTENUATION_3D'
+
+! radii in PREM or IASP91
+! and normalized density at fluid-solid interface on fluid size for coupling
+! ROCEAN: radius of the ocean (m)
+! RMIDDLE_CRUST: radius of the middle crust (m)
+! RMOHO: radius of the Moho (m)
+! R80: radius of 80 km discontinuity (m)
+! R120: radius of 120 km discontinuity (m) in IASP91
+! R220: radius of 220 km discontinuity (m)
+! R400: radius of 400 km discontinuity (m)
+! R600: radius of 600 km 2nd order discontinuity (m)
+! R670: radius of 670 km discontinuity (m)
+! R771: radius of 771 km 2nd order discontinuity (m)
+! RTOPDDOUBLEPRIME: radius of top of D" 2nd order discontinuity (m)
+! RCMB: radius of CMB (m)
+! RICB: radius of ICB (m)
+
+! by default there is no d120 discontinuity, except in IASP91, therefore set to fictitious value
+ R120 = -1.d0
+
+! value common to all models
+ RHO_OCEANS = 1020.0 / RHOAV
+
+ if(REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) then
+
+! IASP91
+ ROCEAN = 6371000.d0
+ RMIDDLE_CRUST = 6351000.d0
+ RMOHO = 6336000.d0
+ R80 = 6291000.d0
+ R120 = 6251000.d0
+ R220 = 6161000.d0
+ R400 = 5961000.d0
+! there is no d600 discontinuity in IASP91 therefore this value is useless
+! but it needs to be there for compatibility with other subroutines
+ R600 = R_EARTH - 600000.d0
+ R670 = 5711000.d0
+ R771 = 5611000.d0
+ RTOPDDOUBLEPRIME = 3631000.d0
+ RCMB = 3482000.d0
+ RICB = 1217000.d0
+
+ RHO_TOP_OC = 9900.2379 / RHOAV
+ RHO_BOTTOM_OC = 12168.6383 / RHOAV
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_AK135) then
+
+! our implementation of AK135 has not been checked carefully yet
+! therefore let us doublecheck it carefully one day
+
+! values below corrected by Ying Zhou <yingz at gps.caltech.edu>
+
+! AK135 without the 300 meters of mud layer
+ ROCEAN = 6368000.d0
+ RMIDDLE_CRUST = 6361000.d0
+ RMOHO = 6353000.d0
+ R80 = 6291000.d0
+ R220 = 6161000.d0
+ R400 = 5961000.d0
+ R670 = 5711000.d0
+ RTOPDDOUBLEPRIME = 3631000.d0
+ RCMB = 3479500.d0
+ RICB = 1217500.d0
+
+! values for AK135 that are not discontinuities
+ R600 = 5771000.d0
+ R771 = 5611000.d0
+
+ RHO_TOP_OC = 9914.5000 / RHOAV
+ RHO_BOTTOM_OC = 12139.1000 / RHOAV
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) then
+
+! values below corrected by Ying Zhou <yingz at gps.caltech.edu>
+
+! 1066A
+ RMOHO = 6360000.d0
+ R400 = 5950000.d0
+ R600 = 5781000.d0
+ R670 = 5700000.d0
+ RCMB = 3484300.d0
+ RICB = 1229480.d0
+
+! values for 1066A that are not discontinuities
+ RTOPDDOUBLEPRIME = 3631000.d0
+ R220 = 6161000.d0
+ R771 = 5611000.d0
+! RMIDDLE_CRUST used only for high resolution FFSW1C model, with 3 elements crust simulations
+! mid_crust = 10 km
+ RMIDDLE_CRUST = 6361000.d0
+ R80 = 6291000.d0
+
+! model 1066A has no oceans, therefore we use the radius of the Earth instead
+ ROCEAN = R_EARTH
+
+ RHO_TOP_OC = 9917.4500 / RHOAV
+ RHO_BOTTOM_OC = 12160.6500 / RHOAV
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_REF) then
+
+! REF
+ ROCEAN = 6368000.d0
+ RMIDDLE_CRUST = 6356000.d0
+ RMOHO = 6346600.d0
+ R80 = 6291000.d0
+ R220 = 6151000.d0
+ R400 = 5961000.d0
+ R600 = 5771000.d0
+ R670 = 5721000.d0
+ R771 = 5600000.d0
+ RTOPDDOUBLEPRIME = 3630000.d0
+ RCMB = 3479958.d0
+ RICB = 1221491.d0
+
+ RHO_TOP_OC = 9903.48 / RHOAV
+ RHO_BOTTOM_OC = 12166.35 / RHOAV
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_JP1D) then
+
+! values below corrected by Min Chen <mchen at gps.caltech.edu>
+
+! jp1d
+ ROCEAN = 6371000.d0
+ RMIDDLE_CRUST = 6359000.d0
+ RMOHO = 6345000.d0
+ R80 = 6291000.d0
+ R220 = 6161000.d0
+ R400 = 5949000.d0
+ R600 = 5781000.d0
+ R670 = 5711000.d0
+ R771 = 5611000.d0
+ RTOPDDOUBLEPRIME = 3631000.d0
+ RCMB = 3482000.d0
+ RICB = 1217000.d0
+ RHO_TOP_OC = 9900.2379 / RHOAV
+ RHO_BOTTOM_OC = 12168.6383 / RHOAV
+
+ else if(REFERENCE_1D_MODEL == REFERENCE_MODEL_SEA1D) then
+
+! SEA1D without the 2 km of mud layer or the 3km water layer
+ ROCEAN = 6371000.d0
+ RMIDDLE_CRUST = 6361000.d0
+ RMOHO = 6346000.d0
+ R80 = 6291000.d0
+ R220 = 6161000.d0
+ R400 = 5961000.d0
+ R670 = 5711000.d0
+ RTOPDDOUBLEPRIME = 3631000.d0
+ RCMB = 3485700.d0
+ RICB = 1217100.d0
+
+! values for SEA1D that are not discontinuities
+ R600 = 5771000.d0
+ R771 = 5611000.d0
+
+ RHO_TOP_OC = 9903.4384 / RHOAV
+ RHO_BOTTOM_OC = 12166.5885 / RHOAV
+
+ else
+
+! PREM
+ ROCEAN = 6368000.d0
+ RMIDDLE_CRUST = 6356000.d0
+ RMOHO = 6346600.d0
+ R80 = 6291000.d0
+ R220 = 6151000.d0
+ R400 = 5971000.d0
+ R600 = 5771000.d0
+ R670 = 5701000.d0
+ R771 = 5600000.d0
+ RTOPDDOUBLEPRIME = 3630000.d0
+ RCMB = 3480000.d0
+ RICB = 1221000.d0
+
+ RHO_TOP_OC = 9903.4384 / RHOAV
+ RHO_BOTTOM_OC = 12166.5885 / RHOAV
+
+ endif
+
+! honor the PREM Moho or define a fictitious Moho in order to have even radial sampling
+! from the d220 to the Earth surface
+ if(HONOR_1D_SPHERICAL_MOHO) then
+ RMOHO_FICTITIOUS_IN_MESHER = RMOHO
+ else
+ RMOHO_FICTITIOUS_IN_MESHER = (R80 + R_EARTH) / 2
+ endif
+
+ call read_value_double_precision(RECORD_LENGTH_IN_MINUTES, 'solver.RECORD_LENGTH_IN_MINUTES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+! compute total number of time steps, rounded to next multiple of 100
+ NSTEP = 100 * (int(RECORD_LENGTH_IN_MINUTES * 60.d0 / (100.d0*DT)) + 1)
+
+ call read_value_logical(MOVIE_SURFACE, 'solver.MOVIE_SURFACE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(MOVIE_VOLUME, 'solver.MOVIE_VOLUME')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_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.1d0*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_logical(MOVIE_VOLUME_COARSE,'solver.MOVIE_VOLUME_COARSE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_TOP_KM, 'solver.MOVIE_TOP_KM')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_BOTTOM_KM, 'solver.MOVIE_BOTTOM_KM')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_WEST_DEG, 'solver.MOVIE_WEST_DEG')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_EAST_DEG, 'solver.MOVIE_EAST_DEG')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_NORTH_DEG, 'solver.MOVIE_NORTH_DEG')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_double_precision(MOVIE_SOUTH_DEG, 'solver.MOVIE_SOUTH_DEG')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(MOVIE_START, 'solver.MOVIE_START')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(MOVIE_STOP, 'solver.MOVIE_STOP')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ MOVIE_TOP = (R_EARTH_KM-MOVIE_TOP_KM)/R_EARTH_KM
+ MOVIE_BOTTOM = (R_EARTH_KM-MOVIE_BOTTOM_KM)/R_EARTH_KM
+ MOVIE_EAST = MOVIE_EAST_DEG * DEGREES_TO_RADIANS
+ MOVIE_WEST = MOVIE_WEST_DEG * DEGREES_TO_RADIANS
+ MOVIE_NORTH = (90.0d0 - MOVIE_NORTH_DEG) * DEGREES_TO_RADIANS ! converting from latitude to colatitude
+ MOVIE_SOUTH = (90.0d0 - MOVIE_SOUTH_DEG) * DEGREES_TO_RADIANS
+
+ call read_value_logical(SAVE_MESH_FILES, 'mesher.SAVE_MESH_FILES')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NUMBER_OF_RUNS, 'solver.NUMBER_OF_RUNS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NUMBER_OF_THIS_RUN, 'solver.NUMBER_OF_THIS_RUN')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_string(LOCAL_PATH, 'LOCAL_PATH')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NTSTEP_BETWEEN_OUTPUT_INFO, 'solver.NTSTEP_BETWEEN_OUTPUT_INFO')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NTSTEP_BETWEEN_OUTPUT_SEISMOS, 'solver.NTSTEP_BETWEEN_OUTPUT_SEISMOS')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_integer(NTSTEP_BETWEEN_READ_ADJSRC, 'solver.NTSTEP_BETWEEN_READ_ADJSRC')
+ if(err_occurred() /= 0) return
+
+ call read_value_logical(OUTPUT_SEISMOS_ASCII_TEXT, 'solver.OUTPUT_SEISMOS_ASCII_TEXT')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(OUTPUT_SEISMOS_SAC_ALPHANUM, 'solver.OUTPUT_SEISMOS_SAC_ALPHANUM')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(OUTPUT_SEISMOS_SAC_BINARY, 'solver.OUTPUT_SEISMOS_SAC_BINARY')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(ROTATE_SEISMOGRAMS_RT, 'solver.ROTATE_SEISMOGRAMS_RT')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(WRITE_SEISMOGRAMS_BY_MASTER, 'solver.WRITE_SEISMOGRAMS_BY_MASTER')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(SAVE_ALL_SEISMOS_IN_ONE_FILE, 'solver.SAVE_ALL_SEISMOS_IN_ONE_FILE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(USE_BINARY_FOR_LARGE_FILE, 'solver.USE_BINARY_FOR_LARGE_FILE')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+ call read_value_logical(RECEIVERS_CAN_BE_BURIED, 'solver.RECEIVERS_CAN_BE_BURIED')
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+ call read_value_logical(PRINT_SOURCE_TIME_FUNCTION, 'solver.PRINT_SOURCE_TIME_FUNCTION')
+
+ if(err_occurred() /= 0) stop 'an error occurred while reading the parameter file'
+
+! close parameter file
+ call close_parameter_file
+!--- check that parameters make sense
+
+ if (OUTPUT_SEISMOS_SAC_ALPHANUM .and. (mod(NTSTEP_BETWEEN_OUTPUT_SEISMOS,5)/=0)) &
+ stop 'if OUTPUT_SEISMOS_SAC_ALPHANUM = .true. then NTSTEP_BETWEEN_OUTPUT_SEISMOS must be a multiple of 5, check the Par_file'
+
+! subsets used to save seismograms must not be larger than the whole time series,
+! otherwise we waste memory
+ if(NTSTEP_BETWEEN_OUTPUT_SEISMOS > NSTEP) then
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS = NSTEP
+ if (OUTPUT_SEISMOS_SAC_ALPHANUM .and. (mod(NTSTEP_BETWEEN_OUTPUT_SEISMOS,5)/=0)) &
+ stop 'if OUTPUT_SEISMOS_SAC_ALPHANUM = .true. then modified NTSTEP_BETWEEN_OUTPUT_SEISMOS must be a multiple of 5'
+ endif
+
+! check that reals are either 4 or 8 bytes
+ if(CUSTOM_REAL /= SIZE_REAL .and. CUSTOM_REAL /= SIZE_DOUBLE) stop 'wrong size of CUSTOM_REAL for reals'
+
+! check that the parameter file is correct
+ if(NGNOD /= 27) stop 'number of control nodes must be 27'
+ if(NGNOD == 27 .and. NGNOD2D /= 9) stop 'elements with 27 points should have NGNOD2D = 9'
+
+! for the number of standard linear solids for attenuation
+ if(N_SLS /= 3) stop 'number of SLS must be 3'
+
+! check number of slices in each direction
+ if(NCHUNKS < 1) stop 'must have at least one chunk'
+ if(NPROC_XI < 1) stop 'NPROC_XI must be at least 1'
+ if(NPROC_ETA < 1) stop 'NPROC_ETA must be at least 1'
+
+! check number of chunks
+ if(NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) &
+ stop 'only one, two, three or six chunks can be meshed'
+
+! check that the central cube can be included
+ if(INCLUDE_CENTRAL_CUBE .and. NCHUNKS /= 6) stop 'need six chunks to include central cube'
+
+! check that sphere can be cut into slices without getting negative Jacobian
+ if(NEX_XI < 48) stop 'NEX_XI must be greater than 48 to cut the sphere into slices with positive Jacobian'
+ if(NEX_ETA < 48) stop 'NEX_ETA must be greater than 48 to cut the sphere into slices with positive Jacobian'
+
+! check that mesh can be coarsened in depth three or four times
+ CUT_SUPERBRICK_XI=.false.
+ CUT_SUPERBRICK_ETA=.false.
+
+ if (SUPPRESS_CRUSTAL_MESH .and. .not. ADD_4TH_DOUBLING) then
+ if(mod(NEX_XI,8) /= 0) stop 'NEX_XI must be a multiple of 8'
+ if(mod(NEX_ETA,8) /= 0) stop 'NEX_ETA must be a multiple of 8'
+ if(mod(NEX_XI/4,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 4*NPROC_XI'
+ if(mod(NEX_ETA/4,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 4*NPROC_ETA'
+ if(mod(NEX_XI/8,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
+ if(mod(NEX_ETA/8,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
+ elseif (SUPPRESS_CRUSTAL_MESH .or. .not. ADD_4TH_DOUBLING) then
+ if(mod(NEX_XI,16) /= 0) stop 'NEX_XI must be a multiple of 16'
+ if(mod(NEX_ETA,16) /= 0) stop 'NEX_ETA must be a multiple of 16'
+ if(mod(NEX_XI/8,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 8*NPROC_XI'
+ if(mod(NEX_ETA/8,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 8*NPROC_ETA'
+ if(mod(NEX_XI/16,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
+ if(mod(NEX_ETA/16,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
+!! DK DK added this because of temporary bug in David's code
+ if(mod(NEX_XI/16,NPROC_XI) /=0) &
+ stop 'NEX_XI multiple of 8*NPROC_XI but not of 16*NPROC_XI is currently unsafe'
+ if(mod(NEX_ETA/16,NPROC_ETA) /=0) &
+ stop 'NEX_ETA multiple of 8*NPROC_ETA but not of 16*NPROC_ETA is currently unsafe'
+!! DK DK added this because of temporary bug in David's code
+ else
+ if(mod(NEX_XI,32) /= 0) stop 'NEX_XI must be a multiple of 32'
+ if(mod(NEX_ETA,32) /= 0) stop 'NEX_ETA must be a multiple of 32'
+ if(mod(NEX_XI/16,NPROC_XI) /= 0) stop 'NEX_XI must be a multiple of 16*NPROC_XI'
+ if(mod(NEX_ETA/16,NPROC_ETA) /= 0) stop 'NEX_ETA must be a multiple of 16*NPROC_ETA'
+ if(mod(NEX_XI/32,NPROC_XI) /=0) CUT_SUPERBRICK_XI = .true.
+ if(mod(NEX_ETA/32,NPROC_ETA) /=0) CUT_SUPERBRICK_ETA = .true.
+ endif
+
+! check that topology is correct if more than two chunks
+ if(NCHUNKS > 2 .and. NEX_XI /= NEX_ETA) stop 'must have NEX_XI = NEX_ETA for more than two chunks'
+ if(NCHUNKS > 2 .and. NPROC_XI /= NPROC_ETA) stop 'must have NPROC_XI = NPROC_ETA for more than two chunks'
+
+! check that 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(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: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
+ 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
+ nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK_1L
+ nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK_1L
+ else
+ nb_lay_sb = 2
+ nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK
+ nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK
+ endif
+ doubling = 1
+ else
+ doubling = 0
+ nb_lay_sb = 0
+ nspec2D_xi_sb = 0
+ nspec2D_eta_sb = 0
+ endif
+
+ tmp_sum_xi = tmp_sum_xi + ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)) * &
+ (ner(iter_layer) - doubling*nb_lay_sb)) + &
+ doubling * ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)) * (nspec2D_xi_sb/2))
+
+ tmp_sum_eta = tmp_sum_eta + ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)) * &
+ (ner(iter_layer) - doubling*nb_lay_sb)) + &
+ doubling * ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)) * (nspec2D_eta_sb/2))
+ enddo
+ NSPEC2D_XI(iter_region) = tmp_sum_xi
+ NSPEC2D_ETA(iter_region) = tmp_sum_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))
+ 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))
+ enddo
+ NSPEC(iter_region) = tmp_sum / NPROC
+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)
+
+!! DK DK temporary check because at very high resolution there is a bug somewhere
+!! DK DK (maybe in auto_ner)
+ if(minval(NSPEC) < 0) stop 'negative NSPEC, there is a bug somewhere, maybe in auto_ner'
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!
+!!!!!! 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(:) = NSPEC2DMAX_XMIN_XMAX(:)*NGLLY*NGLLZ + 1
+ NGLOB2DMAX_YMIN_YMAX(:) = NSPEC2DMAX_YMIN_YMAX(:)*NGLLX*NGLLZ + 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_GLOBE/trunk/version41_beta/read_value_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/read_value_parameters.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/read_value_parameters.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/recompute_jacobian.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/recompute_jacobian.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/recompute_jacobian.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/recompute_missing_arrays.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/recompute_missing_arrays.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/recompute_missing_arrays.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,202 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+!! DK DK added this for merged version
+ subroutine recompute_missing_arrays(myrank, &
+ xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore, &
+ xstore,ystore,zstore, &
+ xelm_store,yelm_store,zelm_store,ibool,nspec,nglob)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,nglob,myrank
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+ real(kind=CUSTOM_REAL), dimension(NGNOD,nspec) :: xelm_store,yelm_store,zelm_store
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
+
+ integer i,j,k,ia,ispec
+
+ double precision xxi,xeta,xgamma,yxi,yeta,ygamma,zxi,zeta,zgamma
+ double precision xmesh,ymesh,zmesh
+ double precision xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+ double precision jacobian
+
+! Gauss-Lobatto-Legendre points and weights of integration
+ double precision, dimension(:), allocatable :: xigll,yigll,zigll,wxgll,wygll,wzgll
+
+! 3D shape functions and their derivatives
+ double precision, dimension(:,:,:,:), allocatable :: shape3D
+ double precision, dimension(:,:,:,:,:), allocatable :: dershape3D
+
+! Gauss-Lobatto-Legendre points of integration
+ allocate(xigll(NGLLX))
+ allocate(yigll(NGLLY))
+ allocate(zigll(NGLLZ))
+
+! Gauss-Lobatto-Legendre weights of integration
+ allocate(wxgll(NGLLX))
+ allocate(wygll(NGLLY))
+ allocate(wzgll(NGLLZ))
+
+! 3D shape functions and their derivatives
+ allocate(shape3D(NGNOD,NGLLX,NGLLY,NGLLZ))
+ allocate(dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ))
+
+! set up coordinates of the Gauss-Lobatto-Legendre points
+ call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
+
+! if number of points is odd, the middle abscissa is exactly zero
+ if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO
+ if(mod(NGLLY,2) /= 0) yigll((NGLLY-1)/2+1) = ZERO
+ if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO
+
+! get the 3-D shape functions
+ call get_shape3D(myrank,shape3D,dershape3D,xigll,yigll,zigll)
+
+ do ispec = 1,nspec
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ xxi = ZERO
+ xeta = ZERO
+ xgamma = ZERO
+ yxi = ZERO
+ yeta = ZERO
+ ygamma = ZERO
+ zxi = ZERO
+ zeta = ZERO
+ zgamma = ZERO
+ xmesh = ZERO
+ ymesh = ZERO
+ zmesh = ZERO
+
+ do ia=1,NGNOD
+ if(CUSTOM_REAL == SIZE_REAL) then
+ xxi = xxi + dershape3D(1,ia,i,j,k)*dble(xelm_store(ia,ispec))
+ xeta = xeta + dershape3D(2,ia,i,j,k)*dble(xelm_store(ia,ispec))
+ xgamma = xgamma + dershape3D(3,ia,i,j,k)*dble(xelm_store(ia,ispec))
+ yxi = yxi + dershape3D(1,ia,i,j,k)*dble(yelm_store(ia,ispec))
+ yeta = yeta + dershape3D(2,ia,i,j,k)*dble(yelm_store(ia,ispec))
+ ygamma = ygamma + dershape3D(3,ia,i,j,k)*dble(yelm_store(ia,ispec))
+ zxi = zxi + dershape3D(1,ia,i,j,k)*dble(zelm_store(ia,ispec))
+ zeta = zeta + dershape3D(2,ia,i,j,k)*dble(zelm_store(ia,ispec))
+ zgamma = zgamma + dershape3D(3,ia,i,j,k)*dble(zelm_store(ia,ispec))
+ xmesh = xmesh + shape3D(ia,i,j,k)*dble(xelm_store(ia,ispec))
+ ymesh = ymesh + shape3D(ia,i,j,k)*dble(yelm_store(ia,ispec))
+ zmesh = zmesh + shape3D(ia,i,j,k)*dble(zelm_store(ia,ispec))
+ else
+ xxi = xxi + dershape3D(1,ia,i,j,k)*xelm_store(ia,ispec)
+ xeta = xeta + dershape3D(2,ia,i,j,k)*xelm_store(ia,ispec)
+ xgamma = xgamma + dershape3D(3,ia,i,j,k)*xelm_store(ia,ispec)
+ yxi = yxi + dershape3D(1,ia,i,j,k)*yelm_store(ia,ispec)
+ yeta = yeta + dershape3D(2,ia,i,j,k)*yelm_store(ia,ispec)
+ ygamma = ygamma + dershape3D(3,ia,i,j,k)*yelm_store(ia,ispec)
+ zxi = zxi + dershape3D(1,ia,i,j,k)*zelm_store(ia,ispec)
+ zeta = zeta + dershape3D(2,ia,i,j,k)*zelm_store(ia,ispec)
+ zgamma = zgamma + dershape3D(3,ia,i,j,k)*zelm_store(ia,ispec)
+ xmesh = xmesh + shape3D(ia,i,j,k)*xelm_store(ia,ispec)
+ ymesh = ymesh + shape3D(ia,i,j,k)*yelm_store(ia,ispec)
+ zmesh = zmesh + shape3D(ia,i,j,k)*zelm_store(ia,ispec)
+ endif
+ enddo
+
+ jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
+ xeta*(yxi*zgamma-ygamma*zxi) + &
+ xgamma*(yxi*zeta-yeta*zxi)
+
+ if(jacobian <= ZERO) call exit_MPI(myrank,'3D Jacobian undefined when recomputing missing arrays')
+
+! invert the relation (Fletcher p. 50 vol. 2)
+ xix = (yeta*zgamma-ygamma*zeta) / jacobian
+ xiy = (xgamma*zeta-xeta*zgamma) / jacobian
+ xiz = (xeta*ygamma-xgamma*yeta) / jacobian
+ etax = (ygamma*zxi-yxi*zgamma) / jacobian
+ etay = (xxi*zgamma-xgamma*zxi) / jacobian
+ etaz = (xgamma*yxi-xxi*ygamma) / jacobian
+ gammax = (yxi*zeta-yeta*zxi) / jacobian
+ gammay = (xeta*zxi-xxi*zeta) / jacobian
+ gammaz = (xxi*yeta-xeta*yxi) / jacobian
+
+! save the derivatives and the jacobian
+! store mesh coordinates
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ xixstore(i,j,k,ispec) = sngl(xix)
+ xiystore(i,j,k,ispec) = sngl(xiy)
+ xizstore(i,j,k,ispec) = sngl(xiz)
+ etaxstore(i,j,k,ispec) = sngl(etax)
+ etaystore(i,j,k,ispec) = sngl(etay)
+ etazstore(i,j,k,ispec) = sngl(etaz)
+ gammaxstore(i,j,k,ispec) = sngl(gammax)
+ gammaystore(i,j,k,ispec) = sngl(gammay)
+ gammazstore(i,j,k,ispec) = sngl(gammaz)
+
+ xstore(ibool(i,j,k,ispec)) = sngl(xmesh)
+ ystore(ibool(i,j,k,ispec)) = sngl(ymesh)
+ zstore(ibool(i,j,k,ispec)) = sngl(zmesh)
+ else
+ xixstore(i,j,k,ispec) = xix
+ xiystore(i,j,k,ispec) = xiy
+ xizstore(i,j,k,ispec) = xiz
+ etaxstore(i,j,k,ispec) = etax
+ etaystore(i,j,k,ispec) = etay
+ etazstore(i,j,k,ispec) = etaz
+ gammaxstore(i,j,k,ispec) = gammax
+ gammaystore(i,j,k,ispec) = gammay
+ gammazstore(i,j,k,ispec) = gammaz
+
+ xstore(ibool(i,j,k,ispec)) = xmesh
+ ystore(ibool(i,j,k,ispec)) = ymesh
+ zstore(ibool(i,j,k,ispec)) = zmesh
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ enddo
+
+ deallocate(xigll,yigll,zigll)
+ deallocate(wxgll,wygll,wzgll)
+ deallocate(shape3D,dershape3D)
+
+ end subroutine recompute_missing_arrays
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/reduce.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/reduce.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/reduce.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/remap_lsf_machines.pl
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/remap_lsf_machines.pl (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/remap_lsf_machines.pl 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,20 @@
+#!/usr/bin/perl -w
+
+if (@ARGV != 1) {die("remap_lsf_machines.pl machinefile\n");}
+
+$machine = $ARGV[0];
+
+open(FILE,"$machine") or die("Error opening file $machine\n");
+(@junk) = <FILE>;
+close(FILE);
+
+for($i=0;$i<@junk;$i++) {
+ @node_array = split(" ",$junk[$i]);
+ foreach $node (@node_array) {
+ next if ( $node =~ /^[0-9]/ );
+ push(@nodes, $node);
+ }
+}
+foreach $node (@nodes) {
+ print "$node\n";
+}
Property changes on: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/remap_lsf_machines.pl
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/rthetaphi_xyz.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/rthetaphi_xyz.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/rthetaphi_xyz.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/run_lsf_globe_big.bash
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/run_lsf_globe_big.bash (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/run_lsf_globe_big.bash 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,21 @@
+#!/bin/bash
+
+# use the normal queue unless otherwise directed
+queue="-q normal"
+if [ $# -eq 1 ]; then
+ echo "Setting the queue to $1"
+ queue="-q $1"
+fi
+
+# compute total number of nodes needed
+NPROC_XI=`grep NPROC_XI DATA/Par_file | cut -d = -f 2`
+NPROC_ETA=`grep NPROC_ETA DATA/Par_file | cut -d = -f 2 `
+NCHUNKS=`grep NCHUNKS DATA/Par_file | cut -d = -f 2`
+
+# total number of nodes is the product of the values read
+numnodes=$(( $NCHUNKS * $NPROC_XI * $NPROC_ETA ))
+
+echo "Submitting job"
+bsub $queue -n $numnodes -W 14:00 < go_mesher_solver_lsf_globe.bash
+#bsub $queue -n $numnodes -W 144:00 < go_mesher_solver_lsf_globe.bash
+
Property changes on: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/run_lsf_globe_big.bash
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/s362ani.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/s362ani.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/s362ani.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/save_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/save_header_file.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/save_header_file.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,486 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! save header file OUTPUT_FILES/values_from_mesher.h
+
+ subroutine save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ ELLIPTICITY,GRAVITY,ROTATION,ATTENUATION,ATTENUATION_3D, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,NCHUNKS, &
+ INCLUDE_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,NSOURCES,NSTEP,&
+ static_memory_size,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NSPEC2D_TOP,NSPEC2D_BOTTOM, &
+ NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX, &
+ NPROC_XI,NPROC_ETA, &
+ NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC, nglob
+
+ integer NEX_XI,NEX_ETA,NPROC,NPROCTOT,NCHUNKS,NSOURCES,NSTEP
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ ELLIPTICITY,GRAVITY,ROTATION,ATTENUATION,ATTENUATION_3D,INCLUDE_CENTRAL_CUBE
+
+ double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES, &
+ CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH
+
+ double precision :: subtract_central_cube_elems,subtract_central_cube_points
+
+ character(len=150) HEADER_FILE
+
+! for regional code
+ double precision x,y,gamma,rgt,xi,eta
+ double precision x_top,y_top,z_top
+ double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
+
+! rotation matrix from Euler angles
+ integer i,j,ix,iy,icorner
+ double precision rotation_matrix(3,3)
+ double precision vector_ori(3),vector_rotated(3)
+ double precision r_corner,theta_corner,phi_corner,lat,long,colat_corner
+
+! static memory size needed by the solver
+ double precision :: static_memory_size
+
+ integer :: att1,att2,att3,att4,att5,NCORNERSCHUNKS,NUM_FACES,NUM_MSG_TYPES
+
+ integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NSPEC2D_TOP,NSPEC2D_BOTTOM,NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX
+ integer :: NPROC_XI,NPROC_ETA
+
+ integer :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION, &
+ NSPEC2D_MOHO, NSPEC2D_400, NSPEC2D_670, NSPEC2D_CMB, NSPEC2D_ICB
+
+! copy number of elements and points in an include file for the solver
+ call get_value_string(HEADER_FILE, 'solver.HEADER_FILE', 'OUTPUT_FILES/values_from_mesher.h')
+ open(unit=IOUT,file=HEADER_FILE,status='unknown')
+ write(IOUT,*)
+
+ write(IOUT,*) '!'
+ write(IOUT,*) '! this is the parameter file for static compilation of the solver'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! mesh statistics:'
+ write(IOUT,*) '! ---------------'
+ write(IOUT,*) '!'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! number of chunks = ',NCHUNKS
+ write(IOUT,*) '!'
+
+! the central cube is counted 6 times, therefore remove 5 times
+ if(INCLUDE_CENTRAL_CUBE) then
+ write(IOUT,*) '! these statistics include the central cube'
+ subtract_central_cube_elems = 5.d0 * dble((NEX_XI/8))**3
+ subtract_central_cube_points = 5.d0 * (dble(NEX_XI/8)*dble(NGLLX-1)+1.d0)**3
+ else
+ write(IOUT,*) '! these statistics do not include the central cube'
+ subtract_central_cube_elems = 0.d0
+ subtract_central_cube_points = 0.d0
+ endif
+
+ write(IOUT,*) '!'
+ write(IOUT,*) '! number of processors = ',NPROCTOT
+ write(IOUT,*) '!'
+ write(IOUT,*) '! maximum number of points per region = ',nglob(IREGION_CRUST_MANTLE)
+ write(IOUT,*) '!'
+! use fused loops on the ES
+ write(IOUT,*) '! on NEC SX and Earth Simulator, make sure "loopcnt=" parameter'
+ write(IOUT,*) '! in Makefile is greater than max vector length = ',nglob(IREGION_CRUST_MANTLE)*NDIM
+ write(IOUT,*) '!'
+
+ write(IOUT,*) '! total elements per slice = ',sum(NSPEC)
+ write(IOUT,*) '! total points per slice = ',sum(nglob)
+ write(IOUT,*) '!'
+
+ write(IOUT,*) '! total for full 6-chunk mesh:'
+ write(IOUT,*) '! ---------------------------'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! exact total number of spectral elements in entire mesh = '
+ write(IOUT,*) '! ',6.d0*dble(NPROC)*dble(sum(NSPEC)) - subtract_central_cube_elems
+ write(IOUT,*) '! approximate total number of points in entire mesh = '
+ write(IOUT,*) '! ',2.d0*dble(NPROC)*(3.d0*dble(sum(nglob))) - subtract_central_cube_points
+! there are 3 DOFs in solid regions, but only 1 in fluid outer core
+ write(IOUT,*) '! approximate total number of degrees of freedom in entire mesh = '
+ write(IOUT,*) '! ',6.d0*dble(NPROC)*(3.d0*(dble(sum(nglob))) &
+ - 2.d0*dble(nglob(IREGION_OUTER_CORE))) &
+ - 3.d0*subtract_central_cube_points
+ write(IOUT,*) '!'
+
+! display location of chunk if regional run
+ if(NCHUNKS /= 6) then
+
+ write(IOUT,*) '! position of the mesh chunk at the surface:'
+ write(IOUT,*) '! -----------------------------------------'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! angular size in first direction in degrees = ',sngl(ANGULAR_WIDTH_XI_IN_DEGREES)
+ write(IOUT,*) '! angular size in second direction in degrees = ',sngl(ANGULAR_WIDTH_ETA_IN_DEGREES)
+ write(IOUT,*) '!'
+ write(IOUT,*) '! longitude of center in degrees = ',sngl(CENTER_LONGITUDE_IN_DEGREES)
+ write(IOUT,*) '! latitude of center in degrees = ',sngl(CENTER_LATITUDE_IN_DEGREES)
+ write(IOUT,*) '!'
+ write(IOUT,*) '! angle of rotation of the first chunk = ',sngl(GAMMA_ROTATION_AZIMUTH)
+
+! convert width to radians
+ ANGULAR_WIDTH_XI_RAD = ANGULAR_WIDTH_XI_IN_DEGREES * DEGREES_TO_RADIANS
+ ANGULAR_WIDTH_ETA_RAD = ANGULAR_WIDTH_ETA_IN_DEGREES * DEGREES_TO_RADIANS
+
+! compute rotation matrix from Euler angles
+ call euler_angles(rotation_matrix,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH)
+
+! loop on the four corners of the chunk to display their coordinates
+ icorner = 0
+ do iy = 0,1
+ do ix = 0,1
+
+ icorner = icorner + 1
+
+ xi= - ANGULAR_WIDTH_XI_RAD/2. + dble(ix)*ANGULAR_WIDTH_XI_RAD
+ eta= - ANGULAR_WIDTH_ETA_RAD/2. + dble(iy)*ANGULAR_WIDTH_ETA_RAD
+
+ x=dtan(xi)
+ y=dtan(eta)
+
+ gamma=ONE/dsqrt(ONE+x*x+y*y)
+ rgt=R_UNIT_SPHERE*gamma
+
+! define the mesh points at the top surface
+ x_top=-y*rgt
+ y_top=x*rgt
+ z_top=rgt
+
+! rotate top
+ vector_ori(1) = x_top
+ vector_ori(2) = y_top
+ vector_ori(3) = z_top
+ do i=1,3
+ vector_rotated(i)=0.0d0
+ do j=1,3
+ vector_rotated(i)=vector_rotated(i)+rotation_matrix(i,j)*vector_ori(j)
+ enddo
+ enddo
+ x_top = vector_rotated(1)
+ y_top = vector_rotated(2)
+ z_top = vector_rotated(3)
+
+! convert to latitude and longitude
+ call xyz_2_rthetaphi_dble(x_top,y_top,z_top,r_corner,theta_corner,phi_corner)
+ call reduce(theta_corner,phi_corner)
+
+! convert geocentric to geographic colatitude
+ colat_corner=PI/2.0d0-datan(1.006760466d0*dcos(theta_corner)/dmax1(TINYVAL,dsin(theta_corner)))
+ if(phi_corner>PI) phi_corner=phi_corner-TWO_PI
+
+! compute real position of the source
+ lat = (PI/2.0d0-colat_corner)*180.0d0/PI
+ long = phi_corner*180.0d0/PI
+
+ write(IOUT,*) '!'
+ write(IOUT,*) '! corner ',icorner
+ write(IOUT,*) '! longitude in degrees = ',long
+ write(IOUT,*) '! latitude in degrees = ',lat
+
+ enddo
+ enddo
+
+ write(IOUT,*) '!'
+
+ endif ! regional chunk
+
+ write(IOUT,*) '! resolution of the mesh at the surface:'
+ write(IOUT,*) '! -------------------------------------'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! spectral elements along a great circle = ',4*NEX_XI
+ write(IOUT,*) '! GLL points along a great circle = ',4*NEX_XI*(NGLLX-1)
+ write(IOUT,*) '! average distance between points in degrees = ',360./real(4*NEX_XI*(NGLLX-1))
+ write(IOUT,*) '! average distance between points in km = ',real(TWO_PI*R_EARTH/1000.d0)/real(4*NEX_XI*(NGLLX-1))
+ write(IOUT,*) '! average size of a spectral element in km = ',real(TWO_PI*R_EARTH/1000.d0)/real(4*NEX_XI)
+ write(IOUT,*) '!'
+ write(IOUT,*) '! number of time steps = ',NSTEP
+ write(IOUT,*) '!'
+ write(IOUT,*) '! number of seismic sources = ',NSOURCES
+ write(IOUT,*) '!'
+ write(IOUT,*)
+
+ write(IOUT,*) '! approximate static memory needed by the solver:'
+ write(IOUT,*) '! ----------------------------------------------'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! size of static arrays per slice = ',static_memory_size/1073741824.d0,' GB'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! (should be below and typically equal to 80% of 1.5 GB = 1.2 GB on pangu'
+ write(IOUT,*) '! at Caltech, and below and typically equal to 85% of 2 GB = 1.7 GB'
+ write(IOUT,*) '! on Marenostrum in Barcelona)'
+ write(IOUT,*) '! (if significantly more, the job will not run by lack of memory)'
+ write(IOUT,*) '! (if significantly less, you waste a significant amount of memory)'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! size of static arrays for all slices = ',static_memory_size*dble(NPROCTOT)/1073741824.d0,' GB'
+ write(IOUT,*) '! = ',static_memory_size*dble(NPROCTOT)/1099511627776.d0,' TB'
+ write(IOUT,*) '!'
+
+ write(IOUT,*)
+ write(IOUT,*) 'integer, parameter :: NEX_XI_VAL = ',NEX_XI
+ write(IOUT,*) 'integer, parameter :: NEX_ETA_VAL = ',NEX_ETA
+ write(IOUT,*)
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE = ',NSPEC(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE = ',NSPEC(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE = ',NSPEC(IREGION_INNER_CORE)
+ write(IOUT,*)
+ write(IOUT,*) 'integer, parameter :: NGLOB_CRUST_MANTLE = ',nglob(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NGLOB_OUTER_CORE = ',nglob(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NGLOB_INNER_CORE = ',nglob(IREGION_INNER_CORE)
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPECMAX_ANISO_IC = ',NSPECMAX_ANISO_IC
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPECMAX_ISO_MANTLE = ',NSPECMAX_ISO_MANTLE
+ write(IOUT,*) 'integer, parameter :: NSPECMAX_TISO_MANTLE = ',NSPECMAX_TISO_MANTLE
+ write(IOUT,*) 'integer, parameter :: NSPECMAX_ANISO_MANTLE = ',NSPECMAX_ANISO_MANTLE
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_ATTENUAT = ',NSPEC_CRUST_MANTLE_ATTENUAT
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_ATTENUATION = ',NSPEC_INNER_CORE_ATTENUATION
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_STR_OR_ATT = ',NSPEC_CRUST_MANTLE_STR_OR_ATT
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_STR_OR_ATT = ',NSPEC_INNER_CORE_STR_OR_ATT
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_STR_AND_ATT = ',NSPEC_CRUST_MANTLE_STR_AND_ATT
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_STR_AND_ATT = ',NSPEC_INNER_CORE_STR_AND_ATT
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_STRAIN_ONLY = ',NSPEC_CRUST_MANTLE_STRAIN_ONLY
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_STRAIN_ONLY = ',NSPEC_INNER_CORE_STRAIN_ONLY
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_ADJOINT = ',NSPEC_CRUST_MANTLE_ADJOINT
+ write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE_ADJOINT = ',NSPEC_OUTER_CORE_ADJOINT
+ write(IOUT,*) 'integer, parameter :: NSPEC_INNER_CORE_ADJOINT = ',NSPEC_INNER_CORE_ADJOINT
+
+ write(IOUT,*) 'integer, parameter :: NGLOB_CRUST_MANTLE_ADJOINT = ',NGLOB_CRUST_MANTLE_ADJOINT
+ write(IOUT,*) 'integer, parameter :: NGLOB_OUTER_CORE_ADJOINT = ',NGLOB_OUTER_CORE_ADJOINT
+ write(IOUT,*) 'integer, parameter :: NGLOB_INNER_CORE_ADJOINT = ',NGLOB_INNER_CORE_ADJOINT
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE_ROT_ADJOINT = ',NSPEC_OUTER_CORE_ROT_ADJOINT
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NSPEC_CRUST_MANTLE_STACEY = ',NSPEC_CRUST_MANTLE_STACEY
+ write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE_STACEY = ',NSPEC_OUTER_CORE_STACEY
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NGLOB_CRUST_MANTLE_OCEANS = ',NGLOB_CRUST_MANTLE_OCEANS
+ write(IOUT,*)
+
+! this to allow for code elimination by compiler in solver for performance
+
+ if(TRANSVERSE_ISOTROPY) then
+ write(IOUT,*) 'logical, parameter :: TRANSVERSE_ISOTROPY_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: TRANSVERSE_ISOTROPY_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ANISOTROPIC_3D_MANTLE) then
+ write(IOUT,*) 'logical, parameter :: ANISOTROPIC_3D_MANTLE_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ANISOTROPIC_3D_MANTLE_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ANISOTROPIC_INNER_CORE) then
+ write(IOUT,*) 'logical, parameter :: ANISOTROPIC_INNER_CORE_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ANISOTROPIC_INNER_CORE_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ATTENUATION) then
+ write(IOUT,*) 'logical, parameter :: ATTENUATION_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ATTENUATION_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ATTENUATION_3D) then
+ write(IOUT,*) 'logical, parameter :: ATTENUATION_3D_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ATTENUATION_3D_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ELLIPTICITY) then
+ write(IOUT,*) 'logical, parameter :: ELLIPTICITY_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ELLIPTICITY_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(GRAVITY) then
+ write(IOUT,*) 'logical, parameter :: GRAVITY_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: GRAVITY_VAL = .false.'
+ endif
+ write(IOUT,*)
+
+ if(ROTATION) then
+ write(IOUT,*) 'logical, parameter :: ROTATION_VAL = .true.'
+ else
+ write(IOUT,*) 'logical, parameter :: ROTATION_VAL = .false.'
+ endif
+ write(IOUT,*) 'integer, parameter :: NSPEC_OUTER_CORE_ROTATION = ',NSPEC_OUTER_CORE_ROTATION
+ write(IOUT,*)
+
+ write(IOUT,*) 'integer, parameter :: NGLOB1D_RADIAL_CM = ',NGLOB1D_RADIAL(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NGLOB1D_RADIAL_OC = ',NGLOB1D_RADIAL(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NGLOB1D_RADIAL_IC = ',NGLOB1D_RADIAL(IREGION_INNER_CORE)
+
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XMIN_XMAX_CM = ',NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XMIN_XMAX_OC = ',NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XMIN_XMAX_IC = ',NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE)
+
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_YMIN_YMAX_CM = ',NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE)
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_YMIN_YMAX_OC = ',NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE)
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_YMIN_YMAX_IC = ',NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE)
+
+ write(IOUT,*) 'integer, parameter :: NPROC_XI_VAL = ',NPROC_XI
+ write(IOUT,*) 'integer, parameter :: NPROC_ETA_VAL = ',NPROC_ETA
+ write(IOUT,*) 'integer, parameter :: NCHUNKS_VAL = ',NCHUNKS
+ write(IOUT,*) 'integer, parameter :: NPROCTOT_VAL = ',NPROCTOT
+
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XY_VAL = ', &
+ 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_GLOBE/trunk/version41_beta/sea99_s_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/sea99_s_model.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/sea99_s_model.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,157 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+subroutine read_sea99_s_model(SEA99M_V)
+
+ implicit none
+
+ include "constants.h"
+
+! sea99_s_model_variables
+ type sea99_s_model_variables
+ sequence
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ end type sea99_s_model_variables
+
+ type (sea99_s_model_variables) SEA99M_V
+! sea99_s_model_variables
+
+ integer :: i,ia,io,j
+
+!----------------------- choose input file: ------------------
+! relative anomaly
+
+
+ open(1,file='DATA/Lebedev_sea99/sea99_dvsvs')
+
+!----------------------- read input file: ------------------
+
+ do i = 1, 6
+ read(1,*)
+ enddo
+ read(1,*) SEA99M_V%sea99_ndep
+ read(1,*) (SEA99M_V%sea99_depth(i), i = 1, SEA99M_V%sea99_ndep)
+ read(1,*)
+ read(1,*) SEA99M_V%alatmin, SEA99M_V%alatmax
+ read(1,*) SEA99M_V%alonmin, SEA99M_V%alonmax
+ read(1,*) SEA99M_V%sea99_ddeg,SEA99M_V%sea99_nlat,SEA99M_V%sea99_nlon
+ if (SEA99M_V%sea99_nlat .ne. nint((SEA99M_V%alatmax-SEA99M_V%alatmin)/SEA99M_V%sea99_ddeg)+1) then
+ stop 'alatmin,alatmax,sea99_nlat'
+ endif
+ if (SEA99M_V%sea99_nlon .ne. nint((SEA99M_V%alonmax-SEA99M_V%alonmin)/SEA99M_V%sea99_ddeg)+1) then
+ stop 'alonmin,alonmax,sea99_nlon'
+ endif
+ read(1,*)
+ do j = 1, SEA99M_V%sea99_ndep
+ do ia = 1, SEA99M_V%sea99_nlat
+ read (1,*) (SEA99M_V%sea99_vs(ia,io,j), io = 1, SEA99M_V%sea99_nlon)
+ enddo
+ enddo
+
+end subroutine read_sea99_s_model
+
+subroutine sea99_s_model(radius,theta,phi,dvs,SEA99M_V)
+
+ implicit none
+
+ include "constants.h"
+
+! sea99_s_model_variables
+ type sea99_s_model_variables
+ sequence
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ double precision :: sea99_vs(100,100,100)
+ double precision :: sea99_depth(100)
+ end type sea99_s_model_variables
+
+ type (sea99_s_model_variables) SEA99M_V
+! sea99_s_model_variables
+
+ integer :: id1,i,ilat,ilon
+ double precision :: alat1,alon1,radius,theta,phi,dvs
+ double precision :: xxx,yyy,dep,pla,plo,xd1,dd1,dd2,ddd(2)
+ !----------------------- depth in the model ------------------
+ dep=R_EARTH_KM*(R_UNIT_SPHERE - radius)
+ pla=90.0d0 - theta/DEGREES_TO_RADIANS
+ plo=phi/DEGREES_TO_RADIANS
+ if (dep .le. SEA99M_V%sea99_depth(1)) then
+ id1 = 1
+ xd1 = 0
+ else if (dep .ge. SEA99M_V%sea99_depth(SEA99M_V%sea99_ndep)) then
+ id1 = SEA99M_V%sea99_ndep
+ xd1 = 0
+ else
+ do i = 2, SEA99M_V%sea99_ndep
+ if (dep .le. SEA99M_V%sea99_depth(i)) then
+ id1 = i-1
+ xd1 = (dep-SEA99M_V%sea99_depth(i-1)) / (SEA99M_V%sea99_depth(i) - SEA99M_V%sea99_depth(i-1))
+ go to 1
+ endif
+ enddo
+ endif
+1 continue
+
+!----------------------- value at a point ---------------------
+!----- approximate interpolation, OK for the (dense) 1-degree sampling ------
+
+ ilat = int((pla - SEA99M_V%alatmin)/SEA99M_V%sea99_ddeg) + 1
+ ilon = int((plo - SEA99M_V%alonmin)/SEA99M_V%sea99_ddeg) + 1
+ alat1 = SEA99M_V%alatmin + (ilat-1)*SEA99M_V%sea99_ddeg
+ alon1 = SEA99M_V%alonmin + (ilon-1)*SEA99M_V%sea99_ddeg
+
+ do i = 1, 2
+ xxx = (pla-alat1)/SEA99M_V%sea99_ddeg
+ yyy = SEA99M_V%sea99_vs(ilat+1,ilon,id1+i-1)-SEA99M_V%sea99_vs(ilat,ilon,id1+i-1)
+ dd1 = SEA99M_V%sea99_vs(ilat,ilon,id1+i-1) + yyy*xxx
+ yyy = SEA99M_V%sea99_vs(ilat+1,ilon+1,id1+i-1)-SEA99M_V%sea99_vs(ilat,ilon+1,id1+i-1)
+ dd2 = SEA99M_V%sea99_vs(ilat,ilon+1,id1+i-1) + yyy*xxx
+ xxx = (plo-alon1)/SEA99M_V%sea99_ddeg
+ yyy = dd2 - dd1
+ ddd(i) = dd1 + yyy*xxx
+ enddo
+ dvs = ddd(1) + (ddd(2)-ddd(1)) * xd1
+ if(dvs>1.d0) dvs=0.0d0
+
+end subroutine sea99_s_model
+
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/sort_array_coordinates.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/sort_array_coordinates.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/sort_array_coordinates.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/specfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/specfem3D.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/specfem3D.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,2434 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+!
+! United States Government Sponsorship Acknowledged.
+
+!! DK DK for the merged version
+ include 'call2.f90'
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+! include values created by the mesher
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+!=======================================================================!
+! !
+! specfem3D is a 3-D spectral-element solver for the Earth. !
+! It uses a mesh generated by program meshfem3D !
+! !
+!=======================================================================!
+!
+! If you use this code for your own research, please cite some of these articles:
+!
+! @ARTICLE{KoRiTr02,
+! author={D. Komatitsch and J. Ritsema and J. Tromp},
+! year=2002,
+! title={The Spectral-Element Method, {B}eowulf Computing, and Global Seismology},
+! journal={Science},
+! volume=298,
+! number=5599,
+! pages={1737-1742},
+! doi={10.1126/science.1076024}}
+!
+! @ARTICLE{KoTr02a,
+! author={D. Komatitsch and J. Tromp},
+! year=2002,
+! title={Spectral-Element Simulations of Global Seismic Wave Propagation{-I. V}alidation},
+! journal={Geophys. J. Int.},
+! volume=149,
+! number=2,
+! pages={390-412},
+! doi={10.1046/j.1365-246X.2002.01653.x}}
+!
+! @ARTICLE{KoTr02b,
+! author={D. Komatitsch and J. Tromp},
+! year=2002,
+! title={Spectral-Element Simulations of Global Seismic Wave Propagation{-II. 3-D} Models, Oceans, Rotation, and Self-Gravitation},
+! journal={Geophys. J. Int.},
+! volume=150,
+! pages={303-318},
+! number=1,
+! doi={10.1046/j.1365-246X.2002.01716.x}}
+!
+! @ARTICLE{KoTr99,
+! author={D. Komatitsch and J. Tromp},
+! year=1999,
+! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
+! journal={Geophys. J. Int.},
+! volume=139,
+! number=3,
+! pages={806-822},
+! doi={10.1046/j.1365-246x.1999.00967.x}}
+!
+! @ARTICLE{KoVi98,
+! author={D. Komatitsch and J. P. Vilotte},
+! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
+! journal={Bull. Seismol. Soc. Am.},
+! year=1998,
+! volume=88,
+! number=2,
+! pages={368-392}}
+!
+! If you use the kernel capabilities of the code, please cite
+!
+! @ARTICLE{LiTr06,
+! author={Qinya Liu and Jeroen Tromp},
+! title={Finite-frequency kernels based on adjoint methods},
+! journal={Bull. Seismol. Soc. Am.},
+! year=2006,
+! volume=96,
+! number=6,
+! pages={2383-2397},
+! doi={10.1785/0120060041}}
+!
+! If you use 3-D model S20RTS, please cite
+!
+! @ARTICLE{RiVa00,
+! author={J. Ritsema and H. J. {Van Heijst}},
+! year=2000,
+! title={Seismic imaging of structural heterogeneity in {E}arth's mantle: Evidence for large-scale mantle flow},
+! journal={Science Progress},
+! volume=83,
+! pages={243-259}}
+!
+! Reference frame - convention:
+! ----------------------------
+!
+! The code uses the following convention for the reference frame:
+!
+! - X axis is East
+! - Y axis is North
+! - Z axis is up
+!
+! Note that this convention is different from both the Aki-Richards convention
+! and the Harvard CMT convention.
+!
+! Let us recall that the Aki-Richards convention is:
+!
+! - X axis is North
+! - Y axis is East
+! - Z axis is down
+!
+! and that the Harvard CMT convention is:
+!
+! - X axis is South
+! - Y axis is East
+! - Z axis is up
+!
+! To report bugs or suggest improvements to the code, please send an email
+! to Jeroen Tromp <jtromp AT caltech.edu> and/or use our online
+! bug tracking system at http://www.geodynamics.org/roundup .
+!
+! Evolution of the code:
+! ---------------------
+!
+! v. 4.0 David Michea and Dimitri Komatitsch, University of Pau, France, February 2008:
+! new doubling brick in the mesh, new perfectly load-balanced mesh,
+! more flexible routines for mesh design, one more doubling level
+! at the bottom of the outer core, new inflated central cube
+! with optimized shape, far fewer mesh files saved by the mesher.
+! v. 3.6 Many people, many affiliations, September 2006:
+! adjoint and kernel calculations, fixed IASP91 model,
+! added AK135 and 1066a, fixed topography/bathymetry routine,
+! new attenuation routines, faster and better I/Os on very large
+! systems, many small improvements and bug fixes, new "configure"
+! script, new Pyre version, new user's manual etc.
+! v. 3.5 Dimitri Komatitsch, Brian Savage and Jeroen Tromp, Caltech, July 2004:
+! any size of chunk, 3D attenuation, case of two chunks,
+! more precise topography/bathymetry model, new Par_file structure
+! v. 3.4 Dimitri Komatitsch and Jeroen Tromp, Caltech, August 2003:
+! merged global and regional codes, no iterations in fluid, better movies
+! v. 3.3 Dimitri Komatitsch, Caltech, September 2002:
+! flexible mesh doubling in outer core, inlined code, OpenDX support
+! v. 3.2 Jeroen Tromp, Caltech, July 2002:
+! multiple sources and flexible PREM reading
+! v. 3.1 Dimitri Komatitsch, Caltech, June 2002:
+! vectorized loops in solver and merged central cube
+! v. 3.0 Dimitri Komatitsch and Jeroen Tromp, Caltech, May 2002:
+! ported to SGI and Compaq, double precision solver, more general anisotropy
+! v. 2.3 Dimitri Komatitsch and Jeroen Tromp, Caltech, August 2001:
+! gravity, rotation, oceans and 3-D models
+! v. 2.2 Dimitri Komatitsch and Jeroen Tromp, Caltech, March 2001:
+! final MPI package
+! v. 2.0 Dimitri Komatitsch, Harvard, January 2000: MPI code for the globe
+! v. 1.0 Dimitri Komatitsch, Mexico, June 1999: first MPI code for a chunk
+! Jeroen Tromp, Harvard, July 1998: first chunk solver using OpenMP on Sun
+! Dimitri Komatitsch, IPG Paris, December 1996: first 3-D solver for the CM5
+!
+! From Dahlen and Tromp (1998):
+! ----------------------------
+!
+! Gravity is approximated by solving eq (3.259) without the Phi_E' term
+! The ellipsoidal reference model is that of section 14.1
+! The transversely isotropic expression for PREM is that of eq (8.190)
+!
+! Formulation in the fluid (acoustic) outer core:
+! -----------------------------------------------
+!
+! In case of an acoustic medium, a displacement potential Chi is used
+! as in Chaljub and Valette, Geophysical Journal International, vol. 158,
+! p. 131-141 (2004) and *NOT* a velocity potential as in Komatitsch and Tromp,
+! Geophysical Journal International, vol. 150, p. 303-318 (2002).
+! This permits acoustic-elastic coupling based on a non-iterative time scheme.
+! Displacement if we ignore gravity is then: u = grad(Chi)
+! (In the context of the Cowling approximation displacement is
+! u = grad(rho * Chi) / rho, *not* u = grad(Chi).)
+! Velocity is then: v = grad(Chi_dot) (Chi_dot being the time derivative of Chi)
+! and pressure is: p = - rho * Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
+! The source in an acoustic element is a pressure source.
+! The potential in the outer core is called displ_outer_core for simplicity.
+! Its first time derivative is called veloc_outer_core.
+! Its second time derivative is called accel_outer_core.
+
+! attenuation_model_variables
+ type attenuation_model_variables
+ sequence
+ double precision min_period, max_period
+ double precision :: QT_c_source ! Source Frequency
+ double precision, dimension(:), pointer :: Qtau_s ! tau_sigma
+ double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
+ double precision, dimension(:), pointer :: Qr ! Radius
+ integer, dimension(:), pointer :: interval_Q ! Steps
+ double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
+ double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
+ double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
+ double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
+ double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
+ integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
+ integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
+ integer :: Qn ! Number of points
+ end type attenuation_model_variables
+
+ type (attenuation_model_variables) AM_V
+! attenuation_model_variables
+
+! memory variables and standard linear solids for attenuation
+ double precision, dimension(N_SLS) :: tau_sigma_dble
+ double precision, dimension(ATT1,ATT2,ATT3,ATT4) :: omsb_crust_mantle_dble, factor_scale_crust_mantle_dble
+ double precision, dimension(ATT1,ATT2,ATT3,ATT5) :: omsb_inner_core_dble, factor_scale_inner_core_dble
+ real(kind=CUSTOM_REAL), dimension(ATT1,ATT2,ATT3,ATT4) :: one_minus_sum_beta_crust_mantle, factor_scale_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(ATT1,ATT2,ATT3,ATT5) :: one_minus_sum_beta_inner_core, factor_scale_inner_core
+
+ real(kind=CUSTOM_REAL) mul
+
+ double precision, dimension(N_SLS) :: alphaval_dble, betaval_dble, gammaval_dble
+ real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval, betaval, gammaval
+ real(kind=CUSTOM_REAL), dimension(N_SLS,ATT1,ATT2,ATT3,ATT4) :: factor_common_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(N_SLS,ATT1,ATT2,ATT3,ATT5) :: factor_common_inner_core
+ double precision, dimension(N_SLS,ATT1,ATT2,ATT3,ATT4) :: factor_common_crust_mantle_dble
+ double precision, dimension(N_SLS,ATT1,ATT2,ATT3,ATT5) :: factor_common_inner_core_dble
+
+ double precision scale_factor,scale_factor_minus_one
+ real(kind=CUSTOM_REAL) dist_cr
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ATTENUAT) :: R_memory_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: epsilondev_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(5,N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ATTENUATION) :: R_memory_inner_core
+ real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_STR_OR_ATT) :: epsilondev_inner_core
+
+! for matching with central cube in inner core
+ integer, dimension(:), allocatable :: sender_from_slices_to_cube
+ integer, dimension(:,:), allocatable :: ibool_central_cube
+ double precision, dimension(:,:), allocatable :: buffer_slices,buffer_slices2
+ double precision, dimension(:,:,:), allocatable :: buffer_all_cube_from_slices
+ integer nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices,receiver_cube_from_slices
+
+ integer nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core,ndim_assemble
+
+! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
+
+! for crust/oceans coupling
+ integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
+
+! additional mass matrix for ocean load
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
+
+! arrays to couple with the fluid regions by pointwise matching
+ integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
+ integer, dimension(NSPEC2D_TOP_OC) :: ibelm_top_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: normal_bottom_outer_core
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_OC) :: normal_top_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM_OC) :: jacobian2D_bottom_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP_OC) :: jacobian2D_top_outer_core
+
+ integer, dimension(NSPEC2DMAX_XMIN_XMAX_IC) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
+ integer, dimension(NSPEC2DMAX_YMIN_YMAX_IC) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
+ integer, dimension(NSPEC2D_BOTTOM_IC) :: ibelm_bottom_inner_core
+ integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
+
+! for matching between fluid and solid regions
+ integer :: ispec2D,k_corresp,ispec_selected
+ real(kind=CUSTOM_REAL) :: displ_x,displ_y,displ_z,nx,ny,nz,displ_n,weight,pressure
+
+! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
+
+! for conversion from x y z to r theta phi
+ real(kind=CUSTOM_REAL) rval,thetaval,phival
+
+! ---- arrays to assemble between chunks
+
+! communication pattern for faces between chunks
+ integer, dimension(NUMMSGS_FACES_VAL) :: iprocfrom_faces,iprocto_faces,imsg_type
+
+! communication pattern for corners between chunks
+ integer, dimension(NCORNERSCHUNKS_VAL) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
+
+! indirect addressing for each message for faces and corners of the chunks
+! a given slice can belong to at most one corner and at most two faces
+ integer NGLOB2DMAX_XY
+ integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle, &
+ iboolfaces_outer_core,iboolfaces_inner_core
+
+! buffers for send and receive between faces of the slices and the chunks
+! we use the same buffers to assemble scalars and vectors because vectors are
+! always three times bigger and therefore scalars can use the first part
+! of the vector buffer in memory even if it has an additional index here
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces,buffer_received_faces
+
+! -------- arrays specific to each region here -----------
+
+! ----------------- crust, mantle and oceans ---------------------
+
+! mesh parameters
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle,&
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
+
+! arrays for isotropic elements stored only where needed to save space
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
+ kappavstore_crust_mantle,muvstore_crust_mantle
+
+! arrays for anisotropic elements stored only where needed to save space
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
+ kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle
+
+! arrays for full anisotropy only when needed
+ integer nspec_iso,nspec_tiso,nspec_ani
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_MANTLE) :: &
+ c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
+ c22store_crust_mantle,c23store_crust_mantle,c33store_crust_mantle, &
+ c44store_crust_mantle,c55store_crust_mantle,c66store_crust_mantle
+
+! local to global mapping
+ integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling_crust_mantle
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: rmass_crust_mantle
+
+! displacement, velocity, acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
+ displ_crust_mantle,veloc_crust_mantle,accel_crust_mantle
+
+! ----------------- outer core ---------------------
+
+! mesh parameters
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: &
+ xix_outer_core,xiy_outer_core,xiz_outer_core,&
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
+ xstore_outer_core,ystore_outer_core,zstore_outer_core
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: rmass_outer_core
+
+! velocity potential
+ real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: displ_outer_core, &
+ veloc_outer_core,accel_outer_core
+
+! ----------------- inner core ---------------------
+
+! mesh parameters
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
+ xix_inner_core,xiy_inner_core,xiz_inner_core,&
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ kappavstore_inner_core,muvstore_inner_core
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core
+
+! arrays for inner-core anisotropy only when needed
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_IC) :: &
+ c11store_inner_core,c33store_inner_core,c12store_inner_core, &
+ c13store_inner_core,c44store_inner_core
+
+! local to global mapping
+ integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: rmass_inner_core
+
+! displacement, velocity, acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
+ displ_inner_core,veloc_inner_core,accel_inner_core
+
+! Newmark time scheme parameters and non-dimensionalization
+ real(kind=CUSTOM_REAL) time,deltat,deltatover2,deltatsqover2
+ double precision scale_t,scale_displ,scale_veloc
+
+ integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
+ integer npoin2D_faces_outer_core(NUMFACES_SHARED)
+ integer npoin2D_faces_inner_core(NUMFACES_SHARED)
+
+! parameters for the source
+ integer it,isource
+ integer, dimension(:), allocatable :: islice_selected_source,ispec_selected_source
+ integer yr,jda,ho,mi
+ real(kind=CUSTOM_REAL) stf_used
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: sourcearrays
+ double precision, dimension(:,:,:) ,allocatable:: nu_source
+ double precision sec,stf
+ double precision, dimension(:), allocatable :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
+ double precision, dimension(:), allocatable :: xi_source,eta_source,gamma_source
+ double precision, dimension(:), allocatable :: t_cmt,hdur,hdur_gaussian
+ double precision, dimension(:), allocatable :: theta_source,phi_source
+ double precision, external :: comp_source_time_function
+ double precision t0
+
+! receiver information
+ integer nrec,nrec_local,nrec_tot_found,irec_local,ios
+ integer, dimension(:), allocatable :: islice_selected_rec,ispec_selected_rec,number_receiver_global
+ double precision, dimension(:), allocatable :: xi_receiver,eta_receiver,gamma_receiver
+ double precision hlagrange
+ character(len=150) :: STATIONS,rec_filename,dummystring
+ double precision, dimension(:,:,:), allocatable :: nu
+ double precision, allocatable, dimension(:) :: stlat,stlon,stele
+ character(len=MAX_LENGTH_STATION_NAME), dimension(:), allocatable :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(:), allocatable :: network_name
+
+! seismograms
+ integer it_begin,it_end,nit_written
+ double precision uxd, uyd, uzd
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: seismograms
+ integer :: seismo_offset, seismo_current
+
+ integer i,j,k,ispec,irec,iglob,iglob_mantle,iglob_inner_core
+
+! number of faces between chunks
+ integer NUM_FACES,NUMMSGS_FACES
+
+! number of corners between chunks
+ integer NCORNERSCHUNKS
+
+! number of message types
+ integer NUM_MSG_TYPES
+
+! indirect addressing for each corner of the chunks
+ integer, dimension(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
+ integer, dimension(NGLOB1D_RADIAL_OC,NUMCORNERS_SHARED) :: iboolcorner_outer_core
+ integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
+
+! buffers for send and receive between corners of the chunks
+ real(kind=CUSTOM_REAL), dimension(NGLOB1D_RADIAL_CM) :: buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB1D_RADIAL_CM + NGLOB1D_RADIAL_IC) :: &
+ buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll,wxgll
+ double precision, dimension(NGLLY) :: yigll,wygll
+ double precision, dimension(NGLLZ) :: zigll,wzgll
+
+! product of weights for gravity term
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+! Lagrange interpolators at receivers
+ double precision, dimension(NGLLX) :: hxir,hpxir
+ double precision, dimension(NGLLY) :: hpetar,hetar
+ double precision, dimension(NGLLZ) :: hgammar,hpgammar
+ double precision, dimension(:,:), allocatable :: hxir_store,hetar_store,hgammar_store
+
+! 2-D addressing and buffers for summation between slices
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_CM) :: iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_CM) :: iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle
+
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_OC) :: iboolleft_xi_outer_core,iboolright_xi_outer_core
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_OC) :: iboolleft_eta_outer_core,iboolright_eta_outer_core
+
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX_IC) :: iboolleft_xi_inner_core,iboolright_xi_inner_core
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX_IC) :: iboolleft_eta_inner_core,iboolright_eta_inner_core
+
+! for addressing of the slices
+ integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
+ integer, dimension(0:NPROCTOT_VAL-1) :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
+
+! proc numbers for MPI
+ integer myrank,sizeprocs,ier
+
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_outer_core,npoin2D_eta_outer_core
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_inner_core,npoin2D_eta_inner_core
+
+!! DK DK added this to reduce the size of the buffers
+ integer :: npoin2D_max_all
+
+ integer ichunk,iproc_xi,iproc_eta !!!!!!!!!!!!!!!!!!!!!!,iproc,iproc_read
+ integer NPROC_ONE_DIRECTION
+
+! maximum of the norm of the displacement and of the potential in the fluid
+ real(kind=CUSTOM_REAL) Usolidnorm,Usolidnorm_all,Ufluidnorm,Ufluidnorm_all
+
+! timer MPI
+ integer :: ihours,iminutes,iseconds,int_tCPU, &
+ ihours_remain,iminutes_remain,iseconds_remain,int_t_remain, &
+ ihours_total,iminutes_total,iseconds_total,int_t_total
+
+ double precision :: time_start,tCPU,t_remain,t_total
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,&
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH
+
+ logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_VOLUME_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
+
+ character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL
+
+! parameters deduced from parameters read from file
+ integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+
+ integer, external :: err_occurred
+
+ logical COMPUTE_AND_STORE_STRAIN
+
+! for SAC headers for seismograms
+ integer NSOURCES_SAC,yr_SAC,jda_SAC,ho_SAC,mi_SAC
+ real mb_SAC
+ double precision t_cmt_SAC,elat_SAC,elon_SAC,depth_SAC,cmt_lat_SAC,cmt_lon_SAC,cmt_depth_SAC,cmt_hdur_SAC,sec_SAC
+ character(len=12) ename_SAC
+
+! this for all the regions
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC_computed, &
+ NSPEC2D_XI, NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NGLOB_computed
+
+ character(len=150) prname
+
+! lookup table every km for gravity
+ integer int_radius,idoubling
+ double precision radius,rho,drhodr,vp,vs,Qkappa,Qmu
+ double precision, dimension(NRAD_GRAVITY) :: d_ln_density_dr_table
+
+! flags to read kappa and mu and anisotropy arrays in regions where needed
+ logical READ_KAPPA_MU,READ_TISO
+
+! names of the data files for all the processors in MPI
+ character(len=150) outputname
+
+! if running on MareNostrum in Barcelona
+ character(len=400) system_command
+
+ integer iregion_selected
+
+! computed in read_compute_parameters
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+ logical :: CASE_3D
+
+! arrays for BCAST
+ integer, dimension(38) :: bcast_integer
+ double precision, dimension(30) :: bcast_double_precision
+ logical, dimension(33) :: bcast_logical
+
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+
+! ************** PROGRAM STARTS HERE **************
+
+! initialize the MPI communicator and start the NPROCTOT MPI processes.
+!! DK DK suppressed for merged version call MPI_INIT(ier)
+
+! sizeprocs returns number of processes started (should be equal to NPROCTOT).
+! myrank is the rank of each process, between 0 and sizeprocs-1.
+! as usual in MPI, process 0 is in charge of coordinating everything
+! and also takes care of the main output
+!! DK DK suppressed for merged version call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
+!! DK DK suppressed for merged version call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
+
+!! DK DK added this for merged version
+! synchronize all the processes to make sure everybody has finished
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+!! DK DK added this to reduce the size of the buffers
+! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
+ npoin2D_max_all = max(maxval(npoin2D_xi_crust_mantle(:) + npoin2D_xi_inner_core(:)), &
+ maxval(npoin2D_eta_crust_mantle(:) + npoin2D_eta_inner_core(:)))
+ allocate(buffer_send_faces(NDIM,npoin2D_max_all))
+ allocate(buffer_received_faces(NDIM,npoin2D_max_all))
+
+ if (myrank == 0) then
+
+! read the parameter file and compute additional parameters
+ call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_VOLUME_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC_computed, &
+ NSPEC2D_XI, &
+ NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NGLOB_computed, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.)
+
+ if(err_occurred() /= 0) then
+ call exit_MPI(myrank,'an error occurred while reading the parameter file')
+ endif
+
+! count the total number of sources in the CMTSOLUTION file
+ call count_number_of_sources(NSOURCES)
+
+ bcast_integer = (/MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,&
+ SIMULATION_TYPE,REFERENCE_1D_MODEL,THREE_D_MODEL,NPROC,NPROCTOT, &
+ NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube,&
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP/)
+
+ bcast_logical = (/TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST,ROTATION,ISOTROPIC_3D_MANTLE, &
+ TOPOGRAPHY,OCEANS,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_VOLUME_COARSE,ATTENUATION_3D, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ATTENUATION, &
+ ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE/)
+
+ bcast_double_precision = (/DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH/)
+
+ endif
+
+! broadcast the information read on the master to the nodes
+ call MPI_BCAST(NSOURCES,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(bcast_integer,38,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(bcast_double_precision,30,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(bcast_logical,33,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(LOCAL_PATH,150,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(MODEL,150,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(ner,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ratio_sampling_array,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(doubling_index,MAX_NUMBER_OF_MESH_LAYERS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(r_bottom,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(r_top,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(rmins,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(rmaxs,MAX_NUMBER_OF_MESH_LAYERS,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(this_region_has_a_doubling,MAX_NUMBER_OF_MESH_LAYERS,MPI_LOGICAL,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(NSPEC_computed,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_XI,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_ETA,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2DMAX_XMIN_XMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2DMAX_YMIN_YMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_BOTTOM,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC2D_TOP,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NSPEC1D_RADIAL,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB1D_RADIAL,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB2DMAX_XMIN_XMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB2DMAX_YMIN_YMAX,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(NGLOB_computed,MAX_NUM_REGIONS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(DIFF_NSPEC1D_RADIAL,NB_SQUARE_CORNERS*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(DIFF_NSPEC2D_ETA,NB_SQUARE_EDGES_ONEDIR*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(DIFF_NSPEC2D_XI,NB_SQUARE_EDGES_ONEDIR*NB_CUT_CASE,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ if (myrank /=0) then
+
+ MIN_ATTENUATION_PERIOD = bcast_integer(1)
+ MAX_ATTENUATION_PERIOD = bcast_integer(2)
+ NER_CRUST = bcast_integer(3)
+ NER_80_MOHO = bcast_integer(4)
+ NER_220_80 = bcast_integer(5)
+ NER_400_220 = bcast_integer(6)
+ NER_600_400 = bcast_integer(7)
+ NER_670_600 = bcast_integer(8)
+ NER_771_670 = bcast_integer(9)
+ NER_TOPDDOUBLEPRIME_771 = bcast_integer(10)
+ NER_CMB_TOPDDOUBLEPRIME = bcast_integer(11)
+ NER_OUTER_CORE = bcast_integer(12)
+ NER_TOP_CENTRAL_CUBE_ICB = bcast_integer(13)
+ NEX_XI = bcast_integer(14)
+ NEX_ETA = bcast_integer(15)
+ RMOHO_FICTITIOUS_IN_MESHER = bcast_integer(16)
+ NPROC_XI = bcast_integer(17)
+ NPROC_ETA = bcast_integer(18)
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS = bcast_integer(19)
+ NTSTEP_BETWEEN_READ_ADJSRC = bcast_integer(20)
+ NSTEP = bcast_integer(21)
+ NSOURCES = bcast_integer(22)
+ NTSTEP_BETWEEN_FRAMES = bcast_integer(23)
+ NTSTEP_BETWEEN_OUTPUT_INFO = bcast_integer(24)
+ NUMBER_OF_RUNS = bcast_integer(25)
+ NUMBER_OF_THIS_RUN = bcast_integer(26)
+ NCHUNKS = bcast_integer(27)
+ SIMULATION_TYPE = bcast_integer(28)
+ REFERENCE_1D_MODEL = bcast_integer(29)
+ THREE_D_MODEL = bcast_integer(30)
+ NPROC = bcast_integer(31)
+ NPROCTOT = bcast_integer(32)
+ NEX_PER_PROC_XI = bcast_integer(33)
+ NEX_PER_PROC_ETA = bcast_integer(34)
+ ratio_divide_central_cube = bcast_integer(35)
+ MOVIE_VOLUME_TYPE = bcast_integer(36)
+ MOVIE_START = bcast_integer(37)
+ MOVIE_STOP = bcast_integer(38)
+
+ TRANSVERSE_ISOTROPY = bcast_logical(1)
+ ANISOTROPIC_3D_MANTLE = bcast_logical(2)
+ ANISOTROPIC_INNER_CORE = bcast_logical(3)
+ CRUSTAL = bcast_logical(4)
+ ELLIPTICITY = bcast_logical(5)
+ GRAVITY = bcast_logical(6)
+ ONE_CRUST = bcast_logical(7)
+ ROTATION = bcast_logical(8)
+ ISOTROPIC_3D_MANTLE = bcast_logical(9)
+ TOPOGRAPHY = bcast_logical(10)
+ OCEANS = bcast_logical(11)
+ MOVIE_SURFACE = bcast_logical(12)
+ MOVIE_VOLUME = bcast_logical(13)
+ MOVIE_VOLUME_COARSE = bcast_logical(14)
+ ATTENUATION_3D = bcast_logical(15)
+ RECEIVERS_CAN_BE_BURIED = bcast_logical(16)
+ PRINT_SOURCE_TIME_FUNCTION = bcast_logical(17)
+ SAVE_MESH_FILES = bcast_logical(18)
+ ATTENUATION = bcast_logical(19)
+ ABSORBING_CONDITIONS = bcast_logical(20)
+ INCLUDE_CENTRAL_CUBE = bcast_logical(21)
+ INFLATE_CENTRAL_CUBE = bcast_logical(22)
+ SAVE_FORWARD = bcast_logical(23)
+ CASE_3D = bcast_logical(24)
+ OUTPUT_SEISMOS_ASCII_TEXT = bcast_logical(25)
+ OUTPUT_SEISMOS_SAC_ALPHANUM = bcast_logical(26)
+ OUTPUT_SEISMOS_SAC_BINARY = bcast_logical(27)
+ ROTATE_SEISMOGRAMS_RT = bcast_logical(28)
+ CUT_SUPERBRICK_XI = bcast_logical(29)
+ CUT_SUPERBRICK_ETA = bcast_logical(30)
+ WRITE_SEISMOGRAMS_BY_MASTER = bcast_logical(31)
+ SAVE_ALL_SEISMOS_IN_ONE_FILE = bcast_logical(32)
+ USE_BINARY_FOR_LARGE_FILE = bcast_logical(33)
+
+ DT = bcast_double_precision(1)
+ ANGULAR_WIDTH_XI_IN_DEGREES = bcast_double_precision(2)
+ ANGULAR_WIDTH_ETA_IN_DEGREES = bcast_double_precision(3)
+ CENTER_LONGITUDE_IN_DEGREES = bcast_double_precision(4)
+ CENTER_LATITUDE_IN_DEGREES = bcast_double_precision(5)
+ GAMMA_ROTATION_AZIMUTH = bcast_double_precision(6)
+ ROCEAN = bcast_double_precision(7)
+ RMIDDLE_CRUST = bcast_double_precision(8)
+ RMOHO = bcast_double_precision(9)
+ R80 = bcast_double_precision(10)
+ R120 = bcast_double_precision(11)
+ R220 = bcast_double_precision(12)
+ R400 = bcast_double_precision(13)
+ R600 = bcast_double_precision(14)
+ R670 = bcast_double_precision(15)
+ R771 = bcast_double_precision(16)
+ RTOPDDOUBLEPRIME = bcast_double_precision(17)
+ RCMB = bcast_double_precision(18)
+ RICB = bcast_double_precision(19)
+ R_CENTRAL_CUBE = bcast_double_precision(20)
+ RHO_TOP_OC = bcast_double_precision(21)
+ RHO_BOTTOM_OC = bcast_double_precision(22)
+ RHO_OCEANS = bcast_double_precision(23)
+ HDUR_MOVIE = bcast_double_precision(24)
+ MOVIE_TOP = bcast_double_precision(25)
+ MOVIE_BOTTOM = bcast_double_precision(26)
+ MOVIE_WEST = bcast_double_precision(27)
+ MOVIE_EAST = bcast_double_precision(28)
+ MOVIE_NORTH = bcast_double_precision(29)
+ MOVIE_SOUTH = bcast_double_precision(30)
+
+ endif
+
+! if running on MareNostrum in Barcelona
+ if(RUN_ON_MARENOSTRUM_BARCELONA) then
+
+! check that we combine the seismograms in one large file to avoid GPFS overloading
+ if(.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) call exit_MPI(myrank,'should use SAVE_ALL_SEISMOS_IN_ONE_FILE for GPFS in Barcelona')
+
+! use the local scratch disk to save all the files, ignore the path that is given in the Par_file
+ LOCAL_PATH = '/scratch/komatits_new'
+
+! add processor name to local /scratch/komatits_new path
+ write(system_command,"('_proc',i4.4)") myrank
+ LOCAL_PATH = trim(LOCAL_PATH) // trim(system_command)
+
+ endif
+
+! check simulation pararmeters
+ if (SIMULATION_TYPE /= 1 .and. SIMULATION_TYPE /= 2 .and. SIMULATION_TYPE /= 3) &
+ call exit_MPI(myrank, 'SIMULATION_TYPE could be only 1, 2, or 3')
+
+ if (SIMULATION_TYPE /= 1 .and. NSOURCES > 999999) &
+ call exit_MPI(myrank, 'for adjoint simulations, NSOURCES <= 999999, if you need more change i6.6 in write_seismograms.f90')
+
+ if (ATTENUATION_VAL .or. SIMULATION_TYPE /= 1 .or. SAVE_FORWARD .or. (MOVIE_VOLUME .and. SIMULATION_TYPE /= 3)) then
+ COMPUTE_AND_STORE_STRAIN = .true.
+ else
+ COMPUTE_AND_STORE_STRAIN = .false.
+ endif
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! open main output file, only written to by process 0
+ if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) &
+ open(unit=IMAIN,file=trim(OUTPUT_FILES)//'/output_solver.txt',status='unknown')
+
+ if(myrank == 0) then
+
+ write(IMAIN,*)
+ write(IMAIN,*) '******************************'
+ write(IMAIN,*) '**** Specfem3D MPI Solver ****'
+ write(IMAIN,*) '******************************'
+ write(IMAIN,*)
+ write(IMAIN,*)
+
+ if(FIX_UNDERFLOW_PROBLEM) write(IMAIN,*) 'Fixing slow underflow trapping problem using small initial field'
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',sizeprocs,' MPI processes'
+ write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
+ write(IMAIN,*)
+
+ write(IMAIN,*) 'There are ',NEX_XI,' elements along xi in each chunk'
+ write(IMAIN,*) 'There are ',NEX_ETA,' elements along eta in each chunk'
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',NPROC_XI,' slices along xi in each chunk'
+ write(IMAIN,*) 'There are ',NPROC_ETA,' slices along eta in each chunk'
+ write(IMAIN,*) 'There is a total of ',NPROC,' slices in each chunk'
+ write(IMAIN,*) 'There are ',NCHUNKS,' chunks'
+ write(IMAIN,*) 'There is a total of ',NPROCTOT,' slices in all the chunks'
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'NDIM = ',NDIM
+ write(IMAIN,*)
+ write(IMAIN,*) 'NGLLX = ',NGLLX
+ write(IMAIN,*) 'NGLLY = ',NGLLY
+ write(IMAIN,*) 'NGLLZ = ',NGLLZ
+ write(IMAIN,*)
+
+! write information about precision used for floating-point operations
+ if(CUSTOM_REAL == SIZE_REAL) then
+ write(IMAIN,*) 'using single precision for the calculations'
+ else
+ write(IMAIN,*) 'using double precision for the calculations'
+ endif
+ write(IMAIN,*)
+ write(IMAIN,*) 'smallest and largest possible floating-point numbers are: ',tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
+ write(IMAIN,*)
+
+ endif
+
+! check that the code is running with the requested nb of processes
+ if(sizeprocs /= NPROCTOT) call exit_MPI(myrank,'wrong number of MPI processes')
+
+!! DK DK added this
+ if(OCEANS) call exit_MPI(myrank,'DK DK je crois que j ai enleve les oceans par erreur, les remettre')
+
+! check that the code has been compiled with the right values
+ if (NSPEC_computed(IREGION_CRUST_MANTLE) /= NSPEC_CRUST_MANTLE) then
+ write(IMAIN,*) NSPEC_computed(IREGION_CRUST_MANTLE),NSPEC_CRUST_MANTLE
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 1')
+ endif
+ if (NSPEC_computed(IREGION_OUTER_CORE) /= NSPEC_OUTER_CORE) then
+ write(IMAIN,*) NSPEC_computed(IREGION_OUTER_CORE),NSPEC_OUTER_CORE
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 2')
+ endif
+ if (NSPEC_computed(IREGION_INNER_CORE) /= NSPEC_INNER_CORE) then
+ write(IMAIN,*) NSPEC_computed(IREGION_INNER_CORE),NSPEC_INNER_CORE
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 3')
+ endif
+ if (ATTENUATION_3D .NEQV. ATTENUATION_3D_VAL) then
+ write(IMAIN,*) ATTENUATION_3D,ATTENUATION_3D_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 4')
+ endif
+ if (NCHUNKS /= NCHUNKS_VAL) then
+ write(IMAIN,*) NCHUNKS,NCHUNKS_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 6')
+ endif
+ if (GRAVITY .NEQV. GRAVITY_VAL) then
+ write(IMAIN,*) GRAVITY,GRAVITY_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 7')
+ endif
+ if (ROTATION .NEQV. ROTATION_VAL) then
+ write(IMAIN,*) ROTATION,ROTATION_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 8')
+ endif
+ if (ATTENUATION .NEQV. ATTENUATION_VAL) then
+ write(IMAIN,*) ATTENUATION,ATTENUATION_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 9')
+ endif
+ if (ELLIPTICITY .NEQV. ELLIPTICITY_VAL) then
+ write(IMAIN,*) ELLIPTICITY,ELLIPTICITY_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 10')
+ endif
+ if (NPROCTOT /= NPROCTOT_VAL) then
+ write(IMAIN,*) NPROCTOT,NPROCTOT_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 11')
+ endif
+ if (NEX_XI /= NEX_XI_VAL) then
+ write(IMAIN,*) NEX_XI,NEX_XI_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 12')
+ endif
+ if (NEX_ETA /= NEX_ETA_VAL) then
+ write(IMAIN,*) NEX_ETA,NEX_ETA_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 13')
+ endif
+ if (TRANSVERSE_ISOTROPY .NEQV. TRANSVERSE_ISOTROPY_VAL) then
+ write(IMAIN,*) TRANSVERSE_ISOTROPY,TRANSVERSE_ISOTROPY_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 14')
+ endif
+ if (ANISOTROPIC_3D_MANTLE .NEQV. ANISOTROPIC_3D_MANTLE_VAL) then
+ write(IMAIN,*) ANISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 15')
+ endif
+ if (ANISOTROPIC_INNER_CORE .NEQV. ANISOTROPIC_INNER_CORE_VAL) then
+ write(IMAIN,*) ANISOTROPIC_INNER_CORE,ANISOTROPIC_INNER_CORE_VAL
+ call exit_MPI(myrank,'error in compiled parameters, please recompile solver 16')
+ endif
+
+! determine chunk number and local slice coordinates using addressing
+ ichunk = ichunk_slice(myrank)
+ iproc_xi = iproc_xi_slice(myrank)
+ iproc_eta = iproc_eta_slice(myrank)
+
+! make ellipticity
+ if(ELLIPTICITY_VAL) call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
+
+! define maximum size for message buffers
+! use number of elements found in the mantle since it is the largest region
+ NGLOB2DMAX_XY = max(NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE))
+
+! number of corners and faces shared between chunks and number of message types
+ if(NCHUNKS_VAL == 1 .or. NCHUNKS_VAL == 2) then
+ NCORNERSCHUNKS = 1
+ NUM_FACES = 1
+ NUM_MSG_TYPES = 1
+ else if(NCHUNKS_VAL == 3) then
+ NCORNERSCHUNKS = 1
+ NUM_FACES = 1
+ NUM_MSG_TYPES = 3
+ else if(NCHUNKS_VAL == 6) then
+ NCORNERSCHUNKS = 8
+ NUM_FACES = 4
+ NUM_MSG_TYPES = 3
+ else
+ call exit_MPI(myrank,'number of chunks must be either 1, 2, 3 or 6')
+ endif
+
+! if more than one chunk then same number of processors in each direction
+ NPROC_ONE_DIRECTION = NPROC_XI
+
+! total number of messages corresponding to these common faces
+ NUMMSGS_FACES = NPROC_ONE_DIRECTION*NUM_FACES*NUM_MSG_TYPES
+
+! start reading the databases
+
+! read arrays created by the mesher
+
+! crust and mantle
+
+ if(ANISOTROPIC_3D_MANTLE_VAL) then
+ READ_KAPPA_MU = .false.
+ READ_TISO = .false.
+ nspec_iso = 1
+ nspec_tiso = 1
+ nspec_ani = NSPEC_CRUST_MANTLE
+ else
+ nspec_iso = NSPEC_CRUST_MANTLE
+ if(TRANSVERSE_ISOTROPY_VAL) then
+ nspec_tiso = NSPECMAX_TISO_MANTLE
+ else
+ nspec_tiso = 1
+ endif
+ nspec_ani = 1
+ READ_KAPPA_MU = .true.
+ READ_TISO = .true.
+ endif
+
+! outer core (no anisotropy nor S velocity)
+! rmass_ocean_load is not used in this routine because it is meaningless in the outer core
+ READ_KAPPA_MU = .false.
+ READ_TISO = .false.
+ nspec_iso = NSPEC_OUTER_CORE
+ nspec_tiso = 1
+ nspec_ani = 1
+
+! inner core (no anisotropy)
+! rmass_ocean_load is not used in this routine because it is meaningless in the inner core
+ READ_KAPPA_MU = .true.
+ READ_TISO = .false.
+ nspec_iso = NSPEC_INNER_CORE
+ nspec_tiso = 1
+ if(ANISOTROPIC_INNER_CORE_VAL) then
+ nspec_ani = NSPEC_INNER_CORE
+ else
+ nspec_ani = 1
+ endif
+
+! check that the number of points in this slice is correct
+
+ if(minval(ibool_crust_mantle(:,:,:,:)) /= 1 .or. &
+ maxval(ibool_crust_mantle(:,:,:,:)) /= NGLOB_CRUST_MANTLE) &
+ call exit_MPI(myrank,'incorrect global numbering: iboolmax does not equal nglob in crust and mantle')
+
+ if(minval(ibool_outer_core(:,:,:,:)) /= 1 .or. &
+ maxval(ibool_outer_core(:,:,:,:)) /= NGLOB_OUTER_CORE) &
+ call exit_MPI(myrank,'incorrect global numbering: iboolmax does not equal nglob in outer core')
+
+ if(minval(ibool_inner_core(:,:,:,:)) /= 1 .or. maxval(ibool_inner_core(:,:,:,:)) /= NGLOB_INNER_CORE) &
+ call exit_MPI(myrank,'incorrect global numbering: iboolmax does not equal nglob in inner core')
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! set up GLL points, weights and derivation matrices
+ call define_derivation_matrices(xigll,yigll,zigll,wxgll,wygll,wzgll, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube)
+
+! allocate arrays for source
+ allocate(islice_selected_source(NSOURCES))
+ allocate(ispec_selected_source(NSOURCES))
+ allocate(Mxx(NSOURCES))
+ allocate(Myy(NSOURCES))
+ allocate(Mzz(NSOURCES))
+ allocate(Mxy(NSOURCES))
+ allocate(Mxz(NSOURCES))
+ allocate(Myz(NSOURCES))
+ allocate(xi_source(NSOURCES))
+ allocate(eta_source(NSOURCES))
+ allocate(gamma_source(NSOURCES))
+ allocate(t_cmt(NSOURCES))
+ allocate(hdur(NSOURCES))
+ allocate(hdur_gaussian(NSOURCES))
+ allocate(theta_source(NSOURCES))
+ allocate(phi_source(NSOURCES))
+ allocate(nu_source(NDIM,NDIM,NSOURCES))
+
+! locate sources in the mesh
+ call locate_sources(NSOURCES,myrank,NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE,ibool_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xigll,yigll,zigll,NPROCTOT,ELLIPTICITY,TOPOGRAPHY, &
+ sec,t_cmt,yr,jda,ho,mi,theta_source,phi_source, &
+ NSTEP,DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ islice_selected_source,ispec_selected_source, &
+ xi_source,eta_source,gamma_source, nu_source,&
+ rspl,espl,espl2,nspl,ibathy_topo,NEX_XI,PRINT_SOURCE_TIME_FUNCTION)
+
+ if(minval(t_cmt) /= 0.) call exit_MPI(myrank,'one t_cmt must be zero, others must be positive')
+
+! convert the half duration for triangle STF to the one for gaussian STF
+ hdur_gaussian = hdur/SOURCE_DECAY_MIMIC_TRIANGLE
+
+! define t0 as the earliest start time
+ t0 = - 1.5d0*minval(t_cmt-hdur)
+
+! --------- receivers ---------------
+ rec_filename = 'DATA/STATIONS'
+ call get_value_string(STATIONS, 'solver.STATIONS', rec_filename)
+! get total number of receivers
+ if(myrank == 0) then
+ open(unit=IIN,file=STATIONS,iostat=ios,status='old',action='read')
+ nrec = 0
+ do while(ios == 0)
+ read(IIN,"(a)",iostat=ios) dummystring
+ if(ios == 0) nrec = nrec + 1
+ enddo
+ close(IIN)
+ endif
+! broadcast the information read on the master to the nodes
+ call MPI_BCAST(nrec,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Total number of receivers = ', nrec
+ write(IMAIN,*)
+ endif
+
+ if(nrec < 1) call exit_MPI(myrank,'need at least one receiver')
+
+! allocate memory for receiver arrays
+ allocate(islice_selected_rec(nrec))
+ allocate(ispec_selected_rec(nrec))
+ allocate(xi_receiver(nrec))
+ allocate(eta_receiver(nrec))
+ allocate(gamma_receiver(nrec))
+ allocate(station_name(nrec))
+ allocate(network_name(nrec))
+ allocate(stlat(nrec))
+ allocate(stlon(nrec))
+ allocate(stele(nrec))
+ allocate(nu(NDIM,NDIM,nrec))
+
+! locate receivers in the crust in the mesh
+ call locate_receivers(myrank,DT,NSTEP,NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE,ibool_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xigll,yigll,zigll,trim(rec_filename), &
+ nrec,islice_selected_rec,ispec_selected_rec, &
+ xi_receiver,eta_receiver,gamma_receiver,station_name,network_name,stlat,stlon,stele,nu, &
+ yr,jda,ho,mi,sec, &
+ NPROCTOT,ELLIPTICITY,TOPOGRAPHY, &
+ theta_source(1),phi_source(1),rspl,espl,espl2,nspl,ibathy_topo,RECEIVERS_CAN_BE_BURIED,NCHUNKS)
+
+!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+! ---- source array
+
+ allocate(sourcearrays(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ))
+ do isource = 1,NSOURCES
+
+! check that the source slice number is okay
+ if(islice_selected_source(isource) < 0 .or. islice_selected_source(isource) > NPROCTOT-1) &
+ call exit_MPI(myrank,'something is wrong with the source slice number')
+
+! compute source arrays in source slice
+ if(myrank == islice_selected_source(isource)) then
+ call compute_arrays_source(ispec_selected_source(isource), &
+ xi_source(isource),eta_source(isource),gamma_source(isource),sourcearray, &
+ Mxx(isource),Myy(isource),Mzz(isource),Mxy(isource),Mxz(isource),Myz(isource), &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ xigll,yigll,zigll,NSPEC_CRUST_MANTLE)
+ sourcearrays(isource,:,:,:,:) = sourcearray(:,:,:,:)
+ endif
+ enddo
+
+!--- select local receivers
+
+! count number of receivers located in this slice
+ nrec_local = 0
+ do irec = 1,nrec
+ if(myrank == islice_selected_rec(irec)) nrec_local = nrec_local + 1
+ enddo
+
+ if (nrec_local > 0) then
+
+! allocate Lagrange interpolators for receivers
+ allocate(hxir_store(nrec_local,NGLLX))
+ allocate(hetar_store(nrec_local,NGLLY))
+ allocate(hgammar_store(nrec_local,NGLLZ))
+
+! define local to global receiver numbering mapping
+ allocate(number_receiver_global(nrec_local))
+ irec_local = 0
+ do irec = 1,nrec
+ if(myrank == islice_selected_rec(irec)) then
+ irec_local = irec_local + 1
+ number_receiver_global(irec_local) = irec
+ endif
+ enddo
+
+! define and store Lagrange interpolators at all the receivers
+ do irec_local = 1,nrec_local
+ irec = number_receiver_global(irec_local)
+ call lagrange_any(xi_receiver(irec),NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(eta_receiver(irec),NGLLY,yigll,hetar,hpetar)
+ call lagrange_any(gamma_receiver(irec),NGLLZ,zigll,hgammar,hpgammar)
+ hxir_store(irec_local,:) = hxir(:)
+ hetar_store(irec_local,:) = hetar(:)
+ hgammar_store(irec_local,:) = hgammar(:)
+ enddo
+
+ endif ! nrec_local
+
+! check that the sum of the number of receivers in each slice is nrec
+ call MPI_REDUCE(nrec_local,nrec_tot_found,1,MPI_INTEGER,MPI_SUM,0,MPI_COMM_WORLD,ier)
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'found a total of ',nrec_tot_found,' receivers in all the slices'
+ if(nrec_tot_found /= nrec) then
+ call exit_MPI(myrank,'problem when dispatching the receivers')
+ else
+ write(IMAIN,*) 'this total is okay'
+ endif
+ endif
+
+ if(myrank == 0) then
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'Total number of samples for seismograms = ',NSTEP
+ write(IMAIN,*)
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'Reference radius of the Earth used is ',R_EARTH_KM,' km'
+ write(IMAIN,*)
+
+ if(NSOURCES > 1) write(IMAIN,*) 'Using ',NSOURCES,' point sources'
+
+ write(IMAIN,*)
+ if(ELLIPTICITY_VAL) then
+ write(IMAIN,*) 'incorporating ellipticity'
+ else
+ write(IMAIN,*) 'no ellipticity'
+ endif
+
+ write(IMAIN,*)
+ if(TOPOGRAPHY) then
+ write(IMAIN,*) 'incorporating surface topography'
+ else
+ write(IMAIN,*) 'no surface topography'
+ endif
+
+ write(IMAIN,*)
+ if(ISOTROPIC_3D_MANTLE) then
+ write(IMAIN,*) 'incorporating 3-D lateral variations'
+ else
+ write(IMAIN,*) 'no 3-D lateral variations'
+ endif
+
+ write(IMAIN,*)
+ if(CRUSTAL) then
+ write(IMAIN,*) 'incorporating crustal variations'
+ else
+ write(IMAIN,*) 'no crustal variations'
+ endif
+
+ write(IMAIN,*)
+ if(ONE_CRUST) then
+ write(IMAIN,*) 'using one layer only in PREM crust'
+ else
+ write(IMAIN,*) 'using unmodified 1D crustal model with two layers'
+ endif
+
+ write(IMAIN,*)
+ if(GRAVITY_VAL) then
+ write(IMAIN,*) 'incorporating self-gravitation (Cowling approximation)'
+ else
+ write(IMAIN,*) 'no self-gravitation'
+ endif
+
+ write(IMAIN,*)
+ if(ROTATION_VAL) then
+ write(IMAIN,*) 'incorporating rotation'
+ else
+ write(IMAIN,*) 'no rotation'
+ endif
+
+ write(IMAIN,*)
+ if(TRANSVERSE_ISOTROPY_VAL) then
+ write(IMAIN,*) 'incorporating transverse isotropy'
+ else
+ write(IMAIN,*) 'no transverse isotropy'
+ endif
+
+ write(IMAIN,*)
+ if(ATTENUATION_VAL) then
+ write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids'
+ if(ATTENUATION_3D_VAL) write(IMAIN,*) 'using 3D attenuation'
+ else
+ write(IMAIN,*) 'no attenuation'
+ endif
+
+ write(IMAIN,*)
+ if(OCEANS) then
+ write(IMAIN,*) 'incorporating the oceans using equivalent load'
+ else
+ write(IMAIN,*) 'no oceans'
+ endif
+
+ write(IMAIN,*)
+ if(ANISOTROPIC_INNER_CORE_VAL) then
+ write(IMAIN,*) 'incorporating anisotropic inner core'
+ else
+ write(IMAIN,*) 'no inner-core anisotropy'
+ endif
+
+ write(IMAIN,*)
+ if(ANISOTROPIC_3D_MANTLE_VAL) then
+ write(IMAIN,*) 'incorporating anisotropic mantle'
+ else
+ write(IMAIN,*) 'no general mantle anisotropy'
+ endif
+ write(IMAIN,*)
+ write(IMAIN,*)
+ write(IMAIN,*)
+
+ endif
+
+! synchronize all the processes before assembling the mass matrix
+! to make sure all the nodes have finished to read their databases
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+! the mass matrix needs to be assembled with MPI here once and for all
+
+! ocean load
+ if (OCEANS) then
+ call assemble_MPI_scalar(myrank,rmass_ocean_load,NGLOB_CRUST_MANTLE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
+ buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_XY,NCHUNKS)
+ endif
+
+! crust and mantle
+ call assemble_MPI_scalar(myrank,rmass_crust_mantle,NGLOB_CRUST_MANTLE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
+ buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_XY,NCHUNKS)
+
+! outer core
+ call assemble_MPI_scalar(myrank,rmass_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
+ buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE),NGLOB2DMAX_XY,NCHUNKS)
+
+! inner core
+ call assemble_MPI_scalar(myrank,rmass_inner_core,NGLOB_INNER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
+ buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_INNER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE),NGLOB2DMAX_XY,NCHUNKS)
+
+ if(myrank == 0) write(IMAIN,*) 'end assembling MPI mass matrix'
+
+!
+!--- handle the communications with the central cube if it was included in the mesh
+!
+ if(INCLUDE_CENTRAL_CUBE) then
+
+ if(myrank == 0) write(IMAIN,*) 'including central cube'
+
+! compute number of messages to expect in cube as well as their size
+ call comp_central_cube_buffer_size(iproc_xi,iproc_eta,ichunk,NPROC_XI,NPROC_ETA,NSPEC2D_BOTTOM(IREGION_INNER_CORE), &
+ nb_msgs_theor_in_cube,npoin2D_cube_from_slices)
+
+! this value is used for dynamic memory allocation, therefore make sure it is never zero
+ if(nb_msgs_theor_in_cube > 0) then
+ non_zero_nb_msgs_theor_in_cube = nb_msgs_theor_in_cube
+ else
+ non_zero_nb_msgs_theor_in_cube = 1
+ endif
+
+! allocate buffers for cube and slices
+ allocate(sender_from_slices_to_cube(non_zero_nb_msgs_theor_in_cube))
+ allocate(buffer_all_cube_from_slices(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM))
+ allocate(buffer_slices(npoin2D_cube_from_slices,NDIM))
+ allocate(buffer_slices2(npoin2D_cube_from_slices,NDIM))
+ allocate(ibool_central_cube(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices))
+
+! create buffers to assemble with the central cube
+ call create_central_cube_buffers(myrank,iproc_xi,iproc_eta,ichunk, &
+ NPROC_XI,NPROC_ETA,NCHUNKS,NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
+ NSPEC2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NSPEC2DMAX_YMIN_YMAX(IREGION_INNER_CORE), &
+ NSPEC2D_BOTTOM(IREGION_INNER_CORE), &
+ addressing,ibool_inner_core,idoubling_inner_core, &
+ xstore_inner_core,ystore_inner_core,zstore_inner_core, &
+ nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
+ ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
+ nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices, &
+ receiver_cube_from_slices,sender_from_slices_to_cube,ibool_central_cube, &
+ buffer_slices,buffer_slices2,buffer_all_cube_from_slices)
+
+ if(myrank == 0) write(IMAIN,*) 'done including central cube'
+
+! the mass matrix to assemble is a scalar, not a vector
+ ndim_assemble = 1
+
+! use these buffers to assemble the inner core mass matrix with the central cube
+ call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube, sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices, buffer_all_cube_from_slices, buffer_slices, buffer_slices2, ibool_central_cube, &
+ receiver_cube_from_slices, ibool_inner_core, idoubling_inner_core, NSPEC_INNER_CORE, &
+ ibelm_bottom_inner_core, NSPEC2D_BOTTOM(IREGION_INNER_CORE),NGLOB_INNER_CORE,rmass_inner_core,ndim_assemble)
+
+! suppress fictitious mass matrix elements in central cube
+! because the slices do not compute all their spectral elements in the cube
+ where(rmass_inner_core(:) <= 0.) rmass_inner_core = 1.
+
+ endif ! end of handling the communications with the central cube
+
+! check that all the mass matrices are positive
+ if(minval(rmass_crust_mantle) <= 0. .or. minval(rmass_inner_core) <= 0. .or. minval(rmass_outer_core) <= 0.) &
+ call exit_MPI(myrank,'negative mass matrix term for at least one region')
+
+ if(OCEANS) then
+ if(minval(rmass_ocean_load) <= 0.) call exit_MPI(myrank,'negative mass matrix term for the oceans')
+ endif
+
+! for efficiency, invert final mass matrix once and for all on each slice
+ if(OCEANS) rmass_ocean_load = 1._CUSTOM_REAL / rmass_ocean_load
+ rmass_crust_mantle = 1._CUSTOM_REAL / rmass_crust_mantle
+ rmass_outer_core = 1._CUSTOM_REAL / rmass_outer_core
+ rmass_inner_core = 1._CUSTOM_REAL / rmass_inner_core
+
+! change x, y, z to r, theta and phi once and for all
+! IMPROVE dangerous: old name kept (xstore ystore zstore) for new values
+
+! convert in the crust and mantle
+ do iglob = 1,NGLOB_CRUST_MANTLE
+ call xyz_2_rthetaphi(xstore_crust_mantle(iglob), &
+ ystore_crust_mantle(iglob),zstore_crust_mantle(iglob),rval,thetaval,phival)
+ xstore_crust_mantle(iglob) = rval
+ ystore_crust_mantle(iglob) = thetaval
+ zstore_crust_mantle(iglob) = phival
+ enddo
+
+! convert in the outer core
+ do iglob = 1,NGLOB_OUTER_CORE
+ call xyz_2_rthetaphi(xstore_outer_core(iglob), &
+ ystore_outer_core(iglob),zstore_outer_core(iglob),rval,thetaval,phival)
+ xstore_outer_core(iglob) = rval
+ ystore_outer_core(iglob) = thetaval
+ zstore_outer_core(iglob) = phival
+ enddo
+
+! convert in the inner core
+ do iglob = 1,NGLOB_INNER_CORE
+ call xyz_2_rthetaphi(xstore_inner_core(iglob), &
+ ystore_inner_core(iglob),zstore_inner_core(iglob),rval,thetaval,phival)
+ xstore_inner_core(iglob) = rval
+ ystore_inner_core(iglob) = thetaval
+ zstore_inner_core(iglob) = phival
+ enddo
+
+ if(ATTENUATION_VAL) then
+
+! get and store PREM attenuation model
+
+ call create_name_database(prname, myrank, IREGION_CRUST_MANTLE, LOCAL_PATH)
+ call get_attenuation_model_1D(myrank, prname, IREGION_CRUST_MANTLE, tau_sigma_dble, &
+ omsb_crust_mantle_dble, factor_common_crust_mantle_dble, &
+ factor_scale_crust_mantle_dble, NRAD_ATTENUATION,1,1,1, AM_V)
+ omsb_inner_core_dble(:,:,:,1:min(ATT4,ATT5)) = omsb_crust_mantle_dble(:,:,:,1:min(ATT4,ATT5))
+ factor_scale_inner_core_dble(:,:,:,1:min(ATT4,ATT5)) = factor_scale_crust_mantle_dble(:,:,:,1:min(ATT4,ATT5))
+ factor_common_inner_core_dble(:,:,:,:,1:min(ATT4,ATT5)) = factor_common_crust_mantle_dble(:,:,:,:,1:min(ATT4,ATT5))
+ ! Tell the Attenuation Code about the IDOUBLING regions within the Mesh
+ call set_attenuation_regions_1D(RICB, RCMB, R670, R220, R80, AM_V)
+
+ if(CUSTOM_REAL == SIZE_REAL) then
+ factor_scale_crust_mantle = sngl(factor_scale_crust_mantle_dble)
+ one_minus_sum_beta_crust_mantle = sngl(omsb_crust_mantle_dble)
+ factor_common_crust_mantle = sngl(factor_common_crust_mantle_dble)
+
+ factor_scale_inner_core = sngl(factor_scale_inner_core_dble)
+ one_minus_sum_beta_inner_core = sngl(omsb_inner_core_dble)
+ factor_common_inner_core = sngl(factor_common_inner_core_dble)
+ else
+ factor_scale_crust_mantle = factor_scale_crust_mantle_dble
+ one_minus_sum_beta_crust_mantle = omsb_crust_mantle_dble
+ factor_common_crust_mantle = factor_common_crust_mantle_dble
+
+ factor_scale_inner_core = factor_scale_inner_core_dble
+ one_minus_sum_beta_inner_core = omsb_inner_core_dble
+ factor_common_inner_core = factor_common_inner_core_dble
+ endif
+
+! if attenuation is on, shift PREM to right frequency
+! rescale mu in PREM to average frequency for attenuation
+! the formulas to implement the scaling can be found for instance in
+! Liu, H. P., Anderson, D. L. and Kanamori, H., Velocity dispersion due to
+! anelasticity: implications for seismology and mantle composition,
+! Geophys. J. R. Astron. Soc., vol. 47, pp. 41-58 (1976)
+! and in Aki, K. and Richards, P. G., Quantitative seismology, theory and methods,
+! W. H. Freeman, (1980), second edition, sections 5.5 and 5.5.2, eq. (5.81) p. 170
+
+! rescale in crust and mantle
+
+ do ispec = 1,NSPEC_CRUST_MANTLE
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+! ATTENUATION_3D get scale_factor
+ if(ATTENUATION_3D_VAL) then
+ ! tau_mu and tau_sigma need to reference a point in the mesh
+ scale_factor = factor_scale_crust_mantle(i,j,k,ispec)
+ else
+ iglob = ibool_crust_mantle(i,j,k,ispec)
+ dist_cr = xstore_crust_mantle(iglob)
+ call get_attenuation_index(idoubling_crust_mantle(ispec), dble(dist_cr), iregion_selected, .FALSE., AM_V)
+ scale_factor = factor_scale_crust_mantle(1,1,1,iregion_selected)
+ endif ! ATTENUATION_3D
+
+ if(ANISOTROPIC_3D_MANTLE_VAL) then
+ scale_factor_minus_one = scale_factor - 1.
+ mul = c44store_crust_mantle(i,j,k,ispec)
+ c11store_crust_mantle(i,j,k,ispec) = c11store_crust_mantle(i,j,k,ispec) &
+ + FOUR_THIRDS * scale_factor_minus_one * mul
+ c12store_crust_mantle(i,j,k,ispec) = c12store_crust_mantle(i,j,k,ispec) &
+ - TWO_THIRDS * scale_factor_minus_one * mul
+ c13store_crust_mantle(i,j,k,ispec) = c13store_crust_mantle(i,j,k,ispec) &
+ - TWO_THIRDS * scale_factor_minus_one * mul
+ c22store_crust_mantle(i,j,k,ispec) = c22store_crust_mantle(i,j,k,ispec) &
+ + FOUR_THIRDS * scale_factor_minus_one * mul
+ c23store_crust_mantle(i,j,k,ispec) = c23store_crust_mantle(i,j,k,ispec) &
+ - TWO_THIRDS * scale_factor_minus_one * mul
+ c33store_crust_mantle(i,j,k,ispec) = c33store_crust_mantle(i,j,k,ispec) &
+ + FOUR_THIRDS * scale_factor_minus_one * mul
+ c44store_crust_mantle(i,j,k,ispec) = c44store_crust_mantle(i,j,k,ispec) &
+ + scale_factor_minus_one * mul
+ c55store_crust_mantle(i,j,k,ispec) = c55store_crust_mantle(i,j,k,ispec) &
+ + scale_factor_minus_one * mul
+ c66store_crust_mantle(i,j,k,ispec) = c66store_crust_mantle(i,j,k,ispec) &
+ + scale_factor_minus_one * mul
+ else
+ muvstore_crust_mantle(i,j,k,ispec) = muvstore_crust_mantle(i,j,k,ispec) * scale_factor
+ if(TRANSVERSE_ISOTROPY_VAL .and. (idoubling_crust_mantle(ispec) == IFLAG_220_80 &
+ .or. idoubling_crust_mantle(ispec) == IFLAG_80_MOHO)) &
+ muhstore_crust_mantle(i,j,k,ispec) = muhstore_crust_mantle(i,j,k,ispec) * scale_factor
+ endif
+
+ enddo
+ enddo
+ enddo
+ enddo ! END DO CRUST MANTLE
+
+! rescale in inner core
+
+ do ispec = 1,NSPEC_INNER_CORE
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ if(ATTENUATION_3D_VAL) then
+ scale_factor_minus_one = factor_scale_inner_core(i,j,k,ispec) - 1.0
+ else
+ iglob = ibool_inner_core(i,j,k,ispec)
+ dist_cr = xstore_inner_core(iglob)
+ call get_attenuation_index(idoubling_inner_core(ispec), dble(dist_cr), iregion_selected, .TRUE., AM_V)
+ scale_factor_minus_one = factor_scale_inner_core(1,1,1,iregion_selected) - 1.
+ endif
+
+ if(ANISOTROPIC_INNER_CORE_VAL) then
+ mul = muvstore_inner_core(i,j,k,ispec)
+ c11store_inner_core(i,j,k,ispec) = c11store_inner_core(i,j,k,ispec) &
+ + FOUR_THIRDS * scale_factor_minus_one * mul
+ c12store_inner_core(i,j,k,ispec) = c12store_inner_core(i,j,k,ispec) &
+ - TWO_THIRDS * scale_factor_minus_one * mul
+ c13store_inner_core(i,j,k,ispec) = c13store_inner_core(i,j,k,ispec) &
+ - TWO_THIRDS * scale_factor_minus_one * mul
+ c33store_inner_core(i,j,k,ispec) = c33store_inner_core(i,j,k,ispec) &
+ + FOUR_THIRDS * scale_factor_minus_one * mul
+ c44store_inner_core(i,j,k,ispec) = c44store_inner_core(i,j,k,ispec) &
+ + scale_factor_minus_one * mul
+ endif
+
+ if(ATTENUATION_3D_VAL) then
+ muvstore_inner_core(i,j,k,ispec) = muvstore_inner_core(i,j,k,ispec) * factor_scale_inner_core(i,j,k,ispec)
+ else
+ muvstore_inner_core(i,j,k,ispec) = muvstore_inner_core(i,j,k,ispec) * factor_scale_inner_core(1,1,1,iregion_selected)
+ endif
+
+ enddo
+ enddo
+ enddo
+ enddo ! END DO INNER CORE
+
+ endif ! END IF(ATTENUATION)
+
+! allocate seismogram array
+ if (nrec_local > 0) then
+ allocate(seismograms(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier)
+ if(ier /= 0) stop 'error while allocating seismograms'
+! initialize seismograms
+ seismograms(:,:,:) = 0._CUSTOM_REAL
+ nit_written = 0
+ endif
+
+! initialize arrays to zero
+
+ displ_crust_mantle(:,:) = 0._CUSTOM_REAL
+ veloc_crust_mantle(:,:) = 0._CUSTOM_REAL
+ accel_crust_mantle(:,:) = 0._CUSTOM_REAL
+
+ displ_outer_core(:) = 0._CUSTOM_REAL
+ veloc_outer_core(:) = 0._CUSTOM_REAL
+ accel_outer_core(:) = 0._CUSTOM_REAL
+
+ displ_inner_core(:,:) = 0._CUSTOM_REAL
+ veloc_inner_core(:,:) = 0._CUSTOM_REAL
+ accel_inner_core(:,:) = 0._CUSTOM_REAL
+
+! put negligible initial value to avoid very slow underflow trapping
+ if(FIX_UNDERFLOW_PROBLEM) then
+ displ_crust_mantle(:,:) = VERYSMALLVAL
+ displ_outer_core(:) = VERYSMALLVAL
+ displ_inner_core(:,:) = VERYSMALLVAL
+ endif
+
+! store g, rho and dg/dr=dg using normalized radius in lookup table every 100 m
+! get density and velocity from PREM model using dummy doubling flag
+! this assumes that the gravity perturbations are small and smooth
+! and that we can neglect the 3D model and use PREM every 100 m in all cases
+! this is probably a rather reasonable assumption
+
+ ! tabulate d ln(rho)/dr needed for the no gravity fluid potential
+ do int_radius = 1,NRAD_GRAVITY
+ radius = dble(int_radius) / (R_EARTH_KM * 10.d0)
+ idoubling = 0
+ call prem_iso(myrank,radius,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,.false., &
+ ONE_CRUST,.false.,RICB,RCMB,RTOPDDOUBLEPRIME, &
+ R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
+ d_ln_density_dr_table(int_radius) = drhodr/rho
+ enddo
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' time step: ',sngl(DT),' s'
+ write(IMAIN,*) 'number of time steps: ',NSTEP
+ write(IMAIN,*) 'total simulated time: ',sngl(((NSTEP-1)*DT-t0)/60.d0),' minutes'
+ write(IMAIN,*) 'start time:',sngl(-t0),' seconds'
+ write(IMAIN,*)
+ endif
+
+! define constants for the time integration
+! scaling to make displacement in meters and velocity in meters per second
+ scale_t = ONE/dsqrt(PI*GRAV*RHOAV)
+ scale_displ = R_EARTH
+ scale_veloc = scale_displ / scale_t
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ deltat = sngl(DT/scale_t)
+ else
+ deltat = DT/scale_t
+ endif
+ deltatover2 = 0.5d0*deltat
+ deltatsqover2 = 0.5d0*deltat*deltat
+
+! precompute Runge-Kutta coefficients if attenuation
+ if(ATTENUATION_VAL) then
+ call attenuation_memory_values(tau_sigma_dble, deltat, alphaval_dble, betaval_dble, gammaval_dble)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ alphaval = sngl(alphaval_dble)
+ betaval = sngl(betaval_dble)
+ gammaval = sngl(gammaval_dble)
+ else
+ alphaval = alphaval_dble
+ betaval = betaval_dble
+ gammaval = gammaval_dble
+ endif
+ endif
+
+ if (COMPUTE_AND_STORE_STRAIN) then
+ epsilondev_crust_mantle(:,:,:,:,:) = 0._CUSTOM_REAL
+ epsilondev_inner_core(:,:,:,:,:) = 0._CUSTOM_REAL
+ if(FIX_UNDERFLOW_PROBLEM) then
+ epsilondev_crust_mantle(:,:,:,:,:) = VERYSMALLVAL
+ epsilondev_inner_core(:,:,:,:,:) = VERYSMALLVAL
+ endif
+ endif
+
+! clear memory variables if attenuation
+ if(ATTENUATION_VAL) then
+ if (NSPEC_CRUST_MANTLE_ATTENUAT /= NSPEC_CRUST_MANTLE) &
+ call exit_MPI(myrank, 'NSPEC_CRUST_MANTLE_ATTENUAT /= NSPEC_CRUST_MANTLE, exit')
+ if (NSPEC_INNER_CORE_ATTENUATION /= NSPEC_INNER_CORE) &
+ call exit_MPI(myrank, 'NSPEC_INNER_CORE_ATTENUATION /= NSPEC_INNER_CORE, exit')
+
+ R_memory_crust_mantle(:,:,:,:,:,:) = 0._CUSTOM_REAL
+ R_memory_inner_core(:,:,:,:,:,:) = 0._CUSTOM_REAL
+ if(FIX_UNDERFLOW_PROBLEM) then
+ R_memory_crust_mantle(:,:,:,:,:,:) = VERYSMALLVAL
+ R_memory_inner_core(:,:,:,:,:,:) = VERYSMALLVAL
+ endif
+
+ endif
+
+! get information about event name and location for SAC seismograms
+ call get_event_info_parallel(myrank,yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC, &
+ elat_SAC,elon_SAC,depth_SAC,mb_SAC,ename_SAC,cmt_lat_SAC,cmt_lon_SAC,cmt_depth_SAC,cmt_hdur_SAC,NSOURCES_SAC)
+
+! define correct time steps if restart files
+ if(NUMBER_OF_RUNS < 1 .or. NUMBER_OF_RUNS > 3) stop 'number of restart runs can be 1, 2 or 3'
+ if(NUMBER_OF_THIS_RUN < 1 .or. NUMBER_OF_THIS_RUN > NUMBER_OF_RUNS) stop 'incorrect run number'
+ if (SIMULATION_TYPE /= 1 .and. NUMBER_OF_RUNS /= 1) stop 'Only 1 run for SIMULATION_TYPE = 2/3'
+
+ it_begin = 1
+ it_end = NSTEP
+
+!
+! s t a r t t i m e i t e r a t i o n s
+!
+
+! synchronize all processes to make sure everybody is ready to start time loop
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+ if(myrank == 0) write(IMAIN,*) 'All processes are synchronized before time loop'
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Starting time iteration loop...'
+ write(IMAIN,*)
+ endif
+
+! create an empty file to monitor the start of the simulation
+ if(myrank == 0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/starttimeloop.txt',status='unknown')
+ write(IOUT,*) 'hello, starting time loop'
+ close(IOUT)
+ endif
+
+! get MPI starting time
+ time_start = MPI_WTIME()
+
+! initialize variables for writing seismograms
+ seismo_offset = it_begin-1
+ seismo_current = 0
+
+! *********************************************************
+! ************* MAIN LOOP OVER THE TIME STEPS *************
+! *********************************************************
+
+!! DK DK merged version: may set to 1 for timing
+! displ_crust_mantle = 1
+! veloc_crust_mantle = 1
+! displ_outer_core = 1
+! veloc_outer_core = 1
+! displ_inner_core = 1
+! veloc_inner_core = 1
+
+ do it = it_begin,it_end
+
+! update position in seismograms
+ seismo_current = seismo_current + 1
+
+! mantle
+ do i=1,NGLOB_CRUST_MANTLE
+ displ_crust_mantle(:,i) = displ_crust_mantle(:,i) + deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
+ veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
+ enddo
+
+! outer core
+ do i=1,NGLOB_OUTER_CORE
+ displ_outer_core(i) = displ_outer_core(i) + deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
+ veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
+ enddo
+
+! inner core
+ do i=1,NGLOB_INNER_CORE
+ displ_inner_core(:,i) = displ_inner_core(:,i) + deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
+ veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
+ enddo
+
+! compute the maximum of the norm of the displacement
+! in all the slices using an MPI reduction
+! and output timestamp file to check that simulation is running fine
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
+
+! compute maximum of norm of displacement in each slice
+ Usolidnorm = max( &
+ maxval(sqrt(displ_crust_mantle(1,:)**2 + &
+ displ_crust_mantle(2,:)**2 + displ_crust_mantle(3,:)**2)), &
+ maxval(sqrt(displ_inner_core(1,:)**2 + displ_inner_core(2,:)**2 + displ_inner_core(3,:)**2)))
+
+ Ufluidnorm = maxval(abs(displ_outer_core))
+
+! compute the maximum of the maxima for all the slices using an MPI reduction
+ call MPI_REDUCE(Usolidnorm,Usolidnorm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
+ MPI_COMM_WORLD,ier)
+ call MPI_REDUCE(Ufluidnorm,Ufluidnorm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
+ MPI_COMM_WORLD,ier)
+
+ if(myrank == 0) then
+
+ write(IMAIN,*) 'Time step # ',it
+ write(IMAIN,*) 'Time: ',sngl(((it-1)*DT-t0)/60.d0),' minutes'
+
+! rescale maximum displacement to correct dimensions
+ Usolidnorm_all = Usolidnorm_all * sngl(scale_displ)
+ write(IMAIN,*) 'Max norm displacement vector U in solid in all slices (m) = ',Usolidnorm_all
+ write(IMAIN,*) 'Max non-dimensional potential Ufluid in fluid in all slices = ',Ufluidnorm_all
+
+! elapsed time since beginning of the simulation
+ tCPU = MPI_WTIME() - time_start
+ int_tCPU = int(tCPU)
+ ihours = int_tCPU / 3600
+ iminutes = (int_tCPU - 3600*ihours) / 60
+ iseconds = int_tCPU - 3600*ihours - 60*iminutes
+ write(IMAIN,*) 'Elapsed time in seconds = ',tCPU
+ write(IMAIN,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(IMAIN,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+
+! compute estimated remaining simulation time
+ t_remain = (NSTEP - it) * (tCPU/dble(it))
+ int_t_remain = int(t_remain)
+ ihours_remain = int_t_remain / 3600
+ iminutes_remain = (int_t_remain - 3600*ihours_remain) / 60
+ iseconds_remain = int_t_remain - 3600*ihours_remain - 60*iminutes_remain
+ write(IMAIN,*) 'Time steps done = ',it,' out of ',NSTEP
+ write(IMAIN,*) 'Time steps remaining = ',NSTEP - it
+ write(IMAIN,*) 'Estimated remaining time in seconds = ',t_remain
+ write(IMAIN,"(' Estimated remaining time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
+ ihours_remain,iminutes_remain,iseconds_remain
+
+! compute estimated total simulation time
+ t_total = t_remain + tCPU
+ int_t_total = int(t_total)
+ ihours_total = int_t_total / 3600
+ iminutes_total = (int_t_total - 3600*ihours_total) / 60
+ iseconds_total = int_t_total - 3600*ihours_total - 60*iminutes_total
+ write(IMAIN,*) 'Estimated total run time in seconds = ',t_total
+ write(IMAIN,"(' Estimated total run time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
+ ihours_total,iminutes_total,iseconds_total
+ write(IMAIN,*) 'We have done ',sngl(100.d0*dble(it)/dble(NSTEP)),'% of that'
+
+ if(it < 100) then
+ write(IMAIN,*) '************************************************************'
+ write(IMAIN,*) '**** BEWARE: the above time estimates are not reliable'
+ write(IMAIN,*) '**** because fewer than 100 iterations have been performed'
+ write(IMAIN,*) '************************************************************'
+ endif
+
+ write(IMAIN,*)
+
+! write time stamp file to give information about progression of simulation
+ write(outputname,"('/timestamp',i6.6)") it
+
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='unknown')
+
+ write(IOUT,*) 'Time step # ',it
+ write(IOUT,*) 'Time: ',sngl(((it-1)*DT-t0)/60.d0),' minutes'
+ write(IOUT,*)
+ write(IOUT,*) 'Max norm displacement vector U in solid in all slices (m) = ',Usolidnorm_all
+ write(IOUT,*) 'Max non-dimensional potential Ufluid in fluid in all slices = ',Ufluidnorm_all
+ write(IOUT,*)
+
+ write(IOUT,*) 'Elapsed time in seconds = ',tCPU
+ write(IOUT,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ write(IOUT,*)
+
+ write(IOUT,*) 'Time steps done = ',it,' out of ',NSTEP
+ write(IOUT,*) 'Time steps remaining = ',NSTEP - it
+ write(IOUT,*) 'Estimated remaining time in seconds = ',t_remain
+ write(IOUT,"(' Estimated remaining time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
+ ihours_remain,iminutes_remain,iseconds_remain
+ write(IOUT,*)
+
+ write(IOUT,*) 'Estimated total run time in seconds = ',t_total
+ write(IOUT,"(' Estimated total run time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
+ ihours_total,iminutes_total,iseconds_total
+ write(IOUT,*) 'We have done ',sngl(100.d0*dble(it)/dble(NSTEP)),'% of that'
+ write(IOUT,*)
+
+ if(it < 100) then
+ write(IOUT,*)
+ write(IOUT,*) '************************************************************'
+ write(IOUT,*) '**** BEWARE: the above time estimates are not reliable'
+ write(IOUT,*) '**** because fewer than 100 iterations have been performed'
+ write(IOUT,*) '************************************************************'
+ endif
+
+ close(IOUT)
+
+! check stability of the code, exit if unstable
+! negative values can occur with some compilers when the unstable value is greater
+! than the greatest possible floating-point number of the machine
+ if(Usolidnorm_all > STABILITY_THRESHOLD .or. Usolidnorm_all < 0) &
+ call exit_MPI(myrank,'forward simulation became unstable and blew up in the solid')
+ if(Ufluidnorm_all > STABILITY_THRESHOLD .or. Ufluidnorm_all < 0) &
+ call exit_MPI(myrank,'forward simulation became unstable and blew up in the fluid')
+ endif
+ endif
+
+! ****************************************************
+! big loop over all spectral elements in the fluid
+! ****************************************************
+
+! compute internal forces in the fluid region
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time = sngl((dble(it-1)*DT-t0)/scale_t)
+ else
+ time = (dble(it-1)*DT-t0)/scale_t
+ endif
+
+! accel_outer_core, div_displ_outer_core are initialized to zero in the following subroutine.
+ call compute_forces_outer_core(d_ln_density_dr_table, &
+ displ_outer_core,accel_outer_core,xstore_outer_core,ystore_outer_core,zstore_outer_core, &
+ xix_outer_core,xiy_outer_core,xiz_outer_core, &
+ etax_outer_core,etay_outer_core,etaz_outer_core, &
+ gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,ibool_outer_core)
+
+! ****************************************************
+! ********** add matching with solid part **********
+! ****************************************************
+
+! only for elements in first matching layer in the fluid
+
+!---
+!--- couple with mantle at the top of the outer core
+!---
+
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+
+! for surface elements exactly on the CMB
+ do ispec2D = 1,NSPEC2D_TOP(IREGION_OUTER_CORE)
+ ispec = ibelm_top_outer_core(ispec2D)
+
+! only for DOFs exactly on the CMB (top of these elements)
+ k = NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+! get velocity on the solid side using pointwise matching
+ ispec_selected = ibelm_bottom_crust_mantle(ispec2D)
+
+! corresponding points are located at the bottom of the mantle
+ k_corresp = 1
+ iglob = ibool_crust_mantle(i,j,k_corresp,ispec_selected)
+
+ displ_x = displ_crust_mantle(1,iglob)
+ displ_y = displ_crust_mantle(2,iglob)
+ displ_z = displ_crust_mantle(3,iglob)
+
+! get global point number
+ iglob = ibool_outer_core(i,j,k,ispec)
+
+! get normal on the CMB
+ nx = normal_top_outer_core(1,i,j,ispec2D)
+ ny = normal_top_outer_core(2,i,j,ispec2D)
+ nz = normal_top_outer_core(3,i,j,ispec2D)
+
+! compute dot product
+ displ_n = displ_x*nx + displ_y*ny + displ_z*nz
+
+! formulation with generalized potential
+ weight = jacobian2D_top_outer_core(i,j,ispec2D)*wgllwgll_xy(i,j)
+
+ accel_outer_core(iglob) = accel_outer_core(iglob) + weight*displ_n
+
+ enddo
+ enddo
+ enddo
+
+ endif
+
+!---
+!--- couple with inner core at the bottom of the outer core
+!---
+
+ if(ACTUALLY_COUPLE_FLUID_ICB .and. NCHUNKS_VAL == 6) then
+
+! for surface elements exactly on the ICB
+ do ispec2D = 1,NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
+ ispec = ibelm_bottom_outer_core(ispec2D)
+
+! only for DOFs exactly on the ICB (bottom of these elements)
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+! get velocity on the solid side using pointwise matching
+ ispec_selected = ibelm_top_inner_core(ispec2D)
+
+! corresponding points are located at the bottom of the mantle
+ k_corresp = NGLLZ
+ iglob = ibool_inner_core(i,j,k_corresp,ispec_selected)
+
+ displ_x = displ_inner_core(1,iglob)
+ displ_y = displ_inner_core(2,iglob)
+ displ_z = displ_inner_core(3,iglob)
+
+! get global point number
+ iglob = ibool_outer_core(i,j,k,ispec)
+
+! get normal on the ICB
+ nx = normal_bottom_outer_core(1,i,j,ispec2D)
+ ny = normal_bottom_outer_core(2,i,j,ispec2D)
+ nz = normal_bottom_outer_core(3,i,j,ispec2D)
+
+! compute dot product
+ displ_n = displ_x*nx + displ_y*ny + displ_z*nz
+
+! formulation with generalized potential
+ weight = jacobian2D_bottom_outer_core(i,j,ispec2D)*wgllwgll_xy(i,j)
+
+ accel_outer_core(iglob) = accel_outer_core(iglob) - weight*displ_n
+
+ enddo
+ enddo
+ enddo
+
+ endif
+
+! assemble all the contributions between slices using MPI
+
+! outer core
+ call assemble_MPI_scalar(myrank,accel_outer_core,NGLOB_OUTER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
+ npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
+ iboolfaces_outer_core,iboolcorner_outer_core, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
+ buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE),NGLOB2DMAX_XY,NCHUNKS)
+
+! multiply by the inverse of the mass matrix and update velocity
+ do i=1,NGLOB_OUTER_CORE
+ accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
+ veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
+ enddo
+
+! ****************************************************
+! big loop over all spectral elements in the solid
+! ****************************************************
+
+! compute internal forces in the solid regions
+
+! for anisotropy and gravity, x y and z contain r theta and phi
+
+ call compute_forces_crust_mantle(displ_crust_mantle,accel_crust_mantle, &
+ xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
+ xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
+ etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
+ gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappavstore_crust_mantle,kappahstore_crust_mantle,muvstore_crust_mantle, &
+ muhstore_crust_mantle,eta_anisostore_crust_mantle, &
+ ibool_crust_mantle,idoubling_crust_mantle, &
+ R_memory_crust_mantle,epsilondev_crust_mantle,one_minus_sum_beta_crust_mantle, &
+ alphaval,betaval,gammaval,factor_common_crust_mantle, &
+ size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
+ size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5),COMPUTE_AND_STORE_STRAIN,AM_V)
+
+ call compute_forces_inner_core(displ_inner_core,accel_inner_core,xstore_inner_core, &
+ xix_inner_core,xiy_inner_core,xiz_inner_core, &
+ etax_inner_core,etay_inner_core,etaz_inner_core, &
+ gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappavstore_inner_core,muvstore_inner_core,ibool_inner_core,idoubling_inner_core, &
+ R_memory_inner_core,epsilondev_inner_core,one_minus_sum_beta_inner_core, &
+ alphaval,betaval,gammaval, &
+ factor_common_inner_core, &
+ size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
+ size(factor_common_inner_core,4), size(factor_common_inner_core,5),COMPUTE_AND_STORE_STRAIN,AM_V)
+
+! add the sources
+ do isource = 1,NSOURCES
+
+! add only if this proc carries the source
+ if(myrank == islice_selected_source(isource)) then
+
+ stf = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ stf_used = sngl(stf)
+ else
+ stf_used = stf
+ endif
+
+! add source array
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool_crust_mantle(i,j,k,ispec_selected_source(isource))
+ accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) + sourcearrays(isource,:,i,j,k)*stf_used
+ enddo
+ enddo
+ enddo
+
+ endif
+
+ enddo
+
+! ****************************************************
+! ********** add matching with fluid part **********
+! ****************************************************
+
+! only for elements in first matching layer in the solid
+
+!---
+!--- couple with outer core at the bottom of the mantle
+!---
+
+ if(ACTUALLY_COUPLE_FLUID_CMB) then
+
+! for surface elements exactly on the CMB
+ do ispec2D = 1,NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE)
+
+ ispec = ibelm_bottom_crust_mantle(ispec2D)
+
+! only for DOFs exactly on the CMB (bottom of these elements)
+ k = 1
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+! get velocity potential on the fluid side using pointwise matching
+ ispec_selected = ibelm_top_outer_core(ispec2D)
+ k_corresp = NGLLZ
+
+! get normal at the CMB
+ nx = normal_top_outer_core(1,i,j,ispec2D)
+ ny = normal_top_outer_core(2,i,j,ispec2D)
+ nz = normal_top_outer_core(3,i,j,ispec2D)
+
+! get global point number
+! corresponding points are located at the top of the outer core
+ iglob = ibool_outer_core(i,j,NGLLZ,ispec_selected)
+ iglob_mantle = ibool_crust_mantle(i,j,k,ispec)
+
+! compute pressure, taking gravity into account
+ pressure = - RHO_TOP_OC * accel_outer_core(iglob)
+
+! formulation with generalized potential
+ weight = jacobian2D_top_outer_core(i,j,ispec2D)*wgllwgll_xy(i,j)
+
+ accel_crust_mantle(1,iglob_mantle) = accel_crust_mantle(1,iglob_mantle) + weight*nx*pressure
+ accel_crust_mantle(2,iglob_mantle) = accel_crust_mantle(2,iglob_mantle) + weight*ny*pressure
+ accel_crust_mantle(3,iglob_mantle) = accel_crust_mantle(3,iglob_mantle) + weight*nz*pressure
+
+ enddo
+ enddo
+ enddo
+
+ endif
+
+!---
+!--- couple with outer core at the top of the inner core
+!---
+
+ if(ACTUALLY_COUPLE_FLUID_ICB .and. NCHUNKS_VAL == 6) then
+
+! for surface elements exactly on the ICB
+ do ispec2D = 1,NSPEC2D_TOP(IREGION_INNER_CORE)
+
+ ispec = ibelm_top_inner_core(ispec2D)
+
+! only for DOFs exactly on the ICB (top of these elements)
+ k = NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+! get velocity potential on the fluid side using pointwise matching
+ ispec_selected = ibelm_bottom_outer_core(ispec2D)
+ k_corresp = 1
+
+! get normal at the ICB
+ nx = normal_bottom_outer_core(1,i,j,ispec2D)
+ ny = normal_bottom_outer_core(2,i,j,ispec2D)
+ nz = normal_bottom_outer_core(3,i,j,ispec2D)
+
+! get global point number
+! corresponding points are located at the bottom of the outer core
+ iglob = ibool_outer_core(i,j,k_corresp,ispec_selected)
+ iglob_inner_core = ibool_inner_core(i,j,k,ispec)
+
+! compute pressure, taking gravity into account
+ pressure = - RHO_BOTTOM_OC * accel_outer_core(iglob)
+
+! formulation with generalized potential
+ weight = jacobian2D_bottom_outer_core(i,j,ispec2D)*wgllwgll_xy(i,j)
+
+ accel_inner_core(1,iglob_inner_core) = accel_inner_core(1,iglob_inner_core) - weight*nx*pressure
+ accel_inner_core(2,iglob_inner_core) = accel_inner_core(2,iglob_inner_core) - weight*ny*pressure
+ accel_inner_core(3,iglob_inner_core) = accel_inner_core(3,iglob_inner_core) - weight*nz*pressure
+
+ enddo
+ enddo
+ enddo
+
+ endif
+
+! assemble all the contributions between slices using MPI
+
+! crust/mantle and inner core handled in the same call
+! in order to reduce the number of MPI messages by 2
+ call assemble_MPI_vector(myrank, &
+ accel_crust_mantle,NGLOB_CRUST_MANTLE, &
+ accel_inner_core,NGLOB_INNER_CORE, &
+ iproc_xi,iproc_eta,ichunk,addressing, &
+ iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
+ npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle(1),npoin2D_eta_crust_mantle(1), &
+ iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
+ iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
+ npoin2D_faces_inner_core,npoin2D_xi_inner_core(1),npoin2D_eta_inner_core(1), &
+ iboolfaces_inner_core,iboolcorner_inner_core, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ buffer_send_faces,buffer_received_faces,npoin2D_max_all, &
+ buffer_send_chunkcorners_vector,buffer_recv_chunkcorners_vector, &
+ NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
+ NPROC_XI,NPROC_ETA, &
+ NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE), &
+ NGLOB1D_RADIAL(IREGION_INNER_CORE), &
+ NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE), &
+ NGLOB2DMAX_XY,NCHUNKS)
+
+!---
+!--- use buffers to assemble forces with the central cube
+!---
+
+ if(INCLUDE_CENTRAL_CUBE) then
+
+ call assemble_MPI_central_cube(ichunk,nb_msgs_theor_in_cube, sender_from_slices_to_cube, &
+ npoin2D_cube_from_slices, buffer_all_cube_from_slices, buffer_slices, buffer_slices2, ibool_central_cube, &
+ receiver_cube_from_slices, ibool_inner_core, idoubling_inner_core, NSPEC_INNER_CORE, &
+ ibelm_bottom_inner_core, NSPEC2D_BOTTOM(IREGION_INNER_CORE),NGLOB_INNER_CORE,accel_inner_core,NDIM)
+
+ endif ! end of assembling forces with the central cube
+
+ do i=1,NGLOB_CRUST_MANTLE
+ accel_crust_mantle(1,i) = accel_crust_mantle(1,i)*rmass_crust_mantle(i)
+ accel_crust_mantle(2,i) = accel_crust_mantle(2,i)*rmass_crust_mantle(i)
+ accel_crust_mantle(3,i) = accel_crust_mantle(3,i)*rmass_crust_mantle(i)
+ enddo
+
+ do i=1,NGLOB_CRUST_MANTLE
+ veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) + deltatover2*accel_crust_mantle(:,i)
+ enddo
+
+ do i=1,NGLOB_INNER_CORE
+ accel_inner_core(1,i) = accel_inner_core(1,i)*rmass_inner_core(i)
+ accel_inner_core(2,i) = accel_inner_core(2,i)*rmass_inner_core(i)
+ accel_inner_core(3,i) = accel_inner_core(3,i)*rmass_inner_core(i)
+
+ veloc_inner_core(:,i) = veloc_inner_core(:,i) + deltatover2*accel_inner_core(:,i)
+ enddo
+
+! write the seismograms with time shift
+
+! store the seismograms only if there is at least one receiver located in this slice
+ if (nrec_local > 0) then
+
+ do irec_local = 1,nrec_local
+
+! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+
+! perform the general interpolation using Lagrange polynomials
+ uxd = ZERO
+ uyd = ZERO
+ uzd = ZERO
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ iglob = ibool_crust_mantle(i,j,k,ispec_selected_rec(irec))
+
+ hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
+
+ uxd = uxd + dble(displ_crust_mantle(1,iglob))*hlagrange
+ uyd = uyd + dble(displ_crust_mantle(2,iglob))*hlagrange
+ uzd = uzd + dble(displ_crust_mantle(3,iglob))*hlagrange
+
+ enddo
+ enddo
+ enddo
+! store North, East and Vertical components
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ seismograms(:,irec_local,seismo_current) = sngl(scale_displ*(nu(:,1,irec)*uxd + &
+ nu(:,2,irec)*uyd + nu(:,3,irec)*uzd))
+ else
+ seismograms(:,irec_local,seismo_current) = scale_displ*(nu(:,1,irec)*uxd + &
+ nu(:,2,irec)*uyd + nu(:,3,irec)*uzd)
+ endif
+
+ enddo
+
+ endif ! nrec_local
+
+! write the current or final seismograms
+ if(seismo_current == NTSTEP_BETWEEN_OUTPUT_SEISMOS .or. it == it_end) then
+ call write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
+ network_name,stlat,stlon,stele,nrec,nrec_local,DT,t0,it_end, &
+ yr_SAC,jda_SAC,ho_SAC,mi_SAC,sec_SAC,t_cmt_SAC, &
+ elat_SAC,elon_SAC,depth_SAC,mb_SAC,ename_SAC,cmt_lat_SAC,cmt_lon_SAC,&
+ cmt_depth_SAC,cmt_hdur_SAC,NSOURCES_SAC,NPROCTOT, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE)
+ if(myrank==0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' Total number of time steps written: ', it-it_begin+1
+ write(IMAIN,*)
+ endif
+ seismo_offset = seismo_offset + seismo_current
+ seismo_current = 0
+ endif
+
+!---- end of time iteration loop
+!
+ enddo ! end of main time loop
+
+! if running on MareNostrum in Barcelona
+ if(RUN_ON_MARENOSTRUM_BARCELONA) then
+
+! synchronize all the processes to make sure everybody has finished
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+! suppress the local directory to leave space for future runs with a different rank number
+ write(system_command,"('rm -r -f /scratch/komatits_new_proc',i4.4)") myrank
+ call system(system_command)
+
+ endif
+
+! close the main output file
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'End of the simulation'
+ write(IMAIN,*)
+ close(IMAIN)
+ endif
+
+! synchronize all the processes to make sure everybody has finished
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+! stop all the MPI processes, and exit
+!! DK DK suppressed this for the merged version
+! call MPI_FINALIZE(ier)
+
+ end subroutine specfem3D
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/spline_routines.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/spline_routines.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/spline_routines.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/store_xelm_yelm_zelm.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/store_xelm_yelm_zelm.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/store_xelm_yelm_zelm.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,14 @@
+
+!! DK DK added for merged version
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ xelm_store(:,ispec) = sngl(xelm(:))
+ yelm_store(:,ispec) = sngl(yelm(:))
+ zelm_store(:,ispec) = sngl(zelm(:))
+ else
+ xelm_store(:,ispec) = xelm(:)
+ yelm_store(:,ispec) = yelm(:)
+ zelm_store(:,ispec) = zelm(:)
+ endif
+
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/stretching_function.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/stretching_function.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/stretching_function.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/topo_bathy.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/topo_bathy.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/topo_bathy.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -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_GLOBE/trunk/version41_beta/write_seismograms.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/write_seismograms.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/version41_beta/write_seismograms.f90 2008-05-09 13:08:56 UTC (rev 11930)
@@ -0,0 +1,688 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! write seismograms to files
+ subroutine write_seismograms(myrank,seismograms,number_receiver_global,station_name, &
+ network_name,stlat,stlon,stele,nrec,nrec_local,DT,hdur,it_end, &
+ yr,jda,ho,mi,sec,t_cmt, &
+ elat,elon,depth,mb,ename,cmt_lat,cmt_lon, &
+ cmt_depth,cmt_hdur,NSOURCES,NPROCTOT, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ seismo_offset,seismo_current,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+! parameters
+ integer nrec,nrec_local,myrank,it_end,NPROCTOT,NSOURCES
+ character(len=256) sisname
+
+ integer :: seismo_offset, seismo_current, NTSTEP_BETWEEN_OUTPUT_SEISMOS
+ integer, dimension(nrec_local) :: number_receiver_global
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: seismograms
+ double precision hdur,DT
+
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+ double precision t_cmt,elat,elon,depth
+ double precision cmt_lat,cmt_lon,cmt_depth,cmt_hdur
+ double precision, dimension(nrec) :: stlat,stlon,stele
+ integer yr,jda,ho,mi
+ double precision sec
+ real mb
+ character(12) ename
+
+! variables
+ integer :: iproc,sender,irec_local,irec,ier,receiver,nrec_local_received,nrec_tot_found
+ integer :: total_seismos,total_seismos_local
+ double precision :: write_time_begin,write_time
+
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: one_seismogram
+
+ integer msg_status(MPI_STATUS_SIZE)
+
+ character(len=150) OUTPUT_FILES
+
+! new flags to decide on seismogram type BS BS 06/2007
+ logical OUTPUT_SEISMOS_ASCII_TEXT, OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY
+! flag whether seismograms are ouput for North-East-Z component or Radial-Transverse-Z
+ logical ROTATE_SEISMOGRAMS_RT
+
+! flag to decide if seismograms are written by master proc only or
+! by all processes in parallel (doing the later may create problems on some
+! file systems)
+ logical WRITE_SEISMOGRAMS_BY_MASTER
+
+! save all seismograms in one large combined file instead of one file per seismogram
+! to avoid overloading shared non-local file systems such as GPFS for instance
+ logical SAVE_ALL_SEISMOS_IN_ONE_FILE
+ logical USE_BINARY_FOR_LARGE_FILE
+
+ allocate(one_seismogram(NDIM,NTSTEP_BETWEEN_OUTPUT_SEISMOS),stat=ier)
+ if(ier /= 0) stop 'error while allocating one temporary seismogram'
+
+! check that the sum of the number of receivers in each slice is nrec
+ call MPI_REDUCE(nrec_local,nrec_tot_found,1,MPI_INTEGER,MPI_SUM,0,MPI_COMM_WORLD,ier)
+ if(myrank == 0 .and. nrec_tot_found /= nrec) &
+ call exit_MPI(myrank,'total number of receivers is incorrect')
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! all the processes write their local seismograms themselves
+ if(.not. WRITE_SEISMOGRAMS_BY_MASTER) then
+
+ write_time_begin = MPI_WTIME()
+
+ if(OUTPUT_SEISMOS_ASCII_TEXT .and. SAVE_ALL_SEISMOS_IN_ONE_FILE) then
+ write(sisname,'(A,I5.5)') '/all_seismograms_node_',myrank
+
+ if(USE_BINARY_FOR_LARGE_FILE) then
+ if (seismo_offset==0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='unknown',form='unformatted')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='old',&
+ form='unformatted',position='append')
+ endif
+ else
+ if (seismo_offset==0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='unknown',form='formatted')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='old',&
+ form='formatted',position='append')
+ endif
+ endif
+ endif
+
+ total_seismos_local = 0
+
+! loop on all the local receivers
+ do irec_local = 1,nrec_local
+
+! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+
+ total_seismos_local = total_seismos_local + 1
+
+ one_seismogram = seismograms(:,irec_local,:)
+
+! write this seismogram
+ call write_one_seismogram(one_seismogram,irec, &
+ station_name,network_name,stlat,stlon,stele,nrec, &
+ DT,hdur,it_end, &
+ yr,jda,ho,mi,sec,t_cmt,elat,elon,depth,mb,ename,cmt_lat, &
+ cmt_lon,cmt_depth,cmt_hdur,NSOURCES,OUTPUT_FILES, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismo_offset,seismo_current, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,myrank)
+
+ enddo
+
+ if(total_seismos_local/= nrec_local) call exit_MPI(myrank,'incorrect total number of receivers saved')
+
+ write_time = MPI_WTIME() - write_time_begin
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Writing the seismograms in parallel took ',write_time,' seconds'
+ write(IMAIN,*)
+ endif
+
+! now only the master process does the writing of seismograms and
+! collects the data from all other processes
+ else ! WRITE_SEISMOGRAMS_BY_MASTER
+
+ write_time_begin = MPI_WTIME()
+
+ if(myrank == 0) then ! on the master, gather all the seismograms
+
+ ! create one large file instead of one small file per station to avoid file system overload
+ if(OUTPUT_SEISMOS_ASCII_TEXT .and. SAVE_ALL_SEISMOS_IN_ONE_FILE) then
+ write(sisname,'(A)') '/all_seismograms'
+
+ if(USE_BINARY_FOR_LARGE_FILE) then
+ if (seismo_offset==0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='unknown',form='unformatted')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.bin',status='old',&
+ form='unformatted',position='append')
+ endif
+ else
+ if (seismo_offset==0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='unknown',form='formatted')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname)//'.ascii',status='old',&
+ form='formatted',position='append')
+ endif
+ endif
+
+ endif
+
+ total_seismos = 0
+
+ ! loop on all the slices
+ do iproc = 0,NPROCTOT-1
+
+ ! receive except from proc 0, which is me and therefore I already have this value
+ sender = iproc
+ if(iproc /= 0) then
+ call MPI_RECV(nrec_local_received,1,MPI_INTEGER,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+ if(nrec_local_received < 0) call exit_MPI(myrank,'error while receiving local number of receivers')
+ else
+ nrec_local_received = nrec_local
+ endif
+ if (nrec_local_received > 0) then
+ do irec_local = 1,nrec_local_received
+ ! receive except from proc 0, which is myself and therefore I already have these values
+ if(iproc == 0) then
+ ! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+ one_seismogram(:,:) = seismograms(:,irec_local,:)
+ else
+ call MPI_RECV(irec,1,MPI_INTEGER,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+ if(irec < 1 .or. irec > nrec) call exit_MPI(myrank,'error while receiving global receiver number')
+ call MPI_RECV(one_seismogram,NDIM*seismo_current,CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
+ endif
+
+ total_seismos = total_seismos + 1
+ ! write this seismogram
+ call write_one_seismogram(one_seismogram,irec, &
+ station_name,network_name,stlat,stlon,stele,nrec, &
+ DT,hdur,it_end, &
+ yr,jda,ho,mi,sec,t_cmt,elat,elon,depth,mb,ename,cmt_lat, &
+ cmt_lon,cmt_depth,cmt_hdur,NSOURCES,OUTPUT_FILES, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismo_offset,seismo_current,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,myrank)
+ enddo
+ endif
+ enddo
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'Total number of receivers saved is ',total_seismos,' out of ',nrec
+ write(IMAIN,*)
+
+ if(total_seismos /= nrec) call exit_MPI(myrank,'incorrect total number of receivers saved')
+
+ ! create one large file instead of one small file per station to avoid file system overload
+ if(SAVE_ALL_SEISMOS_IN_ONE_FILE) close(IOUT)
+
+ else ! on the nodes, send the seismograms to the master
+ receiver = 0
+ call MPI_SEND(nrec_local,1,MPI_INTEGER,receiver,itag,MPI_COMM_WORLD,ier)
+ if (nrec_local > 0) then
+ do irec_local = 1,nrec_local
+ ! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+ call MPI_SEND(irec,1,MPI_INTEGER,receiver,itag,MPI_COMM_WORLD,ier)
+ one_seismogram(:,:) = seismograms(:,irec_local,:)
+ call MPI_SEND(one_seismogram,NDIM*seismo_current,CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
+ enddo
+ endif
+ endif
+
+ write_time = MPI_WTIME() - write_time_begin
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Writing the seismograms by master proc alone took ',write_time,' seconds'
+ write(IMAIN,*)
+ endif
+
+ endif ! WRITE_SEISMOGRAMS_BY_MASTER
+
+ deallocate(one_seismogram)
+
+ end subroutine write_seismograms
+
+!
+!----
+!
+
+ subroutine write_one_seismogram(one_seismogram,irec, &
+ station_name,network_name,stlat,stlon,stele,nrec, &
+ DT,hdur,it_end, &
+ yr,jda,ho,mi,sec,t_cmt,elat,elon,depth,mb,ename,cmt_lat,cmt_lon,cmt_depth,cmt_hdur,NSOURCES, &
+ OUTPUT_FILES, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY,ROTATE_SEISMOGRAMS_RT, &
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismo_offset,seismo_current, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,myrank)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nrec,it_end
+
+ integer :: seismo_offset, seismo_current, NTSTEP_BETWEEN_OUTPUT_SEISMOS
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: one_seismogram
+
+ real(kind=CUSTOM_REAL), dimension(5,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: seismogram_tmp
+
+ integer myrank
+ double precision hdur,DT
+
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+
+ integer irec,length_station_name,length_network_name
+ integer iorientation,isample
+ double precision value
+
+ character(len=4) chn
+ character(len=150) sisname,sisname_big_file
+ character(len=150) OUTPUT_FILES
+
+! section added for SAC
+ integer NSOURCES
+
+ double precision t_cmt,elat,elon,depth
+ double precision cmt_lat,cmt_lon,cmt_depth,cmt_hdur
+
+ double precision, dimension(nrec) :: stlat,stlon,stele
+
+ character(len=256) sisname_2
+
+! variables for SAC header fields
+ integer yr,jda,ho,mi
+ double precision sec
+ real mb
+ character(12) ename
+
+ real DELTA
+ real DEPMIN
+ real DEPMAX
+ real SCALE_F
+ real ODELTA
+ real B,E,O,A
+ real STLA,STLO,STEL,STDP
+ real EVLA,EVLO,EVEL,EVDP
+ real MAG,DIST,AZ,BAZ,GCARC
+ real DEPMEN
+ real USER0,USER1,USER2,USER3
+ real CMPAZ,CMPINC
+
+ integer NZYEAR,NZJDAY,NZHOUR,NZMIN,NZSEC
+ integer NZMSEC,NVHDR,NORID,NEVID
+! NUMBER of POINTS:
+ integer NPTS
+ integer IFTYPE,IMAGTYP
+ integer IDEP
+ integer IZTYPE
+ integer IEVTYP
+ integer IQUAL
+ integer ISYNTH
+! permission flags:
+ integer LEVEN
+ integer LPSPOL
+ integer LOVROK
+ integer LCALDA
+
+ character(8) KSTNM
+ character(16) KEVNM
+ character(8) KCMPNM
+ character(8) KNETWK
+ character(8) KUSER0,KUSER1,KUSER2
+ character(8), parameter :: str_undef='-12345 '
+
+ real UNUSED ! header fields unused by SAC
+ real undef ! undefined values
+ real INTERNAL ! SAC internal variables, always leave undefined
+ real BYSAC
+! end SAC header variables
+
+! flags to determine seismogram type
+ logical OUTPUT_SEISMOS_ASCII_TEXT, OUTPUT_SEISMOS_SAC_ALPHANUM, &
+ OUTPUT_SEISMOS_SAC_BINARY
+! flag whether seismograms are ouput for North-East-Z component or Radial-Transverse-Z
+ logical ROTATE_SEISMOGRAMS_RT
+
+! save all seismograms in one large combined file instead of one file per seismogram
+! to avoid overloading shared non-local file systems such as GPFS for instance
+ logical SAVE_ALL_SEISMOS_IN_ONE_FILE
+ logical USE_BINARY_FOR_LARGE_FILE
+
+! variables used for calculation of backazimuth and
+! rotation of components if ROTATE_SEISMOGRAMS=.true.
+
+ integer ior_start,ior_end
+ double precision backaz
+ real(kind=CUSTOM_REAL) phi,cphi,sphi
+!----------------------------------------------------------------
+
+ if (ROTATE_SEISMOGRAMS_RT) then ! iorientation 1=N,2=E,3=Z,4=R,5=T
+ ior_start=3 ! starting from Z
+ ior_end =5 ! ending with T => ZRT
+ else
+ ior_start=1 ! starting from N
+ ior_end =3 ! ending with Z => NEZ
+ endif
+
+ !do iorientation = 1,NDIM
+ !do iorientation = 1,5 ! BS BS changed from 3 (NEZ) to 5 (NEZRT) components
+ do iorientation = ior_start,ior_end ! BS BS changed according to ROTATE_SEISMOGRAMS_RT
+
+ if(iorientation == 1) then
+ chn = 'LHN'
+ else if(iorientation == 2) then
+ chn = 'LHE'
+ else if(iorientation == 3) then
+ chn = 'LHZ'
+ else if(iorientation == 4) then
+ chn = 'LHR'
+ else if(iorientation == 5) then
+ chn = 'LHT'
+ else
+ call exit_MPI(myrank,'incorrect channel value')
+ endif
+
+ if (iorientation == 4 .or. iorientation == 5) then ! LMU BS BS
+
+ ! BS BS calculate backazimuth needed to rotate East and North
+ ! components to Radial and Transverse components
+
+ if (backaz>180.) then
+ phi=backaz-180.
+ elseif (backaz<180.) then
+ phi=backaz+180.
+ elseif (backaz==180.) then
+ phi=backaz
+ endif
+
+ cphi=cos(phi*pi/180)
+ sphi=sin(phi*pi/180)
+
+ ! BS BS do the rotation of the components and put result in
+ ! new variable seismogram_tmp
+ if (iorientation == 4) then ! radial component
+ do isample = 1,seismo_current
+ seismogram_tmp(iorientation,isample) = &
+ cphi * one_seismogram(1,isample) + sphi * one_seismogram(2,isample)
+ enddo
+ elseif (iorientation == 5) then ! transverse component
+ do isample = 1,seismo_current
+ seismogram_tmp(iorientation,isample) = &
+ -1*sphi * one_seismogram(1,isample) + cphi * one_seismogram(2,isample)
+ enddo
+ endif
+
+ else ! keep NEZ components
+ do isample = 1,seismo_current
+ seismogram_tmp(iorientation,isample) = one_seismogram(iorientation,isample)
+ enddo
+
+ endif
+
+! create the name of the seismogram file for each slice
+! file name includes the name of the station and the network
+ length_station_name = len_trim(station_name(irec))
+ length_network_name = len_trim(network_name(irec))
+
+! check that length conforms to standard
+ if(length_station_name < 1 .or. length_station_name > MAX_LENGTH_STATION_NAME) &
+ call exit_MPI(myrank,'wrong length of station name')
+
+ if(length_network_name < 1 .or. length_network_name > MAX_LENGTH_NETWORK_NAME) &
+ call exit_MPI(myrank,'wrong length of network name')
+
+! create the name of the seismogram file using the station name and network name
+ write(sisname,"('/',a,'.',a,'.',a3,'.semd')") station_name(irec)(1:length_station_name), &
+ network_name(irec)(1:length_network_name),chn
+
+! create this name also for the text line added to the unique big seismogram file
+ write(sisname_big_file,"(a,'.',a,'.',a3,'.semd')") station_name(irec)(1:length_station_name), &
+ network_name(irec)(1:length_network_name),chn
+
+ if (OUTPUT_SEISMOS_SAC_ALPHANUM .or. OUTPUT_SEISMOS_SAC_BINARY) then
+
+!######################## SAC Alphanumeric Seismos ############################
+!
+! written by Markus Treml and Bernhard Schuberth, Dept. for Earth and Environ-
+! mental Sciences, Ludwig-Maximilians-University Munich, Germany
+!
+! some words about SAC timing:
+!==============================
+!
+!NPTS,DELTA,B,E:
+! These define the timing of the seismogram. E is calculated by sac. So, say
+! you have 100 NPTS, a DELTA of 0.5, and set B to 0, E should be 50.
+! Likewise setting B to -50 gives an E of 0. Cutting basically cuts out points
+! between the two times you designate based on these values.
+!KZTIME and KZDATE:
+! Now things get funky. KZTIME defines the exact time that the trace begins
+! at. It has no affect on timing per se. You'll really notice its effect if
+! you read in two traces from different dates.
+
+! Reference markers, (e.g. the o-marker) are not defined relative to this time,
+! but rather to the begin time (B) of the seismo, so if you adjust B, you also
+! need to adjust KZTIME to match. l would suggest experimenting with this until
+! you understand it. It is a little non-intuitive until you see it for yourself.
+!
+!-----------------------------------------------------------------------------
+!
+! This file is essentially the alphanumeric equivalent of the SAC binary data
+! file. The header section is stored on the first 30 cards. This is followed
+! by one or two data sections. The data is in 5G15.7 format.
+!----------------------------------------------------------------------
+
+! define certain default values
+
+! unused or undefined values are set to '-12345.00'
+ UNUSED = -12345.00 ! header fields unused by SAC
+ undef = -12345.00 ! undefined values
+ INTERNAL = -12345.00 ! SAC internal variables, always left undefined
+ BYSAC = -12345.00 ! values calculated by SAC from other variables
+!
+ DELTA = DT ! [REQUIRED]
+ DEPMIN = BYSAC
+ DEPMAX = BYSAC
+ DEPMEN = BYSAC
+ SCALE_F= 1000000000 ! factor for y-value, set to 10e9, so that values are in nm
+ ODELTA = undef ! increment from delta
+
+ B = sngl((seismo_offset)*DT-hdur + t_cmt) ! [REQUIRED]
+ E = BYSAC ! [REQUIRED]
+ O = undef !###
+ A = undef !###
+!station values:
+ STLA = stlat(irec)
+ STLO = stlon(irec)
+ STEL = stele(irec)
+ STDP = undef !stdep(irec)
+!event values (hypocenter):
+ EVLA = elat
+ EVLO = elon
+ EVEL = undef !not defined
+ EVDP = depth
+
+!cmt location values (different from hypocenter location, usually):
+ USER0 = cmt_lat
+ USER1 = cmt_lon
+ USER2 = cmt_depth
+
+ USER3 = cmt_hdur !half duration from CMT if not changed to hdur=0.d0 (point source)
+
+ MAG = mb !
+ IMAGTYP= 52 ! 52 = Mb? 55 = Mw!
+
+ DIST = BYSAC ! cause
+ AZ = BYSAC ! LCALDA
+ BAZ = BYSAC ! is
+ GCARC = BYSAC ! TRUE
+
+! instrument orientation
+ if(iorientation == 1) then !N
+ CMPAZ = 0.00
+ CMPINC =90.00
+ else if(iorientation == 2) then !E
+ CMPAZ =90.00
+ CMPINC =90.00
+ else if(iorientation == 3) then !Z
+ CMPAZ = 0.00
+ CMPINC = 0.00
+ else if(iorientation == 4) then !R
+ CMPAZ = modulo(phi,360.) ! phi is calculated above (see call distaz())
+ CMPINC =90.00
+ else if(iorientation == 5) then !T
+ CMPAZ = modulo(phi+90.,360.) ! phi is calculated above (see call distaz())
+ CMPINC =90.00
+ endif
+!----------------end format G15.7--------
+
+! date and time:
+ NZYEAR =yr
+ NZJDAY =jda
+ NZHOUR =ho
+ NZMIN =mi
+ NZSEC =int(sec)
+ NZMSEC =int((sec-int(sec))*1000)
+
+ NVHDR=6 ! SAC header version number. Current is 6
+
+! CSS3.0 variables:
+ NORID =int(undef) !origin ID
+ NEVID =int(undef) !event ID
+!NWVID =undef !waveform ID
+
+! NUMBER of POINTS:
+ NPTS = it_end-seismo_offset ! [REQUIRED]
+! event type
+ IFTYPE = 1 ! 1=ITIME, i.e. seismogram [REQUIRED] # numbering system is
+ IDEP = 6 ! 6: displ/nm # quite strange, best
+
+ IZTYPE = 11 !=origint reference time equivalent ! # by chnhdr and write
+ IEVTYP = 40 !event type, 40: Earthquake # alpha and check
+ IQUAL = int(undef) ! quality
+ ISYNTH = int(undef) ! 1 real data, 2...n synth. flag
+! permission flags:
+ LEVEN =1 ! evenly spaced data [REQUIRED]
+ LPSPOL=1 ! ? pos. polarity of components (has to be TRUE for LCALDA=1)
+ LOVROK=1 ! 1: OK to overwrite file on disk
+ LCALDA=1 ! 1: calculate DIST, AZ, BAZ, and GCARC, 0: do nothing
+! ------------------end format 5I10---------
+!
+!----------------------------------
+ KSTNM = station_name(irec) ! A8
+
+ if (NSOURCES == 1) then
+ KEVNM = ename(1:len_trim(ename))//'_syn'! A16
+ else
+ KEVNM = ename(1:len_trim(ename))//'_sFS'! A16
+ endif
+
+!----------------------------------
+ KCMPNM = chn(3:3) ! 3A8
+ KNETWK = network_name(irec) ! A6
+
+ KUSER0 = 'CMT_LAT_' ! A8
+ KUSER1 = 'CMT_LON_' ! A8
+ KUSER2 = 'CMTDEPTH' ! A8
+!----------------------------------
+
+ if (OUTPUT_SEISMOS_SAC_ALPHANUM) then
+
+ endif ! OUTPUT_SEISMOS_SAC_ALPHANUM
+
+! For explaination on values set, see above (SAC ASCII)
+ if (OUTPUT_SEISMOS_SAC_BINARY) then
+
+ endif ! OUTPUT_SEISMOS_SAC_BINARY
+
+!#################### end SAC Alphanumeric Seismos ############################
+
+ endif ! OUTPUT_SEISMOS_SAC_ALPHANUM .or. OUTPUT_SEISMOS_SAC_BINARY
+
+ if(OUTPUT_SEISMOS_ASCII_TEXT) then
+
+! save seismograms in text format with no subsampling.
+! Because we do not subsample the output, this can result in large files
+! if the simulation uses many time steps. However, subsampling the output
+! here would result in a loss of accuracy when one later convolves
+! the results with the source time function
+
+! add .ascii extension to seismogram file name for ASCII seismograms
+ write(sisname_2,"('/',a,'.ascii')") trim(sisname)
+
+! create one large file instead of one small file per station to avoid file system overload
+ if(SAVE_ALL_SEISMOS_IN_ONE_FILE) then
+ if(USE_BINARY_FOR_LARGE_FILE) then
+ write(IOUT) sisname_big_file
+ else
+ write(IOUT,*) sisname_big_file(1:len_trim(sisname_big_file))
+ endif
+ else
+ if (seismo_offset==0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname_2),status='unknown')
+ else
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(sisname_2),status='old',position='append')
+ endif
+
+ endif
+
+ ! subtract half duration of the source to make sure travel time is correct
+ do isample = 1,seismo_current
+ value = dble(seismogram_tmp(iorientation,isample))
+
+ if(SAVE_ALL_SEISMOS_IN_ONE_FILE .and. USE_BINARY_FOR_LARGE_FILE) then
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ write(IOUT) sngl(dble(seismo_offset+isample-1)*DT - hdur),sngl(value)
+ else
+ write(IOUT) dble(seismo_offset+isample-1)*DT - hdur,value
+ endif
+ else
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ write(IOUT,*) sngl(dble(seismo_offset+isample-1)*DT - hdur),' ',sngl(value)
+ else
+ write(IOUT,*) dble(seismo_offset+isample-1)*DT - hdur,' ',value
+ endif
+ endif
+
+ enddo
+
+ if(.not. SAVE_ALL_SEISMOS_IN_ONE_FILE) close(IOUT)
+
+ endif ! OUTPUT_SEISMOS_ASCII_TEXT
+
+ enddo ! do iorientation
+
+ end subroutine write_one_seismogram
+
More information about the cig-commits
mailing list