[cig-commits] r20555 - in seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER: setup src/auxiliaries src/create_header_file src/cuda src/meshfem3D src/shared src/specfem3D
danielpeter at geodynamics.org
danielpeter at geodynamics.org
Fri Aug 3 15:16:22 PDT 2012
Author: danielpeter
Date: 2012-08-03 15:16:21 -0700 (Fri, 03 Aug 2012)
New Revision: 20555
Modified:
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/setup/constants.h.in
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/auxiliaries/combine_AVS_DX.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/auxiliaries/create_movie_AVS_DX.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/auxiliaries/create_movie_GMT_global.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/create_header_file/create_header_file.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/compute_forces_crust_mantle_cuda.cu
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/specfem3D_gpu_cuda_method_stubs.c
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/add_topography.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/add_topography_410_650.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/calc_jacobian.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/compute_coordinates_grid.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/compute_element_properties.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_central_cube.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_doubling_elements.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_mass_matrices.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regions_mesh.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regular_elements.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/finalize_mesher.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_interfaces.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_global.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_jacobian_boundaries.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_model.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/initialize_mesher.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/meshfem3D_models.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/meshfem3D_par.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_crust.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_crustmaps.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_epcrust.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_eucrust.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_gapp2.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_jp3d.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_ppm.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_s362ani.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_sea99_s.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/moho_stretching.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/setup_model.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/sort_array_coordinates.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/stretching_function.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/write_AVS_DX_global_chunks_data.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/auto_ner.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/get_model_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/lagrange_poly.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/model_topo_bathy.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/reduce.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/save_header_file.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_arrays_source.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/initialize_simulation.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/iterate_time.F90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/locate_receivers.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/locate_sources.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/multiply_arrays_source.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_arrays_solver.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_mesh_databases.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_topography_bathymetry.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/setup_sources_receivers.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/specfem3D_par.F90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/write_seismograms.f90
Log:
updates module usage for models; avoids 3D moho stretching when no topography is used
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/setup/constants.h.in
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/setup/constants.h.in 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/setup/constants.h.in 2012-08-03 22:16:21 UTC (rev 20555)
@@ -324,9 +324,12 @@
double precision, parameter :: PI = 3.141592653589793d0
double precision, parameter :: TWO_PI = 2.d0 * PI
double precision, parameter :: PI_OVER_FOUR = PI / 4.d0
+ double precision, parameter :: PI_OVER_TWO = PI / 2.0d0
! to convert angles from degrees to radians
double precision, parameter :: DEGREES_TO_RADIANS = PI / 180.d0
+! to convert angles from radians to degrees
+ double precision, parameter :: RADIANS_TO_DEGREES = 180.d0 / PI
! 3-D simulation
integer, parameter :: NDIM = 3
@@ -575,10 +578,6 @@
! heterogen_mantle_model_constants
integer, parameter :: N_R = 256,N_THETA = 256,N_PHI = 256
-! Japan 3D model (Zhao, 1994) constants
- integer, parameter :: MPA=42,MRA=48,MHA=21,MPB=42,MRB=48,MHB=18
- integer, parameter :: MKA=2101,MKB=2101
-
! QRFSI12 constants
integer,parameter :: NKQ=8,MAXL_Q=12
integer,parameter :: NSQ=(MAXL_Q+1)**2,NDEPTHS_REFQ=913
@@ -594,30 +593,6 @@
double precision,parameter :: LON_MIN = 130.d0
double precision,parameter :: DEP_MAX = 500.d0
-! crustal_model_constants
-! crustal model parameters for crust2.0
- integer, parameter :: NKEYS_CRUST = 359
- integer, parameter :: NLAYERS_CRUST = 8
- integer, parameter :: NCAP_CRUST = 180
-
-! General Crustmaps parameters
- integer, parameter :: CRUSTMAP_RESOLUTION = 4 !means 1/4 degrees
- integer, parameter :: NLAYERS_CRUSTMAP = 5
-
-! parameters for EPCRUST , from Molinari & Morelli model(2011)
-! latitude : 9.0N - 89.5N
-! longitude: 56.0W - 70.0E
- character(len=*), parameter :: PATHNAME_EPCRUST = 'DATA/epcrust/EPcrust_0_5.txt'
- integer, parameter :: EPCRUST_NLON = 253, EPCRUST_NLAT = 162, EPCRUST_NLAYER = 3
- double precision, parameter :: EPCRUST_LON_MIN = -56.0d0
- double precision, parameter :: EPCRUST_LON_MAX = 70.0d0
- double precision, parameter :: EPCRUST_LAT_MIN = 9.0d0
- double precision, parameter :: EPCRUST_LAT_MAX = 89.5d0
- double precision, parameter :: EPCRUST_SAMPLE = 0.5d0
- logical, parameter :: flag_smooth_epcrust = .true.
- integer, parameter :: NTHETA_EP = 4, NPHI_EP = 20
- double precision, parameter :: cap_degree_EP = 0.2d0
-
! parameters for GLL model (used for iterative model inversions)
character(len=*), parameter :: PATHNAME_GLL_modeldir = 'DATA/GLL/'
integer, parameter :: GLL_REFERENCE_MODEL = THREE_D_MODEL_S29EA
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/auxiliaries/combine_AVS_DX.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/auxiliaries/combine_AVS_DX.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/auxiliaries/combine_AVS_DX.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -1029,8 +1029,8 @@
! convert geographic latitude lat (degrees)
! to geocentric colatitude theta (radians)
- theta=PI/2.0d0-atan(0.99329534d0*tan(dble(lat(1))*PI/180.0d0))
- phi=dble(long(1))*PI/180.0d0
+ theta=PI_OVER_TWO-atan(0.99329534d0*tan(dble(lat(1))*DEGREES_TO_RADIANS))
+ phi=dble(long(1))*DEGREES_TO_RADIANS
call reduce(theta,phi)
! compute Cartesian position of the source (ignore ellipticity for AVS_DX)
@@ -1043,7 +1043,7 @@
! save triangle for AVS or DX representation of epicenter
r_target_source = 1.05d0
- delta_trgl = 1.8 * pi / 180.
+ delta_trgl = 1.8 * DEGREES_TO_RADIANS
x_source_trgl1 = r_target_source*sin(theta+delta_trgl)*cos(phi-delta_trgl)
y_source_trgl1 = r_target_source*sin(theta+delta_trgl)*sin(phi-delta_trgl)
z_source_trgl1 = r_target_source*cos(theta+delta_trgl)
@@ -1093,8 +1093,8 @@
! 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
+ theta=PI_OVER_TWO-atan(0.99329534d0*dtan(stlat(irec)*DEGREES_TO_RADIANS))
+ phi=stlon(irec)*DEGREES_TO_RADIANS
call reduce(theta,phi)
! compute the Cartesian position of the receiver (ignore ellipticity for AVS_DX)
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/auxiliaries/create_movie_AVS_DX.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/auxiliaries/create_movie_AVS_DX.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/auxiliaries/create_movie_AVS_DX.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -616,12 +616,12 @@
! note: converts the geocentric colatitude to a geographic colatitude
if(.not. ASSUME_PERFECT_SPHERE) then
- thetaval = PI/2.0d0 - &
+ thetaval = PI_OVER_TWO - &
datan(1.006760466d0*dcos(dble(thetaval))/dmax1(TINYVAL,dble(sin(thetaval))))
endif
- lat = (PI/2.0-thetaval)*180.0/PI
- long = phival*180.0/PI
+ lat = (PI_OVER_TWO-thetaval)*RADIANS_TO_DEGREES
+ long = phival*RADIANS_TO_DEGREES
if(long > 180.0) long = long-360.0
write(11,*) long,lat,sngl(field_display(ilocnum+ieoff))
endif
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/auxiliaries/create_movie_GMT_global.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/auxiliaries/create_movie_GMT_global.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/auxiliaries/create_movie_GMT_global.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -395,15 +395,15 @@
! converts values into radians
! colatitude [0, PI]
- LAT_SOURCE = (90. - LAT_SOURCE)*PI/180.0
+ LAT_SOURCE = (90.0 - LAT_SOURCE)*DEGREES_TO_RADIANS
! longitude [-PI, PI]
if( LON_SOURCE < -180.0 ) LON_SOURCE = LON_SOURCE + 360.0
if( LON_SOURCE > 180.0 ) LON_SOURCE = LON_SOURCE - 360.0
- LON_SOURCE = LON_SOURCE *PI/180.0
+ LON_SOURCE = LON_SOURCE * DEGREES_TO_RADIANS
! mute radius in rad
- RADIUS_TO_MUTE = RADIUS_TO_MUTE*PI/180.0
+ RADIUS_TO_MUTE = RADIUS_TO_MUTE * DEGREES_TO_RADIANS
endif
print *,'--------'
@@ -456,7 +456,7 @@
! approximate wavefront travel distance in degrees
! (~3.5 km/s wave speed for surface waves)
- distance = 3.5 * ((it-1)*DT-t0) / 6371.0 * 180./PI
+ distance = 3.5 * ((it-1)*DT-t0) / 6371.0 * RADIANS_TO_DEGREES
! approximate distance to source (in degrees)
! (shrinks if waves travel back from antipode)
@@ -477,7 +477,7 @@
print*,'muting radius: ',0.7 * distance,'(degrees)'
! new radius of mute area (in rad)
- RADIUS_TO_MUTE = 0.7 * distance * PI/180.
+ RADIUS_TO_MUTE = 0.7 * distance * DEGREES_TO_RADIANS
else
! mute_factor used at the beginning for scaling displacement values
if( STARTTIME_TO_MUTE > TINYVAL ) then
@@ -586,17 +586,17 @@
! checks source longitude range
if( LON_SOURCE - RADIUS_TO_MUTE < -PI .or. LON_SOURCE + RADIUS_TO_MUTE > PI ) then
! source close to 180. longitudes, shifts range to [0, 2PI]
- if( phival < 0.0 ) phival = phival + 2.0*PI
+ if( phival < 0.0 ) phival = phival + TWO_PI
if( LON_SOURCE < 0.0 ) then
- dist_lon = phival - (LON_SOURCE + 2.0*PI)
+ dist_lon = phival - (LON_SOURCE + TWO_PI)
else
dist_lon = phival - LON_SOURCE
endif
else
! source well between range to [-PI, PI]
! shifts phival to be like LON_SOURCE between [-PI,PI]
- if( phival > PI ) phival = phival - 2.0*PI
- if( phival < -PI ) phival = phival + 2.0*PI
+ if( phival > PI ) phival = phival - TWO_PI
+ if( phival < -PI ) phival = phival + TWO_PI
dist_lon = phival - LON_SOURCE
endif
@@ -765,7 +765,7 @@
if( max_absol < max_average ) then
! distance (in degree) of surface waves travelled
- distance = 3.5 * ((it-1)*DT-t0) / 6371.0 * 180./PI
+ distance = 3.5 * ((it-1)*DT-t0) / 6371.0 * RADIANS_TO_DEGREES
if( distance > 10.0 .and. distance <= 20.0 ) then
! smooth transition between 10 and 20 degrees
! sets positive and negative maximum
@@ -912,13 +912,13 @@
! converts the geocentric colatitude to a geographic colatitude
if(.not. ASSUME_PERFECT_SPHERE) then
- thetaval = PI/2.0d0 - &
+ thetaval = PI_OVER_TWO - &
datan(1.006760466d0*dcos(dble(thetaval))/dmax1(TINYVAL,dble(sin(thetaval))))
endif
! gets geographic latitude and longitude in degrees
- lat = sngl(90.d0 - thetaval*180.0/PI)
- long = sngl(phival*180.0/PI)
+ lat = sngl(90.d0 - thetaval*RADIANS_TO_DEGREES)
+ long = sngl(phival*RADIANS_TO_DEGREES)
if(long > 180.0) long = long-360.0
endif
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/create_header_file/create_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/create_header_file/create_header_file.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/create_header_file/create_header_file.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -179,7 +179,7 @@
! 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,TOPOGRAPHY, &
+ ELLIPTICITY,GRAVITY,ROTATION, &
OCEANS,ATTENUATION,ATTENUATION_NEW,ATTENUATION_3D, &
ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,NCHUNKS, &
INCLUDE_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES, &
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/compute_forces_crust_mantle_cuda.cu
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/compute_forces_crust_mantle_cuda.cu 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/compute_forces_crust_mantle_cuda.cu 2012-08-03 22:16:21 UTC (rev 20555)
@@ -492,6 +492,7 @@
cosfourtheta = cosf(4.0f * theta);
cosfourphi = cosf(4.0f * phi);
+
}else{
// double operations
costheta = cos(theta);
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/specfem3D_gpu_cuda_method_stubs.c
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/specfem3D_gpu_cuda_method_stubs.c 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/specfem3D_gpu_cuda_method_stubs.c 2012-08-03 22:16:21 UTC (rev 20555)
@@ -1,4 +1,4 @@
-/*
+/*
!=====================================================================
!
! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
@@ -34,8 +34,8 @@
typedef float realw;
-
+
//
// src/cuda/assemble_MPI_scalar_cuda.cu
//
@@ -43,12 +43,12 @@
void FC_FUNC_(transfer_boun_pot_from_device,
TRANSFER_BOUN_POT_FROM_DEVICE)(long* Mesh_pointer_f,
realw* send_potential_dot_dot_buffer,
- int* FORWARD_OR_ADJOINT){}
+ int* FORWARD_OR_ADJOINT){}
void FC_FUNC_(transfer_asmbl_pot_to_device,
TRANSFER_ASMBL_POT_TO_DEVICE)(long* Mesh_pointer,
realw* buffer_recv_scalar,
- int* FORWARD_OR_ADJOINT) {}
+ int* FORWARD_OR_ADJOINT) {}
//
@@ -59,13 +59,13 @@
TRANSFER_BOUN_ACCEL_FROM_DEVICE)(long* Mesh_pointer_f,
realw* send_accel_buffer,
int* IREGION,
- int* FORWARD_OR_ADJOINT){}
+ int* FORWARD_OR_ADJOINT){}
void FC_FUNC_(transfer_asmbl_accel_to_device,
TRANSFER_ASMBL_ACCEL_TO_DEVICE)(long* Mesh_pointer,
realw* buffer_recv_vector,
int* IREGION,
- int* FORWARD_OR_ADJOINT) {}
+ int* FORWARD_OR_ADJOINT) {}
//
@@ -73,58 +73,58 @@
//
void FC_FUNC_(pause_for_debug,
- PAUSE_FOR_DEBUG)() {}
+ PAUSE_FOR_DEBUG)() {}
void FC_FUNC_(output_free_device_memory,
- OUTPUT_FREE_DEVICE_MEMORY)(int* myrank) {}
+ OUTPUT_FREE_DEVICE_MEMORY)(int* myrank) {}
void FC_FUNC_(get_free_device_memory,
- get_FREE_DEVICE_MEMORY)(realw* free, realw* used, realw* total ) {}
+ get_FREE_DEVICE_MEMORY)(realw* free, realw* used, realw* total ) {}
void FC_FUNC_(check_max_norm_displ_gpu,
- CHECK_MAX_NORM_DISPL_GPU)(int* size, realw* displ,long* Mesh_pointer_f,int* announceID) {}
+ CHECK_MAX_NORM_DISPL_GPU)(int* size, realw* displ,long* Mesh_pointer_f,int* announceID) {}
void FC_FUNC_(check_max_norm_vector,
- CHECK_MAX_NORM_VECTOR)(int* size, realw* vector1, int* announceID) {}
+ CHECK_MAX_NORM_VECTOR)(int* size, realw* vector1, int* announceID) {}
void FC_FUNC_(check_max_norm_displ,
- CHECK_MAX_NORM_DISPL)(int* size, realw* displ, int* announceID) {}
+ CHECK_MAX_NORM_DISPL)(int* size, realw* displ, int* announceID) {}
void FC_FUNC_(check_max_norm_b_displ_gpu,
- CHECK_MAX_NORM_B_DISPL_GPU)(int* size, realw* b_displ,long* Mesh_pointer_f,int* announceID) {}
+ CHECK_MAX_NORM_B_DISPL_GPU)(int* size, realw* b_displ,long* Mesh_pointer_f,int* announceID) {}
void FC_FUNC_(check_max_norm_b_accel_gpu,
- CHECK_MAX_NORM_B_ACCEL_GPU)(int* size, realw* b_accel,long* Mesh_pointer_f,int* announceID) {}
+ CHECK_MAX_NORM_B_ACCEL_GPU)(int* size, realw* b_accel,long* Mesh_pointer_f,int* announceID) {}
void FC_FUNC_(check_max_norm_b_veloc_gpu,
- CHECK_MAX_NORM_B_VELOC_GPU)(int* size, realw* b_veloc,long* Mesh_pointer_f,int* announceID) {}
+ CHECK_MAX_NORM_B_VELOC_GPU)(int* size, realw* b_veloc,long* Mesh_pointer_f,int* announceID) {}
void FC_FUNC_(check_max_norm_b_displ,
- CHECK_MAX_NORM_B_DISPL)(int* size, realw* b_displ,int* announceID) {}
+ CHECK_MAX_NORM_B_DISPL)(int* size, realw* b_displ,int* announceID) {}
void FC_FUNC_(check_max_norm_b_accel,
- CHECK_MAX_NORM_B_ACCEL)(int* size, realw* b_accel,int* announceID) {}
+ CHECK_MAX_NORM_B_ACCEL)(int* size, realw* b_accel,int* announceID) {}
void FC_FUNC_(check_error_vectors,
- CHECK_ERROR_VECTORS)(int* sizef, realw* vector1,realw* vector2) {}
+ CHECK_ERROR_VECTORS)(int* sizef, realw* vector1,realw* vector2) {}
void FC_FUNC_(get_max_accel,
- GET_MAX_ACCEL)(int* itf,int* sizef,long* Mesh_pointer) {}
+ GET_MAX_ACCEL)(int* itf,int* sizef,long* Mesh_pointer) {}
void FC_FUNC_(check_norm_acoustic_from_device,
CHECK_NORM_ACOUSTIC_FROM_DEVICE)(realw* norm,
long* Mesh_pointer_f,
- int* SIMULATION_TYPE) {}
+ int* SIMULATION_TYPE) {}
void FC_FUNC_(check_norm_elastic_from_device,
CHECK_NORM_ELASTIC_FROM_DEVICE)(realw* norm,
long* Mesh_pointer_f,
- int* SIMULATION_TYPE) {}
+ int* SIMULATION_TYPE) {}
void FC_FUNC_(check_norm_strain_from_device,
CHECK_NORM_STRAIN_FROM_DEVICE)(realw* strain_norm,
realw* strain_norm2,
- long* Mesh_pointer_f) {}
+ long* Mesh_pointer_f) {}
//
@@ -134,12 +134,12 @@
void FC_FUNC_(compute_add_sources_el_cuda,
COMPUTE_ADD_SOURCES_EL_CUDA)(long* Mesh_pointer_f,
int* NSOURCESf,
- double* h_stf_pre_compute) {}
+ double* h_stf_pre_compute) {}
void FC_FUNC_(compute_add_sources_el_s3_cuda,
COMPUTE_ADD_SOURCES_EL_S3_CUDA)(long* Mesh_pointer_f,
int* NSOURCESf,
- double* h_stf_pre_compute) {}
+ double* h_stf_pre_compute) {}
void FC_FUNC_(add_sources_el_sim_type_2_or_3,
ADD_SOURCES_EL_SIM_TYPE_2_OR_3)(long* Mesh_pointer,
@@ -147,7 +147,7 @@
realw* h_adj_sourcearrays,
int* h_islice_selected_rec,
int* h_ispec_selected_rec,
- int* time_index) {}
+ int* time_index) {}
//
@@ -155,26 +155,26 @@
//
void FC_FUNC_(compute_coupling_fluid_cmb_cuda,
- COMPUTE_COUPLING_FLUID_CMB_CUDA)(long* Mesh_pointer_f) {}
+ COMPUTE_COUPLING_FLUID_CMB_CUDA)(long* Mesh_pointer_f) {}
void FC_FUNC_(compute_coupling_fluid_icb_cuda,
- COMPUTE_COUPLING_FLUID_ICB_CUDA)(long* Mesh_pointer_f) {}
+ COMPUTE_COUPLING_FLUID_ICB_CUDA)(long* Mesh_pointer_f) {}
void FC_FUNC_(compute_coupling_cmb_fluid_cuda,
COMPUTE_COUPLING_CMB_FLUID_CUDA)(long* Mesh_pointer_f,
double RHO_TOP_OC,
realw minus_g_cmb,
- int GRAVITY_VAL) {}
+ int GRAVITY_VAL) {}
void FC_FUNC_(compute_coupling_icb_fluid_cuda,
COMPUTE_COUPLING_ICB_FLUID_CUDA)(long* Mesh_pointer_f,
double RHO_BOTTOM_OC,
realw minus_g_icb,
- int GRAVITY_VAL) {}
+ int GRAVITY_VAL) {}
void FC_FUNC_(compute_coupling_ocean_cuda,
COMPUTE_COUPLING_OCEAN_CUDA)(long* Mesh_pointer_f,
- int* NCHUNKS_VAL) {}
+ int* NCHUNKS_VAL) {}
//
@@ -184,7 +184,7 @@
void FC_FUNC_(compute_forces_crust_mantle_cuda,
COMPUTE_FORCES_CRUST_MANTLE_CUDA)(long* Mesh_pointer_f,
realw* deltat,
- int* iphase) {}
+ int* iphase) {}
//
@@ -194,7 +194,7 @@
void FC_FUNC_(compute_forces_inner_core_cuda,
COMPUTE_FORCES_INNER_CORE_CUDA)(long* Mesh_pointer_f,
realw* deltat,
- int* iphase) {}
+ int* iphase) {}
//
@@ -205,7 +205,7 @@
COMPUTE_FORCES_OUTER_CORE_CUDA)(long* Mesh_pointer_f,
int* iphase,
realw* time_f,
- realw* b_time_f) {}
+ realw* b_time_f) {}
//
@@ -213,22 +213,22 @@
//
void FC_FUNC_(compute_kernels_cm_cuda,
- COMPUTE_KERNELS_CM_CUDA)(long* Mesh_pointer,realw* deltat_f) {}
+ COMPUTE_KERNELS_CM_CUDA)(long* Mesh_pointer,realw* deltat_f) {}
void FC_FUNC_(compute_kernels_ic_cuda,
- COMPUTE_KERNELS_IC_CUDA)(long* Mesh_pointer,realw* deltat_f) {}
+ COMPUTE_KERNELS_IC_CUDA)(long* Mesh_pointer,realw* deltat_f) {}
void FC_FUNC_(compute_kernels_oc_cuda,
- COMPUTE_KERNELS_OC_CUDA)(long* Mesh_pointer,realw* deltat_f) {}
+ COMPUTE_KERNELS_OC_CUDA)(long* Mesh_pointer,realw* deltat_f) {}
void FC_FUNC_(compute_kernels_strgth_noise_cu,
COMPUTE_KERNELS_STRGTH_NOISE_CU)(long* Mesh_pointer,
realw* h_noise_surface_movie,
- realw* deltat_f) {}
+ realw* deltat_f) {}
void FC_FUNC_(compute_kernels_hess_cuda,
COMPUTE_KERNELS_HESS_CUDA)(long* Mesh_pointer,
- realw* deltat_f) {}
+ realw* deltat_f) {}
//
@@ -238,7 +238,7 @@
void FC_FUNC_(compute_stacey_acoustic_cuda,
COMPUTE_STACEY_ACOUSTIC_CUDA)(long* Mesh_pointer_f,
realw* absorb_potential,
- int* itype) {}
+ int* itype) {}
//
@@ -248,7 +248,7 @@
void FC_FUNC_(compute_stacey_elastic_cuda,
COMPUTE_STACEY_ELASTIC_CUDA)(long* Mesh_pointer_f,
realw* absorb_field,
- int* itype) {}
+ int* itype) {}
//
@@ -256,10 +256,10 @@
//
void FC_FUNC_(initialize_cuda_device,
- INITIALIZE_CUDA_DEVICE)(int* myrank_f,int* ncuda_devices) {
+ INITIALIZE_CUDA_DEVICE)(int* myrank_f,int* ncuda_devices) {
fprintf(stderr,"ERROR: GPU_MODE enabled without GPU/CUDA Support. To enable GPU support, reconfigure with --with-cuda flag.\n");
exit(1);
-}
+}
//
@@ -273,7 +273,7 @@
realw* deltatover2_F,
realw* b_deltat_F,
realw* b_deltatsqover2_F,
- realw* b_deltatover2_F) {}
+ realw* b_deltatover2_F) {}
void FC_FUNC_(it_update_displacement_cm_cuda,
IT_UPDATE_DISPLACMENT_CM_CUDA)(long* Mesh_pointer_f,
@@ -282,7 +282,7 @@
realw* deltatover2_F,
realw* b_deltat_F,
realw* b_deltatsqover2_F,
- realw* b_deltatover2_F) {}
+ realw* b_deltatover2_F) {}
void FC_FUNC_(it_update_displacement_oc_cuda,
IT_UPDATE_DISPLACEMENT_OC_cuda)(long* Mesh_pointer_f,
@@ -291,7 +291,7 @@
realw* deltatover2_F,
realw* b_deltat_F,
realw* b_deltatsqover2_F,
- realw* b_deltatover2_F) {}
+ realw* b_deltatover2_F) {}
void FC_FUNC_(kernel_3_a_cuda,
KERNEL_3_A_CUDA)(long* Mesh_pointer,
@@ -299,49 +299,49 @@
int* SIMULATION_TYPE_f,
realw* b_deltatover2_F,
int* OCEANS,
- int* NCHUNKS_VAL) {}
+ int* NCHUNKS_VAL) {}
void FC_FUNC_(kernel_3_b_cuda,
KERNEL_3_B_CUDA)(long* Mesh_pointer,
realw* deltatover2_F,
int* SIMULATION_TYPE_f,
realw* b_deltatover2_F,
- int* OCEANS) {}
+ int* OCEANS) {}
void FC_FUNC_(kernel_3_outer_core_cuda,
KERNEL_3_OUTER_CORE_CUDA)(long* Mesh_pointer,
realw* deltatover2_F,
int* SIMULATION_TYPE_f,
- realw* b_deltatover2_F) {}
+ realw* b_deltatover2_F) {}
//
// src/cuda/noise_tomography_cuda.cu
//
-void FC_FUNC_(fortranflush,FORTRANFLUSH)(int* rank){}
+void FC_FUNC_(fortranflush,FORTRANFLUSH)(int* rank){}
-void FC_FUNC_(fortranprint,FORTRANPRINT)(int* id) {}
+void FC_FUNC_(fortranprint,FORTRANPRINT)(int* id) {}
-void FC_FUNC_(fortranprintf,FORTRANPRINTF)(realw* val) {}
+void FC_FUNC_(fortranprintf,FORTRANPRINTF)(realw* val) {}
-void FC_FUNC_(fortranprintd,FORTRANPRINTD)(double* val) {}
+void FC_FUNC_(fortranprintd,FORTRANPRINTD)(double* val) {}
-void FC_FUNC_(make_displ_rand,MAKE_DISPL_RAND)(long* Mesh_pointer_f,realw* h_displ) {}
+void FC_FUNC_(make_displ_rand,MAKE_DISPL_RAND)(long* Mesh_pointer_f,realw* h_displ) {}
void FC_FUNC_(noise_transfer_surface_to_host,
NOISE_TRANSFER_SURFACE_TO_HOST)(long* Mesh_pointer_f,
- realw* h_noise_surface_movie) {}
+ realw* h_noise_surface_movie) {}
void FC_FUNC_(noise_add_source_master_rec_cu,
NOISE_ADD_SOURCE_MASTER_REC_CU)(long* Mesh_pointer_f,
int* it_f,
int* irec_master_noise_f,
- int* islice_selected_rec) {}
+ int* islice_selected_rec) {}
void FC_FUNC_(noise_add_surface_movie_cuda,
NOISE_ADD_SURFACE_MOVIE_CUDA)(long* Mesh_pointer_f,
- realw* h_noise_surface_movie) {}
+ realw* h_noise_surface_movie) {}
//
@@ -383,7 +383,7 @@
int* SAVE_BOUNDARY_MESH_f,
int* USE_MESH_COLORING_GPU_f,
int* ANISOTROPIC_KL_f,
- int* APPROXIMATE_HESS_KL_f) {}
+ int* APPROXIMATE_HESS_KL_f) {}
void FC_FUNC_(prepare_fields_rotation_device,
PREPARE_FIELDS_ROTATION_DEVICE)(long* Mesh_pointer_f,
@@ -396,7 +396,7 @@
realw* b_A_array_rotation,
realw* b_B_array_rotation,
int* NSPEC_OUTER_CORE_ROTATION
- ) {}
+ ) {}
void FC_FUNC_(prepare_fields_gravity_device,
PREPARE_FIELDS_gravity_DEVICE)(long* Mesh_pointer_f,
@@ -407,7 +407,7 @@
realw* density_table,
realw* h_wgll_cube,
int* NRAD_GRAVITY
- ) {}
+ ) {}
void FC_FUNC_(prepare_fields_attenuat_device,
PREPARE_FIELDS_ATTENUAT_DEVICE)(long* Mesh_pointer_f,
@@ -427,7 +427,7 @@
realw* one_minus_sum_beta_inner_core,
realw* alphaval,realw* betaval,realw* gammaval,
realw* b_alphaval,realw* b_betaval,realw* b_gammaval
- ) {}
+ ) {}
void FC_FUNC_(prepare_fields_strain_device,
PREPARE_FIELDS_STRAIN_DEVICE)(long* Mesh_pointer_f,
@@ -455,7 +455,7 @@
realw* b_epsilondev_yz_inner_core,
realw* eps_trace_over_3_inner_core,
realw* b_eps_trace_over_3_inner_core
- ) {}
+ ) {}
void FC_FUNC_(prepare_fields_absorb_device,
PREPARE_FIELDS_ABSORB_DEVICE)(long* Mesh_pointer_f,
@@ -487,7 +487,7 @@
realw* jacobian2D_ymin_outer_core, realw* jacobian2D_ymax_outer_core,
realw* jacobian2D_bottom_outer_core,
realw* vp_outer_core
- ) {}
+ ) {}
void FC_FUNC_(prepare_mpi_buffers_device,
PREPARE_MPI_BUFFERS_DEVICE)(long* Mesh_pointer_f,
@@ -503,7 +503,7 @@
int* max_nibool_interfaces_outer_core,
int* nibool_interfaces_outer_core,
int* ibool_interfaces_outer_core
- ){}
+ ){}
void FC_FUNC_(prepare_fields_noise_device,
PREPARE_FIELDS_NOISE_DEVICE)(long* Mesh_pointer_f,
@@ -515,7 +515,7 @@
realw* normal_y_noise,
realw* normal_z_noise,
realw* mask_noise,
- realw* jacobian2D_top_crust_mantle) {}
+ realw* jacobian2D_top_crust_mantle) {}
void FC_FUNC_(prepare_crust_mantle_device,
PREPARE_CRUST_MANTLE_DEVICE)(long* Mesh_pointer_f,
@@ -549,7 +549,7 @@
int* NSPEC2D_TOP_CM,
int* NSPEC2D_BOTTOM_CM,
int* NCHUNKS_VAL
- ) {}
+ ) {}
void FC_FUNC_(prepare_outer_core_device,
PREPARE_OUTER_CORE_DEVICE)(long* Mesh_pointer_f,
@@ -572,7 +572,7 @@
int* nspec_inner,
int* NSPEC2D_TOP_OC,
int* NSPEC2D_BOTTOM_OC
- ) {}
+ ) {}
void FC_FUNC_(prepare_inner_core_device,
PREPARE_INNER_CORE_DEVICE)(long* Mesh_pointer_f,
@@ -591,15 +591,15 @@
int* phase_ispec_inner,
int* nspec_outer,
int* nspec_inner,
- int* NSPEC2D_TOP_IC) {}
+ int* NSPEC2D_TOP_IC) {}
void FC_FUNC_(prepare_oceans_device,
PREPARE_OCEANS_DEVICE)(long* Mesh_pointer_f,
- realw* h_rmass_ocean_load) {}
+ realw* h_rmass_ocean_load) {}
void FC_FUNC_(prepare_cleanup_device,
PREPARE_CLEANUP_DEVICE)(long* Mesh_pointer_f,
- int* NCHUNKS_VAL) {}
+ int* NCHUNKS_VAL) {}
//
@@ -607,82 +607,82 @@
//
void FC_FUNC_(transfer_fields_cm_to_device,
- TRANSFER_FIELDS_CM_TO_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_FIELDS_CM_TO_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_fields_ic_to_device,
- TRANSFER_FIELDS_IC_TO_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_FIELDS_IC_TO_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_fields_oc_to_device,
- TRANSFER_FIELDS_OC_TO_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_FIELDS_OC_TO_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_fields_cm_to_device,
TRANSFER_FIELDS_B_CM_TO_DEVICE)(int* size, realw* b_displ, realw* b_veloc, realw* b_accel,
- long* Mesh_pointer_f) {}
+ long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_fields_ic_to_device,
TRANSFER_FIELDS_B_IC_TO_DEVICE)(int* size, realw* b_displ, realw* b_veloc, realw* b_accel,
- long* Mesh_pointer_f) {}
+ long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_fields_oc_to_device,
TRANSFER_FIELDS_B_OC_TO_DEVICE)(int* size, realw* b_displ, realw* b_veloc, realw* b_accel,
- long* Mesh_pointer_f) {}
+ long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_fields_cm_from_device,
- TRANSFER_FIELDS_CM_FROM_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_FIELDS_CM_FROM_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_fields_ic_from_device,
- TRANSFER_FIELDS_IC_FROM_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_FIELDS_IC_FROM_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_fields_oc_from_device,
- TRANSFER_FIELDS_OC_FROM_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_FIELDS_OC_FROM_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_fields_cm_from_device,
TRANSFER_B_FIELDS_CM_FROM_DEVICE)(int* size, realw* b_displ, realw* b_veloc, realw* b_accel,
- long* Mesh_pointer_f) {}
+ long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_fields_ic_from_device,
TRANSFER_B_FIELDS_IC_FROM_DEVICE)(int* size, realw* b_displ, realw* b_veloc, realw* b_accel,
- long* Mesh_pointer_f) {}
+ long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_fields_oc_from_device,
TRANSFER_B_FIELDS_OC_FROM_DEVICE)(int* size, realw* b_displ, realw* b_veloc, realw* b_accel,
- long* Mesh_pointer_f) {}
+ long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_accel_cm_to_device,
- TRANSFER_ACCEL_CM_TO_DEVICE)(int* size, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_ACCEL_CM_TO_DEVICE)(int* size, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_displ_cm_from_device,
- TRANSFER_DISPL_CM_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
+ TRANSFER_DISPL_CM_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_displ_cm_from_device,
- TRANSFER_B_DISPL_CM_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
+ TRANSFER_B_DISPL_CM_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_displ_ic_from_device,
- TRANSFER_DISPL_IC_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
+ TRANSFER_DISPL_IC_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_displ_ic_from_device,
- TRANSFER_B_DISPL_IC_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
+ TRANSFER_B_DISPL_IC_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_displ_oc_from_device,
- TRANSFER_DISPL_OC_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
+ TRANSFER_DISPL_OC_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_displ_oc_from_device,
- TRANSFER_B_DISPL_OC_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
+ TRANSFER_B_DISPL_OC_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_veloc_cm_from_device,
- TRANSFER_DISPL_CM_FROM_DEVICE)(int* size, realw* veloc, long* Mesh_pointer_f) {}
+ TRANSFER_DISPL_CM_FROM_DEVICE)(int* size, realw* veloc, long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_accel_cm_from_device,
- TRANSFER_ACCEL_CM_FROM_DEVICE)(int* size, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_ACCEL_CM_FROM_DEVICE)(int* size, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_accel_cm_from_device,
- TRANSFER_B_ACCEL_CM_FROM_DEVICE)(int* size, realw* b_accel,long* Mesh_pointer_f) {}
+ TRANSFER_B_ACCEL_CM_FROM_DEVICE)(int* size, realw* b_accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_accel_ic_from_device,
- TRANSFER_ACCEL_IC_FROM_DEVICE)(int* size, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_ACCEL_IC_FROM_DEVICE)(int* size, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_accel_oc_from_device,
- TRANSFER_ACCEL_OC_FROM_DEVICE)(int* size, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_ACCEL_OC_FROM_DEVICE)(int* size, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_strain_cm_from_device,
TRANSFER_STRAIN_CM_FROM_DEVICE)(long* Mesh_pointer,
@@ -691,7 +691,7 @@
realw* epsilondev_yy,
realw* epsilondev_xy,
realw* epsilondev_xz,
- realw* epsilondev_yz) {}
+ realw* epsilondev_yz) {}
void FC_FUNC_(transfer_b_strain_cm_to_device,
TRANSFER_B_STRAIN_CM_TO_DEVICE)(long* Mesh_pointer,
@@ -699,7 +699,7 @@
realw* epsilondev_yy,
realw* epsilondev_xy,
realw* epsilondev_xz,
- realw* epsilondev_yz) {}
+ realw* epsilondev_yz) {}
void FC_FUNC_(transfer_strain_ic_from_device,
TRANSFER_STRAIN_IC_FROM_DEVICE)(long* Mesh_pointer,
@@ -708,7 +708,7 @@
realw* epsilondev_yy,
realw* epsilondev_xy,
realw* epsilondev_xz,
- realw* epsilondev_yz) {}
+ realw* epsilondev_yz) {}
void FC_FUNC_(transfer_b_strain_ic_to_device,
TRANSFER_B_STRAIN_IC_TO_DEVICE)(long* Mesh_pointer,
@@ -716,17 +716,17 @@
realw* epsilondev_yy,
realw* epsilondev_xy,
realw* epsilondev_xz,
- realw* epsilondev_yz) {}
+ realw* epsilondev_yz) {}
void FC_FUNC_(transfer_rotation_from_device,
TRANSFER_ROTATION_FROM_DEVICE)(long* Mesh_pointer,
realw* A_array_rotation,
- realw* B_array_rotation) {}
+ realw* B_array_rotation) {}
void FC_FUNC_(transfer_b_rotation_to_device,
TRANSFER_B_ROTATION_TO_DEVICE)(long* Mesh_pointer,
realw* A_array_rotation,
- realw* B_array_rotation) {}
+ realw* B_array_rotation) {}
void FC_FUNC_(transfer_kernels_cm_to_host,
TRANSFER_KERNELS_CM_TO_HOST)(long* Mesh_pointer,
@@ -734,30 +734,30 @@
realw* h_alpha_kl,
realw* h_beta_kl,
realw* h_cijkl_kl,
- int* NSPEC) {}
+ int* NSPEC) {}
void FC_FUNC_(transfer_kernels_ic_to_host,
TRANSFER_KERNELS_IC_TO_HOST)(long* Mesh_pointer,
realw* h_rho_kl,
realw* h_alpha_kl,
realw* h_beta_kl,
- int* NSPEC) {}
+ int* NSPEC) {}
void FC_FUNC_(transfer_kernels_oc_to_host,
TRANSFER_KERNELS_OC_TO_HOST)(long* Mesh_pointer,
realw* h_rho_kl,
realw* h_alpha_kl,
- int* NSPEC) {}
+ int* NSPEC) {}
void FC_FUNC_(transfer_kernels_noise_to_host,
TRANSFER_KERNELS_NOISE_TO_HOST)(long* Mesh_pointer,
realw* h_Sigma_kl,
- int* NSPEC) {}
+ int* NSPEC) {}
void FC_FUNC_(transfer_kernels_hess_cm_tohost,
TRANSFER_KERNELS_HESS_CM_TOHOST)(long* Mesh_pointer,
realw* h_hess_kl,
- int* NSPEC) {}
+ int* NSPEC) {}
//
@@ -777,7 +777,7 @@
int* number_receiver_global,
int* ispec_selected_rec,
int* ispec_selected_source,
- int* ibool) {}
+ int* ibool) {}
void FC_FUNC_(transfer_station_ac_from_device,
TRANSFER_STATION_AC_FROM_DEVICE)(
@@ -792,5 +792,5 @@
int* ispec_selected_rec,
int* ispec_selected_source,
int* ibool,
- int* SIMULATION_TYPEf) {}
+ int* SIMULATION_TYPEf) {}
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/add_topography.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/add_topography.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/add_topography.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -25,56 +25,60 @@
!
!=====================================================================
- subroutine add_topography(myrank,xelm,yelm,zelm,ibathy_topo,R220)
+ subroutine add_topography(myrank,xelm,yelm,zelm,ibathy_topo)
+ use constants,only: &
+ NGNOD,NX_BATHY,NY_BATHY,R_EARTH,R_UNIT_SPHERE, &
+ PI_OVER_TWO,RADIANS_TO_DEGREES,TINYVAL,ONE
+
+ use meshfem3D_par,only: R220
+
implicit none
- include "constants.h"
+! include "constants.h"
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
+ integer :: myrank
- integer myrank
+ double precision,dimension(NGNOD) :: xelm,yelm,zelm
-! use integer array to store values
+ ! use integer array to store values
integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
- integer ia
+ ! local parameters
+ double precision :: lat,lon,elevation
+ double precision :: r,theta,phi,colat
+ double precision :: gamma
+ 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
+ ! 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
+ ! gets elevation of point
+ ! 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)))
+ ! convert the geocentric colatitude to a geographic colatitude
+ colat = PI_OVER_TWO - 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
+ ! get geographic latitude and longitude in degrees
+ lat = (PI_OVER_TWO - colat) * RADIANS_TO_DEGREES
+ lon = phi * RADIANS_TO_DEGREES
-! compute elevation at current point
+ ! compute elevation at current point
call get_topo_bathy(lat,lon,elevation,ibathy_topo)
-! non-dimensionalize the elevation, which is in meters
+ ! non-dimensionalize the elevation, which is in meters
elevation = elevation / R_EARTH
-! stretching topography between d220 and the surface
+ ! 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
+ ! 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)
@@ -98,11 +102,12 @@
! xstore,ystore,zstore,
! ispec,nspec,
! ibathy_topo
- ! R220
- subroutine add_topography_gll(myrank,xstore,ystore,zstore,ispec,nspec,&
- ibathy_topo,R220)
+ subroutine add_topography_gll(myrank,xstore,ystore,zstore,ispec,nspec, &
+ ibathy_topo)
+ use meshfem3D_par,only: R220
+
implicit none
include "constants.h"
@@ -110,9 +115,10 @@
! input parameters
integer:: myrank
integer:: ispec,nspec
+
double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec):: xstore,ystore,zstore
+
integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
- double precision:: R220
! local parameters used in this subroutine
integer:: i,j,k
@@ -133,12 +139,11 @@
! convert the geocentric colatitude to a geographic colatitude
- colat = PI/2.0d0 - datan(1.006760466d0*dcos(theta)/dmax1(TINYVAL,dsin(theta)))
+ colat = PI_OVER_TWO - 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
+ lat = (PI_OVER_TWO - colat) * RADIANS_TO_DEGREES
+ lon = phi * RADIANS_TO_DEGREES
! compute elevation at current point
call get_topo_bathy(lat,lon,elevation,ibathy_topo)
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/add_topography_410_650.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/add_topography_410_650.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/add_topography_410_650.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -25,12 +25,10 @@
!
!=====================================================================
- 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)
+ subroutine add_topography_410_650(myrank,xelm,yelm,zelm)
+ use meshfem3D_par,only: R220,R400,R670,R771
+
implicit none
include "constants.h"
@@ -41,8 +39,6 @@
double precision yelm(NGNOD)
double precision zelm(NGNOD)
- double precision R220,R400,R670,R771
-
integer ia
real(kind=4) xcolat,xlon
@@ -52,37 +48,6 @@
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
@@ -91,15 +56,11 @@
call reduce(theta,phi)
! get colatitude and longitude in degrees
- xcolat = sngl(theta*180.0d0/PI)
- xlon = sngl(phi*180.0d0/PI)
+ xcolat = sngl(theta*RADIANS_TO_DEGREES)
+ xlon = sngl(phi*RADIANS_TO_DEGREES)
! 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)
+ call model_s362ani_subtopo(xcolat,xlon,topo410out,topo650out)
! non-dimensionalize the topography, which is in km
! positive for a depression, so change the sign for a perturbation in radius
@@ -139,12 +100,10 @@
!> Hejun
! use GLL points to capture 410_650 topography
! JAN08, 2010
- subroutine add_topography_410_650_gll(myrank,xstore,ystore,zstore,ispec,nspec,R220,R400,R670,R771, &
- numker,numhpa,numcof,ihpa,lmax,nylm, &
- lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
- nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
- coe,ylmcof,wk1,wk2,wk3,varstr)
+ subroutine add_topography_410_650_gll(myrank,xstore,ystore,zstore,ispec,nspec)
+ use meshfem3D_par,only: R220,R400,R670,R771
+
implicit none
include "constants.h"
@@ -153,8 +112,6 @@
integer:: ispec,nspec
double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec):: xstore,ystore,zstore
- double precision R220,R400,R670,R771
-
integer i,j,k
real(kind=4) xcolat,xlon
@@ -164,37 +121,6 @@
double precision r,theta,phi
double precision gamma
- integer, parameter :: maxker=200
- integer, parameter :: maxl=72
- integer, parameter :: maxcoe=2000
- integer, parameter :: maxver=1000
- integer, parameter :: maxhpa=2
-
- integer numker
- integer numhpa,numcof
- integer ihpa,lmax,nylm
- integer lmxhpa(maxhpa)
- integer itypehpa(maxhpa)
- integer ihpakern(maxker)
- integer numcoe(maxhpa)
- integer ivarkern(maxker)
-
- integer nconpt(maxhpa),iver
- integer iconpt(maxver,maxhpa)
- real(kind=4) conpt(maxver,maxhpa)
-
- real(kind=4) xlaspl(maxcoe,maxhpa)
- real(kind=4) xlospl(maxcoe,maxhpa)
- real(kind=4) radspl(maxcoe,maxhpa)
- real(kind=4) coe(maxcoe,maxker)
-
- real(kind=4) ylmcof((maxl+1)**2,maxhpa)
- real(kind=4) wk1(maxl+1)
- real(kind=4) wk2(maxl+1)
- real(kind=4) wk3(maxl+1)
-
- character(len=40) varstr(maxker)
-
! we loop on all GLL points of the element
do k = 1,NGLLZ
do j = 1,NGLLY
@@ -205,15 +131,11 @@
call reduce(theta,phi)
! get colatitude and longitude in degrees
- xcolat = sngl(theta*180.0d0/PI)
- xlon = sngl(phi*180.0d0/PI)
+ xcolat = sngl(theta*RADIANS_TO_DEGREES)
+ xlon = sngl(phi*RADIANS_TO_DEGREES)
! 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)
+ call model_s362ani_subtopo(xcolat,xlon,topo410out,topo650out)
! non-dimensionalize the topography, which is in km
! positive for a depression, so change the sign for a perturbation in radius
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/calc_jacobian.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/calc_jacobian.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/calc_jacobian.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -34,15 +34,14 @@
! xstore,ystore,zstore ----- input GLL point coordinate
! xigll,yigll,zigll ----- gll points position
! ispec,nspec ----- element number
-! ACTUALLY_STORE_ARRAYS ------ save array or not
! output: xixstore,xiystore,xizstore,
! etaxstore,etaystore,etazstore,
! gammaxstore,gammaystore,gammazstore ------ parameters used to calculate jacobian
- subroutine recalc_jacobian_gll3D(myrank,xstore,ystore,zstore,xigll,yigll,zigll,&
- ispec,nspec,ACTUALLY_STORE_ARRAYS,&
+ subroutine calc_jacobian_gll3D(myrank,xstore,ystore,zstore,xigll,yigll,zigll,&
+ ispec,nspec,&
xixstore,xiystore,xizstore, &
etaxstore,etaystore,etazstore, &
gammaxstore,gammaystore,gammazstore)
@@ -53,18 +52,17 @@
! input parameter
integer::myrank,ispec,nspec
+
double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
+
double precision, dimension(NGLLX):: xigll
double precision, dimension(NGLLY):: yigll
double precision, dimension(NGLLZ):: zigll
- logical::ACTUALLY_STORE_ARRAYS
-
! output results
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
- xixstore,xiystore,xizstore,&
- etaxstore,etaystore,etazstore,&
- gammaxstore,gammaystore,gammazstore
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore
! local parameters for this subroutine
@@ -75,160 +73,157 @@
double precision,dimension(NGLLY):: hetar,hpetar
double precision,dimension(NGLLZ):: hgammar,hpgammar
double precision:: hlagrange,hlagrange_xi,hlagrange_eta,hlagrange_gamma
- double precision:: jacobian
+ double precision:: jacobian,jacobian_inv
double precision:: xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
double precision:: r,theta,phi
-
! test parameters which can be deleted
double precision:: xmesh,ymesh,zmesh
double precision:: sumshape,sumdershapexi,sumdershapeeta,sumdershapegamma
! first go over all 125 GLL points
do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
+ do j=1,NGLLY
+ do i=1,NGLLX
- xxi = 0.0
- xeta = 0.0
- xgamma = 0.0
- yxi = 0.0
- yeta = 0.0
- ygamma = 0.0
- zxi = 0.0
- zeta = 0.0
- zgamma = 0.0
+ xxi = ZERO
+ xeta = ZERO
+ xgamma = ZERO
+ yxi = ZERO
+ yeta = ZERO
+ ygamma = ZERO
+ zxi = ZERO
+ zeta = ZERO
+ zgamma = ZERO
- xi = xigll(i)
- eta = yigll(j)
- gamma = zigll(k)
+ xi = xigll(i)
+ eta = yigll(j)
+ gamma = zigll(k)
- ! calculate lagrange polynomial and its derivative
- call lagrange_any(xi,NGLLX,xigll,hxir,hpxir)
- call lagrange_any(eta,NGLLY,yigll,hetar,hpetar)
- call lagrange_any(gamma,NGLLZ,zigll,hgammar,hpgammar)
+ ! calculate lagrange polynomial and its derivative
+ call lagrange_any(xi,NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(eta,NGLLY,yigll,hetar,hpetar)
+ call lagrange_any(gamma,NGLLZ,zigll,hgammar,hpgammar)
- ! test parameters
- sumshape = 0.0
- sumdershapexi = 0.0
- sumdershapeeta = 0.0
- sumdershapegamma = 0.0
- xmesh = 0.0
- ymesh = 0.0
- zmesh = 0.0
+ ! test parameters
+ sumshape = ZERO
+ sumdershapexi = ZERO
+ sumdershapeeta = ZERO
+ sumdershapegamma = ZERO
+ xmesh = ZERO
+ ymesh = ZERO
+ zmesh = ZERO
+ do k1 = 1,NGLLZ
+ do j1 = 1,NGLLY
+ do i1 = 1,NGLLX
+ hlagrange = hxir(i1)*hetar(j1)*hgammar(k1)
+ hlagrange_xi = hpxir(i1)*hetar(j1)*hgammar(k1)
+ hlagrange_eta = hxir(i1)*hpetar(j1)*hgammar(k1)
+ hlagrange_gamma = hxir(i1)*hetar(j1)*hpgammar(k1)
- do k1 = 1,NGLLZ
- do j1 = 1,NGLLY
- do i1 = 1,NGLLX
- hlagrange = hxir(i1)*hetar(j1)*hgammar(k1)
- hlagrange_xi = hpxir(i1)*hetar(j1)*hgammar(k1)
- hlagrange_eta = hxir(i1)*hpetar(j1)*hgammar(k1)
- hlagrange_gamma = hxir(i1)*hetar(j1)*hpgammar(k1)
+ xxi = xxi + xstore(i1,j1,k1,ispec)*hlagrange_xi
+ xeta = xeta + xstore(i1,j1,k1,ispec)*hlagrange_eta
+ xgamma = xgamma + xstore(i1,j1,k1,ispec)*hlagrange_gamma
+ yxi = yxi + ystore(i1,j1,k1,ispec)*hlagrange_xi
+ yeta = yeta + ystore(i1,j1,k1,ispec)*hlagrange_eta
+ ygamma = ygamma + ystore(i1,j1,k1,ispec)*hlagrange_gamma
- xxi = xxi + xstore(i1,j1,k1,ispec)*hlagrange_xi
- xeta = xeta + xstore(i1,j1,k1,ispec)*hlagrange_eta
- xgamma = xgamma + xstore(i1,j1,k1,ispec)*hlagrange_gamma
+ zxi = zxi + zstore(i1,j1,k1,ispec)*hlagrange_xi
+ zeta = zeta + zstore(i1,j1,k1,ispec)*hlagrange_eta
+ zgamma = zgamma + zstore(i1,j1,k1,ispec)*hlagrange_gamma
- yxi = yxi + ystore(i1,j1,k1,ispec)*hlagrange_xi
- yeta = yeta + ystore(i1,j1,k1,ispec)*hlagrange_eta
- ygamma = ygamma + ystore(i1,j1,k1,ispec)*hlagrange_gamma
+ ! test the lagrange polynomial and its derivate
+ xmesh = xmesh + xstore(i1,j1,k1,ispec)*hlagrange
+ ymesh = ymesh + ystore(i1,j1,k1,ispec)*hlagrange
+ zmesh = zmesh + zstore(i1,j1,k1,ispec)*hlagrange
+ sumshape = sumshape + hlagrange
+ sumdershapexi = sumdershapexi + hlagrange_xi
+ sumdershapeeta = sumdershapeeta + hlagrange_eta
+ sumdershapegamma = sumdershapegamma + hlagrange_gamma
- zxi = zxi + zstore(i1,j1,k1,ispec)*hlagrange_xi
- zeta = zeta + zstore(i1,j1,k1,ispec)*hlagrange_eta
- zgamma = zgamma + zstore(i1,j1,k1,ispec)*hlagrange_gamma
-
- ! test the lagrange polynomial and its derivate
- xmesh = xmesh + xstore(i1,j1,k1,ispec)*hlagrange
- ymesh = ymesh + ystore(i1,j1,k1,ispec)*hlagrange
- zmesh = zmesh + zstore(i1,j1,k1,ispec)*hlagrange
- sumshape = sumshape + hlagrange
- sumdershapexi = sumdershapexi + hlagrange_xi
- sumdershapeeta = sumdershapeeta + hlagrange_eta
- sumdershapegamma = sumdershapegamma + hlagrange_gamma
-
- end do
- end do
end do
+ end do
+ end do
- ! Check the lagrange polynomial and its derivative
- if (abs(xmesh - xstore(i,j,k,ispec)) > TINYVAL &
- .or. abs(ymesh - ystore(i,j,k,ispec)) > TINYVAL &
- .or. abs(zmesh - zstore(i,j,k,ispec)) > TINYVAL ) then
- call exit_MPI(myrank,'new mesh are wrong in recalc_jacobian_gall3D.f90')
- end if
- if(abs(sumshape-one) > TINYVAL) then
- call exit_MPI(myrank,'error shape functions in recalc_jacobian_gll3D.f90')
- end if
- if(abs(sumdershapexi) > TINYVAL) then
- call exit_MPI(myrank,'error derivative xi in recalc_jacobian_gll3D.f90')
- end if
- if(abs(sumdershapeeta) > TINYVAL) then
- call exit_MPI(myrank,'error derivative eta in recalc_jacobian_gll3D.f90')
- end if
- if(abs(sumdershapegamma) > TINYVAL) then
- call exit_MPI(myrank,'error derivative gamma in recalc_jacobian_gll3D.f90')
- end if
+ ! Check the lagrange polynomial and its derivative
+ if (abs(xmesh - xstore(i,j,k,ispec)) > TINYVAL &
+ .or. abs(ymesh - ystore(i,j,k,ispec)) > TINYVAL &
+ .or. abs(zmesh - zstore(i,j,k,ispec)) > TINYVAL ) then
+ call exit_MPI(myrank,'new mesh are wrong in recalc_jacobian_gall3D.f90')
+ end if
+ if(abs(sumshape-one) > TINYVAL) then
+ call exit_MPI(myrank,'error shape functions in calc_jacobian_gll3D.f90')
+ end if
+ if(abs(sumdershapexi) > TINYVAL) then
+ call exit_MPI(myrank,'error derivative xi in calc_jacobian_gll3D.f90')
+ end if
+ if(abs(sumdershapeeta) > TINYVAL) then
+ call exit_MPI(myrank,'error derivative eta in calc_jacobian_gll3D.f90')
+ end if
+ if(abs(sumdershapegamma) > TINYVAL) then
+ call exit_MPI(myrank,'error derivative gamma in calc_jacobian_gll3D.f90')
+ end if
+ ! jacobian calculation
+ jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
+ xeta*(yxi*zgamma-ygamma*zxi) + &
+ xgamma*(yxi*zeta-yeta*zxi)
- jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
- xeta*(yxi*zgamma-ygamma*zxi) + &
- xgamma*(yxi*zeta-yeta*zxi)
+ ! Check the jacobian
+ ! note: when honoring the moho, we squeeze and stretch elements
+ ! thus, it can happen that with a coarse mesh resolution, the jacobian encounters problems
+ if(jacobian <= VERYSMALLVAL) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r,theta,phi)
+ print*,'error jacobian rank:',myrank
+ print*,' location r/lat/lon: ',r*R_EARTH_KM, &
+ (PI_OVER_TWO-theta)*RADIANS_TO_DEGREES,phi*RADIANS_TO_DEGREES
+ print*,' jacobian: ',jacobian
+ call exit_MPI(myrank,'3D Jacobian undefined in calc_jacobian_gll3D.f90')
+ end if
- ! Check the jacobian
- ! note: when honoring the moho, we squeeze and stretch elements
- ! thus, it can happen that with a coarse mesh resolution, the jacobian encounters problems
- if(jacobian <= ZERO) then
- call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r,theta,phi)
- print*,'error jacobian rank:',myrank
- print*,' location r/lat/lon: ',r*R_EARTH_KM,90.0-theta*180./PI,phi*180./PI
- print*,' jacobian: ',jacobian
- call exit_MPI(myrank,'3D Jacobian undefined in recalc_jacobian_gll3D.f90')
- end if
+ ! invert the relation (Fletcher p. 50 vol. 2)
+ jacobian_inv = ONE / jacobian
- ! 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
+ xix = (yeta*zgamma-ygamma*zeta) * jacobian_inv
+ xiy = (xgamma*zeta-xeta*zgamma) * jacobian_inv
+ xiz = (xeta*ygamma-xgamma*yeta) * jacobian_inv
+ etax = (ygamma*zxi-yxi*zgamma) * jacobian_inv
+ etay = (xxi*zgamma-xgamma*zxi) * jacobian_inv
+ etaz = (xgamma*yxi-xxi*ygamma) * jacobian_inv
+ gammax = (yxi*zeta-yeta*zxi) * jacobian_inv
+ gammay = (xeta*zxi-xxi*zeta) * jacobian_inv
+ gammaz = (xxi*yeta-xeta*yxi) * jacobian_inv
-
- ! resave the derivatives and the jacobian
- ! distinguish between single and double precision for reals
- if (ACTUALLY_STORE_ARRAYS) then
- if(CUSTOM_REAL == SIZE_REAL) then
- xixstore(i,j,k,ispec) = sngl(xix)
- xiystore(i,j,k,ispec) = sngl(xiy)
- xizstore(i,j,k,ispec) = sngl(xiz)
- etaxstore(i,j,k,ispec) = sngl(etax)
- etaystore(i,j,k,ispec) = sngl(etay)
- etazstore(i,j,k,ispec) = sngl(etaz)
- gammaxstore(i,j,k,ispec) = sngl(gammax)
- gammaystore(i,j,k,ispec) = sngl(gammay)
- gammazstore(i,j,k,ispec) = sngl(gammaz)
- else
- xixstore(i,j,k,ispec) = xix
- xiystore(i,j,k,ispec) = xiy
- xizstore(i,j,k,ispec) = xiz
- etaxstore(i,j,k,ispec) = etax
- etaystore(i,j,k,ispec) = etay
- etazstore(i,j,k,ispec) = etaz
- gammaxstore(i,j,k,ispec) = gammax
- gammaystore(i,j,k,ispec) = gammay
- gammazstore(i,j,k,ispec) = gammaz
- endif
- end if
- enddo
+ ! resave the derivatives and the jacobian
+ ! 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)
+ else
+ xixstore(i,j,k,ispec) = xix
+ xiystore(i,j,k,ispec) = xiy
+ xizstore(i,j,k,ispec) = xiz
+ etaxstore(i,j,k,ispec) = etax
+ etaystore(i,j,k,ispec) = etay
+ etazstore(i,j,k,ispec) = etaz
+ gammaxstore(i,j,k,ispec) = gammax
+ gammaystore(i,j,k,ispec) = gammay
+ gammazstore(i,j,k,ispec) = gammaz
+ endif
+ enddo
enddo
enddo
- end subroutine recalc_jacobian_gll3D
+ end subroutine calc_jacobian_gll3D
!
@@ -244,15 +239,19 @@
! xigll,yigll,NSPEC2DMAX_AB,NGLLA,NGLLB
! output results: jacobian2D,normal
- subroutine recalc_jacobian_gll2D(myrank,ispecb, &
+ subroutine calc_jacobian_gll2D(myrank,ispecb, &
xelm2D,yelm2D,zelm2D,xigll,yigll,&
jacobian2D,normal,NGLLA,NGLLB,NSPEC2DMAX_AB)
implicit none
+
include "constants.h"
+
! input parameters
integer::myrank,ispecb,NSPEC2DMAX_AB,NGLLA,NGLLB
+
double precision,dimension(NGLLA,NGLLB)::xelm2D,yelm2D,zelm2D
+
double precision,dimension(NGLLA)::xigll
double precision,dimension(NGLLB)::yigll
@@ -260,23 +259,22 @@
real(kind=CUSTOM_REAL),dimension(NGLLA,NGLLB,NSPEC2DMAX_AB)::jacobian2D
real(kind=CUSTOM_REAL),dimension(3,NGLLA,NGLLB,NSPEC2DMAX_AB)::normal
-
! local parameters in this subroutine
integer::i,j,i1,j1
double precision::xxi,xeta,yxi,yeta,zxi,zeta,&
- xi,eta,xmesh,ymesh,zmesh,hlagrange,hlagrange_xi,hlagrange_eta,&
- sumshape,sumdershapexi,sumdershapeeta,unx,uny,unz,jacobian
+ xi,eta,xmesh,ymesh,zmesh,hlagrange,hlagrange_xi,hlagrange_eta,&
+ sumshape,sumdershapexi,sumdershapeeta,unx,uny,unz,jacobian,jacobian_inv
double precision,dimension(NGLLA)::hxir,hpxir
double precision,dimension(NGLLB)::hetar,hpetar
do j = 1,NGLLB
do i = 1,NGLLA
- xxi = 0.0
- xeta = 0.0
- yxi = 0.0
- yeta = 0.0
- zxi = 0.0
- zeta = 0.0
+ xxi = ZERO
+ xeta = ZERO
+ yxi = ZERO
+ yeta = ZERO
+ zxi = ZERO
+ zeta = ZERO
xi=xigll(i)
eta = yigll(j)
@@ -284,13 +282,13 @@
call lagrange_any(xi,NGLLA,xigll,hxir,hpxir)
call lagrange_any(eta,NGLLB,yigll,hetar,hpetar)
+ xmesh = ZERO
+ ymesh = ZERO
+ zmesh = ZERO
+ sumshape = ZERO
+ sumdershapexi = ZERO
+ sumdershapeeta = ZERO
- xmesh = 0.0
- ymesh = 0.0
- zmesh = 0.0
- sumshape = 0.0
- sumdershapexi = 0.0
- sumdershapeeta = 0.0
do j1 = 1,NGLLB
do i1 = 1,NGLLA
hlagrange = hxir(i1)*hetar(j1)
@@ -315,191 +313,48 @@
end do
end do
-
! Check the lagrange polynomial
if ( abs(xmesh - xelm2D(i,j)) > TINYVAL &
.or. abs(ymesh - yelm2D(i,j)) > TINYVAL &
.or. abs(zmesh - zelm2D(i,j)) > TINYVAL ) then
- call exit_MPI(myrank,'new boundary mesh is wrong in recalc_jacobian_gll2D')
+ call exit_MPI(myrank,'new boundary mesh is wrong in calc_jacobian_gll2D')
end if
-
if (abs(sumshape-one) > TINYVAL) then
- call exit_MPI(myrank,'error shape functions in recalc_jacobian_gll2D')
+ call exit_MPI(myrank,'error shape functions in calc_jacobian_gll2D')
end if
if (abs(sumdershapexi) > TINYVAL) then
- call exit_MPI(myrank,'error derivative xi in recalc_jacobian_gll2D')
+ call exit_MPI(myrank,'error derivative xi in calc_jacobian_gll2D')
end if
if (abs(sumdershapeeta) > TINYVAL) then
- call exit_MPI(myrank,'error derivative eta in recalc_jacobian_gll2D')
+ call exit_MPI(myrank,'error derivative eta in calc_jacobian_gll2D')
end if
+ ! calculates j2D acobian
unx = yxi*zeta - yeta*zxi
uny = zxi*xeta - zeta*xxi
unz = xxi*yeta - xeta*yxi
- jacobian = dsqrt(unx**2+uny**2+unz**2)
- if (abs(jacobian) < TINYVAL ) call exit_MPI(myrank,'2D Jacobian undefined in recalc_jacobian_gll2D')
+ jacobian = dsqrt(unx*unx + uny*uny + unz*unz)
+ ! checks
+ if (abs(jacobian) < TINYVAL ) &
+ call exit_MPI(myrank,'2D Jacobian undefined in calc_jacobian_gll2D')
+
+ ! inverts jacobian
+ jacobian_inv = ONE / jacobian
+
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)
+ jacobian2D(i,j,ispecb) = sngl(jacobian)
+ normal(1,i,j,ispecb) = sngl(unx * jacobian_inv)
+ normal(2,i,j,ispecb) = sngl(uny * jacobian_inv)
+ normal(3,i,j,ispecb) = sngl(unz * jacobian_inv)
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
+ jacobian2D(i,j,ispecb) = jacobian
+ normal(1,i,j,ispecb) = unx * jacobian_inv
+ normal(2,i,j,ispecb) = uny * jacobian_inv
+ normal(3,i,j,ispecb) = unz * jacobian_inv
endif
end do
end do
- end subroutine recalc_jacobian_gll2D
+ end subroutine calc_jacobian_gll2D
-!
-!-------------------------------------------------------------------------------------------------
-!
-! deprecated...
-!
-! subroutine calc_jacobian(myrank,xixstore,xiystore,xizstore, &
-! etaxstore,etaystore,etazstore, &
-! gammaxstore,gammaystore,gammazstore, &
-! xstore,ystore,zstore, &
-! xelm,yelm,zelm,shape3D,dershape3D,ispec,nspec,ACTUALLY_STORE_ARRAYS)
-!
-! implicit none
-!
-! include "constants.h"
-!
-! integer ispec,nspec,myrank
-!
-! logical ACTUALLY_STORE_ARRAYS
-!
-! double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
-! double precision dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ)
-!
-! double precision xelm(NGNOD)
-! double precision yelm(NGNOD)
-! double precision zelm(NGNOD)
-!
-! real(kind=CUSTOM_REAL) xixstore(NGLLX,NGLLY,NGLLZ,nspec), &
-! xiystore(NGLLX,NGLLY,NGLLZ,nspec), &
-! xizstore(NGLLX,NGLLY,NGLLZ,nspec), &
-! etaxstore(NGLLX,NGLLY,NGLLZ,nspec), &
-! etaystore(NGLLX,NGLLY,NGLLZ,nspec), &
-! etazstore(NGLLX,NGLLY,NGLLZ,nspec), &
-! gammaxstore(NGLLX,NGLLY,NGLLZ,nspec), &
-! gammaystore(NGLLX,NGLLY,NGLLZ,nspec), &
-! gammazstore(NGLLX,NGLLY,NGLLZ,nspec)
-!
-! double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
-! double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
-! double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-!
-! integer i,j,k,ia
-!
-! double precision xxi,xeta,xgamma,yxi,yeta,ygamma,zxi,zeta,zgamma
-! double precision xmesh,ymesh,zmesh
-! double precision xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
-! double precision jacobian
-!
-! do k=1,NGLLZ
-! do j=1,NGLLY
-! do i=1,NGLLX
-!
-! xxi = ZERO
-! xeta = ZERO
-! xgamma = ZERO
-! yxi = ZERO
-! yeta = ZERO
-! ygamma = ZERO
-! zxi = ZERO
-! zeta = ZERO
-! zgamma = ZERO
-! xmesh = ZERO
-! ymesh = ZERO
-! zmesh = ZERO
-!
-! do ia=1,NGNOD
-! xxi = xxi + dershape3D(1,ia,i,j,k)*xelm(ia)
-! xeta = xeta + dershape3D(2,ia,i,j,k)*xelm(ia)
-! xgamma = xgamma + dershape3D(3,ia,i,j,k)*xelm(ia)
-! yxi = yxi + dershape3D(1,ia,i,j,k)*yelm(ia)
-! yeta = yeta + dershape3D(2,ia,i,j,k)*yelm(ia)
-! ygamma = ygamma + dershape3D(3,ia,i,j,k)*yelm(ia)
-! zxi = zxi + dershape3D(1,ia,i,j,k)*zelm(ia)
-! zeta = zeta + dershape3D(2,ia,i,j,k)*zelm(ia)
-! zgamma = zgamma + dershape3D(3,ia,i,j,k)*zelm(ia)
-! xmesh = xmesh + shape3D(ia,i,j,k)*xelm(ia)
-! ymesh = ymesh + shape3D(ia,i,j,k)*yelm(ia)
-! zmesh = zmesh + shape3D(ia,i,j,k)*zelm(ia)
-! enddo
-!
-! jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
-! xeta*(yxi*zgamma-ygamma*zxi) + &
-! xgamma*(yxi*zeta-yeta*zxi)
-!
-! if(jacobian <= ZERO) then
-! print*,'jacobian error:',myrank
-! print*,' point ijk:',i,j,k,ispec
-! print*,' xyz:',xmesh,ymesh,zmesh
-! call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,xxi,xeta,xgamma)
-! print*,' r/lat/lon:',xxi*R_EARTH_KM,90.0-xeta*180./PI,xgamma*180./PI
-! print*,' nodes:'
-! do ia=1,NGNOD
-! print*,xelm(ia),yelm(ia),zelm(ia)
-! enddo
-! print*
-! print*,'maybe check with CAP smoothing'
-! call exit_MPI(myrank,'3D Jacobian undefined')
-! endif
-!
-!! invert the relation (Fletcher p. 50 vol. 2)
-! xix = (yeta*zgamma-ygamma*zeta) / jacobian
-! xiy = (xgamma*zeta-xeta*zgamma) / jacobian
-! xiz = (xeta*ygamma-xgamma*yeta) / jacobian
-! etax = (ygamma*zxi-yxi*zgamma) / jacobian
-! etay = (xxi*zgamma-xgamma*zxi) / jacobian
-! etaz = (xgamma*yxi-xxi*ygamma) / jacobian
-! gammax = (yxi*zeta-yeta*zxi) / jacobian
-! gammay = (xeta*zxi-xxi*zeta) / jacobian
-! gammaz = (xxi*yeta-xeta*yxi) / jacobian
-!
-!! save the derivatives and the jacobian
-!! distinguish between single and double precision for reals
-! if(ACTUALLY_STORE_ARRAYS) then
-! if(CUSTOM_REAL == SIZE_REAL) then
-! xixstore(i,j,k,ispec) = sngl(xix)
-! xiystore(i,j,k,ispec) = sngl(xiy)
-! xizstore(i,j,k,ispec) = sngl(xiz)
-! etaxstore(i,j,k,ispec) = sngl(etax)
-! etaystore(i,j,k,ispec) = sngl(etay)
-! etazstore(i,j,k,ispec) = sngl(etaz)
-! gammaxstore(i,j,k,ispec) = sngl(gammax)
-! gammaystore(i,j,k,ispec) = sngl(gammay)
-! gammazstore(i,j,k,ispec) = sngl(gammaz)
-! else
-! xixstore(i,j,k,ispec) = xix
-! xiystore(i,j,k,ispec) = xiy
-! xizstore(i,j,k,ispec) = xiz
-! etaxstore(i,j,k,ispec) = etax
-! etaystore(i,j,k,ispec) = etay
-! etazstore(i,j,k,ispec) = etaz
-! gammaxstore(i,j,k,ispec) = gammax
-! gammaystore(i,j,k,ispec) = gammay
-! gammazstore(i,j,k,ispec) = gammaz
-! endif
-! endif
-!
-!! store mesh coordinates
-!! xstore(i,j,k,ispec) = xmesh
-!! ystore(i,j,k,ispec) = ymesh
-!! zstore(i,j,k,ispec) = zmesh
-!
-! enddo
-! enddo
-! enddo
-!
-! end subroutine calc_jacobian
-!
-
-
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/compute_coordinates_grid.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/compute_coordinates_grid.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/compute_coordinates_grid.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -60,9 +60,7 @@
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
@@ -297,7 +295,6 @@
! 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
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/compute_element_properties.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/compute_element_properties.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/compute_element_properties.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -27,9 +27,7 @@
! compute several rheological and geometrical properties for a given spectral element
subroutine compute_element_properties(ispec,iregion_code,idoubling,ipass, &
- xstore,ystore,zstore,nspec,myrank,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xstore,ystore,zstore,nspec,myrank, &
xelm,yelm,zelm,shape3D,rmin,rmax,rhostore,dvpstore, &
kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
@@ -38,31 +36,26 @@
c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
nspec_ani,nspec_stacey,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
- vx,vy,vz,rho_vp,rho_vs,ACTUALLY_STORE_ARRAYS,&
+ vx,vy,vz,rho_vp,rho_vs,&
xigll,yigll,zigll,ispec_is_tiso)
use meshfem3D_models_par
+! use meshfem3D_par,only: R220
+
implicit none
! correct number of spectral elements in each block depending on chunk type
integer ispec,nspec,nspec_stacey
- logical ABSORBING_CONDITIONS,ACTUALLY_STORE_ARRAYS
-
- double precision RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220,R771,&
- R400,R120,R80,RMIDDLE_CRUST,ROCEAN,RMOHO_FICTITIOUS_IN_MESHER
-
! arrays with the mesh in double precision
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
! code for the four regions of the mesh
- integer iregion_code
+ integer :: iregion_code
! meshing phase
- integer ipass
+ integer :: ipass
! 3D shape functions and their derivatives
double precision, dimension(NGNOD,NGLLX,NGLLY,NGLLZ) :: shape3D
@@ -71,42 +64,42 @@
! parameters needed to store the radii of the grid points
! in the spherically symmetric Earth
- integer idoubling(nspec)
- double precision rmin,rmax
+ integer,dimension(nspec) :: idoubling
+ double precision :: rmin,rmax
! for model density and anisotropy
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rhostore,dvpstore,kappavstore, &
kappahstore,muvstore,muhstore,eta_anisostore
! the 21 coefficients for an anisotropic medium in reduced notation
- integer nspec_ani
+ integer :: nspec_ani
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_ani) :: &
c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
c36store,c44store,c45store,c46store,c55store,c56store,c66store
! arrays with mesh parameters
- integer nspec_actually
+ integer :: nspec_actually
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_actually) :: &
xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
! proc numbers for MPI
- integer myrank
+ integer :: myrank
! Stacey, indices for Clayton-Engquist absorbing conditions
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_stacey) :: rho_vp,rho_vs
! attenuation
- integer vx,vy,vz,nspec_att
+ integer :: vx,vy,vz,nspec_att
double precision, dimension(vx,vy,vz,nspec_att) :: Qmu_store
double precision, dimension(N_SLS,vx,vy,vz,nspec_att) :: tau_e_store
double precision, dimension(N_SLS) :: tau_s
- double precision T_c_source
+ double precision :: T_c_source
! Parameters used to calculate Jacobian based upon 125 GLL points
- double precision:: xigll(NGLLX)
- double precision:: yigll(NGLLY)
- double precision:: zigll(NGLLZ)
+ double precision :: xigll(NGLLX)
+ double precision :: yigll(NGLLY)
+ double precision :: zigll(NGLLZ)
logical, dimension(nspec) :: ispec_is_tiso
@@ -115,7 +108,7 @@
! flag for transverse isotropic elements
logical:: elem_is_tiso
- ! add topography of the Moho *before* adding the 3D crustal velocity model so that the streched
+ ! add topography of the Moho *before* adding the 3D crustal velocity model so that the stretched
! mesh gets assigned the right model values
elem_in_crust = .false.
elem_in_mantle = .false.
@@ -130,13 +123,11 @@
! differentiate between regional and global meshing
if( REGIONAL_MOHO_MESH ) then
- call moho_stretching_honor_crust_reg(myrank, &
- xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER,&
- R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
+ call moho_stretching_honor_crust_reg(myrank,xelm,yelm,zelm, &
+ elem_in_crust,elem_in_mantle)
else
- call moho_stretching_honor_crust(myrank, &
- xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER,&
- R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
+ call moho_stretching_honor_crust(myrank,xelm,yelm,zelm, &
+ elem_in_crust,elem_in_mantle)
endif
else
! element below 220km
@@ -205,11 +196,10 @@
c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
nspec_stacey,rho_vp,rho_vs, &
xstore,ystore,zstore, &
- rmin,rmax,RCMB,RICB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220, &
- R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ rmin,rmax, &
tau_s,tau_e_store,Qmu_store,T_c_source, &
size(tau_e_store,2),size(tau_e_store,3),size(tau_e_store,4),size(tau_e_store,5), &
- ABSORBING_CONDITIONS,elem_in_crust,elem_in_mantle)
+ elem_in_crust,elem_in_mantle)
endif
@@ -219,15 +209,16 @@
! problems with the jacobian. using the anchors is therefore more robust.
! adds surface topography
if( TOPOGRAPHY ) then
- if (idoubling(ispec)==IFLAG_CRUST .or. idoubling(ispec)==IFLAG_220_80 &
- .or. idoubling(ispec)==IFLAG_80_MOHO) then
+ if( idoubling(ispec) == IFLAG_CRUST .or. &
+ idoubling(ispec) == IFLAG_220_80 .or. &
+ idoubling(ispec) == IFLAG_80_MOHO) then
! stretches mesh between surface and R220 accordingly
if( USE_GLL ) then
! stretches every gll point accordingly
- call add_topography_gll(myrank,xstore,ystore,zstore,ispec,nspec,ibathy_topo,R220)
+ call add_topography_gll(myrank,xstore,ystore,zstore,ispec,nspec,ibathy_topo)
else
! stretches anchor points only, interpolates gll points later on
- call add_topography(myrank,xelm,yelm,zelm,ibathy_topo,R220)
+ call add_topography(myrank,xelm,yelm,zelm,ibathy_topo)
endif
endif
endif
@@ -237,19 +228,11 @@
.or. THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM .or. THREE_D_MODEL == THREE_D_MODEL_S29EA) then
if( USE_GLL ) then
! stretches every gll point accordingly
- call add_topography_410_650_gll(myrank,xstore,ystore,zstore,ispec,nspec,R220,R400,R670,R771, &
- numker,numhpa,numcof,ihpa,lmax,nylm, &
- lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
- nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
- coe,ylmcof,wk1,wk2,wk3,varstr)
+ call add_topography_410_650_gll(myrank,xstore,ystore,zstore,ispec,nspec)
else
! stretches anchor points only, interpolates gll points later on
- call add_topography_410_650(myrank,xelm,yelm,zelm,R220,R400,R670,R771, &
- numker,numhpa,numcof,ihpa,lmax,nylm, &
- lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
- nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
- coe,ylmcof,wk1,wk2,wk3,varstr)
+ call add_topography_410_650(myrank,xelm,yelm,zelm)
endif
endif
@@ -291,8 +274,8 @@
! updates jacobian
! (only needed for second meshing phase)
if( ipass == 2 ) then
- call recalc_jacobian_gll3D(myrank,xstore,ystore,zstore,xigll,yigll,zigll,&
- ispec,nspec,ACTUALLY_STORE_ARRAYS,&
+ call calc_jacobian_gll3D(myrank,xstore,ystore,zstore,xigll,yigll,zigll,&
+ ispec,nspec,&
xixstore,xiystore,xizstore,&
etaxstore,etaystore,etazstore,&
gammaxstore,gammaystore,gammazstore)
@@ -311,21 +294,17 @@
include "constants.h"
- integer ispec,nspec
+ integer :: ispec,nspec
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
+ double precision,dimension(NGNOD) :: xelm,yelm,zelm
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
- double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
+ double precision,dimension(NGNOD,NGLLX,NGLLY,NGLLZ) :: shape3D
! local parameters
- double precision xmesh,ymesh,zmesh
- integer i,j,k,ia
+ double precision :: xmesh,ymesh,zmesh
+ integer :: i,j,k,ia
do k=1,NGLLZ
do j=1,NGLLY
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_central_cube.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_central_cube.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_central_cube.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -30,8 +30,6 @@
iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,ratio_divide_central_cube, &
iMPIcut_xi,iMPIcut_eta,iboun, &
idoubling,iregion_code,xstore,ystore,zstore, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME,&
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
shape3D,rmin,rmax,rhostore,dvpstore,&
kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
@@ -40,7 +38,7 @@
c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
nspec_ani,nspec_stacey,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,vx,vy,vz, &
- rho_vp,rho_vs,ABSORBING_CONDITIONS,ACTUALLY_STORE_ARRAYS,xigll,yigll,zigll, &
+ rho_vp,rho_vs,xigll,yigll,zigll, &
ispec_is_tiso)
! creates the inner core cube of the mesh
@@ -58,8 +56,7 @@
integer NPROC_XI,NPROC_ETA
- double precision R_CENTRAL_CUBE,RICB,RCMB,R670,RMOHO,RTOPDDOUBLEPRIME,&
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN,RMOHO_FICTITIOUS_IN_MESHER
+ double precision R_CENTRAL_CUBE
! arrays with the mesh in double precision
double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
@@ -119,8 +116,6 @@
double precision, dimension(N_SLS) :: tau_s
double precision T_c_source
- logical :: ACTUALLY_STORE_ARRAYS,ABSORBING_CONDITIONS
-
logical, dimension(nspec) :: ispec_is_tiso
!local parameters
@@ -258,9 +253,7 @@
! compute several rheological and geometrical properties for this spectral element
call compute_element_properties(ispec,iregion_code,idoubling,ipass, &
- xstore,ystore,zstore,nspec,myrank,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xstore,ystore,zstore,nspec,myrank, &
xelm,yelm,zelm,shape3D,rmin,rmax,rhostore,dvpstore, &
kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
@@ -270,7 +263,7 @@
c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
nspec_ani,nspec_stacey,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
size(tau_e_store,2),size(tau_e_store,3),size(tau_e_store,4), &
- rho_vp,rho_vs,ACTUALLY_STORE_ARRAYS, &
+ rho_vp,rho_vs, &
xigll,yigll,zigll,ispec_is_tiso)
enddo
enddo
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_doubling_elements.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_doubling_elements.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_doubling_elements.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -32,9 +32,7 @@
ner,ratio_sampling_array,r_top,r_bottom, &
xstore,ystore,zstore,xigll,yigll,zigll, &
shape3D,dershape2D_bottom, &
- INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ INCLUDE_CENTRAL_CUBE, &
rmin,rmax,r_moho,r_400,r_670, &
rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
nspec_ani,c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
@@ -45,7 +43,7 @@
nspec_stacey,rho_vp,rho_vs,iboun,iMPIcut_xi,iMPIcut_eta, &
ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,vx,vy,vz, &
- rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB,ACTUALLY_STORE_ARRAYS, &
+ rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB, &
NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho, &
ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot,ibelm_670_top,ibelm_670_bot, &
normal_moho,normal_400,normal_670,jacobian2D_moho,jacobian2D_400,jacobian2D_670, &
@@ -85,11 +83,8 @@
! 2D shape functions and their derivatives
double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY)
- logical INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS
+ logical INCLUDE_CENTRAL_CUBE
- double precision RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,&
- RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
-
! parameters needed to store the radii of the grid points in the spherically symmetric Earth
double precision rmin,rmax
double precision r_moho,r_400,r_670
@@ -136,7 +131,6 @@
integer idoubling(nspec)
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
logical :: USE_ONE_LAYER_SB
- logical :: ACTUALLY_STORE_ARRAYS
! Boundary Mesh
integer NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho
@@ -335,9 +329,7 @@
! compute several rheological and geometrical properties for this spectral element
call compute_element_properties(ispec,iregion_code,idoubling,ipass, &
- xstore,ystore,zstore,nspec,myrank,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xstore,ystore,zstore,nspec,myrank, &
xelm,yelm,zelm,shape3D,rmin,rmax,rhostore,dvpstore, &
kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
@@ -347,7 +339,7 @@
c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
nspec_ani,nspec_stacey,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
size(tau_e_store,2),size(tau_e_store,3),size(tau_e_store,4), &
- rho_vp,rho_vs,ACTUALLY_STORE_ARRAYS, &
+ rho_vp,rho_vs, &
xigll,yigll,zigll,ispec_is_tiso)
! boundary mesh
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_mass_matrices.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_mass_matrices.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_mass_matrices.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -25,107 +25,72 @@
!
!=====================================================================
- subroutine create_mass_matrices(myrank,nspec,idoubling,wxgll,wygll,wzgll,ibool, &
- nspec_actually,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore, &
- iregion_code,rhostore,kappavstore, &
- nglob_xy,nglob,prname, &
- rmassx,rmassy,rmassz, &
- nglob_oceans,rmass_ocean_load, &
- xstore,ystore,zstore,RHO_OCEANS, &
- NSPEC2D_TOP,NSPEC2D_BOTTOM,NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- 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, &
- rho_vp,rho_vs,nspec_stacey, &
- jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax, &
- jacobian2D_bottom,jacobian2D_top)
+ subroutine create_mass_matrices(myrank,nspec,idoubling,ibool, &
+ iregion_code,xstore,ystore,zstore, &
+ NSPEC2D_TOP,NSPEC2D_BOTTOM, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX)
- ! creates rmassx, rmassy, rmassz and rmass_ocean_load
+! creates rmassx, rmassy, rmassz and rmass_ocean_load
- use meshfem3D_models_par
- use meshfem3D_par,only: DT, NCHUNKS, ABSORBING_CONDITIONS, ichunk
+ use constants
- implicit none
+ use meshfem3D_models_par,only: &
+ OCEANS,TOPOGRAPHY,ibathy_topo
- integer :: myrank,nspec
- integer :: idoubling(nspec)
- integer :: ibool(NGLLX,NGLLY,NGLLZ,nspec)
- integer :: nspec_actually
+ use meshfem3D_par,only: &
+ DT,NCHUNKS,ABSORBING_CONDITIONS,ichunk,RHO_OCEANS
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_actually) :: &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+ use create_regions_mesh_par,only: &
+ wxgll,wygll,wzgll
- integer :: iregion_code,nglob_xy,nglob
+ use create_regions_mesh_par2,only: &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore,rhostore,kappavstore, &
+ rmassx,rmassy,rmassz,rmass_ocean_load, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+ normal_xmin,normal_xmax,normal_ymin,normal_ymax, &
+ jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax, &
+ jacobian2D_bottom,jacobian2D_top, &
+ rho_vp,rho_vs, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ prname
- ! mass matrices
- ! add C*deltat/2 contribution to the mass matrices on Stacey edges
- real(kind=CUSTOM_REAL), dimension(nglob_xy) :: rmassx,rmassy
- real(kind=CUSTOM_REAL), dimension(nglob) :: rmassz
+ implicit none
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rhostore,kappavstore
+ integer :: myrank
- ! ocean mass matrix
- integer :: nglob_oceans
- real(kind=CUSTOM_REAL), dimension(nglob_oceans) :: rmass_ocean_load
+ integer :: nspec
+ integer,dimension(nspec) :: idoubling
+ integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ integer :: iregion_code
+
! arrays with the mesh in double precision
- double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore
- double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ystore
- double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: zstore
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
- double precision :: RHO_OCEANS
+ ! Stacey conditions put back
+ integer :: NSPEC2D_TOP,NSPEC2D_BOTTOM
+ integer :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
- ! processor identification
- character(len=150) prname
-
+ ! local parameters
+ double precision :: xval,yval,zval,rval,thetaval,phival,weight
+ double precision :: lat,lon
+ double precision :: elevation,height_oceans
+ real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
! time scheme
real(kind=CUSTOM_REAL) :: deltat,deltatover2
-
- ! Stacey conditions put back
- integer :: NSPEC2D_TOP,NSPEC2D_BOTTOM,NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
- integer :: nspec_stacey
-
- double precision, dimension(NGLLX) :: wxgll
- double precision, dimension(NGLLY) :: wygll
- double precision, dimension(NGLLZ) :: wzgll
-
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX) :: jacobian2D_xmin,jacobian2D_xmax
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX) :: jacobian2D_ymin,jacobian2D_ymax
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM) :: jacobian2D_bottom
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP) :: jacobian2D_top
-
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX) :: normal_xmin,normal_xmax
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX) :: normal_ymin,normal_ymax
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_stacey) :: rho_vp,rho_vs
-
+ ! absorbing boundaries
+ integer, dimension(2,NSPEC2DMAX_YMIN_YMAX) :: nimin,nimax,nkmin_eta
+ integer, dimension(2,NSPEC2DMAX_XMIN_XMAX) :: njmin,njmax,nkmin_xi
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) :: tx,ty,tz,sn
real(kind=CUSTOM_REAL) :: nx,ny,nz,vn
- integer, dimension(NSPEC2D_TOP) :: ibelm_top
- integer, dimension(NSPEC2D_BOTTOM) :: ibelm_bottom
- integer, dimension(NSPEC2DMAX_XMIN_XMAX) :: ibelm_xmin,ibelm_xmax
- integer, dimension(NSPEC2DMAX_YMIN_YMAX) :: ibelm_ymin,ibelm_ymax
-
- integer, dimension(2,NSPEC2DMAX_YMIN_YMAX) :: nimin,nimax,nkmin_eta
- integer, dimension(2,NSPEC2DMAX_XMIN_XMAX) :: njmin,njmax,nkmin_xi
-
- integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,ispec2D
-
- ! local parameters
- double precision :: xval,yval,zval,rval,thetaval,phival,weight
- double precision :: lat,lon,colat
- double precision :: elevation,height_oceans
- real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
-
integer :: ispec,i,j,k,iglob,ier
integer :: ix_oceans,iy_oceans,iz_oceans,ispec_oceans,ispec2D_top_crust
+ integer :: ispec2D
! initializes matrices
!
@@ -274,8 +239,8 @@
iglob=ibool(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
- ! if 3D Earth, compute local height of oceans
- if(CASE_3D) then
+ ! if 3D Earth with topography, compute local height of oceans
+ if( TOPOGRAPHY ) then
! get coordinates of current point
xval = xstore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
@@ -287,17 +252,17 @@
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)))
+ if( .not. ASSUME_PERFECT_SPHERE) then
+ thetaval = PI_OVER_TWO - &
+ datan(1.006760466d0*dcos(thetaval)/dmax1(TINYVAL,dsin(thetaval)))
+ endif
! get geographic latitude and longitude in degrees
- lat = 90.0d0 - colat*180.0d0/PI
- lon = phival*180.0d0/PI
+ lat = (PI_OVER_TWO-thetaval)*RADIANS_TO_DEGREES
+ lon = phival * RADIANS_TO_DEGREES
! compute elevation at current point
- elevation = 0.d0
- if( TOPOGRAPHY ) then
- call get_topo_bathy(lat,lon,elevation,ibathy_topo)
- endif
+ 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
@@ -337,337 +302,337 @@
! add C*deltat/2 contribution to the mass matrices on Stacey edges
if(NCHUNKS /= 6 .and. ABSORBING_CONDITIONS) then
- ! read arrays for Stacey conditions
- open(unit=27,file=prname(1:len_trim(prname))//'stacey.bin', &
- status='old',form='unformatted',action='read',iostat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error opening stacey.bin in create_mass_matrices')
- read(27) nimin
- read(27) nimax
- read(27) njmin
- read(27) njmax
- read(27) nkmin_xi
- read(27) nkmin_eta
- close(27)
+ ! read arrays for Stacey conditions
+ open(unit=27,file=prname(1:len_trim(prname))//'stacey.bin', &
+ status='old',form='unformatted',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error opening stacey.bin in create_mass_matrices')
+ read(27) nimin
+ read(27) nimax
+ read(27) njmin
+ read(27) njmax
+ read(27) nkmin_xi
+ read(27) nkmin_eta
+ close(27)
- select case(iregion_code)
+ select case(iregion_code)
+ case(IREGION_CRUST_MANTLE)
- case(IREGION_CRUST_MANTLE)
+ rmassx(:) = rmassz(:)
+ rmassy(:) = rmassz(:)
- rmassx(:) = rmassz(:)
- rmassy(:) = rmassz(:)
+ ! xmin
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS == 1 .or. ichunk == CHUNK_AC) then
- ! xmin
- ! if two chunks exclude this face for one of them
- if(NCHUNKS == 1 .or. ichunk == CHUNK_AC) then
+ do ispec2D=1,nspec2D_xmin
- do ispec2D=1,nspec2D_xmin
+ ispec=ibelm_xmin(ispec2D)
- ispec=ibelm_xmin(ispec2D)
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_xi(1,ispec2D) == 0 .or. njmin(1,ispec2D) == 0) cycle
- ! exclude elements that are not on absorbing edges
- if(nkmin_xi(1,ispec2D) == 0 .or. njmin(1,ispec2D) == 0) cycle
+ i=1
+ do k=nkmin_xi(1,ispec2D),NGLLZ
+ do j=njmin(1,ispec2D),njmax(1,ispec2D)
+ iglob=ibool(i,j,k,ispec)
- i=1
- do k=nkmin_xi(1,ispec2D),NGLLZ
- do j=njmin(1,ispec2D),njmax(1,ispec2D)
- iglob=ibool(i,j,k,ispec)
+ nx = normal_xmin(1,j,k,ispec2D)
+ ny = normal_xmin(2,j,k,ispec2D)
+ nz = normal_xmin(3,j,k,ispec2D)
- nx = normal_xmin(1,j,k,ispec2D)
- ny = normal_xmin(2,j,k,ispec2D)
- nz = normal_xmin(3,j,k,ispec2D)
+ vn = deltatover2*(nx+ny+nz)
- vn = deltatover2*(nx+ny+nz)
+ tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(deltatover2-vn*nx)
+ ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(deltatover2-vn*ny)
+ tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(deltatover2-vn*nz)
- tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(deltatover2-vn*nx)
- ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(deltatover2-vn*ny)
- tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(deltatover2-vn*nz)
+ weight = jacobian2D_xmin(j,k,ispec2D)*wgllwgll_yz(j,k)
- weight = jacobian2D_xmin(j,k,ispec2D)*wgllwgll_yz(j,k)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassx(iglob) = rmassx(iglob) + sngl(tx*weight)
+ rmassy(iglob) = rmassy(iglob) + sngl(ty*weight)
+ rmassz(iglob) = rmassz(iglob) + sngl(tz*weight)
+ else
+ rmassx(iglob) = rmassx(iglob) + tx*weight
+ rmassy(iglob) = rmassy(iglob) + ty*weight
+ rmassz(iglob) = rmassz(iglob) + tz*weight
+ endif
+ enddo
+ enddo
+ enddo
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassx(iglob) = rmassx(iglob) + sngl(tx*weight)
- rmassy(iglob) = rmassy(iglob) + sngl(ty*weight)
- rmassz(iglob) = rmassz(iglob) + sngl(tz*weight)
- else
- rmassx(iglob) = rmassx(iglob) + tx*weight
- rmassy(iglob) = rmassy(iglob) + ty*weight
- rmassz(iglob) = rmassz(iglob) + tz*weight
- endif
- enddo
- enddo
- enddo
+ endif ! NCHUNKS == 1 .or. ichunk == CHUNK_AC
- endif ! NCHUNKS == 1 .or. ichunk == CHUNK_AC
+ ! xmax
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS == 1 .or. ichunk == CHUNK_AB) then
- ! xmax
- ! if two chunks exclude this face for one of them
- if(NCHUNKS == 1 .or. ichunk == CHUNK_AB) then
+ do ispec2D=1,nspec2D_xmax
- do ispec2D=1,nspec2D_xmax
+ ispec=ibelm_xmax(ispec2D)
- ispec=ibelm_xmax(ispec2D)
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_xi(2,ispec2D) == 0 .or. njmin(2,ispec2D) == 0) cycle
- ! exclude elements that are not on absorbing edges
- if(nkmin_xi(2,ispec2D) == 0 .or. njmin(2,ispec2D) == 0) cycle
+ i=NGLLX
+ do k=nkmin_xi(2,ispec2D),NGLLZ
+ do j=njmin(2,ispec2D),njmax(2,ispec2D)
+ iglob=ibool(i,j,k,ispec)
- i=NGLLX
- do k=nkmin_xi(2,ispec2D),NGLLZ
- do j=njmin(2,ispec2D),njmax(2,ispec2D)
- iglob=ibool(i,j,k,ispec)
+ nx = normal_xmax(1,j,k,ispec2D)
+ ny = normal_xmax(2,j,k,ispec2D)
+ nz = normal_xmax(3,j,k,ispec2D)
- nx = normal_xmax(1,j,k,ispec2D)
- ny = normal_xmax(2,j,k,ispec2D)
- nz = normal_xmax(3,j,k,ispec2D)
+ vn = deltatover2*(nx+ny+nz)
- vn = deltatover2*(nx+ny+nz)
+ tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(deltatover2-vn*nx)
+ ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(deltatover2-vn*ny)
+ tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(deltatover2-vn*nz)
- tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(deltatover2-vn*nx)
- ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(deltatover2-vn*ny)
- tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(deltatover2-vn*nz)
+ weight = jacobian2D_xmax(j,k,ispec2D)*wgllwgll_yz(j,k)
- weight = jacobian2D_xmax(j,k,ispec2D)*wgllwgll_yz(j,k)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassx(iglob) = rmassx(iglob) + sngl(tx*weight)
+ rmassy(iglob) = rmassy(iglob) + sngl(ty*weight)
+ rmassz(iglob) = rmassz(iglob) + sngl(tz*weight)
+ else
+ rmassx(iglob) = rmassx(iglob) + tx*weight
+ rmassy(iglob) = rmassy(iglob) + ty*weight
+ rmassz(iglob) = rmassz(iglob) + tz*weight
+ endif
+ enddo
+ enddo
+ enddo
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassx(iglob) = rmassx(iglob) + sngl(tx*weight)
- rmassy(iglob) = rmassy(iglob) + sngl(ty*weight)
- rmassz(iglob) = rmassz(iglob) + sngl(tz*weight)
- else
- rmassx(iglob) = rmassx(iglob) + tx*weight
- rmassy(iglob) = rmassy(iglob) + ty*weight
- rmassz(iglob) = rmassz(iglob) + tz*weight
- endif
- enddo
- enddo
- enddo
+ endif ! NCHUNKS == 1 .or. ichunk == CHUNK_AB
- endif ! NCHUNKS == 1 .or. ichunk == CHUNK_AB
+ ! ymin
+ do ispec2D=1,nspec2D_ymin
- ! ymin
- do ispec2D=1,nspec2D_ymin
+ ispec=ibelm_ymin(ispec2D)
- ispec=ibelm_ymin(ispec2D)
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_eta(1,ispec2D) == 0 .or. nimin(1,ispec2D) == 0) cycle
- ! exclude elements that are not on absorbing edges
- if(nkmin_eta(1,ispec2D) == 0 .or. nimin(1,ispec2D) == 0) cycle
+ j=1
+ do k=nkmin_eta(1,ispec2D),NGLLZ
+ do i=nimin(1,ispec2D),nimax(1,ispec2D)
+ iglob=ibool(i,j,k,ispec)
- j=1
- do k=nkmin_eta(1,ispec2D),NGLLZ
- do i=nimin(1,ispec2D),nimax(1,ispec2D)
- iglob=ibool(i,j,k,ispec)
+ nx = normal_ymin(1,i,k,ispec2D)
+ ny = normal_ymin(2,i,k,ispec2D)
+ nz = normal_ymin(3,i,k,ispec2D)
- nx = normal_ymin(1,i,k,ispec2D)
- ny = normal_ymin(2,i,k,ispec2D)
- nz = normal_ymin(3,i,k,ispec2D)
+ vn = deltatover2*(nx+ny+nz)
- vn = deltatover2*(nx+ny+nz)
+ tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(deltatover2-vn*nx)
+ ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(deltatover2-vn*ny)
+ tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(deltatover2-vn*nz)
- tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(deltatover2-vn*nx)
- ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(deltatover2-vn*ny)
- tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(deltatover2-vn*nz)
+ weight = jacobian2D_ymin(i,k,ispec2D)*wgllwgll_xz(i,k)
- weight = jacobian2D_ymin(i,k,ispec2D)*wgllwgll_xz(i,k)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassx(iglob) = rmassx(iglob) + sngl(tx*weight)
+ rmassy(iglob) = rmassy(iglob) + sngl(ty*weight)
+ rmassz(iglob) = rmassz(iglob) + sngl(tz*weight)
+ else
+ rmassx(iglob) = rmassx(iglob) + tx*weight
+ rmassy(iglob) = rmassy(iglob) + ty*weight
+ rmassz(iglob) = rmassz(iglob) + tz*weight
+ endif
+ enddo
+ enddo
+ enddo
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassx(iglob) = rmassx(iglob) + sngl(tx*weight)
- rmassy(iglob) = rmassy(iglob) + sngl(ty*weight)
- rmassz(iglob) = rmassz(iglob) + sngl(tz*weight)
- else
- rmassx(iglob) = rmassx(iglob) + tx*weight
- rmassy(iglob) = rmassy(iglob) + ty*weight
- rmassz(iglob) = rmassz(iglob) + tz*weight
- endif
- enddo
- enddo
- enddo
+ ! ymax
+ do ispec2D=1,nspec2D_ymax
- ! ymax
- do ispec2D=1,nspec2D_ymax
+ ispec=ibelm_ymax(ispec2D)
- ispec=ibelm_ymax(ispec2D)
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_eta(2,ispec2D) == 0 .or. nimin(2,ispec2D) == 0) cycle
- ! exclude elements that are not on absorbing edges
- if(nkmin_eta(2,ispec2D) == 0 .or. nimin(2,ispec2D) == 0) cycle
+ j=NGLLY
+ do k=nkmin_eta(2,ispec2D),NGLLZ
+ do i=nimin(2,ispec2D),nimax(2,ispec2D)
+ iglob=ibool(i,j,k,ispec)
- j=NGLLY
- do k=nkmin_eta(2,ispec2D),NGLLZ
- do i=nimin(2,ispec2D),nimax(2,ispec2D)
- iglob=ibool(i,j,k,ispec)
+ nx = normal_ymax(1,i,k,ispec2D)
+ ny = normal_ymax(2,i,k,ispec2D)
+ nz = normal_ymax(3,i,k,ispec2D)
- nx = normal_ymax(1,i,k,ispec2D)
- ny = normal_ymax(2,i,k,ispec2D)
- nz = normal_ymax(3,i,k,ispec2D)
+ vn = deltatover2*(nx+ny+nz)
- vn = deltatover2*(nx+ny+nz)
+ tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(deltatover2-vn*nx)
+ ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(deltatover2-vn*ny)
+ tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(deltatover2-vn*nz)
- tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(deltatover2-vn*nx)
- ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(deltatover2-vn*ny)
- tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(deltatover2-vn*nz)
+ weight = jacobian2D_ymax(i,k,ispec2D)*wgllwgll_xz(i,k)
- weight = jacobian2D_ymax(i,k,ispec2D)*wgllwgll_xz(i,k)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassx(iglob) = rmassx(iglob) + sngl(tx*weight)
+ rmassy(iglob) = rmassy(iglob) + sngl(ty*weight)
+ rmassz(iglob) = rmassz(iglob) + sngl(tz*weight)
+ else
+ rmassx(iglob) = rmassx(iglob) + tx*weight
+ rmassy(iglob) = rmassy(iglob) + ty*weight
+ rmassz(iglob) = rmassz(iglob) + tz*weight
+ endif
+ enddo
+ enddo
+ enddo
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassx(iglob) = rmassx(iglob) + sngl(tx*weight)
- rmassy(iglob) = rmassy(iglob) + sngl(ty*weight)
- rmassz(iglob) = rmassz(iglob) + sngl(tz*weight)
- else
- rmassx(iglob) = rmassx(iglob) + tx*weight
- rmassy(iglob) = rmassy(iglob) + ty*weight
- rmassz(iglob) = rmassz(iglob) + tz*weight
- endif
- enddo
- enddo
- enddo
+ ! check that mass matrix is positive
+ if(minval(rmassx(:)) <= 0.) call exit_MPI(myrank,'negative rmassx matrix term')
+ if(minval(rmassy(:)) <= 0.) call exit_MPI(myrank,'negative rmassy matrix term')
- ! check that mass matrix is positive
- if(minval(rmassx(:)) <= 0.) call exit_MPI(myrank,'negative rmassx matrix term')
- if(minval(rmassy(:)) <= 0.) call exit_MPI(myrank,'negative rmassy matrix term')
+ case(IREGION_OUTER_CORE)
- case(IREGION_OUTER_CORE)
+ ! xmin
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS == 1 .or. ichunk == CHUNK_AC) then
- ! xmin
- ! if two chunks exclude this face for one of them
- if(NCHUNKS == 1 .or. ichunk == CHUNK_AC) then
+ do ispec2D=1,nspec2D_xmin
- do ispec2D=1,nspec2D_xmin
+ ispec=ibelm_xmin(ispec2D)
- ispec=ibelm_xmin(ispec2D)
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_xi(1,ispec2D) == 0 .or. njmin(1,ispec2D) == 0) cycle
- ! exclude elements that are not on absorbing edges
- if(nkmin_xi(1,ispec2D) == 0 .or. njmin(1,ispec2D) == 0) cycle
+ i=1
+ do k=nkmin_xi(1,ispec2D),NGLLZ
+ do j=njmin(1,ispec2D),njmax(1,ispec2D)
+ iglob=ibool(i,j,k,ispec)
- i=1
- do k=nkmin_xi(1,ispec2D),NGLLZ
- do j=njmin(1,ispec2D),njmax(1,ispec2D)
- iglob=ibool(i,j,k,ispec)
+ sn = deltatover2/rho_vp(i,j,k,ispec)
- sn = deltatover2/rho_vp(i,j,k,ispec)
+ weight = jacobian2D_xmin(j,k,ispec2D)*wgllwgll_yz(j,k)
- weight = jacobian2D_xmin(j,k,ispec2D)*wgllwgll_yz(j,k)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
+ else
+ rmassz(iglob) = rmassz(iglob) + weight*sn
+ endif
+ enddo
+ enddo
+ enddo
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
- else
- rmassz(iglob) = rmassz(iglob) + weight*sn
- endif
- enddo
- enddo
- enddo
+ endif ! NCHUNKS == 1 .or. ichunk == CHUNK_AC
- endif ! NCHUNKS == 1 .or. ichunk == CHUNK_AC
+ ! xmax
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS == 1 .or. ichunk == CHUNK_AB) then
- ! xmax
- ! if two chunks exclude this face for one of them
- if(NCHUNKS == 1 .or. ichunk == CHUNK_AB) then
+ do ispec2D=1,nspec2D_xmax
- do ispec2D=1,nspec2D_xmax
+ ispec=ibelm_xmax(ispec2D)
- ispec=ibelm_xmax(ispec2D)
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_xi(2,ispec2D) == 0 .or. njmin(2,ispec2D) == 0) cycle
- ! exclude elements that are not on absorbing edges
- if(nkmin_xi(2,ispec2D) == 0 .or. njmin(2,ispec2D) == 0) cycle
+ i=NGLLX
+ do k=nkmin_xi(2,ispec2D),NGLLZ
+ do j=njmin(2,ispec2D),njmax(2,ispec2D)
+ iglob=ibool(i,j,k,ispec)
- i=NGLLX
- do k=nkmin_xi(2,ispec2D),NGLLZ
- do j=njmin(2,ispec2D),njmax(2,ispec2D)
- iglob=ibool(i,j,k,ispec)
+ sn = deltatover2/rho_vp(i,j,k,ispec)
- sn = deltatover2/rho_vp(i,j,k,ispec)
+ weight = jacobian2D_xmax(j,k,ispec2D)*wgllwgll_yz(j,k)
- weight = jacobian2D_xmax(j,k,ispec2D)*wgllwgll_yz(j,k)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
+ else
+ rmassz(iglob) = rmassz(iglob) + weight*sn
+ endif
+ enddo
+ enddo
+ enddo
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
- else
- rmassz(iglob) = rmassz(iglob) + weight*sn
- endif
- enddo
- enddo
- enddo
+ endif ! NCHUNKS == 1 .or. ichunk == CHUNK_AB
- endif ! NCHUNKS == 1 .or. ichunk == CHUNK_AB
+ ! ymin
+ do ispec2D=1,nspec2D_ymin
- ! ymin
- do ispec2D=1,nspec2D_ymin
+ ispec=ibelm_ymin(ispec2D)
- ispec=ibelm_ymin(ispec2D)
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_eta(1,ispec2D) == 0 .or. nimin(1,ispec2D) == 0) cycle
- ! exclude elements that are not on absorbing edges
- if(nkmin_eta(1,ispec2D) == 0 .or. nimin(1,ispec2D) == 0) cycle
+ j=1
+ do k=nkmin_eta(1,ispec2D),NGLLZ
+ do i=nimin(1,ispec2D),nimax(1,ispec2D)
+ iglob=ibool(i,j,k,ispec)
- j=1
- do k=nkmin_eta(1,ispec2D),NGLLZ
- do i=nimin(1,ispec2D),nimax(1,ispec2D)
- iglob=ibool(i,j,k,ispec)
+ sn = deltatover2/rho_vp(i,j,k,ispec)
- sn = deltatover2/rho_vp(i,j,k,ispec)
+ weight = jacobian2D_ymin(i,k,ispec2D)*wgllwgll_xz(i,k)
- weight = jacobian2D_ymin(i,k,ispec2D)*wgllwgll_xz(i,k)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
+ else
+ rmassz(iglob) = rmassz(iglob) + weight*sn
+ endif
+ enddo
+ enddo
+ enddo
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
- else
- rmassz(iglob) = rmassz(iglob) + weight*sn
- endif
- enddo
- enddo
- enddo
+ ! ymax
+ do ispec2D=1,nspec2D_ymax
- ! ymax
- do ispec2D=1,nspec2D_ymax
+ ispec=ibelm_ymax(ispec2D)
- ispec=ibelm_ymax(ispec2D)
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_eta(2,ispec2D) == 0 .or. nimin(2,ispec2D) == 0) cycle
- ! exclude elements that are not on absorbing edges
- if(nkmin_eta(2,ispec2D) == 0 .or. nimin(2,ispec2D) == 0) cycle
+ j=NGLLY
+ do k=nkmin_eta(2,ispec2D),NGLLZ
+ do i=nimin(2,ispec2D),nimax(2,ispec2D)
+ iglob=ibool(i,j,k,ispec)
- j=NGLLY
- do k=nkmin_eta(2,ispec2D),NGLLZ
- do i=nimin(2,ispec2D),nimax(2,ispec2D)
- iglob=ibool(i,j,k,ispec)
+ sn = deltatover2/rho_vp(i,j,k,ispec)
- sn = deltatover2/rho_vp(i,j,k,ispec)
+ weight = jacobian2D_ymax(i,k,ispec2D)*wgllwgll_xz(i,k)
- weight = jacobian2D_ymax(i,k,ispec2D)*wgllwgll_xz(i,k)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
+ else
+ rmassz(iglob) = rmassz(iglob) + weight*sn
+ endif
+ enddo
+ enddo
+ enddo
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
- else
- rmassz(iglob) = rmassz(iglob) + weight*sn
- endif
- enddo
- enddo
- enddo
+ ! bottom (zmin)
+ do ispec2D=1,NSPEC2D_BOTTOM
- ! bottom (zmin)
- do ispec2D=1,NSPEC2D_BOTTOM
+ ispec=ibelm_bottom(ispec2D)
- ispec=ibelm_bottom(ispec2D)
+ k=1
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob=ibool(i,j,k,ispec)
- k=1
- do j=1,NGLLY
- do i=1,NGLLX
- iglob=ibool(i,j,k,ispec)
+ sn = deltatover2/rho_vp(i,j,k,ispec)
- sn = deltatover2/rho_vp(i,j,k,ispec)
+ weight = jacobian2D_bottom(i,j,ispec2D)*wgllwgll_xy(i,j)
- weight = jacobian2D_bottom(i,j,ispec2D)*wgllwgll_xy(i,j)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
+ else
+ rmassz(iglob) = rmassz(iglob) + weight*sn
+ endif
+ enddo
+ enddo
+ enddo
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
- else
- rmassz(iglob) = rmassz(iglob) + weight*sn
- endif
- enddo
- enddo
- enddo
+ case( IREGION_INNER_CORE )
+ continue
- case( IREGION_INNER_CORE )
+ case default
+ call exit_MPI(myrank,'wrong region code')
- case default
- call exit_MPI(myrank,'wrong region code')
+ end select
- end select
-
endif
! check that mass matrix is positive
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regions_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regions_mesh.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regions_mesh.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -73,9 +73,7 @@
logical, dimension(nspec) :: is_on_a_slice_edge
! arrays with the mesh in double precision
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
integer :: nglob_theor,npointot
@@ -232,7 +230,7 @@
! xstore,ystore,zstore,rhostore,dvpstore, &
! kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,&
! nspec,HETEROGEN_3D_MANTLE, &
- ! NEX_XI,NCHUNKS,ABSORBING_CONDITIONS,PPM_V )
+ ! NEX_XI,NCHUNKS,ABSORBING_CONDITIONS )
! creates mass matrix
call sync_all()
@@ -253,22 +251,23 @@
nglob = nglob_theor
if(NCHUNKS /= 6 .and. ABSORBING_CONDITIONS) then
- select case(iregion_code)
- case( IREGION_CRUST_MANTLE )
- nglob_xy = nglob
- case( IREGION_INNER_CORE, IREGION_OUTER_CORE )
- nglob_xy = 1
- endselect
+ select case(iregion_code)
+ case( IREGION_CRUST_MANTLE )
+ nglob_xy = nglob
+ case( IREGION_INNER_CORE, IREGION_OUTER_CORE )
+ nglob_xy = 1
+ endselect
else
nglob_xy = 1
endif
- allocate(rmassx(nglob_xy),stat=ier)
+ allocate(rmassx(nglob_xy), &
+ rmassy(nglob_xy), &
+ stat=ier)
if(ier /= 0) stop 'error in allocate 21'
- allocate(rmassy(nglob_xy),stat=ier)
- if(ier /= 0) stop 'error in allocate 21'
+
allocate(rmassz(nglob),stat=ier)
- if(ier /= 0) stop 'error in allocate 21'
+ if(ier /= 0) stop 'error in allocate 22'
! allocates ocean load mass matrix as well if oceans
if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) then
@@ -281,49 +280,20 @@
if(ier /= 0) stop 'error in allocate 22'
! creating mass matrices in this slice (will be fully assembled in the solver)
- call create_mass_matrices(myrank,nspec,idoubling,wxgll,wygll,wzgll,ibool, &
- nspec_actually,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore, &
- iregion_code,rhostore,kappavstore, &
- nglob_xy,nglob,prname, &
- rmassx,rmassy,rmassz, &
- nglob_oceans,rmass_ocean_load, &
- xstore,ystore,zstore,RHO_OCEANS, &
- NSPEC2D_TOP,NSPEC2D_BOTTOM,NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- 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, &
- rho_vp,rho_vs,nspec_stacey, &
- jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax, &
- jacobian2D_bottom,jacobian2D_top)
+ call create_mass_matrices(myrank,nspec,idoubling,ibool, &
+ iregion_code,xstore,ystore,zstore, &
+ NSPEC2D_TOP,NSPEC2D_BOTTOM, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX)
! save the binary files
call sync_all()
if( myrank == 0) then
write(IMAIN,*) ' ...saving binary files'
endif
- call save_arrays_solver(myrank,rho_vp,rho_vs,nspec_stacey, &
- prname,iregion_code,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
- xstore,ystore,zstore,rhostore,dvpstore, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- nspec_ani,c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- ibool,idoubling,is_on_a_slice_edge,nglob_xy,nglob, &
- rmassx,rmassy,rmassz,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, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- TRANSVERSE_ISOTROPY,HETEROGEN_3D_MANTLE,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,OCEANS, &
- tau_s,tau_e_store,Qmu_store,T_c_source,ATTENUATION, &
- size(tau_e_store,2),size(tau_e_store,3),size(tau_e_store,4),size(tau_e_store,5),&
- ABSORBING_CONDITIONS,SAVE_MESH_FILES,ispec_is_tiso)
+ call save_arrays_solver(myrank,nspec,nglob,idoubling,ibool, &
+ iregion_code,xstore,ystore,zstore, &
+ is_on_a_slice_edge, &
+ NSPEC2D_TOP,NSPEC2D_BOTTOM)
deallocate(rmassx,rmassy,rmassz)
deallocate(rmass_ocean_load)
@@ -590,10 +560,8 @@
! store and save the final arrays only in the second pass
! therefore in the first pass some arrays can be allocated with a dummy size
if(ipass == 1) then
- ACTUALLY_STORE_ARRAYS = .false.
nspec_actually = 1
else
- ACTUALLY_STORE_ARRAYS = .true.
nspec_actually = nspec
endif
allocate(xixstore(NGLLX,NGLLY,NGLLZ,nspec_actually), &
@@ -747,9 +715,7 @@
IMAIN,myrank, &
IREGION_CRUST_MANTLE,IREGION_OUTER_CORE,IREGION_INNER_CORE,IFLAG_IN_FICTITIOUS_CUBE, &
NPROC_XI,NPROC_ETA,NCHUNKS, &
- INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
- R_CENTRAL_CUBE,RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,&
- RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ INCLUDE_CENTRAL_CUBE,R_CENTRAL_CUBE, &
MAX_NUMBER_OF_MESH_LAYERS,MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR,NB_SQUARE_CORNERS, &
rmins,rmaxs,iproc_xi,iproc_eta,ichunk,NEX_XI, &
rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD, &
@@ -847,9 +813,7 @@
xstore,ystore,zstore, &
iaddx,iaddy,iaddz,xigll,yigll,zigll, &
shape3D,dershape2D_bottom, &
- INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ INCLUDE_CENTRAL_CUBE, &
rmin,rmax,r_moho,r_400,r_670, &
rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
nspec_ani,c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
@@ -862,7 +826,7 @@
nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
size(tau_e_store,2),size(tau_e_store,3),size(tau_e_store,4), &
rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB, &
- stretch_tab,ACTUALLY_STORE_ARRAYS, &
+ stretch_tab, &
NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho, &
ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot,ibelm_670_top,ibelm_670_bot, &
normal_moho,normal_400,normal_670,jacobian2D_moho,jacobian2D_400,jacobian2D_670, &
@@ -880,9 +844,7 @@
ner,ratio_sampling_array,r_top,r_bottom, &
xstore,ystore,zstore,xigll,yigll,zigll, &
shape3D,dershape2D_bottom, &
- INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ INCLUDE_CENTRAL_CUBE, &
rmin,rmax,r_moho,r_400,r_670, &
rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
nspec_ani,c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
@@ -894,7 +856,7 @@
ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
size(tau_e_store,2),size(tau_e_store,3),size(tau_e_store,4), &
- rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB,ACTUALLY_STORE_ARRAYS, &
+ rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB, &
NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho, &
ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot,ibelm_670_top,ibelm_670_bot, &
normal_moho,normal_400,normal_670,jacobian2D_moho,jacobian2D_400,jacobian2D_670, &
@@ -934,8 +896,6 @@
iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,ratio_divide_central_cube, &
iMPIcut_xi,iMPIcut_eta,iboun, &
idoubling,iregion_code,xstore,ystore,zstore, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME,&
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
shape3D,rmin,rmax,rhostore,dvpstore,&
kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
@@ -945,7 +905,7 @@
c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
nspec_ani,nspec_stacey,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
size(tau_e_store,2),size(tau_e_store,3),size(tau_e_store,4), &
- rho_vp,rho_vs,ABSORBING_CONDITIONS,ACTUALLY_STORE_ARRAYS,xigll,yigll,zigll, &
+ rho_vp,rho_vs,xigll,yigll,zigll, &
ispec_is_tiso)
endif
@@ -992,10 +952,12 @@
! creates global indexing array ibool
- use meshfem3d_par,only: &
- myrank,NGLLX,NGLLY,NGLLZ
+ use constants,only: NGLLX,NGLLY,NGLLZ,ZERO
+ use meshfem3d_par,only: myrank
+
use create_regions_mesh_par2
+
implicit none
! number of spectral elements in each block
@@ -1024,11 +986,11 @@
zp(npointot),stat=ier)
if(ier /= 0) stop 'error in allocate 20'
- locval = 0
- ifseg = .false.
- xp = 0.d0
- yp = 0.d0
- zp = 0.d0
+ locval(:) = 0
+ ifseg(:) = .false.
+ xp(:) = ZERO
+ yp(:) = ZERO
+ zp(:) = ZERO
! 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
@@ -1058,14 +1020,16 @@
myrank,nglob,nglob_theor
call exit_MPI(myrank,errmsg)
endif
- if(minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) call exit_MPI(myrank,'incorrect global numbering')
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) &
+ call exit_MPI(myrank,'incorrect global numbering')
! creates a new indirect addressing to reduce cache misses in memory access in the solver
! this is *critical* to improve performance in the solver
call get_global_indirect_addressing(nspec,nglob_theor,ibool)
! checks again
- if(minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) call exit_MPI(myrank,'incorrect global numbering after sorting')
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) &
+ call exit_MPI(myrank,'incorrect global numbering after sorting')
end subroutine crm_setup_indexing
@@ -1226,8 +1190,8 @@
RMIDDLE_CRUST,ROCEAN,iregion_code)
call write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun,ibool, &
- idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool,npointot, &
- rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
+ idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool, &
+ npointot,rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
RMIDDLE_CRUST,ROCEAN,iregion_code)
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regular_elements.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regular_elements.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regular_elements.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -33,9 +33,7 @@
xstore,ystore,zstore, &
iaddx,iaddy,iaddz,xigll,yigll,zigll, &
shape3D,dershape2D_bottom, &
- INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ INCLUDE_CENTRAL_CUBE, &
rmin,rmax,r_moho,r_400,r_670, &
rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
nspec_ani,c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
@@ -47,7 +45,7 @@
ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,vx,vy,vz, &
rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB, &
- stretch_tab,ACTUALLY_STORE_ARRAYS, &
+ stretch_tab, &
NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho, &
ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot,ibelm_670_top,ibelm_670_bot, &
normal_moho,normal_400,normal_670,jacobian2D_moho,jacobian2D_400,jacobian2D_670, &
@@ -90,11 +88,8 @@
! 2D shape functions and their derivatives
double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY)
- logical INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS
+ logical INCLUDE_CENTRAL_CUBE
- double precision RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,&
- RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
-
! parameters needed to store the radii of the grid points in the spherically symmetric Earth
double precision rmin,rmax
double precision r_moho,r_400,r_670
@@ -144,8 +139,6 @@
double precision, dimension(2,ner(1)) :: stretch_tab
- logical :: ACTUALLY_STORE_ARRAYS
-
! Boundary Mesh
integer NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho
integer ibelm_moho_top(NSPEC2D_MOHO),ibelm_moho_bot(NSPEC2D_MOHO)
@@ -254,9 +247,7 @@
! compute several rheological and geometrical properties for this spectral element
call compute_element_properties(ispec,iregion_code,idoubling,ipass, &
- xstore,ystore,zstore,nspec,myrank,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ xstore,ystore,zstore,nspec,myrank, &
xelm,yelm,zelm,shape3D,rmin,rmax,rhostore,dvpstore, &
kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
@@ -266,7 +257,7 @@
c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
nspec_ani,nspec_stacey,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
size(tau_e_store,2),size(tau_e_store,3),size(tau_e_store,4), &
- rho_vp,rho_vs,ACTUALLY_STORE_ARRAYS,&
+ rho_vp,rho_vs, &
xigll,yigll,zigll,ispec_is_tiso)
! boundary mesh
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/finalize_mesher.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/finalize_mesher.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/finalize_mesher.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -122,7 +122,7 @@
! 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,TOPOGRAPHY, &
+ ELLIPTICITY,GRAVITY,ROTATION, &
OCEANS,ATTENUATION,ATTENUATION_NEW,ATTENUATION_3D, &
ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,NCHUNKS, &
INCLUDE_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,&
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_interfaces.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_interfaces.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_interfaces.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -581,7 +581,7 @@
subroutine sort_MPI_interface(myrank,npoin,ibool_n, &
NGLOB,xstore,ystore,zstore)
- use constants,only: CUSTOM_REAL
+ use constants,only: CUSTOM_REAL,SIZE_REAL
implicit none
@@ -619,9 +619,16 @@
ipoin = ibool_n(i)
ibool_selected(i) = ipoin
- xstore_selected(i) = xstore(ipoin)
- ystore_selected(i) = ystore(ipoin)
- zstore_selected(i) = zstore(ipoin)
+
+ if( CUSTOM_REAL == SIZE_REAL ) then
+ xstore_selected(i) = dble(xstore(ipoin))
+ ystore_selected(i) = dble(ystore(ipoin))
+ zstore_selected(i) = dble(zstore(ipoin))
+ else
+ xstore_selected(i) = xstore(ipoin)
+ ystore_selected(i) = ystore(ipoin)
+ zstore_selected(i) = zstore(ipoin)
+ endif
enddo
! sort buffer obtained to be conforming with neighbor in other chunk
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_global.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_global.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_global.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -25,6 +25,7 @@
!
!=====================================================================
+
subroutine get_global(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot)
! this routine MUST be in double precision to avoid sensitivity
@@ -38,28 +39,30 @@
include "constants.h"
-! parameters
+ ! input 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)
+ double precision, dimension(npointot), intent(in) :: xp,yp,zp
+
+ integer, dimension(npointot), intent(out) :: iglob,loc
+ logical, dimension(npointot), intent(out) :: ifseg
integer, intent(out) :: nglob
-! variables
- integer ispec,i,j
- integer ieoff,ilocnum,nseg,ioff,iseg,ig
-
+ ! local variables
+ double precision, dimension(:), allocatable :: work
integer, dimension(:), allocatable :: ind,ninseg,iwork
- double precision, dimension(:), allocatable :: work
+ integer :: ispec,i,j,ier
+ integer :: ieoff,ilocnum,nseg,ioff,iseg,ig
-! dynamically allocate arrays
- allocate(ind(npointot))
- allocate(ninseg(npointot))
- allocate(iwork(npointot))
- allocate(work(npointot))
+ ! dynamically allocate arrays
+ allocate(ind(npointot), &
+ ninseg(npointot), &
+ iwork(npointot), &
+ work(npointot), &
+ stat=ier)
+ if( ier /= 0 ) stop 'error allocating local array in get_global'
-! establish initial pointers
+ ! establish initial pointers
do ispec=1,nspec
ieoff=NGLLX * NGLLY * NGLLZ * (ispec-1)
do ilocnum=1,NGLLX * NGLLY * NGLLZ
@@ -67,57 +70,58 @@
enddo
enddo
- ifseg(:)=.false.
+ ifseg(:) = .false.
- nseg=1
- ifseg(1)=.true.
- ninseg(1)=npointot
+ nseg = 1
+ ifseg(1) = .true.
+ ninseg(1) = npointot
-do j=1,NDIM
-
+ 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)
+ 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
+ ! 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
+ 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
+ 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
+ do i=2,npointot
+ if(dabs(zp(i)-zp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
+ enddo
endif
-! count up number of different segments
+ ! count up number of different segments
nseg=0
do i=1,npointot
- if(ifseg(i)) then
+ if(ifseg(i)) then
nseg=nseg+1
ninseg(nseg)=1
- else
+ else
ninseg(nseg)=ninseg(nseg)+1
- endif
+ endif
enddo
-enddo
+ enddo
-! assign global node numbers (now sorted lexicographically)
+ ! assign global node numbers (now sorted lexicographically)
ig=0
do i=1,npointot
if(ifseg(i)) ig=ig+1
@@ -126,11 +130,8 @@
nglob=ig
-! deallocate arrays
- deallocate(ind)
- deallocate(ninseg)
- deallocate(iwork)
- deallocate(work)
+ ! deallocate arrays
+ deallocate(ind,ninseg,iwork,work)
end subroutine get_global
@@ -152,6 +153,7 @@
integer,intent(in) :: nspec,nglob
integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ ! local parameters
! mask to sort ibool
integer, dimension(:), allocatable :: mask_ibool
integer, dimension(:,:,:,:), allocatable :: copy_ibool_ori
@@ -159,9 +161,12 @@
integer:: i,j,k,ispec,ier
! copies original array
- allocate(copy_ibool_ori(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate'
- allocate(mask_ibool(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(copy_ibool_ori(NGLLX,NGLLY,NGLLZ,nspec), &
+ mask_ibool(nglob), &
+ stat=ier)
+ if(ier /= 0) stop 'error allocating local arrays in get_global_indirect_addressing'
+ ! initializes arrays
mask_ibool(:) = -1
copy_ibool_ori(:,:,:,:) = ibool(:,:,:,:)
@@ -186,10 +191,9 @@
enddo
! cleanup
- deallocate(copy_ibool_ori,stat=ier); if(ier /= 0) stop 'error in deallocate'
- deallocate(mask_ibool,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(copy_ibool_ori,mask_ibool)
-end subroutine get_global_indirect_addressing
+ end subroutine get_global_indirect_addressing
!
!-------------------------------------------------------------------------------------------------
@@ -203,12 +207,13 @@
!
implicit none
- integer n
- double precision A(n)
- integer IND(n)
+ integer :: n
+ double precision,dimension(n) :: A
+ integer,dimension(n) :: IND
- integer i,j,l,ir,indx
- double precision q
+ ! local parameters
+ integer :: i,j,l,ir,indx
+ double precision :: q
do j=1,n
IND(j)=j
@@ -216,41 +221,47 @@
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
+ L = floor(n/2.0) + 1
+ ir = n
+
+ do while( .true. )
+
+ 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
+
+ ! checks exit criteria
if (ir == 1) then
- ind(1)=indx
+ 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
+
+ i = l
+ j = l+l
+
+ do while( J <= IR )
+ 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
+ IF ( q < A(IND(j)) ) THEN
+ IND(I) = IND(J)
+ I = J
+ J = J+J
ELSE
- J=IR+1
+ J = IR+1
ENDIF
- goto 200
- ENDIF
- IND(I)=INDX
- goto 100
+ enddo
+
+ IND(I)=INDX
+ enddo
+
end subroutine rank
!
@@ -263,32 +274,32 @@
!
implicit none
- integer n
+ integer :: n
+ integer,dimension(n) :: IND
+ integer,dimension(n) :: IA,IW
+ double precision,dimension(n) :: A,B,C,W
- integer IND(n)
- integer IA(n),IW(n)
- double precision A(n),B(n),C(n),W(n)
+ ! local parameter
+ integer :: i
- integer i
-
IW(:) = IA(:)
W(:) = A(:)
do i=1,n
- IA(i)=IW(ind(i))
- A(i)=W(ind(i))
+ IA(i) = IW(ind(i))
+ A(i) = W(ind(i))
enddo
W(:) = B(:)
do i=1,n
- B(i)=W(ind(i))
+ B(i) = W(ind(i))
enddo
W(:) = C(:)
do i=1,n
- C(i)=W(ind(i))
+ C(i) = W(ind(i))
enddo
end subroutine swap_all
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_jacobian_boundaries.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_jacobian_boundaries.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_jacobian_boundaries.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -154,7 +154,7 @@
end do
end do
! recalculate jacobian according to 2D GLL points
- call recalc_jacobian_gll2D(myrank,ispecb1,xelm2D,yelm2D,zelm2D, &
+ call calc_jacobian_gll2D(myrank,ispecb1,xelm2D,yelm2D,zelm2D, &
yigll,zigll,jacobian2D_xmin,normal_xmin,&
NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
end if
@@ -210,7 +210,7 @@
end do
end do
! recalculate jacobian according to 2D GLL points
- call recalc_jacobian_gll2D(myrank,ispecb2,xelm2D,yelm2D,zelm2D,&
+ call calc_jacobian_gll2D(myrank,ispecb2,xelm2D,yelm2D,zelm2D,&
yigll,zigll,jacobian2D_xmax,normal_xmax,&
NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
end if
@@ -266,7 +266,7 @@
end do
end do
! recalcualte 2D jacobian according to GLL points
- call recalc_jacobian_gll2D(myrank,ispecb3,xelm2D,yelm2D,zelm2D,&
+ call calc_jacobian_gll2D(myrank,ispecb3,xelm2D,yelm2D,zelm2D,&
xigll,zigll,jacobian2D_ymin,normal_ymin,&
NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
end if
@@ -322,7 +322,7 @@
end do
end do
! recalculate jacobian for 2D GLL points
- call recalc_jacobian_gll2D(myrank,ispecb4,xelm2D,yelm2D,zelm2D,&
+ call calc_jacobian_gll2D(myrank,ispecb4,xelm2D,yelm2D,zelm2D,&
xigll,zigll,jacobian2D_ymax,normal_ymax,&
NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
end if
@@ -377,7 +377,7 @@
end do
end do
! recalcuate 2D jacobian according to GLL points
- call recalc_jacobian_gll2D(myrank,ispecb5,xelm2D,yelm2D,zelm2D,&
+ call calc_jacobian_gll2D(myrank,ispecb5,xelm2D,yelm2D,zelm2D,&
xigll,yigll,jacobian2D_bottom,normal_bottom,&
NGLLX,NGLLY,NSPEC2D_BOTTOM)
end if
@@ -432,7 +432,7 @@
end do
end do
! recalcuate jacobian according to 2D gll points
- call recalc_jacobian_gll2D(myrank,ispecb6,xelm2D,yelm2D,zelm2D,&
+ call calc_jacobian_gll2D(myrank,ispecb6,xelm2D,yelm2D,zelm2D,&
xigll,yigll,jacobian2D_top,normal_top,&
NGLLX,NGLLY,NSPEC2D_TOP)
@@ -490,6 +490,7 @@
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)
@@ -499,16 +500,17 @@
zeta=zeta+dershape2D(2,ia,i,j)*zelm(ia)
enddo
-! calculate the unnormalized normal to the boundary
+ ! 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
+ ! normalize normal vector and store surface jacobian
-! distinguish between single and double precision for reals
+ ! 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)
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_model.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_model.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -33,11 +33,16 @@
c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
nspec_stacey,rho_vp,rho_vs, &
xstore,ystore,zstore, &
- rmin,rmax,RCMB,RICB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220, &
- R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ rmin,rmax, &
tau_s,tau_e_store,Qmu_store,T_c_source,vx,vy,vz,vnspec, &
- ABSORBING_CONDITIONS,elem_in_crust,elem_in_mantle)
+ elem_in_crust,elem_in_mantle)
+
+ use meshfem3D_par,only: &
+ RCMB,RICB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220, &
+ R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ ABSORBING_CONDITIONS
+
use meshfem3D_models_par
implicit none
@@ -59,8 +64,7 @@
double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
- double precision :: rmin,rmax,RCMB,RICB,R670,RMOHO, &
- RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN
+ double precision :: rmin,rmax
! attenuation values
integer :: vx,vy,vz,vnspec
@@ -69,7 +73,6 @@
double precision, dimension(N_SLS, vx, vy, vz, vnspec) :: tau_e_store
double precision :: T_c_source
- logical :: ABSORBING_CONDITIONS
logical :: elem_in_crust,elem_in_mantle
! local parameters
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/initialize_mesher.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/initialize_mesher.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/initialize_mesher.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -142,8 +142,8 @@
if(sizeprocs /= NPROCTOT) call exit_MPI(myrank,'wrong number of MPI processes')
! compute rotation matrix from Euler angles
- ANGULAR_WIDTH_XI_RAD = ANGULAR_WIDTH_XI_IN_DEGREES * PI / 180.d0
- ANGULAR_WIDTH_ETA_RAD = ANGULAR_WIDTH_ETA_IN_DEGREES * PI / 180.d0
+ ANGULAR_WIDTH_XI_RAD = ANGULAR_WIDTH_XI_IN_DEGREES * DEGREES_TO_RADIANS
+ ANGULAR_WIDTH_ETA_RAD = ANGULAR_WIDTH_ETA_IN_DEGREES * DEGREES_TO_RADIANS
if(NCHUNKS /= 6) call euler_angles(rotation_matrix,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH)
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/meshfem3D_models.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/meshfem3D_models.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/meshfem3D_models.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -77,31 +77,30 @@
call model_s40rts_broadcast(myrank,S40RTS_V)
case(THREE_D_MODEL_SEA99_JP3D)
- ! the variables read are declared and stored in structure SEA99M_V and JP3DM_V
- call model_sea99_s_broadcast(myrank,SEA99M_V)
- call model_jp3d_broadcast(myrank,JP3DM_V)
+ ! the variables read are declared and stored in structure model_sea99_s_par and model_jp3d_par
+ call model_sea99_s_broadcast(myrank)
+ call model_jp3d_broadcast(myrank)
case(THREE_D_MODEL_SEA99)
- ! the variables read are declared and stored in structure SEA99M_V
- call model_sea99_s_broadcast(myrank,SEA99M_V)
+ ! the variables read are declared and stored in structure model_sea99_s_par
+ call model_sea99_s_broadcast(myrank)
case(THREE_D_MODEL_JP3D)
- ! the variables read are declared and stored in structure JP3DM_V
- call model_jp3d_broadcast(myrank,JP3DM_V)
+ ! the variables read are declared and stored in structure model_jp3d_par
+ call model_jp3d_broadcast(myrank)
case(THREE_D_MODEL_S362ANI,THREE_D_MODEL_S362WMANI, &
THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA)
- call model_s362ani_broadcast(myrank,THREE_D_MODEL,numker,numhpa,ihpa,&
- lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,itpspl, &
- xlaspl,xlospl,radspl,coe,hsplfl,dskker,kerstr,varstr,refmdl)
+ ! the variables read are declared and stored in structure model_s362ani_par
+ call model_s362ani_broadcast(myrank,THREE_D_MODEL)
case(THREE_D_MODEL_PPM)
! Point Profile Models
- ! the variables read are declared and stored in structure PPM_V
- call model_ppm_broadcast(myrank,PPM_V)
+ ! the variables read are declared and stored in structure model_ppm_par
+ call model_ppm_broadcast(myrank)
! could use EUcrust07 Vp crustal structure
- !call model_eucrust_broadcast(myrank,EUCM_V)
+ !call model_eucrust_broadcast(myrank)
case(THREE_D_MODEL_GAPP2)
! GAP model
@@ -198,15 +197,15 @@
case (ICRUST_CRUST2)
! crust 2.0
- call model_crust_broadcast(myrank,CM_V)
+ call model_crust_broadcast(myrank)
case (ICRUST_CRUSTMAPS)
! general crustmaps
- call model_crustmaps_broadcast(myrank,GC_V)
+ call model_crustmaps_broadcast(myrank)
case (ICRUST_EPCRUST)
! EPcrust
- call model_epcrust_broadcast(myrank,EPCRUST)
+ call model_epcrust_broadcast(myrank)
case default
stop 'crustal model type not defined'
@@ -436,14 +435,14 @@
case(THREE_D_MODEL_SEA99_JP3D)
! sea99 + jp3d1994
- call model_sea99_s(r_used,theta,phi,dvs,SEA99M_V)
+ call model_sea99_s(r_used,theta,phi,dvs)
vsv=vsv*(1.0d0+dvs)
vsh=vsh*(1.0d0+dvs)
! use Lebedev model sea99 as background and add vp & vs perturbation from Zhao 1994 model jp3d
if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
.and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
if(r_used > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
- call model_jp3d_iso_zhao(r_used,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ call model_jp3d_iso_zhao(r_used,theta,phi,vp,vs,dvp,dvs,rho,found_crust)
vpv=vpv*(1.0d0+dvp)
vph=vph*(1.0d0+dvp)
vsv=vsv*(1.0d0+dvs)
@@ -453,7 +452,7 @@
case(THREE_D_MODEL_SEA99)
! sea99 Vs-only
- call model_sea99_s(r_used,theta,phi,dvs,SEA99M_V)
+ call model_sea99_s(r_used,theta,phi,dvs)
vsv=vsv*(1.0d0+dvs)
vsh=vsh*(1.0d0+dvs)
@@ -462,7 +461,7 @@
if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
.and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
if(r_used > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
- call model_jp3d_iso_zhao(r_used,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ call model_jp3d_iso_zhao(r_used,theta,phi,vp,vs,dvp,dvs,rho,found_crust)
vpv=vpv*(1.0d0+dvp)
vph=vph*(1.0d0+dvp)
vsv=vsv*(1.0d0+dvs)
@@ -476,11 +475,7 @@
xcolat = sngl(theta*180.0d0/PI)
xlon = sngl(phi*180.0d0/PI)
xrad = sngl(r_used*R_EARTH_KM)
- call model_s362ani_subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv, &
- numker,numhpa,numcof,ihpa,lmax,nylm, &
- lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
- nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
- coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+ call model_s362ani_subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv)
! to use speed values from the 1D reference model but with 3D mesh variations
if( USE_1D_REFERENCE ) then
@@ -514,7 +509,7 @@
case(THREE_D_MODEL_PPM )
! point profile model
- call model_PPM(r_used,theta,phi,dvs,dvp,drho,PPM_V)
+ call model_PPM(r_used,theta,phi,dvs,dvp,drho)
vpv=vpv*(1.0d0+dvp)
vph=vph*(1.0d0+dvp)
vsv=vsv*(1.0d0+dvs)
@@ -632,17 +627,17 @@
implicit none
- integer iregion_code
+ integer :: iregion_code
! note: r is the exact radius (and not r_prem with tolerance)
- double precision xmesh,ymesh,zmesh,r
- double precision vpv,vph,vsv,vsh,rho,eta_aniso,dvp
+ double precision :: xmesh,ymesh,zmesh,r
+ double precision :: vpv,vph,vsv,vsh,rho,eta_aniso,dvp
! the 21 coefficients for an anisotropic medium in reduced notation
- double precision c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,c33, &
+ double precision :: c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,c33, &
c34,c35,c36,c44,c45,c46,c55,c56,c66
- logical elem_in_crust
- double precision moho
+ logical :: elem_in_crust
+ double precision :: moho
! local parameters
double precision :: r_dummy,theta,phi
@@ -658,10 +653,12 @@
! gets point's position theta/phi, lat/lon
call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
call reduce(theta,phi)
- lat = (PI/2.0d0-theta)*180.0d0/PI
- lon = phi*180.0d0/PI
- if(lon>180.0d0) lon = lon-360.0d0
+ lat = (PI_OVER_TWO - theta) * RADIANS_TO_DEGREES
+ lon = phi * RADIANS_TO_DEGREES
+ if( lon > 180.0d0 ) lon = lon - 360.0d0
+
+
!---
!
! ADD YOUR MODEL HERE
@@ -678,7 +675,7 @@
.and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
! makes sure radius is fine
if(r > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
- call model_jp3d_iso_zhao(r,theta,phi,vpc,vsc,dvp,dvs,rhoc,found_crust,JP3DM_V)
+ call model_jp3d_iso_zhao(r,theta,phi,vpc,vsc,dvp,dvs,rhoc,found_crust)
endif
else
! default crust
@@ -690,7 +687,7 @@
call meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
! takes vp from eucrust07
- !call model_eucrust(lat,lon,r,vpc_eu,found_eucrust,EUCM_V)
+ !call model_eucrust(lat,lon,r,vpc_eu,found_eucrust)
!if( found_eucrust) then
! vpc=vpc_eu
!endif
@@ -775,14 +772,14 @@
case (ICRUST_CRUST2)
! crust 2.0
- call model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,CM_V,elem_in_crust)
+ call model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
case (ICRUST_CRUSTMAPS)
! general crustmaps
- call model_crustmaps(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,GC_V,elem_in_crust)
+ call model_crustmaps(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
case (ICRUST_EPCRUST)
-! call model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,CM_V,elem_in_crust)
+! call model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
! within EPCRUST region
! if (lat >= EPCRUST_LAT_MIN .and. lat <= EPCRUST_LAT_MAX &
! .and. lon >= EPCRUST_LON_MIN .and. lon<=EPCRUST_LON_MAX ) then
@@ -791,7 +788,7 @@
! rhoc=0.0d0
! moho=0.0d0
! found_crust = .false.
- call model_epcrust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,EPCRUST,elem_in_crust)
+ call model_epcrust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
! end if
case default
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/meshfem3D_par.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/meshfem3D_par.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/meshfem3D_par.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -185,149 +185,6 @@
type (model_heterogen_m_variables) HMM
! model_heterogen_m_variables
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- double precision :: PNA(MPA)
- double precision :: RNA(MRA)
- double precision :: HNA(MHA)
- double precision :: PNB(MPB)
- double precision :: RNB(MRB)
- double precision :: HNB(MHB)
- double precision :: VELAP(MPA,MRA,MHA)
- double precision :: VELBP(MPB,MRB,MHB)
- ! discon
- double precision :: PN(51)
- double precision :: RRN(63)
- double precision :: DEPA(51,63)
- double precision :: DEPB(51,63)
- double precision :: DEPC(51,63)
- ! locate
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- double precision :: WV(8)
- ! prhfd
- double precision :: P
- double precision :: R
- double precision :: H
- double precision :: PF
- double precision :: RF
- double precision :: HF
- double precision :: PF1
- double precision :: RF1
- double precision :: HF1
- double precision :: PD
- double precision :: RD
- double precision :: HD
- ! jpmodv
- double precision :: VP(29)
- double precision :: VS(29)
- double precision :: RA(29)
- double precision :: DEPJ(29)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_variables
-
-! model_sea99_s_variables
- type model_sea99_s_variables
- sequence
- double precision :: sea99_vs(100,100,100)
- double precision :: sea99_depth(100)
- double precision :: sea99_ddeg
- double precision :: alatmin
- double precision :: alatmax
- double precision :: alonmin
- double precision :: alonmax
- integer :: sea99_ndep
- integer :: sea99_nlat
- integer :: sea99_nlon
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_sea99_s_variables
- type (model_sea99_s_variables) SEA99M_V
-! model_sea99_s_variables
-
-! crust 2.0 model_crust_variables
- type model_crust_variables
- sequence
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
- character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
- character(len=2) code(NKEYS_CRUST)
- character(len=2) dummy_pad ! padding 2 bytes to align the structure
- end type model_crust_variables
- type (model_crust_variables) CM_V
-! model_crust_variables
-
-! EUcrust
- type model_eucrust_variables
- sequence
- double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
- eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
- eucrust_basement,eucrust_ucdepth
- integer :: num_eucrust
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_eucrust_variables
- type (model_eucrust_variables) EUCM_V
-
-! type for EPCRUST 1.0
- type model_epcrust_variables
- sequence
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT):: lon_ep,lat_ep,topo_ep
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER):: thickness_ep
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER):: vp_ep
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER):: vs_ep
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER):: rho_ep
- end type model_epcrust_variables
- type (model_epcrust_variables) EPCRUST
-
-! model_crustmaps_variables combined crustal maps
- type model_crustmaps_variables
- sequence
- double precision, dimension(180*CRUSTMAP_RESOLUTION,360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: thickness
- double precision, dimension(180*CRUSTMAP_RESOLUTION,360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: density
- double precision, dimension(180*CRUSTMAP_RESOLUTION,360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocp
- double precision, dimension(180*CRUSTMAP_RESOLUTION,360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocs
- double precision thicknessnp(NLAYERS_CRUSTMAP)
- double precision densitynp(NLAYERS_CRUSTMAP)
- double precision velocpnp(NLAYERS_CRUSTMAP)
- double precision velocsnp(NLAYERS_CRUSTMAP)
- double precision thicknesssp(NLAYERS_CRUSTMAP)
- double precision densitysp(NLAYERS_CRUSTMAP)
- double precision velocpsp(NLAYERS_CRUSTMAP)
- double precision velocssp(NLAYERS_CRUSTMAP)
- end type model_crustmaps_variables
- type (model_crustmaps_variables) GC_V
-!model_crustmaps_variables
-
! model_attenuation_storage_var
type model_attenuation_storage_var
sequence
@@ -355,17 +212,6 @@
type(attenuation_simplex_variables) AS_V
! attenuation_simplex_variables
-! point profile model_variables
- type model_ppm_variables
- sequence
- double precision,dimension(:),pointer :: dvs,lat,lon,depth
- double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
- double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
- integer :: num_v,num_latperlon,num_lonperdepth
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_ppm_variables
- type (model_ppm_variables) PPM_V
-
! GLL model_variables
type model_gll_variables
sequence
@@ -384,46 +230,6 @@
! bathymetry and topography: use integer array to store values
integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
-! used for 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
- integer, parameter :: maxker=200
- integer, parameter :: maxl=72
- integer, parameter :: maxcoe=2000
- integer, parameter :: maxver=1000
- integer, parameter :: maxhpa=2
-
- real(kind=4) conpt(maxver,maxhpa)
- real(kind=4) xlaspl(maxcoe,maxhpa)
- real(kind=4) xlospl(maxcoe,maxhpa)
- real(kind=4) radspl(maxcoe,maxhpa)
- real(kind=4) coe(maxcoe,maxker)
- real(kind=4) vercof(maxker)
- real(kind=4) vercofd(maxker)
-
- real(kind=4) ylmcof((maxl+1)**2,maxhpa)
- real(kind=4) wk1(maxl+1)
- real(kind=4) wk2(maxl+1)
- real(kind=4) wk3(maxl+1)
-
- integer lmxhpa(maxhpa)
- integer itypehpa(maxhpa)
- integer ihpakern(maxker)
- integer numcoe(maxhpa)
- integer ivarkern(maxker)
- integer itpspl(maxcoe,maxhpa)
-
- integer nconpt(maxhpa),iver
- integer iconpt(maxver,maxhpa)
- integer numker
- integer numhpa,numcof
- integer ihpa,lmax,nylm
-
- character(len=80) kerstr
- character(len=80) refmdl
- character(len=40) varstr(maxker)
- character(len=80) hsplfl(maxhpa)
- character(len=40) dskker(maxker)
-
-
! for ellipticity
double precision rspl(NR),espl(NR),espl2(NR)
integer nspl
@@ -562,7 +368,6 @@
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
end module meshfem3D_par
@@ -665,8 +470,8 @@
! 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
+ double precision, dimension(N_SLS) :: tau_s
+ double precision :: T_c_source
logical :: USE_ONE_LAYER_SB
@@ -677,8 +482,6 @@
integer :: nb_layer_above_aniso,FIRST_ELT_ABOVE_ANISO
- logical :: ACTUALLY_STORE_ARRAYS
-
! Boundary Mesh
integer NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho
integer, dimension(:), allocatable :: ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot, &
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_crust.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_crust.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_crust.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -35,45 +35,57 @@
! reads and smooths crust2.0 model
!--------------------------------------------------------------------------------------------------
+ module model_crust_par
- subroutine model_crust_broadcast(myrank,CM_V)
+ ! crustal_model_constants
+ ! crustal model parameters for crust2.0
+ integer, parameter :: NKEYS_CRUST = 359
+ integer, parameter :: NLAYERS_CRUST = 8
+ integer, parameter :: NCAP_CRUST = 180
+ ! model_crust_variables
+ double precision, dimension(:,:),allocatable :: thlr,velocp,velocs,dens
+ character(len=2) :: abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+ character(len=2) :: code(NKEYS_CRUST)
+
+ end module model_crust_par
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ subroutine model_crust_broadcast(myrank)
+
! standard routine to setup model
+ use model_crust_par
+
implicit none
include "constants.h"
- ! standard include of the MPI library
include 'mpif.h'
- ! model_crust_variables
- type model_crust_variables
- sequence
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
- character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
- character(len=2) code(NKEYS_CRUST)
- character(len=2) dummy_pad ! padding 2 bytes to align the structure
- end type model_crust_variables
-
- type (model_crust_variables) CM_V
- ! model_crust_variables
-
integer :: myrank
integer :: ier
- ! the variables read are declared and stored in structure CM_V
- if(myrank == 0) call read_crust_model(CM_V)
+ ! allocate crustal arrays
+ allocate( thlr(NKEYS_CRUST,NLAYERS_CRUST), &
+ velocp(NKEYS_CRUST,NLAYERS_CRUST), &
+ velocs(NKEYS_CRUST,NLAYERS_CRUST), &
+ dens(NKEYS_CRUST,NLAYERS_CRUST), &
+ stat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating crustal arrays')
+ ! the variables read are declared and stored in structure model_crust_par
+ if(myrank == 0) call read_crust_model()
+
! 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)
+ call MPI_BCAST(thlr,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(velocp,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(velocs,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(dens,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(abbreviation,NCAP_CRUST*NCAP_CRUST,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(code,2*NKEYS_CRUST,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
end subroutine model_crust_broadcast
@@ -83,53 +95,53 @@
!
- subroutine model_crust(lat,lon,x,vp,vs,rho,moho,found_crust,CM_V,elem_in_crust)
+ subroutine model_crust(lat,lon,x,vp,vs,rho,moho,found_crust,elem_in_crust)
+ use model_crust_par
+
implicit none
include "constants.h"
-! model_crust_variables
- type model_crust_variables
- sequence
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
- character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
- character(len=2) code(NKEYS_CRUST)
- character(len=2) dummy_pad ! padding 2 bytes to align the structure
- end type model_crust_variables
+ double precision :: lat,lon,x,vp,vs,rho,moho
+ logical :: found_crust,elem_in_crust
- type (model_crust_variables) CM_V
-! model_crust_variables
-
- double precision lat,lon,x,vp,vs,rho,moho
- logical found_crust,elem_in_crust
-
! local parameters
- double precision h_sed,h_uc
- double precision x3,x4,x5,x6,x7,scaleval
- double precision vps(NLAYERS_CRUST),vss(NLAYERS_CRUST),rhos(NLAYERS_CRUST),thicks(NLAYERS_CRUST)
+ double precision :: h_sed,h_uc
+ double precision :: x3,x4,x5,x6,x7,scaleval
+ double precision,dimension(NLAYERS_CRUST):: vps,vss,rhos,thicks
! initializes
- vp = 0.d0
- vs = 0.d0
- rho = 0.d0
+ vp = ZERO
+ vs = ZERO
+ rho = ZERO
! gets smoothed crust2.0 structure
- call crust_CAPsmoothed(lat,lon,vps,vss,rhos,thicks,CM_V%abbreviation, &
- CM_V%code,CM_V%thlr,CM_V%velocp,CM_V%velocs,CM_V%dens)
+ call crust_CAPsmoothed(lat,lon,vps,vss,rhos,thicks,abbreviation, &
+ code,thlr,velocp,velocs,dens)
- x3 = (R_EARTH-thicks(3)*1000.0d0)/R_EARTH
+ scaleval = ONE / R_EARTH_KM
+
+ ! non-dimensializes thickness (given in km)
+ x3 = ONE - thicks(3) * scaleval
h_sed = thicks(3) + thicks(4)
- x4 = (R_EARTH-h_sed*1000.0d0)/R_EARTH
+ x4 = ONE - h_sed * scaleval
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
+ x5 = ONE - h_uc * scaleval
+ x6 = ONE - (h_uc+thicks(6)) * scaleval
+ x7 = ONE - (h_uc+thicks(6)+thicks(7)) * scaleval
- found_crust = .true.
+ ! checks moho value
+ !moho = h_uc + thicks(6) + thicks(7)
+ !if( moho /= thicks(NLAYERS_CRUST) ) then
+ ! print*,'moho:',moho,thicks(NLAYERS_CRUST)
+ ! print*,' lat/lon/x:',lat,lon,x
+ !endif
+ ! No matter found_crust true or false, output moho thickness
+ moho = (h_uc+thicks(6)+thicks(7)) * scaleval
+
+ ! gets corresponding crustal velocities and density
+ found_crust = .true.
! if(x > x3 .and. INCLUDE_SEDIMENTS_CRUST &
! .and. h_sed >= MINIMUM_SEDIMENT_THICKNESS) then
if(x > x3 .and. INCLUDE_SEDIMENTS_CRUST ) then
@@ -167,75 +179,55 @@
! non-dimensionalize
if (found_crust) then
- scaleval = dsqrt(PI*GRAV*RHOAV)
- vp = vp*1000.0d0/(R_EARTH*scaleval)
- vs = vs*1000.0d0/(R_EARTH*scaleval)
- rho = rho*1000.0d0/RHOAV
+ scaleval = ONE / ( R_EARTH_KM * dsqrt(PI*GRAV*RHOAV) )
+ vp = vp * scaleval
+ vs = vs * scaleval
+ rho = rho * 1000.0d0 / RHOAV
endif
- ! checks moho value
- !moho = h_uc + thicks(6) + thicks(7)
- !if( moho /= thicks(NLAYERS_CRUST) ) then
- ! print*,'moho:',moho,thicks(NLAYERS_CRUST)
- ! print*,' lat/lon/x:',lat,lon,x
- !endif
-
- ! No matter found_crust true or false, output moho thickness
- moho = (h_uc+thicks(6)+thicks(7))*1000.0d0/R_EARTH
-
end subroutine model_crust
!---------------------------
- subroutine read_crust_model(CM_V)
+ subroutine read_crust_model()
+ use model_crust_par
+
implicit none
+
include "constants.h"
-! model_crust_variables
- type model_crust_variables
- sequence
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocp
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: velocs
- double precision, dimension(NKEYS_CRUST,NLAYERS_CRUST) :: dens
- character(len=2) abbreviation(NCAP_CRUST/2,NCAP_CRUST)
- character(len=2) code(NKEYS_CRUST)
- character(len=2) dummy_pad ! padding 2 bytes to align the structure
- end type model_crust_variables
+ ! local variables
+ integer :: i,ila,icolat,ikey,ier
- type (model_crust_variables) CM_V
-! model_crust_variables
+ double precision :: h_moho_min,h_moho_max
-! local variables
- integer i
- integer ila,icolat
- integer ikey
+ character(len=150) :: CNtype2, CNtype2_key_modif
- 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',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(0,'error opening file CNtype2.txt of crust2.0 model')
- 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)
+ read(1,*) icolat,(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
+ call get_value_string(CNtype2_key_modif, 'model.CNtype2_key_modif', 'DATA/crust2.0/CNtype2_key_modif.txt')
+ open(unit=1,file=CNtype2_key_modif,status='old',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(0,'error opening file CNtype2_key_modif.txt of crust2.0 model')
+
+ 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)
+ read (1,"(a2)") code(ikey)
+ read (1,*) (velocp(ikey,i),i=1,NLAYERS_CRUST)
+ read (1,*) (velocs(ikey,i),i=1,NLAYERS_CRUST)
+ read (1,*) (dens(ikey,i),i=1,NLAYERS_CRUST)
+ read (1,*) (thlr(ikey,i),i=1,NLAYERS_CRUST-1),thlr(ikey,NLAYERS_CRUST)
+ if(thlr(ikey,NLAYERS_CRUST) > h_moho_max) h_moho_max = thlr(ikey,NLAYERS_CRUST)
+ if(thlr(ikey,NLAYERS_CRUST) < h_moho_min) h_moho_min = thlr(ikey,NLAYERS_CRUST)
enddo
close(1)
@@ -255,7 +247,10 @@
! in the theta direction and NPHI in the phi direction.
! The cap is rotated to the North Pole.
+ use model_crust_par,only: NLAYERS_CRUST,NKEYS_CRUST,NCAP_CRUST
+
implicit none
+
include "constants.h"
! sampling rate for CAP points
@@ -263,12 +258,13 @@
integer, parameter :: NPHI = 20
! argument variables
- double precision lat,lon
- double precision rho(NLAYERS_CRUST),thick(NLAYERS_CRUST),velp(NLAYERS_CRUST),vels(NLAYERS_CRUST)
- double precision thlr(NKEYS_CRUST,NLAYERS_CRUST),velocp(NKEYS_CRUST,NLAYERS_CRUST)
- double precision velocs(NKEYS_CRUST,NLAYERS_CRUST),dens(NKEYS_CRUST,NLAYERS_CRUST)
- character(len=2) code(NKEYS_CRUST),abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+ double precision :: lat,lon
+ double precision,dimension(NLAYERS_CRUST) :: rho,thick,velp,vels
+ double precision,dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr,velocp,velocs,dens
+ character(len=2) :: code(NKEYS_CRUST)
+ character(len=2) :: abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+
!-------------------------------
! work-around to avoid jacobian problems when stretching mesh elements;
! one could also try to slightly change the shape of the doulbing element bricks (which cause the problem)...
@@ -308,9 +304,9 @@
if( dist < CRITICAL_RANGE ) then
! increases cap smoothing degree
! scales between -1 at center and 0 at border
- dist = dist / CRITICAL_RANGE - 1.0d0
+ dist = dist / CRITICAL_RANGE - ONE
! shifts value to 1 at center and 0 to the border with exponential decay
- dist = 1.0d0 - exp( - dist*dist*10.0d0 )
+ dist = ONE - exp( - dist*dist*10.0d0 )
! increases smoothing degree inside of critical region to 2 degree
cap_degree = cap_degree + dist
endif
@@ -320,10 +316,10 @@
call CAP_vardegree(lon,lat,xlon,xlat,weight,cap_degree,NTHETA,NPHI)
! initializes
- velp(:) = 0.0d0
- vels(:) = 0.0d0
- rho(:) = 0.0d0
- thick(:) = 0.0d0
+ velp(:) = ZERO
+ vels(:) = ZERO
+ rho(:) = ZERO
+ thick(:) = ZERO
! loops over weight points
do i=1,NTHETA*NPHI
@@ -368,14 +364,14 @@
! argument variables
- double precision xlat,xlon
- integer icolat,ilon
+ 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))
+ icolat=int(1+( (90.d0-xlat)*0.5d0 ))
if(icolat == 91) icolat=90
- ilon=int(1+((180.d0+xlon)/2.d0))
+ ilon=int(1+( (180.d0+xlon)*0.5d0 ))
if(ilon == 181) ilon=1
if(icolat>90 .or. icolat<1) stop 'error in routine icolat_ilon'
@@ -388,11 +384,11 @@
subroutine get_crust_structure(type,vptyp,vstyp,rhtyp,thtp, &
code,thlr,velocp,velocs,dens,ierr)
+ use model_crust_par,only: NLAYERS_CRUST,NKEYS_CRUST
+
implicit none
- include "constants.h"
-
-! argument variables
+ ! argument variables
integer ierr
double precision rhtyp(NLAYERS_CRUST),thtp(NLAYERS_CRUST)
double precision vptyp(NLAYERS_CRUST),vstyp(NLAYERS_CRUST)
@@ -400,7 +396,7 @@
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
+ ! local variables
integer i,ikey
ierr=1
@@ -440,29 +436,26 @@
! sampling rate
integer :: NTHETA
integer :: NPHI
+
! smoothing size (in degrees)
double precision :: CAP_DEGREE
! argument variables
- double precision lat,lon
- double precision xlon(NTHETA*NPHI),xlat(NTHETA*NPHI),weight(NTHETA*NPHI)
+ double precision :: lat,lon
+ double precision,dimension(NTHETA*NPHI) :: xlon,xlat,weight
! local variables
- double precision CAP
- double precision theta,phi,sint,cost,sinp,cosp,wght,total
- double precision r_rot,theta_rot,phi_rot
- double precision rotation_matrix(3,3),x(3),xc(3)
- double precision dtheta,dphi,cap_area,dweight,pi_over_nphi
- integer i,j,k
- integer itheta,iphi
+ double precision :: CAP
+ double precision :: theta,phi,sint,cost,sinp,cosp,wght,total
+ double precision :: r_rot,theta_rot,phi_rot
+ double precision :: rotation_matrix(3,3),x(3),xc(3)
+ double precision :: dtheta,dphi,cap_area,dweight,pi_over_nphi
+ integer :: i,j,k,itheta,iphi
- double precision, parameter :: RADIANS_TO_DEGREES = 180.d0 / PI
- double precision, parameter :: PI_OVER_TWO = PI / 2.0d0
-
! initializes
- xlon(:) = 0.d0
- xlat(:) = 0.d0
- weight(:) = 0.d0
+ xlon(:) = ZERO
+ xlat(:) = ZERO
+ weight(:) = ZERO
! checks cap degree size
if( CAP_DEGREE < TINYVAL ) then
@@ -473,10 +466,11 @@
endif
! pre-compute parameters
- CAP = CAP_DEGREE * PI/180.0d0
+ CAP = CAP_DEGREE * DEGREES_TO_RADIANS
dtheta = 0.5d0 * CAP / dble(NTHETA)
dphi = TWO_PI / dble(NPHI)
- cap_area = TWO_PI * (1.0d0 - dcos(CAP))
+
+ cap_area = TWO_PI * ( ONE - dcos(CAP) )
dweight = CAP / dble(NTHETA) * dphi / cap_area
pi_over_nphi = PI/dble(NPHI)
@@ -498,12 +492,12 @@
rotation_matrix(2,2) = cosp
rotation_matrix(2,3) = sinp*sint
rotation_matrix(3,1) = -sint
- rotation_matrix(3,2) = 0.0d0
+ rotation_matrix(3,2) = ZERO
rotation_matrix(3,3) = cost
! calculates points over a cap at the North pole and rotates them to specified lat/lon point
i = 0
- total = 0.0d0
+ total = ZERO
do itheta = 1,NTHETA
theta = dble(2*itheta-1)*dtheta
@@ -530,7 +524,7 @@
! get x,y,z coordinates in cap around point of interest
do j=1,3
- x(j) = 0.0d0
+ x(j) = ZERO
do k=1,3
x(j) = x(j)+rotation_matrix(j,k)*xc(k)
enddo
@@ -546,197 +540,10 @@
enddo
enddo
- if(abs(total-1.0d0) > 0.001d0) then
+ if(abs(total - ONE) > 0.001d0) then
print*,'error cap:',total,CAP_DEGREE
stop 'error in cap integration for variable degree'
endif
- end subroutine
+ end subroutine CAP_vardegree
-
-!---------------------------
-! unused routines...
-!
-! subroutine crust_singlevalue(lat,lon,velp,vels,rho,thick,abbreviation,&
-! code,thlr,velocp,velocs,dens)
-!
-!! crustal vp and vs in km/s, layer thickness in km
-!
-!! uses crust2.0 as is, without smoothing
-!
-! implicit none
-! include "constants.h"
-!
-!! argument variables
-! double precision lat,lon
-! double precision rho(NLAYERS_CRUST),thick(NLAYERS_CRUST),velp(NLAYERS_CRUST),vels(NLAYERS_CRUST)
-! double precision thlr(NKEYS_CRUST,NLAYERS_CRUST),velocp(NKEYS_CRUST,NLAYERS_CRUST)
-! double precision velocs(NKEYS_CRUST,NLAYERS_CRUST),dens(NKEYS_CRUST,NLAYERS_CRUST)
-! character(len=2) code(NKEYS_CRUST),abbreviation(NCAP_CRUST/2,NCAP_CRUST)
-!
-!! local variables
-! integer icolat,ilon,ierr
-! character(len=2) crustaltype
-!
-!
-!! get integer colatitude and longitude of crustal cap
-!! -90<lat<90 -180<lon<180
-! if(lat > 90.0d0 .or. lat < -90.0d0 .or. lon > 180.0d0 .or. lon < -180.0d0) &
-! stop 'error in latitude/longitude range in crust'
-! if(lat==90.0d0) lat=89.9999d0
-! if(lat==-90.0d0) lat=-89.9999d0
-! if(lon==180.0d0) lon=179.9999d0
-! if(lon==-180.0d0) lon=-179.9999d0
-!
-! call icolat_ilon(lat,lon,icolat,ilon)
-! crustaltype = abbreviation(icolat,ilon)
-! call get_crust_structure(crustaltype,velp,vels,rho,thick, &
-! code,thlr,velocp,velocs,dens,ierr)
-! if( ierr /= 0 ) stop 'error in routine get_crust_structure'
-!
-! end subroutine crust_singlevalue
-!
-!---------------------------
-!
-!
-! subroutine crust_org(lat,lon,velp,vels,rho,thick,abbreviation,code,thlr,velocp,velocs,dens)
-!
-!! crustal vp and vs in km/s, layer thickness in km
-!! crust2.0 is smoothed with a cap of size CAP using NTHETA points
-!! in the theta direction and NPHI in the phi direction.
-!! The cap is rotated to the North Pole.
-!
-! implicit none
-! include "constants.h"
-!! Change the CAP function to smooth crustal model
-! integer, parameter :: NTHETA = 4 !2
-! integer, parameter :: NPHI = 20 !10
-! double precision, parameter :: CAP = 1.0d0*PI/180.0d0 ! 2.0d0*PI/180.0d0
-!
-!! argument variables
-! double precision lat,lon
-! double precision rho(NLAYERS_CRUST),thick(NLAYERS_CRUST),velp(NLAYERS_CRUST),vels(NLAYERS_CRUST)
-! double precision thlr(NKEYS_CRUST,NLAYERS_CRUST),velocp(NKEYS_CRUST,NLAYERS_CRUST)
-! double precision velocs(NKEYS_CRUST,NLAYERS_CRUST),dens(NKEYS_CRUST,NLAYERS_CRUST)
-! character(len=2) code(NKEYS_CRUST),abbreviation(NCAP_CRUST/2,NCAP_CRUST)
-!
-!! local variables
-! integer i,j,k,icolat,ilon,ierr
-! integer itheta,iphi,npoints
-! double precision theta,phi,sint,cost,sinp,cosp,dtheta,dphi,cap_area,wght,total
-! double precision r_rot,theta_rot,phi_rot
-! double precision rotation_matrix(3,3),x(3),xc(3)
-! double precision xlon(NTHETA*NPHI),xlat(NTHETA*NPHI),weight(NTHETA*NPHI)
-! double precision rhol(NLAYERS_CRUST),thickl(NLAYERS_CRUST),velpl(NLAYERS_CRUST),velsl(NLAYERS_CRUST)
-! character(len=2) crustaltype
-!
-!! get integer colatitude and longitude of crustal cap
-!! -90<lat<90 -180<lon<180
-! if(lat > 90.0d0 .or. lat < -90.0d0 .or. lon > 180.0d0 .or. lon < -180.0d0) &
-! stop 'error in latitude/longitude range in crust'
-! if(lat==90.0d0) lat=89.9999d0
-! if(lat==-90.0d0) lat=-89.9999d0
-! if(lon==180.0d0) lon=179.9999d0
-! if(lon==-180.0d0) lon=-179.9999d0
-!
-! call icolat_ilon(lat,lon,icolat,ilon)
-! crustaltype=abbreviation(icolat,ilon)
-! call get_crust_structure(crustaltype,velp,vels,rho,thick, &
-! code,thlr,velocp,velocs,dens,ierr)
-!
-!! uncomment the following line to use crust2.0 as is, without smoothing
-!!
-!! return
-!
-! theta = (90.0-lat)*PI/180.0
-! phi = lon*PI/180.0
-!
-! sint = sin(theta)
-! cost = cos(theta)
-! sinp = sin(phi)
-! cosp = cos(phi)
-!
-!! set up rotation matrix to go from cap at North pole
-!! to cap around point of interest
-! rotation_matrix(1,1) = cosp*cost
-! rotation_matrix(1,2) = -sinp
-! rotation_matrix(1,3) = cosp*sint
-! rotation_matrix(2,1) = sinp*cost
-! rotation_matrix(2,2) = cosp
-! rotation_matrix(2,3) = sinp*sint
-! rotation_matrix(3,1) = -sint
-! rotation_matrix(3,2) = 0.0
-! rotation_matrix(3,3) = cost
-!
-! dtheta = CAP/dble(NTHETA)
-! dphi = 2.0*PI/dble(NPHI)
-! cap_area = 2.0*PI*(1.0-cos(CAP))
-!
-!! integrate over a cap at the North pole
-! i = 0
-! total = 0.0
-! do itheta = 1,NTHETA
-!
-! theta = 0.5*dble(2*itheta-1)*CAP/dble(NTHETA)
-! cost = cos(theta)
-! sint = sin(theta)
-! wght = sint*dtheta*dphi/cap_area
-!
-! do iphi = 1,NPHI
-!
-! i = i+1
-!! get the weight associated with this integration point (same for all phi)
-! weight(i) = wght
-! total = total + weight(i)
-! phi = dble(2*iphi-1)*PI/dble(NPHI)
-! cosp = cos(phi)
-! sinp = sin(phi)
-!! x,y,z coordinates of integration point in cap at North pole
-! xc(1) = sint*cosp
-! xc(2) = sint*sinp
-! xc(3) = cost
-!! get x,y,z coordinates in cap around point of interest
-! do j=1,3
-! x(j) = 0.0
-! do k=1,3
-! x(j) = x(j)+rotation_matrix(j,k)*xc(k)
-! enddo
-! enddo
-!! get latitude and longitude (degrees) of integration point
-! call xyz_2_rthetaphi_dble(x(1),x(2),x(3),r_rot,theta_rot,phi_rot)
-! call reduce(theta_rot,phi_rot)
-! xlat(i) = (PI/2.0-theta_rot)*180.0/PI
-! xlon(i) = phi_rot*180.0/PI
-! if(xlon(i) > 180.0) xlon(i) = xlon(i)-360.0
-!
-! enddo
-!
-! enddo
-!
-! if(abs(total-1.0) > 0.001) stop 'error in cap integration for crust2.0'
-!
-! npoints = i
-!
-! do j=1,NLAYERS_CRUST
-! rho(j)=0.0d0
-! thick(j)=0.0d0
-! velp(j)=0.0d0
-! vels(j)=0.0d0
-! enddo
-!
-! do i=1,npoints
-! call icolat_ilon(xlat(i),xlon(i),icolat,ilon)
-! crustaltype=abbreviation(icolat,ilon)
-! call get_crust_structure(crustaltype,velpl,velsl,rhol,thickl, &
-! code,thlr,velocp,velocs,dens,ierr)
-! if(ierr /= 0) stop 'error in routine get_crust_structure'
-! do j=1,NLAYERS_CRUST
-! rho(j)=rho(j)+weight(i)*rhol(j)
-! thick(j)=thick(j)+weight(i)*thickl(j)
-! velp(j)=velp(j)+weight(i)*velpl(j)
-! vels(j)=vels(j)+weight(i)*velsl(j)
-! enddo
-! enddo
-!
-! end subroutine crust_org
-
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_crustmaps.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_crustmaps.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_crustmaps.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -39,73 +39,83 @@
! main author: Matthias Meschede (meschede at princeton.edu)
!--------------------------------------------------------------------------------------------------
- subroutine model_crustmaps_broadcast(myrank,GC_V)
+ module model_crustmaps_par
+ ! General Crustmaps parameters
+ integer, parameter :: CRUSTMAP_RESOLUTION = 4 !means 1/4 degrees
+ integer, parameter :: NLAYERS_CRUSTMAP = 5
+
+ ! model_crustmaps_variables combined crustal maps
+ double precision, dimension(:,:,:),allocatable :: thickness,density,velocp,velocs
+
+ double precision,dimension(:),allocatable :: thicknessnp,densitynp, &
+ velocpnp,velocsnp,thicknesssp,densitysp,velocpsp,velocssp
+
+ end module model_crustmaps_par
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine model_crustmaps_broadcast(myrank)
+
! standard routine to setup model
+ use model_crustmaps_par
+
implicit none
include "constants.h"
- ! standard include of the MPI library
include 'mpif.h'
integer :: myrank
- !model_crustmaps_variables
- type model_crustmaps_variables
- sequence
- double precision, dimension(180*CRUSTMAP_RESOLUTION,&
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: thickness
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: density
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocp
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocs
-
- double precision thicknessnp(NLAYERS_CRUSTMAP)
- double precision densitynp(NLAYERS_CRUSTMAP)
- double precision velocpnp(NLAYERS_CRUSTMAP)
- double precision velocsnp(NLAYERS_CRUSTMAP)
- double precision thicknesssp(NLAYERS_CRUSTMAP)
- double precision densitysp(NLAYERS_CRUSTMAP)
- double precision velocpsp(NLAYERS_CRUSTMAP)
- double precision velocssp(NLAYERS_CRUSTMAP)
-
- end type model_crustmaps_variables
- type (model_crustmaps_variables) GC_V
- !model_crustmaps_variables
-
! local parameters
integer :: ier
+ ! allocates model arrays
+ allocate(thickness(180*CRUSTMAP_RESOLUTION,360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP), &
+ density(180*CRUSTMAP_RESOLUTION,360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP), &
+ velocp(180*CRUSTMAP_RESOLUTION,360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP), &
+ velocs(180*CRUSTMAP_RESOLUTION,360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP), &
+ thicknessnp(NLAYERS_CRUSTMAP), &
+ densitynp(NLAYERS_CRUSTMAP), &
+ velocpnp(NLAYERS_CRUSTMAP), &
+ velocsnp(NLAYERS_CRUSTMAP), &
+ thicknesssp(NLAYERS_CRUSTMAP), &
+ densitysp(NLAYERS_CRUSTMAP), &
+ velocpsp(NLAYERS_CRUSTMAP), &
+ velocssp(NLAYERS_CRUSTMAP), &
+ stat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating model_crustmaps arrays')
+
! master reads in crust maps
- if(myrank == 0) &
- call read_general_crustmap(GC_V)
+ if(myrank == 0) call read_general_crustmap()
! broadcasts values to all processes
- call MPI_BCAST(GC_V%thickness,180*360*CRUSTMAP_RESOLUTION*CRUSTMAP_RESOLUTION*NLAYERS_CRUSTMAP, &
+ call MPI_BCAST(thickness,180*360*CRUSTMAP_RESOLUTION*CRUSTMAP_RESOLUTION*NLAYERS_CRUSTMAP, &
MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%velocp,180*360*CRUSTMAP_RESOLUTION*CRUSTMAP_RESOLUTION*NLAYERS_CRUSTMAP, &
+ call MPI_BCAST(velocp,180*360*CRUSTMAP_RESOLUTION*CRUSTMAP_RESOLUTION*NLAYERS_CRUSTMAP, &
MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%velocs,180*360*CRUSTMAP_RESOLUTION*CRUSTMAP_RESOLUTION*NLAYERS_CRUSTMAP, &
+ call MPI_BCAST(velocs,180*360*CRUSTMAP_RESOLUTION*CRUSTMAP_RESOLUTION*NLAYERS_CRUSTMAP, &
MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%density,180*360*CRUSTMAP_RESOLUTION*CRUSTMAP_RESOLUTION*NLAYERS_CRUSTMAP, &
+ call MPI_BCAST(density,180*360*CRUSTMAP_RESOLUTION*CRUSTMAP_RESOLUTION*NLAYERS_CRUSTMAP, &
MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
! north pole
- call MPI_BCAST(GC_V%thicknessnp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%densitynp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%velocpnp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%velocsnp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%densitynp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(thicknessnp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(densitynp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(velocpnp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(velocsnp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(densitynp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
! south pole
- call MPI_BCAST(GC_V%thicknesssp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%densitysp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%velocpsp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%velocssp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(GC_V%densitysp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(thicknesssp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(densitysp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(velocpsp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(velocssp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(densitysp,NLAYERS_CRUSTMAP,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
end subroutine model_crustmaps_broadcast
@@ -116,46 +126,20 @@
! read general crustmap by Matthias Meschede
- subroutine read_general_crustmap(GC_V)
+ subroutine read_general_crustmap()
+ use model_crustmaps_par
+
implicit none
include "constants.h"
-!Matthias Meschede
- !model_crustmaps_variables
- type model_crustmaps_variables
- sequence
- double precision, dimension(180*CRUSTMAP_RESOLUTION,&
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: thickness
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: density
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocp
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocs
+ integer :: ila,iln,i,l
- double precision thicknessnp(NLAYERS_CRUSTMAP)
- double precision densitynp(NLAYERS_CRUSTMAP)
- double precision velocpnp(NLAYERS_CRUSTMAP)
- double precision velocsnp(NLAYERS_CRUSTMAP)
- double precision thicknesssp(NLAYERS_CRUSTMAP)
- double precision densitysp(NLAYERS_CRUSTMAP)
- double precision velocpsp(NLAYERS_CRUSTMAP)
- double precision velocssp(NLAYERS_CRUSTMAP)
+ character(len=150) :: eucrustt3,eucrustt4,eucrustt5,eucrustt6,eucrustt7,&
+ eucrustr3,eucrustr4,eucrustr5,eucrustr6,eucrustr7,&
+ eucrustp3,eucrustp4,eucrustp5,eucrustp6,eucrustp7,&
+ eucrusts3,eucrusts4,eucrusts5,eucrusts6,eucrusts7
- end type model_crustmaps_variables
- type (model_crustmaps_variables) GC_V
- !model_crustmaps_variables
-
-
-
- integer ila,iln,i,l
-
- character(len=150) eucrustt3,eucrustt4,eucrustt5,eucrustt6,eucrustt7,&
- eucrustr3,eucrustr4,eucrustr5,eucrustr6,eucrustr7,&
- eucrustp3,eucrustp4,eucrustp5,eucrustp6,eucrustp7,&
- eucrusts3,eucrusts4,eucrusts5,eucrusts6,eucrusts7
-
!Matthias Meschede
call get_value_string(eucrustt3, 'model.eucrustt3','DATA/crustmap/eucrustt3.cmap')
call get_value_string(eucrustt4, 'model.eucrustt4','DATA/crustmap/eucrustt4.cmap')
@@ -185,31 +169,31 @@
open(unit=1,file=eucrustt3,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%thickness(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (thickness(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
open(unit=1,file=eucrustt4,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%thickness(ila,iln,2),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (thickness(ila,iln,2),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
open(unit=1,file=eucrustt5,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%thickness(ila,iln,3),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (thickness(ila,iln,3),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
open(unit=1,file=eucrustt6,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%thickness(ila,iln,4),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (thickness(ila,iln,4),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
open(unit=1,file=eucrustt7,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%thickness(ila,iln,5),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (thickness(ila,iln,5),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
@@ -217,31 +201,31 @@
open(unit=1,file=eucrustr3,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%density(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (density(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
open(unit=1,file=eucrustr4,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%density(ila,iln,2),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (density(ila,iln,2),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
open(unit=1,file=eucrustr5,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%density(ila,iln,3),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (density(ila,iln,3),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
open(unit=1,file=eucrustr6,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%density(ila,iln,4),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (density(ila,iln,4),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
open(unit=1,file=eucrustr7,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%density(ila,iln,5),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (density(ila,iln,5),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
@@ -249,31 +233,31 @@
open(unit=1,file=eucrustp3,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocp(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (velocp(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
open(unit=1,file=eucrustp4,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocp(ila,iln,2),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (velocp(ila,iln,2),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
open(unit=1,file=eucrustp5,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocp(ila,iln,3),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (velocp(ila,iln,3),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
open(unit=1,file=eucrustp6,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocp(ila,iln,4),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (velocp(ila,iln,4),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
open(unit=1,file=eucrustp7,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocp(ila,iln,5),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (velocp(ila,iln,5),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
@@ -281,65 +265,65 @@
open(unit=1,file=eucrusts3,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocs(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (velocs(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
open(unit=1,file=eucrusts4,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocs(ila,iln,2),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (velocs(ila,iln,2),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
open(unit=1,file=eucrusts5,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocs(ila,iln,3),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (velocs(ila,iln,3),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
open(unit=1,file=eucrusts6,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocs(ila,iln,4),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (velocs(ila,iln,4),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
open(unit=1,file=eucrusts7,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
- read(1,*) (GC_V%velocs(ila,iln,5),iln=1,360*CRUSTMAP_RESOLUTION)
+ read(1,*) (velocs(ila,iln,5),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
- GC_V%thicknessnp(:) = 0.0
- GC_V%thicknesssp(:) = 0.0
- GC_V%densitynp(:) = 0.0
- GC_V%densitysp(:) = 0.0
- GC_V%velocpnp(:) = 0.0
- GC_V%velocpsp(:) = 0.0
- GC_V%velocsnp(:) = 0.0
- GC_V%velocssp(:) = 0.0
+ thicknessnp(:) = ZERO
+ thicknesssp(:) = ZERO
+ densitynp(:) = ZERO
+ densitysp(:) = ZERO
+ velocpnp(:) = ZERO
+ velocpsp(:) = ZERO
+ velocsnp(:) = ZERO
+ velocssp(:) = ZERO
!compute average values for north and southpole
do l=1,NLAYERS_CRUSTMAP
do i=1,360*CRUSTMAP_RESOLUTION
- GC_V%thicknessnp(l) = GC_V%thicknessnp(l)+GC_V%thickness(1,i,l)
- GC_V%thicknesssp(l) = GC_V%thicknesssp(l)+GC_V%thickness(180*CRUSTMAP_RESOLUTION,i,l)
- GC_V%densitynp(l) = GC_V%densitynp(l)+GC_V%density(1,i,l)
- GC_V%densitysp(l) = GC_V%densitysp(l)+GC_V%density(180*CRUSTMAP_RESOLUTION,i,l)
- GC_V%velocpnp(l) = GC_V%velocpnp(l)+GC_V%velocp(1,i,l)
- GC_V%velocpsp(l) = GC_V%velocpsp(l)+GC_V%velocp(180*CRUSTMAP_RESOLUTION,i,l)
- GC_V%velocsnp(l) = GC_V%velocsnp(l)+GC_V%velocs(1,i,l)
- GC_V%velocssp(l) = GC_V%velocssp(l)+GC_V%velocs(180*CRUSTMAP_RESOLUTION,i,l)
+ thicknessnp(l) = thicknessnp(l)+thickness(1,i,l)
+ thicknesssp(l) = thicknesssp(l)+thickness(180*CRUSTMAP_RESOLUTION,i,l)
+ densitynp(l) = densitynp(l)+density(1,i,l)
+ densitysp(l) = densitysp(l)+density(180*CRUSTMAP_RESOLUTION,i,l)
+ velocpnp(l) = velocpnp(l)+velocp(1,i,l)
+ velocpsp(l) = velocpsp(l)+velocp(180*CRUSTMAP_RESOLUTION,i,l)
+ velocsnp(l) = velocsnp(l)+velocs(1,i,l)
+ velocssp(l) = velocssp(l)+velocs(180*CRUSTMAP_RESOLUTION,i,l)
enddo
- GC_V%thicknessnp(l) = GC_V%thicknessnp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
- GC_V%thicknesssp(l) = GC_V%thicknesssp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
- GC_V%densitynp(l) = GC_V%densitynp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
- GC_V%densitysp(l) = GC_V%densitysp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
- GC_V%velocpnp(l) = GC_V%velocpnp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
- GC_V%velocpsp(l) = GC_V%velocpsp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
- GC_V%velocsnp(l) = GC_V%velocsnp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
- GC_V%velocssp(l) = GC_V%velocssp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
+ thicknessnp(l) = thicknessnp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
+ thicknesssp(l) = thicknesssp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
+ densitynp(l) = densitynp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
+ densitysp(l) = densitysp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
+ velocpnp(l) = velocpnp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
+ velocpsp(l) = velocpsp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
+ velocsnp(l) = velocsnp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
+ velocssp(l) = velocssp(l)/360.0/dble(CRUSTMAP_RESOLUTION)
-! print *,'thicknessnp(',l,')',GC_V%thicknessnp(l)
+! print *,'thicknessnp(',l,')',thicknessnp(l)
enddo
@@ -349,51 +333,26 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine model_crustmaps(lat,lon,x,vp,vs,rho,moho,found_crust,GC_V,elem_in_crust)
+ subroutine model_crustmaps(lat,lon,x,vp,vs,rho,moho,found_crust,elem_in_crust)
! Matthias Meschede
! read smooth crust2.0 model (0.25 degree resolution) with eucrust
! based on software routines provided with the crust2.0 model by Bassin et al.
!
+ use model_crustmaps_par
+
implicit none
include "constants.h"
-!Matthias Meschede
- !model_crustmaps_variables
- type model_crustmaps_variables
- sequence
- double precision, dimension(180*CRUSTMAP_RESOLUTION,&
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: thickness
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: density
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocp
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocs
+ double precision :: lat,lon,x,vp,vs,rho,moho
+ logical :: found_crust,elem_in_crust
+ double precision :: h_sed,h_uc
+ double precision :: x3,x4,x5,x6,x7,scaleval
+ double precision,dimension(NLAYERS_CRUSTMAP) :: vps,vss,rhos,thicks
- double precision thicknessnp(NLAYERS_CRUSTMAP)
- double precision densitynp(NLAYERS_CRUSTMAP)
- double precision velocpnp(NLAYERS_CRUSTMAP)
- double precision velocsnp(NLAYERS_CRUSTMAP)
- double precision thicknesssp(NLAYERS_CRUSTMAP)
- double precision densitysp(NLAYERS_CRUSTMAP)
- double precision velocpsp(NLAYERS_CRUSTMAP)
- double precision velocssp(NLAYERS_CRUSTMAP)
+ call read_crustmaps(lat,lon,vps,vss,rhos,thicks)
- end type model_crustmaps_variables
- type (model_crustmaps_variables) GC_V
- !model_crustmaps_variables
-
-
- double precision lat,lon,x,vp,vs,rho,moho
- logical found_crust,elem_in_crust
- double precision h_sed,h_uc
- double precision x3,x4,x5,x6,x7,scaleval
- double precision vps(NLAYERS_CRUSTMAP),vss(NLAYERS_CRUSTMAP),rhos(NLAYERS_CRUSTMAP),thicks(NLAYERS_CRUSTMAP)
-
- call read_crustmaps(lat,lon,vps,vss,rhos,thicks,GC_V)
-
x3 = (R_EARTH-thicks(1)*1000.0d0)/R_EARTH
h_sed = thicks(1) + thicks(2)
x4 = (R_EARTH-h_sed*1000.0d0)/R_EARTH
@@ -454,43 +413,21 @@
!
- subroutine read_crustmaps(lat,lon,velp,vels,rhos,thicks,GC_V)
+ subroutine read_crustmaps(lat,lon,velp,vels,rhos,thicks)
! crustal vp and vs in km/s, layer thickness in km
+ use model_crustmaps_par
+
implicit none
+
include "constants.h"
-! argument variables
+ ! argument variables
double precision lat,lon
double precision rhos(5),thicks(5),velp(5),vels(5)
-!Matthias Meschede
- !model_crustmaps_variables
- type model_crustmaps_variables
- sequence
- double precision, dimension(180*CRUSTMAP_RESOLUTION,&
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: thickness
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: density
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocp
- double precision, dimension(180*CRUSTMAP_RESOLUTION, &
- 360*CRUSTMAP_RESOLUTION,NLAYERS_CRUSTMAP) :: velocs
- double precision thicknessnp(NLAYERS_CRUSTMAP)
- double precision densitynp(NLAYERS_CRUSTMAP)
- double precision velocpnp(NLAYERS_CRUSTMAP)
- double precision velocsnp(NLAYERS_CRUSTMAP)
- double precision thicknesssp(NLAYERS_CRUSTMAP)
- double precision densitysp(NLAYERS_CRUSTMAP)
- double precision velocpsp(NLAYERS_CRUSTMAP)
- double precision velocssp(NLAYERS_CRUSTMAP)
-
- end type model_crustmaps_variables
- type (model_crustmaps_variables) GC_V
- !model_crustmaps_variables
-
!-------------------------------
! work-around to avoid jacobian problems when stretching mesh elements;
! one could also try to slightly change the shape of the doulbing element bricks (which cause the problem)...
@@ -616,38 +553,38 @@
if(iupcolat==0) then
! north pole
do i=1,NLAYERS_CRUSTMAP
- thickl(i)=weightul*GC_V%thicknessnp(i)+weightur*GC_V%thicknessnp(i)+&
- weightll*GC_V%thickness(1,ileftlng,i)+weightlr*GC_V%thickness(1,irightlng,i)
+ thickl(i)=weightul*thicknessnp(i)+weightur*thicknessnp(i)+&
+ weightll*thickness(1,ileftlng,i)+weightlr*thickness(1,irightlng,i)
- rhol(i)=weightul*GC_V%densitynp(i)+weightur*GC_V%densitynp(i)+&
- weightll*GC_V%density(1,ileftlng,i)+weightlr*GC_V%density(1,irightlng,i)
- velpl(i)=weightul*GC_V%velocpnp(i)+weightur*GC_V%velocpnp(i)+&
- weightll*GC_V%velocp(1,ileftlng,i)+weightlr*GC_V%velocp(1,irightlng,i)
- velsl(i)=weightul*GC_V%velocsnp(i)+weightur*GC_V%velocsnp(i)+&
- weightll*GC_V%velocs(1,ileftlng,i)+weightlr*GC_V%velocs(1,irightlng,i)
+ rhol(i)=weightul*densitynp(i)+weightur*densitynp(i)+&
+ weightll*density(1,ileftlng,i)+weightlr*density(1,irightlng,i)
+ velpl(i)=weightul*velocpnp(i)+weightur*velocpnp(i)+&
+ weightll*velocp(1,ileftlng,i)+weightlr*velocp(1,irightlng,i)
+ velsl(i)=weightul*velocsnp(i)+weightur*velocsnp(i)+&
+ weightll*velocs(1,ileftlng,i)+weightlr*velocs(1,irightlng,i)
enddo
elseif(iupcolat==180*CRUSTMAP_RESOLUTION) then
! south pole
do i=1,NLAYERS_CRUSTMAP
- thickl(i)=weightul*GC_V%thickness(iupcolat,ileftlng,i)+weightur*GC_V%thickness(iupcolat,irightlng,i)+&
- weightll*GC_V%thicknesssp(i)+weightlr*GC_V%thicknesssp(i)
- rhol(i)=weightul*GC_V%density(iupcolat,ileftlng,i)+weightur*GC_V%density(iupcolat,irightlng,i)+&
- weightll*GC_V%densitysp(i)+weightlr*GC_V%densitysp(i)
- velpl(i)=weightul*GC_V%velocp(iupcolat,ileftlng,i)+weightur*GC_V%velocp(iupcolat,irightlng,i)+&
- weightll*GC_V%velocpsp(i)+weightlr*GC_V%velocpsp(i)
- velsl(i)=weightul*GC_V%velocs(iupcolat,ileftlng,i)+weightur*GC_V%velocs(iupcolat,irightlng,i)+&
- weightll*GC_V%velocssp(i)+weightlr*GC_V%velocssp(i)
+ thickl(i)=weightul*thickness(iupcolat,ileftlng,i)+weightur*thickness(iupcolat,irightlng,i)+&
+ weightll*thicknesssp(i)+weightlr*thicknesssp(i)
+ rhol(i)=weightul*density(iupcolat,ileftlng,i)+weightur*density(iupcolat,irightlng,i)+&
+ weightll*densitysp(i)+weightlr*densitysp(i)
+ velpl(i)=weightul*velocp(iupcolat,ileftlng,i)+weightur*velocp(iupcolat,irightlng,i)+&
+ weightll*velocpsp(i)+weightlr*velocpsp(i)
+ velsl(i)=weightul*velocs(iupcolat,ileftlng,i)+weightur*velocs(iupcolat,irightlng,i)+&
+ weightll*velocssp(i)+weightlr*velocssp(i)
enddo
else
do i=1,NLAYERS_CRUSTMAP
- thickl(i)=weightul*GC_V%thickness(iupcolat,ileftlng,i)+weightur*GC_V%thickness(iupcolat,irightlng,i)+&
- weightll*GC_V%thickness(iupcolat+1,ileftlng,i)+weightlr*GC_V%thickness(iupcolat+1,irightlng,i)
- rhol(i)=weightul*GC_V%density(iupcolat,ileftlng,i)+weightur*GC_V%density(iupcolat,irightlng,i)+&
- weightll*GC_V%density(iupcolat+1,ileftlng,i)+weightlr*GC_V%density(iupcolat+1,irightlng,i)
- velpl(i)=weightul*GC_V%velocp(iupcolat,ileftlng,i)+weightur*GC_V%velocp(iupcolat,irightlng,i)+&
- weightll*GC_V%velocp(iupcolat+1,ileftlng,i)+weightlr*GC_V%velocp(iupcolat+1,irightlng,i)
- velsl(i)=weightul*GC_V%velocs(iupcolat,ileftlng,i)+weightur*GC_V%velocs(iupcolat,irightlng,i)+&
- weightll*GC_V%velocs(iupcolat+1,ileftlng,i)+weightlr*GC_V%velocs(iupcolat+1,irightlng,i)
+ thickl(i)=weightul*thickness(iupcolat,ileftlng,i)+weightur*thickness(iupcolat,irightlng,i)+&
+ weightll*thickness(iupcolat+1,ileftlng,i)+weightlr*thickness(iupcolat+1,irightlng,i)
+ rhol(i)=weightul*density(iupcolat,ileftlng,i)+weightur*density(iupcolat,irightlng,i)+&
+ weightll*density(iupcolat+1,ileftlng,i)+weightlr*density(iupcolat+1,irightlng,i)
+ velpl(i)=weightul*velocp(iupcolat,ileftlng,i)+weightur*velocp(iupcolat,irightlng,i)+&
+ weightll*velocp(iupcolat+1,ileftlng,i)+weightlr*velocp(iupcolat+1,irightlng,i)
+ velsl(i)=weightul*velocs(iupcolat,ileftlng,i)+weightur*velocs(iupcolat,irightlng,i)+&
+ weightll*velocs(iupcolat+1,ileftlng,i)+weightlr*velocs(iupcolat+1,irightlng,i)
! thicks(i)=1.0
! rhos(i)=1.0
! velp(i)=1.0
@@ -681,11 +618,13 @@
subroutine ibilinearmap(lat,lng,iupcolat,ileftlng,weightup,weightleft)
+ use model_crustmaps_par,only: CRUSTMAP_RESOLUTION
+
implicit none
+
include "constants.h"
-
-! argument variables
+ ! argument variables
double precision weightup,weightleft
double precision lat,lng, xlng
double precision buffer
@@ -716,42 +655,5 @@
if(ileftlng<1) ileftlng=360*CRUSTMAP_RESOLUTION
if(ileftlng>360*CRUSTMAP_RESOLUTION) ileftlng=1
-
-
end subroutine ibilinearmap
-!
-!-------------------------------------------------------------------------------------------------
-!
-!
-! subroutine ilatlng(lat,lng,icolat,ilng)
-!
-! implicit none
-! include "constants.h"
-!
-!
-! ! argument variables
-! double precision lat,lng, xlng
-! integer icolat,ilng
-!
-! if(lat > 90.0d0 .or. lat < -90.0d0 .or. lng > 180.0d0 .or. lng < -180.0d0) &
-! stop 'error in latitude/longitude range in icolat_ilon'
-!
-! if(lng<0) then
-! xlng=lng+360.0
-! else
-! xlng=lng
-! endif
-!
-! icolat=int(1+((90.0-lat)*CRUSTMAP_RESOLUTION))
-! ! icolat=10
-! if(icolat == 180*CRUSTMAP_RESOLUTION+1) icolat=180*CRUSTMAP_RESOLUTION
-! ilng=int(1+(xlng*CRUSTMAP_RESOLUTION))
-! ! ilng=10
-! if(ilng == 360*CRUSTMAP_RESOLUTION+1) ilng=360*CRUSTMAP_RESOLUTION
-!
-! if(icolat>180*CRUSTMAP_RESOLUTION .or. icolat<1) stop 'error in routine icolat_ilon'
-! if(ilng<1 .or. ilng>360*CRUSTMAP_RESOLUTION) stop 'error in routine icolat_ilon'
-!
-! end subroutine ilatlng
-
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_epcrust.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_epcrust.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_epcrust.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -32,43 +32,74 @@
! GJI, 185 (1), pages 352-364
!--------------------------------------------------------------------------------------------------
+ module model_epcrust_par
- subroutine model_epcrust_broadcast(myrank,EPCRUST)
+ ! parameters for EPCRUST , from Molinari & Morelli model(2011)
+ ! latitude : 9.0N - 89.5N
+ ! longitude: 56.0W - 70.0E
+ character(len=*), parameter :: PATHNAME_EPCRUST = 'DATA/epcrust/EPcrust_0_5.txt'
+ integer, parameter :: EPCRUST_NLON = 253, EPCRUST_NLAT = 162, EPCRUST_NLAYER = 3
+ double precision, parameter :: EPCRUST_LON_MIN = -56.0d0
+ double precision, parameter :: EPCRUST_LON_MAX = 70.0d0
+ double precision, parameter :: EPCRUST_LAT_MIN = 9.0d0
+ double precision, parameter :: EPCRUST_LAT_MAX = 89.5d0
+ double precision, parameter :: EPCRUST_SAMPLE = 0.5d0
+ logical, parameter :: flag_smooth_epcrust = .true.
+ integer, parameter :: NTHETA_EP = 4, NPHI_EP = 20
+ double precision, parameter :: cap_degree_EP = 0.2d0
+
+ ! arrays for EPCRUST 1.0
+ double precision,dimension(:,:),allocatable :: lon_ep,lat_ep,topo_ep
+ double precision,dimension(:,:,:),allocatable :: thickness_ep,vp_ep,vs_ep,rho_ep
+
+ end module model_epcrust_par
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine model_epcrust_broadcast(myrank)
+
+ use model_epcrust_par
+
implicit none
include "constants.h"
include 'mpif.h'
- type model_epcrust_variables
- sequence
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT):: lon_ep,lat_ep,topo_ep
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER):: thickness_ep
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER):: vp_ep
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER):: vs_ep
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER):: rho_ep
- end type model_epcrust_variables
- type (model_epcrust_variables) EPCRUST
- integer:: myrank,ierr
+ integer:: myrank,ier
+ ! allocates arrays for model
+ allocate(lon_ep(EPCRUST_NLON,EPCRUST_NLAT), &
+ lat_ep(EPCRUST_NLON,EPCRUST_NLAT), &
+ topo_ep(EPCRUST_NLON,EPCRUST_NLAT), &
+ thickness_ep(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER), &
+ vp_ep(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER), &
+ vs_ep(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER), &
+ rho_ep(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER), &
+ stat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating EPcrust arrays')
+
! read EPCRUST model on master
- if(myrank == 0) call read_epcrust_model(EPCRUST)
+ if(myrank == 0) call read_epcrust_model()
! broadcast EPCRUST model
- call MPI_BCAST(EPCRUST%lon_ep,EPCRUST_NLON*EPCRUST_NLAT, &
- MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
- call MPI_BCAST(EPCRUST%lat_ep,EPCRUST_NLON*EPCRUST_NLAT, &
- MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
- call MPI_BCAST(EPCRUST%topo_ep,EPCRUST_NLON*EPCRUST_NLAT, &
- MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
- call MPI_BCAST(EPCRUST%thickness_ep,EPCRUST_NLON*EPCRUST_NLAT*EPCRUST_NLAYER, &
- MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
- call MPI_BCAST(EPCRUST%vp_ep,EPCRUST_NLON*EPCRUST_NLAT*EPCRUST_NLAYER, &
- MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
- call MPI_BCAST(EPCRUST%vs_ep,EPCRUST_NLON*EPCRUST_NLAT*EPCRUST_NLAYER, &
- MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
- call MPI_BCAST(EPCRUST%rho_ep,EPCRUST_NLON*EPCRUST_NLAT*EPCRUST_NLAYER, &
- MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
+ call MPI_BCAST(lon_ep,EPCRUST_NLON*EPCRUST_NLAT, &
+ MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(lat_ep,EPCRUST_NLON*EPCRUST_NLAT, &
+ MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(topo_ep,EPCRUST_NLON*EPCRUST_NLAT, &
+ MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(thickness_ep,EPCRUST_NLON*EPCRUST_NLAT*EPCRUST_NLAYER, &
+ MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(vp_ep,EPCRUST_NLON*EPCRUST_NLAT*EPCRUST_NLAYER, &
+ MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(vs_ep,EPCRUST_NLON*EPCRUST_NLAT*EPCRUST_NLAYER, &
+ MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(rho_ep,EPCRUST_NLON*EPCRUST_NLAT*EPCRUST_NLAYER, &
+ MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
end subroutine model_epcrust_broadcast
@@ -76,41 +107,37 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine read_epcrust_model(EPCRUST)
+ subroutine read_epcrust_model()
+ use model_epcrust_par
+
implicit none
+
include "constants.h"
- type model_epcrust_variables
- sequence
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT):: lon_ep,lat_ep,topo_ep
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER):: thickness_ep
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER):: vp_ep
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER):: vs_ep
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER):: rho_ep
- end type model_epcrust_variables
- type (model_epcrust_variables) EPCRUST
-
character(len=150) EPCRUST_FNM
character(len=150),dimension(15) :: header
double precision,dimension(15) :: tmp
- integer:: ilon, jlat
+ integer:: ilon, jlat,ier
call get_value_string(EPCRUST_FNM,'model.EPCRUST_FNM',PATHNAME_EPCRUST)
- open(unit=1001,file=EPCRUST_FNM,status='old',action='read')
+
+ open(unit=1001,file=trim(EPCRUST_FNM),status='old',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(0,'error opening file for EPcrust')
+
read(1001,*) header
do jlat = 1,EPCRUST_NLAT
do ilon=1,EPCRUST_NLON
read(1001,*) tmp
- EPCRUST%lon_ep(ilon,jlat) = tmp(1)
- EPCRUST%lat_ep(ilon,jlat) = tmp(2)
- EPCRUST%topo_ep(ilon,jlat) = tmp(3)
- EPCRUST%thickness_ep(ilon,jlat,1:3) = tmp(4:6)
- EPCRUST%vp_ep(ilon,jlat,1:3) = tmp(7:9)
- EPCRUST%vs_ep(ilon,jlat,1:3) = tmp(10:12)
- EPCRUST%rho_ep(ilon,jlat,1:3) = tmp(13:15)
+ lon_ep(ilon,jlat) = tmp(1)
+ lat_ep(ilon,jlat) = tmp(2)
+ topo_ep(ilon,jlat) = tmp(3)
+ thickness_ep(ilon,jlat,1:3) = tmp(4:6)
+ vp_ep(ilon,jlat,1:3) = tmp(7:9)
+ vs_ep(ilon,jlat,1:3) = tmp(10:12)
+ rho_ep(ilon,jlat,1:3) = tmp(13:15)
end do
end do
close(1001)
@@ -121,21 +148,15 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine model_epcrust(lat,lon,dep,vp,vs,rho,moho,found_crust,EPCRUST,elem_in_crust)
+ subroutine model_epcrust(lat,lon,dep,vp,vs,rho,moho,found_crust,elem_in_crust)
+
+ use model_epcrust_par
+
implicit none
+
include "constants.h"
! INPUT & OUTPUT
- type model_epcrust_variables
- sequence
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT):: lon_ep,lat_ep,topo_ep
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER):: thickness_ep
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER):: vp_ep
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER):: vs_ep
- double precision,dimension(EPCRUST_NLON,EPCRUST_NLAT,EPCRUST_NLAYER):: rho_ep
- end type model_epcrust_variables
- type (model_epcrust_variables) EPCRUST
-
double precision:: lat, lon, dep, vp, vs, rho, moho
logical :: found_crust, elem_in_crust
@@ -152,34 +173,34 @@
! stop 'incorrect enter EPCRUST model, check lat and lon'
!end if
- vp=0.0d0
- vs=0.0d0
- rho=0.0d0
+ vp = ZERO
+ vs = ZERO
+ rho = ZERO
if ( .not. flag_smooth_epcrust) then
call ilon_jlat(lon,lat,ilon,jlat)
- z0=EPCRUST%topo_ep(ilon,jlat)
- zsmooth(:)=EPCRUST%thickness_ep(ilon,jlat,:)
- vpsmooth(:)=EPCRUST%vp_ep(ilon,jlat,:)
- vssmooth(:)=EPCRUST%vs_ep(ilon,jlat,:)
- rhosmooth(:)=EPCRUST%rho_ep(ilon,jlat,:)
+ z0 = topo_ep(ilon,jlat)
+ zsmooth(:) = thickness_ep(ilon,jlat,:)
+ vpsmooth(:) = vp_ep(ilon,jlat,:)
+ vssmooth(:) = vs_ep(ilon,jlat,:)
+ rhosmooth(:) = rho_ep(ilon,jlat,:)
else
call epcrust_smooth_base(lon,lat,x1,y1,weight)
- z0=0.d0
- zsmooth(:)=0.0d0
- vpsmooth(:)=0.0d0
- vssmooth(:)=0.0d0
- rhosmooth(:)=0.0d0
+ z0 = ZERO
+ zsmooth(:) = ZERO
+ vpsmooth(:) = ZERO
+ vssmooth(:) = ZERO
+ rhosmooth(:) = ZERO
do k = 1,NTHETA_EP*NPHI_EP
call ilon_jlat(x1(k),y1(k),ilon,jlat)
weightl=weight(k)
- z0=z0+weightl*EPCRUST%topo_ep(ilon,jlat)
- zsmooth(:)=zsmooth(:)+weightl*EPCRUST%thickness_ep(ilon,jlat,:)
- vpsmooth(:)=vpsmooth(:)+weightl*EPCRUST%vp_ep(ilon,jlat,:)
- vssmooth(:)=vssmooth(:)+weightl*EPCRUST%vs_ep(ilon,jlat,:)
- rhosmooth(:)=rhosmooth(:)+weightl*EPCRUST%rho_ep(ilon,jlat,:)
+ z0=z0+weightl*topo_ep(ilon,jlat)
+ zsmooth(:)=zsmooth(:)+weightl*thickness_ep(ilon,jlat,:)
+ vpsmooth(:)=vpsmooth(:)+weightl*vp_ep(ilon,jlat,:)
+ vssmooth(:)=vssmooth(:)+weightl*vs_ep(ilon,jlat,:)
+ rhosmooth(:)=rhosmooth(:)+weightl*rho_ep(ilon,jlat,:)
end do
end if
@@ -238,6 +259,8 @@
subroutine epcrust_smooth_base(x,y,x1,y1,weight)
+ use model_epcrust_par,only: NTHETA_EP,NPHI_EP,cap_degree_EP
+
implicit none
include "constants.h"
@@ -252,12 +275,10 @@
double precision,dimension(3,3):: rotation_matrix
double precision,dimension(3):: xx,xc
integer:: i,j,k,itheta,iphi
- double precision:: RADIANS_TO_DEGREES = 180.d0/PI
- double precision:: PI_OVER_TWO = PI/2.0d0
- x1(:)=0.0d0
- y1(:)=0.0d0
- weight(:)=0.0d0
+ x1(:)=ZERO
+ y1(:)=ZERO
+ weight(:)=ZERO
if (cap_degree_EP < TINYVAL ) then
print*, 'error cap:', cap_degree_EP
@@ -265,9 +286,10 @@
stop 'error cap_degree too small'
end if
- CAP=cap_degree_EP*PI/180.0d0
+ CAP=cap_degree_EP * DEGREES_TO_RADIANS
dtheta=0.5d0*CAP/dble(NTHETA_EP)
dphi=TWO_PI/dble(NPHI_EP)
+
cap_area=TWO_PI*(1.0d0-dcos(CAP))
dweight=CAP/dble(NTHETA_EP)*dphi/cap_area
pi_over_nphi=PI/dble(NPHI_EP)
@@ -287,7 +309,7 @@
rotation_matrix(2,2)=cosp
rotation_matrix(2,3)=sinp*sint
rotation_matrix(3,1)=-sint
- rotation_matrix(3,2)=0.0d0
+ rotation_matrix(3,2)=ZERO
rotation_matrix(3,3)=cost
i=0
@@ -336,7 +358,12 @@
subroutine ilon_jlat(lon,lat,ilon,jlat)
+ use model_epcrust_par,only: &
+ EPCRUST_LON_MIN,EPCRUST_LAT_MAX,EPCRUST_SAMPLE, &
+ EPCRUST_NLON,EPCRUST_NLAT
+
implicit none
+
include "constants.h"
double precision:: lon,lat
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_eucrust.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_eucrust.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_eucrust.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -33,96 +33,104 @@
! Geophysical Research Letters, 35: p. L05313.208
!--------------------------------------------------------------------------------------------------
- subroutine model_eucrust_broadcast(myrank,EUCM_V)
+ module model_eucrust_par
+ ! EUcrust
+ double precision, dimension(:),allocatable :: eucrust_lat,eucrust_lon,&
+ eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
+ eucrust_basement,eucrust_ucdepth
+ integer :: num_eucrust
+
+ end module model_eucrust_par
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ subroutine model_eucrust_broadcast(myrank)
+
! standard routine to setup model
+ use model_eucrust_par
+
implicit none
include "constants.h"
- ! standard include of the MPI library
include 'mpif.h'
- ! EUcrust
- type model_eucrust_variables
- sequence
- double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
- eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
- eucrust_basement,eucrust_ucdepth
- integer :: num_eucrust
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_eucrust_variables
- type (model_eucrust_variables) EUCM_V
-
integer :: myrank
integer :: ier
! EUcrust07 Vp crustal structure
- if( myrank == 0 ) call read_EuCrust(EUCM_V)
+ if( myrank == 0 ) call read_EuCrust()
! broadcast the information read on the master to the nodes
- call MPI_BCAST(EUCM_V%num_eucrust,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(num_eucrust,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ ! allocates on all other processes
if( myrank /= 0 ) then
- allocate(EUCM_V%eucrust_vp_uppercrust(EUCM_V%num_eucrust),EUCM_V%eucrust_vp_lowercrust(EUCM_V%num_eucrust),&
- EUCM_V%eucrust_mohodepth(EUCM_V%num_eucrust),EUCM_V%eucrust_basement(EUCM_V%num_eucrust),&
- EUCM_V%eucrust_ucdepth(EUCM_V%num_eucrust), EUCM_V%eucrust_lon(EUCM_V%num_eucrust),&
- EUCM_V%eucrust_lat(EUCM_V%num_eucrust))
+ allocate(eucrust_vp_uppercrust(num_eucrust), &
+ eucrust_vp_lowercrust(num_eucrust),&
+ eucrust_mohodepth(num_eucrust), &
+ eucrust_basement(num_eucrust),&
+ eucrust_ucdepth(num_eucrust), &
+ eucrust_lon(num_eucrust),&
+ eucrust_lat(num_eucrust), &
+ stat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating EUcrust arrays')
endif
- call MPI_BCAST(EUCM_V%eucrust_lat(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(EUCM_V%eucrust_lon(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(EUCM_V%eucrust_vp_uppercrust(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(EUCM_V%eucrust_vp_lowercrust(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(EUCM_V%eucrust_mohodepth(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(EUCM_V%eucrust_basement(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(EUCM_V%eucrust_ucdepth(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(eucrust_lat(1:num_eucrust),num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(eucrust_lon(1:num_eucrust),num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(eucrust_vp_uppercrust(1:num_eucrust),num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(eucrust_vp_lowercrust(1:num_eucrust),num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(eucrust_mohodepth(1:num_eucrust),num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(eucrust_basement(1:num_eucrust),num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(eucrust_ucdepth(1:num_eucrust),num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
end subroutine model_eucrust_broadcast
!----------------------------------------------------------------------------------------------------
- subroutine read_EuCrust(EUCM_V)
+ subroutine read_EuCrust()
+ use model_eucrust_par
+
implicit none
include "constants.h"
- type model_eucrust_variables
- sequence
- double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
- eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
- eucrust_basement,eucrust_ucdepth
- integer :: num_eucrust
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_eucrust_variables
- type (model_eucrust_variables) EUCM_V
-
-
! local variables
character(len=80):: line
character(len=150):: filename
- integer:: i,ierror
+ integer:: i,ier
double precision:: vp_uppercrust,vp_lowercrust,vp_avg,topo,basement
double precision:: upper_lower_depth,moho_depth,lat,lon
! original file size entries
- EUCM_V%num_eucrust = 36058
+ num_eucrust = 36058
- allocate(EUCM_V%eucrust_vp_uppercrust(EUCM_V%num_eucrust),EUCM_V%eucrust_vp_lowercrust(EUCM_V%num_eucrust),&
- EUCM_V%eucrust_mohodepth(EUCM_V%num_eucrust),EUCM_V%eucrust_basement(EUCM_V%num_eucrust),&
- EUCM_V%eucrust_ucdepth(EUCM_V%num_eucrust), EUCM_V%eucrust_lon(EUCM_V%num_eucrust),&
- EUCM_V%eucrust_lat(EUCM_V%num_eucrust))
+ ! only on master we allocate these arrays here
+ allocate(eucrust_vp_uppercrust(num_eucrust), &
+ eucrust_vp_lowercrust(num_eucrust),&
+ eucrust_mohodepth(num_eucrust), &
+ eucrust_basement(num_eucrust),&
+ eucrust_ucdepth(num_eucrust), &
+ eucrust_lon(num_eucrust),&
+ eucrust_lat(num_eucrust), &
+ stat=ier)
+ if( ier /= 0 ) call exit_MPI(0,'error allocating EUcrust arrays on master')
- EUCM_V%eucrust_vp_uppercrust(:) = 0.0
- EUCM_V%eucrust_vp_lowercrust(:) = 0.0
- EUCM_V%eucrust_mohodepth(:) = 0.0
- EUCM_V%eucrust_basement(:) = 0.0
- EUCM_V%eucrust_ucdepth(:) = 0.0
+ eucrust_vp_uppercrust(:) = ZERO
+ eucrust_vp_lowercrust(:) = ZERO
+ eucrust_mohodepth(:) = ZERO
+ eucrust_basement(:) = ZERO
+ eucrust_ucdepth(:) = ZERO
! opens data file
call get_value_string(filename, 'model.eu', 'DATA/eucrust-07/ds01.txt')
- open(unit=11,file=filename,status='old',action='read')
+ open(unit=11,file=filename,status='old',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(0,'error opening EUcrust file')
! skip first line
read(11,*)
@@ -130,19 +138,19 @@
! data
do i=1,36058
- read(11,'(a80)',iostat=ierror) line
- if(ierror .ne. 0 ) stop
+ read(11,'(a80)',iostat=ier) line
+ if( ier /= 0 ) stop 'error reading EUcrust file'
read(line,*)lon,lat,vp_uppercrust,vp_lowercrust,vp_avg,topo,basement,upper_lower_depth,moho_depth
! stores moho values
- EUCM_V%eucrust_lon(i) = lon
- EUCM_V%eucrust_lat(i) = lat
- EUCM_V%eucrust_vp_uppercrust(i) = vp_uppercrust
- EUCM_V%eucrust_vp_lowercrust(i) = vp_lowercrust
- EUCM_V%eucrust_mohodepth(i) = moho_depth
- EUCM_V%eucrust_basement(i) = basement
- EUCM_V%eucrust_ucdepth(i) = upper_lower_depth
+ eucrust_lon(i) = lon
+ eucrust_lat(i) = lat
+ eucrust_vp_uppercrust(i) = vp_uppercrust
+ eucrust_vp_lowercrust(i) = vp_lowercrust
+ eucrust_mohodepth(i) = moho_depth
+ eucrust_basement(i) = basement
+ eucrust_ucdepth(i) = upper_lower_depth
enddo
close(11)
@@ -153,20 +161,12 @@
!--------------------------------------------------------------------------------------------------
!
- subroutine model_eucrust(lat,lon,x,vp,found_crust,EUCM_V)
+ subroutine model_eucrust(lat,lon,x,vp,found_crust)
+ use model_eucrust_par
+
implicit none
- type model_eucrust_variables
- sequence
- double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
- eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
- eucrust_basement,eucrust_ucdepth
- integer :: num_eucrust
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_eucrust_variables
- type (model_eucrust_variables) EUCM_V
-
double precision :: lat,lon,x,vp
logical :: found_crust
double precision :: lon_min,lon_max,lat_min,lat_max
@@ -187,10 +187,10 @@
if( lat < lat_min .or. lat > lat_max ) return
! smoothing over 1.0 degrees
- call eu_cap_smoothing(lat,lon,x,vp,found_crust,EUCM_V)
+ call eu_cap_smoothing(lat,lon,x,vp,found_crust)
! without smoothing
- !vp = crust_eu(lat,lon,x,vp,found_crust,EUCM_V)
+ !vp = crust_eu(lat,lon,x,vp,found_crust)
end subroutine model_eucrust
@@ -198,24 +198,16 @@
!--------------------------------------------------------------------------------------------------
!
- double precision function crust_eu(lat,lon,x,vp,found_crust,EUCM_V)
+ double precision function crust_eu(lat,lon,x,vp,found_crust)
! returns Vp at the specific location lat/lon
+ use model_eucrust_par
+
implicit none
include "constants.h"
- type model_eucrust_variables
- sequence
- double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
- eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
- eucrust_basement,eucrust_ucdepth
- integer :: num_eucrust
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_eucrust_variables
- type (model_eucrust_variables) EUCM_V
-
double precision :: lat,lon,x,vp !,vs,rho,moho
logical :: found_crust
@@ -241,13 +233,13 @@
! search
do i=1,ilons-1
- if( lon >= EUCM_V%eucrust_lon(i) .and. lon < EUCM_V%eucrust_lon(i+1) ) then
+ if( lon >= eucrust_lon(i) .and. lon < eucrust_lon(i+1) ) then
do j=0,ilats-1
- if(lat>=EUCM_V%eucrust_lat(i+j*ilons) .and. lat<EUCM_V%eucrust_lat(i+(j+1)*ilons)) then
+ if(lat>=eucrust_lat(i+j*ilons) .and. lat<eucrust_lat(i+(j+1)*ilons)) then
- h_basement = EUCM_V%eucrust_basement(i+j*ilons)
- h_uc = EUCM_V%eucrust_ucdepth(i+j*ilons)
- h_moho = EUCM_V%eucrust_mohodepth(i+j*ilons)
+ h_basement = eucrust_basement(i+j*ilons)
+ h_uc = eucrust_ucdepth(i+j*ilons)
+ h_moho = eucrust_mohodepth(i+j*ilons)
x3=(R_EARTH - h_basement*1000.0d0)/R_EARTH
x4=(R_EARTH - h_uc*1000.0d0)/R_EARTH
@@ -260,17 +252,17 @@
! above sediment basement, returns average upper crust value
! since no special sediment values are given
found_crust = .true.
- vp = EUCM_V%eucrust_vp_uppercrust(i+j*ilons) *1000.0d0/(R_EARTH*scaleval)
+ vp = eucrust_vp_uppercrust(i+j*ilons) *1000.0d0/(R_EARTH*scaleval)
crust_eu = vp
return
else if( x > x4 ) then
found_crust = .true.
- vp = EUCM_V%eucrust_vp_uppercrust(i+j*ilons) *1000.0d0/(R_EARTH*scaleval)
+ vp = eucrust_vp_uppercrust(i+j*ilons) *1000.0d0/(R_EARTH*scaleval)
crust_eu = vp
return
else if( x > x5 ) then
found_crust = .true.
- vp = EUCM_V%eucrust_vp_lowercrust(i+j*ilons) *1000.0d0/(R_EARTH*scaleval)
+ vp = eucrust_vp_lowercrust(i+j*ilons) *1000.0d0/(R_EARTH*scaleval)
crust_eu = vp
return
endif
@@ -285,14 +277,17 @@
!
!--------------------------------------------------------------------------------------------------
!
- subroutine eu_cap_smoothing(lat,lon,radius,value,found,EUCM_V)
+ subroutine eu_cap_smoothing(lat,lon,radius,value,found)
! smooths with a cap of size CAP (in degrees)
! using NTHETA points in the theta direction (latitudal)
! and NPHI in the phi direction (longitudal).
! The cap is rotated to the North Pole.
+ use model_eucrust_par
+
implicit none
+
include "constants.h"
! argument variables
@@ -300,19 +295,9 @@
double precision :: value
logical :: found
- type model_eucrust_variables
- sequence
- double precision, dimension(:),pointer :: eucrust_lat,eucrust_lon,&
- eucrust_vp_uppercrust,eucrust_vp_lowercrust,eucrust_mohodepth,&
- eucrust_basement,eucrust_ucdepth
- integer :: num_eucrust
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_eucrust_variables
- type (model_eucrust_variables) EUCM_V
-
integer, parameter :: NTHETA = 4
integer, parameter :: NPHI = 10
- double precision, parameter :: CAP = 1.0d0*PI/180.0d0 ! 1 degree smoothing
+ double precision, parameter :: CAP = 1.0d0 * DEGREES_TO_RADIANS ! 1 degree smoothing
double precision,external :: crust_eu
@@ -338,11 +323,11 @@
!call get_crust_structure(crustaltype,velp,vels,rho,thick,code,thlr,velocp,velocs,dens,ierr)
! uncomment the following line to use as is, without smoothing
- ! value = func(lat,lon,x,value,found,EUCM_V)
+ ! value = func(lat,lon,x,value,found)
! return
- theta = (90.0-lat)*PI/180.0
- phi = lon*PI/180.0
+ theta = (90.0-lat)*DEGREES_TO_RADIANS
+ phi = lon*DEGREES_TO_RADIANS
sint = sin(theta)
cost = cos(theta)
@@ -362,8 +347,8 @@
rotation_matrix(3,3) = cost
dtheta = CAP/dble(NTHETA)
- dphi = 2.0*PI/dble(NPHI)
- cap_area = 2.0*PI*(1.0-cos(CAP))
+ dphi = TWO_PI/dble(NPHI)
+ cap_area = TWO_PI*(1.0-cos(CAP))
! integrate over a cap at the North pole
i = 0
@@ -398,8 +383,8 @@
! 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
+ xlat(i) = (PI_OVER_TWO-theta_rot)*RADIANS_TO_DEGREES
+ xlon(i) = phi_rot*RADIANS_TO_DEGREES
if(xlon(i) > 180.0) xlon(i) = xlon(i)-360.0
enddo
@@ -418,7 +403,7 @@
! integrates value
value = 0.0d0
do i=1,npoints
- valuel = crust_eu(xlat(i),xlon(i),radius,value,found,EUCM_V)
+ valuel = crust_eu(xlat(i),xlon(i),radius,value,found)
value = value + weight(i)*valuel
enddo
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_gapp2.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_gapp2.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_gapp2.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -194,8 +194,8 @@
drho = ZERO_
! increments in latitude/longitude (in rad)
- dtheta = dela * PI / 180.0
- dphi = delo * PI / 180.0
+ dtheta = dela * DEGREES_TO_RADIANS
+ dphi = delo * DEGREES_TO_RADIANS
! depth given in km
d=R_EARTH_-radius*R_EARTH_
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_jp3d.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_jp3d.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_jp3d.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -59,147 +59,157 @@
!
!--------------------------------------------------------------------------------------------------
- subroutine model_jp3d_broadcast(myrank,JP3DM_V)
+ module model_jp3d_par
+ ! 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
+
+ ! JP3DM_V arrays: vmod3d
+ double precision,dimension(:),allocatable :: JP3DM_PNA,JP3DM_RNA,JP3DM_HNA, &
+ JP3DM_PNB,JP3DM_RNB,JP3DM_HNB
+ double precision,dimension(:,:,:),allocatable :: JP3DM_VELAP,JP3DM_VELBP
+ ! discon
+ double precision,dimension(:),allocatable :: JP3DM_PN,JP3DM_RRN
+ double precision,dimension(:,:),allocatable :: JP3DM_DEPA,JP3DM_DEPB,JP3DM_DEPC
+ ! locate
+ double precision :: JP3DM_PLA
+ double precision :: JP3DM_RLA
+ double precision :: JP3DM_HLA
+ double precision :: JP3DM_PLB
+ double precision :: JP3DM_RLB
+ double precision :: JP3DM_HLB
+ ! weight
+ double precision,dimension(:),allocatable :: JP3DM_WV
+ ! prhfd
+ double precision :: JP3DM_P
+ double precision :: JP3DM_R
+ double precision :: JP3DM_H
+ double precision :: JP3DM_PF
+ double precision :: JP3DM_RF
+ double precision :: JP3DM_HF
+ double precision :: JP3DM_PF1
+ double precision :: JP3DM_RF1
+ double precision :: JP3DM_HF1
+ double precision :: JP3DM_PD
+ double precision :: JP3DM_RD
+ double precision :: JP3DM_HD
+ ! jpmodv
+ double precision,dimension(:),allocatable :: JP3DM_VP,JP3DM_VS,JP3DM_RA,JP3DM_DEPJ
+ ! locate integers
+ integer,dimension(:),allocatable :: JP3DM_IPLOCA,JP3DM_IRLOCA,JP3DM_IHLOCA, &
+ JP3DM_IPLOCB,JP3DM_IRLOCB,JP3DM_IHLOCB
+
+ ! vmod3D integers
+ integer :: JP3DM_NPA
+ integer :: JP3DM_NRA
+ integer :: JP3DM_NHA
+ integer :: JP3DM_NPB
+ integer :: JP3DM_NRB
+ integer :: JP3DM_NHB
+ ! weight integers
+ integer :: JP3DM_IP
+ integer :: JP3DM_JP
+ integer :: JP3DM_KP
+ integer :: JP3DM_IP1
+ integer :: JP3DM_JP1
+ integer :: JP3DM_KP1
+
+ end module model_jp3d_par
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ subroutine model_jp3d_broadcast(myrank)
+
! standard routine to setup model
+ use model_jp3d_par
+
implicit none
include "constants.h"
! standard include of the MPI library
include 'mpif.h'
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- double precision :: PNA(MPA)
- double precision :: RNA(MRA)
- double precision :: HNA(MHA)
- double precision :: PNB(MPB)
- double precision :: RNB(MRB)
- double precision :: HNB(MHB)
- double precision :: VELAP(MPA,MRA,MHA)
- double precision :: VELBP(MPB,MRB,MHB)
- ! discon
- double precision :: PN(51)
- double precision :: RRN(63)
- double precision :: DEPA(51,63)
- double precision :: DEPB(51,63)
- double precision :: DEPC(51,63)
- ! locate
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- double precision :: WV(8)
- ! prhfd
- double precision :: P
- double precision :: R
- double precision :: H
- double precision :: PF
- double precision :: RF
- double precision :: HF
- double precision :: PF1
- double precision :: RF1
- double precision :: HF1
- double precision :: PD
- double precision :: RD
- double precision :: HD
- ! jpmodv
- double precision :: VP(29)
- double precision :: VS(29)
- double precision :: RA(29)
- double precision :: DEPJ(29)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
-
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_variables
-
integer :: myrank
integer :: ier
- if(myrank == 0) call read_jp3d_iso_zhao_model(JP3DM_V)
+ ! allocates arrays
+! model_jp3d_variables
+ allocate(JP3DM_PNA(MPA),JP3DM_RNA(MRA),JP3DM_HNA(MHA), &
+ JP3DM_PNB(MPB),JP3DM_RNB(MRB),JP3DM_HNB(MHB), &
+ JP3DM_VELAP(MPA,MRA,MHA), &
+ JP3DM_VELBP(MPB,MRB,MHB), &
+ JP3DM_PN(51),JP3DM_RRN(63), &
+ JP3DM_DEPA(51,63),JP3DM_DEPB(51,63),JP3DM_DEPC(51,63), &
+ JP3DM_WV(8),JP3DM_VP(29),JP3DM_VS(29), &
+ JP3DM_RA(29),JP3DM_DEPJ(29), &
+ JP3DM_IPLOCA(MKA),JP3DM_IRLOCA(MKA), &
+ JP3DM_IHLOCA(MKA),JP3DM_IPLOCB(MKB), &
+ JP3DM_IRLOCB(MKB),JP3DM_IHLOCB(MKB), &
+ stat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating JP3D arrays')
+ ! master reads in values
+ if(myrank == 0) call read_jp3d_iso_zhao_model()
+
! 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)
+ call MPI_BCAST(JP3DM_NPA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_NRA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_NHA,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_NPB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_NRB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_NHB,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_PNA,MPA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_RNA,MRA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_HNA,MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_PNB,MPB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_RNB,MRB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_HNB,MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_VELAP,MPA*MRA*MHA,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_VELBP,MPB*MRB*MHB,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_PN,51,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_RRN,63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_DEPA,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_DEPB,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_DEPC,51*63,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_IPLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_IRLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_IHLOCA,MKA,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_IPLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_IRLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_IHLOCB,MKB,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_PLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_RLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_HLA,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_PLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_RLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_HLB,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_IP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_JP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_KP,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_IP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_JP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_KP1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_WV,8,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_P,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_R,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_H,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_PF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_RF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_HF,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_PF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_RF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_HF1,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_PD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_RD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_HD,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_VP,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_VS,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_RA,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(JP3DM_DEPJ,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
end subroutine model_jp3d_broadcast
@@ -208,171 +218,35 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine read_jp3d_iso_zhao_model(JP3DM_V)
+ subroutine read_jp3d_iso_zhao_model()
+ use model_jp3d_par
+
implicit none
include "constants.h"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- double precision :: PNA(MPA)
- double precision :: RNA(MRA)
- double precision :: HNA(MHA)
- double precision :: PNB(MPB)
- double precision :: RNB(MRB)
- double precision :: HNB(MHB)
- double precision :: VELAP(MPA,MRA,MHA)
- double precision :: VELBP(MPB,MRB,MHB)
- ! discon
- double precision :: PN(51)
- double precision :: RRN(63)
- double precision :: DEPA(51,63)
- double precision :: DEPB(51,63)
- double precision :: DEPC(51,63)
- ! locate
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- double precision :: WV(8)
- ! prhfd
- double precision :: P
- double precision :: R
- double precision :: H
- double precision :: PF
- double precision :: RF
- double precision :: HF
- double precision :: PF1
- double precision :: RF1
- double precision :: HF1
- double precision :: PD
- double precision :: RD
- double precision :: HD
- ! jpmodv
- double precision :: VP(29)
- double precision :: VS(29)
- double precision :: RA(29)
- double precision :: DEPJ(29)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_variables
-
OPEN(2,FILE="DATA/Zhao_JP_model/m3d1341")
OPEN(3,FILE="DATA/Zhao_JP_model/datadis")
- CALL INPUTJP(JP3DM_V)
- CALL INPUT1(JP3DM_V)
- CALL INPUT2(JP3DM_V)
+ CALL INPUTJP()
+ CALL INPUT1()
+ CALL INPUT2()
end subroutine read_jp3d_iso_zhao_model
!
-!==========================================================================
+!-------------------------------------------------------------------------------------------------
!
- subroutine model_jp3d_iso_zhao(radius,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
+ subroutine model_jp3d_iso_zhao(radius,theta,phi,vp,vs,dvp,dvs,rho,found_crust)
+
+ use model_jp3d_par
+
implicit none
include "constants.h"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- double precision :: PNA(MPA)
- double precision :: RNA(MRA)
- double precision :: HNA(MHA)
- double precision :: PNB(MPB)
- double precision :: RNB(MRB)
- double precision :: HNB(MHB)
- double precision :: VELAP(MPA,MRA,MHA)
- double precision :: VELBP(MPB,MRB,MHB)
- ! discon
- double precision :: PN(51)
- double precision :: RRN(63)
- double precision :: DEPA(51,63)
- double precision :: DEPB(51,63)
- double precision :: DEPC(51,63)
- ! locate
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- double precision :: WV(8)
- ! prhfd
- double precision :: P
- double precision :: R
- double precision :: H
- double precision :: PF
- double precision :: RF
- double precision :: HF
- double precision :: PF1
- double precision :: RF1
- double precision :: HF1
- double precision :: PD
- double precision :: RD
- double precision :: HD
- ! jpmodv
- double precision :: VP(29)
- double precision :: VS(29)
- double precision :: RA(29)
- double precision :: DEPJ(29)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
-
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_variables
-
logical found_crust
double precision :: radius,theta,phi,vp,vs,dvs,dvp,rho
double precision :: PE,RE,HE,H1,H2,H3,scaleval
@@ -386,9 +260,9 @@
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)
+ CALL HLAY(PE,RE,H1,1)
+ CALL HLAY(PE,RE,H2,2)
+ CALL HLAY(PE,RE,H3,3)
! 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;
@@ -405,9 +279,9 @@
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)
+ CALL VEL1D(HE,vp,LAY,1)
+ CALL VEL1D(HE,vs,LAY,2)
+ CALL VEL3(PE,RE,HE,dvp,LAY)
dvp = 0.01d0*dvp
dvs = 1.5d0*dvp
@@ -434,100 +308,45 @@
END subroutine model_jp3d_iso_zhao
!
-!---------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
!
- SUBROUTINE INPUT1(JP3DM_V)
- implicit none
+ SUBROUTINE INPUT1()
- include "constants.h"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- double precision :: PNA(MPA)
- double precision :: RNA(MRA)
- double precision :: HNA(MHA)
- double precision :: PNB(MPB)
- double precision :: RNB(MRB)
- double precision :: HNB(MHB)
- double precision :: VELAP(MPA,MRA,MHA)
- double precision :: VELBP(MPB,MRB,MHB)
- ! discon
- double precision :: PN(51)
- double precision :: RRN(63)
- double precision :: DEPA(51,63)
- double precision :: DEPB(51,63)
- double precision :: DEPC(51,63)
- ! locate
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- double precision :: WV(8)
- ! prhfd
- double precision :: P
- double precision :: R
- double precision :: H
- double precision :: PF
- double precision :: RF
- double precision :: HF
- double precision :: PF1
- double precision :: RF1
- double precision :: HF1
- double precision :: PD
- double precision :: RD
- double precision :: HD
- ! jpmodv
- double precision :: VP(29)
- double precision :: VS(29)
- double precision :: RA(29)
- double precision :: DEPJ(29)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
+ use model_jp3d_par
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_variables
+ implicit none
+ include "constants.h"
+
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), &
+ READ(2,100) JP3DM_NPA,JP3DM_NRA,JP3DM_NHA
+
+ CALL PUT1(JP3DM_NPA,JP3DM_NRA,JP3DM_NHA,JP3DM_PNA,JP3DM_RNA,JP3DM_HNA,JP3DM_VELAP)
+
+ READ(2,100) JP3DM_NPB,JP3DM_NRB,JP3DM_NHB
+
+ CALL PUT1(JP3DM_NPB,JP3DM_NRB,JP3DM_NHB,JP3DM_PNB,JP3DM_RNB,JP3DM_HNB,JP3DM_VELBP)
+ CALL BLDMAP()
+
+ RETURN
+ END SUBROUTINE INPUT1
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+ SUBROUTINE PUT1(NPX,NRX,NHX,PNX,RNX,HNX,VELXP)
+
+ implicit none
+
+ 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)
+
+ 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)
@@ -541,188 +360,60 @@
!
!---------------------------------------------------------------------------------------------
!
- SUBROUTINE INPUT2(JP3DM_V)
+ SUBROUTINE INPUT2()
+
+ use model_jp3d_par
+
implicit none
include "constants.h"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- double precision :: PNA(MPA)
- double precision :: RNA(MRA)
- double precision :: HNA(MHA)
- double precision :: PNB(MPB)
- double precision :: RNB(MRB)
- double precision :: HNB(MHB)
- double precision :: VELAP(MPA,MRA,MHA)
- double precision :: VELBP(MPB,MRB,MHB)
- ! discon
- double precision :: PN(51)
- double precision :: RRN(63)
- double precision :: DEPA(51,63)
- double precision :: DEPB(51,63)
- double precision :: DEPC(51,63)
- ! locate
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- double precision :: WV(8)
- ! prhfd
- double precision :: P
- double precision :: R
- double precision :: H
- double precision :: PF
- double precision :: RF
- double precision :: HF
- double precision :: PF1
- double precision :: RF1
- double precision :: HF1
- double precision :: PD
- double precision :: RD
- double precision :: HD
- ! jpmodv
- double precision :: VP(29)
- double precision :: VS(29)
- double precision :: RA(29)
- double precision :: DEPJ(29)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
+ integer :: NP,NNR,I,J
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_variables
-
- integer :: NP,NNR,I,J
- READ(3,100) NP,NNR
- READ(3,110) (JP3DM_V%PN(I),I=1,NP)
- READ(3,120) (JP3DM_V%RRN(I),I=1,NNR)
- DO 1 I = NP,1,-1
- READ(3,130) (JP3DM_V%DEPA(I,J),J=1,NNR)
+ READ(3,100) NP,NNR
+ READ(3,110) (JP3DM_PN(I),I=1,NP)
+ READ(3,120) (JP3DM_RRN(I),I=1,NNR)
+ DO 1 I = NP,1,-1
+ READ(3,130) (JP3DM_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)
+ DO 2 I = NP,1,-1
+ READ(3,130) (JP3DM_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)
+ DO 3 I = NP,1,-1
+ READ(3,130) (JP3DM_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
+ RETURN
+ END
+
!
-!-----------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
!
- SUBROUTINE BLDMAP(JP3DM_V)
+ SUBROUTINE BLDMAP()
+
+ use model_jp3d_par
+
implicit none
include "constants.h"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- double precision :: PNA(MPA)
- double precision :: RNA(MRA)
- double precision :: HNA(MHA)
- double precision :: PNB(MPB)
- double precision :: RNB(MRB)
- double precision :: HNB(MHB)
- double precision :: VELAP(MPA,MRA,MHA)
- double precision :: VELBP(MPB,MRB,MHB)
- ! discon
- double precision :: PN(51)
- double precision :: RRN(63)
- double precision :: DEPA(51,63)
- double precision :: DEPB(51,63)
- double precision :: DEPC(51,63)
- ! locate
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- double precision :: WV(8)
- ! prhfd
- double precision :: P
- double precision :: R
- double precision :: H
- double precision :: PF
- double precision :: RF
- double precision :: HF
- double precision :: PF1
- double precision :: RF1
- double precision :: HF1
- double precision :: PD
- double precision :: RD
- double precision :: HD
- ! jpmodv
- double precision :: VP(29)
- double precision :: VS(29)
- double precision :: RA(29)
- double precision :: DEPJ(29)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_variables
+ CALL LOCX(JP3DM_PNA,JP3DM_RNA,JP3DM_HNA,JP3DM_NPA,JP3DM_NRA,JP3DM_NHA,MKA, &
+ JP3DM_PLA,JP3DM_RLA,JP3DM_HLA,JP3DM_IPLOCA,JP3DM_IRLOCA,JP3DM_IHLOCA)
+ CALL LOCX(JP3DM_PNB,JP3DM_RNB,JP3DM_HNB,JP3DM_NPB,JP3DM_NRB,JP3DM_NHB,MKB, &
+ JP3DM_PLB,JP3DM_RLB,JP3DM_HLB,JP3DM_IPLOCB,JP3DM_IRLOCB,JP3DM_IHLOCB)
- 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
+ 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)
@@ -763,415 +454,162 @@
!-------------------------------------------------------------------------------------------
!
- SUBROUTINE VEL3(PE,RE,HE,V,LAY,JP3DM_V)
+ SUBROUTINE VEL3(PE,RE,HE,V,LAY)
+
+ use model_jp3d_par
+
implicit none
include "constants.h"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- double precision :: PNA(MPA)
- double precision :: RNA(MRA)
- double precision :: HNA(MHA)
- double precision :: PNB(MPB)
- double precision :: RNB(MRB)
- double precision :: HNB(MHB)
- double precision :: VELAP(MPA,MRA,MHA)
- double precision :: VELBP(MPB,MRB,MHB)
- ! discon
- double precision :: PN(51)
- double precision :: RRN(63)
- double precision :: DEPA(51,63)
- double precision :: DEPB(51,63)
- double precision :: DEPC(51,63)
- ! locate
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- double precision :: WV(8)
- ! prhfd
- double precision :: P
- double precision :: R
- double precision :: H
- double precision :: PF
- double precision :: RF
- double precision :: HF
- double precision :: PF1
- double precision :: RF1
- double precision :: HF1
- double precision :: PD
- double precision :: RD
- double precision :: HD
- ! jpmodv
- double precision :: VP(29)
- double precision :: VS(29)
- double precision :: RA(29)
- double precision :: DEPJ(29)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_variables
+ double precision :: PE,RE,HE,V
- double precision :: PE,RE,HE,V
+ integer :: LAY
- integer :: LAY
+ JP3DM_P = 90.0-PE/DEGREES_TO_RADIANS
+ JP3DM_R = RE/DEGREES_TO_RADIANS
+ JP3DM_H = HE
+ IF(LAY.LE.3) THEN
+ CALL PRHF(JP3DM_IPLOCA,JP3DM_IRLOCA,JP3DM_IHLOCA,JP3DM_PLA,JP3DM_RLA,JP3DM_HLA, &
+ JP3DM_PNA,JP3DM_RNA,JP3DM_HNA,MPA,MRA,MHA,MKA)
+ ELSE IF(LAY.EQ.4) THEN
+ CALL PRHF(JP3DM_IPLOCB,JP3DM_IRLOCB,JP3DM_IHLOCB,JP3DM_PLB,JP3DM_RLB,JP3DM_HLB, &
+ JP3DM_PNB,JP3DM_RNB,JP3DM_HNB,MPB,MRB,MHB,MKB)
+ ELSE
+ END IF
- 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
+ JP3DM_WV(1) = JP3DM_PF1*JP3DM_RF1*JP3DM_HF1
+ JP3DM_WV(2) = JP3DM_PF*JP3DM_RF1*JP3DM_HF1
+ JP3DM_WV(3) = JP3DM_PF1*JP3DM_RF*JP3DM_HF1
+ JP3DM_WV(4) = JP3DM_PF*JP3DM_RF*JP3DM_HF1
+ JP3DM_WV(5) = JP3DM_PF1*JP3DM_RF1*JP3DM_HF
+ JP3DM_WV(6) = JP3DM_PF*JP3DM_RF1*JP3DM_HF
+ JP3DM_WV(7) = JP3DM_PF1*JP3DM_RF*JP3DM_HF
+ JP3DM_WV(8) = JP3DM_PF*JP3DM_RF*JP3DM_HF
- RETURN
- END SUBROUTINE VEL3
+ ! calculate velocity
+ IF(LAY.LE.3) THEN
+ CALL VABPS(MPA,MRA,MHA,JP3DM_VELAP,V)
+ ELSE IF(LAY.EQ.4) THEN
+ CALL VABPS(MPB,MRB,MHB,JP3DM_VELBP,V)
+ ELSE
+ END IF
+ RETURN
+ END SUBROUTINE VEL3
+
!
!---------------------------------------------------------------------------------------
!
- SUBROUTINE VABPS(MP,MR,MH,V,VEL,JP3DM_V)
+ SUBROUTINE VABPS(MP,MR,MH,V,VEL)
+
+ use model_jp3d_par
+
implicit none
include "constants.h"
+ double precision :: VEL
+ integer :: MP,MR,MH
+ double precision :: V(MP,MR,MH)
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- double precision :: PNA(MPA)
- double precision :: RNA(MRA)
- double precision :: HNA(MHA)
- double precision :: PNB(MPB)
- double precision :: RNB(MRB)
- double precision :: HNB(MHB)
- double precision :: VELAP(MPA,MRA,MHA)
- double precision :: VELBP(MPB,MRB,MHB)
- ! discon
- double precision :: PN(51)
- double precision :: RRN(63)
- double precision :: DEPA(51,63)
- double precision :: DEPB(51,63)
- double precision :: DEPC(51,63)
- ! locate
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- double precision :: WV(8)
- ! prhfd
- double precision :: P
- double precision :: R
- double precision :: H
- double precision :: PF
- double precision :: RF
- double precision :: HF
- double precision :: PF1
- double precision :: RF1
- double precision :: HF1
- double precision :: PD
- double precision :: RD
- double precision :: HD
- ! jpmodv
- double precision :: VP(29)
- double precision :: VS(29)
- double precision :: RA(29)
- double precision :: DEPJ(29)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
+ VEL = JP3DM_WV(1)*V(JP3DM_IP,JP3DM_JP,JP3DM_KP) + JP3DM_WV(2)*V(JP3DM_IP1,JP3DM_JP,JP3DM_KP) &
+ + JP3DM_WV(3)*V(JP3DM_IP,JP3DM_JP1,JP3DM_KP) + JP3DM_WV(4)*V(JP3DM_IP1,JP3DM_JP1,JP3DM_KP) &
+ + JP3DM_WV(5)*V(JP3DM_IP,JP3DM_JP,JP3DM_KP1) + JP3DM_WV(6)*V(JP3DM_IP1,JP3DM_JP,JP3DM_KP1) &
+ + JP3DM_WV(7)*V(JP3DM_IP,JP3DM_JP1,JP3DM_KP1)+ JP3DM_WV(8)*V(JP3DM_IP1,JP3DM_JP1,JP3DM_KP1)
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_variables
- double precision :: VEL
- integer :: MP,MR,MH
- double precision :: V(MP,MR,MH)
- VEL = JP3DM_V%WV(1)*V(JP3DM_V%IP,JP3DM_V%JP,JP3DM_V%KP) + JP3DM_V%WV(2)*V(JP3DM_V%IP1,JP3DM_V%JP,JP3DM_V%KP) &
- + JP3DM_V%WV(3)*V(JP3DM_V%IP,JP3DM_V%JP1,JP3DM_V%KP) + JP3DM_V%WV(4)*V(JP3DM_V%IP1,JP3DM_V%JP1,JP3DM_V%KP) &
- + JP3DM_V%WV(5)*V(JP3DM_V%IP,JP3DM_V%JP,JP3DM_V%KP1) + JP3DM_V%WV(6)*V(JP3DM_V%IP1,JP3DM_V%JP,JP3DM_V%KP1) &
- + JP3DM_V%WV(7)*V(JP3DM_V%IP,JP3DM_V%JP1,JP3DM_V%KP1)+ JP3DM_V%WV(8)*V(JP3DM_V%IP1,JP3DM_V%JP1,JP3DM_V%KP1)
- RETURN
- END
+ 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 INTMAP(R,IRLOC,NNR,RL,IR)
+
+ implicit none
+ 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)
+ PNX,RNX,HNX,MPX,MRX,MHX,MKX)
+
+ use model_jp3d_par
+
implicit none
include "constants.h"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- double precision :: PNA(MPA)
- double precision :: RNA(MRA)
- double precision :: HNA(MHA)
- double precision :: PNB(MPB)
- double precision :: RNB(MRB)
- double precision :: HNB(MHB)
- double precision :: VELAP(MPA,MRA,MHA)
- double precision :: VELBP(MPB,MRB,MHB)
- ! discon
- double precision :: PN(51)
- double precision :: RRN(63)
- double precision :: DEPA(51,63)
- double precision :: DEPB(51,63)
- double precision :: DEPC(51,63)
- ! locate
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- double precision :: WV(8)
- ! prhfd
- double precision :: P
- double precision :: R
- double precision :: H
- double precision :: PF
- double precision :: RF
- double precision :: HF
- double precision :: PF1
- double precision :: RF1
- double precision :: HF1
- double precision :: PD
- double precision :: RD
- double precision :: HD
- ! jpmodv
- double precision :: VP(29)
- double precision :: VS(29)
- double precision :: RA(29)
- double precision :: DEPJ(29)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
+ 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
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_variables
+ CALL LIMIT(PNX(1),PNX(MPX),JP3DM_P)
+ CALL LIMIT(RNX(1),RNX(MRX),JP3DM_R)
+ CALL LIMIT(HNX(1),HNX(MHX),JP3DM_H)
+ CALL INTMAP(JP3DM_P*100.0,IPLOCX,MKX,PLX,JP3DM_IP)
+ CALL INTMAP(JP3DM_R*100.0,IRLOCX,MKX,RLX,JP3DM_JP)
+ CALL INTMAP(JP3DM_H,IHLOCX,MKX,HLX,JP3DM_KP)
+ JP3DM_IP1 = JP3DM_IP+1
+ JP3DM_JP1 = JP3DM_JP+1
+ JP3DM_KP1 = JP3DM_KP+1
+ JP3DM_PD = PNX(JP3DM_IP1)-PNX(JP3DM_IP)
+ JP3DM_RD = RNX(JP3DM_JP1)-RNX(JP3DM_JP)
+ JP3DM_HD = HNX(JP3DM_KP1)-HNX(JP3DM_KP)
+ JP3DM_PF = (JP3DM_P-PNX(JP3DM_IP))/JP3DM_PD
+ JP3DM_RF = (JP3DM_R-RNX(JP3DM_JP))/JP3DM_RD
+ JP3DM_HF = (JP3DM_H-HNX(JP3DM_KP))/JP3DM_HD
+ JP3DM_PF1 = 1.0-JP3DM_PF
+ JP3DM_RF1 = 1.0-JP3DM_RF
+ JP3DM_HF1 = 1.0-JP3DM_HF
+ RETURN
+ END
- 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)
+ SUBROUTINE HLAY(PE,RE,HE,IJK)
+
+ use model_jp3d_par
+
implicit none
include "constants.h"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- double precision :: PNA(MPA)
- double precision :: RNA(MRA)
- double precision :: HNA(MHA)
- double precision :: PNB(MPB)
- double precision :: RNB(MRB)
- double precision :: HNB(MHB)
- double precision :: VELAP(MPA,MRA,MHA)
- double precision :: VELBP(MPB,MRB,MHB)
- ! discon
- double precision :: PN(51)
- double precision :: RRN(63)
- double precision :: DEPA(51,63)
- double precision :: DEPB(51,63)
- double precision :: DEPC(51,63)
- ! locate
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- double precision :: WV(8)
- ! prhfd
- double precision :: P
- double precision :: R
- double precision :: H
- double precision :: PF
- double precision :: RF
- double precision :: HF
- double precision :: PF1
- double precision :: RF1
- double precision :: HF1
- double precision :: PD
- double precision :: RD
- double precision :: HD
- ! jpmodv
- double precision :: VP(29)
- double precision :: VS(29)
- double precision :: RA(29)
- double precision :: DEPJ(29)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_variables
- double precision :: PE,RE,HE,WV1,WV2,WV3,WV4,P,R,PF,RF,PF1,RF1
- integer :: IJK,J,J1,I,I1
- P = 90.0-PE/DEGREES_TO_RADIANS
- R = RE/DEGREES_TO_RADIANS
- CALL LIMIT(JP3DM_V%PN(1),JP3DM_V%PN(51),P)
- CALL LIMIT(JP3DM_V%RRN(1),JP3DM_V%RRN(63),R)
+ 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_PN(1),JP3DM_PN(51),P)
+ CALL LIMIT(JP3DM_RRN(1),JP3DM_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
+ IF(P.GE.JP3DM_PN(I).AND.P.LT.JP3DM_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
+ IF(R.GE.JP3DM_RRN(J).AND.R.LT.JP3DM_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))
+ PF = (P-JP3DM_PN(I))/(JP3DM_PN(I1)-JP3DM_PN(I))
+ RF = (R-JP3DM_RRN(J))/(JP3DM_RRN(J1)-JP3DM_RRN(J))
PF1 = 1.0-PF
RF1 = 1.0-RF
WV1 = PF1*RF1
@@ -1179,316 +617,138 @@
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)
+ HE = WV1*JP3DM_DEPA(I,J) + WV2*JP3DM_DEPA(I1,J) &
+ + WV3*JP3DM_DEPA(I,J1) + WV4*JP3DM_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)
+ HE = WV1*JP3DM_DEPB(I,J) + WV2*JP3DM_DEPB(I1,J) &
+ + WV3*JP3DM_DEPB(I,J1) + WV4*JP3DM_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)
+ HE = WV1*JP3DM_DEPC(I,J) + WV2*JP3DM_DEPC(I1,J) &
+ + WV3*JP3DM_DEPC(I,J1) + WV4*JP3DM_DEPC(I1,J1)
ELSE
END IF
- RETURN
- END SUBROUTINE HLAY
+ 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 LIMIT(C1,C2,C)
+
+ implicit none
+ 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)
+
+ SUBROUTINE VEL1D(HE,V,LAY,IPS)
+
+ use model_jp3d_par
+
implicit none
include "constants.h"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- double precision :: PNA(MPA)
- double precision :: RNA(MRA)
- double precision :: HNA(MHA)
- double precision :: PNB(MPB)
- double precision :: RNB(MRB)
- double precision :: HNB(MHB)
- double precision :: VELAP(MPA,MRA,MHA)
- double precision :: VELBP(MPB,MRB,MHB)
- ! discon
- double precision :: PN(51)
- double precision :: RRN(63)
- double precision :: DEPA(51,63)
- double precision :: DEPB(51,63)
- double precision :: DEPC(51,63)
- ! locate
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- double precision :: WV(8)
- ! prhfd
- double precision :: P
- double precision :: R
- double precision :: H
- double precision :: PF
- double precision :: RF
- double precision :: HF
- double precision :: PF1
- double precision :: RF1
- double precision :: HF1
- double precision :: PD
- double precision :: RD
- double precision :: HD
- ! jpmodv
- double precision :: VP(29)
- double precision :: VS(29)
- double precision :: RA(29)
- double precision :: DEPJ(29)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_variables
+ integer :: IPS,LAY
+ double precision :: HE,V,VM,HM
- 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
+ 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)
+ V = VM-(HM-HE)*0.003
+ ELSE
+ CALL JPMODEL(IPS,HE,V)
+ END IF
+ ELSE
+ END IF
- SUBROUTINE INPUTJP(JP3DM_V)
+ RETURN
+ END
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ SUBROUTINE INPUTJP()
+
+ use model_jp3d_par
+
implicit none
include "constants.h"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- double precision :: PNA(MPA)
- double precision :: RNA(MRA)
- double precision :: HNA(MHA)
- double precision :: PNB(MPB)
- double precision :: RNB(MRB)
- double precision :: HNB(MHB)
- double precision :: VELAP(MPA,MRA,MHA)
- double precision :: VELBP(MPB,MRB,MHB)
- ! discon
- double precision :: PN(51)
- double precision :: RRN(63)
- double precision :: DEPA(51,63)
- double precision :: DEPB(51,63)
- double precision :: DEPC(51,63)
- ! locate
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- double precision :: WV(8)
- ! prhfd
- double precision :: P
- double precision :: R
- double precision :: H
- double precision :: PF
- double precision :: RF
- double precision :: HF
- double precision :: PF1
- double precision :: RF1
- double precision :: HF1
- double precision :: PD
- double precision :: RD
- double precision :: HD
- ! jpmodv
- double precision :: VP(29)
- double precision :: VS(29)
- double precision :: RA(29)
- double precision :: DEPJ(29)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_variables
- double precision :: VP1(29),VS1(29),RA1(29)
- integer :: L
- DATA VP1/7.75, 7.94, 8.13, 8.33, 8.54, 8.75, 8.97, &
- 9.50, 9.91,10.26,10.55,10.99,11.29,11.50, &
- 11.67,11.85,12.03,12.20,12.37,12.54,12.71, &
- 12.87,13.02,13.16,13.32,13.46,13.60,13.64,13.64/
- DATA VS1/4.353,4.444,4.539,4.638,4.741,4.850,4.962, &
- 5.227,5.463,5.670,5.850,6.125,6.295,6.395, &
- 6.483,6.564,6.637,6.706,6.770,6.833,6.893, &
- 6.953,7.012,7.074,7.137,7.199,7.258,7.314,7.304/
- DATA RA1/1.00,0.99,0.98,0.97,0.96,0.95,0.94,0.93, &
- 0.92,0.91,0.90,0.88,0.86,0.84,0.82,0.80, &
- 0.78,0.76,0.74,0.72,0.70,0.68,0.66,0.64, &
- 0.62,0.60,0.58,0.56,0.55/
- DO 1 L = 1,29
- JP3DM_V%VP(L) = VP1(L)
- JP3DM_V%VS(L) = VS1(L)
- JP3DM_V%RA(L) = RA1(L)
- JP3DM_V%DEPJ(L) = 40.0+6325.59*(1.0-RA1(L))
+ 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_VP(L) = VP1(L)
+ JP3DM_VS(L) = VS1(L)
+ JP3DM_RA(L) = RA1(L)
+ JP3DM_DEPJ(L) = 40.0+6325.59*(1.0-RA1(L))
1 CONTINUE
- RETURN
- END
+ RETURN
+ END
+
!
-!---------------------------------------------
+!-------------------------------------------------------------------------------------------------
!
- SUBROUTINE JPMODEL(IPS,H,V,JP3DM_V)
+
+ SUBROUTINE JPMODEL(IPS,H,V)
+
+ use model_jp3d_par
+
implicit none
include "constants.h"
-! model_jp3d_variables
- type model_jp3d_variables
- sequence
- ! vmod3d
- double precision :: PNA(MPA)
- double precision :: RNA(MRA)
- double precision :: HNA(MHA)
- double precision :: PNB(MPB)
- double precision :: RNB(MRB)
- double precision :: HNB(MHB)
- double precision :: VELAP(MPA,MRA,MHA)
- double precision :: VELBP(MPB,MRB,MHB)
- ! discon
- double precision :: PN(51)
- double precision :: RRN(63)
- double precision :: DEPA(51,63)
- double precision :: DEPB(51,63)
- double precision :: DEPC(51,63)
- ! locate
- double precision :: PLA
- double precision :: RLA
- double precision :: HLA
- double precision :: PLB
- double precision :: RLB
- double precision :: HLB
- ! weight
- double precision :: WV(8)
- ! prhfd
- double precision :: P
- double precision :: R
- double precision :: H
- double precision :: PF
- double precision :: RF
- double precision :: HF
- double precision :: PF1
- double precision :: RF1
- double precision :: HF1
- double precision :: PD
- double precision :: RD
- double precision :: HD
- ! jpmodv
- double precision :: VP(29)
- double precision :: VS(29)
- double precision :: RA(29)
- double precision :: DEPJ(29)
- ! locate integers
- integer :: IPLOCA(MKA)
- integer :: IRLOCA(MKA)
- integer :: IHLOCA(MKA)
- integer :: IPLOCB(MKB)
- integer :: IRLOCB(MKB)
- integer :: IHLOCB(MKB)
- ! vmod3D integers
- integer :: NPA
- integer :: NRA
- integer :: NHA
- integer :: NPB
- integer :: NRB
- integer :: NHB
- ! weight integers
- integer :: IP
- integer :: JP
- integer :: KP
- integer :: IP1
- integer :: JP1
- integer :: KP1
- end type model_jp3d_variables
- type (model_jp3d_variables) JP3DM_V
-! model_jp3d_variables
- integer :: IPS,K,K1
- double precision :: H1,H2,H12,H,V
- DO 2 K = 1,28
+ 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)
+ H1 = JP3DM_DEPJ(K)
+ H2 = JP3DM_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
+ H12 = (H-H1)/(H2-H1)
+ IF(IPS.EQ.1) THEN
+ V = (JP3DM_VP(K1)-JP3DM_VP(K))*H12+JP3DM_VP(K)
+ ELSE
+ V = (JP3DM_VS(K1)-JP3DM_VS(K))*H12+JP3DM_VS(K)
+ END IF
+ RETURN
+ END
+
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_ppm.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_ppm.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_ppm.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -38,30 +38,10 @@
!
!--------------------------------------------------------------------------------------------------
- module module_PPM
+ module model_ppm_par
- include "constants.h"
-
- ! file
- character(len=150):: PPM_file_path = "./DATA/PPM/model.txt"
-
- ! smoothing parameters
- logical,parameter:: GAUSS_SMOOTHING = .false.
-
- double precision,parameter:: sigma_h = 10.0 ! 50.0 ! km, horizontal
- double precision,parameter:: sigma_v = 10.0 ! 20.0 ! km, vertical
-
- double precision,parameter:: pi_by180 = PI/180.0d0
- double precision,parameter:: degtokm = pi_by180*R_EARTH_KM
-
- double precision,parameter:: const_a = sigma_v/3.0
- double precision,parameter:: const_b = sigma_h/3.0/(R_EARTH_KM*pi_by180)
- integer,parameter:: NUM_GAUSSPOINTS = 10
-
- double precision,parameter:: pi_by2 = PI/2.0d0
- double precision,parameter:: radtodeg = 180.0d0/PI
-
! ----------------------
+
! scale perturbations in shear speed to perturbations in density and vp
logical,parameter:: SCALE_MODEL = .false.
@@ -84,59 +64,72 @@
! Qin et al. 2009, sec. 5.2
double precision, parameter :: SCALE_VP = 0.588d0 ! by Karato, 1993
- end module module_PPM
+ ! ----------------------
+
+ ! file
+ character(len=*),parameter :: PPM_file_path = "./DATA/PPM/model.txt"
+
+ ! smoothing parameters
+ logical,parameter:: GAUSS_SMOOTHING = .false.
+
+ double precision,parameter:: sigma_h = 10.0 ! 50.0 ! km, horizontal
+ double precision,parameter:: sigma_v = 10.0 ! 20.0 ! km, vertical
+
+ integer,parameter:: NUM_GAUSSPOINTS = 10
+
+ ! point profile model_variables
+ double precision,dimension(:),allocatable :: PPM_dvs,PPM_lat,PPM_lon,PPM_depth
+
+ double precision :: PPM_maxlat,PPM_maxlon,PPM_minlat,PPM_minlon,PPM_maxdepth,PPM_mindepth
+ double precision :: PPM_dlat,PPM_dlon,PPM_ddepth,PPM_max_dvs,PPM_min_dvs
+
+ integer :: PPM_num_v,PPM_num_latperlon,PPM_num_lonperdepth
+
+ end module model_ppm_par
+
!
!--------------------------------------------------------------------------------------------------
!
- subroutine model_ppm_broadcast(myrank,PPM_V)
+ subroutine model_ppm_broadcast(myrank)
! standard routine to setup model
+ use model_ppm_par
+
implicit none
include "constants.h"
! standard include of the MPI library
include 'mpif.h'
-! point profile model_variables
- type model_ppm_variables
- sequence
- double precision,dimension(:),pointer :: dvs,lat,lon,depth
- double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
- double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
- integer :: num_v,num_latperlon,num_lonperdepth
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_ppm_variables
- type (model_ppm_variables) PPM_V
-
integer :: myrank
integer :: ier
! upper mantle structure
- if(myrank == 0) call read_model_ppm(PPM_V)
+ if(myrank == 0) call read_model_ppm()
! broadcast the information read on the master to the nodes
- call MPI_BCAST(PPM_V%num_v,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%num_latperlon,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%num_lonperdepth,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_num_v,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_num_latperlon,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_num_lonperdepth,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
if( myrank /= 0 ) then
- allocate(PPM_V%lat(PPM_V%num_v),PPM_V%lon(PPM_V%num_v),PPM_V%depth(PPM_V%num_v),PPM_V%dvs(PPM_V%num_v))
+ allocate(PPM_lat(PPM_num_v),PPM_lon(PPM_num_v),PPM_depth(PPM_num_v),PPM_dvs(PPM_num_v))
endif
- call MPI_BCAST(PPM_V%dvs(1:PPM_V%num_v),PPM_V%num_v,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%lat(1:PPM_V%num_v),PPM_V%num_v,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%lon(1:PPM_V%num_v),PPM_V%num_v,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%depth(1:PPM_V%num_v),PPM_V%num_v,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%maxlat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%minlat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%maxlon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%minlon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%maxdepth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%mindepth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%dlat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%dlon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%ddepth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_dvs(1:PPM_num_v),PPM_num_v,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_lat(1:PPM_num_v),PPM_num_v,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_lon(1:PPM_num_v),PPM_num_v,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_depth(1:PPM_num_v),PPM_num_v,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_maxlat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_minlat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_maxlon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_minlon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_maxdepth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_mindepth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_dlat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_dlon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_ddepth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
end subroutine model_ppm_broadcast
@@ -145,22 +138,13 @@
!--------------------------------------------------------------------------------------------------
!
- subroutine read_model_ppm(PPM_V)
+ subroutine read_model_ppm()
- use module_PPM
+ use model_ppm_par
implicit none
- ! point profile model_variables
- type model_ppm_variables
- sequence
- double precision,dimension(:),pointer :: dvs,lat,lon,depth
- double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
- double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
- integer :: num_v,num_latperlon,num_lonperdepth
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_ppm_variables
- type (model_ppm_variables) PPM_V
+ include "constants.h"
! local parameters
integer :: ier,counter,i
@@ -191,7 +175,7 @@
enddo
close(10)
- PPM_V%num_v = counter
+ PPM_num_v = counter
if( counter < 1 ) then
write(IMAIN,*)
write(IMAIN,*) ' model PPM:',filename
@@ -206,10 +190,10 @@
write(IMAIN,*)
endif
- allocate(PPM_V%lat(counter),PPM_V%lon(counter),PPM_V%depth(counter),PPM_V%dvs(counter))
- PPM_V%min_dvs = 0.0
- PPM_V%max_dvs = 0.0
- PPM_V%dvs(:) = 0.0
+ allocate(PPM_lat(counter),PPM_lon(counter),PPM_depth(counter),PPM_dvs(counter))
+ PPM_min_dvs = 0.0
+ PPM_max_dvs = 0.0
+ PPM_dvs(:) = 0.0
! vs values
open(unit=10,file=trim(filename),status='old',action='read',iostat=ier)
@@ -224,45 +208,45 @@
read(10,*,iostat=ier) lon,lat,depth,dvs,vs
if( ier == 0 ) then
counter = counter + 1
- PPM_V%lat(counter) = lat
- PPM_V%lon(counter) = lon
- PPM_V%depth(counter) = depth
- PPM_V%dvs(counter) = dvs/100.0
+ PPM_lat(counter) = lat
+ PPM_lon(counter) = lon
+ PPM_depth(counter) = depth
+ PPM_dvs(counter) = dvs/100.0
!debug
!if( abs(depth - 100.0) < 1.e-3) write(IMAIN,*) ' lon/lat/depth : ',lon,lat,depth,' dvs:',dvs
endif
enddo
close(10)
- if( counter /= PPM_V%num_v ) then
+ if( counter /= PPM_num_v ) then
write(IMAIN,*)
write(IMAIN,*) ' model PPM:',filename
write(IMAIN,*) ' error values read in!!!!!!'
- write(IMAIN,*) ' expected: ',PPM_V%num_v
+ write(IMAIN,*) ' expected: ',PPM_num_v
write(IMAIN,*) ' got: ',counter
call exit_mpi(0,' error model PPM ')
endif
! gets depths (in km) of upper and lower limit
- PPM_V%minlat = minval( PPM_V%lat(1:PPM_V%num_v) )
- PPM_V%maxlat = maxval( PPM_V%lat(1:PPM_V%num_v) )
+ PPM_minlat = minval( PPM_lat(1:PPM_num_v) )
+ PPM_maxlat = maxval( PPM_lat(1:PPM_num_v) )
- PPM_V%minlon = minval( PPM_V%lon(1:PPM_V%num_v) )
- PPM_V%maxlon = maxval( PPM_V%lon(1:PPM_V%num_v) )
+ PPM_minlon = minval( PPM_lon(1:PPM_num_v) )
+ PPM_maxlon = maxval( PPM_lon(1:PPM_num_v) )
- PPM_V%mindepth = minval( PPM_V%depth(1:PPM_V%num_v) )
- PPM_V%maxdepth = maxval( PPM_V%depth(1:PPM_V%num_v) )
+ PPM_mindepth = minval( PPM_depth(1:PPM_num_v) )
+ PPM_maxdepth = maxval( PPM_depth(1:PPM_num_v) )
- PPM_V%min_dvs = minval(PPM_V%dvs(1:PPM_V%num_v))
- PPM_V%max_dvs = maxval(PPM_V%dvs(1:PPM_V%num_v))
+ PPM_min_dvs = minval(PPM_dvs(1:PPM_num_v))
+ PPM_max_dvs = maxval(PPM_dvs(1:PPM_num_v))
write(IMAIN,*) 'model PPM:'
- write(IMAIN,*) ' latitude min/max : ',PPM_V%minlat,PPM_V%maxlat
- write(IMAIN,*) ' longitude min/max: ',PPM_V%minlon,PPM_V%maxlon
- write(IMAIN,*) ' depth min/max : ',PPM_V%mindepth,PPM_V%maxdepth
+ write(IMAIN,*) ' latitude min/max : ',PPM_minlat,PPM_maxlat
+ write(IMAIN,*) ' longitude min/max: ',PPM_minlon,PPM_maxlon
+ write(IMAIN,*) ' depth min/max : ',PPM_mindepth,PPM_maxdepth
write(IMAIN,*)
- write(IMAIN,*) ' dvs min/max : ',PPM_V%min_dvs,PPM_V%max_dvs
+ write(IMAIN,*) ' dvs min/max : ',PPM_min_dvs,PPM_max_dvs
write(IMAIN,*)
if( SCALE_MODEL ) then
write(IMAIN,*) ' scaling: '
@@ -278,46 +262,46 @@
endif
! steps lengths
- PPM_V%dlat = 0.0d0
- lat = PPM_V%lat(1)
- do i=1,PPM_V%num_v
- if( abs(lat - PPM_V%lat(i)) > 1.e-15 ) then
- PPM_V%dlat = PPM_V%lat(i) - lat
+ PPM_dlat = 0.0d0
+ lat = PPM_lat(1)
+ do i=1,PPM_num_v
+ if( abs(lat - PPM_lat(i)) > 1.e-15 ) then
+ PPM_dlat = PPM_lat(i) - lat
exit
endif
enddo
- PPM_V%dlon = 0.0d0
- lon = PPM_V%lon(1)
- do i=1,PPM_V%num_v
- if( abs(lon - PPM_V%lon(i)) > 1.e-15 ) then
- PPM_V%dlon = PPM_V%lon(i) - lon
+ PPM_dlon = 0.0d0
+ lon = PPM_lon(1)
+ do i=1,PPM_num_v
+ if( abs(lon - PPM_lon(i)) > 1.e-15 ) then
+ PPM_dlon = PPM_lon(i) - lon
exit
endif
enddo
- PPM_V%ddepth = 0.0d0
- depth = PPM_V%depth(1)
- do i=1,PPM_V%num_v
- if( abs(depth - PPM_V%depth(i)) > 1.e-15 ) then
- PPM_V%ddepth = PPM_V%depth(i) - depth
+ PPM_ddepth = 0.0d0
+ depth = PPM_depth(1)
+ do i=1,PPM_num_v
+ if( abs(depth - PPM_depth(i)) > 1.e-15 ) then
+ PPM_ddepth = PPM_depth(i) - depth
exit
endif
enddo
- if( abs(PPM_V%dlat) < 1.e-15 .or. abs(PPM_V%dlon) < 1.e-15 .or. abs(PPM_V%ddepth) < 1.e-15) then
+ if( abs(PPM_dlat) < 1.e-15 .or. abs(PPM_dlon) < 1.e-15 .or. abs(PPM_ddepth) < 1.e-15) then
write(IMAIN,*) ' model PPM:',filename
write(IMAIN,*) ' error in delta values:'
- write(IMAIN,*) ' dlat : ',PPM_V%dlat,' dlon: ',PPM_V%dlon,' ddepth: ',PPM_V%ddepth
+ write(IMAIN,*) ' dlat : ',PPM_dlat,' dlon: ',PPM_dlon,' ddepth: ',PPM_ddepth
call exit_mpi(0,' error model PPM ')
else
write(IMAIN,*) ' model increments:'
- write(IMAIN,*) ' ddepth: ',sngl(PPM_V%ddepth),' dlat:',sngl(PPM_V%dlat),' dlon:',sngl(PPM_V%dlon)
+ write(IMAIN,*) ' ddepth: ',sngl(PPM_ddepth),' dlat:',sngl(PPM_dlat),' dlon:',sngl(PPM_dlon)
write(IMAIN,*)
endif
- PPM_V%num_latperlon = int( (PPM_V%maxlat - PPM_V%minlat) / PPM_V%dlat) + 1
- PPM_V%num_lonperdepth = int( (PPM_V%maxlon - PPM_V%minlon) / PPM_V%dlon ) + 1
+ PPM_num_latperlon = int( (PPM_maxlat - PPM_minlat) / PPM_dlat) + 1
+ PPM_num_lonperdepth = int( (PPM_maxlon - PPM_minlon) / PPM_dlon ) + 1
end subroutine read_model_ppm
@@ -326,26 +310,17 @@
!--------------------------------------------------------------------------------------------------
!
- subroutine model_ppm(radius,theta,phi,dvs,dvp,drho,PPM_V)
+ subroutine model_ppm(radius,theta,phi,dvs,dvp,drho)
! returns dvs,dvp and drho for given radius,theta,phi location
- use module_PPM
+ use model_ppm_par
implicit none
- ! point profile model_variables
- type model_ppm_variables
- sequence
- double precision,dimension(:),pointer :: dvs,lat,lon,depth
- double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
- double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
- integer :: num_v,num_latperlon,num_lonperdepth
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_ppm_variables
- type (model_ppm_variables) PPM_V
+ include "constants.h"
- double precision radius,theta,phi,dvs,dvp,drho
+ double precision :: radius,theta,phi,dvs,dvp,drho
! local parameters
integer:: i,j,k
@@ -354,6 +329,9 @@
double precision:: g_dvs,g_depth,g_lat,g_lon,x,g_weight,weight_sum,weight_prod
+ double precision,parameter:: const_a = sigma_v/3.0
+ double precision,parameter:: const_b = sigma_h/3.0/(R_EARTH_KM*DEGREES_TO_RADIANS)
+
! initialize
dvs = 0.0d0
dvp = 0.0d0
@@ -361,18 +339,18 @@
! depth of given radius (in km)
r_depth = R_EARTH_KM*(1.0 - radius) ! radius is normalized between [0,1]
- if(r_depth>PPM_V%maxdepth .or. r_depth < PPM_V%mindepth) return
+ if(r_depth>PPM_maxdepth .or. r_depth < PPM_mindepth) return
- lat=(pi_by2-theta)*radtodeg
- if( lat < PPM_V%minlat .or. lat > PPM_V%maxlat ) return
+ lat=(PI_OVER_TWO-theta)*RADIANS_TO_DEGREES
+ if( lat < PPM_minlat .or. lat > PPM_maxlat ) return
- lon=phi*radtodeg
+ lon=phi*RADIANS_TO_DEGREES
if(lon>180.0d0) lon=lon-360.0d0
- if( lon < PPM_V%minlon .or. lon > PPM_V%maxlon ) return
+ if( lon < PPM_minlon .or. lon > PPM_maxlon ) return
! search location value
if( .not. GAUSS_SMOOTHING ) then
- call get_PPMmodel_value(lat,lon,r_depth,PPM_V,dvs)
+ call get_PPMmodel_value(lat,lon,r_depth,dvs)
return
endif
@@ -388,15 +366,15 @@
do k=-NUM_GAUSSPOINTS,NUM_GAUSSPOINTS
g_lat = lat + k*const_b
- call get_PPMmodel_value(g_lat,g_lon,g_depth,PPM_V,g_dvs)
+ call get_PPMmodel_value(g_lat,g_lon,g_depth,g_dvs)
! horizontal weighting
- x = (g_lat-lat)*degtokm
+ x = (g_lat-lat)*DEGREES_TO_RADIANS*R_EARTH_KM
call get_Gaussianweight(x,sigma_h,g_weight)
g_dvs = g_dvs*g_weight
weight_prod = g_weight
- x = (g_lon-lon)*degtokm
+ x = (g_lon-lon)*DEGREES_TO_RADIANS*R_EARTH_KM
call get_Gaussianweight(x,sigma_h,g_weight)
g_dvs = g_dvs*g_weight
weight_prod = weight_prod * g_weight
@@ -418,14 +396,14 @@
! store min/max
- max_dvs = PPM_V%max_dvs
- min_dvs = PPM_V%min_dvs
+ max_dvs = PPM_max_dvs
+ min_dvs = PPM_min_dvs
if( dvs > max_dvs ) max_dvs = dvs
if( dvs < min_dvs ) min_dvs = dvs
- PPM_V%max_dvs = max_dvs
- PPM_V%min_dvs = min_dvs
+ PPM_max_dvs = max_dvs
+ PPM_min_dvs = min_dvs
!write(IMAIN,*) ' dvs = ',sngl(dvs),' weight: ',sngl(weight_sum),(sngl((2*PI*sigma_h**2)*sqrt(2*PI)*sigma_v))
@@ -442,23 +420,14 @@
!--------------------------------------------------------------------------------------------------
!
- subroutine get_PPMmodel_value(lat,lon,depth,PPM_V,dvs)
+ subroutine get_PPMmodel_value(lat,lon,depth,dvs)
+ use model_ppm_par
+
implicit none
include "constants.h"
- ! point profile model_variables
- type model_ppm_variables
- sequence
- double precision,dimension(:),pointer :: dvs,lat,lon,depth
- double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
- double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
- integer :: num_v,num_latperlon,num_lonperdepth
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_ppm_variables
- type (model_ppm_variables) PPM_V
-
double precision lat,lon,depth,dvs
!integer i,j,k
@@ -468,35 +437,35 @@
dvs = 0.0
- if( lat > PPM_V%maxlat ) return
- if( lat < PPM_V%minlat ) return
- if( lon > PPM_V%maxlon ) return
- if( lon < PPM_V%minlon ) return
- if( depth > PPM_V%maxdepth ) return
- if( depth < PPM_V%mindepth ) return
+ if( lat > PPM_maxlat ) return
+ if( lat < PPM_minlat ) return
+ if( lon > PPM_maxlon ) return
+ if( lon < PPM_minlon ) return
+ if( depth > PPM_maxdepth ) return
+ if( depth < PPM_mindepth ) return
! direct access: assumes having a regular interval spacing
- num_latperlon = PPM_V%num_latperlon ! int( (PPM_V%maxlat - PPM_V%minlat) / PPM_V%dlat) + 1
- num_lonperdepth = PPM_V%num_lonperdepth ! int( (PPM_V%maxlon - PPM_V%minlon) / PPM_V%dlon ) + 1
+ num_latperlon = PPM_num_latperlon ! int( (PPM_maxlat - PPM_minlat) / PPM_dlat) + 1
+ num_lonperdepth = PPM_num_lonperdepth ! int( (PPM_maxlon - PPM_minlon) / PPM_dlon ) + 1
- index = int( (depth-PPM_V%mindepth)/PPM_V%ddepth )*num_lonperdepth*num_latperlon &
- + int( (lon-PPM_V%minlon)/PPM_V%dlon )*num_latperlon &
- + int( (lat-PPM_V%minlat)/PPM_V%dlat ) + 1
- dvs = PPM_V%dvs(index)
+ index = int( (depth-PPM_mindepth)/PPM_ddepth )*num_lonperdepth*num_latperlon &
+ + int( (lon-PPM_minlon)/PPM_dlon )*num_latperlon &
+ + int( (lat-PPM_minlat)/PPM_dlat ) + 1
+ dvs = PPM_dvs(index)
! ! loop-wise: slower performance
- ! do i=1,PPM_V%num_v
+ ! do i=1,PPM_num_v
! ! depth
- ! r_top = PPM_V%depth(i)
- ! r_bottom = PPM_V%depth(i) + PPM_V%ddepth
+ ! r_top = PPM_depth(i)
+ ! r_bottom = PPM_depth(i) + PPM_ddepth
! if( depth > r_top .and. depth <= r_bottom ) then
! ! longitude
- ! do j=i,PPM_V%num_v
- ! if( lon >= PPM_V%lon(j) .and. lon < PPM_V%lon(j)+PPM_V%dlon ) then
+ ! do j=i,PPM_num_v
+ ! if( lon >= PPM_lon(j) .and. lon < PPM_lon(j)+PPM_dlon ) then
! ! latitude
- ! do k=j,PPM_V%num_v
- ! if( lat >= PPM_V%lat(k) .and. lat < PPM_V%lat(k)+PPM_V%dlat ) then
- ! dvs = PPM_V%dvs(k)
+ ! do k=j,PPM_num_v
+ ! if( lat >= PPM_lat(k) .and. lat < PPM_lat(k)+PPM_dlat ) then
+ ! dvs = PPM_dvs(k)
! return
! endif
! enddo
@@ -534,34 +503,26 @@
!
subroutine smooth_model(myrank, nproc_xi,nproc_eta,&
- rho_vp,rho_vs,nspec_stacey, &
- iregion_code,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore, &
- xstore,ystore,zstore,rhostore,dvpstore, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,&
- nspec,HETEROGEN_3D_MANTLE, &
- NEX_XI,NCHUNKS,ABSORBING_CONDITIONS,PPM_V )
+ rho_vp,rho_vs,nspec_stacey, &
+ iregion_code,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore, &
+ xstore,ystore,zstore,rhostore,dvpstore, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,&
+ nspec,HETEROGEN_3D_MANTLE, &
+ NEX_XI,NCHUNKS,ABSORBING_CONDITIONS )
! smooth model parameters
+ use model_ppm_par,only: &
+ PPM_maxlat,PPM_maxlon,PPM_minlat,PPM_minlon,PPM_maxdepth,PPM_mindepth
+
implicit none
include 'mpif.h'
include "constants.h"
include "precision.h"
- ! point profile model_variables
- type model_ppm_variables
- sequence
- double precision,dimension(:),pointer :: dvs,lat,lon,depth
- double precision :: maxlat,maxlon,minlat,minlon,maxdepth,mindepth
- double precision :: dlat,dlon,ddepth,max_dvs,min_dvs
- integer :: num_v,num_latperlon,num_lonperdepth
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_ppm_variables
- type (model_ppm_variables) PPM_V
-
integer :: myrank, nproc_xi, nproc_eta
integer NEX_XI
@@ -998,14 +959,14 @@
if (myrank == 0) write(IMAIN, *) 'Done with integration ...'
! gets depths (in km) of upper and lower limit
- maxlat = PPM_V%maxlat
- minlat = PPM_V%minlat
+ maxlat = PPM_maxlat
+ minlat = PPM_minlat
- maxlon = PPM_V%maxlon
- minlon = PPM_V%minlon
+ maxlon = PPM_maxlon
+ minlon = PPM_minlon
- maxdepth = PPM_V%maxdepth
- mindepth = PPM_V%mindepth
+ maxdepth = PPM_maxdepth
+ mindepth = PPM_mindepth
margin_v = sigma_v*R_EARTH/1000.0 ! in km
margin_h = sigma_h*R_EARTH/1000.0 * 180.0/(R_EARTH_KM*PI) ! in degree
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_s362ani.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_s362ani.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_s362ani.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -42,31 +42,21 @@
! calculated using REF as the 1D reference model.
!--------------------------------------------------------------------------------------------------
+ module model_s362ani_par
- subroutine model_s362ani_broadcast(myrank,THREE_D_MODEL,numker,numhpa,ihpa,&
- lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,itpspl, &
- xlaspl,xlospl,radspl,coe,hsplfl,dskker,kerstr,varstr,refmdl)
-
-! standard routine to setup model
-
- implicit none
-
- include "constants.h"
- ! standard include of the MPI library
- include 'mpif.h'
-
- integer THREE_D_MODEL
-
-! used for 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
+ ! used for 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
integer, parameter :: maxker=200
integer, parameter :: maxl=72
integer, parameter :: maxcoe=2000
integer, parameter :: maxver=1000
integer, parameter :: maxhpa=2
- integer numker
- integer numhpa !,numcof
- integer ihpa !,lmax,nylm
+ real(kind=4),dimension(:,:),allocatable :: conpt,xlaspl,xlospl,radspl,coe
+ real(kind=4),dimension(:),allocatable :: vercof,vercofd
+
+ real(kind=4),dimension(:,:),allocatable :: ylmcof
+ real(kind=4),dimension(:),allocatable :: wk1,wk2,wk3
+
integer lmxhpa(maxhpa)
integer itypehpa(maxhpa)
integer ihpakern(maxker)
@@ -74,37 +64,58 @@
integer ivarkern(maxker)
integer itpspl(maxcoe,maxhpa)
- !integer nconpt(maxhpa),iver
- !integer iconpt(maxver,maxhpa)
- !real(kind=4) conpt(maxver,maxhpa)
+ integer nconpt(maxhpa),iver
+ integer iconpt(maxver,maxhpa)
+ integer numker
+ integer numhpa,numcof
+ integer ihpa,lmax,nylm
- 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) kerstr
+ character(len=80) refmdl
+ character(len=40) varstr(maxker)
character(len=80) hsplfl(maxhpa)
character(len=40) dskker(maxker)
- !real(kind=4) vercof(maxker)
- !real(kind=4) vercofd(maxker)
+ end module model_s362ani_par
- !real(kind=4) ylmcof((maxl+1)**2,maxhpa)
- !real(kind=4) wk1(maxl+1)
- !real(kind=4) wk2(maxl+1)
- !real(kind=4) wk3(maxl+1)
+!
+!--------------------------------------------------------------------------------------------------
+!
- character(len=80) kerstr
- character(len=40) varstr(maxker)
- character(len=80) refmdl
+ subroutine model_s362ani_broadcast(myrank,THREE_D_MODEL)
+! standard routine to setup model
+
+ use model_s362ani_par
+
+ implicit none
+
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+
integer :: myrank
+ integer :: THREE_D_MODEL
integer :: ier
+ ! allocates model arrays
+ allocate(conpt(maxver,maxhpa), &
+ xlaspl(maxcoe,maxhpa), &
+ xlospl(maxcoe,maxhpa), &
+ radspl(maxcoe,maxhpa), &
+ coe(maxcoe,maxker), &
+ vercof(maxker), &
+ vercofd(maxker), &
+ ylmcof((maxl+1)**2,maxhpa), &
+ wk1(maxl+1), &
+ wk2(maxl+1), &
+ wk3(maxl+1), &
+ stat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating s362ani arrays')
+
! master process
if(myrank == 0) call read_model_s362ani(THREE_D_MODEL,THREE_D_MODEL_S362ANI,THREE_D_MODEL_S362WMANI, &
- THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA, &
- numker,numhpa,ihpa,lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,itpspl, &
- xlaspl,xlospl,radspl,coe,hsplfl,dskker,kerstr,varstr,refmdl)
+ THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA)
call MPI_BCAST(numker,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(numhpa,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
@@ -127,7 +138,6 @@
call MPI_BCAST(refmdl,80,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(varstr,40*maxker,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
-
end subroutine model_s362ani_broadcast
!
@@ -137,10 +147,10 @@
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)
+ THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA)
+ use model_s362ani_par
+
implicit none
integer THREE_D_MODEL,THREE_D_MODEL_S362ANI
@@ -153,35 +163,7 @@
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'
@@ -197,18 +179,17 @@
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)
+ 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
-
+ ! check arrays
if(numker > maxker) stop 'numker > maxker'
do ihpa=1,numhpa
if(itypehpa(ihpa) == 1) then
@@ -817,12 +798,12 @@
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)
+ maxhpa,maxker,maxcoe, &
+ numhpa,numker,numcoe,lmxhpa, &
+ ihpakern,itypehpa,coe, &
+ itpspl,xlatspl,xlonspl,radispl, &
+ numvar,ivarkern,varstr, &
+ refmdl,kerstr,hsplfl,dskker,ierror)
implicit none
@@ -1169,48 +1150,12 @@
! --- evaluate perturbations in per cent
- subroutine model_s362ani_subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv, &
- numker,numhpa,numcof,ihpa,lmax,nylm, &
- lmxhpa,itypehpa,ihpakern,numcoe,ivarkern, &
- nconpt,iver,iconpt,conpt,xlaspl,xlospl,radspl, &
- coe,vercof,vercofd,ylmcof,wk1,wk2,wk3,kerstr,varstr)
+ subroutine model_s362ani_subshsv(xcolat,xlon,xrad,dvsh,dvsv,dvph,dvpv)
+ use model_s362ani_par
+
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
@@ -1349,45 +1294,12 @@
! --- 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)
+ subroutine model_s362ani_subtopo(xcolat,xlon,topo410,topo650)
+ use model_s362ani_par
+
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
@@ -1480,7 +1392,7 @@
topo410=valu(1)
topo650=valu(2)
- end subroutine subtopo
+ end subroutine model_s362ani_subtopo
!
!-------------------------------------------------------------------------------------------------
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_sea99_s.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_sea99_s.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_sea99_s.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -40,53 +40,60 @@
! reference period: 50 s.
!--------------------------------------------------------------------------------------------------
+ module model_sea99_s_par
- subroutine model_sea99_s_broadcast(myrank,SEA99M_V)
+ double precision,dimension(:,:,:),allocatable :: sea99_vs
+ double precision,dimension(:),allocatable :: sea99_depth
+ double precision :: sea99_ddeg
+ double precision :: alatmin
+ double precision :: alatmax
+ double precision :: alonmin
+ double precision :: alonmax
+ integer :: sea99_ndep
+ integer :: sea99_nlat
+ integer :: sea99_nlon
+ end module model_sea99_s_par
+
+!
+!--------------------------------------------------------------------------------------------------
+!
+
+ subroutine model_sea99_s_broadcast(myrank)
+
! standard routine to setup model
+ use model_sea99_s_par
+
implicit none
include "constants.h"
- ! standard include of the MPI library
include 'mpif.h'
- ! model_sea99_s_variables
- type model_sea99_s_variables
- sequence
- double precision :: sea99_vs(100,100,100)
- double precision :: sea99_depth(100)
- double precision :: sea99_ddeg
- double precision :: alatmin
- double precision :: alatmax
- double precision :: alonmin
- double precision :: alonmax
- integer :: sea99_ndep
- integer :: sea99_nlat
- integer :: sea99_nlon
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_sea99_s_variables
-
- type (model_sea99_s_variables) SEA99M_V
- ! model_sea99_s_variables
-
integer :: myrank
+
integer :: ier
- if(myrank == 0) call read_sea99_s_model(SEA99M_V)
+ ! allocates model arrays
+ allocate(sea99_vs(100,100,100), &
+ sea99_depth(100), &
+ stat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating sea99 arrays')
+ ! master proc reads in values
+ if(myrank == 0) call read_sea99_s_model()
+
! 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)
+ call MPI_BCAST(sea99_ndep,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(sea99_nlat,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(sea99_nlon,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(sea99_ddeg,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(alatmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(alatmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(alonmin,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(alonmax,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(sea99_vs,100*100*100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(sea99_depth,100,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
end subroutine model_sea99_s_broadcast
@@ -94,60 +101,44 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine read_sea99_s_model(SEA99M_V)
+ subroutine read_sea99_s_model()
+ use model_sea99_s_par
+
implicit none
include "constants.h"
- ! model_sea99_s_variables
- type model_sea99_s_variables
- sequence
- double precision :: sea99_vs(100,100,100)
- double precision :: sea99_depth(100)
- double precision :: sea99_ddeg
- double precision :: alatmin
- double precision :: alatmax
- double precision :: alonmin
- double precision :: alonmax
- integer :: sea99_ndep
- integer :: sea99_nlat
- integer :: sea99_nlon
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_sea99_s_variables
+ integer :: i,ia,io,j,ier
- type (model_sea99_s_variables) SEA99M_V
- ! model_sea99_s_variables
-
- integer :: i,ia,io,j
-
!----------------------- choose input file: ------------------
! relative anomaly
- open(1,file='DATA/Lebedev_sea99/sea99_dvsvs')
+ open(1,file='DATA/Lebedev_sea99/sea99_dvsvs',status='old',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(0,'error opening file 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,*) sea99_ndep
+ read(1,*) (sea99_depth(i), i = 1, sea99_ndep)
read(1,*)
- read(1,*) SEA99M_V%alatmin, SEA99M_V%alatmax
- read(1,*) SEA99M_V%alonmin, SEA99M_V%alonmax
- read(1,*) SEA99M_V%sea99_ddeg,SEA99M_V%sea99_nlat,SEA99M_V%sea99_nlon
- if (SEA99M_V%sea99_nlat /= nint((SEA99M_V%alatmax-SEA99M_V%alatmin)/SEA99M_V%sea99_ddeg)+1) then
+ read(1,*) alatmin, alatmax
+ read(1,*) alonmin, alonmax
+ read(1,*) sea99_ddeg,sea99_nlat,sea99_nlon
+ if (sea99_nlat /= nint((alatmax-alatmin)/sea99_ddeg)+1) then
stop 'alatmin,alatmax,sea99_nlat'
endif
- if (SEA99M_V%sea99_nlon /= nint((SEA99M_V%alonmax-SEA99M_V%alonmin)/SEA99M_V%sea99_ddeg)+1) then
+ if (sea99_nlon /= nint((alonmax-alonmin)/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)
+ do j = 1, sea99_ndep
+ do ia = 1, sea99_nlat
+ read (1,*) (sea99_vs(ia,io,j), io = 1, sea99_nlon)
enddo
enddo
@@ -157,33 +148,16 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine model_sea99_s(radius,theta,phi,dvs,SEA99M_V)
+ subroutine model_sea99_s(radius,theta,phi,dvs)
! returns Vs perturbation (dvs) for given position r/theta/phi
+ use model_sea99_s_par
+
implicit none
include "constants.h"
- ! model_sea99_s_variables
- type model_sea99_s_variables
- sequence
- double precision :: sea99_vs(100,100,100)
- double precision :: sea99_depth(100)
- double precision :: sea99_ddeg
- double precision :: alatmin
- double precision :: alatmax
- double precision :: alonmin
- double precision :: alonmax
- integer :: sea99_ndep
- integer :: sea99_nlat
- integer :: sea99_nlon
- integer :: dummy_pad ! padding 4 bytes to align the structure
- end type model_sea99_s_variables
-
- type (model_sea99_s_variables) SEA99M_V
- ! model_sea99_s_variables
-
integer :: id1,i,ilat,ilon
double precision :: alat1,alon1,radius,theta,phi,dvs
double precision :: xxx,yyy,dep,pla,plo,xd1,dd1,dd2,ddd(2)
@@ -196,17 +170,17 @@
!----------------------- depth in the model ------------------
dep=R_EARTH_KM*(R_UNIT_SPHERE - radius)
- if (dep .le. SEA99M_V%sea99_depth(1)) then
+ if (dep .le. 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
+ else if (dep .ge. sea99_depth(sea99_ndep)) then
+ id1 = sea99_ndep
xd1 = 0
else
- do i = 2, SEA99M_V%sea99_ndep
- if (dep .le. SEA99M_V%sea99_depth(i)) then
+ do i = 2, sea99_ndep
+ if (dep .le. 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))
+ xd1 = (dep-sea99_depth(i-1)) / (sea99_depth(i) - sea99_depth(i-1))
exit
endif
enddo
@@ -223,22 +197,22 @@
! -20.00 45.00 -- min, max latitude
! 95.00 160.00 -- min, max longitude
! checks range
- if( pla < SEA99M_V%alatmin .or. pla > SEA99M_V%alatmax &
- .or. plo < SEA99M_V%alonmin .or. plo > SEA99M_V%alonmax ) return
+ if( pla < alatmin .or. pla > alatmax &
+ .or. plo < alonmin .or. plo > alonmax ) return
! array indices
- ilat = int((pla - SEA99M_V%alatmin)/SEA99M_V%sea99_ddeg) + 1
- ilon = int((plo - SEA99M_V%alonmin)/SEA99M_V%sea99_ddeg) + 1
- alat1 = SEA99M_V%alatmin + (ilat-1)*SEA99M_V%sea99_ddeg
- alon1 = SEA99M_V%alonmin + (ilon-1)*SEA99M_V%sea99_ddeg
+ ilat = int((pla - alatmin)/sea99_ddeg) + 1
+ ilon = int((plo - alonmin)/sea99_ddeg) + 1
+ alat1 = alatmin + (ilat-1)*sea99_ddeg
+ alon1 = alonmin + (ilon-1)*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
+ xxx = (pla-alat1)/sea99_ddeg
+ yyy = sea99_vs(ilat+1,ilon,id1+i-1)-sea99_vs(ilat,ilon,id1+i-1)
+ dd1 = sea99_vs(ilat,ilon,id1+i-1) + yyy*xxx
+ yyy = sea99_vs(ilat+1,ilon+1,id1+i-1)-sea99_vs(ilat,ilon+1,id1+i-1)
+ dd2 = sea99_vs(ilat,ilon+1,id1+i-1) + yyy*xxx
+ xxx = (plo-alon1)/sea99_ddeg
yyy = dd2 - dd1
ddd(i) = dd1 + yyy*xxx
enddo
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/moho_stretching.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/moho_stretching.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/moho_stretching.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -26,36 +26,40 @@
!=====================================================================
- subroutine moho_stretching_honor_crust(myrank,xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER,&
- R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
+ subroutine moho_stretching_honor_crust(myrank,xelm,yelm,zelm, &
+ elem_in_crust,elem_in_mantle)
! stretching the moho according to the crust 2.0
-! input: myrank, xelm, yelm, zelm, RMOHO_FICTITIOUS_IN_MESHER R220,RMIDDLE_CRUST, CM_V
+! input: myrank, xelm, yelm, zelm
! Dec, 30, 2009
+ use constants,only: &
+ NGNOD,R_EARTH_KM,R_EARTH,R_UNIT_SPHERE, &
+ PI_OVER_TWO,RADIANS_TO_DEGREES,TINYVAL,SMALLVAL,ONE
+
+ use meshfem3D_par,only: &
+ RMOHO_FICTITIOUS_IN_MESHER,R220,RMIDDLE_CRUST
+
+ use meshfem3D_models_par,only: &
+ TOPOGRAPHY
+
implicit none
- include "constants.h"
-
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
- double precision R220,RMIDDLE_CRUST
- double precision RMOHO_FICTITIOUS_IN_MESHER
integer :: myrank
+ double precision,dimension(NGNOD) :: xelm,yelm,zelm
logical :: elem_in_crust,elem_in_mantle
! local parameters
+ double precision :: r,theta,phi,lat,lon
+ double precision :: vpc,vsc,rhoc,moho,elevation,gamma
+ double precision :: x,y,z
+ double precision :: R_moho,R_middlecrust
integer:: ia,count_crust,count_mantle
- double precision:: r,theta,phi,lat,lon
- double precision:: vpc,vsc,rhoc,moho,elevation,gamma
logical:: found_crust
- double precision, parameter :: RADIANS_TO_DEGREES = 180.d0 / PI
- double precision, parameter :: PI_OVER_TWO = PI / 2.0d0
- !double precision :: stretch_factor
- double precision :: x,y,z
- double precision :: R_moho,R_middlecrust
+ ! minimum/maximum allowed moho depths (5km/90km non-dimensionalized)
+ double precision,parameter :: MOHO_MINIMUM = 5.0 / R_EARTH_KM
+ double precision,parameter :: MOHO_MAXIMUM = 90.0 / R_EARTH_KM
! radii for stretching criteria
R_moho = RMOHO_FICTITIOUS_IN_MESHER/R_EARTH
@@ -65,26 +69,42 @@
count_crust = 0
count_mantle = 0
do ia = 1,NGNOD
+ ! gets anchor point location
x = xelm(ia)
y = yelm(ia)
z = zelm(ia)
+ ! converts location to lat/lon
call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
call reduce(theta,phi)
- lat = 90.d0 - theta * RADIANS_TO_DEGREES
+ ! get geographic latitude and longitude in degrees
+ ! note: at this point, the mesh is still perfectly spherical, thus no need to
+ ! convert the geocentric colatitude to a geographic colatitude
+ lat = (PI_OVER_TWO - theta) * RADIANS_TO_DEGREES
lon = phi * RADIANS_TO_DEGREES
- if( lon > 180.d0 ) lon = lon - 360.0d0
+ if( lon > 180.0d0 ) lon = lon - 360.0d0
- ! initializes
- moho = 0.d0
-
! gets smoothed moho depth
call meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
- ! checks moho depth
- if( abs(moho) < TINYVAL ) call exit_mpi(myrank,'error moho depth to honor')
+ ! checks non-dimensionalized moho depth
+ !
+ ! note: flag found_crust returns .false. for points below moho,
+ ! nevertheless its moho depth should be set and will be used in linear stretching
+ if( moho < TINYVAL ) call exit_mpi(myrank,'error moho depth to honor')
+ ! limits moho depth to a threshold value to avoid stretching problems
+ if( moho < MOHO_MINIMUM ) then
+ print*,'moho value exceeds minimum: ',moho,MOHO_MINIMUM,'in km: ',moho*R_EARTH_KM
+ moho = MOHO_MINIMUM
+ endif
+ if( moho > MOHO_MAXIMUM ) then
+ print*,'moho value exceeds maximum: ',moho,MOHO_MAXIMUM,'in km: ',moho*R_EARTH_KM
+ moho = MOHO_MAXIMUM
+ endif
+
+ ! radius of moho depth (normalized)
moho = ONE - moho
! checks if moho will be honored by elements
@@ -92,62 +112,70 @@
! note: we will honor the moho only, if the moho depth is below R_moho (~35km)
! or above R_middlecrust (~15km). otherwise, the moho will be "interpolated"
! within the element
- if (moho < R_moho ) then
- ! actual moho below fictitious moho
- ! elements in second layer will stretch down to honor moho topography
- elevation = moho - R_moho
+ if( TOPOGRAPHY ) then
+ ! globe surface honors topography, elements stretched for moho
+ !
+ ! note: if no topography is honored, stretching may lead to distorted elements and invalid jacobian
- if ( r >= R_moho ) then
- ! point above fictitious moho
- ! gamma ranges from 0 (point at surface) to 1 (point at fictitious moho depth)
- gamma = (( R_UNIT_SPHERE - r )/( R_UNIT_SPHERE - R_moho ))
- else
- ! point below fictitious moho
- ! gamma ranges from 0 (point at R220) to 1 (point at fictitious moho depth)
- gamma = (( r - R220/R_EARTH)/( R_moho - R220/R_EARTH))
+ if (moho < R_moho ) then
+ ! actual moho below fictitious moho
+ ! elements in second layer will stretch down to honor moho topography
- ! since not all GLL points are exactlly at R220, use a small
- ! tolerance for R220 detection, fix R220
- if (abs(gamma) < SMALLVAL) then
- gamma = 0.0d0
+ elevation = moho - R_moho
+
+ if ( r >= R_moho ) then
+ ! point above fictitious moho
+ ! gamma ranges from 0 (point at surface) to 1 (point at fictitious moho depth)
+ gamma = (( R_UNIT_SPHERE - r )/( R_UNIT_SPHERE - R_moho ))
+ else
+ ! point below fictitious moho
+ ! gamma ranges from 0 (point at R220) to 1 (point at fictitious moho depth)
+ gamma = (( r - R220/R_EARTH)/( R_moho - R220/R_EARTH))
+
+ ! since not all GLL points are exactlly at R220, use a small
+ ! tolerance for R220 detection, fix R220
+ if (abs(gamma) < SMALLVAL) then
+ gamma = 0.0d0
+ end if
end if
- end if
- if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
- call exit_MPI(myrank,'incorrect value of gamma for moho from crust 2.0')
+ if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
+ call exit_MPI(myrank,'incorrect value of gamma for moho from crust 2.0')
- call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
+ call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
- else if ( moho > R_middlecrust ) then
- ! moho above middle crust
- ! elements in first layer will squeeze into crust above moho
+ else if ( moho > R_middlecrust ) then
+ ! moho above middle crust
+ ! elements in first layer will squeeze into crust above moho
- elevation = moho - R_middlecrust
+ elevation = moho - R_middlecrust
- if ( r > R_middlecrust ) then
- ! point above middle crust
- ! gamma ranges from 0 (point at surface) to 1 (point at middle crust depth)
- gamma = (R_UNIT_SPHERE-r)/(R_UNIT_SPHERE - R_middlecrust )
- else
- ! point below middle crust
- ! gamma ranges from 0 (point at R220) to 1 (point at middle crust depth)
- gamma = (r - R220/R_EARTH)/( R_middlecrust - R220/R_EARTH )
+ if ( r > R_middlecrust ) then
+ ! point above middle crust
+ ! gamma ranges from 0 (point at surface) to 1 (point at middle crust depth)
+ gamma = (R_UNIT_SPHERE-r)/(R_UNIT_SPHERE - R_middlecrust )
+ else
+ ! point below middle crust
+ ! gamma ranges from 0 (point at R220) to 1 (point at middle crust depth)
+ gamma = (r - R220/R_EARTH)/( R_middlecrust - R220/R_EARTH )
- ! since not all GLL points are exactlly at R220, use a small
- ! tolerance for R220 detection, fix R220
- if (abs(gamma) < SMALLVAL) then
- gamma = 0.0d0
+ ! since not all GLL points are exactlly at R220, use a small
+ ! tolerance for R220 detection, fix R220
+ if (abs(gamma) < SMALLVAL) then
+ gamma = 0.0d0
+ end if
end if
- end if
- if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
- call exit_MPI(myrank,'incorrect value of gamma for moho from crust 2.0')
+ if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
+ call exit_MPI(myrank,'incorrect value of gamma for moho from crust 2.0')
- call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
+ call move_point(ia,xelm,yelm,zelm,x,y,z,gamma,elevation,r)
- end if
+ end if
+ endif ! TOPOGRAPHY
+
! counts corners in above moho
! note: uses a small tolerance
if ( r >= 0.9999d0*moho ) then
@@ -184,28 +212,33 @@
!
- subroutine moho_stretching_honor_crust_reg(myrank, &
- xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER,&
- R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
+ subroutine moho_stretching_honor_crust_reg(myrank,xelm,yelm,zelm, &
+ elem_in_crust,elem_in_mantle)
! regional routine: for REGIONAL_MOHO_MESH adaptations
!
! uses a 3-layer crust region
!
! stretching the moho according to the crust 2.0
-! input: myrank, xelm, yelm, zelm, RMOHO_FICTITIOUS_IN_MESHER R220,RMIDDLE_CRUST, CM_V
+! input: myrank, xelm, yelm, zelm
! Dec, 30, 2009
+ use constants,only: &
+ NGNOD,R_EARTH_KM,R_EARTH,R_UNIT_SPHERE, &
+ PI_OVER_TWO,RADIANS_TO_DEGREES,TINYVAL,SMALLVAL,ONE,HONOR_DEEP_MOHO
+
+ use meshfem3D_par,only: &
+ RMOHO_FICTITIOUS_IN_MESHER,R220,RMIDDLE_CRUST
+
+ use meshfem3D_models_par,only: &
+ TOPOGRAPHY
+
implicit none
- include "constants.h"
+ integer :: myrank
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
- double precision R220,RMIDDLE_CRUST
- double precision RMOHO_FICTITIOUS_IN_MESHER
- integer :: myrank
+ double precision,dimension(NGNOD) :: xelm,yelm,zelm
+
logical :: elem_in_crust,elem_in_mantle
! local parameters
@@ -213,9 +246,6 @@
double precision:: r,theta,phi,lat,lon
double precision:: vpc,vsc,rhoc,moho
logical:: found_crust
-
- double precision, parameter :: RADIANS_TO_DEGREES = 180.d0 / PI
- double precision, parameter :: PI_OVER_TWO = PI / 2.0d0
double precision :: x,y,z
! loops over element's anchor points
@@ -254,11 +284,9 @@
! - below 60 km (in HONOR_DEEP_MOHO case)
! otherwise, the moho will be "interpolated" within the element
if( HONOR_DEEP_MOHO) then
- call stretch_deep_moho(ia,xelm,yelm,zelm,x,y,z,r,moho,R220, &
- RMOHO_FICTITIOUS_IN_MESHER,RMIDDLE_CRUST)
+ call stretch_deep_moho(ia,xelm,yelm,zelm,x,y,z,r,moho)
else
- call stretch_moho(ia,xelm,yelm,zelm,x,y,z,r,moho,R220, &
- RMOHO_FICTITIOUS_IN_MESHER,RMIDDLE_CRUST)
+ call stretch_moho(ia,xelm,yelm,zelm,x,y,z,r,moho)
endif
! counts corners in above moho
@@ -297,11 +325,12 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine stretch_deep_moho(ia,xelm,yelm,zelm,x,y,z,r,moho,R220, &
- RMOHO_FICTITIOUS_IN_MESHER,RMIDDLE_CRUST)
+ subroutine stretch_deep_moho(ia,xelm,yelm,zelm,x,y,z,r,moho)
! honors deep moho (below 60 km), otherwise keeps the mesh boundary at r60 fixed
+ use meshfem3D_par,only: RMOHO_FICTITIOUS_IN_MESHER,R220,RMIDDLE_CRUST
+
implicit none
include "constants.h"
@@ -314,9 +343,7 @@
double precision :: x,y,z
- double precision :: r,moho,R220
- double precision :: RMIDDLE_CRUST
- double precision :: RMOHO_FICTITIOUS_IN_MESHER
+ double precision :: r,moho
! local parameters
double precision :: elevation,gamma
@@ -448,12 +475,13 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine stretch_moho(ia,xelm,yelm,zelm,x,y,z,r,moho,R220, &
- RMOHO_FICTITIOUS_IN_MESHER,RMIDDLE_CRUST)
+ subroutine stretch_moho(ia,xelm,yelm,zelm,x,y,z,r,moho)
! honors shallow and middle depth moho, deep moho will be interpolated within elements
! mesh will get stretched down to r220
+ use meshfem3D_par,only: RMOHO_FICTITIOUS_IN_MESHER,R220,RMIDDLE_CRUST
+
implicit none
include "constants.h"
@@ -464,10 +492,8 @@
double precision yelm(NGNOD)
double precision zelm(NGNOD)
- double precision :: r,moho,R220
+ double precision :: r,moho
double precision :: x,y,z
- double precision :: RMIDDLE_CRUST
- double precision :: RMOHO_FICTITIOUS_IN_MESHER
! local parameters
double precision :: elevation,gamma
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -25,122 +25,60 @@
!
!=====================================================================
- subroutine save_arrays_solver(myrank,rho_vp,rho_vs,nspec_stacey, &
- prname,iregion_code,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
- xstore,ystore,zstore,rhostore,dvpstore, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- nspec_ani,c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- ibool,idoubling,is_on_a_slice_edge,nglob_xy,nglob, &
- rmassx,rmassy,rmassz,rmass_ocean_load,npointot_oceans, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
- normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top, &
- jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax, &
- jacobian2D_bottom,jacobian2D_top,nspec, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- TRANSVERSE_ISOTROPY,HETEROGEN_3D_MANTLE,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,OCEANS, &
- tau_s,tau_e_store,Qmu_store,T_c_source,ATTENUATION,vx,vy,vz,vnspec, &
- ABSORBING_CONDITIONS,SAVE_MESH_FILES,ispec_is_tiso)
+ subroutine save_arrays_solver(myrank,nspec,nglob,idoubling,ibool, &
+ iregion_code,xstore,ystore,zstore, &
+ is_on_a_slice_edge, &
+ NSPEC2D_TOP,NSPEC2D_BOTTOM)
- use meshfem3D_par,only: NCHUNKS
+ use constants
- implicit none
+ use meshfem3D_models_par,only: &
+ OCEANS,TRANSVERSE_ISOTROPY,HETEROGEN_3D_MANTLE,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,ATTENUATION
- include "constants.h"
+ use meshfem3D_par,only: &
+ NCHUNKS,ABSORBING_CONDITIONS,SAVE_MESH_FILES
- integer :: myrank
+ use create_regions_mesh_par2,only: &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore, &
+ rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ rmassx,rmassy,rmassz,rmass_ocean_load, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+ normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top, &
+ jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax, &
+ jacobian2D_bottom,jacobian2D_top, &
+ rho_vp,rho_vs, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ ispec_is_tiso,tau_s,T_c_source,tau_e_store,Qmu_store, &
+ prname
- character(len=150) prname
- integer iregion_code
+ implicit none
- integer nspec,nglob_xy,nglob,nspec_stacey
- integer npointot_oceans
+ integer :: myrank
+ integer :: nspec,nglob
- ! Stacey
- real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey)
- real(kind=CUSTOM_REAL) rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey)
-
- logical :: TRANSVERSE_ISOTROPY,HETEROGEN_3D_MANTLE,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS
- logical :: ATTENUATION
-
- ! arrays with jacobian matrix
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
-
- ! arrays with mesh parameters
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- ! for anisotropy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
- rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore
-
- integer nspec_ani
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_ani) :: &
- c11store,c12store,c13store,c14store,c15store,c16store, &
- c22store,c23store,c24store,c25store,c26store,c33store,c34store, &
- c35store,c36store,c44store,c45store,c46store,c55store,c56store,c66store
-
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
! doubling mesh flag
integer, dimension(nspec) :: idoubling
+ integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ integer :: iregion_code
+
+ ! arrays with the mesh in double precision
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
+
! this for non blocking MPI
logical, dimension(nspec) :: is_on_a_slice_edge
- ! mass matrices
- real(kind=CUSTOM_REAL), dimension(nglob_xy) :: rmassx,rmassy
- real(kind=CUSTOM_REAL), dimension(nglob) :: rmassz
-
- ! additional ocean load mass matrix
- real(kind=CUSTOM_REAL) rmass_ocean_load(npointot_oceans)
-
! boundary parameters locator
- integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP
+ integer :: NSPEC2D_TOP,NSPEC2D_BOTTOM
- integer ibelm_xmin(NSPEC2DMAX_XMIN_XMAX),ibelm_xmax(NSPEC2DMAX_XMIN_XMAX)
- integer ibelm_ymin(NSPEC2DMAX_YMIN_YMAX),ibelm_ymax(NSPEC2DMAX_YMIN_YMAX)
- integer ibelm_bottom(NSPEC2D_BOTTOM),ibelm_top(NSPEC2D_TOP)
-
- ! normals
- real(kind=CUSTOM_REAL) normal_xmin(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- real(kind=CUSTOM_REAL) normal_xmax(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- real(kind=CUSTOM_REAL) normal_ymin(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- real(kind=CUSTOM_REAL) normal_ymax(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- real(kind=CUSTOM_REAL) normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM)
- real(kind=CUSTOM_REAL) normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP)
-
- ! jacobian on 2D edges
- real(kind=CUSTOM_REAL) jacobian2D_xmin(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- real(kind=CUSTOM_REAL) jacobian2D_xmax(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- real(kind=CUSTOM_REAL) jacobian2D_ymin(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- real(kind=CUSTOM_REAL) jacobian2D_ymax(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- real(kind=CUSTOM_REAL) jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM)
- real(kind=CUSTOM_REAL) jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP)
-
- ! number of elements on the boundaries
- integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
-
- ! attenuation
- integer vx, vy, vz, vnspec
- double precision T_c_source
- double precision, dimension(N_SLS) :: tau_s
- double precision, dimension(vx, vy, vz, vnspec) :: Qmu_store
- double precision, dimension(N_SLS, vx, vy, vz, vnspec) :: tau_e_store
-
- logical ABSORBING_CONDITIONS,SAVE_MESH_FILES
-
- logical, dimension(nspec) :: ispec_is_tiso
-
! local parameters
integer i,j,k,ispec,iglob,nspec1,nglob1,ier
- real(kind=CUSTOM_REAL) scaleval1,scaleval2
+ real(kind=CUSTOM_REAL) :: scaleval1,scaleval2
! save nspec and nglob, to be used in combine_paraview_data
open(unit=27,file=prname(1:len_trim(prname))//'array_dims.txt', &
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/setup_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/setup_model.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/setup_model.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -30,6 +30,9 @@
use meshfem3D_par
implicit none
+ ! user output
+ if(myrank == 0) call sm_output_info()
+
! dynamic allocation of mesh arrays
allocate(addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1))
allocate(ichunk_slice(0:NPROCTOT-1))
@@ -51,10 +54,6 @@
NSPEC1D_RADIAL_CORNER,NSPEC2D_XI_FACE, &
NSPEC2D_ETA_FACE,NGLOB1D_RADIAL_CORNER)
- ! user output
- if(myrank == 0) call sm_output_info(myrank,sizeprocs,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT, &
- R_CENTRAL_CUBE)
! distributes 3D models
call meshfem3D_models_broadcast(myrank,NSPEC, &
@@ -63,9 +62,9 @@
LOCAL_PATH)
+ ! user output
if(myrank == 0 ) then
write(IMAIN,*)
- write(IMAIN,*) 'model setup successfully read in'
write(IMAIN,*)
endif
call sync_all()
@@ -76,19 +75,18 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine sm_output_info(myrank,sizeprocs,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT,&
- R_CENTRAL_CUBE)
+ subroutine sm_output_info()
use meshfem3D_models_par
+ use meshfem3D_par,only: &
+ MODEL,sizeprocs,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT, &
+ R_CENTRAL_CUBE
implicit none
- integer :: myrank,sizeprocs,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT
- double precision :: R_CENTRAL_CUBE
-
- write(IMAIN,*) 'This is process ',myrank
+ ! user output
+ write(IMAIN,*)
write(IMAIN,*) 'There are ',sizeprocs,' MPI processes'
write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
write(IMAIN,*)
@@ -108,85 +106,77 @@
write(IMAIN,*) 'Shape functions defined by NGNOD = ',NGNOD,' control nodes'
write(IMAIN,*) 'Surface shape functions defined by NGNOD2D = ',NGNOD2D,' control nodes'
write(IMAIN,*)
- write(IMAIN,*)
- write(IMAIN,*)
+
+ ! model user parameters
+ write(IMAIN,*) 'model: ',trim(MODEL)
+ if(OCEANS) then
+ write(IMAIN,*) ' incorporating the oceans using equivalent load'
+ else
+ write(IMAIN,*) ' no oceans'
+ endif
if(ELLIPTICITY) then
- write(IMAIN,*) 'incorporating ellipticity'
+ write(IMAIN,*) ' incorporating ellipticity'
else
- write(IMAIN,*) 'no ellipticity'
+ write(IMAIN,*) ' no ellipticity'
endif
- write(IMAIN,*)
if(TOPOGRAPHY) then
- write(IMAIN,*) 'incorporating surface topography'
+ write(IMAIN,*) ' incorporating surface topography'
else
- write(IMAIN,*) 'no surface topography'
+ write(IMAIN,*) ' no surface topography'
endif
- write(IMAIN,*)
- if(ISOTROPIC_3D_MANTLE) then
- write(IMAIN,*) 'incorporating 3-D lateral variations'
+ if(GRAVITY) then
+ write(IMAIN,*) ' incorporating self-gravitation (Cowling approximation)'
else
- write(IMAIN,*) 'no 3-D lateral variations'
+ write(IMAIN,*) ' no self-gravitation'
endif
- write(IMAIN,*)
- if(HETEROGEN_3D_MANTLE) then
- write(IMAIN,*) 'incorporating heterogeneities in the mantle'
+ if(ROTATION) then
+ write(IMAIN,*) ' incorporating rotation'
else
- write(IMAIN,*) 'no heterogeneities in the mantle'
+ write(IMAIN,*) ' no rotation'
endif
- write(IMAIN,*)
- if(CRUSTAL) then
- write(IMAIN,*) 'incorporating crustal variations'
+ 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 crustal variations'
+ write(IMAIN,*) ' no attenuation'
endif
write(IMAIN,*)
- if(ONE_CRUST) then
- write(IMAIN,*) 'using one layer only in PREM crust'
+
+ ! model mesh parameters
+ if(ISOTROPIC_3D_MANTLE) then
+ write(IMAIN,*) ' incorporating 3-D lateral variations'
else
- write(IMAIN,*) 'using unmodified 1D crustal model with two layers'
+ write(IMAIN,*) ' no 3-D lateral variations'
endif
- write(IMAIN,*)
- if(GRAVITY) then
- write(IMAIN,*) 'incorporating self-gravitation (Cowling approximation)'
+ if(HETEROGEN_3D_MANTLE) then
+ write(IMAIN,*) ' incorporating heterogeneities in the mantle'
else
- write(IMAIN,*) 'no self-gravitation'
+ write(IMAIN,*) ' no heterogeneities in the mantle'
endif
- write(IMAIN,*)
- if(ROTATION) then
- write(IMAIN,*) 'incorporating rotation'
+ if(CRUSTAL) then
+ write(IMAIN,*) ' incorporating crustal variations'
else
- write(IMAIN,*) 'no rotation'
+ write(IMAIN,*) ' no crustal variations'
endif
- write(IMAIN,*)
- if(TRANSVERSE_ISOTROPY) then
- write(IMAIN,*) 'incorporating anisotropy'
+ if(ONE_CRUST) then
+ write(IMAIN,*) ' using one layer only in PREM crust'
else
- write(IMAIN,*) 'no anisotropy'
+ write(IMAIN,*) ' using unmodified 1D crustal model with two layers'
endif
- write(IMAIN,*)
- if(ATTENUATION) then
- write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids'
- if(ATTENUATION_3D) write(IMAIN,*)'using 3D attenuation'
+ if(TRANSVERSE_ISOTROPY) then
+ write(IMAIN,*) ' incorporating anisotropy'
else
- write(IMAIN,*) 'no attenuation'
+ write(IMAIN,*) ' no anisotropy'
endif
- write(IMAIN,*)
- if(OCEANS) then
- write(IMAIN,*) 'incorporating the oceans using equivalent load'
- else
- write(IMAIN,*) 'no oceans'
- endif
- write(IMAIN,*)
if(ANISOTROPIC_INNER_CORE) then
- write(IMAIN,*) 'incorporating anisotropic inner core'
+ write(IMAIN,*) ' incorporating anisotropic inner core'
else
- write(IMAIN,*) 'no inner-core anisotropy'
+ write(IMAIN,*) ' no inner-core anisotropy'
endif
- write(IMAIN,*)
if(ANISOTROPIC_3D_MANTLE) then
- write(IMAIN,*) 'incorporating anisotropic mantle'
+ write(IMAIN,*) ' incorporating anisotropic mantle'
else
- write(IMAIN,*) 'no general mantle anisotropy'
+ write(IMAIN,*) ' no general mantle anisotropy'
endif
write(IMAIN,*)
write(IMAIN,*) 'Reference radius of the Earth used is ',R_EARTH_KM,' km'
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/sort_array_coordinates.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/sort_array_coordinates.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/sort_array_coordinates.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -27,7 +27,9 @@
! 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)
+ 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
@@ -36,27 +38,26 @@
include "constants.h"
- integer npointot,nglob
+ 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)
+ double precision,dimension(npointot) :: x,y,z
- integer ipoin,i,j
- integer nseg,ioff,iseg,ig
- double precision xtol
+ integer,dimension(npointot) :: ibool,iglob,loc
+ integer,dimension(npointot) :: ind,ninseg
+ logical,dimension(npointot) :: ifseg
-! establish initial pointers
+ integer,dimension(npointot) :: iwork
+ double precision,dimension(npointot) :: work
+
+ ! local parameters
+ integer :: ipoin,i,j
+ integer :: nseg,ioff,iseg,ig
+
+ ! 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
@@ -65,57 +66,53 @@
do j=1,NDIM
-! sort within each segment
- ioff=1
- do iseg=1,nseg
- if(j == 1) then
+ ! 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 rank_buffers(x(ioff),ind,ninseg(iseg))
+ 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
+ ! define a tolerance, normalized radius is 1., so let's use a small value
+ if(j == 1) then
+ do i=2,npointot
+ if(dabs(x(i)-x(i-1)) > SMALLVALTOL ) ifseg(i)=.true.
+ enddo
else if(j == 2) then
-
- call rank_buffers(y(ioff),ind,ninseg(iseg))
-
+ do i=2,npointot
+ if(dabs(y(i)-y(i-1)) > SMALLVALTOL ) ifseg(i)=.true.
+ enddo
else
-
- call rank_buffers(z(ioff),ind,ninseg(iseg))
-
+ do i=2,npointot
+ if(dabs(z(i)-z(i-1)) > SMALLVALTOL ) ifseg(i)=.true.
+ enddo
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.
+ ! 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
- 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)
+ ! assign global node numbers (now sorted lexicographically)
ig=0
do i=1,npointot
if(ifseg(i)) ig=ig+1
@@ -136,12 +133,13 @@
!
implicit none
- integer n
- double precision A(n)
- integer IND(n)
+ integer :: n
+ double precision,dimension(n) :: A
+ integer,dimension(n) :: IND
- integer i,j,l,ir,indx
- double precision q
+ ! local parameters
+ integer :: i,j,l,ir,indx
+ double precision :: q
do j=1,n
IND(j)=j
@@ -149,41 +147,49 @@
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
+ L = floor(n/2.0) + 1
+ ir = n
+
+ do while( .true. )
+
+ 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
+
+ ! checks exit criteria
if (ir == 1) then
- ind(1)=indx
+ 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
+
+ i = l
+ j = l+l
+
+ do while( J <= IR )
+ 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
+ IF ( q < A(IND(j)) ) THEN
+ IND(I) = IND(J)
+ I = J
+ J = J+J
ELSE
- J=IR+1
+ J = IR+1
ENDIF
- goto 200
- ENDIF
- IND(I)=INDX
- goto 100
+
+ enddo
+
+ IND(I)=INDX
+ enddo
+
end subroutine rank_buffers
! -------------------------------------------------------------------
@@ -194,14 +200,14 @@
!
implicit none
- integer n
+ integer :: n
+ integer,dimension(n) :: IND
+ integer,dimension(n) :: IA,IB,IW
+ double precision,dimension(n) :: A,B,C,W
- integer IND(n)
- integer IA(n),IB(n),IW(n)
- double precision A(n),B(n),C(n),W(n)
+ ! local parameter
+ integer :: i
- integer i
-
do i=1,n
W(i)=A(i)
IW(i)=IA(i)
@@ -232,4 +238,3 @@
end subroutine swap_all_buffers
-
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/stretching_function.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/stretching_function.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/stretching_function.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -25,7 +25,7 @@
!
!=====================================================================
-subroutine stretching_function(r_top,r_bottom,ner,stretch_tab)
+ 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.
!
@@ -76,14 +76,14 @@
stretch_tab(2,i) = stretch_tab(1,i+1)
enddo
-end subroutine stretching_function
+ end subroutine stretching_function
!
!-------------------------------------------------------------------------------------------------
!
-subroutine stretching_function_regional(r_top,r_bottom,ner,stretch_tab)
+ subroutine stretching_function_regional(r_top,r_bottom,ner,stretch_tab)
! define stretch_tab which contains r_top and r_bottom for each element layer in the crust for 3D models.
!
@@ -144,6 +144,6 @@
stretch_tab(2,2) = 6336000.d0 ! bottom second layer
stretch_tab(2,3) = r_bottom ! bottom third layer
-end subroutine stretching_function_regional
+ end subroutine stretching_function_regional
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/write_AVS_DX_global_chunks_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/write_AVS_DX_global_chunks_data.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/write_AVS_DX_global_chunks_data.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -27,42 +27,53 @@
! create AVS or DX 2D data for the faces of the global chunks,
! to be recombined in postprocessing
- subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun, &
- ibool,idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool, &
- npointot,rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code)
+ subroutine write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun,ibool, &
+ idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool, &
+ npointot,rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
+ ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
+ RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
+ RMIDDLE_CRUST,ROCEAN,iregion_code)
implicit none
include "constants.h"
- integer nspec,myrank
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+ integer :: myrank
+ ! processor identification
+ character(len=150) :: prname
+
+ integer :: nspec
+
+ logical iboun(6,nspec)
+
+ integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
integer idoubling(nspec)
- logical iboun(6,nspec),ELLIPTICITY,ISOTROPIC_3D_MANTLE
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
- double precision RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771, &
- R400,R120,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
+ integer :: npointot
+ ! numbering of global AVS or DX points
+ integer num_ibool_AVS_DX(npointot)
+ ! logical mask used to output global points only once
+ logical mask_ibool(npointot)
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
real(kind=CUSTOM_REAL) kappavstore(NGLLX,NGLLY,NGLLZ,nspec)
real(kind=CUSTOM_REAL) muvstore(NGLLX,NGLLY,NGLLZ,nspec)
real(kind=CUSTOM_REAL) rhostore(NGLLX,NGLLY,NGLLZ,nspec)
-! logical mask used to output global points only once
- integer npointot
- logical mask_ibool(npointot)
+ ! for ellipticity
+ integer nspl
+ double precision rspl(NR),espl(NR),espl2(NR)
-! numbering of global AVS or DX points
- integer num_ibool_AVS_DX(npointot)
+ logical ELLIPTICITY,ISOTROPIC_3D_MANTLE
+ double precision RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771, &
+ R400,R120,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
+
+ integer iregion_code
+
+ ! local parameters
integer ispec
integer i,j,k,np
integer, dimension(8) :: iglobval
@@ -75,16 +86,7 @@
double precision x,y,z,theta,phi_dummy,cost,p20,ell,factor
real(kind=CUSTOM_REAL) dvp,dvs
-! for ellipticity
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
-! processor identification
- character(len=150) prname
-
- integer iregion_code
-
-
! writing points
open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointschunks.txt',status='unknown')
open(unit=11,file=prname(1:len_trim(prname))//'AVS_DXpointschunks_stability.txt',status='unknown')
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/auto_ner.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/auto_ner.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/auto_ner.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -72,7 +72,7 @@
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) / &
+ DT = ( RADIAL_LEN_RATIO_CENTRAL_CUBE * ((WIDTH * DEGREES_TO_RADIANS ) * RADIUS_INNER_CORE) / &
( dble(NEX_MAX) / DOUBLING_INNER_CORE ) / P_VELOCITY_MAX) * &
MIN_GLL_POINT_SPACING_5 * MAXIMUM_STABILITY_CONDITION
@@ -274,8 +274,8 @@
! 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
+ wt = width * DEGREES_TO_RADIANS * r(i) / (NEX*1.0d0 / scaling(i)*1.0d0) ! Element Width Top
+ wb = width * DEGREES_TO_RADIANS * 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
@@ -334,8 +334,10 @@
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)
@@ -349,6 +351,7 @@
! 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
@@ -367,8 +370,9 @@
implicit none
+ include 'constants.h'
+
double precision, parameter :: RICB_KM = 1221.0d0
- double precision, parameter :: PI = 3.1415
integer nex_xi, ner
double precision rcube, alpha
@@ -385,10 +389,10 @@
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))
+ y = (rcube / sqrt(2.0d0)) * (1 + cos(xi) * alpha / PI_OVER_TWO)
- 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))
+ surfx = RICB_KM * cos(3 * (PI/4.0d0) - ratio_x * PI_OVER_TWO)
+ surfy = RICB_KM * sin(3 * (PI/4.0d0) - ratio_x * PI_OVER_TWO)
dist_cc_icb = sqrt((surfx -x)**2 + (surfy - y)**2)
if(ix /= nex_xi/2) then
@@ -408,9 +412,11 @@
subroutine get_element(points, ispec, npts, pts)
implicit none
+
integer npts, ispec
integer, parameter :: NBNODE = 8
double precision pts(NBNODE+1,2), points(npts,2)
+
pts(1:8,:) = points( ( (ispec-1) * NBNODE)+1 : ( (ispec) * NBNODE ), : )
pts(NBNODE+1,:) = pts(1,:) ! Use first point as the last point
@@ -423,12 +429,12 @@
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
@@ -506,7 +512,7 @@
implicit none
- double precision, parameter :: PI = 3.1415d0
+ include 'constants.h'
integer ix, iy, nbx, nby
double precision radius, alpha
@@ -522,11 +528,11 @@
factx = 2.0d0 * ratio_x - 1.0d0
facty = 2.0d0 * ratio_y - 1.0d0
- xi = (PI / 2.0d0) * factx
- eta = (PI / 2.0d0) * facty
+ xi = PI_OVER_TWO * factx
+ eta = PI_OVER_TWO * 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))
+ x = (radius / sqrt(2.0d0)) * factx * ( 1 + cos(eta) * alpha / PI_OVER_TWO )
+ y = (radius / sqrt(2.0d0)) * facty * ( 1 + cos(xi) * alpha / PI_OVER_TWO )
end subroutine compute_coordinate_central_cube
@@ -538,7 +544,8 @@
implicit none
- double precision, parameter :: PI = 3.1415d0
+ include 'constants.h'
+
double precision, parameter :: RICB_KM = 1221.0d0
integer ix, iy, nbx, nby, ic
@@ -556,13 +563,13 @@
ratio_y = (iy * 1.0d0) / (nby * 1.0d0)
factx = 2.0d0 * ratio_x - 1.0d0
- xi = (PI/2.0d0) * factx
+ xi = PI_OVER_TWO * factx
xcc = (rcube / sqrt(2.0d0)) * factx
- ycc = (rcube / sqrt(2.0d0)) * (1 + cos(xi) * alpha / (PI/2.0d0))
+ ycc = (rcube / sqrt(2.0d0)) * (1 + cos(xi) * alpha / PI_OVER_TWO)
- 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))
+ xsurf = RICB_KM * cos(3.0d0 * PI_OVER_FOUR - ratio_x * PI_OVER_TWO)
+ ysurf = RICB_KM * sin(3.0d0 * PI_OVER_FOUR - ratio_x * PI_OVER_TWO)
deltax = xsurf - xcc
deltay = ysurf - ycc
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/get_model_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/get_model_parameters.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/get_model_parameters.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -122,6 +122,8 @@
! 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.
!
+ ! CRUSTAL : flag set to .true. if a 3D crustal model (e.g. Crust-2.0) will be used or
+ ! to .false. for a 1D crustal model.
! extract ending of model name
ending = ' '
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/lagrange_poly.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/lagrange_poly.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/lagrange_poly.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -32,35 +32,37 @@
implicit none
- integer NGLL
- double precision xi,xigll(NGLL),h(NGLL),hprime(NGLL)
+ double precision :: xi
+ integer :: NGLL
+ double precision,dimension(NGLL):: xigll,h,hprime
+
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
+ 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
+ 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
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/model_topo_bathy.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/model_topo_bathy.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/model_topo_bathy.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -258,21 +258,24 @@
include "constants.h"
- ! use integer array to store values
- integer, dimension(NX_BATHY,NY_BATHY),intent(in) :: ibathy_topo
-
! location latitude/longitude (in degree)
double precision,intent(in):: xlat,xlon
! returns elevation (in meters)
double precision,intent(out):: value
+ ! use integer array to store values
+ integer, dimension(NX_BATHY,NY_BATHY),intent(in) :: ibathy_topo
+
! local parameters
integer:: iadd1,iel1
double precision:: samples_per_degree_topo
double precision:: xlo
double precision:: lon_corner,lat_corner,ratio_lon,ratio_lat
+ ! initializes elevation
+ value = ZERO
+
! longitude within range [0,360] degrees
xlo = xlon
if(xlo < 0.d0) xlo = xlo + 360.d0
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/reduce.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/reduce.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/reduce.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -33,19 +33,21 @@
include "constants.h"
- double precision theta,phi
+ double precision :: theta,phi
- integer i
- double precision th,ph
+ 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)
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/save_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/save_header_file.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/shared/save_header_file.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -29,7 +29,7 @@
subroutine save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, &
TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY, &
+ ELLIPTICITY,GRAVITY,ROTATION, &
OCEANS,ATTENUATION,ATTENUATION_NEW,ATTENUATION_3D, &
ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,NCHUNKS, &
INCLUDE_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES, &
@@ -61,7 +61,7 @@
integer NEX_XI,NEX_ETA,NPROC,NPROCTOT,NCHUNKS,NSOURCES,NSTEP
logical TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS,ATTENUATION,ATTENUATION_NEW,ATTENUATION_3D,INCLUDE_CENTRAL_CUBE
+ ELLIPTICITY,GRAVITY,ROTATION,OCEANS,ATTENUATION,ATTENUATION_NEW,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
@@ -222,12 +222,12 @@
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)))
+ colat_corner=PI_OVER_TWO-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
+ lat = (PI_OVER_TWO-colat_corner)*RADIANS_TO_DEGREES
+ long = phi_corner*RADIANS_TO_DEGREES
write(IOUT,*) '!'
write(IOUT,*) '! corner ',icorner
@@ -394,15 +394,6 @@
endif
write(IOUT,*)
- if(TOPOGRAPHY) then
- write(IOUT,*) 'integer, parameter :: NX_BATHY_VAL = NX_BATHY'
- write(IOUT,*) 'integer, parameter :: NY_BATHY_VAL = NY_BATHY'
- else
- write(IOUT,*) 'integer, parameter :: NX_BATHY_VAL = 1'
- write(IOUT,*) 'integer, parameter :: NY_BATHY_VAL = 1'
- endif
- write(IOUT,*)
-
if(ROTATION) then
write(IOUT,*) 'logical, parameter :: ROTATION_VAL = .true.'
else
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_arrays_source.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_arrays_source.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/compute_arrays_source.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -35,24 +35,25 @@
include "constants.h"
- integer ispec_selected_source,nspec
+ integer :: ispec_selected_source
- double precision xi_source,eta_source,gamma_source
- double precision Mxx,Myy,Mzz,Mxy,Mxz,Myz
+ double precision :: xi_source,eta_source,gamma_source
+ double precision :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
+
+ integer :: nspec
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
+ ! 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
+ ! local parameters
+ double precision :: xixd,xiyd,xizd,etaxd,etayd,etazd,gammaxd,gammayd,gammazd
+ ! 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
@@ -61,21 +62,33 @@
integer k,l,m
-! calculate G_ij for general source location
-! the source does not necessarily correspond to a Gauss-Lobatto point
+ ! 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))
+ if( CUSTOM_REAL == SIZE_REAL ) then
+ 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))
+ else
+ xixd = xix(k,l,m,ispec_selected_source)
+ xiyd = xiy(k,l,m,ispec_selected_source)
+ xizd = xiz(k,l,m,ispec_selected_source)
+ etaxd = etax(k,l,m,ispec_selected_source)
+ etayd = etay(k,l,m,ispec_selected_source)
+ etazd = etaz(k,l,m,ispec_selected_source)
+ gammaxd = gammax(k,l,m,ispec_selected_source)
+ gammayd = gammay(k,l,m,ispec_selected_source)
+ gammazd = gammaz(k,l,m,ispec_selected_source)
+ endif
G11(k,l,m) = Mxx*xixd+Mxy*xiyd+Mxz*xizd
G12(k,l,m) = Mxx*etaxd+Mxy*etayd+Mxz*etazd
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/initialize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/initialize_simulation.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/initialize_simulation.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -198,44 +198,77 @@
tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
write(IMAIN,*)
- write(IMAIN,*) 'model:'
+ ! model user parameters
+ write(IMAIN,*) 'model: ',trim(MODEL)
+ if(OCEANS) then
+ write(IMAIN,*) ' incorporating the oceans using equivalent load'
+ else
+ write(IMAIN,*) ' no oceans'
+ endif
+ if(ELLIPTICITY) then
+ write(IMAIN,*) ' incorporating ellipticity'
+ else
+ write(IMAIN,*) ' no ellipticity'
+ endif
+ if(TOPOGRAPHY) then
+ write(IMAIN,*) ' incorporating surface topography'
+ else
+ write(IMAIN,*) ' no surface topography'
+ endif
+ if(GRAVITY) then
+ write(IMAIN,*) ' incorporating self-gravitation (Cowling approximation)'
+ else
+ write(IMAIN,*) ' no self-gravitation'
+ endif
+ if(ROTATION) then
+ write(IMAIN,*) ' incorporating rotation'
+ else
+ write(IMAIN,*) ' no rotation'
+ endif
+ 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,*)
+ ! model mesh parameters
if(ISOTROPIC_3D_MANTLE) then
- write(IMAIN,*) ' incorporates 3-D lateral variations'
+ write(IMAIN,*) ' incorporating 3-D lateral variations'
else
write(IMAIN,*) ' no 3-D lateral variations'
endif
if(HETEROGEN_3D_MANTLE) then
- write(IMAIN,*) ' incorporates heterogeneities in the mantle'
+ write(IMAIN,*) ' incorporating heterogeneities in the mantle'
else
write(IMAIN,*) ' no heterogeneities in the mantle'
endif
if(CRUSTAL) then
- write(IMAIN,*) ' incorporates crustal variations'
+ write(IMAIN,*) ' incorporating crustal variations'
else
write(IMAIN,*) ' no crustal variations'
endif
if(ONE_CRUST) then
- write(IMAIN,*) ' uses one layer only in PREM crust'
+ write(IMAIN,*) ' using one layer only in PREM crust'
else
- write(IMAIN,*) ' uses unmodified 1D crustal model with two layers'
+ write(IMAIN,*) ' using unmodified 1D crustal model with two layers'
endif
if(TRANSVERSE_ISOTROPY) then
- write(IMAIN,*) ' incorporates transverse isotropy'
+ write(IMAIN,*) ' incorporating transverse isotropy'
else
write(IMAIN,*) ' no transverse isotropy'
endif
- if(ANISOTROPIC_INNER_CORE_VAL) then
- write(IMAIN,*) ' incorporates anisotropic inner core'
+ if(ANISOTROPIC_INNER_CORE) then
+ write(IMAIN,*) ' incorporating anisotropic inner core'
else
write(IMAIN,*) ' no inner-core anisotropy'
endif
- if(ANISOTROPIC_3D_MANTLE_VAL) then
- write(IMAIN,*) ' incorporates anisotropic mantle'
+ if(ANISOTROPIC_3D_MANTLE) then
+ write(IMAIN,*) ' incorporating anisotropic mantle'
else
write(IMAIN,*) ' no general mantle anisotropy'
endif
-
write(IMAIN,*)
write(IMAIN,*)
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/iterate_time.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/iterate_time.F90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/iterate_time.F90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -489,7 +489,7 @@
! rval = xstore_crust_mantle(indx(1))
! thetaval = ystore_crust_mantle(indx(1))
! phival = zstore_crust_mantle(indx(1))
- ! !thetaval = PI/2.0d0-datan(1.006760466d0*dcos(dble(thetaval))/dmax1(TINYVAL,dsin(dble(thetaval))))
+ ! !thetaval = PI_OVER_TWO-datan(1.006760466d0*dcos(dble(thetaval))/dmax1(TINYVAL,dsin(dble(thetaval))))
! print*,'r/lat/lon:',rval*R_EARTH_KM,90.0-thetaval*180./PI,phival*180./PI
! call rthetaphi_2_xyz(rval,thetaval,phival,xstore_crust_mantle(indx(1)),&
! ystore_crust_mantle(indx(1)),zstore_crust_mantle(indx(1)))
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/locate_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/locate_receivers.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/locate_receivers.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -242,17 +242,17 @@
! convert geographic latitude stlat (degrees) to geocentric colatitude theta (radians)
if(ASSUME_PERFECT_SPHERE) then
- theta = PI/2.0d0 - stlat(irec)*PI/180.0d0
+ theta = PI_OVER_TWO - stlat(irec)*DEGREES_TO_RADIANS
else
- theta = PI/2.0d0 - atan(0.99329534d0*dtan(stlat(irec)*PI/180.0d0))
+ theta = PI_OVER_TWO - atan(0.99329534d0*dtan(stlat(irec)*DEGREES_TO_RADIANS))
endif
- phi = stlon(irec)*PI/180.0d0
+ phi = stlon(irec)*DEGREES_TO_RADIANS
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
+ sin(theta)*sin(theta_source)*cos(phi-phi_source))*RADIANS_TO_DEGREES
! print some information about stations
if(myrank == 0) &
@@ -280,8 +280,8 @@
endif
! get the orientation of the seismometer
- thetan=(90.0d0+stdip)*PI/180.0d0
- phin=stazi*PI/180.0d0
+ thetan=(90.0d0+stdip)*DEGREES_TO_RADIANS
+ phin=stazi*DEGREES_TO_RADIANS
! we use the same convention as in Harvard normal modes for the orientation
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/locate_sources.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/locate_sources.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/locate_sources.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -233,12 +233,12 @@
! convert geographic latitude lat (degrees) to geocentric colatitude theta (radians)
if(ASSUME_PERFECT_SPHERE) then
- theta = PI/2.0d0 - lat(isource)*PI/180.0d0
+ theta = PI_OVER_TWO - lat(isource)*DEGREES_TO_RADIANS
else
- theta = PI/2.0d0 - atan(0.99329534d0*dtan(lat(isource)*PI/180.0d0))
+ theta = PI_OVER_TWO - atan(0.99329534d0*dtan(lat(isource)*DEGREES_TO_RADIANS))
endif
- phi = long(isource)*PI/180.0d0
+ phi = long(isource)*DEGREES_TO_RADIANS
call reduce(theta,phi)
! get the moment tensor
@@ -287,8 +287,8 @@
endif
! get the orientation of the seismometer
- thetan=(90.0d0+stdip)*PI/180.0d0
- phin=stazi*PI/180.0d0
+ thetan=(90.0d0+stdip)*DEGREES_TO_RADIANS
+ phin=stazi*DEGREES_TO_RADIANS
! we use the same convention as in Harvard normal modes for the orientation
@@ -673,7 +673,7 @@
call reduce(theta_source(isource),phi_source(isource))
! convert geocentric to geographic colatitude
- colat_source = PI/2.0d0 &
+ colat_source = PI_OVER_TWO &
- 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
@@ -688,8 +688,8 @@
! 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,*) ' latitude: ',(PI_OVER_TWO-colat_source)*RADIANS_TO_DEGREES
+ write(IMAIN,*) ' longitude: ',phi_source(isource)*RADIANS_TO_DEGREES
write(IMAIN,*) ' depth: ',(r0-r_found_source)*R_EARTH/1000.0d0,' km'
write(IMAIN,*)
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/multiply_arrays_source.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/multiply_arrays_source.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/multiply_arrays_source.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -38,17 +38,19 @@
include "constants.h"
-! source arrays
+ ! 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 :: k,l,m
- integer ir,it,iv
+ ! local parameters
+ integer :: ir,it,iv
+ ! initializes
sourcearrayd(:,k,l,m) = ZERO
do iv=1,NGLLZ
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_arrays_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_arrays_solver.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_arrays_solver.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -28,36 +28,31 @@
! read arrays created by the mesher
subroutine read_arrays_solver(iregion_code,myrank, &
+ nspec,nglob,nglob_xy, &
+ nspec_iso,nspec_tiso,nspec_ani, &
rho_vp,rho_vs,xstore,ystore,zstore, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
rhostore, kappavstore,muvstore,kappahstore,muhstore,eta_anisostore, &
- nspec_iso,nspec_tiso,nspec_ani, &
c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- ibool,idoubling,ispec_is_tiso,nglob_xy,nglob, &
- rmassx,rmassy,rmassz,rmass_ocean_load,nspec, &
- READ_KAPPA_MU,READ_TISO,TRANSVERSE_ISOTROPY, &
- ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS,LOCAL_PATH,ABSORBING_CONDITIONS)
+ ibool,idoubling,ispec_is_tiso, &
+ rmassx,rmassy,rmassz,rmass_ocean_load, &
+ READ_KAPPA_MU,READ_TISO, &
+ ABSORBING_CONDITIONS,LOCAL_PATH)
implicit none
include "constants.h"
-
include "OUTPUT_FILES/values_from_mesher.h"
- integer iregion_code,myrank
+ integer :: iregion_code,myrank
+ integer :: nspec,nglob,nglob_xy
+ integer :: nspec_iso,nspec_tiso,nspec_ani
- ! flags to know if we should read Vs and anisotropy arrays
- logical READ_KAPPA_MU,READ_TISO,TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,OCEANS,ABSORBING_CONDITIONS
+ ! Stacey
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,nspec):: rho_vp,rho_vs
- character(len=150) LOCAL_PATH
-
- integer nspec,nglob,nglob_xy
-
- integer nspec_iso,nspec_tiso,nspec_ani
-
real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
@@ -79,28 +74,27 @@
c22store,c23store,c24store,c25store,c26store,c33store,c34store, &
c35store,c36store,c44store,c45store,c46store,c55store,c56store,c66store
- ! Stacey
- real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) rho_vs(NGLLX,NGLLY,NGLLZ,nspec)
+ ! global addressing
+ integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ integer, dimension(nspec) :: idoubling
+ logical, dimension(nspec) :: ispec_is_tiso
! mass matrices and additional ocean load mass matrix
- real(kind=CUSTOM_REAL), dimension(nglob) :: rmass_ocean_load
-
real(kind=CUSTOM_REAL), dimension(nglob_xy) :: rmassx,rmassy
real(kind=CUSTOM_REAL), dimension(nglob) :: rmassz
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
- ! global addressing
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+ ! flags to know if we should read Vs and anisotropy arrays
+ logical :: READ_KAPPA_MU,READ_TISO, &
+ ABSORBING_CONDITIONS
- integer, dimension(nspec) :: idoubling
+ character(len=150) :: LOCAL_PATH
- logical, dimension(nspec) :: ispec_is_tiso
-
! local parameters
integer :: ier
logical,dimension(nspec) :: dummy_l
! processor identification
- character(len=150) prname
+ character(len=150) :: prname
! create the name for the database of the current slide and region
call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
@@ -126,13 +120,13 @@
if(READ_KAPPA_MU) read(IIN) muvstore
! for anisotropy, gravity and rotation
- if(TRANSVERSE_ISOTROPY .and. READ_TISO) then
+ if(TRANSVERSE_ISOTROPY_VAL .and. READ_TISO) then
read(IIN) kappahstore
read(IIN) muhstore
read(IIN) eta_anisostore
endif
- if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then
+ if(ANISOTROPIC_INNER_CORE_VAL .and. iregion_code == IREGION_INNER_CORE) then
read(IIN) c11store
read(IIN) c12store
read(IIN) c13store
@@ -140,7 +134,7 @@
read(IIN) c44store
endif
- if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
+ if(ANISOTROPIC_3D_MANTLE_VAL .and. iregion_code == IREGION_CRUST_MANTLE) then
read(IIN) c11store
read(IIN) c12store
read(IIN) c13store
@@ -192,7 +186,7 @@
read(IIN) rmassz
! read additional ocean load mass matrix
- if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) read(IIN) rmass_ocean_load
+ if(OCEANS_VAL .and. iregion_code == IREGION_CRUST_MANTLE) read(IIN) rmass_ocean_load
close(IIN)
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_mesh_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_mesh_databases.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_mesh_databases.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -96,13 +96,9 @@
integer :: nspec_iso,nspec_tiso,nspec_ani,NGLOB_XY
logical :: READ_KAPPA_MU,READ_TISO
! dummy array that does not need to be actually read
- integer, dimension(:),allocatable :: dummy_i
+ integer, dimension(:),allocatable :: dummy_idoubling
integer :: ier
- ! allocates dummy array
- allocate(dummy_i(NSPEC_CRUST_MANTLE),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating dummy_i array in read_mesh_databases_CM')
-
! crust and mantle
if(ANISOTROPIC_3D_MANTLE_VAL) then
READ_KAPPA_MU = .false.
@@ -139,15 +135,21 @@
NGLOB_XY = 1
endif
- allocate(rmassx_crust_mantle(NGLOB_XY),stat=ier)
- if(ier /= 0) stop 'error in allocate 21'
- allocate(rmassy_crust_mantle(NGLOB_XY),stat=ier)
- if(ier /= 0) stop 'error in allocate 21'
+ ! allocates dummy array
+ allocate(dummy_idoubling(NSPEC_CRUST_MANTLE),stat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating dummy idoubling in crust_mantle')
+
+ ! allocates mass matrices
+ allocate(rmassx_crust_mantle(NGLOB_XY), &
+ rmassy_crust_mantle(NGLOB_XY),stat=ier)
+ if(ier /= 0) stop 'error allocating dummy rmassx, rmassy in crust_mantle'
allocate(rmassz_crust_mantle(NGLOB_CRUST_MANTLE),stat=ier)
- if(ier /= 0) stop 'error in allocate 21'
+ if(ier /= 0) stop 'error allocating rmassz in crust_mantle'
! reads databases file
call read_arrays_solver(IREGION_CRUST_MANTLE,myrank, &
+ NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE,NGLOB_XY, &
+ nspec_iso,nspec_tiso,nspec_ani, &
rho_vp_crust_mantle,rho_vs_crust_mantle, &
xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
@@ -155,7 +157,6 @@
gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle, &
kappahstore_crust_mantle,muhstore_crust_mantle,eta_anisostore_crust_mantle, &
- nspec_iso,nspec_tiso,nspec_ani, &
c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
c14store_crust_mantle,c15store_crust_mantle,c16store_crust_mantle, &
c22store_crust_mantle,c23store_crust_mantle,c24store_crust_mantle, &
@@ -163,17 +164,17 @@
c34store_crust_mantle,c35store_crust_mantle,c36store_crust_mantle, &
c44store_crust_mantle,c45store_crust_mantle,c46store_crust_mantle, &
c55store_crust_mantle,c56store_crust_mantle,c66store_crust_mantle, &
- ibool_crust_mantle,dummy_i,ispec_is_tiso_crust_mantle,NGLOB_XY,NGLOB_CRUST_MANTLE, &
- rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle,rmass_ocean_load,NSPEC_CRUST_MANTLE, &
- READ_KAPPA_MU,READ_TISO,TRANSVERSE_ISOTROPY_VAL,ANISOTROPIC_3D_MANTLE_VAL, &
- ANISOTROPIC_INNER_CORE_VAL,OCEANS_VAL,LOCAL_PATH,ABSORBING_CONDITIONS)
+ ibool_crust_mantle,dummy_idoubling,ispec_is_tiso_crust_mantle, &
+ rmassx_crust_mantle,rmassy_crust_mantle,rmassz_crust_mantle,rmass_ocean_load, &
+ READ_KAPPA_MU,READ_TISO, &
+ ABSORBING_CONDITIONS,LOCAL_PATH)
! 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')
- deallocate(dummy_i)
+ deallocate(dummy_idoubling)
end subroutine read_mesh_databases_CM
@@ -212,9 +213,11 @@
! dummy allocation
NGLOB_XY = 1
- allocate(dummy_rmass(NGLOB_XY))
- allocate(dummy_ispec_is_tiso(NSPEC_OUTER_CORE))
- allocate(dummy_idoubling_outer_core(NSPEC_OUTER_CORE))
+ allocate(dummy_rmass(NGLOB_XY), &
+ dummy_ispec_is_tiso(NSPEC_OUTER_CORE), &
+ dummy_idoubling_outer_core(NSPEC_OUTER_CORE), &
+ stat=ier)
+ if(ier /= 0) stop 'error allocating dummy rmass and dummy ispec/idoubling in outer core'
! allocates mass matrices in this slice (will be fully assembled in the solver)
!
@@ -225,9 +228,11 @@
! if absorbing_conditions are not set or if NCHUNKS=6, only one mass matrix is needed
! for the sake of performance, only "rmassz" array will be filled and "rmassx" & "rmassy" will be obsolete
allocate(rmass_outer_core(NGLOB_OUTER_CORE),stat=ier)
- if(ier /= 0) stop 'error in allocate 21'
+ if(ier /= 0) stop 'error allocating rmass in outer core'
call read_arrays_solver(IREGION_OUTER_CORE,myrank, &
+ NSPEC_OUTER_CORE,NGLOB_OUTER_CORE,NGLOB_XY, &
+ nspec_iso,nspec_tiso,nspec_ani, &
vp_outer_core,dummy_array, &
xstore_outer_core,ystore_outer_core,zstore_outer_core, &
xix_outer_core,xiy_outer_core,xiz_outer_core, &
@@ -235,7 +240,6 @@
gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
rhostore_outer_core,kappavstore_outer_core,dummy_array, &
dummy_array,dummy_array,dummy_array, &
- nspec_iso,nspec_tiso,nspec_ani, &
dummy_array,dummy_array,dummy_array, &
dummy_array,dummy_array,dummy_array, &
dummy_array,dummy_array,dummy_array, &
@@ -243,14 +247,12 @@
dummy_array,dummy_array,dummy_array, &
dummy_array,dummy_array,dummy_array, &
dummy_array,dummy_array,dummy_array, &
- ibool_outer_core,dummy_idoubling_outer_core,dummy_ispec_is_tiso,NGLOB_XY,NGLOB_OUTER_CORE, &
- dummy_rmass,dummy_rmass,rmass_outer_core,rmass_ocean_load,NSPEC_OUTER_CORE, &
- READ_KAPPA_MU,READ_TISO,TRANSVERSE_ISOTROPY_VAL,ANISOTROPIC_3D_MANTLE_VAL, &
- ANISOTROPIC_INNER_CORE_VAL,OCEANS_VAL,LOCAL_PATH,ABSORBING_CONDITIONS)
+ ibool_outer_core,dummy_idoubling_outer_core,dummy_ispec_is_tiso, &
+ dummy_rmass,dummy_rmass,rmass_outer_core,rmass_ocean_load, &
+ READ_KAPPA_MU,READ_TISO, &
+ ABSORBING_CONDITIONS,LOCAL_PATH)
- deallocate(dummy_idoubling_outer_core)
- deallocate(dummy_ispec_is_tiso)
- deallocate(dummy_rmass)
+ deallocate(dummy_idoubling_outer_core,dummy_ispec_is_tiso,dummy_rmass)
! check that the number of points in this slice is correct
if(minval(ibool_outer_core(:,:,:,:)) /= 1 .or. &
@@ -296,8 +298,10 @@
! dummy allocation
NGLOB_XY = 1
- allocate(dummy_rmass(NGLOB_XY))
- allocate(dummy_ispec_is_tiso(NSPEC_INNER_CORE))
+ allocate(dummy_rmass(NGLOB_XY), &
+ dummy_ispec_is_tiso(NSPEC_INNER_CORE), &
+ stat=ier)
+ if(ier /= 0) stop 'error allocating dummy rmass and dummy ispec in inner core'
! allocates mass matrices in this slice (will be fully assembled in the solver)
!
@@ -308,9 +312,11 @@
! if absorbing_conditions are not set or if NCHUNKS=6, only one mass matrix is needed
! for the sake of performance, only "rmassz" array will be filled and "rmassx" & "rmassy" will be obsolete
allocate(rmass_inner_core(NGLOB_INNER_CORE),stat=ier)
- if(ier /= 0) stop 'error in allocate 21'
+ if(ier /= 0) stop 'error allocating rmass in inner core'
call read_arrays_solver(IREGION_INNER_CORE,myrank, &
+ NSPEC_INNER_CORE,NGLOB_INNER_CORE,NGLOB_XY, &
+ nspec_iso,nspec_tiso,nspec_ani, &
dummy_array,dummy_array, &
xstore_inner_core,ystore_inner_core,zstore_inner_core, &
xix_inner_core,xiy_inner_core,xiz_inner_core, &
@@ -318,7 +324,6 @@
gammax_inner_core,gammay_inner_core,gammaz_inner_core, &
rhostore_inner_core,kappavstore_inner_core,muvstore_inner_core, &
dummy_array,dummy_array,dummy_array, &
- nspec_iso,nspec_tiso,nspec_ani, &
c11store_inner_core,c12store_inner_core,c13store_inner_core, &
dummy_array,dummy_array,dummy_array, &
dummy_array,dummy_array,dummy_array, &
@@ -326,13 +331,12 @@
dummy_array,dummy_array,dummy_array, &
c44store_inner_core,dummy_array,dummy_array, &
dummy_array,dummy_array,dummy_array, &
- ibool_inner_core,idoubling_inner_core,dummy_ispec_is_tiso,NGLOB_XY,NGLOB_INNER_CORE, &
- dummy_rmass,dummy_rmass,rmass_inner_core,rmass_ocean_load,NSPEC_INNER_CORE, &
- READ_KAPPA_MU,READ_TISO,TRANSVERSE_ISOTROPY_VAL,ANISOTROPIC_3D_MANTLE_VAL, &
- ANISOTROPIC_INNER_CORE_VAL,OCEANS_VAL,LOCAL_PATH,ABSORBING_CONDITIONS)
+ ibool_inner_core,idoubling_inner_core,dummy_ispec_is_tiso, &
+ dummy_rmass,dummy_rmass,rmass_inner_core,rmass_ocean_load, &
+ READ_KAPPA_MU,READ_TISO, &
+ ABSORBING_CONDITIONS,LOCAL_PATH)
- deallocate(dummy_ispec_is_tiso)
- deallocate(dummy_rmass)
+ deallocate(dummy_ispec_is_tiso,dummy_rmass)
! check that the number of points in this slice is correct
if(minval(ibool_inner_core(:,:,:,:)) /= 1 .or. maxval(ibool_inner_core(:,:,:,:)) /= NGLOB_INNER_CORE) &
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_topography_bathymetry.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_topography_bathymetry.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_topography_bathymetry.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -52,6 +52,10 @@
! read topography and bathymetry file
if( TOPOGRAPHY ) then
+ ! allocates topography array
+ allocate(ibathy_topo(NX_BATHY,NY_BATHY),stat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating ibathy_topo array')
+
! initializes
ibathy_topo(:,:) = 0
@@ -65,7 +69,7 @@
endif
! broadcast the information read on the master to the nodes
- call MPI_BCAST(ibathy_topo,NX_BATHY_VAL*NY_BATHY_VAL,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(ibathy_topo,NX_BATHY*NY_BATHY,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
endif
! user output
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/setup_sources_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/setup_sources_receivers.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/setup_sources_receivers.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -104,8 +104,6 @@
allocate(nu_source(NDIM,NDIM,NSOURCES),stat=ier)
if( ier /= 0 ) call exit_MPI(myrank,'error allocating source arrays')
- call sync_all()
-
! sources
! BS BS moved open statement and writing of first lines into sr.vtk before the
! call to locate_sources, where further write statements to that file follow
@@ -128,7 +126,8 @@
xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
ELLIPTICITY_VAL,min_tshift_cmt_original)
- if(abs(minval(tshift_cmt)) > TINYVAL) call exit_MPI(myrank,'one tshift_cmt must be zero, others must be positive')
+ if(abs(minval(tshift_cmt)) > TINYVAL) &
+ call exit_MPI(myrank,'one tshift_cmt must be zero, others must be positive')
! count number of sources located in this slice
nsources_local = 0
@@ -234,8 +233,6 @@
elat_SAC,elon_SAC,depth_SAC,mb_SAC,cmt_lat_SAC,&
cmt_lon_SAC,cmt_depth_SAC,cmt_hdur_SAC,NSOURCES)
- call sync_all()
-
end subroutine setup_sources
!
@@ -288,7 +285,6 @@
endif
write(IMAIN,*)
endif
- call sync_all()
! locate receivers in the crust in the mesh
call locate_receivers(NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE,ibool_crust_mantle, &
@@ -396,7 +392,10 @@
! frees arrays
deallocate(theta_source,phi_source)
- call sync_all()
+ ! topography array no more needed
+ if( TOPOGRAPHY ) then
+ if(allocated(ibathy_topo) ) deallocate(ibathy_topo)
+ endif
end subroutine setup_receivers
@@ -462,6 +461,7 @@
! source interpolated on all GLL points in source element
allocate(sourcearrays(NDIM,NGLLX,NGLLY,NGLLZ,NSOURCES),stat=ier)
if( ier /= 0 ) call exit_MPI(myrank,'error allocating sourcearrays')
+ sourcearrays(:,:,:,:,:) = 0._CUSTOM_REAL
! stores source arrays
call setup_sources_receivers_srcarr()
@@ -482,7 +482,8 @@
if(nadj_rec_local > 0) then
! allocate adjoint source arrays
- allocate(adj_sourcearrays(NDIM,NGLLX,NGLLY,NGLLZ,nadj_rec_local,NTSTEP_BETWEEN_READ_ADJSRC),stat=ier)
+ allocate(adj_sourcearrays(NDIM,NGLLX,NGLLY,NGLLZ,nadj_rec_local,NTSTEP_BETWEEN_READ_ADJSRC), &
+ stat=ier)
if( ier /= 0 ) call exit_MPI(myrank,'error allocating adjoint sourcearrays')
adj_sourcearrays(:,:,:,:,:,:) = 0._CUSTOM_REAL
@@ -516,6 +517,9 @@
do isource = 1,NSOURCES
+ ! initializes
+ sourcearray(:,:,:,:) = 0._CUSTOM_REAL
+
! check that the source slice number is okay
if(islice_selected_source(isource) < 0 .or. islice_selected_source(isource) > NPROCTOT_VAL-1) &
call exit_MPI(myrank,'something is wrong with the source slice number')
@@ -538,7 +542,6 @@
nint(gamma_source(isource)), &
ispec_selected_source(isource))
! sets sourcearrays
- sourcearray(:,:,:,:) = 0.0
ispec = ispec_selected_source(isource)
do k=1,NGLLZ
do j=1,NGLLY
@@ -555,6 +558,7 @@
! stores source excitations
sourcearrays(:,:,:,:,isource) = sourcearray(:,:,:,:)
endif
+
enddo
end subroutine setup_sources_receivers_srcarr
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/specfem3D_par.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/specfem3D_par.F90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/specfem3D_par.F90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -48,6 +48,28 @@
implicit none
!-----------------------------------------------------------------
+ ! GLL points & weights
+ !-----------------------------------------------------------------
+
+ ! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll,wxgll
+ double precision, dimension(NGLLY) :: yigll,wygll
+ double precision, dimension(NGLLZ) :: zigll,wzgll
+
+ ! product of weights for gravity term
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
+
+ ! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xxT,hprimewgll_xxT
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+
+ !-----------------------------------------------------------------
! attenuation parameters
!-----------------------------------------------------------------
@@ -61,7 +83,7 @@
!-----------------------------------------------------------------
! use integer array to store values
- integer, dimension(NX_BATHY_VAL,NY_BATHY_VAL) :: ibathy_topo
+ integer, dimension(:,:),allocatable :: ibathy_topo
! additional mass matrix for ocean load
real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
@@ -103,23 +125,6 @@
minus_deriv_gravity_table,density_table,d_ln_density_dr_table,minus_rho_g_over_kappa_fluid
!-----------------------------------------------------------------
- ! time scheme
- !-----------------------------------------------------------------
-
- integer :: it
-
- ! Newmark time scheme parameters and non-dimensionalization
- double precision :: scale_t,scale_t_inv,scale_displ,scale_veloc
- real(kind=CUSTOM_REAL) :: deltat,deltatover2,deltatsqover2
- ! ADJOINT
- real(kind=CUSTOM_REAL) :: b_deltat,b_deltatover2,b_deltatsqover2
-
-#ifdef _HANDOPT
- integer :: imodulo_NGLOB_CRUST_MANTLE,imodulo_NGLOB_CRUST_MANTLE4, &
- imodulo_NGLOB_INNER_CORE,imodulo_NGLOB_OUTER_CORE
-#endif
-
- !-----------------------------------------------------------------
! sources
!-----------------------------------------------------------------
@@ -182,34 +187,17 @@
cmt_lat_SAC,cmt_lon_SAC,cmt_depth_SAC,cmt_hdur_SAC,sec_SAC
character(len=20) :: event_name_SAC
-
!-----------------------------------------------------------------
- ! GLL points & weights
- !-----------------------------------------------------------------
-
- ! Gauss-Lobatto-Legendre points of integration and weights
- double precision, dimension(NGLLX) :: xigll,wxgll
- double precision, dimension(NGLLY) :: yigll,wygll
- double precision, dimension(NGLLZ) :: zigll,wzgll
-
- ! product of weights for gravity term
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
-
- ! array with derivatives of Lagrange polynomials and precalculated products
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xxT,hprimewgll_xxT
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
- real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
-
-
- !-----------------------------------------------------------------
! file parameters
!-----------------------------------------------------------------
! parameters read from parameter file
+ double precision DT,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
+ ANGULAR_WIDTH_XI_IN_DEGREES
+
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, &
@@ -219,12 +207,6 @@
NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,SIMULATION_TYPE, &
MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
- double precision DT,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
- ANGULAR_WIDTH_XI_IN_DEGREES
-
logical ONE_CRUST,TOPOGRAPHY,MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,SAVE_FORWARD, &
@@ -311,6 +293,23 @@
integer(kind=8) :: Mesh_pointer
logical :: GPU_MODE
+ !-----------------------------------------------------------------
+ ! time scheme
+ !-----------------------------------------------------------------
+
+ integer :: it
+
+ ! Newmark time scheme parameters and non-dimensionalization
+ double precision :: scale_t,scale_t_inv,scale_displ,scale_veloc
+ real(kind=CUSTOM_REAL) :: deltat,deltatover2,deltatsqover2
+ ! ADJOINT
+ real(kind=CUSTOM_REAL) :: b_deltat,b_deltatover2,b_deltatsqover2
+
+#ifdef _HANDOPT
+ integer :: imodulo_NGLOB_CRUST_MANTLE,imodulo_NGLOB_CRUST_MANTLE4, &
+ imodulo_NGLOB_INNER_CORE,imodulo_NGLOB_OUTER_CORE
+#endif
+
end module specfem_par
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/write_seismograms.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/write_seismograms.f90 2012-08-02 08:59:14 UTC (rev 20554)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/write_seismograms.f90 2012-08-03 22:16:21 UTC (rev 20555)
@@ -427,8 +427,8 @@
phi = backaz
endif
- cphi=cos(phi*pi/180)
- sphi=sin(phi*pi/180)
+ cphi=cos(phi*DEGREES_TO_RADIANS)
+ sphi=sin(phi*DEGREES_TO_RADIANS)
! BS BS do the rotation of the components and put result in
! new variable seismogram_tmp
More information about the CIG-COMMITS
mailing list