[cig-commits] r16371 - seismo/3D/SPECFEM3D_GLOBE/trunk
dkomati1 at geodynamics.org
dkomati1 at geodynamics.org
Wed Mar 3 10:07:24 PST 2010
Author: dkomati1
Date: 2010-03-03 10:07:17 -0800 (Wed, 03 Mar 2010)
New Revision: 16371
Modified:
seismo/3D/SPECFEM3D_GLOBE/trunk/INSTALL
seismo/3D/SPECFEM3D_GLOBE/trunk/README_SPECFEM3D_GLOBE
seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_410_650.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/auto_ner.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/broadcast_compute_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/calc_jacobian.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/calendar.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/check_simulation_stability.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/combine_AVS_DX.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/combine_vol_data.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_add_sources.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_arrays_source.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_coupling.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_element_properties.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle_Dev.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core_Dev.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core_Dev.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_kernels.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_seismograms.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_crust_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_outer_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_central_cube.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_doubling_elements.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_mass_matrices.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_AVS_DX.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_GMT_global.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_regions_mesh.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/create_regular_elements.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_cutplanes_xi.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_cmt.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_ellipticity.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_event_info.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_global.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_jacobian_boundaries.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/get_model_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/initialize_simulation.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/intgrl.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/locate_receivers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/meshfem3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/meshfem3D_models.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_1066a.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_1dref.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_ak135.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_inner_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_atten3D_QRFSI12.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_attenuation.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_crust.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_crustmaps.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_eucrust.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_gll.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_heterogen_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_iasp91.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_jp1d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_jp3d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_ppm.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_prem.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_s20rts.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_s362ani.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_sea1d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_sea99_s.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/model_topo_bathy.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/moho_stretching.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/prepare_timerun.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/read_compute_parameters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/read_forward_arrays.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/read_mesh_databases.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/read_parameter_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/rthetaphi_xyz.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/save_arrays_solver.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/save_forward_arrays.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/save_header_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/save_kernels.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/setup_sources_receivers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/specfem3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/stretching_function.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_chunks_data.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_data.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_surface.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_volume.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/write_seismograms.f90
Log:
removed useless white spaces at the end of lines (using a script)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/INSTALL
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/INSTALL 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/INSTALL 2010-03-03 18:07:17 UTC (rev 16371)
@@ -7,7 +7,7 @@
!=======================================================================!
Instructions on how to install and use SPECFEM3D_GLOBE are
-available in the manual located in directory USERS_MANUAL.
+available in the manual located in directory USER_MANUAL.
Main developers: Dimitri Komatitsch, Jeroen Tromp, Qinya Liu and David Michea.
@@ -64,7 +64,7 @@
the created files 'constant.h' and 'Makefile' satisfy
your needs.
- more information is given in the manual provided in USERS_MANUAL.
+ more information is given in the manual provided in USER_MANUAL.
3. compile the package:
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/README_SPECFEM3D_GLOBE
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/README_SPECFEM3D_GLOBE 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/README_SPECFEM3D_GLOBE 2010-03-03 18:07:17 UTC (rev 16371)
@@ -7,7 +7,7 @@
!=======================================================================!
Instructions on how to install and use SPECFEM3D_GLOBE are
-available in the manual located in directory USERS_MANUAL.
+available in the manual located in directory USER_MANUAL.
Main developers: Dimitri Komatitsch, Jeroen Tromp, Qinya Liu and David Michea.
@@ -16,7 +16,7 @@
------------
In order to compile the package on your system, please consult the
-manual located in directory USERS_MANUAL and the file './INSTALL' within this
+manual located in directory USER_MANUAL and the file './INSTALL' within this
package directory.
@@ -115,4 +115,4 @@
well done!
-
\ No newline at end of file
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -114,7 +114,7 @@
integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
double precision:: R220
- ! local parameters used in this subroutine
+ ! local parameters used in this subroutine
integer:: i,j,k
double precision:: r,theta,phi,colat
double precision:: lat,lon,elevation,gamma
@@ -154,19 +154,19 @@
! also make sure factor makes sense
if(gamma < -0.02 .or. gamma > 1.02) then
call exit_MPI(myrank,'incorrect value of factor for topography gll points')
- end if
+ end if
!
! since not all GLL points are exactlly at R220, use a small
! tolerance for R220 detection
if (abs(gamma) < SMALLVAL) then
gamma = 0.0
- end if
+ end if
xstore(i,j,k,ispec) = xstore(i,j,k,ispec)*(ONE + gamma * elevation / r)
ystore(i,j,k,ispec) = ystore(i,j,k,ispec)*(ONE + gamma * elevation / r)
zstore(i,j,k,ispec) = zstore(i,j,k,ispec)*(ONE + gamma * elevation / r)
- end do
- end do
+ end do
+ end do
end do
end subroutine add_topography_gll
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_410_650.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_410_650.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/add_topography_410_650.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -243,7 +243,7 @@
if(gamma < -0.0001 .or. gamma > 1.0001) call exit_MPI(myrank,'incorrect value of gamma for 410-650 topography')
enddo
- end do
+ end do
end do
end subroutine add_topography_410_650_gll
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/auto_ner.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/auto_ner.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/auto_ner.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -51,7 +51,7 @@
!
subroutine auto_time_stepping(WIDTH, NEX_MAX, DT)
-
+
implicit none
include 'constants.h'
@@ -156,7 +156,7 @@
logical CASE_3D,CRUSTAL,HONOR_1D_SPHERICAL_MOHO
integer REFERENCE_1D_MODEL
- ! local parameters
+ ! local parameters
integer, parameter :: NUM_REGIONS = 14
integer, dimension(NUM_REGIONS) :: scaling
double precision, dimension(NUM_REGIONS) :: radius
@@ -208,7 +208,7 @@
radius(12) = 2511000.0d0 ! 3860 - 3rd Mesh Doubling Interface
radius(13) = 1371000.0d0 ! 5000 - 4th Mesh Doubling Interface
radius(14) = 982000.0d0 ! Top Central Cube
-
+
! radii in km
radius(:) = radius(:) / 1000.0d0
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/broadcast_compute_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/broadcast_compute_parameters.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/broadcast_compute_parameters.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -53,18 +53,18 @@
this_region_has_a_doubling,rmins,rmaxs, &
ratio_divide_central_cube,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
- REFERENCE_1D_MODEL,THREE_D_MODEL,ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE)
-
+
implicit none
! standard include of the MPI library
include 'mpif.h'
include "constants.h"
include "precision.h"
-
+
integer myrank
! parameters read from parameter file
@@ -89,7 +89,7 @@
SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT,&
OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY,&
ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE
-
+
character(len=150) LOCAL_PATH,MODEL
! parameters to be computed based upon parameters above read from file
@@ -102,7 +102,7 @@
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ratio_sampling_array,ner
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
-
+
double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
@@ -116,9 +116,9 @@
integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
! mesh model parameters
- integer REFERENCE_1D_MODEL,THREE_D_MODEL
+ integer REFERENCE_1D_MODEL,THREE_D_MODEL
- logical ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
+ logical ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE
@@ -128,7 +128,7 @@
integer, dimension(38) :: bcast_integer
logical, dimension(35) :: bcast_logical
integer ier
-
+
! master process prepares broadcasting arrays
if (myrank==0) then
! count the total number of sources in the CMTSOLUTION file
@@ -201,7 +201,7 @@
! non-master processes set their parameters
if (myrank /=0) then
-
+
! please, be careful with ordering and counting here
! integers
MIN_ATTENUATION_PERIOD = bcast_integer(1)
@@ -242,7 +242,7 @@
MOVIE_START = bcast_integer(36)
MOVIE_STOP = bcast_integer(37)
NSOURCES = bcast_integer(38)
-
+
! logicals
TRANSVERSE_ISOTROPY = bcast_logical(1)
ANISOTROPIC_3D_MANTLE = bcast_logical(2)
@@ -314,5 +314,5 @@
RMOHO_FICTITIOUS_IN_MESHER = bcast_double_precision(31)
endif
-
+
end subroutine broadcast_compute_parameters
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/calc_jacobian.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/calc_jacobian.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/calc_jacobian.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -26,19 +26,19 @@
!=====================================================================
!
!> Hejun
-! This subroutine recomputes the 3D jacobian for one element
-! based upon 125 GLL points
+! This subroutine recomputes the 3D jacobian for one element
+! based upon 125 GLL points
! Hejun Zhu OCT16,2009
! input: myrank,
! xstore,ystore,zstore ----- input GLL point coordinate
! xigll,yigll,zigll ----- gll points position
-! ispec,nspec ----- element number
+! ispec,nspec ----- element number
! ACTUALLY_STORE_ARRAYS ------ save array or not
-! output: xixstore,xiystore,xizstore,
+! output: xixstore,xiystore,xizstore,
! etaxstore,etaystore,etazstore,
-! gammaxstore,gammaystore,gammazstore ------ parameters used to calculate jacobian
+! gammaxstore,gammaystore,gammazstore ------ parameters used to calculate jacobian
subroutine recalc_jacobian_gll3D(myrank,xstore,ystore,zstore,xigll,yigll,zigll,&
@@ -80,7 +80,7 @@
double precision:: r,theta,phi
- ! test parameters which can be deleted
+ ! test parameters which can be deleted
double precision:: xmesh,ymesh,zmesh
double precision:: sumshape,sumdershapexi,sumdershapeeta,sumdershapegamma
@@ -88,7 +88,7 @@
do k=1,NGLLZ
do j=1,NGLLY
do i=1,NGLLX
-
+
xxi = 0.0
xeta = 0.0
xgamma = 0.0
@@ -103,7 +103,7 @@
eta = yigll(j)
gamma = zigll(k)
- ! calculate lagrange polynomial and its derivative
+ ! 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)
@@ -116,8 +116,8 @@
xmesh = 0.0
ymesh = 0.0
zmesh = 0.0
-
+
do k1 = 1,NGLLZ
do j1 = 1,NGLLY
do i1 = 1,NGLLX
@@ -126,7 +126,7 @@
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
@@ -139,48 +139,48 @@
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
+ ! 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
+ 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
+ ! Check the lagrange polynomial and its derivative
if (xmesh /=xstore(i,j,k,ispec).or.ymesh/=ystore(i,j,k,ispec)&
.or.zmesh/=zstore(i,j,k,ispec)) then
call exit_MPI(myrank,'new mesh are wrong in recalc_jacobian_gall3D.f90')
- end if
+ 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
+ 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
+ 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
+ end if
+ if(abs(sumdershapegamma) > TINYVAL) then
call exit_MPI(myrank,'error derivative gamma in recalc_jacobian_gll3D.f90')
- end if
-
+ end if
+
jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
xeta*(yxi*zgamma-ygamma*zxi) + &
xgamma*(yxi*zeta-yeta*zxi)
- ! Check the jacobian
- if(jacobian <= ZERO) then
+ ! Check the jacobian
+ if(jacobian <= ZERO) then
call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r,theta,phi)
print*,'r/lat/lon:',r*R_EARTH_KM,90.0-theta*180./PI,phi*180./PI
call exit_MPI(myrank,'3D Jacobian undefined in recalc_jacobian_gll3D.f90')
- end if
+ end if
! invert the relation (Fletcher p. 50 vol. 2)
xix = (yeta*zgamma-ygamma*zeta) / jacobian
@@ -218,7 +218,7 @@
gammaystore(i,j,k,ispec) = gammay
gammazstore(i,j,k,ispec) = gammaz
endif
- end if
+ end if
enddo
enddo
enddo
@@ -237,7 +237,7 @@
! input parameters: myrank,ispecb,
! xelm2D,yelm2D,zelm2D,
! xigll,yigll,NSPEC2DMAX_AB,NGLLA,NGLLB
-
+
! output results: jacobian2D,normal
subroutine recalc_jacobian_gll2D(myrank,ispecb, &
xelm2D,yelm2D,zelm2D,xigll,yigll,&
@@ -256,7 +256,7 @@
real(kind=CUSTOM_REAL),dimension(3,NGLLA,NGLLB,NSPEC2DMAX_AB)::normal
- ! local parameters in this subroutine
+ ! 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,&
@@ -279,7 +279,7 @@
call lagrange_any(xi,NGLLA,xigll,hxir,hpxir)
call lagrange_any(eta,NGLLB,yigll,hetar,hpetar)
-
+
xmesh = 0.0
ymesh = 0.0
zmesh = 0.0
@@ -294,7 +294,7 @@
xxi = xxi + xelm2D(i1,j1)*hlagrange_xi
xeta = xeta + xelm2D(i1,j1)*hlagrange_eta
-
+
yxi = yxi + yelm2D(i1,j1)*hlagrange_xi
yeta = yeta + yelm2D(i1,j1)*hlagrange_eta
@@ -307,25 +307,25 @@
sumshape = sumshape + hlagrange
sumdershapexi = sumdershapexi + hlagrange_xi
sumdershapeeta = sumdershapeeta + hlagrange_eta
- end do
+ end do
end do
- ! Check the lagrange polynomial
+ ! Check the lagrange polynomial
if (xmesh/=xelm2D(i,j).or.ymesh/=yelm2D(i,j).or.zmesh/=zelm2D(i,j)) then
call exit_MPI(myrank,'new boundary mesh is wrong in recalc_jacobian_gll2D')
- end if
-
+ end if
+
if (abs(sumshape-one) > TINYVAL) then
call exit_MPI(myrank,'error shape functions in recalc_jacobian_gll2D')
- end if
- if (abs(sumdershapexi) > TINYVAL) then
+ end if
+ if (abs(sumdershapexi) > TINYVAL) then
call exit_MPI(myrank,'error derivative xi in recalc_jacobian_gll2D')
- end if
+ end if
if (abs(sumdershapeeta) > TINYVAL) then
call exit_MPI(myrank,'error derivative eta in recalc_jacobian_gll2D')
- end if
-
+ end if
+
unx = yxi*zeta - yeta*zxi
uny = zxi*xeta - zeta*xxi
unz = xxi*yeta - xeta*yxi
@@ -343,14 +343,14 @@
normal(2,i,j,ispecb)=uny/jacobian
normal(3,i,j,ispecb)=unz/jacobian
endif
- end do
- end do
-
+ end do
+ end do
+
end subroutine recalc_jacobian_gll2D
-
+
!
!-------------------------------------------------------------------------------------------------
-!
+!
! deprecated...
!
! subroutine calc_jacobian(myrank,xixstore,xiystore,xizstore, &
@@ -435,14 +435,14 @@
! 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)
+! 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'
+! print*,'maybe check with CAP smoothing'
! call exit_MPI(myrank,'3D Jacobian undefined')
! endif
!
@@ -495,4 +495,4 @@
! end subroutine calc_jacobian
!
-
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/calendar.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/calendar.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/calendar.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -75,8 +75,8 @@
! (tested with dates: Feb, 23 2010 -> idaywk = Tue
! Dec, 24 2009 -> idaywk = Thu
! Oct, 15 1582 -> idaywk = Fri ...which all look o.k. )
- integer, parameter :: ioptn = 3
-
+ integer, parameter :: ioptn = 3
+
! Input/Output variables
integer, intent(inout) :: iday,month,iyear,idayct
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/check_simulation_stability.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/check_simulation_stability.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/check_simulation_stability.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -30,9 +30,9 @@
eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
COMPUTE_AND_STORE_STRAIN,myrank)
-
+
implicit none
-
+
include 'mpif.h'
include "constants.h"
include "precision.h"
@@ -40,7 +40,7 @@
! time step
integer it,NSTEP,myrank
-
+
! displacement
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: displ_crust_mantle
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: displ_inner_core
@@ -61,7 +61,7 @@
double precision :: time_start,DT,t0
logical COMPUTE_AND_STORE_STRAIN
-
+
! local parameters
! maximum of the norm of the displacement and of the potential in the fluid
real(kind=CUSTOM_REAL) Usolidnorm,Usolidnorm_all,Ufluidnorm,Ufluidnorm_all
@@ -70,7 +70,7 @@
! names of the data files for all the processors in MPI
character(len=150) outputname
! timer MPI
- double precision :: tCPU,t_remain,t_total
+ double precision :: tCPU,t_remain,t_total
integer :: ihours,iminutes,iseconds,int_tCPU, &
ihours_remain,iminutes_remain,iseconds_remain,int_t_remain, &
ihours_total,iminutes_total,iseconds_total,int_t_total
@@ -87,10 +87,10 @@
timestamp_remote,year_remote,mon_remote,day_remote,hr_remote,minutes_remote,day_of_week_remote
integer :: ier
integer, external :: idaywk
-
+
double precision,parameter :: scale_displ = R_EARTH
-
+
! compute maximum of norm of displacement in each slice
Usolidnorm = max( &
maxval(sqrt(displ_crust_mantle(1,:)**2 + &
@@ -104,7 +104,7 @@
MPI_COMM_WORLD,ier)
call MPI_REDUCE(Ufluidnorm,Ufluidnorm_all,1,CUSTOM_MPI_TYPE,MPI_MAX,0, &
MPI_COMM_WORLD,ier)
-
+
if (SIMULATION_TYPE == 3) then
b_Usolidnorm = max( &
maxval(sqrt(b_displ_crust_mantle(1,:)**2 + &
@@ -140,13 +140,13 @@
Usolidnorm_all = Usolidnorm_all * sngl(scale_displ)
write(IMAIN,*) 'Max norm displacement vector U in solid in all slices (m) = ',Usolidnorm_all
write(IMAIN,*) 'Max non-dimensional potential Ufluid in fluid in all slices = ',Ufluidnorm_all
-
+
if (SIMULATION_TYPE == 3) then
b_Usolidnorm_all = b_Usolidnorm_all * sngl(scale_displ)
write(IMAIN,*) 'Max norm displacement vector U in solid in all slices for back prop.(m) = ',b_Usolidnorm_all
write(IMAIN,*) 'Max non-dimensional potential Ufluid in fluid in all slices for back prop.= ',b_Ufluidnorm_all
endif
-
+
if(COMPUTE_AND_STORE_STRAIN) then
write(IMAIN,*) 'Max of strain, eps_trace_over_3_crust_mantle =',Strain_norm_all
write(IMAIN,*) 'Max of strain, epsilondev_crust_mantle =',Strain2_norm_all
@@ -333,14 +333,14 @@
call exit_MPI(myrank,'forward simulation became unstable and blew up in the solid')
if(Ufluidnorm_all > STABILITY_THRESHOLD .or. Ufluidnorm_all < 0) &
call exit_MPI(myrank,'forward simulation became unstable and blew up in the fluid')
-
+
if(SIMULATION_TYPE == 3) then
if(b_Usolidnorm_all > STABILITY_THRESHOLD .or. b_Usolidnorm_all < 0) &
call exit_MPI(myrank,'backward simulation became unstable and blew up in the solid')
if(b_Ufluidnorm_all > STABILITY_THRESHOLD .or. b_Ufluidnorm_all < 0) &
call exit_MPI(myrank,'backward simulation became unstable and blew up in the fluid')
endif
-
+
endif
-
+
end subroutine check_simulation_stability
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/combine_AVS_DX.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/combine_AVS_DX.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/combine_AVS_DX.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -557,7 +557,7 @@
open(unit=12,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='old',action='read')
!if(icolor == 5 .or. icolor == 6) &
! open(unit=13,file=prname(1:len_trim(prname))//'AVS_DXelementschunks_dvp_dvs.txt',status='old',action='read')
-
+
endif
read(10,*) nspec
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/combine_vol_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/combine_vol_data.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/combine_vol_data.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -52,15 +52,15 @@
real x, y, z, dat
integer numpoin, iglob, n1, n2, n3, n4, n5, n6, n7, n8
integer iglob1, iglob2, iglob3, iglob4, iglob5, iglob6, iglob7, iglob8
-
- !daniel: instead of taking the first value which appears for a global point, average the values
- ! if there are more than one gll points for a global point (points on element corners, edges, faces)
+
+ !daniel: instead of taking the first value which appears for a global point, average the values
+ ! if there are more than one gll points for a global point (points on element corners, edges, faces)
logical,parameter:: AVERAGE_GLOBALPOINTS = .false.
integer:: ibool_count(NGLOB_CRUST_MANTLE)
real(kind=CUSTOM_REAL):: ibool_dat(NGLOB_CRUST_MANTLE)
-
-
+
+
! starts here--------------------------------------------------------------------------------------------------
do i = 1, 7
call getarg(i,arg(i))
@@ -103,7 +103,7 @@
print*,'no file: ',trim(arg(1))
stop 'Error opening slices file'
endif
-
+
do while (1 == 1)
read(20,'(a)',iostat=ios) sline
if (ios /= 0) exit
@@ -135,13 +135,13 @@
di = 1; dj = 1; dk = 1
else if( ires == 2 ) then
HIGH_RESOLUTION_MESH = .false.
- di = (NGLLX-1)/2.0; dj = (NGLLY-1)/2.0; dk = (NGLLZ-1)/2.0
+ di = (NGLLX-1)/2.0; dj = (NGLLY-1)/2.0; dk = (NGLLZ-1)/2.0
endif
if( HIGH_RESOLUTION_MESH ) then
print *, ' high resolution ', HIGH_RESOLUTION_MESH
else
- print *, ' low resolution ', HIGH_RESOLUTION_MESH
- endif
+ print *, ' low resolution ', HIGH_RESOLUTION_MESH
+ endif
do ir = irs, ire
print *, '----------- Region ', ir, '----------------'
@@ -173,7 +173,7 @@
print*,'file:',trim(dimension_file)
stop 'Error opening file'
endif
-
+
read(27,*) nspec(it)
read(27,*) nglob(it)
close(27)
@@ -183,7 +183,7 @@
else if( ires == 0 ) then
nelement(it) = nspec(it)
else if (ires == 2 ) then
- nelement(it) = nspec(it) * (NGLLX-1) * (NGLLY-1) * (NGLLZ-1) / 8
+ nelement(it) = nspec(it) * (NGLLX-1) * (NGLLY-1) * (NGLLZ-1) / 8
endif
enddo
@@ -200,8 +200,8 @@
do it = 1, num_node
iproc = node_list(it)
-
-
+
+
print *, ' '
print *, 'Reading slice ', iproc
write(prname_topo,'(a,i6.6,a,i1,a)') trim(in_topo_dir)//'/proc',iproc,'_reg',ir,'_'
@@ -219,11 +219,11 @@
data(:,:,:,:) = -1.e10
read(27) data(:,:,:,1:nspec(it))
close(27)
-
+
print *,trim(data_file)
print *,' min/max value: ',minval(data(:,:,:,1:nspec(it))),maxval(data(:,:,:,1:nspec(it)))
print *
-
+
! topology file
topo_file = trim(prname_topo) // 'solver_data_2' // '.bin'
open(unit = 28,file = trim(topo_file),status='old',action='read', iostat = ios, form='unformatted')
@@ -241,19 +241,19 @@
read(28) zstore(1:nglob(it))
read(28) ibool(:,:,:,1:nspec(it))
close(28)
-
+
print *, trim(topo_file)
!average data on global points
- ibool_count(:) = 0
+ ibool_count(:) = 0
ibool_dat(:) = 0.0
if( AVERAGE_GLOBALPOINTS ) then
do ispec=1,nspec(it)
do k = 1, NGLLZ, dk
do j = 1, NGLLY, dj
do i = 1, NGLLX, di
- iglob = ibool(i,j,k,ispec)
+ iglob = ibool(i,j,k,ispec)
dat = data(i,j,k,ispec)
@@ -274,7 +274,7 @@
num_ibool(:) = 0
numpoin = 0
-
+
! write point file
do ispec=1,nspec(it)
do k = 1, NGLLZ, dk
@@ -282,7 +282,7 @@
do i = 1, NGLLX, di
iglob = ibool(i,j,k,ispec)
if( iglob == -1 ) cycle
-
+
! takes the averaged data value for mesh
if( AVERAGE_GLOBALPOINTS ) then
if(.not. mask_ibool(iglob)) then
@@ -290,15 +290,15 @@
x = xstore(iglob)
y = ystore(iglob)
z = zstore(iglob)
-
+
!dat = data(i,j,k,ispec)
dat = ibool_dat(iglob)
-
+
call write_real_fd(pfd,x)
call write_real_fd(pfd,y)
call write_real_fd(pfd,z)
call write_real_fd(pfd,dat)
-
+
mask_ibool(iglob) = .true.
num_ibool(iglob) = numpoin
endif
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_add_sources.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_add_sources.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_add_sources.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -31,7 +31,7 @@
islice_selected_source,ispec_selected_source,it)
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
@@ -48,9 +48,9 @@
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
- integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
+ integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
integer :: it
-
+
! local parameters
double precision :: stf
real(kind=CUSTOM_REAL) :: stf_used
@@ -59,7 +59,7 @@
do isource = 1,NSOURCES
-
+
! add only if this proc carries the source
if(myrank == islice_selected_source(isource)) then
@@ -73,15 +73,15 @@
endif
! add source array
- ispec = ispec_selected_source(isource)
+ ispec = ispec_selected_source(isource)
do k=1,NGLLZ
do j=1,NGLLY
do i=1,NGLLX
iglob = ibool_crust_mantle(i,j,k,ispec)
-
+
accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) &
+ sourcearrays(:,i,j,k,isource)*stf_used
-
+
enddo
enddo
enddo
@@ -89,13 +89,13 @@
endif
enddo
-
+
end subroutine compute_add_sources
-
+
!
!-------------------------------------------------------------------------------------------------
!
-
+
subroutine compute_add_sources_adjoint(myrank,nrec, &
nadj_rec_local,NSTEP,NTSTEP_BETWEEN_READ_ADJSRC, &
accel_crust_mantle,adj_sourcearrays, &
@@ -106,7 +106,7 @@
it,it_begin,station_name,network_name)
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
@@ -117,7 +117,7 @@
real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ,nadj_rec_local,NTSTEP_BETWEEN_READ_ADJSRC) :: &
adj_sourcearrays
-
+
double precision, dimension(NDIM,NDIM,nrec) :: nu
double precision, dimension(nrec) :: xi_receiver,eta_receiver,gamma_receiver
double precision, dimension(NGLLX) :: xigll
@@ -131,18 +131,18 @@
integer, dimension(NSTEP_SUB_ADJ) :: iadjsrc_len
integer, dimension(NSTEP_SUB_ADJ,2) :: iadjsrc ! to read input in chunks
integer, dimension(NSTEP) :: iadj_vec
-
+
integer :: it,it_begin,itime
character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
-
- ! local parameters
+
+ ! local parameters
real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: adj_sourcearray
integer :: irec,irec_local,i,j,k,iglob,it_sub_adj
character(len=150) :: adj_source_file
logical :: ibool_read_adj_arrays
-
+
! figure out if we need to read in a chunk of the adjoint source at this timestep
it_sub_adj = ceiling( dble(it)/dble(NTSTEP_BETWEEN_READ_ADJSRC) ) !chunk_number
ibool_read_adj_arrays = (((it == it_begin) .or. (mod(it-1,NTSTEP_BETWEEN_READ_ADJSRC) == 0)) &
@@ -154,7 +154,7 @@
! temporary source array
allocate(adj_sourcearray(NDIM,NGLLX,NGLLY,NGLLZ,NTSTEP_BETWEEN_READ_ADJSRC))
adj_sourcearray = 0._CUSTOM_REAL
-
+
irec_local = 0
do irec = 1, nrec
! check that the source slice number is okay
@@ -166,7 +166,7 @@
! compute source arrays
if(myrank == islice_selected_rec(irec)) then
irec_local = irec_local + 1
-
+
! reads in **sta**.**net**.**LH**.adj files
adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
call compute_arrays_source_adjoint(myrank,adj_source_file, &
@@ -180,14 +180,14 @@
do itime = 1,NTSTEP_BETWEEN_READ_ADJSRC
adj_sourcearrays(:,:,:,:,irec_local,itime) = adj_sourcearray(:,:,:,:,itime)
enddo
-
+
endif
enddo
if(irec_local /= nadj_rec_local) &
call exit_MPI(myrank,'irec_local /= nadj_rec_local in adjoint simulation')
-
- deallocate(adj_sourcearray)
-
+
+ deallocate(adj_sourcearray)
+
endif
irec_local = 0
@@ -202,8 +202,8 @@
do j=1,NGLLY
do i=1,NGLLX
iglob = ibool_crust_mantle(i,j,k,ispec_selected_rec(irec))
-
-
+
+
! adds adjoint source acting at this time step (it):
!
! note: we use index iadj_vec(it) which is the corresponding time step
@@ -211,37 +211,37 @@
!
! see routine: setup_sources_receivers_adjindx() how this adjoint index array is set up
!
- ! e.g. total length NSTEP = 3000, chunk length NTSTEP_BETWEEN_READ_ADJSRC= 1000
+ ! e.g. total length NSTEP = 3000, chunk length NTSTEP_BETWEEN_READ_ADJSRC= 1000
! then for it=1,..1000, first block has iadjsrc(1,1) with start = 2001 and end = 3000;
- ! corresponding iadj_vec(it) goes from
- ! iadj_vec(1) = 1000, iadj_vec(2) = 999 to iadj_vec(1000) = 1,
+ ! corresponding iadj_vec(it) goes from
+ ! iadj_vec(1) = 1000, iadj_vec(2) = 999 to iadj_vec(1000) = 1,
! that is, originally the idea was
! adj_sourcearrays(.. iadj_vec(1) ) corresponds to adjoint source trace at time index 3000
! adj_sourcearrays(.. iadj_vec(2) ) corresponds to adjoint source trace at time index 2999
! ..
! adj_sourcearrays(.. iadj_vec(1000) ) corresponds to adjoint source trace at time index 2001
! then a new block will be read, etc, and it is going down till to adjoint source trace at time index 1
- !
+ !
! now comes the tricky part:
! adjoint source traces are based on the seismograms from the forward run;
! such seismograms have a time step index 1 which corresponds to time -t0
! then time step index 2 which corresponds to -t0 + DT, and
! the last time step in the file at time step NSTEP corresponds to time -t0 + (NSTEP-1)*DT
- ! (see how we add the sources to the simulation in compute_add_sources() and
+ ! (see how we add the sources to the simulation in compute_add_sources() and
! how we write/save the seismograms and wavefields at the end of the time loop).
!
! then you use that seismogram and take e.g. the velocity of it for a travetime adjoint source
!
- ! now we read it in again, and remember the last time step in
+ ! now we read it in again, and remember the last time step in
! the file at NSTEP corresponds to -t0 + (NSTEP-1)*DT
- !
+ !
! the same time step is saved for the forward wavefields to reconstruct them;
! however, the Newark time scheme acts at the very beginning of this time loop
! such that we have the backward/reconstructed wavefield updated by
! a single time step into the direction -DT and b_displ(it=1) corresponds to -t0 + (NSTEP-1)*DT - DT
! after the Newark (predictor) time step update.
!
- ! for the kernel calculations, we want:
+ ! for the kernel calculations, we want:
! adjoint wavefield at time t, starting from 0 to T
! and forward wavefield at time T-t, starting from T down to 0
! let's say time 0 corresponds to -t0 = -t0 + (it - 1)*DT at it=1
@@ -250,17 +250,17 @@
! as seen before, the time for the forward wavefield b_displ(it=1) would then
! correspond to time -t0 + (NSTEP-1)*DT - DT, which is T - DT.
! the corresponding time for the adjoint wavefield thus would be 0 + DT
- ! and the adjoint source index would be iadj_vec(it+1)
+ ! and the adjoint source index would be iadj_vec(it+1)
! however, iadj_vec(it+1) which would go from 999 down to 0. 0 is out of bounds.
! we thus have to read in the adjoint source trace beginning from 2999 down to 0.
! index 0 is not defined in the adjoint source trace, let's just set it to zero.
!
- ! for this reason, we use iadj_vec(it) from 1000 down to 1, but
- ! pointing to the indices in the adjoint source trace from 2999 down to 0 (virtually zero).
+ ! for this reason, we use iadj_vec(it) from 1000 down to 1, but
+ ! pointing to the indices in the adjoint source trace from 2999 down to 0 (virtually zero).
! i guess by now everyone is confused. see how we read in the adjoint source trace
! in routine compute_arrays_source_adjoint() and note that there is a shift of indices.
! then the following should be correct...
- accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) &
+ accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) &
+ adj_sourcearrays(:,i,j,k,irec_local,iadj_vec(it))
enddo
@@ -269,22 +269,22 @@
endif
enddo
-
-
+
+
end subroutine compute_add_sources_adjoint
!
!-------------------------------------------------------------------------------------------------
!
-
-
+
+
subroutine compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
b_accel_crust_mantle,sourcearrays, &
DT,t0,t_cmt,hdur_gaussian,ibool_crust_mantle, &
islice_selected_source,ispec_selected_source,it)
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
@@ -300,9 +300,9 @@
double precision :: DT,t0
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
- integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
+ integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
integer :: it
-
+
! local parameters
double precision :: stf
real(kind=CUSTOM_REAL) :: stf_used
@@ -314,10 +314,10 @@
! add the source (only if this proc carries the source)
if(myrank == islice_selected_source(isource)) then
-! note on backward/reconstructed wavefields:
+! note on backward/reconstructed wavefields:
! time for b_displ( it ) corresponds to (NSTEP - it - 1 )*DT - t0 ...
! as we start with saved wavefields b_displ( 0 ) = displ( NSTEP ) which correspond
-! to a time (NSTEP - 1)*DT - t0
+! to a time (NSTEP - 1)*DT - t0
! (see sources for simulation_type 1 and seismograms)
!
! now, at the beginning of the time loop, the numerical Newark time scheme updates
@@ -333,12 +333,12 @@
endif
! add source array
- ispec = ispec_selected_source(isource)
+ ispec = ispec_selected_source(isource)
do k=1,NGLLZ
do j=1,NGLLY
do i=1,NGLLX
iglob = ibool_crust_mantle(i,j,k,ispec)
-
+
b_accel_crust_mantle(:,iglob) = b_accel_crust_mantle(:,iglob) &
+ sourcearrays(:,i,j,k,isource)*stf_used
@@ -349,7 +349,7 @@
endif
enddo
-
+
end subroutine compute_add_sources_backward
-
-
\ No newline at end of file
+
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_arrays_source.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_arrays_source.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_arrays_source.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -209,16 +209,16 @@
real(kind=CUSTOM_REAL) :: junk
character(len=3),dimension(NDIM) :: comp = (/ "LHN", "LHE", "LHZ" /)
character(len=150) :: filename
-
+
! (sub)trace start and end
! reading starts in chunks of NSTEP_BLOCK from the end of the trace,
- ! i.e. as an example: total length NSTEP = 3000, chunk length NSTEP_BLOCK= 1000
- ! then it will read in first it_start=2001 to it_end=3000,
+ ! i.e. as an example: total length NSTEP = 3000, chunk length NSTEP_BLOCK= 1000
+ ! then it will read in first it_start=2001 to it_end=3000,
! second time, it will be it_start=1001 to it_end=2000 and so on...
it_start = iadjsrc(it_sub_adj,1)
it_end = iadjsrc(it_sub_adj,1)+NSTEP_BLOCK-1
-
+
! unfortunately, things become more tricky because of the Newark time scheme at
! the very beginning of the time loop.
!
@@ -230,7 +230,7 @@
! that is e.g., it_start is now 2000 and it_end = 2999, then 1000 to 1999, then 0 to 999.
it_start = it_start - 1
it_end = it_end - 1
-
+
adj_src = 0._CUSTOM_REAL
do icomp = 1, NDIM
@@ -238,7 +238,7 @@
filename = 'SEM/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
open(unit=IIN,file=trim(filename),status='old',action='read',iostat=ios)
if (ios /= 0) cycle ! cycles to next file
-
+
! jumps over unused trace length
do itime =1,it_start-1
read(IIN,*,iostat=ios) junk,junk
@@ -246,33 +246,33 @@
call exit_MPI(myrank,&
'file '//trim(filename)//' has wrong length, please check with your simulation duration')
enddo
-
+
! reads in (sub)trace
do itime = it_start,it_end
! index will run from 1 to NSTEP_BLOCK
index_i = itime - it_start + 1
-
+
! skips read and sets source artifically to zero if out of bounds, see comments above
- if( it_start == 0 .and. itime == 0 ) then
+ if( it_start == 0 .and. itime == 0 ) then
adj_src(icomp,1) = 0._CUSTOM_REAL
cycle
endif
-
+
! reads in adjoint source trace
!read(IIN,*,iostat=ios) junk, adj_src(icomp,itime-it_start+1)
read(IIN,*,iostat=ios) junk, adj_src(icomp,index_i)
-
+
if( ios /= 0) &
call exit_MPI(myrank, &
'file '//trim(filename)//' has wrong length, please check with your simulation duration')
enddo
-
+
close(IIN)
enddo
- ! non-dimensionalize
+ ! non-dimensionalize
adj_src = adj_src*scale_displ_inv
! rotates to cartesian
@@ -282,7 +282,7 @@
+ nu(3,:) * adj_src(3,itime)
enddo
- ! receiver interpolators
+ ! receiver interpolators
call lagrange_any(xi_receiver,NGLLX,xigll,hxir,hpxir)
call lagrange_any(eta_receiver,NGLLY,yigll,hetar,hpetar)
call lagrange_any(gamma_receiver,NGLLZ,zigll,hgammar,hpgammar)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_coupling.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_coupling.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_coupling.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -31,9 +31,9 @@
normal_top_outer_core,jacobian2D_top_outer_core, &
wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
SIMULATION_TYPE,nspec_top)
-
+
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
@@ -41,7 +41,7 @@
displ_crust_mantle
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
b_displ_crust_mantle
-
+
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
@@ -61,8 +61,8 @@
! local parameters
real(kind=CUSTOM_REAL) :: displ_x,displ_y,displ_z,displ_n,nx,ny,nz,weight
integer :: i,j,k,k_corresp,ispec,ispec2D,iglob_cm,iglob_oc,ispec_selected
-
-
+
+
! for surface elements exactly on the CMB
do ispec2D = 1,nspec_top !NSPEC2D_TOP(IREGION_OUTER_CORE)
ispec = ibelm_top_outer_core(ispec2D)
@@ -96,7 +96,7 @@
! get global point number
iglob_oc = ibool_outer_core(i,j,k,ispec)
-
+
! update fluid acceleration/pressure
accel_outer_core(iglob_oc) = accel_outer_core(iglob_oc) + weight*displ_n
@@ -106,9 +106,9 @@
displ_x = b_displ_crust_mantle(1,iglob_cm)
displ_y = b_displ_crust_mantle(2,iglob_cm)
displ_z = b_displ_crust_mantle(3,iglob_cm)
-
+
displ_n = displ_x*nx + displ_y*ny + displ_z*nz
-
+
! update fluid acceleration/pressure
iglob_oc = ibool_outer_core(i,j,k,ispec)
b_accel_outer_core(iglob_oc) = b_accel_outer_core(iglob_oc) + weight*displ_n
@@ -130,9 +130,9 @@
normal_bottom_outer_core,jacobian2D_bottom_outer_core, &
wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
SIMULATION_TYPE,nspec_bottom)
-
+
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
@@ -140,7 +140,7 @@
displ_inner_core
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
b_displ_inner_core
-
+
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
@@ -156,7 +156,7 @@
integer SIMULATION_TYPE
integer nspec_bottom
-
+
! local parameters
real(kind=CUSTOM_REAL) :: displ_x,displ_y,displ_z,displ_n,nx,ny,nz,weight
integer :: i,j,k,k_corresp,ispec,ispec2D,iglob_oc,iglob_ic,ispec_selected
@@ -201,11 +201,11 @@
if (SIMULATION_TYPE == 3) then
! get displacement in inner core
- iglob_ic = ibool_inner_core(i,j,k_corresp,ispec_selected)
+ iglob_ic = ibool_inner_core(i,j,k_corresp,ispec_selected)
displ_x = b_displ_inner_core(1,iglob_ic)
displ_y = b_displ_inner_core(2,iglob_ic)
displ_z = b_displ_inner_core(3,iglob_ic)
-
+
displ_n = displ_x*nx + displ_y*ny + displ_z*nz
@@ -234,9 +234,9 @@
wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
RHO_TOP_OC,minus_g_cmb, &
SIMULATION_TYPE,nspec_bottom)
-
+
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
@@ -244,7 +244,7 @@
displ_crust_mantle,accel_crust_mantle
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
b_displ_crust_mantle,b_accel_crust_mantle
-
+
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
integer, dimension(NSPEC2D_BOTTOM_CM) :: ibelm_bottom_crust_mantle
@@ -260,7 +260,7 @@
double precision RHO_TOP_OC
real(kind=CUSTOM_REAL) minus_g_cmb
-
+
integer SIMULATION_TYPE
integer nspec_bottom
@@ -325,10 +325,10 @@
enddo
enddo
enddo
-
+
end subroutine compute_coupling_CMB_fluid
-
-
+
+
!
!-------------------------------------------------------------------------------------------------
!
@@ -341,9 +341,9 @@
wgllwgll_xy,ibool_outer_core,ibelm_bottom_outer_core, &
RHO_BOTTOM_OC,minus_g_icb, &
SIMULATION_TYPE,nspec_top)
-
+
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
@@ -351,7 +351,7 @@
displ_inner_core,accel_inner_core
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
b_displ_inner_core,b_accel_inner_core
-
+
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
integer, dimension(NSPEC2D_TOP_IC) :: ibelm_top_inner_core
@@ -370,7 +370,7 @@
integer SIMULATION_TYPE
integer nspec_top
-
+
! local parameters
real(kind=CUSTOM_REAL) :: pressure,nx,ny,nz,weight
integer :: i,j,k,k_corresp,ispec,ispec2D,iglob,iglob_inner_core,ispec_selected
@@ -433,19 +433,19 @@
enddo
end subroutine compute_coupling_ICB_fluid
-
+
!
!-------------------------------------------------------------------------------------------------
!
-
+
subroutine compute_coupling_ocean(accel_crust_mantle,b_accel_crust_mantle, &
rmass_crust_mantle,rmass_ocean_load,normal_top_crust_mantle, &
ibool_crust_mantle,ibelm_top_crust_mantle, &
updated_dof_ocean_load, &
SIMULATION_TYPE,nspec_top)
-
+
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
@@ -455,9 +455,9 @@
b_accel_crust_mantle
real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: rmass_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
+ real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_CM) :: normal_top_crust_mantle
-
+
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
integer, dimension(NSPEC2D_TOP_CM) :: ibelm_top_crust_mantle
@@ -470,7 +470,7 @@
real(kind=CUSTOM_REAL) :: force_normal_comp,b_force_normal_comp
real(kind=CUSTOM_REAL) :: additional_term,b_additional_term
real(kind=CUSTOM_REAL) :: nx,ny,nz
- integer :: i,j,k,ispec,ispec2D,iglob
+ integer :: i,j,k,ispec,ispec2D,iglob
! initialize the updates
updated_dof_ocean_load(:) = .false.
@@ -532,4 +532,4 @@
enddo
end subroutine compute_coupling_ocean
-
\ No newline at end of file
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_element_properties.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_element_properties.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_element_properties.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -106,16 +106,16 @@
double precision:: xigll(NGLLX)
double precision:: yigll(NGLLY)
double precision:: zigll(NGLLZ)
-
+
! Parameter used to decide whether this element is in the crust or not
logical:: elem_in_crust,elem_in_mantle
-
+
! add topography of the Moho *before* adding the 3D crustal velocity model so that the streched
! mesh gets assigned the right model values
elem_in_crust = .false.
- elem_in_mantle = .false.
+ elem_in_mantle = .false.
if( iregion_code == IREGION_CRUST_MANTLE ) then
- if( CRUSTAL .and. CASE_3D ) then
+ if( CRUSTAL .and. CASE_3D ) then
if( idoubling(ispec) == IFLAG_CRUST &
.or. idoubling(ispec) == IFLAG_220_80 &
.or. idoubling(ispec) == IFLAG_80_MOHO ) then
@@ -123,7 +123,7 @@
call moho_stretching_honor_crust(myrank,xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER,&
R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
endif
- endif
+ endif
endif
! interpolates and stores GLL point locations
@@ -139,33 +139,33 @@
c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
nspec_stacey,rho_vp,rho_vs, &
- xstore,ystore,zstore, &
+ xstore,ystore,zstore, &
rmin,rmax,RCMB,RICB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220, &
R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
tau_s,tau_e_store,Qmu_store,T_c_source, &
- size(tau_e_store,2),size(tau_e_store,3),size(tau_e_store,4),size(tau_e_store,5), &
- ABSORBING_CONDITIONS,elem_in_crust,elem_in_mantle)
+ size(tau_e_store,2),size(tau_e_store,3),size(tau_e_store,4),size(tau_e_store,5), &
+ ABSORBING_CONDITIONS,elem_in_crust,elem_in_mantle)
! either use GLL points or anchor points to capture TOPOGRAPHY and ELLIPTICITY
- ! note: using gll points to capture them results in a slightly more accurate mesh.
+ ! note: using gll points to capture them results in a slightly more accurate mesh.
! however, it introduces more deformations to the elements which might lead to
! problems with the jacobian. using the anchors is therefore more robust.
! adds surface topography
if( TOPOGRAPHY ) then
if (idoubling(ispec)==IFLAG_CRUST .or. idoubling(ispec)==IFLAG_220_80 &
.or. idoubling(ispec)==IFLAG_80_MOHO) then
- ! stretches mesh between surface and R220 accordingly
+ ! 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,R220)
else
! stretches anchor points only, interpolates gll points later on
call add_topography(myrank,xelm,yelm,zelm,ibathy_topo,R220)
endif
- endif
+ endif
endif
-
+
! adds topography on 410 km and 650 km discontinuity in model S362ANI
if(THREE_D_MODEL == THREE_D_MODEL_S362ANI .or. THREE_D_MODEL == THREE_D_MODEL_S362WMANI &
.or. THREE_D_MODEL == THREE_D_MODEL_S362ANI_PREM .or. THREE_D_MODEL == THREE_D_MODEL_S29EA) then
@@ -178,7 +178,7 @@
coe,ylmcof,wk1,wk2,wk3,varstr)
else
- ! stretches anchor points only, interpolates gll points later on
+ ! 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, &
@@ -187,7 +187,7 @@
endif
endif
- ! these are placeholders:
+ ! these are placeholders:
! their corresponding subroutines subtopo_cmb() and subtopo_icb() are not implemented yet....
! must be done/supplied by the user; uncomment in case
! CMB topography
@@ -215,9 +215,9 @@
! re-interpolates and creates the GLL point locations since the anchor points might have moved
!
- ! note: velocity values associated for each GLL point will "move" along together with
+ ! note: velocity values associated for each GLL point will "move" along together with
! their associated points. however, we don't re-calculate the velocity model values since the
- ! models are/should be referenced with respect to a spherical Earth.
+ ! models are/should be referenced with respect to a spherical Earth.
if( .not. USE_GLL) &
call compute_element_GLL_locations(xelm,yelm,zelm,ispec,nspec, &
xstore,ystore,zstore,shape3D)
@@ -228,26 +228,26 @@
xixstore,xiystore,xizstore,&
etaxstore,etaystore,etazstore,&
gammaxstore,gammaystore,gammazstore)
-
+
end subroutine compute_element_properties
-
+
!
!-------------------------------------------------------------------------------------------------
-!
+!
subroutine compute_element_GLL_locations(xelm,yelm,zelm,ispec,nspec, &
xstore,ystore,zstore,shape3D)
-
+
implicit none
include "constants.h"
integer ispec,nspec
-
+
double precision xelm(NGNOD)
double precision yelm(NGNOD)
double precision zelm(NGNOD)
-
+
double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
@@ -257,7 +257,7 @@
! local parameters
double precision xmesh,ymesh,zmesh
integer i,j,k,ia
-
+
do k=1,NGLLZ
do j=1,NGLLY
do i=1,NGLLX
@@ -265,7 +265,7 @@
xmesh = ZERO
ymesh = ZERO
zmesh = ZERO
-
+
! interpolates the location using 3D shape functions
do ia=1,NGNOD
@@ -274,15 +274,15 @@
zmesh = zmesh + shape3D(ia,i,j,k)*zelm(ia)
enddo
-
+
! stores mesh coordinates
xstore(i,j,k,ispec) = xmesh
ystore(i,j,k,ispec) = ymesh
zstore(i,j,k,ispec) = zmesh
-
+
enddo
enddo
enddo
-
+
end subroutine compute_element_GLL_locations
-
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -63,7 +63,7 @@
integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
integer :: Qn ! Number of points
- integer dummy_pad ! padding 4 bytes to align the structure
+ integer dummy_pad ! padding 4 bytes to align the structure
end type model_attenuation_variables
! for forward or backward simulations
@@ -404,7 +404,7 @@
!mimik: apparent velocity shift
if( ATTENUATION_MIMIK) then
muvl = muvl * ATTENUATION_MIMIK_FACTOR
- muhl = muhl * ATTENUATION_MIMIK_FACTOR
+ muhl = muhl * ATTENUATION_MIMIK_FACTOR
endif
rhovpvsq = kappavl + FOUR_THIRDS * muvl !!! that is C
@@ -697,7 +697,7 @@
rho_s_H(3,i,j,k) = sngl(factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl))
else
-
+
! get displacement and multiply by density to compute G tensor
sx_l = rho * displ(1,iglob)
sy_l = rho * displ(2,iglob)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle_Dev.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle_Dev.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_crust_mantle_Dev.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -65,7 +65,7 @@
! array with derivatives of Lagrange polynomials and precalculated products
double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xxT,hprimewgll_xxT
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xxT,hprimewgll_xxT
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
@@ -107,10 +107,10 @@
logical COMPUTE_AND_STORE_STRAIN
! local parameters
- ! Deville
+ ! Deville
! manually inline the calls to the Deville et al. (2002) routines
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
- tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc, &
newtempx1,newtempx2,newtempx3,newtempy1,newtempy2,newtempy3,newtempz1,newtempz2,newtempz3
real(kind=CUSTOM_REAL), dimension(NGLLX,m2) :: B1_m1_m2_5points,B2_m1_m2_5points,B3_m1_m2_5points
@@ -188,10 +188,10 @@
integer ::i_sls,i_memory
integer :: ispec,ispec_strain
- integer :: i,j,k
+ integer :: i,j,k
integer :: int_radius
integer :: iglob1,iglob2,iglob3,iglob4,iglob5
-
+
! ****************************************************
! big loop over all spectral elements in the solid
! ****************************************************
@@ -204,7 +204,7 @@
do k=1,NGLLZ
do j=1,NGLLY
-! way 1:
+! way 1:
! do i=1,NGLLX
! iglob = ibool(i,j,k,ispec)
! dummyx_loc(i,j,k) = displ(1,iglob)
@@ -219,7 +219,7 @@
iglob3 = ibool(3,j,k,ispec)
iglob4 = ibool(4,j,k,ispec)
iglob5 = ibool(5,j,k,ispec)
-
+
dummyx_loc(1,j,k) = displ(1,iglob1)
dummyy_loc(1,j,k) = displ(2,iglob1)
dummyz_loc(1,j,k) = displ(3,iglob1)
@@ -239,9 +239,9 @@
dummyx_loc(5,j,k) = displ(1,iglob5)
dummyy_loc(5,j,k) = displ(2,iglob5)
dummyz_loc(5,j,k) = displ(3,iglob5)
-
+
enddo
- enddo
+ enddo
do j=1,m2
do i=1,m1
C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
@@ -262,7 +262,7 @@
hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
hprime_xx(i,5)*B3_m1_m2_5points(5,j)
enddo
- enddo
+ enddo
do j=1,m1
do i=1,m1
! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
@@ -308,7 +308,7 @@
A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
enddo
enddo
-
+
do k=1,NGLLZ
do j=1,NGLLY
do i=1,NGLLX
@@ -488,7 +488,7 @@
!mimik: apparent velocity shift
if( ATTENUATION_MIMIK) then
muvl = muvl * ATTENUATION_MIMIK_FACTOR
- muhl = muhl * ATTENUATION_MIMIK_FACTOR
+ muhl = muhl * ATTENUATION_MIMIK_FACTOR
endif
rhovpvsq = kappavl + FOUR_THIRDS * muvl !!! that is C
@@ -693,7 +693,7 @@
! sigma_zz = sigma_zz + R_xx_val + R_yy_val
! sigma_xy = sigma_xy - R_memory(3,i_sls,i,j,k,ispec)
! sigma_xz = sigma_xz - R_memory(4,i_sls,i,j,k,ispec)
-! sigma_yz = sigma_yz - R_memory(5,i_sls,i,j,k,ispec)
+! sigma_yz = sigma_yz - R_memory(5,i_sls,i,j,k,ispec)
! enddo
! way 2:
@@ -708,9 +708,9 @@
sigma_zz = sigma_zz + R_xx_val1 + R_yy_val1
sigma_xy = sigma_xy - R_memory(3,i_sls,i,j,k,ispec)
sigma_xz = sigma_xz - R_memory(4,i_sls,i,j,k,ispec)
- sigma_yz = sigma_yz - R_memory(5,i_sls,i,j,k,ispec)
+ sigma_yz = sigma_yz - R_memory(5,i_sls,i,j,k,ispec)
enddo
-
+
do i_sls = mod(N_SLS,3)+1,N_SLS,3
R_xx_val1 = R_memory(1,i_sls,i,j,k,ispec)
R_yy_val1 = R_memory(2,i_sls,i,j,k,ispec)
@@ -825,7 +825,7 @@
rho_s_H(3,i,j,k) = sngl(factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl))
else
-
+
! get displacement and multiply by density to compute G tensor
sx_l = rho * displ(1,iglob1)
sy_l = rho * displ(2,iglob1)
@@ -943,9 +943,9 @@
do k=1,NGLLZ
do j=1,NGLLY
-
+
! way 1:
-! this seems to be still the fastest way here.
+! this seems to be still the fastest way here.
fac1 = wgllwgll_yz(j,k)
do i=1,NGLLX
fac2 = wgllwgll_xz(i,k)
@@ -966,18 +966,18 @@
! sum contributions from each element to the global mesh and add gravity terms
do k=1,NGLLZ
do j=1,NGLLY
-! way 1:
+! way 1:
! do i=1,NGLLX
! iglob = ibool(i,j,k,ispec)
-! accel(:,iglob) = accel(:,iglob) + sum_terms(:,i,j,k)
+! accel(:,iglob) = accel(:,iglob) + sum_terms(:,i,j,k)
! enddo
! way 2:
- accel(:,ibool(1,j,k,ispec)) = accel(:,ibool(1,j,k,ispec)) + sum_terms(:,1,j,k)
- accel(:,ibool(2,j,k,ispec)) = accel(:,ibool(2,j,k,ispec)) + sum_terms(:,2,j,k)
- accel(:,ibool(3,j,k,ispec)) = accel(:,ibool(3,j,k,ispec)) + sum_terms(:,3,j,k)
- accel(:,ibool(4,j,k,ispec)) = accel(:,ibool(4,j,k,ispec)) + sum_terms(:,4,j,k)
- accel(:,ibool(5,j,k,ispec)) = accel(:,ibool(5,j,k,ispec)) + sum_terms(:,5,j,k)
+ accel(:,ibool(1,j,k,ispec)) = accel(:,ibool(1,j,k,ispec)) + sum_terms(:,1,j,k)
+ accel(:,ibool(2,j,k,ispec)) = accel(:,ibool(2,j,k,ispec)) + sum_terms(:,2,j,k)
+ accel(:,ibool(3,j,k,ispec)) = accel(:,ibool(3,j,k,ispec)) + sum_terms(:,3,j,k)
+ accel(:,ibool(4,j,k,ispec)) = accel(:,ibool(4,j,k,ispec)) + sum_terms(:,4,j,k)
+ accel(:,ibool(5,j,k,ispec)) = accel(:,ibool(5,j,k,ispec)) + sum_terms(:,5,j,k)
enddo
enddo
@@ -1007,7 +1007,7 @@
! way 1:
! it still seems to be the fastest way here.
- do i_sls = 1,N_SLS
+ do i_sls = 1,N_SLS
! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
factor_common_c44_muv = factor_common(i_sls,:,:,:,ispec)
@@ -1016,7 +1016,7 @@
else
factor_common_c44_muv = factor_common_c44_muv * muvstore(:,:,:,ispec)
endif
-
+
do i_memory = 1,5
R_memory(i_memory,i_sls,:,:,:,ispec) = alphaval(i_sls) * &
R_memory(i_memory,i_sls,:,:,:,ispec) + &
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -289,7 +289,7 @@
if(ATTENUATION_VAL) then
mul = mul * one_minus_sum_beta(i,j,k,ispec)
endif
-
+
lambdalplus2mul = kappal + FOUR_THIRDS * mul
lambdal = lambdalplus2mul - 2.*mul
@@ -434,7 +434,7 @@
rho_s_H(3,i,j,k) = factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl)
endif
-
+
endif ! end of section with gravity terms
! form dot product with test vector, non-symmetric form
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core_Dev.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core_Dev.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_inner_core_Dev.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -70,9 +70,9 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: epsilon_trace_over_3
! array with derivatives of Lagrange polynomials and precalculated products
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xxT,hprimewgll_xxT
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xxT,hprimewgll_xxT
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
@@ -164,8 +164,8 @@
integer :: i_sls,i_memory
integer :: iglob1,iglob2,iglob3,iglob4,iglob5
-
+
! ****************************************************
! big loop over all spectral elements in the solid
! ****************************************************
@@ -180,7 +180,7 @@
! pages 386 and 389 and Figure 8.3.1
do k=1,NGLLZ
do j=1,NGLLY
-! way 1:
+! way 1:
! do i=1,NGLLX
! iglob = ibool(i,j,k,ispec)
! dummyx_loc(i,j,k) = displ(1,iglob)
@@ -188,7 +188,7 @@
! dummyz_loc(i,j,k) = displ(3,iglob)
! enddo
-! way 2:
+! way 2:
! since we know that NGLLX = 5, this should help pipelining
iglob1 = ibool(1,j,k,ispec)
iglob2 = ibool(2,j,k,ispec)
@@ -215,10 +215,10 @@
dummyx_loc(5,j,k) = displ(1,iglob5)
dummyy_loc(5,j,k) = displ(2,iglob5)
dummyz_loc(5,j,k) = displ(3,iglob5)
-
-
+
+
enddo
- enddo
+ enddo
do j=1,m2
do i=1,m1
C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
@@ -239,7 +239,7 @@
hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
hprime_xx(i,5)*B3_m1_m2_5points(5,j)
enddo
- enddo
+ enddo
do j=1,m1
do i=1,m1
! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
@@ -285,7 +285,7 @@
A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
enddo
enddo
-
+
do k=1,NGLLZ
do j=1,NGLLY
do i=1,NGLLX
@@ -437,9 +437,9 @@
sigma_zz = sigma_zz + R_xx_val1 + R_yy_val1
sigma_xy = sigma_xy - R_memory(3,i_sls,i,j,k,ispec)
sigma_xz = sigma_xz - R_memory(4,i_sls,i,j,k,ispec)
- sigma_yz = sigma_yz - R_memory(5,i_sls,i,j,k,ispec)
+ sigma_yz = sigma_yz - R_memory(5,i_sls,i,j,k,ispec)
enddo
-
+
do i_sls = mod(N_SLS,3)+1,N_SLS,3
R_xx_val1 = R_memory(1,i_sls,i,j,k,ispec)
R_yy_val1 = R_memory(2,i_sls,i,j,k,ispec)
@@ -468,7 +468,7 @@
sigma_xz = sigma_xz - R_memory(4,i_sls+2,i,j,k,ispec)
sigma_yz = sigma_yz - R_memory(5,i_sls+2,i,j,k,ispec)
enddo
-
+
endif
! define symmetric components of sigma for gravity
@@ -528,7 +528,7 @@
! for locality principle, we set iglob again, in order to have it in the cache again
iglob1 = ibool(i,j,k,ispec)
-
+
! distinguish between single and double precision for reals
if(CUSTOM_REAL == SIZE_REAL) then
! get displacement and multiply by density to compute G tensor
@@ -695,19 +695,19 @@
! sum contributions from each element to the global mesh and add gravity terms
do k=1,NGLLZ
do j=1,NGLLY
-! way 1:
+! way 1:
! do i=1,NGLLX
! iglob = ibool(i,j,k,ispec)
! accel(:,iglob) = accel(:,iglob) + sum_terms(:,i,j,k)
! enddo
! way 2:
- accel(:,ibool(1,j,k,ispec)) = accel(:,ibool(1,j,k,ispec)) + sum_terms(:,1,j,k)
- accel(:,ibool(2,j,k,ispec)) = accel(:,ibool(2,j,k,ispec)) + sum_terms(:,2,j,k)
- accel(:,ibool(3,j,k,ispec)) = accel(:,ibool(3,j,k,ispec)) + sum_terms(:,3,j,k)
- accel(:,ibool(4,j,k,ispec)) = accel(:,ibool(4,j,k,ispec)) + sum_terms(:,4,j,k)
- accel(:,ibool(5,j,k,ispec)) = accel(:,ibool(5,j,k,ispec)) + sum_terms(:,5,j,k)
-
+ accel(:,ibool(1,j,k,ispec)) = accel(:,ibool(1,j,k,ispec)) + sum_terms(:,1,j,k)
+ accel(:,ibool(2,j,k,ispec)) = accel(:,ibool(2,j,k,ispec)) + sum_terms(:,2,j,k)
+ accel(:,ibool(3,j,k,ispec)) = accel(:,ibool(3,j,k,ispec)) + sum_terms(:,3,j,k)
+ accel(:,ibool(4,j,k,ispec)) = accel(:,ibool(4,j,k,ispec)) + sum_terms(:,4,j,k)
+ accel(:,ibool(5,j,k,ispec)) = accel(:,ibool(5,j,k,ispec)) + sum_terms(:,5,j,k)
+
enddo
enddo
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -202,7 +202,7 @@
! use mesh coordinates to get theta and phi
! x y z contain r theta phi
iglob = ibool(i,j,k,ispec)
-
+
radius = dble(xstore(iglob))
theta = dble(ystore(iglob))
phi = dble(zstore(iglob))
@@ -218,7 +218,7 @@
grad_x_ln_rho = sin_theta * cos_phi * d_ln_density_dr_table(int_radius)
grad_y_ln_rho = sin_theta * sin_phi * d_ln_density_dr_table(int_radius)
grad_z_ln_rho = cos_theta * d_ln_density_dr_table(int_radius)
-
+
! adding (chi/rho)grad(rho)
dpotentialdx_with_rot = dpotentialdx_with_rot + displfluid(iglob) * grad_x_ln_rho
dpotentialdy_with_rot = dpotentialdx_with_rot + displfluid(iglob) * grad_y_ln_rho
@@ -303,9 +303,9 @@
enddo
! sum contributions from each element to the global mesh and add gravity term
- sum_terms = - (wgllwgll_yz(j,k)*tempx1l + wgllwgll_xz(i,k)*tempx2l + wgllwgll_xy(i,j)*tempx3l)
+ sum_terms = - (wgllwgll_yz(j,k)*tempx1l + wgllwgll_xz(i,k)*tempx2l + wgllwgll_xy(i,j)*tempx3l)
if(GRAVITY_VAL) sum_terms = sum_terms + gravity_term(i,j,k)
-
+
accelfluid(ibool(i,j,k,ispec)) = accelfluid(ibool(i,j,k,ispec)) + sum_terms
enddo
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core_Dev.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core_Dev.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_forces_outer_core_Dev.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -128,7 +128,7 @@
do i=1,NGLLX
iglob = ibool(i,j,k,ispec)
- ! stores "displacement"
+ ! stores "displacement"
dummyx_loc(i,j,k) = displfluid(iglob)
! pre-computes factors
@@ -144,8 +144,8 @@
sin_phi = dsin(phi)
int_radius = nint(radius * R_EARTH_KM * 10.d0)
-
- if( .not. GRAVITY_VAL ) then
+
+ if( .not. GRAVITY_VAL ) then
! grad(rho)/rho in Cartesian components
displ_times_grad_x_ln_rho(i,j,k) = dummyx_loc(i,j,k) &
* sngl(sin_theta * cos_phi * d_ln_density_dr_table(int_radius))
@@ -160,7 +160,7 @@
temp_gyl(i,j,k) = sin_theta*sin_phi
temp_gzl(i,j,k) = cos_theta
endif
-
+
enddo
enddo
enddo
@@ -383,7 +383,7 @@
! sum contributions from each element to the global mesh and add gravity term
sum_terms = - (wgllwgll_yz(j,k)*newtempx1(i,j,k) &
+ wgllwgll_xz(i,k)*newtempx2(i,j,k) &
- + wgllwgll_xy(i,j)*newtempx3(i,j,k))
+ + wgllwgll_xy(i,j)*newtempx3(i,j,k))
if(GRAVITY_VAL) sum_terms = sum_terms + gravity_term(i,j,k)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_kernels.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_kernels.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_kernels.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -28,14 +28,14 @@
subroutine compute_kernels_crust_mantle(ibool_crust_mantle, &
rho_kl_crust_mantle,beta_kl_crust_mantle, &
- alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
+ alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
accel_crust_mantle,b_displ_crust_mantle, &
epsilondev_crust_mantle,b_epsilondev_crust_mantle, &
eps_trace_over_3_crust_mantle,b_eps_trace_over_3_crust_mantle, &
deltat)
-
+
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
@@ -43,11 +43,11 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
rho_kl_crust_mantle, beta_kl_crust_mantle, alpha_kl_crust_mantle
-
+
real(kind=CUSTOM_REAL), dimension(21,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
cijkl_kl_crust_mantle
-
+
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
accel_crust_mantle
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE_ADJOINT) :: &
@@ -66,7 +66,7 @@
real(kind=CUSTOM_REAL) deltat
! local parameters
- real(kind=CUSTOM_REAL),dimension(21) :: prod !, cijkl_kl_local
+ real(kind=CUSTOM_REAL),dimension(21) :: prod !, cijkl_kl_local
real(kind=CUSTOM_REAL), dimension(5) :: epsilondev_loc
real(kind=CUSTOM_REAL), dimension(5) :: b_epsilondev_loc
integer :: i,j,k,ispec,iglob
@@ -81,7 +81,7 @@
! density kernel: see e.g. Tromp et al.(2005), equation (14)
! b_displ_crust_mantle is the backward/reconstructed wavefield, that is s(x,t) in eq. (14),
! accel_crust_mantle is the adjoint wavefield, that corresponds to s_dagger(x,T-t)
- !
+ !
! note with respect to eq. (14) the second time derivative is applied to the
! adjoint wavefield here rather than the backward/reconstructed wavefield.
! this is a valid operation and the resultant kernel identical to the eq. (14).
@@ -106,7 +106,7 @@
cijkl_kl_crust_mantle(:,i,j,k,ispec) = cijkl_kl_crust_mantle(:,i,j,k,ispec) + deltat * prod(:)
else
-
+
! kernel for shear modulus, see e.g. Tromp et al. (2005), equation (17)
! note: multiplication with 2*mu(x) will be done after the time loop
beta_kl_crust_mantle(i,j,k,ispec) = beta_kl_crust_mantle(i,j,k,ispec) &
@@ -128,8 +128,8 @@
enddo
enddo
enddo
-
-
+
+
end subroutine compute_kernels_crust_mantle
@@ -152,9 +152,9 @@
rho_kl_outer_core,alpha_kl_outer_core, &
deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
deltat)
-
+
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
@@ -191,9 +191,9 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_beta_kl_outer_core) :: &
beta_kl_outer_core
logical deviatoric_outercore
-
+
real(kind=CUSTOM_REAL) deltat
-
+
! local parameters
real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,kappal
real(kind=CUSTOM_REAL) :: tempx1l,tempx2l,tempx3l
@@ -279,7 +279,7 @@
- ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
+ xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
-
+
b_epsilondev_loc(2) = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
- ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
@@ -302,7 +302,7 @@
- ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
+ xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
-
+
endif !deviatoric kernel check
@@ -383,7 +383,7 @@
- ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
+ xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l )
-
+
epsilondev_loc(2) = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
- ONE_THIRD* (xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l &
+ xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l &
@@ -412,7 +412,7 @@
+ (epsilondev_loc(1)+epsilondev_loc(2)) * (b_epsilondev_loc(1)+b_epsilondev_loc(2)) &
+ 2 * (epsilondev_loc(3)*b_epsilondev_loc(3) + epsilondev_loc(4)*b_epsilondev_loc(4) + &
epsilondev_loc(5)*b_epsilondev_loc(5)) )
-
+
endif !deviatoric kernel check
@@ -421,7 +421,7 @@
+ deltat * dot_product(vector_accel_outer_core(:,iglob), b_vector_displ_outer_core(:,iglob))
kappal = rhostore_outer_core(i,j,k,ispec)/kappavstore_outer_core(i,j,k,ispec)
-
+
div_displ_outer_core(i,j,k,ispec) = kappal * accel_outer_core(iglob)
b_div_displ_outer_core(i,j,k,ispec) = kappal * b_accel_outer_core(iglob)
@@ -435,8 +435,8 @@
enddo
end subroutine compute_kernels_outer_core
-
-
+
+
!
!-------------------------------------------------------------------------------------------------
!
@@ -444,15 +444,15 @@
subroutine compute_kernels_inner_core(ibool_inner_core, &
rho_kl_inner_core,beta_kl_inner_core, &
- alpha_kl_inner_core, &
+ alpha_kl_inner_core, &
accel_inner_core,b_displ_inner_core, &
epsilondev_inner_core,b_epsilondev_inner_core, &
eps_trace_over_3_inner_core,b_eps_trace_over_3_inner_core, &
deltat)
-
+
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
@@ -460,7 +460,7 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
rho_kl_inner_core, beta_kl_inner_core, alpha_kl_inner_core
-
+
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: &
accel_inner_core
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE_ADJOINT) :: &
@@ -481,10 +481,10 @@
! local parameters
real(kind=CUSTOM_REAL), dimension(5) :: b_epsilondev_loc
real(kind=CUSTOM_REAL), dimension(5) :: epsilondev_loc
-
+
integer :: i,j,k,ispec,iglob
-
+
! inner_core
do ispec = 1, NSPEC_INNER_CORE
do k = 1, NGLLZ
@@ -513,8 +513,8 @@
enddo
end subroutine compute_kernels_inner_core
-
+
!
!-------------------------------------------------------------------------------------------------
!
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_seismograms.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_seismograms.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_seismograms.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -45,20 +45,20 @@
double precision, dimension(nrec_local,NGLLX) :: hxir_store
double precision, dimension(nrec_local,NGLLY) :: hetar_store
double precision, dimension(nrec_local,NGLLZ) :: hgammar_store
-
+
double precision scale_displ
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
integer, dimension(nrec) :: ispec_selected_rec
integer, dimension(nrec_local) :: number_receiver_global
-
- integer :: seismo_current
+
+ integer :: seismo_current
integer :: NTSTEP_BETWEEN_OUTPUT_SEISMOS
-
+
real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: &
seismograms
-
+
! local parameters
double precision :: uxd,uyd,uzd,hlagrange
integer :: i,j,k,iglob,irec_local,irec
@@ -97,16 +97,16 @@
else
seismograms(:,irec_local,seismo_current) = scale_displ*(nu(:,1,irec)*uxd + &
nu(:,2,irec)*uyd + nu(:,3,irec)*uzd)
- endif
+ endif
enddo
-
+
end subroutine compute_seismograms
!
!-------------------------------------------------------------------------------------------------
!
-
+
subroutine compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
nu,hxir_store,hetar_store,hgammar_store, &
scale_displ,ibool_crust_mantle, &
@@ -127,20 +127,20 @@
double precision, dimension(nrec_local,NGLLX) :: hxir_store
double precision, dimension(nrec_local,NGLLY) :: hetar_store
double precision, dimension(nrec_local,NGLLZ) :: hgammar_store
-
+
double precision scale_displ
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
integer, dimension(nrec) :: ispec_selected_rec
integer, dimension(nrec_local) :: number_receiver_global
-
+
integer :: seismo_current
integer :: NTSTEP_BETWEEN_OUTPUT_SEISMOS
-
+
real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: &
seismograms
-
+
! local parameters
double precision :: uxd,uyd,uzd,hlagrange
integer :: i,j,k,iglob,irec_local,irec
@@ -183,13 +183,13 @@
enddo
-
+
end subroutine compute_seismograms_backward
!
!-------------------------------------------------------------------------------------------------
!
-
+
subroutine compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
nu_source,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
@@ -210,7 +210,7 @@
include "OUTPUT_FILES/values_from_mesher.h"
integer NSOURCES,nrec_local
-
+
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
displ_crust_mantle
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STRAIN_ONLY) :: &
@@ -240,19 +240,19 @@
real(kind=CUSTOM_REAL), dimension(NDIM,NDIM,nrec_local) :: moment_der
real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local) :: sloc_der
-
+
integer NTSTEP_BETWEEN_OUTPUT_SEISMOS
-
+
real(kind=CUSTOM_REAL), dimension(NDIM*NDIM,nrec_local,NTSTEP_BETWEEN_OUTPUT_SEISMOS) :: &
seismograms
real(kind=CUSTOM_REAL) :: deltat
-
+
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
integer,dimension(NSOURCES) :: ispec_selected_source
- integer, dimension(nrec_local) :: number_receiver_global
- integer :: NSTEP,it,nit_written
-
+ integer, dimension(nrec_local) :: number_receiver_global
+ integer :: NSTEP,it,nit_written
+
! local parameters
double precision :: uxd,uyd,uzd,hlagrange
double precision :: eps_trace,dxx,dyy,dxy,dxz,dyz
@@ -356,10 +356,10 @@
stf = comp_source_time_function(dble(NSTEP-it)*DT-t0-t_cmt(irec),hdur_gaussian(irec))
stf_deltat = stf * deltat
-
+
moment_der(:,:,irec_local) = moment_der(:,:,irec_local) + eps_s(:,:) * stf_deltat
sloc_der(:,irec_local) = sloc_der(:,irec_local) + eps_m_s(:) * stf_deltat
enddo
-
- end subroutine compute_seismograms_adjoint
\ No newline at end of file
+
+ end subroutine compute_seismograms_adjoint
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_crust_mantle.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_crust_mantle.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_crust_mantle.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -46,9 +46,9 @@
nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm, &
absorb_xmin_crust_mantle,absorb_xmax_crust_mantle, &
absorb_ymin_crust_mantle,absorb_ymax_crust_mantle)
-
+
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
@@ -88,8 +88,8 @@
njmin_crust_mantle,njmax_crust_mantle,nkmin_xi_crust_mantle
integer nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
- nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle
-
+ nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle
+
integer reclen_xmin_crust_mantle,reclen_xmax_crust_mantle,&
reclen_ymin_crust_mantle,reclen_ymax_crust_mantle
@@ -97,12 +97,12 @@
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nabs_xmin_cm) :: absorb_xmin_crust_mantle
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nabs_xmax_cm) :: absorb_xmax_crust_mantle
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,nabs_ymin_cm) :: absorb_ymin_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,nabs_ymax_cm) :: absorb_ymax_crust_mantle
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,nabs_ymax_cm) :: absorb_ymax_crust_mantle
! local parameters
real(kind=CUSTOM_REAL) :: weight
- real(kind=CUSTOM_REAL) :: vn,vx,vy,vz,nx,ny,nz,tx,ty,tz
+ real(kind=CUSTOM_REAL) :: vn,vx,vy,vz,nx,ny,nz,tx,ty,tz
integer :: i,j,k,ispec,iglob,ispec2D
integer :: reclen1,reclen2
@@ -233,7 +233,7 @@
if (reclen1 /= reclen_ymin_crust_mantle .or. reclen1 /= reclen2) &
call exit_MPI(myrank,'Error reading absorbing contribution absorb_ymin')
endif
-
+
do ispec2D=1,nspec2D_ymin_crust_mantle
ispec=ibelm_ymin_crust_mantle(ispec2D)
@@ -287,7 +287,7 @@
if (reclen1 /= reclen_ymax_crust_mantle .or. reclen1 /= reclen2) &
call exit_MPI(myrank,'Error reading absorbing contribution absorb_ymax')
endif
-
+
do ispec2D=1,nspec2D_ymax_crust_mantle
ispec=ibelm_ymax_crust_mantle(ispec2D)
@@ -331,9 +331,9 @@
enddo
enddo
enddo
-
+
if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. nspec2D_ymax_crust_mantle > 0 ) &
- write(54,rec=it) reclen_ymax_crust_mantle,absorb_ymax_crust_mantle,reclen_ymax_crust_mantle
-
+ write(54,rec=it) reclen_ymax_crust_mantle,absorb_ymax_crust_mantle,reclen_ymax_crust_mantle
+
end subroutine compute_stacey_crust_mantle
-
\ No newline at end of file
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_outer_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_outer_core.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/compute_stacey_outer_core.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -50,16 +50,16 @@
absorb_zmin_outer_core, &
absorb_xmin_outer_core,absorb_xmax_outer_core, &
absorb_ymin_outer_core,absorb_ymax_outer_core)
-
+
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
integer myrank,ichunk,SIMULATION_TYPE
integer NSTEP,it
logical SAVE_FORWARD
-
+
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE) :: ibool_outer_core
real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
@@ -91,8 +91,8 @@
integer, dimension(MAX_NUM_REGIONS) :: NSPEC2D_BOTTOM
integer nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
-
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
+
integer reclen_zmin,reclen_xmin_outer_core,reclen_xmax_outer_core,&
reclen_ymin_outer_core,reclen_ymax_outer_core
@@ -101,14 +101,14 @@
real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nabs_xmax_oc) :: absorb_xmax_outer_core
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nabs_ymin_oc) :: absorb_ymin_outer_core
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nabs_ymax_oc) :: absorb_ymax_outer_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,nabs_zmin_oc) :: absorb_zmin_outer_core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,nabs_zmin_oc) :: absorb_zmin_outer_core
! local parameters
real(kind=CUSTOM_REAL) :: sn,weight
integer :: reclen1,reclen2
integer :: i,j,k,ispec2D,ispec,iglob
-
-
+
+
! xmin
! if two chunks exclude this face for one of them
if(NCHUNKS_VAL == 1 .or. ichunk == CHUNK_AC) then
@@ -306,4 +306,4 @@
if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. NSPEC2D_BOTTOM(IREGION_OUTER_CORE) > 0 ) &
write(65,rec=it) reclen_zmin,absorb_zmin_outer_core,reclen_zmin
- end subroutine compute_stacey_outer_core
\ No newline at end of file
+ end subroutine compute_stacey_outer_core
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/create_central_cube.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_central_cube.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_central_cube.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -24,7 +24,7 @@
! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
!
!=====================================================================
-
+
subroutine create_central_cube(myrank,ichunk,ispec,iaddx,iaddy,iaddz, &
nspec,NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,R_CENTRAL_CUBE, &
iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,ratio_divide_central_cube, &
@@ -131,9 +131,9 @@
integer nx_central_cube,ny_central_cube,nz_central_cube
! the height at which the central cube is cut
integer :: nz_inf_limit
-
+
! create the shape of a regular mesh element in the inner core
call hex_nodes(iaddx,iaddy,iaddz)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/create_doubling_elements.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_doubling_elements.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_doubling_elements.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -52,8 +52,8 @@
ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,&
ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot, &
CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,offset_proc_xi,offset_proc_eta)
-
-
+
+
! adds doubling elements to the different regions of the mesh
use meshfem3D_models_par
@@ -64,7 +64,7 @@
! code for the four regions of the mesh
integer iregion_code
! correct number of spectral elements in each block depending on chunk type
- integer nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS
+ integer nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS
integer NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
@@ -148,26 +148,26 @@
real(kind=CUSTOM_REAL) jacobian2D_moho(NGLLX,NGLLY,NSPEC2D_MOHO)
real(kind=CUSTOM_REAL) jacobian2D_400(NGLLX,NGLLY,NSPEC2D_400)
real(kind=CUSTOM_REAL) jacobian2D_670(NGLLX,NGLLY,NSPEC2D_670)
-
+
integer ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot
integer :: offset_proc_xi,offset_proc_eta
logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
! local parameters
- double precision, dimension(NGLOB_DOUBLING_SUPERBRICK) :: x_superbrick,y_superbrick,z_superbrick
+ double precision, dimension(NGLOB_DOUBLING_SUPERBRICK) :: x_superbrick,y_superbrick,z_superbrick
double precision, dimension(NGNOD) :: offset_x,offset_y,offset_z
double precision, dimension(NGNOD) :: xelm,yelm,zelm
double precision :: r1,r2,r3,r4,r5,r6,r7,r8
! mesh doubling superbrick
- integer, dimension(NGNOD_EIGHT_CORNERS,NSPEC_DOUBLING_SUPERBRICK) :: ibool_superbrick
+ integer, dimension(NGNOD_EIGHT_CORNERS,NSPEC_DOUBLING_SUPERBRICK) :: ibool_superbrick
integer :: ix_elem,iy_elem,iz_elem,ignod,ispec_superbrick,case_xi,case_eta
integer :: step_mult,subblock_num
- integer :: nspec_sb
+ integer :: nspec_sb
logical, dimension(NSPEC_DOUBLING_SUPERBRICK,6) :: iboun_sb
logical :: is_superbrick
-
+
! If there is a doubling at the top of this region, let us add these elements.
! The superbrick implements a symmetric four-to-two doubling and therefore replaces
! a basic regular block of 2 x 2 = 4 elements.
@@ -363,5 +363,5 @@
enddo
enddo
enddo
-
+
end subroutine create_doubling_elements
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/create_mass_matrices.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_mass_matrices.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_mass_matrices.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -34,11 +34,11 @@
xstore,ystore,zstore,RHO_OCEANS)
! creates rmass and rmass_ocean_load
-
+
use meshfem3D_models_par
implicit none
-
+
integer myrank,nspec
integer idoubling(nspec)
@@ -56,9 +56,9 @@
! mass matrix
integer nglob
real(kind=CUSTOM_REAL), dimension(nglob) :: rmass
-
+
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rhostore,kappavstore
-
+
! ocean mass matrix
integer nglob_oceans
real(kind=CUSTOM_REAL), dimension(nglob_oceans) :: rmass_ocean_load
@@ -66,26 +66,26 @@
integer NSPEC2D_TOP
integer, dimension(NSPEC2D_TOP) :: ibelm_top
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP) :: jacobian2D_top
-
+
! arrays with the mesh in double precision
double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
+
double precision RHO_OCEANS
-
+
! local parameters
double precision weight
double precision xval,yval,zval,rval,thetaval,phival
double precision lat,lon,colat
double precision elevation,height_oceans
real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
-
+
integer :: ispec,i,j,k,iglobnum
integer :: ix_oceans,iy_oceans,iz_oceans,ispec_oceans,ispec2D_top_crust
-
-
- ! initializes
+
+
+ ! initializes
rmass(:) = 0._CUSTOM_REAL
do ispec=1,nspec
@@ -224,5 +224,5 @@
rmass_ocean_load(:) = rmass_ocean_load(:) + rmass(:)
endif
-
+
end subroutine create_mass_matrices
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_AVS_DX.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_AVS_DX.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_AVS_DX.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -437,7 +437,7 @@
print *,'thresholding... '
where(abs(field_display(:)) <= THRESHOLD) field_display = 0.
endif
-
+
! apply non linear scaling to normalized field if needed
if(NONLINEAR_SCALING) then
print *,'nonlinear scaling... '
@@ -785,7 +785,7 @@
ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube,HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE,.false.)
-
+
if(MOVIE_COARSE) stop 'create_movie_AVS_DX does not work with MOVIE_COARSE'
end subroutine read_AVS_DX_parameters
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_GMT_global.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_GMT_global.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_movie_GMT_global.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -33,9 +33,9 @@
! reads in files: OUTPUT_FILES/moviedata******
!
-! and creates new files: ascii_movie_*** (ascii option) /or/ bin_movie_*** (binary option)
+! and creates new files: ascii_movie_*** (ascii option) /or/ bin_movie_*** (binary option)
!
-! these files can then be visualized using GMT, the Generic Mapping Tools
+! these files can then be visualized using GMT, the Generic Mapping Tools
! ( http://www.soest.hawaii.edu/GMT/ )
!
! example scripts can be found in: UTILS/Visualization/GMT/
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/create_regions_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_regions_mesh.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_regions_mesh.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -81,9 +81,9 @@
double precision R_CENTRAL_CUBE,RICB,RCMB,R670,RMOHO, &
RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
RMOHO_FICTITIOUS_IN_MESHER
-
+
double precision RHO_OCEANS
-
+
character(len=150) LOCAL_PATH,errmsg
! arrays with the mesh in double precision
@@ -184,7 +184,7 @@
! number of elements on the boundaries
integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
- integer i,j,k,ispec
+ integer i,j,k,ispec
integer iproc_xi,iproc_eta,ichunk
double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
@@ -203,7 +203,7 @@
integer NUMBER_OF_MESH_LAYERS,layer_shift,cpt, &
first_layer_aniso,last_layer_aniso,FIRST_ELT_NON_ANISO
-
+
double precision, dimension(:,:), allocatable :: stretch_tab
integer :: nb_layer_above_aniso,FIRST_ELT_ABOVE_ANISO
@@ -234,7 +234,7 @@
nspec_att = nspec
else
nspec_att = 1
- end if
+ end if
allocate(Qmu_store(NGLLX,NGLLY,NGLLZ,nspec_att))
allocate(tau_e_store(N_SLS,NGLLX,NGLLY,NGLLZ,nspec_att))
@@ -405,7 +405,7 @@
! to consider anisotropic elements first and to build the mesh from the bottom to the top of the region
allocate (perm_layer(ifirst_region:ilast_region))
perm_layer = (/ (i, i=ilast_region,ifirst_region,-1) /)
-
+
if(iregion_code == IREGION_CRUST_MANTLE) then
cpt=3
perm_layer(1)=first_layer_aniso
@@ -418,7 +418,7 @@
enddo
endif
- ! crustal layer stretching: element layer's top and bottom radii will get stretched when in crust
+ ! crustal layer stretching: element layer's top and bottom radii will get stretched when in crust
! (number of element layers in crust can vary for different resolutions and 1chunk simulations)
allocate(stretch_tab(2,ner(1)))
if (CASE_3D .and. iregion_code == IREGION_CRUST_MANTLE .and. .not. SUPPRESS_CRUSTAL_MESH) then
@@ -427,9 +427,9 @@
! number of element layers in this crust region
call stretching_function(r_top(1),r_bottom(1),ner(1),stretch_tab)
- ! RMIDDLE_CRUST so far is only used for 1D - models with two layers in the crust
+ ! RMIDDLE_CRUST so far is only used for 1D - models with two layers in the crust
! (i.e. ONE_CRUST is set to .false.), those models do not use CASE_3D
-
+
! all 3D models use this stretching function to honor a 3D crustal model
! for those models, we set RMIDDLE_CRUST to the bottom of the first element layer
! this value will be used in moho_stretching.f90 to decide whether or not elements
@@ -437,7 +437,7 @@
!
! note: stretch_tab uses (dimensionalized) radii from r_top and r_bottom
!(with stretch_tab( index_radius(1=top,2=bottom), index_layer( 1=first layer, 2=second layer, 3= ...) )
- RMIDDLE_CRUST = stretch_tab(2,1)
+ RMIDDLE_CRUST = stretch_tab(2,1)
endif
@@ -507,8 +507,8 @@
normal_moho,normal_400,normal_670,jacobian2D_moho,jacobian2D_400,jacobian2D_670, &
ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,&
ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot)
-
-
+
+
! mesh doubling elements
if( this_region_has_a_doubling(ilayer) ) &
call create_doubling_elements(myrank,ilayer,ichunk,ispec,ipass, &
@@ -652,20 +652,20 @@
! create AVS or DX mesh data for the slices
if(SAVE_MESH_FILES) then
call write_AVS_DX_global_data(myrank,prname,nspec,ibool,idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
-
+
call write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, &
idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
-
+
call write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun,ibool, &
idoubling,xstore,ystore,zstore,locval,ifseg,npointot, &
rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code)
-
+ RMIDDLE_CRUST,ROCEAN,iregion_code)
+
call write_AVS_DX_surface_data(myrank,prname,nspec,iboun,ibool, &
idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
-
+
!> Hejun
! Output material information for all GLL points
! Can be use to check the mesh
@@ -701,7 +701,7 @@
xigll,yigll,zigll)
! allocates mass matrix in this slice (will be fully assembled in the solver)
- allocate(rmass(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(rmass(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
! allocates ocean load mass matrix as well if oceans
if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) then
nglob_oceans = nglob
@@ -718,8 +718,8 @@
gammaxstore,gammaystore,gammazstore, &
iregion_code,nglob,rmass,rhostore,kappavstore, &
nglob_oceans,rmass_ocean_load,NSPEC2D_TOP,ibelm_top,jacobian2D_top, &
- xstore,ystore,zstore,RHO_OCEANS)
-
+ xstore,ystore,zstore,RHO_OCEANS)
+
! save the binary files
call save_arrays_solver(rho_vp,rho_vs,nspec_stacey, &
prname,iregion_code,xixstore,xiystore,xizstore, &
@@ -783,8 +783,8 @@
nspec,wxgll,wygll,wzgll,xixstore,xiystore,xizstore, &
etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
NSPEC2D_BOTTOM,jacobian2D_bottom,NSPEC2D_TOP,jacobian2D_top)
-
+
else
stop 'there cannot be more than two passes in mesh creation'
@@ -858,7 +858,7 @@
ONE_CRUST,NUMBER_OF_MESH_LAYERS,layer_shift, &
iregion_code,ifirst_region,ilast_region, &
first_layer_aniso,last_layer_aniso,nb_layer_above_aniso)
-
+
! create the different regions of the mesh
implicit none
@@ -871,7 +871,7 @@
double precision wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ)
double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ),dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ)
-
+
double precision shape2D_x(NGNOD2D,NGLLY,NGLLZ),shape2D_y(NGNOD2D,NGLLX,NGLLZ)
double precision shape2D_bottom(NGNOD2D,NGLLX,NGLLY),shape2D_top(NGNOD2D,NGLLX,NGLLY)
double precision dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ),dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ)
@@ -885,10 +885,10 @@
double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
integer idoubling(nspec)
-
+
logical iboun(6,nspec)
logical iMPIcut_xi(2,nspec),iMPIcut_eta(2,nspec)
-
+
integer ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot, &
ispec2D_670_top,ispec2D_670_bot
integer NEX_PER_PROC_ETA,nex_eta_moho
@@ -993,7 +993,7 @@
end subroutine crm_initialize_layers
-
+
!
!-------------------------------------------------------------------------------------------------
!
@@ -1002,13 +1002,13 @@
nspec,wxgll,wygll,wzgll,xixstore,xiystore,xizstore, &
etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
NSPEC2D_BOTTOM,jacobian2D_bottom,NSPEC2D_TOP,jacobian2D_top)
-
+
implicit none
-
+
include "constants.h"
double precision :: volume_local,area_local_bottom,area_local_top
-
+
integer :: nspec
double precision :: wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ)
@@ -1018,12 +1018,12 @@
integer :: NSPEC2D_BOTTOM,NSPEC2D_TOP
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM) :: jacobian2D_bottom
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP) :: jacobian2D_top
-
+
! local parameters
double precision :: weight
real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
integer :: i,j,k,ispec
-
+
! initializes
volume_local = ZERO
area_local_bottom = ZERO
@@ -1075,7 +1075,7 @@
enddo
enddo
enddo
-
-
+
+
end subroutine crm_compute_volumes
-
\ No newline at end of file
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/create_regular_elements.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/create_regular_elements.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/create_regular_elements.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -53,8 +53,8 @@
normal_moho,normal_400,normal_670,jacobian2D_moho,jacobian2D_400,jacobian2D_670, &
ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,&
ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot)
-
-
+
+
! adds a regular spectral element to the different regions of the mesh
use meshfem3D_models_par
@@ -65,10 +65,10 @@
! code for the four regions of the mesh
integer iregion_code
! correct number of spectral elements in each block depending on chunk type
- integer nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS
+ integer nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS
integer NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
- integer :: ner_without_doubling
+ integer :: ner_without_doubling
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
@@ -156,7 +156,7 @@
real(kind=CUSTOM_REAL) jacobian2D_moho(NGLLX,NGLLY,NSPEC2D_MOHO)
real(kind=CUSTOM_REAL) jacobian2D_400(NGLLX,NGLLY,NSPEC2D_400)
real(kind=CUSTOM_REAL) jacobian2D_670(NGLLX,NGLLY,NSPEC2D_670)
-
+
integer ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top, &
ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot
@@ -166,7 +166,7 @@
double precision :: r1,r2,r3,r4,r5,r6,r7,r8
integer :: ix_elem,iy_elem,iz_elem,ignod,ispec_superbrick
logical :: is_superbrick
-
+
! loop on all the elements
do ix_elem = 1,NEX_PER_PROC_XI,ratio_sampling_array(ilayer)
do iy_elem = 1,NEX_PER_PROC_ETA,ratio_sampling_array(ilayer)
@@ -187,7 +187,7 @@
! compute the actual position of all the grid points of that element
if (ilayer == 1 .and. CASE_3D .and. .not. SUPPRESS_CRUSTAL_MESH) then
! crustal elements are stretched to be thinner in the upper crust than in lower crust in the 3D case
- ! max ratio between size of upper crust elements and
+ ! max ratio between size of upper crust elements and
! lower crust elements is given by the param MAX_RATIO_STRETCHING
! to avoid stretching, set MAX_RATIO_STRETCHING = 1.0d in constants.h
call compute_coord_main_mesh(offset_x,offset_y,offset_z,xelm,yelm,zelm, &
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_cutplanes_xi.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_cutplanes_xi.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_MPI_cutplanes_xi.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -60,7 +60,7 @@
integer ispecc1,ispecc2,npoin2D_xi,ix,iy,iz
integer nspec2Dtheor
integer ier
-
+
! processor identification
character(len=150) prname,errmsg
@@ -78,7 +78,7 @@
open(unit=10,file=prname(1:len_trim(prname))//'iboolleft_xi.txt', &
status='unknown',iostat=ier)
if( ier /= 0 ) call exit_mpi(myrank,'error creating iboolleft_xi.txt for this process')
-
+
! erase the logical mask used to mark points already found
mask_ibool(:) = .false.
@@ -129,7 +129,7 @@
open(unit=10,file=prname(1:len_trim(prname))//'iboolright_xi.txt', &
status='unknown',iostat=ier)
if( ier /= 0 ) call exit_mpi(myrank,'error creating iboolright_xi.txt for this process')
-
+
! erase the logical mask used to mark points already found
mask_ibool(:) = .false.
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/get_cmt.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_cmt.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_cmt.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -62,7 +62,7 @@
ho = 0
mi = 0
sec = 0.d0
-
+
!
!---- read hypocenter info
!
@@ -133,10 +133,10 @@
close(1)
- ! Sets t_cmt to zero to initiate the simulation!
+ ! Sets t_cmt to zero to initiate the simulation!
if(NSOURCES == 1)then
t_cmt = 0.d0
- else
+ else
t_cmt(1:NSOURCES) = t_shift(1:NSOURCES)-minval(t_shift)
endif
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/get_ellipticity.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_ellipticity.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_ellipticity.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -67,7 +67,7 @@
end subroutine get_ellipticity
- !> Hejun
+ !> Hejun
! get ellipticity according to GLL points
! JAN08, 2010
subroutine get_ellipticity_gll(xstore,ystore,zstore,ispec,nspec,nspl,rspl,espl,espl2)
@@ -106,7 +106,7 @@
zstore(i,j,k,ispec)=zstore(i,j,k,ispec)*factor
end do
- end do
+ end do
end do
end subroutine get_ellipticity_gll
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/get_event_info.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_event_info.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_event_info.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -27,9 +27,9 @@
! get information about event name and location for SAC seismograms: MPI version by Dimitri Komatitsch
-! Instead of using region names as event names,
-! event names given in the second row of CMT files will be used.
-! Thus, I removed old parameters ename, region, LENGTH_REGION_NAME and added event_name!!!!!!!
+! Instead of using region names as event names,
+! event names given in the second row of CMT files will be used.
+! Thus, I removed old parameters ename, region, LENGTH_REGION_NAME and added event_name!!!!!!!
! Also, t_shift is added as a new parameter to be written on sac headers!
! by Ebru Bozdag
@@ -99,9 +99,9 @@
call MPI_BCAST(sec,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(NSOURCES,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
+
call MPI_BCAST(t_cmt,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
+
! event location given on first, PDE line
call MPI_BCAST(elat,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(elon,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
@@ -114,7 +114,7 @@
call MPI_BCAST(cmt_hdur,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
!call MPI_BCAST(ename,12,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(event_name,20,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(event_name,20,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
end subroutine get_event_info_parallel
@@ -124,8 +124,8 @@
! This subroutine reads the first line of the DATA/CMTSOLUTION file
! and extracts event information needed for SAC or PITSA headers
-! This subroutine has been modified to read full CMTSOLUTION file particularly for multiple-source cases.
-! Time-shifts of all sources can be read and the minimum t_shift is taken to be written in sac headers!
+! This subroutine has been modified to read full CMTSOLUTION file particularly for multiple-source cases.
+! Time-shifts of all sources can be read and the minimum t_shift is taken to be written in sac headers!
! by Ebru
subroutine get_event_info_serial(yr,jda,ho,mi,sec,event_name,t_cmt,t_shift,&
@@ -160,7 +160,7 @@
integer ios,mo,da,julian_day
integer isource
-
+
double precision, dimension(NSOURCES) :: t_s,hdur,lat,lon,depth
character(len=20), dimension(NSOURCES) :: e_n
@@ -169,8 +169,8 @@
character(len=5) datasource
character(len=150) string,CMTSOLUTION
!character(len=150) string,dummystring,CMTSOLUTION
-
+
!
!---- read hypocenter info
!
@@ -188,7 +188,7 @@
!if(mod(icounter,NLINES_PER_CMTSOLUTION_SOURCE) /= 0) &
! stop 'total number of lines in CMTSOLUTION file should be a multiple of NLINES_PER_CMTSOLUTION_SOURCE'
!NSOURCES = icounter / NLINES_PER_CMTSOLUTION_SOURCE
- !if(NSOURCES < 1) stop 'need at least one source in CMTSOLUTION file'
+ !if(NSOURCES < 1) stop 'need at least one source in CMTSOLUTION file'
!open(unit=821,file=CMTSOLUTION,status='old',action='read')
! example header line of CMTSOLUTION file
@@ -234,13 +234,13 @@
read(821,"(a)") string
read(821,"(a)") string
enddo
- ! sets t_cmt to zero
+ ! sets t_cmt to zero
t_cmt = 0.
-
+
! takes first event id as event_name
event_name = e_n(1)
-
- ! sets cmt infos
+
+ ! sets cmt infos
if (NSOURCES == 1) then
cmt_lat = lat(1)
cmt_lon = lon(1)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/get_global.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_global.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_global.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -146,19 +146,19 @@
! (put into this subroutine but compiler keeps on complaining that it can't vectorize loops...)
implicit none
-
+
include "constants.h"
-
+
integer :: nspec,nglob
integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
-
+
! mask to sort ibool
integer, dimension(:), allocatable :: mask_ibool
- integer, dimension(:,:,:,:), allocatable :: copy_ibool_ori
+ integer, dimension(:,:,:,:), allocatable :: copy_ibool_ori
integer :: inumber
integer:: i,j,k,ispec,ier
-
- ! copies original array
+
+ ! 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'
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/get_jacobian_boundaries.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_jacobian_boundaries.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_jacobian_boundaries.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -151,13 +151,13 @@
xelm2D(j,k) = xstore(1,j,k,ispec)
yelm2D(j,k) = ystore(1,j,k,ispec)
zelm2D(j,k) = zstore(1,j,k,ispec)
- end do
+ end do
end do
! recalculate jacobian according to 2D GLL points
call recalc_jacobian_gll2D(myrank,ispecb1,xelm2D,yelm2D,zelm2D, &
yigll,zigll,jacobian2D_xmin,normal_xmin,&
NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- end if
+ end if
endif
! on boundary: xmax
@@ -200,20 +200,20 @@
call compute_jacobian_2D(myrank,ispecb2,xelm,yelm,zelm,dershape2D_x, &
jacobian2D_xmax,normal_xmax,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- else
+ else
! get 25 GLL points for xmax
do k = 1,NGLLZ
do j = 1,NGLLY
xelm2D(j,k) = xstore(NGLLX,j,k,ispec)
yelm2D(j,k) = ystore(NGLLX,j,k,ispec)
zelm2D(j,k) = zstore(NGLLX,j,k,ispec)
- end do
+ end do
end do
! recalculate jacobian according to 2D GLL points
call recalc_jacobian_gll2D(myrank,ispecb2,xelm2D,yelm2D,zelm2D,&
yigll,zigll,jacobian2D_xmax,normal_xmax,&
NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- end if
+ end if
endif
! on boundary: ymin
@@ -263,13 +263,13 @@
xelm2D(i,k) = xstore(i,1,k,ispec)
yelm2D(i,k) = ystore(i,1,k,ispec)
zelm2D(i,k) = zstore(i,1,k,ispec)
- end do
- end do
+ end do
+ end do
! recalcualte 2D jacobian according to GLL points
call recalc_jacobian_gll2D(myrank,ispecb3,xelm2D,yelm2D,zelm2D,&
xigll,zigll,jacobian2D_ymin,normal_ymin,&
NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- end if
+ end if
endif
! on boundary: ymax
@@ -319,13 +319,13 @@
xelm2D(i,k) = xstore(i,NGLLY,k,ispec)
yelm2D(i,k) = ystore(i,NGLLY,k,ispec)
zelm2D(i,k) = zstore(i,NGLLY,k,ispec)
- end do
- end do
+ end do
+ end do
! recalculate jacobian for 2D GLL points
call recalc_jacobian_gll2D(myrank,ispecb4,xelm2D,yelm2D,zelm2D,&
xigll,zigll,jacobian2D_ymax,normal_ymax,&
NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- end if
+ end if
endif
! on boundary: bottom
@@ -366,21 +366,21 @@
call compute_jacobian_2D(myrank,ispecb5,xelm,yelm,zelm,dershape2D_bottom, &
jacobian2D_bottom,normal_bottom,NGLLX,NGLLY,NSPEC2D_BOTTOM)
-
- else
+
+ else
! get 25 GLL points for zmin
do j = 1,NGLLY
do i = 1,NGLLX
xelm2D(i,j) = xstore(i,j,1,ispec)
yelm2D(i,j) = ystore(i,j,1,ispec)
zelm2D(i,j) = zstore(i,j,1,ispec)
- end do
+ end do
end do
! recalcuate 2D jacobian according to GLL points
call recalc_jacobian_gll2D(myrank,ispecb5,xelm2D,yelm2D,zelm2D,&
xigll,yigll,jacobian2D_bottom,normal_bottom,&
NGLLX,NGLLY,NSPEC2D_BOTTOM)
- end if
+ end if
endif
@@ -429,14 +429,14 @@
xelm2D(i,j) = xstore(i,j,NGLLZ,ispec)
yelm2D(i,j) = ystore(i,j,NGLLZ,ispec)
zelm2D(i,j) = zstore(i,j,NGLLZ,ispec)
- end do
+ end do
end do
! recalcuate jacobian according to 2D gll points
call recalc_jacobian_gll2D(myrank,ispecb6,xelm2D,yelm2D,zelm2D,&
xigll,yigll,jacobian2D_top,normal_top,&
NGLLX,NGLLY,NSPEC2D_TOP)
- end if
+ end if
endif
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/get_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_model.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_model.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -32,10 +32,10 @@
c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
nspec_stacey,rho_vp,rho_vs, &
- xstore,ystore,zstore, &
+ xstore,ystore,zstore, &
rmin,rmax,RCMB,RICB,R670,RMOHO,RTOPDDOUBLEPRIME,R600,R220, &
R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- tau_s,tau_e_store,Qmu_store,T_c_source,vx,vy,vz,vnspec, &
+ tau_s,tau_e_store,Qmu_store,T_c_source,vx,vy,vz,vnspec, &
ABSORBING_CONDITIONS,elem_in_crust,elem_in_mantle)
use meshfem3D_models_par
@@ -76,26 +76,26 @@
logical ABSORBING_CONDITIONS
logical elem_in_crust,elem_in_mantle
-
+
! local parameters
double precision xmesh,ymesh,zmesh
! the 21 coefficients for an anisotropic medium in reduced notation
double precision c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,c33, &
c34,c35,c36,c44,c45,c46,c55,c56,c66
- double precision, dimension(N_SLS) :: tau_e
+ double precision, dimension(N_SLS) :: tau_e
- ! local parameters
- double precision rho,dvp
+ ! local parameters
+ double precision rho,dvp
double precision vpv,vph,vsv,vsh,eta_aniso
- double precision Qkappa,Qmu
- double precision r,r_prem,moho
+ double precision Qkappa,Qmu
+ double precision r,r_prem,moho
integer i,j,k
! loops over all gll points for this spectral element
do k=1,NGLLZ
do j=1,NGLLY
do i=1,NGLLX
-
+
! initializes values
rho = 0.d0
vpv = 0.d0
@@ -123,17 +123,17 @@
c46 = 0.d0
c55 = 0.d0
c56 = 0.d0
- c66 = 0.d0
+ c66 = 0.d0
Qmu = 0.d0
Qkappa = 0.d0 ! not used, not stored so far...
tau_e(:) = 0.d0
dvp = 0.d0
-
+
! sets xyz coordinates of GLL point
xmesh = xstore(i,j,k,ispec)
ymesh = ystore(i,j,k,ispec)
- zmesh = zstore(i,j,k,ispec)
-
+ zmesh = zstore(i,j,k,ispec)
+
! exact point location radius
r = dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*zmesh)
@@ -146,7 +146,7 @@
call get_model_check_idoubling(r_prem,xmesh,ymesh,zmesh,rmin,rmax,idoubling, &
RICB,RCMB,RTOPDDOUBLEPRIME, &
R220,R670,myrank)
-
+
! gets reference model values: rho,vpv,vph,vsv,vsh and eta_aniso
call meshfem3D_models_get1D_val(myrank,iregion_code,idoubling, &
r_prem,rho,vpv,vph,vsv,vsh,eta_aniso, &
@@ -161,7 +161,7 @@
xmesh,ymesh,zmesh,r, &
c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
c33,c34,c35,c36,c44,c45,c46,c55,c56,c66)
-
+
! gets the 3-D crustal model
if( CRUSTAL ) then
if( .not. elem_in_mantle) &
@@ -171,11 +171,11 @@
c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66, &
elem_in_crust,moho)
endif
-
+
! overwrites with tomographic model values (from iteration step) here, given at all GLL points
call meshfem3D_models_impose_val(vpv,vph,vsv,vsh,rho,dvp,eta_aniso,&
myrank,iregion_code,ispec,i,j,k)
-
+
! checks vpv: if close to zero then there is probably an error
if( vpv < TINYVAL ) then
print*,'error vpv: ',vpv,vph,vsv,vsh,rho
@@ -185,10 +185,10 @@
!> Hejun
! New Attenuation assignment
- ! Define 3D and 1D Attenuation after moho stretch
+ ! Define 3D and 1D Attenuation after moho stretch
! and before TOPOGRAPHY/ELLIPCITY
!
- !note: only Qmu attenuation considered, Qkappa attenuation not used so far...
+ !note: only Qmu attenuation considered, Qkappa attenuation not used so far...
if( ATTENUATION ) &
call meshfem3D_models_getatten_val(idoubling,xmesh,ymesh,zmesh,r_prem, &
tau_e,tau_s,T_c_source, &
@@ -336,7 +336,7 @@
R220,R670,myrank)
use meshfem3D_models_par
-
+
implicit none
!include "constants.h"
@@ -344,14 +344,14 @@
integer idoubling,myrank
double precision r_prem,rmin,rmax,x,y,z
-
+
double precision RICB,RCMB,RTOPDDOUBLEPRIME,R670,R220
double precision r_m,r,theta,phi
! compute real physical radius in meters
r_m = r_prem * R_EARTH
- ! checks layers
+ ! checks layers
if( abs(rmax - rmin ) < TINYVAL ) then
! there's probably an error
print*,'error layer radius min/max:',rmin,rmax
@@ -374,7 +374,7 @@
idoubling /= IFLAG_IN_FICTITIOUS_CUBE) then
call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
print*,'error point r/lat/lon:',r_m,90.0 - theta/DEGREES_TO_RADIANS,phi/DEGREES_TO_RADIANS
- print*,' idoubling/IFLAG: ',idoubling,IFLAG_INNER_CORE_NORMAL,'-to-',IFLAG_IN_FICTITIOUS_CUBE
+ print*,' idoubling/IFLAG: ',idoubling,IFLAG_INNER_CORE_NORMAL,'-to-',IFLAG_IN_FICTITIOUS_CUBE
call exit_MPI(myrank,'error in get_model_check_idoubling() wrong doubling flag for inner core point')
endif
!
@@ -432,5 +432,5 @@
endif
endif
-
- end subroutine get_model_check_idoubling
\ No newline at end of file
+
+ end subroutine get_model_check_idoubling
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/get_model_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/get_model_parameters.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/get_model_parameters.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -48,7 +48,7 @@
ISOTROPIC_3D_MANTLE,ONE_CRUST,TRANSVERSE_ISOTROPY
logical OCEANS,TOPOGRAPHY
-
+
double precision ROCEAN,RMIDDLE_CRUST, &
RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
@@ -71,7 +71,7 @@
RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS, &
HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL)
-
+
end subroutine get_model_parameters
@@ -99,15 +99,15 @@
CASE_3D,CRUSTAL,HETEROGEN_3D_MANTLE,HONOR_1D_SPHERICAL_MOHO,&
ISOTROPIC_3D_MANTLE,ONE_CRUST,TRANSVERSE_ISOTROPY
logical OCEANS,TOPOGRAPHY
-
- ! local parameters
+
+ ! local parameters
character(len=4) ending
character(len=8) ending_1Dcrust
-
- character(len=150) MODEL_ROOT
+
+ character(len=150) MODEL_ROOT
logical :: impose_1Dcrust
-
- ! defaults:
+
+ ! defaults:
!
! HONOR_1D_SPHERICAL_MOHO: honor PREM Moho or not: doing so drastically reduces
! the stability condition and therefore the time step, resulting in expensive
@@ -122,22 +122,22 @@
! layers in the case of 3D models. The purpose of this stretching is to squeeze more
! GLL points per km in the upper part of the crust than in the lower part.
!
-
+
! extract ending of model name
ending = ' '
if( len_trim(MODEL) > 4 ) ending = MODEL(len_trim(MODEL)-3:len_trim(MODEL))
-
+
! determines if the anisotropic inner core option should be turned on
if( ending == '_AIC' ) then
ANISOTROPIC_INNER_CORE = .true.
! in case it has an ending for the inner core, remove it from the name
MODEL_ROOT = MODEL(1: len_trim(MODEL)-4)
else
- ANISOTROPIC_INNER_CORE = .false.
+ ANISOTROPIC_INNER_CORE = .false.
! sets root name of model to original one
MODEL_ROOT = MODEL
endif
-
+
! checks with '_1Dcrust' option
impose_1Dcrust = .false.
ending_1Dcrust = ' '
@@ -148,14 +148,14 @@
MODEL_ROOT = MODEL_ROOT(1: len_trim(MODEL)-8)
endif
-
+
!---
!
! ADD YOUR MODEL HERE
!
!---
-
-
+
+
! uses PREM as the 1D reference model by default
! uses no mantle heterogeneities by default
! uses no 3D model by default
@@ -172,7 +172,7 @@
TRANSVERSE_ISOTROPY = .false.
! model specifics
-
+
! 1-D models
if(MODEL_ROOT == '1D_isotropic_prem') then
HONOR_1D_SPHERICAL_MOHO = .true.
@@ -353,16 +353,16 @@
THREE_D_MODEL = THREE_D_MODEL_S362ANI
TRANSVERSE_ISOTROPY = .true.
- else if(MODEL_ROOT == 'PPM') then
+ else if(MODEL_ROOT == 'PPM') then
! overimposed based on isotropic-prem
- CASE_3D = .true.
+ CASE_3D = .true.
CRUSTAL = .true.
ISOTROPIC_3D_MANTLE = .true.
ONE_CRUST = .true.
THREE_D_MODEL = THREE_D_MODEL_PPM
- else if(MODEL_ROOT == 'GLL') then
- ! model will be given on local basis, at all GLL points,
+ else if(MODEL_ROOT == 'GLL') then
+ ! model will be given on local basis, at all GLL points,
! as from meshfem3d output from routine save_arrays_solver()
CASE_3D = .true.
CRUSTAL = .true.
@@ -370,8 +370,8 @@
ONE_CRUST = .true.
! based on model s29ea
REFERENCE_1D_MODEL = REFERENCE_MODEL_1DREF
- THREE_D_MODEL = THREE_D_MODEL_GLL
- TRANSVERSE_ISOTROPY = .true.
+ THREE_D_MODEL = THREE_D_MODEL_GLL
+ TRANSVERSE_ISOTROPY = .true.
! note: after call to this routines read_compute_parameters() we will set
! mgll_v%model_gll flag and reset
! THREE_D_MODEL = THREE_D_MODEL_S29EA
@@ -381,20 +381,20 @@
else
print*
- print*,'error model: ',trim(MODEL)
+ print*,'error model: ',trim(MODEL)
stop 'model not implemented yet, edit get_model_parameters.f90 and recompile'
endif
- ! suppress the crustal layers
+ ! suppress the crustal layers
if( SUPPRESS_CRUSTAL_MESH ) then
CRUSTAL = .false.
OCEANS = .false.
ONE_CRUST = .false.
- TOPOGRAPHY = .false.
+ TOPOGRAPHY = .false.
endif
! additional option for 3D mantle models:
- ! this takes crust from reference 1D model rather than a 3D crust;
+ ! this takes crust from reference 1D model rather than a 3D crust;
if( impose_1Dcrust ) then
! no 3D crust
CRUSTAL = .false.
@@ -402,7 +402,7 @@
CASE_3D = .false.
! mesh honors the 1D moho depth
HONOR_1D_SPHERICAL_MOHO = .true.
- ! 2 element layers in top crust region rather than just one
+ ! 2 element layers in top crust region rather than just one
ONE_CRUST = .false.
endif
@@ -441,7 +441,7 @@
! parameters read from parameter file
integer REFERENCE_1D_MODEL
-
+
double precision ROCEAN,RMIDDLE_CRUST, &
RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
@@ -449,7 +449,7 @@
double precision RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS
logical HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL
-
+
! radii in PREM or IASP91
! and normalized density at fluid-solid interface on fluid size for coupling
! ROCEAN: radius of the ocean (m)
@@ -637,7 +637,7 @@
R80_FICTITIOUS_IN_MESHER = R80
if( CRUSTAL .and. CASE_3D ) then
!> Hejun
- ! mesh will honor 3D crustal moho topography
+ ! mesh will honor 3D crustal moho topography
! moves MOHO up 5km to honor moho topography deeper than 35 km
! moves R80 down to 120km depth in order to have less squeezing for elements below moho
RMOHO_FICTITIOUS_IN_MESHER = RMOHO_FICTITIOUS_IN_MESHER + RMOHO_STRETCH_ADJUSTEMENT
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/initialize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/initialize_simulation.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/initialize_simulation.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -56,9 +56,9 @@
hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,hprimewgll_xxT, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
rec_filename,STATIONS,nrec)
-
+
implicit none
-
+
include 'mpif.h'
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
@@ -85,12 +85,12 @@
SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT,&
OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY,&
ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE
-
+
character(len=150) LOCAL_PATH,OUTPUT_FILES
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ratio_sampling_array,ner
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
-
+
double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
@@ -98,8 +98,8 @@
! mesh model parameters
- logical TOPOGRAPHY,HONOR_1D_SPHERICAL_MOHO,ONE_CRUST
- logical COMPUTE_AND_STORE_STRAIN
+ logical TOPOGRAPHY,HONOR_1D_SPHERICAL_MOHO,ONE_CRUST
+ logical COMPUTE_AND_STORE_STRAIN
! for ellipticity
integer nspl
@@ -111,7 +111,7 @@
integer, dimension(MAX_NUM_REGIONS) :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
NSPEC2D_BOTTOM,NSPEC2D_TOP, &
NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
-
+
! Gauss-Lobatto-Legendre points of integration and weights
double precision, dimension(NGLLX) :: xigll,wxgll
double precision, dimension(NGLLY) :: yigll,wygll
@@ -122,37 +122,37 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xxT,hprimewgll_xxT
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xxT,hprimewgll_xxT
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
character(len=150) rec_filename,STATIONS
integer nrec
-
+
! local parameters
integer, dimension(MAX_NUM_REGIONS) :: NSPEC_computed,NGLOB_computed, &
- NSPEC2D_XI,NSPEC2D_ETA,NSPEC1D_RADIAL
+ NSPEC2D_XI,NSPEC2D_ETA,NSPEC1D_RADIAL
logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
integer :: ratio_divide_central_cube
integer :: sizeprocs
- integer :: ier,i,j,ios
- integer :: NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NCHUNKS,NPROC_XI,NPROC_ETA
+ integer :: ier,i,j,ios
+ integer :: NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NCHUNKS,NPROC_XI,NPROC_ETA
double precision :: RMOHO_FICTITIOUS_IN_MESHER,R120,R_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,&
CENTER_LATITUDE_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,ANGULAR_WIDTH_XI_IN_DEGREES,&
GAMMA_ROTATION_AZIMUTH
- integer :: REFERENCE_1D_MODEL,THREE_D_MODEL
+ integer :: REFERENCE_1D_MODEL,THREE_D_MODEL
logical :: TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE,OCEANS, &
ATTENUATION,ATTENUATION_3D,ROTATION,ELLIPTICITY,GRAVITY,CASE_3D,ISOTROPIC_3D_MANTLE, &
- HETEROGEN_3D_MANTLE,CRUSTAL,INFLATE_CENTRAL_CUBE
- character(len=150) :: MODEL,dummystring
+ HETEROGEN_3D_MANTLE,CRUSTAL,INFLATE_CENTRAL_CUBE
+ character(len=150) :: MODEL,dummystring
! if running on MareNostrum in Barcelona
- character(len=400) :: system_command
+ character(len=400) :: system_command
integer, external :: err_occurred
-
+
! sizeprocs returns number of processes started (should be equal to NPROCTOT).
! myrank is the rank of each process, between 0 and sizeprocs-1.
! as usual in MPI, process 0 is in charge of coordinating everything
@@ -199,7 +199,7 @@
if(err_occurred() /= 0) then
call exit_MPI(myrank,'an error occurred while reading the parameter file')
endif
-
+
endif
! distributes parameters from master to all processes
@@ -232,7 +232,7 @@
this_region_has_a_doubling,rmins,rmaxs, &
ratio_divide_central_cube,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
- REFERENCE_1D_MODEL,THREE_D_MODEL,ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE)
@@ -305,7 +305,7 @@
write(IMAIN,*)
write(IMAIN,*) 'model:'
-
+
if(ISOTROPIC_3D_MANTLE) then
write(IMAIN,*) ' incorporates 3-D lateral variations'
else
@@ -341,10 +341,10 @@
else
write(IMAIN,*) ' no general mantle anisotropy'
endif
-
+
write(IMAIN,*)
write(IMAIN,*)
-
+
endif
! check that the code is running with the requested nb of processes
@@ -447,12 +447,12 @@
if (SIMULATION_TYPE == 3 .and. (ANISOTROPIC_3D_MANTLE_VAL .or. ANISOTROPIC_INNER_CORE_VAL)) &
call exit_MPI(myrank, 'anisotropic model is not implemented for kernel simulations yet')
- ! checks attenuation
+ ! checks attenuation
if( ATTENUATION_VAL ) then
if (NSPEC_CRUST_MANTLE_ATTENUAT /= NSPEC_CRUST_MANTLE) &
call exit_MPI(myrank, 'NSPEC_CRUST_MANTLE_ATTENUAT /= NSPEC_CRUST_MANTLE, exit')
if (NSPEC_INNER_CORE_ATTENUATION /= NSPEC_INNER_CORE) &
- call exit_MPI(myrank, 'NSPEC_INNER_CORE_ATTENUATION /= NSPEC_INNER_CORE, exit')
+ call exit_MPI(myrank, 'NSPEC_INNER_CORE_ATTENUATION /= NSPEC_INNER_CORE, exit')
if( ATTENUATION_MIMIK ) then
print *,'Attenuation set true, no mimiking possible'
call exit_MPI(myrank,'attenuation and attenuation_mimik confilct')
@@ -466,7 +466,7 @@
COMPUTE_AND_STORE_STRAIN = .false.
endif
-
+
! make ellipticity
if(ELLIPTICITY_VAL) call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
@@ -488,7 +488,7 @@
hprime_xxT(j,i) = hprime_xx(i,j)
hprimewgll_xxT(j,i) = hprimewgll_xx(i,j)
enddo
- enddo
+ enddo
endif
! counts receiver stations
@@ -514,5 +514,5 @@
end subroutine initialize_simulation
-
-
\ No newline at end of file
+
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/intgrl.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/intgrl.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/intgrl.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -37,14 +37,14 @@
double precision f(640),r(640),s1(640),s2(640)
double precision s3(640),sum
-! Local variables
+! Local variables
double precision, parameter :: third = 1.0d0/3.0d0
double precision, parameter :: fifth = 1.0d0/5.0d0
double precision, parameter :: sixth = 1.0d0/6.0d0
double precision rji,yprime(640)
double precision s1l,s2l,s3l
-
+
integer i,j,n,kdis(28)
integer ndis,nir1
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/locate_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/locate_receivers.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/locate_receivers.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -358,7 +358,7 @@
! create file for QmX Harvard
! Harvard format does not support the network name
! therefore only the station name is included below
- ! compute total number of samples for normal modes with 1 sample per second
+ ! compute total number of samples for normal modes with 1 sample per second
open(unit=1,file=trim(OUTPUT_FILES)//'/RECORDHEADERS',status='unknown')
nsamp = nint(dble(NSTEP-1)*DT)
do irec = 1,nrec
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/meshfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/meshfem3D.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/meshfem3D.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -193,10 +193,10 @@
! ---------------------
!
! v. 5.0 aka Tiger, many developers some with Princeton Tiger logo on their shirts, February 2010:
-! new moho mesh stretching honoring crust2.0 moho depths,
+! new moho mesh stretching honoring crust2.0 moho depths,
! new attenuation assignment, new SAC headers, new general crustal models,
! faster performance due to Deville routines and enhanced loop unrolling,
-! slight changes in code structure
+! slight changes in code structure
!
! v. 4.0 David Michea and Dimitri Komatitsch, University of Pau, France, February 2008:
! new doubling brick in the mesh, new perfectly load-balanced mesh,
@@ -287,9 +287,9 @@
integer myrank,sizeprocs,ier
! check area and volume of the final mesh
- double precision area_local_bottom
- double precision area_local_top
- double precision volume_local,volume_total
+ double precision area_local_bottom
+ double precision area_local_top
+ double precision volume_local,volume_total
!integer iprocnum
@@ -407,7 +407,7 @@
! trivia about the programming style adopted here
!
! note 1: in general, we do not use modules in the fortran codes. this seems to
-! be mainly a performance reason. changing the codes to adopt modules
+! be mainly a performance reason. changing the codes to adopt modules
! will have to prove that it performs as fast as it does without now.
!
! another reason why modules are avoided, is to make the code thread safe.
@@ -428,7 +428,7 @@
! put your model structure into the module "meshfem3D_models_par"
! and add your specific routine calls to get 1D/3D/attenuation values.
!
-! - get_model_parameters.f90:
+! - get_model_parameters.f90:
! set your specific model flags and radii
!
! - read_compute_parameters.f90:
@@ -439,14 +439,14 @@
! in general, this file should have as first routine the model_***_broadcast() routine
! implemented which deals with passing the model structure to all processes.
! this involves reading in model specific data which is normally put in directory DATA/
-! then follows a routine that returns the velocity values
+! then follows a routine that returns the velocity values
! (as perturbation to the associated 1D reference model) for a given point location.
-!
-! finally, in order to compile the new mesher with your new file(s),
-! you will add it to the list in the 'Makefile.in' file and run
+!
+! finally, in order to compile the new mesher with your new file(s),
+! you will add it to the list in the 'Makefile.in' file and run
! `configure` to recreate a new Makefile.
-!
!
+!
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
@@ -551,11 +551,11 @@
this_region_has_a_doubling,rmins,rmaxs, &
ratio_divide_central_cube,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
- REFERENCE_1D_MODEL,THREE_D_MODEL,ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE)
-
+
! check that the code is running with the requested number of processes
if(sizeprocs /= NPROCTOT) call exit_MPI(myrank,'wrong number of MPI processes')
@@ -563,8 +563,8 @@
ANGULAR_WIDTH_XI_RAD = ANGULAR_WIDTH_XI_IN_DEGREES * PI / 180.d0
ANGULAR_WIDTH_ETA_RAD = ANGULAR_WIDTH_ETA_IN_DEGREES * PI / 180.d0
if(NCHUNKS /= 6) call euler_angles(rotation_matrix,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH)
-
+
! DK DK UGLY if running on MareNostrum in Barcelona
if(RUN_ON_MARENOSTRUM_BARCELONA) then
@@ -622,19 +622,19 @@
CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
NPROCTOT,iproc_xi_slice,iproc_eta_slice, &
NSPEC1D_RADIAL_CORNER,NSPEC2D_XI_FACE, &
- NSPEC2D_ETA_FACE,NGLOB1D_RADIAL_CORNER)
+ NSPEC2D_ETA_FACE,NGLOB1D_RADIAL_CORNER)
! user output
if(myrank == 0) call meshfem3D_output_info(myrank,sizeprocs,NEX_XI,NEX_ETA, &
NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT, &
R_CENTRAL_CUBE)
-
- ! distributes 3D models
+
+ ! distributes 3D models
call meshfem3D_models_broadcast(myrank,NSPEC, &
MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,&
R80,R220,R670,RCMB,RICB)
-
+
if(myrank == 0 ) then
write(IMAIN,*)
write(IMAIN,*) 'model setup successfully read in'
@@ -692,7 +692,7 @@
! create all the regions of the mesh
! perform two passes in this part to be able to save memory
- do ipass = 1,2
+ do ipass = 1,2
call create_regions_mesh(iregion_code,ibool,idoubling, &
xstore,ystore,zstore,rmins,rmaxs, &
@@ -727,8 +727,8 @@
area_local_bottom,area_local_top,&
volume_local,volume_total, &
RCMB,RICB,R_CENTRAL_CUBE)
-
+
! create chunk buffers if more than one chunk
if(NCHUNKS > 1) then
call create_chunk_buffers(iregion_code,NSPEC(iregion_code),ibool,idoubling, &
@@ -904,21 +904,21 @@
subroutine meshfem3D_create_addressing(myrank,NCHUNKS,NPROC,NPROC_ETA,NPROC_XI,NPROCTOT, &
addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice, &
OUTPUT_FILES)
-
+
implicit none
-
+
include "constants.h"
-
+
integer :: myrank,NCHUNKS,NPROC,NPROC_ETA,NPROC_XI,NPROCTOT
-
+
integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1) :: addressing
integer, dimension(0:NPROCTOT-1) :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
character(len=150) OUTPUT_FILES
-
+
! local parameters
integer ichunk,iproc_eta,iproc_xi,iprocnum,ier
-
+
! initializes
addressing(:,:,:) = 0
ichunk_slice(:) = 0
@@ -932,7 +932,7 @@
write(IMAIN,*) 'creating global slice addressing'
write(IMAIN,*)
endif
-
+
do ichunk = 1,NCHUNKS
do iproc_eta=0,NPROC_ETA-1
do iproc_xi=0,NPROC_XI-1
@@ -947,7 +947,7 @@
enddo
if(myrank == 0) close(IOUT)
-
+
end subroutine meshfem3D_create_addressing
@@ -968,15 +968,15 @@
! NSPEC2D_ETA_FACE,NGLOB1D_RADIAL_CORNER
implicit none
-
+
include "constants.h"
-
+
integer myrank
! this for all the regions
integer, dimension(MAX_NUM_REGIONS) :: NSPEC2D_XI,NSPEC2D_ETA, &
NSPEC1D_RADIAL,NGLOB1D_RADIAL
-
+
integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
@@ -990,15 +990,15 @@
! 1 : xi_min, eta_min
! 2 : xi_max, eta_min
! 3 : xi_max, eta_max
-! 4 : xi_min, eta_max
+! 4 : xi_min, eta_max
integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: &
NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
! 1 -> min, 2 -> max
integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE
-
-
+
+
! local parameters
- integer :: iregion
+ integer :: iregion
do iregion=1,MAX_NUM_REGIONS
NSPEC1D_RADIAL_CORNER(iregion,:) = NSPEC1D_RADIAL(iregion)
@@ -1069,8 +1069,8 @@
+ (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
endif
endif
- endif
-
+ endif
+
end subroutine meshfem3D_setup_counters
@@ -1083,13 +1083,13 @@
R_CENTRAL_CUBE)
use meshfem3D_models_par
-
+
implicit none
integer :: myrank,sizeprocs,NEX_XI,NEX_ETA, &
NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT
double precision :: R_CENTRAL_CUBE
-
+
write(IMAIN,*) 'This is process ',myrank
write(IMAIN,*) 'There are ',sizeprocs,' MPI processes'
write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
@@ -1183,13 +1183,13 @@
write(IMAIN,*) 'incorporating anisotropic inner core'
else
write(IMAIN,*) 'no inner-core anisotropy'
- endif
+ endif
write(IMAIN,*)
if(ANISOTROPIC_3D_MANTLE) then
write(IMAIN,*) 'incorporating anisotropic mantle'
else
write(IMAIN,*) 'no general mantle anisotropy'
- endif
+ endif
write(IMAIN,*)
write(IMAIN,*) 'Reference radius of the Earth used is ',R_EARTH_KM,' km'
write(IMAIN,*)
@@ -1207,21 +1207,21 @@
RCMB,RICB,R_CENTRAL_CUBE)
use meshfem3D_models_par
-
+
implicit none
-
+
include 'mpif.h'
integer :: myrank,NCHUNKS,iregion_code
-
+
double precision :: area_local_bottom,area_local_top,volume_local
double precision :: volume_total
double precision :: RCMB,RICB,R_CENTRAL_CUBE
-
+
! local parameters
double precision :: volume_total_region,area_total_bottom,area_total_top
integer :: ier
-
+
! use MPI reduction to compute total area and volume
volume_total_region = ZERO
area_total_bottom = ZERO
@@ -1274,7 +1274,7 @@
endif
-
+
end subroutine meshfem3D_compute_area
-
\ No newline at end of file
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/meshfem3D_models.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/meshfem3D_models.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/meshfem3D_models.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -33,11 +33,11 @@
! ADD YOUR MODEL HERE
!
!---
-
+
implicit none
include "constants.h"
-
+
! model_aniso_mantle_variables
type model_aniso_mantle_variables
sequence
@@ -221,7 +221,7 @@
double precision :: VP(29)
double precision :: VS(29)
double precision :: RA(29)
- double precision :: DEPJ(29)
+ double precision :: DEPJ(29)
end type model_jp3d_variables
type (model_jp3d_variables) JP3DM_V
! model_jp3d_variables
@@ -232,7 +232,7 @@
integer :: sea99_ndep
integer :: sea99_nlat
integer :: sea99_nlon
- integer :: dummy_pad ! padding 4 bytes to align the structure
+ integer :: dummy_pad ! padding 4 bytes to align the structure
double precision :: sea99_ddeg
double precision :: alatmin
double precision :: alatmax
@@ -253,7 +253,7 @@
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
+ 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
@@ -281,7 +281,7 @@
double precision thicknesssp(NLAYERS_CRUSTMAP)
double precision densitysp(NLAYERS_CRUSTMAP)
double precision velocpsp(NLAYERS_CRUSTMAP)
- double precision velocssp(NLAYERS_CRUSTMAP)
+ double precision velocssp(NLAYERS_CRUSTMAP)
end type model_crustmaps_variables
type (model_crustmaps_variables) GC_V
!model_crustmaps_variables
@@ -328,7 +328,7 @@
! tomographic iteration model on GLL points
real(kind=CUSTOM_REAL),dimension(:,:,:,:),pointer :: vs_new,vp_new,rho_new
double precision :: scale_velocity,scale_density
- logical :: MODEL_GLL
+ logical :: MODEL_GLL
end type model_gll_variables
type (model_gll_variables) MGLL_V
@@ -380,18 +380,18 @@
double precision rspl(NR),espl(NR),espl2(NR)
! model parameter and flags
- integer REFERENCE_1D_MODEL,THREE_D_MODEL
+ integer REFERENCE_1D_MODEL,THREE_D_MODEL
logical ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS
-
+
logical HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY
-
+
logical ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE
logical ATTENUATION,ATTENUATION_3D
-
+
logical ANISOTROPIC_INNER_CORE
-
+
end module meshfem3D_models_par
@@ -405,83 +405,83 @@
R80,R220,R670,RCMB,RICB)
! preparing model parameter coefficients on all processes
-
+
use meshfem3D_models_par
implicit none
-
+
! standard include of the MPI library
include 'mpif.h'
-
+
integer myrank
integer, dimension(MAX_NUM_REGIONS) :: NSPEC
integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD
double precision R80,R220,R670,RCMB,RICB
-
+
!---
!
! ADD YOUR MODEL HERE
!
!---
- ! sets up spline coefficients for ellipticity
+ ! sets up spline coefficients for ellipticity
if(ELLIPTICITY) &
call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
-
+
! GLL model uses s29ea as reference 3D model
if( THREE_D_MODEL == THREE_D_MODEL_GLL ) then
MGLL_V%MODEL_GLL = .true.
THREE_D_MODEL = THREE_D_MODEL_S29EA
else
- MGLL_V%MODEL_GLL = .false.
- endif
-
+ MGLL_V%MODEL_GLL = .false.
+ endif
+
! reads in 3D mantle models
if(ISOTROPIC_3D_MANTLE) then
-
+
select case( THREE_D_MODEL )
-
+
case(THREE_D_MODEL_S20RTS)
call model_s20rts_broadcast(myrank,D3MM_V)
-
+
case(THREE_D_MODEL_SEA99_JP3D)
! the variables read are declared and stored in structure SEA99M_V and JP3DM_V
call model_sea99_s_broadcast(myrank,SEA99M_V)
call model_jp3d_broadcast(myrank,JP3DM_V)
-
+
case(THREE_D_MODEL_SEA99)
! the variables read are declared and stored in structure SEA99M_V
call model_sea99_s_broadcast(myrank,SEA99M_V)
- case(THREE_D_MODEL_JP3D)
+ case(THREE_D_MODEL_JP3D)
! the variables read are declared and stored in structure JP3DM_V
call model_jp3d_broadcast(myrank,JP3DM_V)
-
+
case(THREE_D_MODEL_S362ANI,THREE_D_MODEL_S362WMANI, &
THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA)
call model_s362ani_broadcast(myrank,THREE_D_MODEL,numker,numhpa,ihpa,&
lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,itpspl, &
- xlaspl,xlospl,radspl,coe,hsplfl,dskker,kerstr,varstr,refmdl)
-
- case(THREE_D_MODEL_PPM)
- ! Point Profile Models
+ xlaspl,xlospl,radspl,coe,hsplfl,dskker,kerstr,varstr,refmdl)
+
+ case(THREE_D_MODEL_PPM)
+ ! Point Profile Models
! the variables read are declared and stored in structure PPM_V
- call model_ppm_broadcast(myrank,PPM_V)
+ call model_ppm_broadcast(myrank,PPM_V)
! could use EUcrust07 Vp crustal structure
call model_eucrust_broadcast(myrank,EUCM_V)
case default
call exit_MPI(myrank,'3D model not defined')
-
+
end select
-
+
endif
! arbitrary mantle models
if(HETEROGEN_3D_MANTLE) &
- call model_heterogen_mntl_broadcast(myrank,HMM)
+ call model_heterogen_mntl_broadcast(myrank,HMM)
! anisotropic mantle
if(ANISOTROPIC_3D_MANTLE) &
@@ -490,15 +490,15 @@
! crustal model
if(CRUSTAL) &
call meshfem3D_crust_broadcast(myrank)
-
+
! GLL model
if( MGLL_V%MODEL_GLL ) &
- call model_gll_broadcast(myrank,MGLL_V,NSPEC)
+ call model_gll_broadcast(myrank,MGLL_V,NSPEC)
! attenuation
if(ATTENUATION ) then
call model_attenuation_broadcast(myrank,AM_V,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD)
-
+
! 3D attenuation
if( ATTENUATION_3D) then
! Colleen's model defined originally between 24.4km and 650km
@@ -509,32 +509,32 @@
call model_attenuation_setup(REFERENCE_1D_MODEL, RICB, RCMB, &
R670, R220, R80,AM_V,M1066a_V,Mak135_V,Mref_V,SEA1DM_V,AM_S,AS_V)
endif
-
+
endif
! read topography and bathymetry file
if(TOPOGRAPHY .or. OCEANS) &
call model_topo_bathy_broadcast(myrank,ibathy_topo)
- ! re-defines/initializes models 1066a and ak135 and ref
- ! ( with possible external crustal model: if CRUSTAL is set to true
+ ! re-defines/initializes models 1066a and ak135 and ref
+ ! ( with possible external crustal model: if CRUSTAL is set to true
! it strips the 1-D crustal profile and replaces it with mantle properties)
select case( REFERENCE_1D_MODEL )
-
+
case(REFERENCE_MODEL_1066A)
call model_1066a_broadcast(CRUSTAL,M1066a_V)
-
+
case( REFERENCE_MODEL_AK135)
call model_ak135_broadcast(CRUSTAL,Mak135_V)
-
- case(REFERENCE_MODEL_1DREF)
+
+ case(REFERENCE_MODEL_1DREF)
call model_1dref_broadcast(CRUSTAL,Mref_V)
-
+
case(REFERENCE_MODEL_SEA1D)
call model_sea1d_broadcast(CRUSTAL,SEA1DM_V)
-
- end select
-
+
+ end select
+
end subroutine meshfem3D_models_broadcast
!
@@ -545,17 +545,17 @@
subroutine meshfem3D_crust_broadcast(myrank)
! preparing model parameter coefficients on all processes
-
+
use meshfem3D_models_par
implicit none
-
+
! standard include of the MPI library
include 'mpif.h'
-
+
integer myrank
-
-
+
+
!---
!
! ADD YOUR MODEL HERE
@@ -563,21 +563,21 @@
!---
select case (ITYPE_CRUSTAL_MODEL )
-
+
case (ICRUST_CRUST2)
! crust 2.0
- call model_crust_broadcast(myrank,CM_V)
-
+ call model_crust_broadcast(myrank,CM_V)
+
case (ICRUST_CRUSTMAPS)
! general crustmaps
- call model_crustmaps_broadcast(myrank,GC_V)
-
+ call model_crustmaps_broadcast(myrank,GC_V)
+
case default
stop 'crustal model type not defined'
-
+
end select
-
+
end subroutine meshfem3D_crust_broadcast
!
!-------------------------------------------------------------------------------------------------
@@ -595,9 +595,9 @@
! this calculates density and velocities
!
! note: if CRUSTAL is set, it strips the 1-D crustal profile and mantle gets expanded
-! up to the surface.
+! up to the surface.
! only exception is JP1D...
-!
+!
! routine returns: rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu
use meshfem3D_models_par
@@ -619,7 +619,7 @@
! ADD YOUR MODEL HERE
!
!---
-
+
! gets 1-D reference model parameters
select case ( REFERENCE_1D_MODEL )
@@ -636,14 +636,14 @@
ONE_CRUST,.true.,RICB,RCMB,RTOPDDOUBLEPRIME, &
R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
endif
-
+
case(REFERENCE_MODEL_1DREF)
! 1D-REF also known as STW105 (by Kustowski et al.) - used also as background for 3D models
call model_1dref(r_prem,rho,vpv,vph,vsv,vsh,eta_aniso,Qkappa,Qmu,iregion_code,CRUSTAL,Mref_V)
if(.not. TRANSVERSE_ISOTROPY) then
if(.not. ISOTROPIC_3D_MANTLE) then
! this case here is only executed for 1D_ref_iso
- ! calculates isotropic values
+ ! calculates isotropic values
vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv &
+ (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv &
@@ -651,33 +651,33 @@
endif
endif
- case(REFERENCE_MODEL_1066A)
+ case(REFERENCE_MODEL_1066A)
! 1066A (by Gilbert & Dziewonski) - pure isotropic model, used in 1D model mode only
call model_1066a(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,M1066a_V)
-
+
case(REFERENCE_MODEL_AK135)
! AK135 (by Kennett et al. ) - pure isotropic model, used in 1D model mode only
call model_ak135(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,Mak135_V)
- case(REFERENCE_MODEL_IASP91)
+ case(REFERENCE_MODEL_IASP91)
! IASP91 (by Kennett & Engdahl) - pure isotropic model, used in 1D model mode only
call model_iasp91(myrank,r_prem,rho,vp,vs,Qkappa,Qmu,idoubling, &
ONE_CRUST,.true.,RICB,RCMB,RTOPDDOUBLEPRIME, &
R771,R670,R400,R220,R120,RMOHO,RMIDDLE_CRUST)
-
+
case(REFERENCE_MODEL_JP1D)
!JP1D (by Zhao et al.) - pure isotropic model, used also as background for 3D models
call model_jp1d(myrank,r_prem,rho,vp,vs,Qkappa,Qmu,idoubling, &
.true.,RICB,RCMB,RTOPDDOUBLEPRIME, &
R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST)
- case(REFERENCE_MODEL_SEA1D)
- ! SEA1D (by Lebedev & Nolet) - pure isotropic model, used also as background for 3D models
+ case(REFERENCE_MODEL_SEA1D)
+ ! SEA1D (by Lebedev & Nolet) - pure isotropic model, used also as background for 3D models
call model_sea1d(r_prem,rho,vp,vs,Qkappa,Qmu,iregion_code,SEA1DM_V)
-
+
case default
stop 'unknown 1D reference Earth model in meshfem3D_models_get1D_val()'
-
+
end select
! needs to set vpv,vph,vsv,vsh and eta_aniso for isotropic models
@@ -693,8 +693,8 @@
endif ! TRANSVERSE_ISOTROPY
end subroutine meshfem3D_models_get1D_val
-
+
!
!-------------------------------------------------------------------------------------------------
!
@@ -708,17 +708,17 @@
c33,c34,c35,c36,c44,c45,c46,c55,c56,c66)
use meshfem3D_models_par
-
+
implicit none
integer iregion_code
double precision r_prem
double precision rho,dvp
double precision vpv,vph,vsv,vsh,eta_aniso
-
+
double precision RCMB,R670,RMOHO
- double precision xmesh,ymesh,zmesh,r
-
+ double precision xmesh,ymesh,zmesh,r
+
! the 21 coefficients for an anisotropic medium in reduced notation
double precision c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,c33, &
c34,c35,c36,c44,c45,c46,c55,c56,c66
@@ -739,7 +739,7 @@
dvsh = 0.
r_used = ZERO
suppress_mantle_extension = .false.
-
+
! gets point's theta/phi
call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
call reduce(theta,phi)
@@ -754,16 +754,16 @@
if(r_prem >= RMOHO/R_EARTH .and. .not. CRUSTAL) then
suppress_mantle_extension = .true.
endif
-
+
! gets parameters for isotropic 3D mantle model
!
! note: there can be tranverse isotropy in the mantle, but only lamé parameters
! like kappav,kappah,muv,muh and eta_aniso are used for these simulations
!
- ! note: in general, models here make use of perturbation values with respect to their
- ! corresponding 1-D reference models
+ ! note: in general, models here make use of perturbation values with respect to their
+ ! corresponding 1-D reference models
if( ISOTROPIC_3D_MANTLE .and. r_prem > RCMB/R_EARTH .and. .not. suppress_mantle_extension) then
-
+
! extend 3-D mantle model above the Moho to the surface before adding the crust
if(r_prem > RCMB/R_EARTH .and. r_prem < RMOHO/R_EARTH) then
! GLL point is in mantle region, takes exact location
@@ -776,10 +776,10 @@
r_used = 0.999999d0*RMOHO/R_EARTH
endif
endif
-
+
! gets model parameters
select case( THREE_D_MODEL )
-
+
case(THREE_D_MODEL_S20RTS)
! s20rts
call mantle_s20rts(r_used,theta,phi,dvs,dvp,drho,D3MM_V)
@@ -788,7 +788,7 @@
vsv=vsv*(1.0d0+dvs)
vsh=vsh*(1.0d0+dvs)
rho=rho*(1.0d0+drho)
-
+
case(THREE_D_MODEL_SEA99_JP3D)
! sea99 + jp3d1994
call model_sea99_s(r_used,theta,phi,dvs,SEA99M_V)
@@ -796,7 +796,7 @@
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
+ .and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
if(r_used > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
call model_jp3d_iso_zhao(r_used,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
vpv=vpv*(1.0d0+dvp)
@@ -805,14 +805,14 @@
vsh=vsh*(1.0d0+dvs)
endif
endif
-
+
case(THREE_D_MODEL_SEA99)
! sea99 Vs-only
call model_sea99_s(r_used,theta,phi,dvs,SEA99M_V)
vsv=vsv*(1.0d0+dvs)
vsh=vsh*(1.0d0+dvs)
-
- case(THREE_D_MODEL_JP3D)
+
+ case(THREE_D_MODEL_JP3D)
! jp3d1994
if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
.and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
@@ -824,7 +824,7 @@
vsh=vsh*(1.0d0+dvs)
endif
endif
-
+
case(THREE_D_MODEL_S362ANI,THREE_D_MODEL_S362WMANI, &
THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA)
! 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
@@ -856,19 +856,19 @@
vsh=vs
eta_aniso=1.0d0
endif
-
- case(THREE_D_MODEL_PPM )
- ! point profile model
+
+ case(THREE_D_MODEL_PPM )
+ ! point profile model
call model_PPM(r_used,theta,phi,dvs,dvp,drho,PPM_V)
vpv=vpv*(1.0d0+dvp)
vph=vph*(1.0d0+dvp)
vsv=vsv*(1.0d0+dvs)
vsh=vsh*(1.0d0+dvs)
- rho=rho*(1.0d0+drho)
-
+ rho=rho*(1.0d0+drho)
+
case default
stop 'unknown 3D Earth model in meshfem3D_models_get3Dmntl_val() '
-
+
end select ! THREE_D_MODEL
endif ! ISOTROPIC_3D_MANTLE
@@ -890,7 +890,7 @@
vpv,vph,vsv,vsh,rho,eta_aniso)
if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
-
+
! anisotropic model between the Moho and 670 km (change to CMB if desired)
if( r_prem > R670/R_EARTH .and. .not. suppress_mantle_extension ) then
@@ -902,10 +902,10 @@
! fills 3-D mantle model above the Moho with the values at moho depth
r_used = RMOHO/R_EARTH
endif
- endif
+ endif
call model_aniso_mantle(r_used,theta,phi,rho,c11,c12,c13,c14,c15,c16, &
c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66,AMM_V)
-
+
else
! fills the rest of the mantle with the isotropic model
c11 = rho*vpv*vpv
@@ -933,7 +933,7 @@
endif ! ANISOTROPIC_3D_MANTLE
!> Hejun
-! Assign Attenuation after get 3-D crustal model
+! Assign Attenuation after get 3-D crustal model
! This is here to identify how and where to include 3D attenuation
! if(ATTENUATION .and. ATTENUATION_3D) then
! call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r_dummy,theta,phi)
@@ -969,8 +969,8 @@
implicit none
integer iregion_code
- ! note: r is the exact radius (and not r_prem with tolerance)
- double precision xmesh,ymesh,zmesh,r
+ ! note: r is the exact radius (and not r_prem with tolerance)
+ double precision xmesh,ymesh,zmesh,r
double precision vpv,vph,vsv,vsh,rho,eta_aniso,dvp
! the 21 coefficients for an anisotropic medium in reduced notation
@@ -987,7 +987,7 @@
double precision :: dvs
logical :: found_crust,found_eucrust
- ! checks if anything to do, that is, there is nothing to do
+ ! checks if anything to do, that is, there is nothing to do
! for point radius smaller than deepest possible crust radius (~80 km depth)
if( r < R_DEEPEST_CRUST ) return
@@ -997,13 +997,13 @@
lat = (PI/2.0d0-theta)*180.0d0/PI
lon = phi*180.0d0/PI
if(lon>180.0d0) lon = lon-360.0d0
-
+
!---
!
! ADD YOUR MODEL HERE
!
!---
-
+
! crustal model can vary for different 3-D models
select case (THREE_D_MODEL )
@@ -1011,15 +1011,15 @@
! tries to use Zhao's model of the crust
if(theta>=(PI/2.d0 - LAT_MAX*DEGREES_TO_RADIANS) .and. theta<=(PI/2.d0 - LAT_MIN*DEGREES_TO_RADIANS) &
.and. phi>=LON_MIN*DEGREES_TO_RADIANS .and. phi<=LON_MAX*DEGREES_TO_RADIANS) then
- ! makes sure radius is fine
+ ! makes sure radius is fine
if(r > (R_EARTH - DEP_MAX*1000.d0)/R_EARTH) then
call model_jp3d_iso_zhao(r,theta,phi,vpc,vsc,dvp,dvs,rhoc,found_crust,JP3DM_V)
endif
else
- ! default crust
- call meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
+ ! default crust
+ call meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
endif
-
+
case ( THREE_D_MODEL_PPM )
! takes vs,rho from default crust
call meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
@@ -1044,7 +1044,7 @@
rho=rhoc
eta_aniso=1.0d0
- ! sets anisotropy in crustal region as well
+ ! sets anisotropy in crustal region as well
if( ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
c11 = rho*vpv*vpv
c12 = rho*(vpv*vpv-2.*vsv*vsv)
@@ -1069,7 +1069,7 @@
c66 = c44
endif
endif
-
+
end subroutine meshfem3D_models_get3Dcrust_val
!
@@ -1080,28 +1080,28 @@
subroutine meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
! returns velocity/density for default crust
-
+
use meshfem3D_models_par
implicit none
-
+
! standard include of the MPI library
include 'mpif.h'
-
+
!integer myrank
double precision,intent(in) :: lat,lon,r
double precision,intent(out) :: vpc,vsc,rhoc
double precision,intent(out) :: moho
logical,intent(out) :: found_crust
logical,intent(in) :: elem_in_crust
-
+
! initializes
vpc = 0.d0
vsc = 0.d0
rhoc = 0.d0
moho = 0.d0
found_crust = .false.
-
+
!---
!
! ADD YOUR MODEL HERE
@@ -1109,21 +1109,21 @@
!---
select case (ITYPE_CRUSTAL_MODEL )
-
+
case (ICRUST_CRUST2)
! crust 2.0
- call model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,CM_V,elem_in_crust)
-
+ call model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,CM_V,elem_in_crust)
+
case (ICRUST_CRUSTMAPS)
! general crustmaps
call model_crustmaps(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,GC_V,elem_in_crust)
-
+
case default
stop 'crustal model type not defined'
-
+
end select
-
+
end subroutine meshfem3D_model_crust
!
@@ -1133,11 +1133,11 @@
subroutine meshfem3D_models_getatten_val(idoubling,xmesh,ymesh,zmesh,r_prem, &
tau_e,tau_s,T_c_source, &
- moho,Qmu,Qkappa,elem_in_crust)
+ moho,Qmu,Qkappa,elem_in_crust)
! sets attenuation values tau_e and Qmu for a given point
!
-! note: only Qmu attenuation considered, Qkappa attenuation not used so far in solver...
+! note: only Qmu attenuation considered, Qkappa attenuation not used so far in solver...
use meshfem3D_models_par
@@ -1148,20 +1148,20 @@
double precision xmesh,ymesh,zmesh
double precision r_prem
- double precision moho
+ double precision moho
! attenuation values
double precision Qkappa,Qmu
double precision, dimension(N_SLS) :: tau_s, tau_e
double precision T_c_source
-
+
logical elem_in_crust
! local parameters
- double precision r_dummy,theta,phi,theta_degrees,phi_degrees
+ double precision r_dummy,theta,phi,theta_degrees,phi_degrees
double precision, parameter :: rmoho_prem = 6371.0-24.4
double precision r_used
-
+
! initializes
tau_e(:) = 0.0d0
@@ -1181,68 +1181,68 @@
call reduce(theta,phi)
theta_degrees = theta / DEGREES_TO_RADIANS
phi_degrees = phi / DEGREES_TO_RADIANS
-
- ! in case models incorporate a 3D crust, attenuation values for mantle
+
+ ! in case models incorporate a 3D crust, attenuation values for mantle
! get expanded up to surface, and for the crustal points Qmu for PREM crust is imposed
- r_used = r_prem*R_EARTH_KM
+ r_used = r_prem*R_EARTH_KM
if( CRUSTAL ) then
if ( r_prem > (ONE-moho) .or. elem_in_crust) then
! points in actual crust: puts point radius into prem crust
r_used = rmoho_prem*1.0001
- else if( r_prem*R_EARTH_KM >= rmoho_prem ) then
- ! points below actual crust (e.g. oceanic crust case), but above prem moho:
+ else if( r_prem*R_EARTH_KM >= rmoho_prem ) then
+ ! points below actual crust (e.g. oceanic crust case), but above prem moho:
! puts point slightly below prem moho to expand mantle values at that depth
r_used = rmoho_prem*0.99999
endif
endif ! CRUSTAL
-
+
! gets value according to radius/theta/phi location and idoubling flag
call model_atten3D_QRFSI12(r_used,theta_degrees,phi_degrees,Qmu,QRFSI12_Q,idoubling)
- else
+ else
select case (REFERENCE_1D_MODEL)
- ! case(REFERENCE_MODEL_PREM)
- ! this case is probably not needed since Qmu is 600. between R80 and surface
+ ! case(REFERENCE_MODEL_PREM)
+ ! this case is probably not needed since Qmu is 600. between R80 and surface
! call model_attenuation_1D_PREM(r_prem, Qmu)
case(REFERENCE_MODEL_1DREF)
! 1D Ref changes Qmu at moho depth of 24.4km
! we take the crustal value and assign it to points only inside actual crust,
! otherwise the mantle values is taken
- ! makes sense especially for points below thin oceanic and thick continental crust
+ ! makes sense especially for points below thin oceanic and thick continental crust
if ( CRUSTAL ) then
- ! takes crustal Q value only if point is in actual crust
+ ! takes crustal Q value only if point is in actual crust
if ( r_prem > (ONE-moho) .or. elem_in_crust) then
- ! reference from 1D-REF aka STW105
+ ! reference from 1D-REF aka STW105
Qmu=300.0d0
Qkappa=57822.5d0 ! not used so far...
- endif
+ endif
endif ! CRUSTAL
case(REFERENCE_MODEL_SEA1D)
! SEA1D changes Qmu at 25km (moho) depth. we take the crustal value
! for points only inside actual crust
if ( CRUSTAL ) then
- ! takes crustal Q value only if point is in actual crust
+ ! takes crustal Q value only if point is in actual crust
if ( r_prem > (ONE-moho) .or. elem_in_crust) then
- ! reference from Sea1D
+ ! reference from Sea1D
Qmu = 300.0d0
- Qkappa = 57822.5d0 ! not used so far...
- endif
+ Qkappa = 57822.5d0 ! not used so far...
+ endif
endif
end select
-
- end if
+ end if
+
! Get tau_e from tau_s and Qmu
call model_attenuation_getstored_tau(Qmu, T_c_source, tau_s, tau_e, AM_V, AM_S, AS_V)
-
+
end subroutine meshfem3D_models_getatten_val
-
+
!
!-------------------------------------------------------------------------------------------------
!
@@ -1259,23 +1259,23 @@
double precision :: vpv,vph,vsv,vsh,rho,dvp,eta_aniso
integer :: myrank,iregion_code,ispec,i,j,k
-
+
! local parameters
double precision :: vp,vs
-
- ! model GLL
+
+ ! model GLL
if( MGLL_V%MODEL_GLL .and. iregion_code == IREGION_CRUST_MANTLE ) then
!check
if( ispec > size(MGLL_V%vp_new(1,1,1,:)) ) then
call exit_MPI(myrank,'model gll: ispec too big')
endif
- ! takes stored gll values from file
+ ! takes stored gll values from file
if(CUSTOM_REAL == SIZE_REAL) then
vp = dble( MGLL_V%vp_new(i,j,k,ispec) )
vs = dble( MGLL_V%vs_new(i,j,k,ispec) )
rho = dble( MGLL_V%rho_new(i,j,k,ispec) )
else
- vp = MGLL_V%vp_new(i,j,k,ispec)
+ vp = MGLL_V%vp_new(i,j,k,ispec)
vs = MGLL_V%vs_new(i,j,k,ispec)
rho = MGLL_V%rho_new(i,j,k,ispec)
endif
@@ -1283,16 +1283,16 @@
vp = vp * MGLL_V%scale_velocity
vs = vs * MGLL_V%scale_velocity
rho = rho * MGLL_V%scale_density
- ! isotropic model
- vpv = vp
- vph = vp
- vsv = vs
- vsh = vs
- rho = rho
+ ! isotropic model
+ vpv = vp
+ vph = vp
+ vsv = vs
+ vsh = vs
+ rho = rho
dvp = 0.0d0
eta_aniso = 1.0d0
endif ! MODEL_GLL
end subroutine meshfem3D_models_impose_val
-
-
\ No newline at end of file
+
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_1066a.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_1066a.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_1066a.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -28,7 +28,7 @@
!--------------------------------------------------------------------------------------------------
! 1066A
!
-! Spherically symmetric earth model 1066A [Gilbert and Dziewonski, 1975].
+! Spherically symmetric earth model 1066A [Gilbert and Dziewonski, 1975].
!
! When ATTENTUATION is on, it uses an unpublished 1D attenuation model from Scripps.
!--------------------------------------------------------------------------------------------------
@@ -36,7 +36,7 @@
subroutine model_1066a_broadcast(CRUSTAL,M1066a_V)
-! standard routine to setup model
+! standard routine to setup model
implicit none
@@ -60,7 +60,7 @@
! all processes will define same parameters
call define_model_1066a(CRUSTAL, M1066a_V)
-
+
end subroutine model_1066a_broadcast
!
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_1dref.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_1dref.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_1dref.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -31,27 +31,27 @@
!
! this is STW105 - new reference model, also known as REF
!
-! A recent 1D Earth model developed by Kustowski et al. This model is the 1D background
+! A recent 1D Earth model developed by Kustowski et al. This model is the 1D background
! model for the 3D models s362ani, s362wmani, s362ani_prem, and s29ea.
!
! see chapter 3, in:
-! Kustowski, B, Ekstrom, G., and A. M. Dziewonski, 2008,
+! Kustowski, B, Ekstrom, G., and A. M. Dziewonski, 2008,
! Anisotropic shear-wave velocity structure of the Earth's mantle: A global model,
! J. Geophys. Res., 113, B06306, doi:10.1029/2007JB005169.
!
! model is identical to PREM at crustal depths, between 220 and 400km
! and below 670km.
!
-! attenuation structure is taken from model QL6:
+! attenuation structure is taken from model QL6:
! Durek, J. J. and G. Ekström, 1996.
-! A radial model of anelasticity consistent with long period surface wave attenuation,
+! A radial model of anelasticity consistent with long period surface wave attenuation,
! Bull. Seism. Soc. Am., 86, 144-158
!--------------------------------------------------------------------------------------------------
subroutine model_1dref_broadcast(CRUSTAL,Mref_V)
-! standard routine to setup model
+! standard routine to setup model
implicit none
@@ -78,7 +78,7 @@
! all processes will define same parameters
call define_model_1dref(CRUSTAL,Mref_V)
-
+
end subroutine model_1dref_broadcast
!
@@ -145,7 +145,7 @@
if(iregion_code == IREGION_OUTER_CORE .and. i > 358) i = 358
if(iregion_code == IREGION_CRUST_MANTLE .and. i < 360) i = 360
-
+
! if crustal model is used, mantle gets expanded up to surface
! for any depth less than 24.4 km, values from mantle below moho are taken
if(CRUSTAL .and. i > 717) i = 717
@@ -162,7 +162,7 @@
Qkappa = Mref_V%Qkappa_ref(i)
Qmu = Mref_V%Qmu_ref(i)
else
- ! interpolates between one layer below to actual radius layer,
+ ! interpolates between one layer below to actual radius layer,
! that is from radius_ref(i-1) to r using the values at i-1 and i
frac = (r-Mref_V%radius_ref(i-1))/(Mref_V%radius_ref(i)-Mref_V%radius_ref(i-1))
! interpolated model parameters
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_ak135.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_ak135.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_ak135.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -39,7 +39,7 @@
subroutine model_ak135_broadcast(CRUSTAL,Mak135_V)
-! standard routine to setup model
+! standard routine to setup model
implicit none
@@ -63,7 +63,7 @@
! all processes will define same parameters
call define_model_ak135(CRUSTAL, Mak135_V)
-
+
end subroutine model_ak135_broadcast
!
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_inner_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_inner_core.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_inner_core.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -29,7 +29,7 @@
!
! based on scaling factors by Ishii et al. (2002)
!
-! one should add an MPI_BCAST in meshfem3D_models.f90 if one
+! one should add an MPI_BCAST in meshfem3D_models.f90 if one
! adds a 3D model or a read_aniso_inner_core_model subroutine
!--------------------------------------------------------------------------------------------------
@@ -46,21 +46,21 @@
double precision x,c11,c33,c12,c13,c44
double precision rho,vpv,vph,vsv,vsh,eta_aniso
-
+
! local parameters
double precision vp,vs
double precision vpc,vsc,rhoc
double precision vp0,vs0,rho0,A0
double precision c66
double precision scale_fac
-
+
! calculates isotropic values from given (transversely isotropic) reference values
! (are non-dimensionalized)
vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv &
+ (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv &
+ 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
-
+
! scale to dimensions (e.g. used in prem model)
scale_fac = R_EARTH*dsqrt(PI*GRAV*RHOAV)/1000.d0
vp = vp * scale_fac
@@ -68,7 +68,7 @@
rho = rho * RHOAV/1000.d0
select case(REFERENCE_1D_MODEL)
-
+
case(REFERENCE_MODEL_IASP91)
vpc=11.24094d0-4.09689d0*x*x
vsc=3.56454d0-3.45241d0*x*x
@@ -77,13 +77,13 @@
if( abs(vpc-vp) > TINYVAL .or. abs(vsc-vs) > TINYVAL .or. abs(rhoc-rho) > TINYVAL) then
stop 'error isotropic IASP91 values in model_aniso_inner_core() '
endif
-
+
! values at center
vp0=11.24094d0
vs0=3.56454d0
rho0=13.0885d0
- case(REFERENCE_MODEL_PREM)
+ case(REFERENCE_MODEL_PREM)
vpc=11.2622d0-6.3640d0*x*x
vsc=3.6678d0-4.4475d0*x*x
rhoc=13.0885d0-8.8381d0*x*x
@@ -97,7 +97,7 @@
vs0=3.6678d0
rho0=13.0885d0
- case(REFERENCE_MODEL_1DREF)
+ case(REFERENCE_MODEL_1DREF)
! values at center
vp0 = 11262.20 / 1000.0d0
vs0 = 3667.800 / 1000.0d0
@@ -108,13 +108,13 @@
vp0 = 11.33830
vs0 = 3.62980
rho0 = 13.429030
-
+
case(REFERENCE_MODEL_AK135)
! values at center
vp0 = 11.26220
vs0 = 3.667800
rho0 = 13.01220
-
+
case(REFERENCE_MODEL_JP1D)
! values at center
vp0 = 11.24094
@@ -162,7 +162,7 @@
! c13 = lambda
! c44 = mu
! c66 = mu
-
+
! Ishii et al. (2002):
!
! alpha = 3.490 % = (C-A)/A0 = (c33-c11)/A0
@@ -195,7 +195,7 @@
c12 = c11 - 2.0d0*c66
A0 = rho0*vp0*vp0*scale_fac
-
+
c33 = c11 + 0.0349d0*A0
c44 = c66 + 0.00988d0*A0
c13 = c12 - 0.00881d0*A0
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_mantle.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_mantle.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_aniso_mantle.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -43,7 +43,7 @@
subroutine model_aniso_mantle_broadcast(myrank,AMM_V)
-! standard routine to setup model
+! standard routine to setup model
implicit none
@@ -57,24 +57,24 @@
double precision beta(14,34,37,73)
double precision pro(47)
integer npar1
- integer dummy_pad ! padding 4 bytes to align the structure
+ integer dummy_pad ! padding 4 bytes to align the structure
end type model_aniso_mantle_variables
type (model_aniso_mantle_variables) AMM_V
! model_aniso_mantle_variables
-
+
integer :: myrank
integer :: ier
-
+
! the variables read are declared and stored in structure AMM_V
if(myrank == 0) call read_aniso_mantle_model(AMM_V)
-
+
! broadcast the information read on the master to the nodes
call MPI_BCAST(AMM_V%npar1,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(AMM_V%beta,14*34*37*73,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(AMM_V%pro,47,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
+
end subroutine model_aniso_mantle_broadcast
!
@@ -96,7 +96,7 @@
double precision beta(14,34,37,73)
double precision pro(47)
integer npar1
- integer dummy_pad ! padding 4 bytes to align the structure
+ integer dummy_pad ! padding 4 bytes to align the structure
end type model_aniso_mantle_variables
type (model_aniso_mantle_variables) AMM_V
@@ -374,7 +374,7 @@
double precision beta(14,34,37,73)
double precision pro(47)
integer npar1
- integer dummy_pad ! padding 4 bytes to align the structure
+ integer dummy_pad ! padding 4 bytes to align the structure
end type model_aniso_mantle_variables
type (model_aniso_mantle_variables) AMM_V
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_atten3D_QRFSI12.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_atten3D_QRFSI12.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_atten3D_QRFSI12.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -44,7 +44,7 @@
subroutine model_atten3D_QRFSI12_broadcast(myrank,QRFSI12_Q)
-! standard routine to setup model
+! standard routine to setup model
implicit none
@@ -76,9 +76,9 @@
if(myrank == 0) write(IMAIN,*) 'read 3D attenuation model'
-
- end subroutine
+ end subroutine
+
!
!-------------------------------------------------------------------------------------------------
!
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_attenuation.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_attenuation.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_attenuation.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -53,7 +53,7 @@
subroutine model_attenuation_broadcast(myrank,AM_V,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD)
-! standard routine to setup model
+! standard routine to setup model
implicit none
@@ -78,7 +78,7 @@
integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
integer :: Qn ! Number of points
- integer dummy_pad ! padding 4 bytes to align the structure
+ integer dummy_pad ! padding 4 bytes to align the structure
end type model_attenuation_variables
type (model_attenuation_variables) AM_V
@@ -292,7 +292,7 @@
if(myrank > 0) return
- ! uses "pure" 1D models including their 1D-crust profiles
+ ! uses "pure" 1D models including their 1D-crust profiles
! (uses USE_EXTERNAL_CRUSTAL_MODEL set to false)
if(REFERENCE_1D_MODEL == REFERENCE_MODEL_PREM) then
AM_V%Qn = 12
@@ -493,11 +493,11 @@
!Qmu = Qtmp / Q_resolution;
! by default: resolution is Q_resolution = 10
- ! converts Qmu to an array integer index:
+ ! converts Qmu to an array integer index:
! e.g. Qmu = 150.31 -> Qtmp = 150.31 * 10 = int( 1503.10 ) = 1503
Qtmp = Qmu * dble(AM_S%Q_resolution)
-
- ! rounds to corresponding double value:
+
+ ! rounds to corresponding double value:
! e.g. Qmu_new = dble( 1503 ) / dble(10) = 150.30
! but Qmu_new is not used any further...
Qmu_new = dble(Qtmp) / dble(AM_S%Q_resolution)
@@ -1482,4 +1482,4 @@
! endif
!
! end subroutine model_attenuation_1D_REF
-!
\ No newline at end of file
+!
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_crust.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_crust.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_crust.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -28,9 +28,9 @@
!--------------------------------------------------------------------------------------------------
! CRUST 2.0 model by Bassin et al. (2000)
!
-! C. Bassin, G. Laske, and G. Masters.
-! The current limits of resolution for surface wave tomography in North America.
-! EOS, 81: F897, 2000.
+! C. Bassin, G. Laske, and G. Masters.
+! The current limits of resolution for surface wave tomography in North America.
+! EOS, 81: F897, 2000.
!
! reads and smooths crust2.0 model
!--------------------------------------------------------------------------------------------------
@@ -38,7 +38,7 @@
subroutine model_crust_broadcast(myrank,CM_V)
-! standard routine to setup model
+! standard routine to setup model
implicit none
@@ -55,15 +55,15 @@
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
+ 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)
@@ -74,8 +74,8 @@
call MPI_BCAST(CM_V%dens,NKEYS_CRUST*NLAYERS_CRUST,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(CM_V%abbreviation,NCAP_CRUST*NCAP_CRUST,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(CM_V%code,2*NKEYS_CRUST,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
-
-
+
+
end subroutine model_crust_broadcast
!
@@ -97,14 +97,14 @@
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
+ character(len=2) dummy_pad ! padding 2 bytes to align the structure
end type model_crust_variables
type (model_crust_variables) CM_V
! model_crust_variables
double precision lat,lon,x,vp,vs,rho,moho
- logical found_crust,elem_in_crust
+ logical found_crust,elem_in_crust
! local parameters
double precision h_sed,h_uc
@@ -129,8 +129,8 @@
x7 = (R_EARTH-(h_uc+thicks(6)+thicks(7))*1000.0d0)/R_EARTH
found_crust = .true.
-
- if(x > x3 .and. INCLUDE_SEDIMENTS_CRUST &
+
+ if(x > x3 .and. INCLUDE_SEDIMENTS_CRUST &
.and. h_sed > MINIMUM_SEDIMENT_THICKNESS/R_EARTH_KM) then
vp = vps(3)
vs = vss(3)
@@ -139,7 +139,7 @@
.and. h_sed > MINIMUM_SEDIMENT_THICKNESS/R_EARTH_KM) then
vp = vps(4)
vs = vss(4)
- rho = rhos(4)
+ rho = rhos(4)
else if(x > x5) then
vp = vps(5)
vs = vss(5)
@@ -153,7 +153,7 @@
! if elem_in_crust is set
!
! note: it looks like this does distinguish between GLL points at the exact moho boundary,
- ! where the point is on the interface between both,
+ ! where the point is on the interface between both,
! oceanic elements and mantle elements below
vp = vps(7)
vs = vss(7)
@@ -167,12 +167,12 @@
if (found_crust) then
scaleval = dsqrt(PI*GRAV*RHOAV)
vp = vp*1000.0d0/(R_EARTH*scaleval)
- vs = vs*1000.0d0/(R_EARTH*scaleval)
+ vs = vs*1000.0d0/(R_EARTH*scaleval)
rho = rho*1000.0d0/RHOAV
endif
-
+
! checks moho value
- !moho = h_uc + thicks(6) + thicks(7)
+ !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
@@ -180,7 +180,7 @@
! 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
!---------------------------
@@ -199,7 +199,7 @@
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
+ character(len=2) dummy_pad ! padding 2 bytes to align the structure
end type model_crust_variables
type (model_crust_variables) CM_V
@@ -271,17 +271,17 @@
! work-around to avoid jacobian problems when stretching mesh elements;
! one could also try to slightly change the shape of the doulbing element bricks (which cause the problem)...
!
- ! defines a "critical" region around the andes to have at least a 2-degree smoothing;
- ! critical region can lead to negative jacobians for mesh stretching when CAP smoothing is too small
+ ! defines a "critical" region around the andes to have at least a 2-degree smoothing;
+ ! critical region can lead to negative jacobians for mesh stretching when CAP smoothing is too small
double precision,parameter :: LAT_CRITICAL_ANDES = -20.0d0
double precision,parameter :: LON_CRITICAL_ANDES = -70.0d0
double precision,parameter :: CRITICAL_RANGE = 70.0d0
!-------------------------------
-
+
! local variables
double precision xlon(NTHETA*NPHI),xlat(NTHETA*NPHI),weight(NTHETA*NPHI)
double precision rhol(NLAYERS_CRUST),thickl(NLAYERS_CRUST),velpl(NLAYERS_CRUST),velsl(NLAYERS_CRUST)
- double precision weightl,cap_degree,dist
+ double precision weightl,cap_degree,dist
integer i,icolat,ilon,ierr
character(len=2) crustaltype
@@ -297,22 +297,22 @@
! sets up smoothing points
! by default uses CAP smoothing with 1 degree
- cap_degree = 1.0d0
-
+ cap_degree = 1.0d0
+
! checks if inside/outside of critical region for mesh stretching
if( SMOOTH_CRUST ) then
dist = dsqrt( (lon-LON_CRITICAL_ANDES)**2 + (lat-LAT_CRITICAL_ANDES )**2 )
if( dist < CRITICAL_RANGE ) then
- ! increases cap smoothing degree
+ ! increases cap smoothing degree
! scales between -1 at center and 0 at border
dist = dist / CRITICAL_RANGE - 1.0d0
! shifts value to 1 at center and 0 to the border with exponential decay
- dist = 1.0d0 - exp( - dist*dist*10.0d0 )
+ dist = 1.0d0 - exp( - dist*dist*10.0d0 )
! increases smoothing degree inside of critical region to 2 degree
cap_degree = cap_degree + dist
- endif
+ endif
endif
-
+
! gets smoothing points and weights
call CAP_vardegree(lon,lat,xlon,xlat,weight,cap_degree,NTHETA,NPHI)
@@ -333,17 +333,17 @@
! weighting value
weightl = weight(i)
-
+
! total, smoothed values
rho(:) = rho(:) + weightl*rhol(:)
thick(:) = thick(:) + weightl*thickl(:)
velp(:) = velp(:) + weightl*velpl(:)
- vels(:) = vels(:) + weightl*velsl(:)
+ vels(:) = vels(:) + weightl*velsl(:)
enddo
end subroutine crust_CAPsmoothed
-
+
!------------------------------------------------------
subroutine icolat_ilon(xlat,xlon,icolat,ilon)
@@ -422,8 +422,8 @@
include "constants.h"
! sampling rate
- integer :: NTHETA
- integer :: NPHI
+ integer :: NTHETA
+ integer :: NPHI
! smoothing size (in degrees)
double precision :: CAP_DEGREE
@@ -436,7 +436,7 @@
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
+ double precision dtheta,dphi,cap_area,dweight,pi_over_nphi
integer i,j,k
integer itheta,iphi
@@ -447,7 +447,7 @@
xlon(:) = 0.d0
xlat(:) = 0.d0
weight(:) = 0.d0
-
+
! checks cap degree size
if( CAP_DEGREE < TINYVAL ) then
! no cap smoothing
@@ -455,15 +455,15 @@
print*,' lat/lon:',lat,lon
stop 'error cap_degree too small'
endif
-
+
! pre-compute parameters
- CAP = CAP_DEGREE * PI/180.0d0
+ CAP = CAP_DEGREE * PI/180.0d0
dtheta = 0.5d0 * CAP / dble(NTHETA)
dphi = TWO_PI / dble(NPHI)
cap_area = TWO_PI * (1.0d0 - dcos(CAP))
dweight = CAP / dble(NTHETA) * dphi / cap_area
pi_over_nphi = PI/dble(NPHI)
-
+
! colatitude/longitude in radian
theta = (90.0d0 - lat ) * DEGREES_TO_RADIANS
phi = lon * DEGREES_TO_RADIANS
@@ -494,14 +494,14 @@
cost = dcos(theta)
sint = dsin(theta)
wght = sint*dweight
-
+
do iphi = 1,NPHI
i = i+1
-
+
! get the weight associated with this integration point (same for all phi)
weight(i) = wght
-
+
total = total + weight(i)
phi = dble(2*iphi-1)*pi_over_nphi
cosp = dcos(phi)
@@ -562,7 +562,7 @@
! 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) &
@@ -579,7 +579,7 @@
! if( ierr /= 0 ) stop 'error in routine get_crust_structure'
!
! end subroutine crust_singlevalue
-!
+!
!---------------------------
!
!
@@ -723,4 +723,4 @@
! enddo
!
! end subroutine crust_org
-
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_crustmaps.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_crustmaps.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_crustmaps.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -30,10 +30,10 @@
!
! combines Crust2.0 and EUcrust07 for moho depths; the crustal maps are
! interpolating the crustal velocities from Crust2.0 onto the more detailed EUcrust
-! crustal depths where ever they are defined.
+! crustal depths where ever they are defined.
-! current crustmaps (cmaps) take sediment thickness
-! and moho depths from EUcrust07 if possible and interpolate corresponding
+! current crustmaps (cmaps) take sediment thickness
+! and moho depths from EUcrust07 if possible and interpolate corresponding
! velocity/densities given from Crust2.0.
!
! main author: Matthias Meschede (meschede at princeton.edu)
@@ -41,7 +41,7 @@
subroutine model_crustmaps_broadcast(myrank,GC_V)
-! standard routine to setup model
+! standard routine to setup model
implicit none
@@ -49,8 +49,8 @@
! standard include of the MPI library
include 'mpif.h'
- integer :: myrank
-
+ integer :: myrank
+
!model_crustmaps_variables
type model_crustmaps_variables
sequence
@@ -71,7 +71,7 @@
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
@@ -118,10 +118,10 @@
subroutine read_general_crustmap(GC_V)
- implicit none
+ implicit none
include "constants.h"
-!Matthias Meschede
+!Matthias Meschede
!general_crustmap_variables
type general_crustmap_variables
sequence
@@ -145,7 +145,7 @@
integer ila,iln,i,l
- character(len=150) eucrustt3,eucrustt4,eucrustt5,eucrustt6,eucrustt7,&
+ character(len=150) eucrustt3,eucrustt4,eucrustt5,eucrustt6,eucrustt7,&
eucrustr3,eucrustr4,eucrustr5,eucrustr6,eucrustr7,&
eucrustp3,eucrustp4,eucrustp5,eucrustp6,eucrustp7,&
eucrusts3,eucrusts4,eucrusts5,eucrusts6,eucrusts7
@@ -156,19 +156,19 @@
call get_value_string(eucrustt5, 'model.eucrustt5','DATA/crustmap/eucrustt5.cmap')
call get_value_string(eucrustt6, 'model.eucrustt6','DATA/crustmap/eucrustt6.cmap')
call get_value_string(eucrustt7, 'model.eucrustt7','DATA/crustmap/eucrustt7.cmap')
-
+
call get_value_string(eucrustr3, 'model.eucrustr3','DATA/crustmap/eucrustr3.cmap')
call get_value_string(eucrustr4, 'model.eucrustr4','DATA/crustmap/eucrustr4.cmap')
call get_value_string(eucrustr5, 'model.eucrustr5','DATA/crustmap/eucrustr5.cmap')
call get_value_string(eucrustr6, 'model.eucrustr6','DATA/crustmap/eucrustr6.cmap')
call get_value_string(eucrustr7, 'model.eucrustr7','DATA/crustmap/eucrustr7.cmap')
-
+
call get_value_string(eucrustp3, 'model.eucrustp3','DATA/crustmap/eucrustp3.cmap')
call get_value_string(eucrustp4, 'model.eucrustp4','DATA/crustmap/eucrustp4.cmap')
call get_value_string(eucrustp5, 'model.eucrustp5','DATA/crustmap/eucrustp5.cmap')
call get_value_string(eucrustp6, 'model.eucrustp6','DATA/crustmap/eucrustp6.cmap')
call get_value_string(eucrustp7, 'model.eucrustp7','DATA/crustmap/eucrustp7.cmap')
-
+
call get_value_string(eucrusts3, 'model.eucrusts3','DATA/crustmap/eucrusts3.cmap')
call get_value_string(eucrusts4, 'model.eucrusts4','DATA/crustmap/eucrusts4.cmap')
call get_value_string(eucrusts5, 'model.eucrusts5','DATA/crustmap/eucrusts5.cmap')
@@ -302,7 +302,7 @@
read(1,*) (GC_V%velocs(ila,iln,5),iln=1,360*CRUSTMAP_RESOLUTION)
enddo
close(1)
-
+
GC_V%thicknessnp(:) = 0.0
GC_V%thicknesssp(:) = 0.0
GC_V%densitynp(:) = 0.0
@@ -335,8 +335,8 @@
! print *,'thicknessnp(',l,')',GC_V%thicknessnp(l)
enddo
-
-
+
+
end subroutine read_general_crustmap
!
@@ -353,7 +353,7 @@
implicit none
include "constants.h"
-!Matthias Meschede
+!Matthias Meschede
!general_crustmap_variables
type general_crustmap_variables
sequence
@@ -371,7 +371,7 @@
double precision velocpsp(NLAYERS_CRUSTMAP)
double precision velocssp(NLAYERS_CRUSTMAP)
end type general_crustmap_variables
-
+
type (general_crustmap_variables) GC_V
!general_crustmap_variables
@@ -393,7 +393,7 @@
x7 = (R_EARTH-(h_uc+thicks(4)+thicks(5))*1000.0d0)/R_EARTH
found_crust = .true.
- if(x > x3 .and. INCLUDE_SEDIMENTS_CRUST &
+ if(x > x3 .and. INCLUDE_SEDIMENTS_CRUST &
.and. h_sed > MINIMUM_SEDIMENT_THICKNESS/R_EARTH_KM) then
vp = vps(1)
vs = vss(1)
@@ -426,7 +426,7 @@
vs = vs*1000.0d0/(R_EARTH*scaleval)
rho = rho*1000.0d0/RHOAV
! moho = (h_uc+thicks(4)+thicks(5))*1000.0d0/R_EARTH
- else
+ else
scaleval = dsqrt(PI*GRAV*RHOAV)
vp = 20.0*1000.0d0/(R_EARTH*scaleval)
vs = 20.0*1000.0d0/(R_EARTH*scaleval)
@@ -453,7 +453,7 @@
! argument variables
double precision lat,lon
double precision rhos(5),thicks(5),velp(5),vels(5)
-!Matthias Meschede
+!Matthias Meschede
!general_crustmap_variables
type general_crustmap_variables
sequence
@@ -479,29 +479,29 @@
! work-around to avoid jacobian problems when stretching mesh elements;
! one could also try to slightly change the shape of the doulbing element bricks (which cause the problem)...
!
- ! defines a "critical" region to have at least a 1-degree smoothing;
- ! critical region can lead to negative jacobians for mesh stretching when CAP smoothing is too small
+ ! defines a "critical" region to have at least a 1-degree smoothing;
+ ! critical region can lead to negative jacobians for mesh stretching when CAP smoothing is too small
double precision,parameter :: LAT_CRITICAL_EUROPE = 50.0d0
double precision,parameter :: LON_CRITICAL_EUROPE = 22.0d0
double precision,parameter :: CRITICAL_RANGE_EUROPE = 50.0d0
-
- ! defines a "critical" region around the andes to have at least a 1-degree smoothing;
- ! critical region can lead to negative jacobians for mesh stretching when CAP smoothing is too small
+
+ ! defines a "critical" region around the andes to have at least a 1-degree smoothing;
+ ! critical region can lead to negative jacobians for mesh stretching when CAP smoothing is too small
double precision,parameter :: LAT_CRITICAL_ANDES = -20.0d0
double precision,parameter :: LON_CRITICAL_ANDES = -70.0d0
double precision,parameter :: CRITICAL_RANGE_ANDES = 70.0d0
-
+
! sampling rate for CAP points
integer, parameter :: NTHETA = 4
- integer, parameter :: NPHI = 20
+ integer, parameter :: NPHI = 20
!-------------------------------
! local variables
double precision weightup,weightleft,weightul,weightur,weightll,weightlr
double precision xlon(NTHETA*NPHI),xlat(NTHETA*NPHI),weight(NTHETA*NPHI)
double precision rhol(NLAYERS_CRUSTMAP),thickl(NLAYERS_CRUSTMAP), &
- velpl(NLAYERS_CRUSTMAP),velsl(NLAYERS_CRUSTMAP)
- double precision weightl,cap_degree,dist
+ velpl(NLAYERS_CRUSTMAP),velsl(NLAYERS_CRUSTMAP)
+ double precision weightl,cap_degree,dist
integer num_points
integer i,ipoin,iupcolat,ileftlng,irightlng
@@ -523,13 +523,13 @@
if( dist < CRITICAL_RANGE_EUROPE ) then
! sets up smoothing points
! by default uses CAP smoothing with crustmap resolution, e.g. 1/4 degree
- cap_degree = 1.d0 / CRUSTMAP_RESOLUTION
-
- ! increases cap smoothing degree
+ cap_degree = 1.d0 / CRUSTMAP_RESOLUTION
+
+ ! increases cap smoothing degree
! scales between -1 at center and 0 at border
dist = dist / CRITICAL_RANGE_EUROPE - 1.0d0
! shifts value to 1 at center and 0 to the border with exponential decay
- dist = 1.0d0 - exp( - dist*dist*10.0d0 )
+ dist = 1.0d0 - exp( - dist*dist*10.0d0 )
! increases smoothing degree inside of critical region
cap_degree = cap_degree + dist
@@ -541,27 +541,27 @@
if( dist < CRITICAL_RANGE_ANDES ) then
! sets up smoothing points
! by default uses CAP smoothing with crustmap resolution, e.g. 1/4 degree
- cap_degree = 1.d0 / CRUSTMAP_RESOLUTION
+ cap_degree = 1.d0 / CRUSTMAP_RESOLUTION
- ! increases cap smoothing degree
+ ! increases cap smoothing degree
! scales between -1 at center and 0 at border
dist = dist / CRITICAL_RANGE_ANDES - 1.0d0
! shifts value to 1 at center and 0 to the border with exponential decay
- dist = 1.0d0 - exp( - dist*dist*10.0d0 )
+ dist = 1.0d0 - exp( - dist*dist*10.0d0 )
! increases smoothing degree inside of critical region
cap_degree = cap_degree + dist
-
+
! gets smoothing points and weights
call CAP_vardegree(lon,lat,xlon,xlat,weight,cap_degree,NTHETA,NPHI)
num_points = NTHETA*NPHI
- endif
+ endif
endif
! initializes
velp(:) = 0.0d0
vels(:) = 0.0d0
rhos(:) = 0.0d0
- thicks(:) = 0.0d0
+ thicks(:) = 0.0d0
! loops over weight points
do ipoin=1,num_points
@@ -595,7 +595,7 @@
weightur=weightup*(1.0-weightleft)
weightll=(1.0-weightup)*weightleft
weightlr=(1.0-weightup)*(1.0-weightleft)
-
+
if(iupcolat==0) then
! north pole
do i=1,NLAYERS_CRUSTMAP
@@ -637,12 +637,12 @@
! vels(i)=1.0i
enddo
endif
-
+
! total, smoothed values
rhos(:) = rhos(:) + weightl*rhol(:)
thicks(:) = thicks(:) + weightl*thickl(:)
velp(:) = velp(:) + weightl*velpl(:)
- vels(:) = vels(:) + weightl*velsl(:)
+ vels(:) = vels(:) + weightl*velsl(:)
enddo
end subroutine read_crustmaps
@@ -650,7 +650,7 @@
!--------------------------------------------------------------------------------------------
subroutine ibilinearmap(lat,lng,iupcolat,ileftlng,weightup,weightleft)
-
+
implicit none
include "constants.h"
@@ -677,14 +677,14 @@
if(iupcolat<0) iupcolat=0
if(iupcolat>180*CRUSTMAP_RESOLUTION) iupcolat=180*CRUSTMAP_RESOLUTION
-
-
+
+
buffer=0.5+(xlng*CRUSTMAP_RESOLUTION)
ileftlng=int(buffer)
weightleft=1.0-(buffer-dble(ileftlng))
if(ileftlng<1) ileftlng=360*CRUSTMAP_RESOLUTION
- if(ileftlng>360*CRUSTMAP_RESOLUTION) ileftlng=1
+ if(ileftlng>360*CRUSTMAP_RESOLUTION) ileftlng=1
@@ -695,7 +695,7 @@
!
!
! subroutine ilatlng(lat,lng,icolat,ilng)
-!
+!
! implicit none
! include "constants.h"
!
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_eucrust.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_eucrust.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_eucrust.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -28,14 +28,14 @@
!--------------------------------------------------------------------------------------------------
! EUCRUST-07
!
-! Tesauro, M., M. K. Kaban and S. A. P. L. Cloetingh, 2008.
-! Eucrust-07: A New Reference Model for the European Crust,
-! Geophysical Research Letters, 35: p. L05313.208
+! Tesauro, M., M. K. Kaban and S. A. P. L. Cloetingh, 2008.
+! Eucrust-07: A New Reference Model for the European Crust,
+! Geophysical Research Letters, 35: p. L05313.208
!--------------------------------------------------------------------------------------------------
subroutine model_eucrust_broadcast(myrank,EUCM_V)
-! standard routine to setup model
+! standard routine to setup model
implicit none
@@ -54,20 +54,20 @@
integer :: myrank
integer :: ier
-
+
! EUcrust07 Vp crustal structure
if( myrank == 0 ) call read_EuCrust(EUCM_V)
-
+
! broadcast the information read on the master to the nodes
- call MPI_BCAST(EUCM_V%num_eucrust,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
+ call MPI_BCAST(EUCM_V%num_eucrust,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
if( myrank /= 0 ) then
allocate(EUCM_V%eucrust_vp_uppercrust(EUCM_V%num_eucrust),EUCM_V%eucrust_vp_lowercrust(EUCM_V%num_eucrust),&
EUCM_V%eucrust_mohodepth(EUCM_V%num_eucrust),EUCM_V%eucrust_basement(EUCM_V%num_eucrust),&
EUCM_V%eucrust_ucdepth(EUCM_V%num_eucrust), EUCM_V%eucrust_lon(EUCM_V%num_eucrust),&
EUCM_V%eucrust_lat(EUCM_V%num_eucrust))
- endif
-
+ 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)
@@ -77,7 +77,7 @@
call MPI_BCAST(EUCM_V%eucrust_ucdepth(1:EUCM_V%num_eucrust),EUCM_V%num_eucrust,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
end subroutine model_eucrust_broadcast
-
+
!----------------------------------------------------------------------------------------------------
subroutine read_EuCrust(EUCM_V)
@@ -94,35 +94,35 @@
end type model_eucrust_variables
type (model_eucrust_variables) EUCM_V
-
+
! local variables
character(len=80):: line
character(len=150):: filename
integer:: i,ierror
double precision:: vp_uppercrust,vp_lowercrust,vp_avg,topo,basement
double precision:: upper_lower_depth,moho_depth,lat,lon
-
- ! original file size entries
+
+ ! original file size entries
EUCM_V%num_eucrust = 36058
-
+
allocate(EUCM_V%eucrust_vp_uppercrust(EUCM_V%num_eucrust),EUCM_V%eucrust_vp_lowercrust(EUCM_V%num_eucrust),&
EUCM_V%eucrust_mohodepth(EUCM_V%num_eucrust),EUCM_V%eucrust_basement(EUCM_V%num_eucrust),&
EUCM_V%eucrust_ucdepth(EUCM_V%num_eucrust), EUCM_V%eucrust_lon(EUCM_V%num_eucrust),&
EUCM_V%eucrust_lat(EUCM_V%num_eucrust))
-
+
EUCM_V%eucrust_vp_uppercrust(:) = 0.0
EUCM_V%eucrust_vp_lowercrust(:) = 0.0
EUCM_V%eucrust_mohodepth(:) = 0.0
EUCM_V%eucrust_basement(:) = 0.0
EUCM_V%eucrust_ucdepth(:) = 0.0
-
+
! opens data file
call get_value_string(filename, 'model.eu', 'DATA/eucrust-07/ds01.txt')
open(unit=11,file=filename,status='old',action='read')
-
- ! skip first line
- read(11,*)
-
+
+ ! skip first line
+ read(11,*)
+
! data
do i=1,36058
@@ -130,22 +130,22 @@
if(ierror .ne. 0 ) stop
read(line,*)lon,lat,vp_uppercrust,vp_lowercrust,vp_avg,topo,basement,upper_lower_depth,moho_depth
-
+
! stores moho values
EUCM_V%eucrust_lon(i) = lon
EUCM_V%eucrust_lat(i) = lat
EUCM_V%eucrust_vp_uppercrust(i) = vp_uppercrust
EUCM_V%eucrust_vp_lowercrust(i) = vp_lowercrust
- EUCM_V%eucrust_mohodepth(i) = moho_depth
- EUCM_V%eucrust_basement(i) = basement
+ EUCM_V%eucrust_mohodepth(i) = moho_depth
+ EUCM_V%eucrust_basement(i) = basement
EUCM_V%eucrust_ucdepth(i) = upper_lower_depth
-
+
enddo
close(11)
end subroutine read_EuCrust
-!
+!
!--------------------------------------------------------------------------------------------------
!
@@ -161,18 +161,18 @@
end type model_eucrust_variables
type (model_eucrust_variables) EUCM_V
- double precision :: lat,lon,x,vp
- logical :: found_crust
- double precision :: lon_min,lon_max,lat_min,lat_max
+ double precision :: lat,lon,x,vp
+ logical :: found_crust
+ double precision :: lon_min,lon_max,lat_min,lat_max
double precision, external:: crust_eu
-
+
! initializes
vp = 0.d0
-
+
! eucrust boundary region
lon_min = -24.875
lon_max = 35.375
-
+
lat_min = 34.375
lat_max = 71.375
@@ -188,7 +188,7 @@
end subroutine model_eucrust
-!
+!
!--------------------------------------------------------------------------------------------------
!
@@ -210,19 +210,19 @@
double precision :: lat,lon,x,vp !,vs,rho,moho
logical :: found_crust
-
+
double precision :: longitude_min,longitude_max,latitude_min,latitude_max
double precision :: h_basement,h_uc,h_moho,x3,x4,x5
double precision :: scaleval
-
+
integer :: i,j
integer,parameter :: ilons = 242 ! number of different longitudes
integer,parameter :: ilats = 149 ! number of different latitudes
-
+
! eucrust boundary region
longitude_min = -24.875
longitude_max = 35.375
-
+
latitude_min = 34.375
latitude_max = 71.375
@@ -232,24 +232,24 @@
if( lat < latitude_min .or. lat > latitude_max ) return
! search
- do i=1,ilons-1
+ do i=1,ilons-1
if( lon >= EUCM_V%eucrust_lon(i) .and. lon < EUCM_V%eucrust_lon(i+1) ) then
do j=0,ilats-1
if(lat>=EUCM_V%eucrust_lat(i+j*ilons) .and. lat<EUCM_V%eucrust_lat(i+(j+1)*ilons)) then
-
+
h_basement = EUCM_V%eucrust_basement(i+j*ilons)
h_uc = EUCM_V%eucrust_ucdepth(i+j*ilons)
h_moho = EUCM_V%eucrust_mohodepth(i+j*ilons)
-
+
x3=(R_EARTH - h_basement*1000.0d0)/R_EARTH
x4=(R_EARTH - h_uc*1000.0d0)/R_EARTH
x5=(R_EARTH - h_moho*1000.0d0)/R_EARTH
-
+
scaleval = dsqrt(PI*GRAV*RHOAV)
-
+
if( x > x3 ) then
return
- else if( x > x4 ) then
+ else if( x > x4 ) then
found_crust = .true.
vp = EUCM_V%eucrust_vp_uppercrust(i+j*ilons) *1000.0d0/(R_EARTH*scaleval)
crust_eu = vp
@@ -268,13 +268,13 @@
end function crust_eu
-!
+!
!--------------------------------------------------------------------------------------------------
!
subroutine eu_cap_smoothing(lat,lon,radius,value,found,EUCM_V)
! smooths with a cap of size CAP (in degrees)
-! using NTHETA points in the theta direction (latitudal)
+! using NTHETA points in the theta direction (latitudal)
! and NPHI in the phi direction (longitudal).
! The cap is rotated to the North Pole.
@@ -293,13 +293,13 @@
integer :: num_eucrust
end type model_eucrust_variables
type (model_eucrust_variables) EUCM_V
-
+
integer, parameter :: NTHETA = 4
integer, parameter :: NPHI = 10
double precision, parameter :: CAP = 1.0d0*PI/180.0d0 ! 1 degree smoothing
double precision,external :: crust_eu
-
+
! local variables
integer i,j,k !,icolat,ilon,ierr
integer itheta,iphi,npoints
@@ -311,7 +311,7 @@
! 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'
+ 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
@@ -394,20 +394,20 @@
npoints = i
- ! at this point:
+ ! at this point:
!
! xlat(i),xlon(i) are point locations to be used for interpolation
! with weights weight(i)
! integrates value
- value = 0.0d0
- do i=1,npoints
- valuel = crust_eu(xlat(i),xlon(i),radius,value,found,EUCM_V)
- value = value + weight(i)*valuel
+ value = 0.0d0
+ do i=1,npoints
+ valuel = crust_eu(xlat(i),xlon(i),radius,value,found,EUCM_V)
+ value = value + weight(i)*valuel
enddo
if( abs(value) < TINYVAL) found = .false.
end subroutine eu_cap_smoothing
-
-
\ No newline at end of file
+
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_gll.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_gll.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_gll.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -36,8 +36,8 @@
subroutine model_gll_broadcast(myrank,MGLL_V,NSPEC)
-! standard routine to setup model
-
+! standard routine to setup model
+
implicit none
include "constants.h"
@@ -49,13 +49,13 @@
! tomographic iteration model on GLL points
real(kind=CUSTOM_REAL),dimension(:,:,:,:),pointer :: vs_new,vp_new,rho_new
double precision :: scale_velocity,scale_density
- logical :: MODEL_GLL
+ logical :: MODEL_GLL
end type model_gll_variables
type (model_gll_variables) MGLL_V
integer, dimension(MAX_NUM_REGIONS) :: NSPEC
integer :: myrank
-
+
! local parameters
double precision :: min_dvs,max_dvs
integer :: ier
@@ -66,59 +66,59 @@
! non-dimensionalize scaling values
MGLL_V%scale_velocity = 1000.0d0/(PI*GRAV*RHOAV*R_EARTH)
MGLL_V%scale_density = 1000.0d0/RHOAV
-
+
call read_gll_model(myrank,MGLL_V,NSPEC)
-
- ! checks velocity range
+
+ ! checks velocity range
max_dvs = maxval( MGLL_V%vs_new )
min_dvs = minval( MGLL_V%vs_new )
call mpi_reduce(max_dvs, max_dvs, 1, MPI_DOUBLE_PRECISION, MPI_MAX, 0, MPI_COMM_WORLD,ier)
call mpi_reduce(min_dvs, min_dvs, 1, MPI_DOUBLE_PRECISION, MPI_MIN, 0, MPI_COMM_WORLD,ier)
if( myrank == 0 ) then
write(IMAIN,*)'model GLL:'
- write(IMAIN,*) ' vs new min/max: ',min_dvs,max_dvs
+ write(IMAIN,*) ' vs new min/max: ',min_dvs,max_dvs
write(IMAIN,*)
- endif
-
+ endif
+
end subroutine model_gll_broadcast
!
!-------------------------------------------------------------------------------------------------
!
-
-
+
+
subroutine read_gll_model(myrank,MGLL_V,NSPEC)
implicit none
include "constants.h"
-
+
! GLL model_variables
type model_gll_variables
! tomographic iteration model on GLL points
real(kind=CUSTOM_REAL),dimension(:,:,:,:),pointer :: vs_new,vp_new,rho_new
double precision :: scale_velocity,scale_density
- logical :: MODEL_GLL
+ logical :: MODEL_GLL
end type model_gll_variables
- type (model_gll_variables) MGLL_V
+ type (model_gll_variables) MGLL_V
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC
integer :: myrank
!--------------------------------------------------------------------
! USER PARAMETER
-
- character(len=150),parameter:: MGLL_path = 'KERNELS/model_m1/'
+
+ character(len=150),parameter:: MGLL_path = 'KERNELS/model_m1/'
!--------------------------------------------------------------------
! local parameters
integer :: ier
character(len=150) :: prname
-
+
! only crust and mantle
write(prname,'(a,i6.6,a)') MGLL_path(1:len_trim(MGLL_path))//'proc',myrank,'_reg1_'
-
- ! vp mesh
+
+ ! vp mesh
open(unit=27,file=prname(1:len_trim(prname))//'vp_new.bin',&
status='old',action='read',form='unformatted',iostat=ier)
if( ier /= 0 ) then
@@ -127,8 +127,8 @@
endif
read(27) MGLL_V%vp_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
close(27)
-
- ! vs mesh
+
+ ! vs mesh
open(unit=27,file=prname(1:len_trim(prname))//'vs_new.bin', &
status='old',action='read',form='unformatted',iostat=ier)
if( ier /= 0 ) then
@@ -144,8 +144,8 @@
if( ier /= 0 ) then
print*,'error opening: ',prname(1:len_trim(prname))//'rho_new.bin'
call exit_MPI(myrank,'error model gll')
- endif
+ endif
read(27) MGLL_V%rho_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
close(27)
-
- end subroutine read_gll_model
\ No newline at end of file
+
+ end subroutine read_gll_model
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_heterogen_mantle.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_heterogen_mantle.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_heterogen_mantle.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -33,7 +33,7 @@
subroutine model_heterogen_mntl_broadcast(myrank,HMM)
-! standard routine to setup model
+! standard routine to setup model
implicit none
@@ -52,7 +52,7 @@
integer :: myrank
integer :: ier
-
+
if(myrank == 0) then
write(IMAIN,*) 'Reading in model_heterogen_mantle.'
call read_heterogen_mantle_model(HMM)
@@ -66,15 +66,15 @@
write(IMAIN,*) 'model_heterogen_mantle is broadcast.'
write(IMAIN,*) 'First value in HMM:',HMM%rho_in(1)
write(IMAIN,*) 'Last value in HMM:',HMM%rho_in(N_R*N_THETA*N_PHI)
- endif
+ endif
end subroutine model_heterogen_mntl_broadcast
-
+
!
!-------------------------------------------------------------------------------------------------
!
-
+
!
! NOTE: CURRENTLY THIS ROUTINE ONLY WORKS FOR N_R=N_THETA=N_PHI !!!!!
!
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_iasp91.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_iasp91.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_iasp91.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -88,35 +88,35 @@
!--- outer core
!
else if(r > RICB .and. r < RCMB) then
-
+
if(idoubling /= IFLAG_OUTER_CORE_NORMAL) &
call exit_MPI(myrank,'wrong doubling flag for outer core point')
!
!--- D" at the base of the mantle
!
else if(r > RCMB .and. r < RTOPDDOUBLEPRIME) then
-
+
if(idoubling /= IFLAG_MANTLE_NORMAL) &
call exit_MPI(myrank,'wrong doubling flag for D" point')
!
!--- mantle: from top of D" to d670
!
else if(r > RTOPDDOUBLEPRIME .and. r < R670) then
-
+
if(idoubling /= IFLAG_MANTLE_NORMAL) &
call exit_MPI(myrank,'wrong doubling flag for top D" -> d670 point')
!
!--- mantle: from d670 to d220
!
else if(r > R670 .and. r < R220) then
-
+
if(idoubling /= IFLAG_670_220) &
call exit_MPI(myrank,'wrong doubling flag for d670 -> d220 point')
!
!--- mantle and crust: from d220 to MOHO and then to surface
!
else if(r > R220) then
-
+
if(idoubling /= IFLAG_220_80 .and. idoubling /= IFLAG_80_MOHO .and. idoubling /= IFLAG_CRUST) &
call exit_MPI(myrank,'wrong doubling flag for d220 -> Moho -> surface point')
@@ -178,7 +178,7 @@
vs=17.70732-13.50652*x
Qmu=143.0d0
Qkappa=57827.0d0
-
+
else if(r > R400 .and. r <= R220) then
rho=7.1089d0-3.8045d0*x
vp=30.78765-23.25415*x
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_jp1d.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_jp1d.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_jp1d.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -204,5 +204,5 @@
rho=rho*1000.0d0/RHOAV
vp=vp*1000.0d0/(R_EARTH*scaleval)
vs=vs*1000.0d0/(R_EARTH*scaleval)
-
+
end subroutine model_jp1d
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_jp3d.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_jp3d.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_jp3d.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -61,7 +61,7 @@
subroutine model_jp3d_broadcast(myrank,JP3DM_V)
-! standard routine to setup model
+! standard routine to setup model
implicit none
@@ -139,7 +139,7 @@
integer :: myrank
integer :: ier
-
+
if(myrank == 0) call read_jp3d_iso_zhao_model(JP3DM_V)
! JP3DM_V
@@ -204,7 +204,7 @@
!
!-------------------------------------------------------------------------------------------------
!
-
+
subroutine read_jp3d_iso_zhao_model(JP3DM_V)
implicit none
@@ -287,7 +287,7 @@
end subroutine read_jp3d_iso_zhao_model
-!
+!
!==========================================================================
!
@@ -395,11 +395,11 @@
ELSE
LAY = 4
END IF
-
+
CALL VEL1D(HE,vp,LAY,1,JP3DM_V)
CALL VEL1D(HE,vs,LAY,2,JP3DM_V)
CALL VEL3(PE,RE,HE,dvp,LAY,JP3DM_V)
-
+
dvp = 0.01d0*dvp
dvs = 1.5d0*dvp
vp = vp*(1.0d0+dvp)
@@ -421,7 +421,7 @@
rho=rho*1000.0d0/RHOAV
vp=vp*1000.0d0/(R_EARTH*scaleval)
vs=vs*1000.0d0/(R_EARTH*scaleval)
-
+
END subroutine model_jp3d_iso_zhao
!
@@ -854,7 +854,7 @@
!
!---------------------------------------------------------------------------------------
!
-
+
SUBROUTINE VABPS(MP,MR,MH,V,VEL,JP3DM_V)
implicit none
@@ -1052,7 +1052,7 @@
!
!----------------------------------------------------------------------------------------------
!
-
+
SUBROUTINE HLAY(PE,RE,HE,IJK,JP3DM_V)
implicit none
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_ppm.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_ppm.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_ppm.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -32,8 +32,8 @@
! for generic models given as depth profiles at lon/lat using a text-file format like:
!
! #lon(deg), lat(deg), depth(km), Vs-perturbation wrt PREM(%), Vs-PREM (km/s)
-! -10.00000 31.00000 40.00000 -1.775005 4.400000
-! -10.00000 32.00000 40.00000 -1.056823 4.400000
+! -10.00000 31.00000 40.00000 -1.775005 4.400000
+! -10.00000 32.00000 40.00000 -1.056823 4.400000
! ...
!
!--------------------------------------------------------------------------------------------------
@@ -47,7 +47,7 @@
! 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
@@ -57,45 +57,45 @@
double precision,parameter:: const_a = sigma_v/3.0
double precision,parameter:: const_b = sigma_h/3.0/(R_EARTH_KM*pi_by180)
integer,parameter:: NUM_GAUSSPOINTS = 10
-
+
double precision,parameter:: pi_by2 = PI/2.0d0
double precision,parameter:: radtodeg = 180.0d0/PI
-
+
! ----------------------
! scale perturbations in shear speed to perturbations in density and vp
logical,parameter:: SCALE_MODEL = .false.
! factor to convert perturbations in shear speed to perturbations in density
! taken from s20rts (see also Qin, 2009, sec. 5.2)
- double precision, parameter :: SCALE_RHO = 0.40d0
+ double precision, parameter :: SCALE_RHO = 0.40d0
! SCEC version 4 model relationship http://www.data.scec.org/3Dvelocity/
- !double precision, parameter :: SCALE_RHO = 0.254d0
+ !double precision, parameter :: SCALE_RHO = 0.254d0
- ! see: P wave seismic velocity and Vp/Vs ratio beneath the Italian peninsula from local earthquake tomography
+ ! see: P wave seismic velocity and Vp/Vs ratio beneath the Italian peninsula from local earthquake tomography
! (Davide Scadi et al.,2008. tectonophysics)
!! becomes unstable !!
!double precision, parameter :: SCALE_VP = 1.75d0 ! corresponds to average vp/vs ratio
-
+
! Zhou et al. 2005: global upper-mantle structure from finite-frequency surface-wave tomography
- ! http://www.gps.caltech.edu/~yingz/pubs/Zhou_JGR_2005.pdf
+ ! http://www.gps.caltech.edu/~yingz/pubs/Zhou_JGR_2005.pdf
!double precision, parameter :: SCALE_VP = 0.5d0 ! by lab measurements Montagner & Anderson, 1989
-
+
! Qin et al. 2009, sec. 5.2
double precision, parameter :: SCALE_VP = 0.588d0 ! by Karato, 1993
-
+
end module module_PPM
-!
+!
!--------------------------------------------------------------------------------------------------
!
subroutine model_ppm_broadcast(myrank,PPM_V)
-! standard routine to setup model
+! standard routine to setup model
implicit none
-
+
include "constants.h"
! standard include of the MPI library
include 'mpif.h'
@@ -111,14 +111,14 @@
integer :: myrank
integer :: ier
-
+
! upper mantle structure
if(myrank == 0) call read_model_ppm(PPM_V)
-
- ! broadcast the information read on the master to the nodes
- call MPI_BCAST(PPM_V%num_v,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%num_latperlon,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(PPM_V%num_lonperdepth,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ ! broadcast the information read on the master to the nodes
+ call MPI_BCAST(PPM_V%num_v,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_V%num_latperlon,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(PPM_V%num_lonperdepth,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
if( myrank /= 0 ) then
allocate(PPM_V%lat(PPM_V%num_v),PPM_V%lon(PPM_V%num_v),PPM_V%depth(PPM_V%num_v),PPM_V%dvs(PPM_V%num_v))
endif
@@ -134,19 +134,19 @@
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_V%ddepth,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
end subroutine model_ppm_broadcast
-!
+!
!--------------------------------------------------------------------------------------------------
!
subroutine read_model_ppm(PPM_V)
use module_PPM
-
+
implicit none
! point profile model_variables
@@ -173,20 +173,20 @@
write(IMAIN,*) ' error count opening: ',trim(filename)
call exit_mpi(0,"error count opening model ppm")
endif
-
+
! first line is text and will be ignored
- read(10,'(a150)') line
-
+ read(10,'(a150)') line
+
! counts number of data lines
ier = 0
- do while (ier == 0 )
+ do while (ier == 0 )
read(10,*,iostat=ier) lon,lat,depth,dvs,vs
if( ier == 0 ) then
counter = counter + 1
endif
enddo
close(10)
-
+
PPM_V%num_v = counter
if( counter < 1 ) then
write(IMAIN,*)
@@ -206,17 +206,17 @@
PPM_V%min_dvs = 0.0
PPM_V%max_dvs = 0.0
PPM_V%dvs(:) = 0.0
-
+
! vs values
open(unit=10,file=trim(filename),status='old',action='read',iostat=ier)
if( ier /= 0 ) then
write(IMAIN,*) ' error opening: ',trim(filename)
call exit_mpi(0,"error opening model ppm")
- endif
+ endif
read(10,'(a150)') line ! first line is text
counter=0
ier = 0
- do while (ier == 0 )
+ do while (ier == 0 )
read(10,*,iostat=ier) lon,lat,depth,dvs,vs
if( ier == 0 ) then
counter = counter + 1
@@ -224,7 +224,7 @@
PPM_V%lon(counter) = lon
PPM_V%depth(counter) = depth
PPM_V%dvs(counter) = dvs/100.0
-
+
!debug
!if( abs(depth - 100.0) < 1.e-3) write(IMAIN,*) ' lon/lat/depth : ',lon,lat,depth,' dvs:',dvs
endif
@@ -239,7 +239,7 @@
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) )
@@ -247,16 +247,16 @@
PPM_V%minlon = minval( PPM_V%lon(1:PPM_V%num_v) )
PPM_V%maxlon = maxval( PPM_V%lon(1:PPM_V%num_v) )
- PPM_V%mindepth = minval( PPM_V%depth(1:PPM_V%num_v) )
+ PPM_V%mindepth = minval( PPM_V%depth(1:PPM_V%num_v) )
PPM_V%maxdepth = maxval( PPM_V%depth(1:PPM_V%num_v) )
PPM_V%min_dvs = minval(PPM_V%dvs(1:PPM_V%num_v))
PPM_V%max_dvs = maxval(PPM_V%dvs(1:PPM_V%num_v))
-
+
write(IMAIN,*) 'model PPM:'
write(IMAIN,*) ' latitude min/max : ',PPM_V%minlat,PPM_V%maxlat
write(IMAIN,*) ' longitude min/max: ',PPM_V%minlon,PPM_V%maxlon
- write(IMAIN,*) ' depth min/max : ',PPM_V%mindepth,PPM_V%maxdepth
+ write(IMAIN,*) ' depth min/max : ',PPM_V%mindepth,PPM_V%maxdepth
write(IMAIN,*)
write(IMAIN,*) ' dvs min/max : ',PPM_V%min_dvs,PPM_V%max_dvs
write(IMAIN,*)
@@ -277,7 +277,7 @@
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
+ if( abs(lat - PPM_V%lat(i)) > 1.e-15 ) then
PPM_V%dlat = PPM_V%lat(i) - lat
exit
endif
@@ -286,8 +286,8 @@
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
+ if( abs(lon - PPM_V%lon(i)) > 1.e-15 ) then
+ PPM_V%dlon = PPM_V%lon(i) - lon
exit
endif
enddo
@@ -295,17 +295,17 @@
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
+ if( abs(depth - PPM_V%depth(i)) > 1.e-15 ) then
PPM_V%ddepth = PPM_V%depth(i) - depth
exit
endif
- enddo
-
+ enddo
+
if( abs(PPM_V%dlat) < 1.e-15 .or. abs(PPM_V%dlon) < 1.e-15 .or. abs(PPM_V%ddepth) < 1.e-15) then
write(IMAIN,*) ' model PPM:',filename
write(IMAIN,*) ' error in delta values:'
write(IMAIN,*) ' dlat : ',PPM_V%dlat,' dlon: ',PPM_V%dlon,' ddepth: ',PPM_V%ddepth
- call exit_mpi(0,' error model PPM ')
+ 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)
@@ -313,12 +313,12 @@
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_V%num_lonperdepth = int( (PPM_V%maxlon - PPM_V%minlon) / PPM_V%dlon ) + 1
+
end subroutine read_model_ppm
-!
+!
!--------------------------------------------------------------------------------------------------
!
@@ -342,14 +342,14 @@
double precision radius,theta,phi,dvs,dvp,drho
! local parameters
- integer:: i,j,k
+ integer:: i,j,k
double precision:: lat,lon,r_depth
double precision:: min_dvs,max_dvs
double precision:: g_dvs,g_depth,g_lat,g_lon,x,g_weight,weight_sum,weight_prod
-
+
! initialize
- dvs = 0.0d0
+ dvs = 0.0d0
dvp = 0.0d0
drho = 0.0d0
@@ -359,20 +359,20 @@
lat=(pi_by2-theta)*radtodeg
if( lat < PPM_V%minlat .or. lat > PPM_V%maxlat ) return
-
+
lon=phi*radtodeg
- if(lon>180.0d0) lon=lon-360.0d0
+ if(lon>180.0d0) lon=lon-360.0d0
if( lon < PPM_V%minlon .or. lon > PPM_V%maxlon ) return
-
- ! search location value
+
+ ! 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,PPM_V,dvs)
return
endif
!write(IMAIN,*) ' model ppm at ',sngl(lat),sngl(lon),sngl(r_depth)
-
- ! loop over neighboring points
+
+ ! loop over neighboring points
dvs = 0.0
weight_sum = 0.0
do i=-NUM_GAUSSPOINTS,NUM_GAUSSPOINTS
@@ -387,14 +387,14 @@
! horizontal weighting
x = (g_lat-lat)*degtokm
call get_Gaussianweight(x,sigma_h,g_weight)
- g_dvs = g_dvs*g_weight
+ g_dvs = g_dvs*g_weight
weight_prod = g_weight
-
+
x = (g_lon-lon)*degtokm
call get_Gaussianweight(x,sigma_h,g_weight)
g_dvs = g_dvs*g_weight
weight_prod = weight_prod * g_weight
-
+
!vertical weighting
x = g_depth-r_depth
call get_Gaussianweight(x,sigma_v,g_weight)
@@ -402,22 +402,22 @@
weight_prod = weight_prod * g_weight
! averaging
- weight_sum = weight_sum + weight_prod
+ weight_sum = weight_sum + weight_prod
dvs = dvs + g_dvs
enddo
enddo
enddo
-
+
if( weight_sum > 1.e-15) dvs = dvs / weight_sum
! store min/max
max_dvs = PPM_V%max_dvs
- min_dvs = PPM_V%min_dvs
+ min_dvs = PPM_V%min_dvs
if( dvs > max_dvs ) max_dvs = dvs
if( dvs < min_dvs ) min_dvs = dvs
-
+
PPM_V%max_dvs = max_dvs
PPM_V%min_dvs = min_dvs
@@ -428,11 +428,11 @@
drho = SCALE_RHO*dvs
! scale vp and shear velocity
dvp = SCALE_VP*dvs
- endif
+ endif
end subroutine model_ppm
-
-!
+
+!
!--------------------------------------------------------------------------------------------------
!
@@ -453,13 +453,13 @@
double precision lat,lon,depth,dvs
- !integer i,j,k
- !double precision r_top,r_bottom
-
+ !integer i,j,k
+ !double precision r_top,r_bottom
+
integer index,num_latperlon,num_lonperdepth
-
- dvs = 0.0
-
+
+ dvs = 0.0
+
if( lat > PPM_V%maxlat ) return
if( lat < PPM_V%minlat ) return
if( lon > PPM_V%maxlon ) return
@@ -470,17 +470,17 @@
! direct access: assumes having a regular interval spacing
num_latperlon = PPM_V%num_latperlon ! int( (PPM_V%maxlat - PPM_V%minlat) / PPM_V%dlat) + 1
num_lonperdepth = PPM_V%num_lonperdepth ! int( (PPM_V%maxlon - PPM_V%minlon) / PPM_V%dlon ) + 1
-
+
index = int( (depth-PPM_V%mindepth)/PPM_V%ddepth )*num_lonperdepth*num_latperlon &
+ int( (lon-PPM_V%minlon)/PPM_V%dlon )*num_latperlon &
+ int( (lat-PPM_V%minlat)/PPM_V%dlat ) + 1
dvs = PPM_V%dvs(index)
-
- ! ! loop-wise: slower performance
+
+ ! ! loop-wise: slower performance
! do i=1,PPM_V%num_v
! ! depth
- ! r_top = PPM_V%depth(i)
- ! r_bottom = PPM_V%depth(i) + PPM_V%ddepth
+ ! r_top = PPM_V%depth(i)
+ ! r_bottom = PPM_V%depth(i) + PPM_V%ddepth
! if( depth > r_top .and. depth <= r_bottom ) then
! ! longitude
! do j=i,PPM_V%num_v
@@ -488,18 +488,18 @@
! ! 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)
+ ! dvs = PPM_V%dvs(k)
! return
! endif
- ! enddo
+ ! enddo
! endif
- ! enddo
+ ! enddo
! endif
! enddo
end subroutine
-!
+!
!--------------------------------------------------------------------------------------------------
!
@@ -508,12 +508,12 @@
implicit none
include "constants.h"
-
+
double precision:: x,sigma,weight
-
+
double precision,parameter:: one_over2pisqrt = 0.3989422804014327
-
- ! normalized version
+
+ ! normalized version
!weight = one_over2pisqrt*exp(-0.5*x*x/(sigma*sigma))/sigma
! only exponential
@@ -521,7 +521,7 @@
end subroutine
-!
+!
!--------------------------------------------------------------------------------------------------
!
@@ -536,7 +536,7 @@
NEX_XI,NCHUNKS,ABSORBING_CONDITIONS,PPM_V )
! smooth model parameters
-
+
implicit none
include 'mpif.h'
@@ -573,7 +573,7 @@
! for anisotropy
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rhostore,dvpstore,kappavstore,kappahstore,&
muvstore,muhstore,eta_anisostore
-
+
! Stacey
real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey)
real(kind=CUSTOM_REAL) rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey)
@@ -611,7 +611,7 @@
!integer NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NEX_XI,ichunk
!integer nglob
-
+
!integer nspec_ani
!real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_ani) :: &
! c11store,c12store,c13store,c14store,c15store,c16store, &
@@ -624,7 +624,7 @@
! local parameters
integer i,j,k,ispec
integer iregion_code
-
+
! only include the neighboring 3 x 3 slices
integer, parameter :: NSLICES = 3
integer ,parameter :: NSLICES2 = NSLICES * NSLICES
@@ -636,8 +636,8 @@
real(kind=CUSTOM_REAL) :: x0, y0, z0, norm, norm_h, norm_v, element_size
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: factor, exp_val
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: jacobian, jacobian0
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: jacobian, jacobian0
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xl, yl, zl, xx, yy, zz
real(kind=CUSTOM_REAL), dimension(:,:,:,:,:),allocatable :: slice_jacobian
@@ -646,12 +646,12 @@
real(kind=CUSTOM_REAL), dimension(:,:,:,:,:,:),allocatable :: slice_kernels
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ks_rho,ks_kv,ks_kh,ks_muv,ks_muh,ks_eta,ks_dvp,ks_rhovp,ks_rhovs
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: tk_rho,tk_kv,tk_kh,tk_muv,tk_muh,tk_eta,tk_dvp,tk_rhovp,tk_rhovs
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: bk
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: bk
real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable:: xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
-
+
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: x, y, z
real(kind=CUSTOM_REAL), dimension(nspec) :: cx0, cy0, cz0, cx, cy, cz
double precision :: starttime
@@ -664,7 +664,7 @@
double precision, dimension(NGLLZ) :: zigll, wzgll
! array with all the weights in the cube
- double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: wgll_cube
real(kind=CUSTOM_REAL), parameter :: ZERO_ = 0.0_CUSTOM_REAL
@@ -678,23 +678,23 @@
sigma_h = 100.0 ! km, horizontal
sigma_v = 50.0 ! km, vertical
-
+
! check if smoothing applies
if( .not. GAUSS_SMOOTHING ) return
!----------------------------------------------------------------------------------------------------
! check region: only smooth in mantle & crust
if( iregion_code /= IREGION_CRUST_MANTLE ) return
-
-
- sizeprocs = NCHUNKS*NPROC_XI*NPROC_ETA
+
+
+ sizeprocs = NCHUNKS*NPROC_XI*NPROC_ETA
element_size = (TWO_PI*R_EARTH/1000.d0)/(4*NEX_XI)
if (myrank == 0) then
write(IMAIN, *) "model smoothing defaults:"
write(IMAIN, *) " NPROC_XI , NPROC_ETA, NCHUNKS: ",nproc_xi,nproc_eta,nchunks
write(IMAIN, *) " total processors : ",sizeprocs
- write(IMAIN, *) " element size on surface(km): ",element_size
+ write(IMAIN, *) " element size on surface(km): ",element_size
write(IMAIN, *) " smoothing sigma horizontal : ",sigma_h," vertical: ", sigma_v
endif
@@ -705,19 +705,19 @@
element_size = element_size / R_EARTH
sigma_h = sigma_h * 1000.0 ! m
- sigma_h = sigma_h / R_EARTH ! scale
+ sigma_h = sigma_h / R_EARTH ! scale
sigma_v = sigma_v * 1000.0 ! m
sigma_v = sigma_v / R_EARTH ! scale
-
+
sigma_h2 = sigma_h ** 2
sigma_v2 = sigma_v ** 2
! search radius
- sigma_h3 = 3.0 * sigma_h + element_size
+ sigma_h3 = 3.0 * sigma_h + element_size
sigma_h3 = sigma_h3 ** 2
- sigma_v3 = 3.0 * sigma_v + element_size
+ sigma_v3 = 3.0 * sigma_v + element_size
sigma_v3 = sigma_v3 ** 2
- ! theoretic normal value
+ ! theoretic normal value
! (see integral over -inf to +inf of exp[- x*x/(2*sigma) ] = sigma * sqrt(2*pi) )
norm_h = 2.0*PI*sigma_h**2
norm_v = sqrt(2.0*PI) * sigma_v
@@ -759,7 +759,7 @@
islice(j) = islice0(i)
endif
enddo
- nums = j
+ nums = j
if( myrank == 0 ) then
write(IMAIN, *) 'slices:',nums
@@ -772,30 +772,30 @@
xl(:,:,:,:) = xstore(:,:,:,:)
yl(:,:,:,:) = ystore(:,:,:,:)
zl(:,:,:,:) = zstore(:,:,:,:)
-
+
! build jacobian
allocate(xix(NGLLX,NGLLY,NGLLZ,nspec),xiy(NGLLX,NGLLY,NGLLZ,nspec),xiz(NGLLX,NGLLY,NGLLZ,nspec))
xix(:,:,:,:) = xixstore(:,:,:,:)
xiy(:,:,:,:) = xiystore(:,:,:,:)
xiz(:,:,:,:) = xizstore(:,:,:,:)
- allocate(etax(NGLLX,NGLLY,NGLLZ,nspec),etay(NGLLX,NGLLY,NGLLZ,nspec),etaz(NGLLX,NGLLY,NGLLZ,nspec))
+ allocate(etax(NGLLX,NGLLY,NGLLZ,nspec),etay(NGLLX,NGLLY,NGLLZ,nspec),etaz(NGLLX,NGLLY,NGLLZ,nspec))
etax(:,:,:,:) = etaxstore(:,:,:,:)
etay(:,:,:,:) = etaystore(:,:,:,:)
etaz(:,:,:,:) = etazstore(:,:,:,:)
-
- allocate(gammax(NGLLX,NGLLY,NGLLZ,nspec),gammay(NGLLX,NGLLY,NGLLZ,nspec),gammaz(NGLLX,NGLLY,NGLLZ,nspec))
+
+ allocate(gammax(NGLLX,NGLLY,NGLLZ,nspec),gammay(NGLLX,NGLLY,NGLLZ,nspec),gammaz(NGLLX,NGLLY,NGLLZ,nspec))
gammax(:,:,:,:) = gammaxstore(:,:,:,:)
gammay(:,:,:,:) = gammaystore(:,:,:,:)
gammaz(:,:,:,:) = gammazstore(:,:,:,:)
-
+
! get the location of the center of the elements
do ispec = 1, nspec
do k = 1, NGLLZ
do j = 1, NGLLY
do i = 1, NGLLX
- ! build jacobian
+ ! build jacobian
! get derivatives of ux, uy and uz with respect to x, y and z
xixl = xix(i,j,k,ispec)
xiyl = xiy(i,j,k,ispec)
@@ -809,7 +809,7 @@
! compute the jacobian
jacobianl = xixl*(etayl*gammazl-etazl*gammayl) - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ xizl*(etaxl*gammayl-etayl*gammaxl)
-
+
if( abs(jacobianl) > 1.e-25 ) then
jacobianl = 1.0_CUSTOM_REAL / jacobianl
else
@@ -848,7 +848,7 @@
call MPI_BCAST(y,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
call MPI_BCAST(z,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
call MPI_BCAST(jacobian,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
-
+
! only relevant process info gets stored
do ii=1,nums
if( islice(ii) == rank ) then
@@ -857,7 +857,7 @@
slice_z(:,:,:,:,ii) = z(:,:,:,:)
slice_jacobian(:,:,:,:,ii) = jacobian(:,:,:,:)
endif
- enddo
+ enddo
enddo
! arrays to smooth
@@ -876,16 +876,16 @@
if( ABSORBING_CONDITIONS ) then
if( iregion_code == IREGION_CRUST_MANTLE) then
ks_rhovp(:,:,:,1:nspec_stacey) = rho_vp(:,:,:,1:nspec_stacey)
- ks_rhovs(:,:,:,1:nspec_stacey) = rho_vs(:,:,:,1:nspec_stacey)
+ ks_rhovs(:,:,:,1:nspec_stacey) = rho_vs(:,:,:,1:nspec_stacey)
endif
endif
- ! in case of
+ ! in case of
!if(ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) then
! or
!if(ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE) then
! or
- !if(ATTENUATION .and. ATTENUATION_3D) then
- ! one should add the c**store and tau_* arrays here as well
+ !if(ATTENUATION .and. ATTENUATION_3D) then
+ ! one should add the c**store and tau_* arrays here as well
endif
! every process broadcasts its info
call MPI_BCAST(ks_rho,NGLLX*NGLLY*NGLLZ*NSPEC,CUSTOM_MPI_TYPE,rank,MPI_COMM_WORLD,ier)
@@ -900,7 +900,7 @@
! only relevant process info gets stored
do ii=1,nums
- if( islice(ii) == rank ) then
+ if( islice(ii) == rank ) then
slice_kernels(:,:,:,:,ii,1) = ks_rho(:,:,:,:)
slice_kernels(:,:,:,:,ii,2) = ks_kv(:,:,:,:)
slice_kernels(:,:,:,:,ii,3) = ks_kh(:,:,:,:)
@@ -909,9 +909,9 @@
slice_kernels(:,:,:,:,ii,6) = ks_eta(:,:,:,:)
slice_kernels(:,:,:,:,ii,7) = ks_dvp(:,:,:,:)
slice_kernels(:,:,:,:,ii,8) = ks_rhovp(:,:,:,:)
- slice_kernels(:,:,:,:,ii,9) = ks_rhovs(:,:,:,:)
+ slice_kernels(:,:,:,:,ii,9) = ks_rhovs(:,:,:,:)
endif
- enddo
+ enddo
enddo
! get the global maximum value of the original kernel file
@@ -931,16 +931,16 @@
tk_dvp(:,:,:,:) = 0.0_CUSTOM_REAL
tk_rhovp(:,:,:,:) = 0.0_CUSTOM_REAL
tk_rhovs(:,:,:,:) = 0.0_CUSTOM_REAL
-
+
bk(:,:,:,:) = 0.0_CUSTOM_REAL
do ii = 1, nums
if (myrank == 0) starttime = MPI_WTIME()
if (myrank == 0) write(IMAIN, *) ' slice number = ', ii
-
- ! read in the topology, jacobian, calculate center of elements
+
+ ! read in the topology, jacobian, calculate center of elements
xx(:,:,:,:) = slice_x(:,:,:,:,ii)
yy(:,:,:,:) = slice_y(:,:,:,:,ii)
- zz(:,:,:,:) = slice_z(:,:,:,:,ii)
+ zz(:,:,:,:) = slice_z(:,:,:,:,ii)
jacobian(:,:,:,:) = slice_jacobian(:,:,:,:,ii)
! get the location of the center of the elements
@@ -953,7 +953,7 @@
!if (myrank == 0) write(IMAIN, *) ' location:',cx(1),cy(1),cz(1)
!if (myrank == 0) write(IMAIN, *) ' dist:',(cx(1)-cx0(1))**2+(cy(1)-cy0(1))**2,(cz(1)-cz0(1))**2
!if (myrank == 0) write(IMAIN, *) ' sigma:',sigma_h3,sigma_v3
-
+
! array values
ks_rho(:,:,:,:) = slice_kernels(:,:,:,:,ii,1)
ks_kv(:,:,:,:) = slice_kernels(:,:,:,:,ii,2)
@@ -965,27 +965,27 @@
ks_rhovp(:,:,:,:) = slice_kernels(:,:,:,:,ii,8)
ks_rhovs(:,:,:,:) = slice_kernels(:,:,:,:,ii,9)
- ! loop over elements to be smoothed in the current slice
- do ispec = 1, nspec
+ ! loop over elements to be smoothed in the current slice
+ do ispec = 1, nspec
if (myrank == 0 .and. mod(ispec,100) == 0 ) write(IMAIN, *) ' ispec ', ispec,' sec:',MPI_WTIME()-starttime
! --- only double loop over the elements in the search radius ---
do ispec2 = 1, nspec
-
- ! checks distance between centers of elements
+
+ ! checks distance between centers of elements
if ( (cx(ispec2)-cx0(ispec))**2 + (cy(ispec2)-cy0(ispec))** 2 > sigma_h3 &
.or. (cz(ispec2)-cz0(ispec))** 2 > sigma_v3 ) cycle
factor(:,:,:) = jacobian(:,:,:,ispec2) * wgll_cube(:,:,:) ! integration factors
! loop over GLL points of the elements in current slice (ispec)
- do k = 1, NGLLZ
+ do k = 1, NGLLZ
do j = 1, NGLLY
do i = 1, NGLLX
-
- x0 = xl(i,j,k,ispec)
- y0 = yl(i,j,k,ispec)
+
+ x0 = xl(i,j,k,ispec)
+ y0 = yl(i,j,k,ispec)
z0 = zl(i,j,k,ispec) ! current point (i,j,k,ispec)
! gaussian function
@@ -1003,11 +1003,11 @@
tk_dvp(i,j,k,ispec) = tk_dvp(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_dvp(:,:,:,ispec2))
tk_rhovp(i,j,k,ispec) = tk_rhovp(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_rhovp(:,:,:,ispec2))
tk_rhovs(i,j,k,ispec) = tk_rhovs(i,j,k,ispec) + sum(exp_val(:,:,:) * ks_rhovs(:,:,:,ispec2))
-
+
! normalization, integrated values of gaussian smoothing function
bk(i,j,k,ispec) = bk(i,j,k,ispec) + sum(exp_val(:,:,:))
- enddo
+ enddo
enddo
enddo ! (i,j,k)
enddo ! (ispec2)
@@ -1019,10 +1019,10 @@
! gets depths (in km) of upper and lower limit
maxlat = PPM_V%maxlat
minlat = PPM_V%minlat
-
+
maxlon = PPM_V%maxlon
minlon = PPM_V%minlon
-
+
maxdepth = PPM_V%maxdepth
mindepth = PPM_V%mindepth
@@ -1039,9 +1039,9 @@
lat=(PI/2.0d0-theta)*180.0d0/PI
if( lat < minlat-margin_h .or. lat > maxlat+margin_h ) cycle
-
+
lon=phi*180.0d0/PI
- if(lon>180.0d0) lon=lon-360.0d0
+ if(lon>180.0d0) lon=lon-360.0d0
if( lon < minlon-margin_h .or. lon > maxlon+margin_h ) cycle
do k = 1, NGLLZ
@@ -1050,7 +1050,7 @@
! check if bk value has an entry
if (abs(bk(i,j,k,ispec) ) > 1.e-25 ) then
-
+
! check if (integrated) normalization value is close to theoretically one
if (abs(bk(i,j,k,ispec) - norm) > 1.e-3*norm ) then ! check the normalization criterion
print *, 'Problem here --- ', myrank, ispec, i, j, k, bk(i,j,k,ispec), norm
@@ -1067,7 +1067,7 @@
dvpstore(i,j,k,ispec) = tk_dvp(i,j,k,ispec) / bk(i,j,k,ispec)
endif
endif
-
+
enddo
enddo
enddo
@@ -1084,9 +1084,9 @@
lat=(PI/2.0d0-theta)*180.0d0/PI
if( lat < minlat-margin_h .or. lat > maxlat+margin_h ) cycle
-
+
lon=phi*180.0d0/PI
- if(lon>180.0d0) lon=lon-360.0d0
+ if(lon>180.0d0) lon=lon-360.0d0
if( lon < minlon-margin_h .or. lon > maxlon+margin_h ) cycle
do k = 1, NGLLZ
@@ -1096,9 +1096,9 @@
! check if bk value has an entry
if (abs(bk(i,j,k,ispec) ) > 1.e-25 ) then
rho_vp(i,j,k,ispec) = tk_rhovp(i,j,k,ispec)/bk(i,j,k,ispec)
- rho_vs(i,j,k,ispec) = tk_rhovs(i,j,k,ispec)/bk(i,j,k,ispec)
+ rho_vs(i,j,k,ispec) = tk_rhovs(i,j,k,ispec)/bk(i,j,k,ispec)
endif
-
+
enddo
enddo
enddo
@@ -1107,7 +1107,7 @@
endif
!if (myrank == 0) write(IMAIN, *) 'Maximum data value before smoothing = ', max_old
-
+
! the maximum value for the smoothed kernel
!call mpi_barrier(MPI_COMM_WORLD,ier)
!call mpi_reduce(maxval(abs(muvstore(:,:,:,:))), max_new, 1, &
@@ -1118,11 +1118,11 @@
! write(IMAIN, *)
!endif
!call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
+
end subroutine
-!
+!
!--------------------------------------------------------------------------------------------------
!
@@ -1133,11 +1133,11 @@
implicit none
integer, intent(IN) :: ichunk,ixi,ieta,nproc_xi,nproc_eta
-
+
integer, intent(OUT) :: ileft,iright,ibot,itop,ilb,ilt,irb,irt
integer :: get_slice_number
-
+
integer :: ichunk_left, islice_xi_left, islice_eta_left, &
ichunk_right, islice_xi_right, islice_eta_right, &
ichunk_bot, islice_xi_bot, islice_eta_bot, &
@@ -1162,7 +1162,7 @@
ilt = get_slice_number(ichunk,ixi-1,ieta+1,nproc_xi,nproc_eta)
irb = get_slice_number(ichunk,ixi+1,ieta-1,nproc_xi,nproc_eta)
irt = get_slice_number(ichunk,ixi+1,ieta+1,nproc_xi,nproc_eta)
-
+
if (ixi==0) then
call get_lrbt_slices(ichunk_left,islice_xi_left,islice_eta_left, &
ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
@@ -1177,7 +1177,7 @@
else if (ichunk == 2) then
ilb = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
ilt = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
- else
+ else
ilb = get_slice_number(ichunk_left0,islice_xi_left0,islice_eta_left0,nproc_xi,nproc_eta)
ilt = get_slice_number(ichunk_right0,islice_xi_right0,islice_eta_right0,nproc_xi,nproc_eta)
endif
@@ -1223,7 +1223,7 @@
irb = get_slice_number(ichunk_top0,islice_xi_top0,islice_eta_top0,nproc_xi,nproc_eta)
endif
endif
-
+
if (ieta==nproc_eta-1) then
call get_lrbt_slices(ichunk_top,islice_xi_top,islice_eta_top, &
ileft0, ichunk_left0, islice_xi_left0, islice_eta_left0, &
@@ -1250,7 +1250,7 @@
end subroutine get_all_eight_slices
-!
+!
!--------------------------------------------------------------------------------------------------
!
@@ -1327,7 +1327,7 @@
islice_xi_top=slice_xi_top(ichunk+1)
islice_eta_top=slice_eta_top(ichunk+1)
endif
-
+
ileft = get_slice_number(ichunk_left,islice_xi_left,islice_eta_left,nproc_xi,nproc_eta)
iright = get_slice_number(ichunk_right,islice_xi_right,islice_eta_right,nproc_xi,nproc_eta)
ibot = get_slice_number(ichunk_bot,islice_xi_bot,islice_eta_bot,nproc_xi,nproc_eta)
@@ -1335,7 +1335,7 @@
end subroutine get_lrbt_slices
-!
+!
!--------------------------------------------------------------------------------------------------
!
@@ -1348,5 +1348,5 @@
get_slice_number = ichunk*nproc_xi*nproc_eta+ieta*nproc_xi+ixi
end function get_slice_number
-
-
\ No newline at end of file
+
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_prem.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_prem.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_prem.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -27,14 +27,14 @@
!--------------------------------------------------------------------------------------------------
!
-! PREM [Dziewonski and Anderson, 1981].
+! PREM [Dziewonski and Anderson, 1981].
!
-! A. M. Dziewonski and D. L. Anderson.
-! Preliminary reference Earth model.
-! Phys. Earth Planet. Inter., 25:297–356, 1981.
+! A. M. Dziewonski and D. L. Anderson.
+! Preliminary reference Earth model.
+! Phys. Earth Planet. Inter., 25:297–356, 1981.
!
-! Isotropic (iso) and transversely isotropic (aniso) version of the
-! spherically symmetric Preliminary Reference Earth Model
+! Isotropic (iso) and transversely isotropic (aniso) version of the
+! spherically symmetric Preliminary Reference Earth Model
!
!--------------------------------------------------------------------------------------------------
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_s20rts.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_s20rts.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_s20rts.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -28,16 +28,16 @@
!--------------------------------------------------------------------------------------------------
! S20rts
!
-! 3D mantle model S20RTS [Ritsema et al., 1999]
+! 3D mantle model S20RTS [Ritsema et al., 1999]
!
-! Note that S20RTS uses transversely isotropic PREM as a background
-! model, and that we use the PREM radial attenuation model when ATTENUATION is incorporated.
+! Note that S20RTS uses transversely isotropic PREM as a background
+! model, and that we use the PREM radial attenuation model when ATTENUATION is incorporated.
!--------------------------------------------------------------------------------------------------
subroutine model_s20rts_broadcast(myrank,D3MM_V)
-! standard routine to setup model
+! standard routine to setup model
implicit none
@@ -63,9 +63,9 @@
integer :: myrank
integer :: ier
- ! the variables read are declared and stored in structure D3MM_V
+ ! the variables read are declared and stored in structure D3MM_V
if(myrank == 0) call read_model_s20rts(D3MM_V)
-
+
! broadcast the information read on the master to the nodes
call MPI_BCAST(D3MM_V%dvs_a,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(D3MM_V%dvs_b,(NK+1)*(NS+1)*(NS+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_s362ani.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_s362ani.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_s362ani.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -28,18 +28,18 @@
!--------------------------------------------------------------------------------------------------
! S362ani
!
-! A global shear-wave speed model developed by Kustowski et al. [2006].
+! A global shear-wave speed model developed by Kustowski et al. [2006].
!
! In this model, radial anisotropy is confined to the uppermost mantle.
-! The model (and the corresponding mesh) incorporate
+! The model (and the corresponding mesh) incorporate
! tomography on the 650~km and 410~km discontinuities in the 1D reference model REF.
!
! s362wmani: A version of S362ANI with anisotropy allowed throughout the mantle.
!
! s362ani_prem: A version of S362ANI calculated using PREM as the 1D reference model
!
-! s29ea: A global model with higher resolution in the upper mantle beneath Eurasia
-! calculated using REF as the 1D reference model.
+! s29ea: A global model with higher resolution in the upper mantle beneath Eurasia
+! calculated using REF as the 1D reference model.
!--------------------------------------------------------------------------------------------------
@@ -47,7 +47,7 @@
lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,itpspl, &
xlaspl,xlospl,radspl,coe,hsplfl,dskker,kerstr,varstr,refmdl)
-! standard routine to setup model
+! standard routine to setup model
implicit none
@@ -84,7 +84,7 @@
real(kind=4) coe(maxcoe,maxker)
character(len=80) hsplfl(maxhpa)
character(len=40) dskker(maxker)
-
+
!real(kind=4) vercof(maxker)
!real(kind=4) vercofd(maxker)
@@ -105,7 +105,7 @@
THREE_D_MODEL_S362ANI_PREM,THREE_D_MODEL_S29EA, &
numker,numhpa,ihpa,lmxhpa,itypehpa,ihpakern,numcoe,ivarkern,itpspl, &
xlaspl,xlospl,radspl,coe,hsplfl,dskker,kerstr,varstr,refmdl)
-
+
call MPI_BCAST(numker,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(numhpa,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(ihpa,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
@@ -126,10 +126,10 @@
call MPI_BCAST(kerstr,80,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(refmdl,80,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(varstr,40*maxker,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
-
-
+
+
end subroutine model_s362ani_broadcast
-
+
!
!-------------------------------------------------------------------------------------------------
!
@@ -1224,7 +1224,7 @@
! -------------------------------------
vsv3drel = 0.
vsh3drel = 0.
-
+
depth=6371.0-xrad
call evradker (depth,kerstr,numker,vercof,vercofd,ierror)
if(ierror /= 0) stop 'ierror evradker'
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_sea1d.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_sea1d.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_sea1d.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -34,7 +34,7 @@
subroutine model_sea1d_broadcast(CRUSTAL, SEA1DM_V)
-! standard routine to setup model
+! standard routine to setup model
implicit none
@@ -58,7 +58,7 @@
! all processes will define same parameters
call define_model_sea1d(CRUSTAL, SEA1DM_V)
-
+
end subroutine model_sea1d_broadcast
!
@@ -1168,7 +1168,7 @@
SEA1DM_V%Qmu_sea1d(163)= 300.0000000000000
! strip the crust and replace it by mantle
- if (SUPPRESS_CRUSTAL_MESH .or. USE_EXTERNAL_CRUSTAL_MODEL) then
+ if (SUPPRESS_CRUSTAL_MESH .or. USE_EXTERNAL_CRUSTAL_MODEL) then
do i=NR_SEA1D-12,NR_SEA1D
SEA1DM_V%density_sea1d(i) = SEA1DM_V%density_sea1d(NR_SEA1D-13)
SEA1DM_V%vp_sea1d(i) = SEA1DM_V%vp_sea1d(NR_SEA1D-13)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_sea99_s.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_sea99_s.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_sea99_s.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -43,7 +43,7 @@
subroutine model_sea99_s_broadcast(myrank,SEA99M_V)
-! standard routine to setup model
+! standard routine to setup model
implicit none
@@ -57,7 +57,7 @@
integer :: sea99_ndep
integer :: sea99_nlat
integer :: sea99_nlon
- integer :: dummy_pad ! padding 4 bytes to align the structure
+ integer :: dummy_pad ! padding 4 bytes to align the structure
double precision :: sea99_ddeg
double precision :: alatmin
double precision :: alatmax
@@ -72,7 +72,7 @@
integer :: myrank
integer :: ier
-
+
if(myrank == 0) call read_sea99_s_model(SEA99M_V)
! broadcast the information read on the master to the nodes
@@ -106,7 +106,7 @@
integer :: sea99_ndep
integer :: sea99_nlat
integer :: sea99_nlon
- integer :: dummy_pad ! padding 4 bytes to align the structure
+ integer :: dummy_pad ! padding 4 bytes to align the structure
double precision :: sea99_ddeg
double precision :: alatmin
double precision :: alatmax
@@ -171,7 +171,7 @@
integer :: sea99_ndep
integer :: sea99_nlat
integer :: sea99_nlon
- integer :: dummy_pad ! padding 4 bytes to align the structure
+ integer :: dummy_pad ! padding 4 bytes to align the structure
double precision :: sea99_ddeg
double precision :: alatmin
double precision :: alatmax
@@ -190,12 +190,12 @@
! initializes
dvs = 0.d0
-
+
id1 = 0
xd1 = 0
!----------------------- depth in the model ------------------
- dep=R_EARTH_KM*(R_UNIT_SPHERE - radius)
+ dep=R_EARTH_KM*(R_UNIT_SPHERE - radius)
if (dep .le. SEA99M_V%sea99_depth(1)) then
id1 = 1
xd1 = 0
@@ -225,7 +225,7 @@
! checks range
if( pla < SEA99M_V%alatmin .or. pla > SEA99M_V%alatmax &
.or. plo < SEA99M_V%alonmin .or. plo > SEA99M_V%alonmax ) return
-
+
! array indices
ilat = int((pla - SEA99M_V%alatmin)/SEA99M_V%sea99_ddeg) + 1
ilon = int((plo - SEA99M_V%alonmin)/SEA99M_V%sea99_ddeg) + 1
@@ -243,7 +243,7 @@
ddd(i) = dd1 + yyy*xxx
enddo
dvs = ddd(1) + (ddd(2)-ddd(1)) * xd1
-
+
! checks perturbation
if(dvs > 1.d0) dvs = 0.0d0
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/model_topo_bathy.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/model_topo_bathy.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/model_topo_bathy.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -36,7 +36,7 @@
subroutine model_topo_bathy_broadcast(myrank,ibathy_topo)
-! standard routine to setup model
+! standard routine to setup model
implicit none
@@ -49,12 +49,12 @@
integer :: myrank
integer :: ier
-
+
if(myrank == 0) call read_topo_bathy_file(ibathy_topo)
-
+
! broadcast the information read on the master to the nodes
- call MPI_BCAST(ibathy_topo,NX_BATHY*NY_BATHY,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
+ call MPI_BCAST(ibathy_topo,NX_BATHY*NY_BATHY,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
end subroutine model_topo_bathy_broadcast
!
@@ -91,10 +91,10 @@
enddo
enddo
close(13)
-
+
! note: we check the limits after reading in the data. this seems to perform sligthly faster
! however, reading ETOPO1.xyz will take ~ 2m 1.2s for a single process
-
+
! imposes limits
if( USE_MAXIMUM_HEIGHT_TOPO .or. USE_MAXIMUM_DEPTH_OCEANS ) then
do itopo_y=1,NY_BATHY
@@ -110,7 +110,7 @@
enddo
enddo
-
+
endif
end subroutine read_topo_bathy_file
@@ -181,10 +181,10 @@
value = dble(ibathy_topo(iel1,iadd1))*(1-ratio_lon)*(1.-ratio_lat) &
+ dble(ibathy_topo(1,iadd1))*ratio_lon*(1.-ratio_lat) &
+ dble(ibathy_topo(1,iadd1+1))*ratio_lon*ratio_lat &
- + dble(ibathy_topo(iel1,iadd1+1))*(1.-ratio_lon)*ratio_lat
+ + dble(ibathy_topo(iel1,iadd1+1))*(1.-ratio_lon)*ratio_lat
else
! for points on latitude boundaries
- value = dble(ibathy_topo(iel1,iadd1))
+ value = dble(ibathy_topo(iel1,iadd1))
endif
end subroutine get_topo_bathy
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/moho_stretching.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/moho_stretching.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/moho_stretching.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -44,7 +44,7 @@
double precision RMOHO_FICTITIOUS_IN_MESHER
integer :: myrank
logical :: elem_in_crust,elem_in_mantle
-
+
! local parameters
integer:: ia,count_crust,count_mantle
double precision:: r,theta,phi,lat,lon
@@ -55,20 +55,20 @@
double precision, parameter :: PI_OVER_TWO = PI / 2.0d0
double precision :: stretch_factor
double precision :: x,y,z
- double precision :: R_moho,R_middlecrust
+ double precision :: R_moho,R_middlecrust
! radii for stretching criteria
R_moho = RMOHO_FICTITIOUS_IN_MESHER/R_EARTH
- R_middlecrust = RMIDDLE_CRUST/R_EARTH
-
- ! loops over element's anchor points
+ R_middlecrust = RMIDDLE_CRUST/R_EARTH
+
+ ! loops over element's anchor points
count_crust = 0
count_mantle = 0
do ia = 1,NGNOD
x = xelm(ia)
y = yelm(ia)
z = zelm(ia)
-
+
call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
call reduce(theta,phi)
@@ -95,28 +95,28 @@
if (moho < R_moho ) then
! actual moho below fictitious moho
! elements in second layer will stretch down to honor moho topography
-
+
elevation = moho - R_moho
if ( r >= R_moho ) then
! point above fictitious moho
! gamma ranges from 0 (point at surface) to 1 (point at fictitious moho depth)
gamma = (( R_UNIT_SPHERE - r )/( R_UNIT_SPHERE - R_moho ))
- else
+ 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))
-
+ 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
+ end if
if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
call exit_MPI(myrank,'incorrect value of gamma for moho from crust 2.0')
-
+
! offset will be gamma * elevation
! scaling cartesian coordinates xyz rather than spherical r/theta/phi involves division of offset by r
stretch_factor = ONE + gamma * elevation/r
@@ -131,23 +131,23 @@
else if ( moho > R_middlecrust ) then
! moho above middle crust
! elements in first layer will squeeze into crust above moho
-
+
elevation = moho - R_middlecrust
if ( r > R_middlecrust ) then
! point above middle crust
! gamma ranges from 0 (point at surface) to 1 (point at middle crust depth)
gamma = (R_UNIT_SPHERE-r)/(R_UNIT_SPHERE - R_middlecrust )
- else
+ 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 )
-
+ ! gamma ranges from 0 (point at R220) to 1 (point at middle crust depth)
+ gamma = (r - R220/R_EARTH)/( R_middlecrust - R220/R_EARTH )
+
! since not all GLL points are exactlly at R220, use a small
! tolerance for R220 detection, fix R220
if (abs(gamma) < SMALLVAL) then
gamma = 0.0d0
- end if
+ end if
end if
if(gamma < -0.0001d0 .or. gamma > 1.0001d0) &
@@ -156,7 +156,7 @@
! offset will be gamma * elevation
! scaling cartesian coordinates xyz rather than spherical r/theta/phi involves division of offset by r
stretch_factor = ONE + gamma * elevation/r
-
+
xelm(ia) = x * stretch_factor
yelm(ia) = y * stretch_factor
zelm(ia) = z * stretch_factor
@@ -164,29 +164,29 @@
! recalculate radius to decide whether this element is in the crust
r = dsqrt(xelm(ia)*xelm(ia) + yelm(ia)*yelm(ia) + zelm(ia)*zelm(ia))
- end if
+ end if
! counts corners in above moho
- ! note: uses a small tolerance
+ ! note: uses a small tolerance
if ( r >= 0.9999d0*moho ) then
count_crust = count_crust + 1
- endif
+ endif
! counts corners below moho
! again within a small tolerance
if ( r <= 1.0001d0*moho ) then
count_mantle = count_mantle + 1
endif
- end do
+ end do
! sets flag when all corners are above moho
if( count_crust == NGNOD) then
elem_in_crust = .true.
- end if
+ end if
! sets flag when all corners are below moho
if( count_mantle == NGNOD) then
elem_in_mantle = .true.
- end if
+ end if
! small stretch check: stretching should affect only points above R220
if( r*R_EARTH < R220 ) then
@@ -481,4 +481,4 @@
! end subroutine read_smooth_moho
-
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/prepare_timerun.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/prepare_timerun.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/prepare_timerun.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -46,16 +46,16 @@
buffer_send_chunkcorners_scalar,buffer_recv_chunkcorners_scalar, &
NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY)
-
-
+
+
implicit none
-
+
include 'mpif.h'
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
integer myrank
-
+
real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: rmass_crust_mantle
real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: rmass_outer_core
@@ -63,18 +63,18 @@
integer ichunk,iproc_xi,iproc_eta
integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
-
+
! 2-D addressing and buffers for summation between slices
integer, dimension(NGLOB2DMAX_XMIN_XMAX_CM) :: iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle
integer, dimension(NGLOB2DMAX_YMIN_YMAX_CM) :: iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle
-
+
integer, dimension(NGLOB2DMAX_XMIN_XMAX_OC) :: iboolleft_xi_outer_core,iboolright_xi_outer_core
integer, dimension(NGLOB2DMAX_YMIN_YMAX_OC) :: iboolleft_eta_outer_core,iboolright_eta_outer_core
integer, dimension(NGLOB2DMAX_XMIN_XMAX_IC) :: iboolleft_xi_inner_core,iboolright_xi_inner_core
integer, dimension(NGLOB2DMAX_YMIN_YMAX_IC) :: iboolleft_eta_inner_core,iboolright_eta_inner_core
-
+
integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle
-
+
integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_outer_core,npoin2D_eta_outer_core
integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_inner_core,npoin2D_eta_inner_core
@@ -177,8 +177,8 @@
if(myrank == 0) write(IMAIN,*) 'end assembling MPI mass matrix'
- end subroutine prepare_timerun_rmass
-
+ end subroutine prepare_timerun_rmass
+
!
!-------------------------------------------------------------------------------------------------
!
@@ -198,7 +198,7 @@
buffer_slices,buffer_slices2,buffer_all_cube_from_slices)
implicit none
-
+
include 'mpif.h'
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
@@ -208,7 +208,7 @@
real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: rmass_inner_core
integer ichunk,iproc_xi,iproc_eta
-
+
integer, dimension(MAX_NUM_REGIONS) :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM
integer, dimension(NCHUNKS_VAL,0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL-1) :: addressing
@@ -285,16 +285,16 @@
! precomputes constants for time integration
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
-
+
integer myrank,NSTEP
double precision DT
double precision t0
-
-
+
+
double precision scale_t,scale_t_inv,scale_displ,scale_veloc
real(kind=CUSTOM_REAL) deltat,deltatover2,deltatsqover2
@@ -307,10 +307,10 @@
real(kind=CUSTOM_REAL) b_two_omega_earth
integer SIMULATION_TYPE
-
- ! local parameters
-
+ ! local parameters
+
+
if(myrank == 0) then
write(IMAIN,*)
write(IMAIN,*) ' time step: ',sngl(DT),' s'
@@ -324,9 +324,9 @@
! scaling to make displacement in meters and velocity in meters per second
scale_t = ONE/dsqrt(PI*GRAV*RHOAV)
scale_t_inv = dsqrt(PI*GRAV*RHOAV)
-
+
scale_displ = R_EARTH
-
+
scale_veloc = scale_displ * scale_t_inv
! distinguish between single and double precision for reals
@@ -366,7 +366,7 @@
endif
A_array_rotation = 0.
B_array_rotation = 0.
-
+
if (SIMULATION_TYPE == 3) then
if(CUSTOM_REAL == SIZE_REAL) then
b_two_omega_earth = sngl(2.d0 * TWO_PI / (HOURS_PER_DAY * 3600.d0 * scale_t_inv))
@@ -381,7 +381,7 @@
end subroutine prepare_timerun_constants
-
+
!
!-------------------------------------------------------------------------------------------------
!
@@ -396,10 +396,10 @@
! precomputes gravity factors
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
-
+
integer myrank
real(kind=CUSTOM_REAL) minus_g_cmb,minus_g_icb
@@ -410,17 +410,17 @@
d_ln_density_dr_table,minus_rho_g_over_kappa_fluid
logical ONE_CRUST
-
+
double precision RICB,RCMB,RTOPDDOUBLEPRIME, &
R80,R220,R400,R600,R670,R771,RMOHO,RMIDDLE_CRUST,ROCEAN
-
+
! local parameters
double precision :: rspl_gravity(NR),gspl(NR),gspl2(NR)
double precision :: radius,radius_km,g,dg
double precision :: g_cmb_dble,g_icb_dble
double precision :: rho,drhodr,vp,vs,Qkappa,Qmu
integer :: int_radius,idoubling,nspl_gravity
-
+
! store g, rho and dg/dr=dg using normalized radius in lookup table every 100 m
! get density and velocity from PREM model using dummy doubling flag
! this assumes that the gravity perturbations are small and smooth
@@ -439,7 +439,7 @@
R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
dg = 4.0d0*rho - 2.0d0*g/radius
-
+
minus_gravity_table(int_radius) = - g
minus_deriv_gravity_table(int_radius) = - dg
density_table(int_radius) = rho
@@ -481,9 +481,9 @@
call model_prem_iso(myrank,radius,rho,drhodr,vp,vs,Qkappa,Qmu,idoubling,.false., &
ONE_CRUST,.false.,RICB,RCMB,RTOPDDOUBLEPRIME, &
R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
-
+
d_ln_density_dr_table(int_radius) = drhodr/rho
-
+
enddo
endif
@@ -513,10 +513,10 @@
! precomputes attenuation factors
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
-
+
integer myrank
! memory variables and standard linear solids for attenuation
@@ -525,7 +525,7 @@
real(kind=CUSTOM_REAL), dimension(N_SLS,ATT1,ATT2,ATT3,ATT4) :: factor_common_crust_mantle
real(kind=CUSTOM_REAL), dimension(N_SLS,ATT1,ATT2,ATT3,ATT5) :: factor_common_inner_core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_MANTLE) :: &
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_MANTLE) :: &
c11store_crust_mantle,c12store_crust_mantle,c13store_crust_mantle, &
c22store_crust_mantle,c23store_crust_mantle, &
c33store_crust_mantle,c44store_crust_mantle, &
@@ -536,7 +536,7 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_TISO_MANTLE) :: &
muhstore_crust_mantle
integer, dimension(NSPEC_CRUST_MANTLE) :: idoubling_crust_mantle
-
+
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: &
muvstore_inner_core
@@ -545,7 +545,7 @@
logical MOVIE_VOLUME
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STR_OR_ATT) :: muvstore_crust_mantle_3dmovie
-
+
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ANISO_IC) :: &
c11store_inner_core,c33store_inner_core,c12store_inner_core, &
c13store_inner_core,c44store_inner_core
@@ -564,7 +564,7 @@
double precision, dimension(N_SLS,ATT1,ATT2,ATT3,ATT5) :: factor_common_inner_core_dble
double precision, dimension(N_SLS) :: alphaval_dble, betaval_dble, gammaval_dble
double precision, dimension(N_SLS) :: tau_sigma_dble
-
+
double precision :: scale_factor,scale_factor_minus_one
real(kind=CUSTOM_REAL) :: mul
integer :: ispec,i,j,k
@@ -576,7 +576,7 @@
call create_name_database(prname, myrank, IREGION_CRUST_MANTLE, LOCAL_PATH)
call get_attenuation_model_3D(myrank, prname, omsb_crust_mantle_dble, &
factor_common_crust_mantle_dble,factor_scale_crust_mantle_dble,tau_sigma_dble,NSPEC_CRUST_MANTLE)
-
+
! INNER_CORE ATTENUATION
call create_name_database(prname, myrank, IREGION_INNER_CORE, LOCAL_PATH)
call get_attenuation_model_3D(myrank, prname, omsb_inner_core_dble, &
@@ -683,7 +683,7 @@
enddo
enddo ! END DO INNER CORE
- ! precompute Runge-Kutta coefficients
+ ! precompute Runge-Kutta coefficients
call get_attenuation_memory_values(tau_sigma_dble, deltat, alphaval_dble, betaval_dble, gammaval_dble)
if(CUSTOM_REAL == SIZE_REAL) then
alphaval = sngl(alphaval_dble)
@@ -694,7 +694,7 @@
betaval = betaval_dble
gammaval = gammaval_dble
endif
-
+
if (SIMULATION_TYPE == 3) then
call get_attenuation_memory_values(tau_sigma_dble, b_deltat, alphaval_dble, betaval_dble, gammaval_dble)
if(CUSTOM_REAL == SIZE_REAL) then
@@ -709,6 +709,6 @@
endif
end subroutine prepare_timerun_attenuation
-
-
-
\ No newline at end of file
+
+
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/read_compute_parameters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/read_compute_parameters.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/read_compute_parameters.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -93,12 +93,12 @@
NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
NPROC_XI,NPROC_ETA,REFERENCE_1D_MODEL,THREE_D_MODEL
-
+
double precision DT,ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R120,R220,R400, &
R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS, &
RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
-
+
double precision MOVIE_TOP,MOVIE_BOTTOM,MOVIE_EAST,MOVIE_WEST,&
MOVIE_NORTH,MOVIE_SOUTH
@@ -165,7 +165,7 @@
SAVE_MESH_FILES,ATTENUATION,ABSORBING_CONDITIONS,SAVE_FORWARD, &
OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE)
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE)
! converts values to radians
MOVIE_EAST = MOVIE_EAST_DEG * DEGREES_TO_RADIANS
@@ -175,7 +175,7 @@
! converts movie top/bottom depths to radii
MOVIE_TOP = (R_EARTH_KM-MOVIE_TOP_KM)/R_EARTH_KM
MOVIE_BOTTOM = (R_EARTH_KM-MOVIE_BOTTOM_KM)/R_EARTH_KM
-
+
! include central cube or not
! use regular cubed sphere instead of cube for large distances
if(NCHUNKS == 6) then
@@ -208,7 +208,7 @@
RTOPDDOUBLEPRIME,RCMB,RICB,RMOHO_FICTITIOUS_IN_MESHER, &
R80_FICTITIOUS_IN_MESHER,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS)
-
+
! sets time step size and number of layers
! right distribution is determined based upon maximum value of NEX
NEX_MAX = max(NEX_XI,NEX_ETA)
@@ -221,14 +221,14 @@
ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL, &
ANISOTROPIC_INNER_CORE)
-
+
! compute total number of time steps, rounded to next multiple of 100
NSTEP = 100 * (int(RECORD_LENGTH_IN_MINUTES * 60.d0 / (100.d0*DT)) + 1)
! subsets used to save seismograms must not be larger than the whole time series,
! otherwise we waste memory
if(NTSTEP_BETWEEN_OUTPUT_SEISMOS > NSTEP) then
- NTSTEP_BETWEEN_OUTPUT_SEISMOS = NSTEP
+ NTSTEP_BETWEEN_OUTPUT_SEISMOS = NSTEP
endif
! computes a default hdur_movie that creates nice looking movies.
@@ -290,11 +290,11 @@
NPROCTOT = NCHUNKS * NPROC
- ! definition of general mesh parameters
+ ! definition of general mesh parameters
call rcp_define_all_layers(NER_CRUST,NER_80_MOHO,NER_220_80,&
NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,&
+ NER_TOP_CENTRAL_CUBE_ICB,&
RMIDDLE_CRUST,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
R_CENTRAL_CUBE,RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER,&
ONE_CRUST,ner,ratio_sampling_array,&
@@ -307,7 +307,7 @@
doubling_index,rmins,rmaxs)
- ! calculates number of elements (NSPEC)
+ ! calculates number of elements (NSPEC)
call rcp_count_elements(NEX_XI,NEX_ETA,NEX_PER_PROC_XI,NPROC,&
NEX_PER_PROC_ETA,ratio_divide_central_cube,&
NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
@@ -340,15 +340,15 @@
CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge)
-
-
+
+
end subroutine read_compute_parameters
!
!-------------------------------------------------------------------------------------------------
!
-
+
subroutine rcp_set_timestep_and_layers(DT,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD, &
NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,&
NER_600_400,NER_670_600,NER_771_670, &
@@ -366,13 +366,13 @@
! parameters read from parameter file
integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD
-
+
integer NER_CRUST,NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
NER_TOP_CENTRAL_CUBE_ICB
-
+
integer NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL
-
+
double precision DT
double precision R_CENTRAL_CUBE
double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES
@@ -390,7 +390,7 @@
else
multiplication_factor=1
endif
-
+
! element width = 0.5625000 degrees = 62.54715 km
if(NEX_MAX*multiplication_factor <= 160) then
! time step
@@ -412,7 +412,7 @@
NER_CMB_TOPDDOUBLEPRIME = 1
NER_OUTER_CORE = 16
NER_TOP_CENTRAL_CUBE_ICB = 2
-
+
! radius of central cube
R_CENTRAL_CUBE = 950000.d0
@@ -607,7 +607,7 @@
! the 670-discontinuity is moved up to 650 km depth.
if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1DREF) then
NER_771_670 = NER_771_670 + 1
- end if
+ end if
!----
!---- change some values in the case of regular PREM with two crustal layers or of 3D models
@@ -629,7 +629,7 @@
endif
else
! 3D models: must have two element layers for crust
- if (NER_CRUST < 2 ) NER_CRUST = 2
+ if (NER_CRUST < 2 ) NER_CRUST = 2
! makes time step smaller
if(NEX_MAX*multiplication_factor <= 80) then
DT = 0.125d0
@@ -702,7 +702,7 @@
! case 3D
if (NER_CRUST < 2 ) NER_CRUST = 2
endif
-
+
endif
!---
@@ -713,18 +713,18 @@
! time step reductions are based on empirical values (..somehow)
-
+
! following models need special attention, at least for global simulations:
- if( NCHUNKS == 6 ) then
-
+ if( NCHUNKS == 6 ) then
+
! makes time step smaller for this ref model, otherwise becomes unstable in fluid
if (REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) &
DT = DT*(1.d0 - 0.3d0)
! using inner core anisotropy, simulations might become unstable in solid
if( ANISOTROPIC_INNER_CORE ) then
- ! DT = DT*(1.d0 - 0.1d0) not working yet...
- stop 'anisotropic inner core - unstable feature, uncomment this line in read_compute_parameters.f90'
+ ! DT = DT*(1.d0 - 0.1d0) not working yet...
+ stop 'anisotropic inner core - unstable feature, uncomment this line in read_compute_parameters.f90'
endif
endif
@@ -732,7 +732,7 @@
! following models need special attention, regardless of number of chunks:
! it makes the time step smaller for this ref model, otherwise becomes unstable in fluid
if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) &
- DT = DT*(1.d0 - 0.8d0) ! *0.20d0
+ DT = DT*(1.d0 - 0.8d0) ! *0.20d0
if( ITYPE_CRUSTAL_MODEL == ICRUST_CRUSTMAPS ) &
@@ -747,11 +747,11 @@
! takes a 5% safety margin on the maximum stable time step
! which was obtained by trial and error
DT = DT * (1.d0 - 0.05d0)
-
+
end subroutine rcp_set_timestep_and_layers
-
+
!
!-------------------------------------------------------------------------------------------------
!
@@ -766,14 +766,14 @@
include "constants.h"
- integer NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA,NCHUNKS,NTSTEP_BETWEEN_OUTPUT_SEISMOS
+ integer NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA,NCHUNKS,NTSTEP_BETWEEN_OUTPUT_SEISMOS
- double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES
+ double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES
logical ATTENUATION_3D,ATTENUATION,ABSORBING_CONDITIONS,&
- INCLUDE_CENTRAL_CUBE,OUTPUT_SEISMOS_SAC_ALPHANUM
-
+ INCLUDE_CENTRAL_CUBE,OUTPUT_SEISMOS_SAC_ALPHANUM
+
! checks parameters
if(NCHUNKS /= 1 .and. NCHUNKS /= 2 .and. NCHUNKS /= 3 .and. NCHUNKS /= 6) &
@@ -847,17 +847,17 @@
if(NCHUNKS > 1 .and. (NPROC_XI == 1 .or. NPROC_ETA == 1)) stop 'support for only one slice per chunk has been discontinued'
end subroutine rcp_check_parameters
-
-
+
+
!
!-------------------------------------------------------------------------------------------------
!
-
-
+
+
subroutine rcp_define_all_layers(NER_CRUST,NER_80_MOHO,NER_220_80,&
NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,&
+ NER_TOP_CENTRAL_CUBE_ICB,&
RMIDDLE_CRUST,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
R_CENTRAL_CUBE,RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER,&
ONE_CRUST,ner,ratio_sampling_array,&
@@ -884,7 +884,7 @@
NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
NER_TOP_CENTRAL_CUBE_ICB
integer NUMBER_OF_MESH_LAYERS,layer_offset,last_doubling_layer
-
+
double precision RMIDDLE_CRUST,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
R_CENTRAL_CUBE,RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
@@ -1738,8 +1738,8 @@
end subroutine rcp_define_all_layers
-
-
+
+
!
!-------------------------------------------------------------------------------------------------
!
@@ -1765,16 +1765,16 @@
implicit none
include "constants.h"
-
+
! parameters to be computed based upon parameters above read from file
integer NPROC,NEX_XI,NEX_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
integer, dimension(MAX_NUM_REGIONS) :: NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
NSPEC1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
-
+
logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
@@ -1962,9 +1962,9 @@
(((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - to_remove - doubling*nb_lay_sb)) + &
doubling * (((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))/divider) * (nglob_surf-nglob_edges_h) - &
((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))/divider -1) * nglob_edge_v)
-
+
enddo ! iter_layer
-
+
NSPEC2D_XI(iter_region) = tmp_sum_xi
NSPEC2D_ETA(iter_region) = tmp_sum_eta
@@ -2091,10 +2091,10 @@
if(minval(NSPEC) <= 0) stop 'negative NSPEC, there is a problem somewhere, try to recompile :) '
-
+
end subroutine rcp_count_elements
-
+
!
!-------------------------------------------------------------------------------------------------
!
@@ -2111,7 +2111,7 @@
nb_lay_sb, nglob_vol, nglob_surf, nglob_edge, &
CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
- normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge)
+ normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!
@@ -2134,7 +2134,7 @@
NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
NGLOB
- integer NER_TOP_CENTRAL_CUBE_ICB,NEX_XI
+ integer NER_TOP_CENTRAL_CUBE_ICB,NEX_XI
integer nblocks_xi,nblocks_eta
integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
@@ -2312,4 +2312,4 @@
!!! NGLOB = 6.NGLL^2 - 7.NGLL + 2 (SURFACE 2)
end subroutine rcp_count_points
-
\ No newline at end of file
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/read_forward_arrays.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/read_forward_arrays.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/read_forward_arrays.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -45,14 +45,14 @@
! reads in saved wavefields
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
-
+
integer myrank,NSTEP
integer SIMULATION_TYPE
-
+
integer NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,it_begin,it_end
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
@@ -178,4 +178,4 @@
endif
end subroutine read_forward_arrays
-
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/read_mesh_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/read_mesh_databases.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/read_mesh_databases.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -57,15 +57,15 @@
c33store_inner_core,c44store_inner_core, &
ibool_inner_core,idoubling_inner_core,rmass_inner_core, &
ABSORBING_CONDITIONS,LOCAL_PATH)
-
-
+
+
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
- integer myrank
+ integer myrank
! Stacey
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_STACEY) :: &
@@ -102,8 +102,8 @@
! additional mass matrix for ocean load
real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE_OCEANS) :: rmass_ocean_load
- ! stacy outer core
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_STACEY) :: vp_outer_core
+ ! stacy outer core
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_STACEY) :: vp_outer_core
! mesh parameters
real(kind=CUSTOM_REAL), dimension(NGLOB_OUTER_CORE) :: &
xstore_outer_core,ystore_outer_core,zstore_outer_core
@@ -139,7 +139,7 @@
!local parameters
logical READ_KAPPA_MU,READ_TISO
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,1) :: dummy_array
-
+
! start reading the databases
! read arrays created by the mesher
@@ -276,7 +276,7 @@
iboolcorner_outer_core, &
iboolleft_xi_inner_core,iboolright_xi_inner_core, &
iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
iboolfaces_inner_core,npoin2D_faces_inner_core, &
iboolcorner_inner_core, &
iprocfrom_faces,iprocto_faces,imsg_type, &
@@ -288,13 +288,13 @@
ichunk,iproc_xi,iproc_eta)
implicit none
-
+
include 'mpif.h'
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
integer myrank
-
+
! 2-D addressing and buffers for summation between slices
integer, dimension(NGLOB2DMAX_XMIN_XMAX_CM) :: iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle
integer, dimension(NGLOB2DMAX_YMIN_YMAX_CM) :: iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle
@@ -302,7 +302,7 @@
integer, dimension(NGLOB2DMAX_YMIN_YMAX_OC) :: iboolleft_eta_outer_core,iboolright_eta_outer_core
integer, dimension(NGLOB2DMAX_XMIN_XMAX_IC) :: iboolleft_xi_inner_core,iboolright_xi_inner_core
integer, dimension(NGLOB2DMAX_YMIN_YMAX_IC) :: iboolleft_eta_inner_core,iboolright_eta_inner_core
-
+
integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle
integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_outer_core,npoin2D_eta_outer_core
integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_inner_core,npoin2D_eta_inner_core
@@ -483,12 +483,12 @@
end subroutine read_mesh_databases_addressing
-
-!
+
+!
!-------------------------------------------------------------------------------------------------
-!
-
+!
+
subroutine read_mesh_databases_coupling(myrank, &
nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle, &
@@ -507,7 +507,7 @@
jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core,jacobian2D_ymin_outer_core, &
jacobian2D_ymax_outer_core,jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
nspec2D_xmin_inner_core,nspec2D_xmax_inner_core, &
- nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
+ nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core, &
ibelm_ymax_inner_core,ibelm_bottom_inner_core,ibelm_top_inner_core, &
ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot, &
@@ -517,7 +517,7 @@
! to couple mantle with outer core
implicit none
-
+
include 'mpif.h'
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
@@ -546,7 +546,7 @@
! arrays to couple with the fluid regions by pointwise matching
integer nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
integer, dimension(NSPEC2DMAX_XMIN_XMAX_OC) :: ibelm_xmin_outer_core,ibelm_xmax_outer_core
integer, dimension(NSPEC2DMAX_YMIN_YMAX_OC) :: ibelm_ymin_outer_core,ibelm_ymax_outer_core
integer, dimension(NSPEC2D_BOTTOM_OC) :: ibelm_bottom_outer_core
@@ -590,9 +590,9 @@
character(len=150) LOCAL_PATH
integer SIMULATION_TYPE
-
+
! local parameters
- integer njunk1,njunk2,njunk3
+ integer njunk1,njunk2,njunk3
character(len=150) prname
@@ -705,9 +705,9 @@
! -- Boundary Mesh for crust and mantle ---
if (SAVE_BOUNDARY_MESH .and. SIMULATION_TYPE == 3) then
-
+
call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
-
+
open(unit=27,file=prname(1:len_trim(prname))//'boundary_disc.bin', &
status='old',form='unformatted')
read(27) njunk1,njunk2,njunk3
@@ -761,7 +761,7 @@
SIMULATION_TYPE,SAVE_FORWARD,LOCAL_PATH)
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
@@ -774,29 +774,29 @@
integer nspec2D_xmin_crust_mantle,nspec2D_xmax_crust_mantle, &
nspec2D_ymin_crust_mantle,nspec2D_ymax_crust_mantle
integer reclen_xmin_crust_mantle, reclen_xmax_crust_mantle, reclen_ymin_crust_mantle, &
- reclen_ymax_crust_mantle
-
+ reclen_ymax_crust_mantle
+
integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_OC) :: nimin_outer_core,nimax_outer_core,nkmin_eta_outer_core
- integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_OC) :: njmin_outer_core,njmax_outer_core,nkmin_xi_outer_core
+ integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_OC) :: njmin_outer_core,njmax_outer_core,nkmin_xi_outer_core
integer nspec2D_xmin_outer_core,nspec2D_xmax_outer_core, &
- nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
+ nspec2D_ymin_outer_core,nspec2D_ymax_outer_core
integer reclen_xmin_outer_core, reclen_xmax_outer_core,reclen_ymin_outer_core, &
reclen_ymax_outer_core
-
+
integer reclen_zmin
integer, dimension(MAX_NUM_REGIONS) :: NSPEC2D_BOTTOM
-
+
integer SIMULATION_TYPE
logical SAVE_FORWARD
- character(len=150) LOCAL_PATH
-
+ character(len=150) LOCAL_PATH
+
! local parameters
character(len=150) prname
! crust and mantle
! create name of database
- call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
+ call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
! read arrays for Stacey conditions
open(unit=27,file=prname(1:len_trim(prname))//'stacey.bin', &
@@ -950,8 +950,8 @@
recl=reclen_zmin+2*4)
endif
endif
-
+
end subroutine read_mesh_databases_stacey
-
-
+
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/read_parameter_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/read_parameter_file.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/read_parameter_file.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -189,4 +189,4 @@
call close_parameter_file()
end subroutine read_parameter_file
-
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/rthetaphi_xyz.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/rthetaphi_xyz.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/rthetaphi_xyz.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -90,12 +90,12 @@
if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE
if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE
-
+
theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh)
-
+
if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE
if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE
-
+
phi = datan2(ymesh,xmesh)
r = dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*zmesh)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/save_arrays_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/save_arrays_solver.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/save_arrays_solver.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -43,7 +43,7 @@
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)
+ ABSORBING_CONDITIONS,SAVE_MESH_FILES)
implicit none
@@ -67,7 +67,7 @@
integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
integer :: Qn ! Number of points
- integer dummy_pad ! padding 4 bytes to align the structure
+ integer dummy_pad ! padding 4 bytes to align the structure
end type model_attenuation_variables
logical ATTENUATION
@@ -75,7 +75,7 @@
character(len=150) prname
integer iregion_code
- integer nspec,nglob,nspec_stacey
+ integer nspec,nglob,nspec_stacey
integer npointot_oceans
! Stacey
@@ -116,7 +116,7 @@
! boundary parameters locator
integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP
-
+
integer ibelm_xmin(NSPEC2DMAX_XMIN_XMAX),ibelm_xmax(NSPEC2DMAX_XMIN_XMAX)
integer ibelm_ymin(NSPEC2DMAX_YMIN_YMAX),ibelm_ymax(NSPEC2DMAX_YMIN_YMAX)
integer ibelm_bottom(NSPEC2D_BOTTOM),ibelm_top(NSPEC2D_TOP)
@@ -152,25 +152,25 @@
! local parameters
integer i,j,k,ispec,iglob,nspec1, nglob1
real(kind=CUSTOM_REAL) scaleval1,scaleval2
-
+
! save nspec and nglob, to be used in combine_paraview_data
open(unit=27,file=prname(1:len_trim(prname))//'array_dims.txt',status='unknown',action='write')
nspec1 = nspec
nglob1 = nglob
-
+
! might be wrong, check...
!if (NCHUNKS == 6 .and. ichunk /= CHUNK_AB .and. iregion_code == IREGION_INNER_CORE) then
- ! ! only chunk_AB contains inner core?
+ ! ! only chunk_AB contains inner core?
! ratio_divide_central_cube = 16
- ! ! corrects nspec/nglob
+ ! ! corrects nspec/nglob
! nspec1 = nspec1 - (NEX_PER_PROC_XI/ratio_divide_central_cube) &
! * (NEX_PER_PROC_ETA/ratio_divide_central_cube) * (NEX_XI/ratio_divide_central_cube)
! nglob1 = nglob1 - ((NEX_PER_PROC_XI/ratio_divide_central_cube)*(NGLLX-1)+1) &
! * ((NEX_PER_PROC_ETA/ratio_divide_central_cube)*(NGLLY-1)+1) &
- ! * (NEX_XI/ratio_divide_central_cube)*(NGLLZ-1)
+ ! * (NEX_XI/ratio_divide_central_cube)*(NGLLZ-1)
!endif
-
+
write(27,*) nspec1
write(27,*) nglob1
close(27)
@@ -394,7 +394,7 @@
write(27) rhostore*scaleval2
close(27)
endif
-
+
end subroutine save_arrays_solver
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/save_forward_arrays.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/save_forward_arrays.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/save_forward_arrays.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -34,12 +34,12 @@
epsilondev_crust_mantle,epsilondev_inner_core, &
A_array_rotation,B_array_rotation, &
LOCAL_PATH)
-
+
implicit none
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
-
+
integer myrank
integer SIMULATION_TYPE
@@ -68,9 +68,9 @@
character(len=150) LOCAL_PATH
! local parameters
- character(len=150) outputname
+ character(len=150) outputname
-
+
! save files to local disk or tape system if restart file
if(NUMBER_OF_RUNS > 1 .and. NUMBER_OF_THIS_RUN < NUMBER_OF_RUNS) then
write(outputname,"('dump_all_arrays',i6.6)") myrank
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/save_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/save_header_file.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/save_header_file.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -487,7 +487,7 @@
if( NGLLX == 5 .and. NGLLY == 5 .and. NGLLZ == 5 ) then
write(IOUT,*) 'logical, parameter :: USE_DEVILLE_VAL = .true.'
else
- write(IOUT,*) 'logical, parameter :: USE_DEVILLE_VAL = .false.'
+ write(IOUT,*) 'logical, parameter :: USE_DEVILLE_VAL = .false.'
endif
close(IOUT)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/save_kernels.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/save_kernels.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/save_kernels.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -25,10 +25,10 @@
!
!=====================================================================
-
+
subroutine save_kernels_crust_mantle(myrank,scale_t,scale_displ, &
cijkl_kl_crust_mantle,rho_kl_crust_mantle, &
- alpha_kl_crust_mantle,beta_kl_crust_mantle, &
+ alpha_kl_crust_mantle,beta_kl_crust_mantle, &
ystore_crust_mantle,zstore_crust_mantle, &
rhostore_crust_mantle,muvstore_crust_mantle, &
kappavstore_crust_mantle,ibool_crust_mantle, &
@@ -40,7 +40,7 @@
include "OUTPUT_FILES/values_from_mesher.h"
integer myrank
-
+
double precision :: scale_t,scale_displ
real(kind=CUSTOM_REAL), dimension(21,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
@@ -54,7 +54,7 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPECMAX_ISO_MANTLE) :: &
rhostore_crust_mantle,kappavstore_crust_mantle,muvstore_crust_mantle
-
+
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
character(len=150) LOCAL_PATH
@@ -62,13 +62,13 @@
! local parameters
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: &
mu_kl_crust_mantle, kappa_kl_crust_mantle, rhonotprime_kl_crust_mantle
- real(kind=CUSTOM_REAL),dimension(21) :: cijkl_kl_local
+ real(kind=CUSTOM_REAL),dimension(21) :: cijkl_kl_local
real(kind=CUSTOM_REAL) :: scale_kl,scale_kl_ani,scale_kl_rho
real(kind=CUSTOM_REAL) :: rhol,mul,kappal,rho_kl,alpha_kl,beta_kl
integer :: ispec,i,j,k,iglob
character(len=150) prname
-
+
scale_kl = scale_t/scale_displ * 1.d9
! For anisotropic kernels
! final unit : [s km^(-3) GPa^(-1)]
@@ -92,7 +92,7 @@
! ystore and zstore are thetaval and phival (line 2252) -- dangerous
call rotate_kernels_dble(cijkl_kl_crust_mantle(:,i,j,k,ispec),cijkl_kl_local, &
ystore_crust_mantle(iglob),zstore_crust_mantle(iglob))
-
+
cijkl_kl_crust_mantle(:,i,j,k,ispec) = cijkl_kl_local * scale_kl_ani
rho_kl_crust_mantle(i,j,k,ispec) = rho_kl_crust_mantle(i,j,k,ispec) * scale_kl_rho
@@ -101,7 +101,7 @@
rhol = rhostore_crust_mantle(i,j,k,ispec)
mul = muvstore_crust_mantle(i,j,k,ispec)
kappal = kappavstore_crust_mantle(i,j,k,ispec)
-
+
! kernel values for rho, kappa, mu
rho_kl = - rhol * rho_kl_crust_mantle(i,j,k,ispec)
alpha_kl = - kappal * alpha_kl_crust_mantle(i,j,k,ispec)
@@ -110,7 +110,7 @@
rhonotprime_kl_crust_mantle(i,j,k,ispec) = rho_kl * scale_kl
mu_kl_crust_mantle(i,j,k,ispec) = beta_kl * scale_kl
kappa_kl_crust_mantle(i,j,k,ispec) = alpha_kl * scale_kl
-
+
! kernels rho^prime, beta, alpha
rho_kl_crust_mantle(i,j,k,ispec) = (rho_kl + alpha_kl + beta_kl) * scale_kl
beta_kl_crust_mantle(i,j,k,ispec) = 2 * (beta_kl - FOUR_THIRDS * mul * alpha_kl / kappal) * scale_kl
@@ -160,26 +160,26 @@
endif
-
+
end subroutine save_kernels_crust_mantle
-!
+!
!-------------------------------------------------------------------------------------------------
-!
-
+!
+
subroutine save_kernels_outer_core(myrank,scale_t,scale_displ, &
rho_kl_outer_core,alpha_kl_outer_core, &
rhostore_outer_core,kappavstore_outer_core, &
deviatoric_outercore,nspec_beta_kl_outer_core,beta_kl_outer_core, &
LOCAL_PATH)
-
+
implicit none
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
integer myrank
-
+
double precision :: scale_t,scale_displ
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: &
@@ -197,10 +197,10 @@
! local parameters
real(kind=CUSTOM_REAL):: scale_kl
- real(kind=CUSTOM_REAL) :: rhol,kappal,rho_kl,alpha_kl,beta_kl
+ real(kind=CUSTOM_REAL) :: rhol,kappal,rho_kl,alpha_kl,beta_kl
integer :: ispec,i,j,k
character(len=150) prname
-
+
scale_kl = scale_t/scale_displ * 1.d9
! outer_core
@@ -212,17 +212,17 @@
kappal = kappavstore_outer_core(i,j,k,ispec)
rho_kl = - rhol * rho_kl_outer_core(i,j,k,ispec)
alpha_kl = - kappal * alpha_kl_outer_core(i,j,k,ispec)
-
+
rho_kl_outer_core(i,j,k,ispec) = (rho_kl + alpha_kl) * scale_kl
alpha_kl_outer_core(i,j,k,ispec) = 2 * alpha_kl * scale_kl
-
-
+
+
!deviatoric kernel check
if( deviatoric_outercore ) then
beta_kl = - 2 * beta_kl_outer_core(i,j,k,ispec) ! not using mul, since it's zero for the fluid
beta_kl_outer_core(i,j,k,ispec) = beta_kl
endif
-
+
enddo
enddo
enddo
@@ -240,15 +240,15 @@
if( deviatoric_outercore ) then
open(unit=27,file=trim(prname)//'mu_kernel.bin',status='unknown',form='unformatted',action='write')
write(27) beta_kl_outer_core
- close(27)
+ close(27)
endif
-
+
end subroutine save_kernels_outer_core
-
-!
+
+!
!-------------------------------------------------------------------------------------------------
-!
-
+!
+
subroutine save_kernels_inner_core(myrank,scale_t,scale_displ, &
rho_kl_inner_core,beta_kl_inner_core,alpha_kl_inner_core, &
rhostore_inner_core,muvstore_inner_core,kappavstore_inner_core, &
@@ -259,9 +259,9 @@
include "OUTPUT_FILES/values_from_mesher.h"
integer myrank
-
+
double precision :: scale_t,scale_displ
-
+
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: &
rho_kl_inner_core, beta_kl_inner_core, alpha_kl_inner_core
@@ -272,11 +272,11 @@
! local parameters
real(kind=CUSTOM_REAL):: scale_kl
- real(kind=CUSTOM_REAL) :: rhol,mul,kappal,rho_kl,alpha_kl,beta_kl
+ real(kind=CUSTOM_REAL) :: rhol,mul,kappal,rho_kl,alpha_kl,beta_kl
integer :: ispec,i,j,k
character(len=150) prname
-
+
scale_kl = scale_t/scale_displ * 1.d9
! inner_core
@@ -287,11 +287,11 @@
rhol = rhostore_inner_core(i,j,k,ispec)
mul = muvstore_inner_core(i,j,k,ispec)
kappal = kappavstore_inner_core(i,j,k,ispec)
-
+
rho_kl = -rhol * rho_kl_inner_core(i,j,k,ispec)
alpha_kl = -kappal * alpha_kl_inner_core(i,j,k,ispec)
beta_kl = - 2 * mul * beta_kl_inner_core(i,j,k,ispec)
-
+
rho_kl_inner_core(i,j,k,ispec) = (rho_kl + alpha_kl + beta_kl) * scale_kl
beta_kl_inner_core(i,j,k,ispec) = 2 * (beta_kl - FOUR_THIRDS * mul * alpha_kl / kappal) * scale_kl
alpha_kl_inner_core(i,j,k,ispec) = 2 * (1 + FOUR_THIRDS * mul / kappal) * alpha_kl * scale_kl
@@ -310,13 +310,13 @@
open(unit=27,file=trim(prname)//'beta_kernel.bin',status='unknown',form='unformatted',action='write')
write(27) beta_kl_inner_core
close(27)
-
+
end subroutine save_kernels_inner_core
-!
+!
!-------------------------------------------------------------------------------------------------
-!
-
+!
+
subroutine save_kernels_boundary_kl(myrank,scale_t,scale_displ, &
moho_kl,d400_kl,d670_kl,cmb_kl,icb_kl, &
LOCAL_PATH,HONOR_1D_SPHERICAL_MOHO)
@@ -327,7 +327,7 @@
include "OUTPUT_FILES/values_from_mesher.h"
integer myrank
-
+
double precision :: scale_t,scale_displ
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_MOHO) :: moho_kl
@@ -339,7 +339,7 @@
character(len=150) LOCAL_PATH
logical HONOR_1D_SPHERICAL_MOHO
-
+
! local parameters
real(kind=CUSTOM_REAL):: scale_kl
character(len=150) prname
@@ -356,39 +356,39 @@
icb_kl = icb_kl * scale_kl * 1.d3
call create_name_database(prname,myrank,IREGION_CRUST_MANTLE,LOCAL_PATH)
-
+
if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
open(unit=27,file=trim(prname)//'moho_kernel.bin',status='unknown',form='unformatted',action='write')
write(27) moho_kl
close(27)
endif
-
+
open(unit=27,file=trim(prname)//'d400_kernel.bin',status='unknown',form='unformatted',action='write')
write(27) d400_kl
close(27)
-
+
open(unit=27,file=trim(prname)//'d670_kernel.bin',status='unknown',form='unformatted',action='write')
write(27) d670_kl
close(27)
-
+
open(unit=27,file=trim(prname)//'CMB_kernel.bin',status='unknown',form='unformatted',action='write')
write(27) cmb_kl
close(27)
-
+
call create_name_database(prname,myrank,IREGION_OUTER_CORE,LOCAL_PATH)
-
+
open(unit=27,file=trim(prname)//'ICB_kernel.bin',status='unknown',form='unformatted',action='write')
write(27) icb_kl
close(27)
-
+
end subroutine save_kernels_boundary_kl
-
-!
+
+!
!-------------------------------------------------------------------------------------------------
-!
-
+!
+
subroutine save_kernels_source_derivatives(nrec_local,NSOURCES,scale_displ,scale_t, &
nu_source,moment_der,sloc_der,number_receiver_global)
@@ -404,7 +404,7 @@
real(kind=CUSTOM_REAL) :: moment_der(NDIM,NDIM,nrec_local),sloc_der(NDIM,nrec_local)
integer, dimension(nrec_local) :: number_receiver_global
-
+
! local parameters
real(kind=CUSTOM_REAL),parameter :: scale_mass = RHOAV * (R_EARTH**3)
integer :: irec_local
@@ -416,7 +416,7 @@
! rotate and scale the location derivatives to correspond to dn,de,dz
sloc_der(:,irec_local) = matmul(nu_source(:,:,irec_local),sloc_der(:,irec_local)) &
* scale_displ * scale_t
-
+
! rotate scale the moment derivatives to correspond to M[n,e,z][n,e,z]
moment_der(:,:,irec_local) = matmul(matmul(nu_source(:,:,irec_local),moment_der(:,:,irec_local)),&
transpose(nu_source(:,:,irec_local))) * scale_t ** 3 / scale_mass
@@ -448,4 +448,4 @@
end subroutine save_kernels_source_derivatives
-
\ No newline at end of file
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/setup_sources_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/setup_sources_receivers.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/setup_sources_receivers.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -39,16 +39,16 @@
nrec_local,nadj_rec_local,nrec_simulation, &
SIMULATION_TYPE,RECEIVERS_CAN_BE_BURIED,MOVIE_SURFACE,MOVIE_VOLUME, &
HDUR_MOVIE,OUTPUT_FILES)
-
-
+
+
implicit none
-
+
include 'mpif.h'
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
integer NSOURCES,myrank
-
+
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: ibool_crust_mantle
real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
@@ -58,7 +58,7 @@
double precision, dimension(NGLLZ) :: zigll
logical TOPOGRAPHY
-
+
double precision sec,DT,t0
double precision, dimension(NSOURCES) :: t_cmt,hdur,hdur_gaussian
@@ -68,21 +68,21 @@
integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
integer NSTEP
-
+
! for ellipticity
integer nspl
double precision rspl(NR),espl(NR),espl2(NR)
-
+
integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
integer NEX_XI
logical PRINT_SOURCE_TIME_FUNCTION
character(len=150) rec_filename
-
+
integer nrec
integer, dimension(nrec) :: islice_selected_rec,ispec_selected_rec
-
+
double precision, dimension(nrec) :: xi_receiver,eta_receiver,gamma_receiver
character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
@@ -93,13 +93,13 @@
integer nrec_local,nadj_rec_local,nrec_simulation
integer SIMULATION_TYPE
-
+
logical RECEIVERS_CAN_BE_BURIED,MOVIE_SURFACE,MOVIE_VOLUME
-
+
double precision HDUR_MOVIE
-
+
character(len=150) OUTPUT_FILES
-
+
! local parameters
double precision :: junk
integer :: yr,jda,ho,mi
@@ -107,8 +107,8 @@
integer :: icomp,itime,nadj_files_found,nadj_files_found_tot
character(len=3),dimension(NDIM) :: comp = (/ "LHN", "LHE", "LHZ" /)
character(len=150) :: filename,adj_source_file,system_command,filename_new
-
-! sources
+
+! sources
! BS BS moved open statement and writing of first lines into sr.vtk before the
! call to locate_sources, where further write statements to that file follow
if(myrank == 0) then
@@ -151,7 +151,7 @@
t0 = - 1.5d0*minval(t_cmt-hdur)
-! receivers
+! receivers
if(myrank == 0) then
write(IMAIN,*)
if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
@@ -199,7 +199,7 @@
! adjoint receiver station in this process slice
if(islice_selected_rec(irec) < 0 .or. islice_selected_rec(irec) > NPROCTOT_VAL-1) &
call exit_MPI(myrank,'something is wrong with the source slice number in adjoint simulation')
-
+
! updates counter
nadj_rec_local = nadj_rec_local + 1
@@ -211,7 +211,7 @@
if( ier == 0 ) then
! checks length of file
itime = 0
- do while(ier == 0)
+ do while(ier == 0)
read(IIN,*,iostat=ier) junk,junk
if( ier == 0 ) itime = itime + 1
enddo
@@ -221,8 +221,8 @@
nadj_files_found = nadj_files_found + 1
endif
close(IIN)
- enddo
- endif
+ enddo
+ endif
enddo
! checks if any adjoint source files found at all
call MPI_REDUCE(nadj_files_found,nadj_files_found_tot,1,MPI_INTEGER,MPI_SUM,0,MPI_COMM_WORLD,ier)
@@ -255,11 +255,11 @@
! we should know NSOURCES+nrec at this point...
write(filename,*) trim(OUTPUT_FILES)//'/sr_tmp.vtk'
- write(filename_new,*) trim(OUTPUT_FILES)//'/sr.vtk'
+ write(filename_new,*) trim(OUTPUT_FILES)//'/sr.vtk'
write(system_command,"('sed -e ',a1,'s/POINTS.*/POINTS',i6,' float/',a1,' < ',a,' > ',a)") &
"'",NSOURCES + nrec,"'",trim(filename),trim(filename_new)
call system(system_command)
-
+
write(IMAIN,*)
write(IMAIN,*) 'Total number of samples for seismograms = ',NSTEP
write(IMAIN,*)
@@ -269,7 +269,7 @@
endif
end subroutine setup_sources_receivers
-
+
!
!-------------------------------------------------------------------------------------------------
!
@@ -283,9 +283,9 @@
etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
xigll,yigll,zigll,sourcearrays)
-
+
implicit none
-
+
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
@@ -305,12 +305,12 @@
double precision, dimension(NGLLZ) :: zigll
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ,NSOURCES) :: sourcearrays
-
-
+
+
! local parameters
integer :: isource
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
-
+
do isource = 1,NSOURCES
! check that the source slice number is okay
@@ -333,8 +333,8 @@
enddo
end subroutine setup_sources_receivers_srcarr
-
+
!
!-------------------------------------------------------------------------------------------------
!
@@ -343,9 +343,9 @@
subroutine setup_sources_receivers_adjindx(NSTEP,NSTEP_SUB_ADJ, &
NTSTEP_BETWEEN_READ_ADJSRC, &
iadjsrc,iadjsrc_len,iadj_vec)
-
+
implicit none
-
+
include "constants.h"
integer NSTEP,NSTEP_SUB_ADJ,NTSTEP_BETWEEN_READ_ADJSRC
@@ -353,8 +353,8 @@
integer, dimension(NSTEP_SUB_ADJ,2) :: iadjsrc ! to read input in chunks
integer, dimension(NSTEP_SUB_ADJ) :: iadjsrc_len
integer, dimension(NSTEP) :: iadj_vec
-
-
+
+
! local parameters
integer :: iadj_block,it,it_sub_adj
@@ -364,11 +364,11 @@
iadjsrc_len(:) = 0
! setting up chunks of NTSTEP_BETWEEN_READ_ADJSRC to read adjoint source traces
- ! i.e. as an example: total length NSTEP = 3000, chunk length NTSTEP_BETWEEN_READ_ADJSRC= 1000
- ! then it will set first block from 2001 to 3000,
+ ! i.e. as an example: total length NSTEP = 3000, chunk length NTSTEP_BETWEEN_READ_ADJSRC= 1000
+ ! then it will set first block from 2001 to 3000,
! second block from 1001 to 2000 and so on...
!
- ! see routine: compute_arrays_source_adjoint()
+ ! see routine: compute_arrays_source_adjoint()
! how we read in the adjoint source trace in blocks/chunk sizes
!
! see routine: compute_add_sources_adjoint()
@@ -377,23 +377,23 @@
! block number
! e.g. increases from 1 (case it=1-1000), 2 (case it=1001-2000) to 3 (case it=2001-3000)
- it_sub_adj = ceiling( dble(it)/dble(NTSTEP_BETWEEN_READ_ADJSRC) )
+ it_sub_adj = ceiling( dble(it)/dble(NTSTEP_BETWEEN_READ_ADJSRC) )
! we are at the edge of a block
- if(mod(it-1,NTSTEP_BETWEEN_READ_ADJSRC) == 0) then
- ! block start time ( e.g. 2001)
+ if(mod(it-1,NTSTEP_BETWEEN_READ_ADJSRC) == 0) then
+ ! block start time ( e.g. 2001)
iadjsrc(iadj_block,1) = NSTEP-it_sub_adj*NTSTEP_BETWEEN_READ_ADJSRC+1
! block end time (e.g. 3000)
iadjsrc(iadj_block,2) = NSTEP-(it_sub_adj-1)*NTSTEP_BETWEEN_READ_ADJSRC
-
- ! final adj src array
- ! e.g. will be from 1000 to 1, but doesn't go below 1 in cases where NSTEP isn't
+
+ ! final adj src array
+ ! e.g. will be from 1000 to 1, but doesn't go below 1 in cases where NSTEP isn't
! a multiple of NTSTEP_BETWEEN_READ_ADJSRC
- if(iadjsrc(iadj_block,1) < 0) iadjsrc(iadj_block,1) = 1
-
+ if(iadjsrc(iadj_block,1) < 0) iadjsrc(iadj_block,1) = 1
+
! actual block length
iadjsrc_len(iadj_block) = iadjsrc(iadj_block,2)-iadjsrc(iadj_block,1)+1
-
+
! increases block number
iadj_block = iadj_block+1
endif
@@ -425,15 +425,15 @@
xi_receiver,eta_receiver,gamma_receiver, &
hxir_store,hetar_store,hgammar_store, &
nadj_hprec_local,hpxir_store,hpetar_store,hpgammar_store)
-
+
implicit none
-
+
include "constants.h"
integer NSOURCES,myrank
integer, dimension(NSOURCES) :: islice_selected_source
-
+
double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
double precision, dimension(NGLLX) :: xigll
double precision, dimension(NGLLY) :: yigll
@@ -443,7 +443,7 @@
integer SIMULATION_TYPE
integer nrec,nrec_local
- integer, dimension(nrec) :: islice_selected_rec
+ integer, dimension(nrec) :: islice_selected_rec
integer, dimension(nrec_local) :: number_receiver_global
double precision, dimension(nrec) :: xi_receiver,eta_receiver,gamma_receiver
@@ -455,15 +455,15 @@
double precision, dimension(nadj_hprec_local,NGLLX) :: hpxir_store
double precision, dimension(nadj_hprec_local,NGLLY) :: hpetar_store
double precision, dimension(nadj_hprec_local,NGLLZ) :: hpgammar_store
-
-
+
+
! local parameters
integer :: isource,irec,irec_local
double precision, dimension(NGLLX) :: hxir,hpxir
double precision, dimension(NGLLY) :: hpetar,hetar
double precision, dimension(NGLLZ) :: hgammar,hpgammar
-
+
! select local receivers
! define local to global receiver numbering mapping
@@ -511,4 +511,4 @@
endif
end subroutine setup_sources_receivers_intp
-
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/specfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/specfem3D.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/specfem3D.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -191,7 +191,7 @@
! ---------------------
!
! v. 5.0 aka Tiger, many developers some with Princeton Tiger logo on their shirts, February 2010:
-! new moho mesh stretching honoring crust2.0 moho depths,
+! new moho mesh stretching honoring crust2.0 moho depths,
! new attenuation assignment, new SAC headers, new general crustal models,
! faster performance due to Deville routines and enhanced loop unrolling,
! slight changes in code structure (see also trivia at program start)
@@ -307,7 +307,7 @@
integer nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core
! to save movie frames
- integer nmovie_points,NIT
+ integer nmovie_points,NIT
real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
store_val_x,store_val_y,store_val_z, &
store_val_ux,store_val_uy,store_val_uz
@@ -512,7 +512,7 @@
! Newmark time scheme parameters and non-dimensionalization
real(kind=CUSTOM_REAL) time,deltat,deltatover2,deltatsqover2
- double precision scale_t,scale_t_inv,scale_displ,scale_veloc
+ double precision scale_t,scale_t_inv,scale_displ,scale_veloc
! ADJOINT
real(kind=CUSTOM_REAL) b_deltat,b_deltatover2,b_deltatsqover2
@@ -527,18 +527,18 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: b_div_displ_outer_core
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: rho_kl_crust_mantle, &
- beta_kl_crust_mantle, alpha_kl_crust_mantle
+ beta_kl_crust_mantle, alpha_kl_crust_mantle
! For anisotropic kernels (see compute_kernels.f90 for a definition of the array)
real(kind=CUSTOM_REAL), dimension(21,NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE_ADJOINT) :: cijkl_kl_crust_mantle
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: rho_kl_outer_core, &
alpha_kl_outer_core
-
- ! check for deviatoric kernel for outer core region
- real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: beta_kl_outer_core
+
+ ! check for deviatoric kernel for outer core region
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: beta_kl_outer_core
integer :: nspec_beta_kl_outer_core
logical,parameter:: deviatoric_outercore = .false.
-
+
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE_ADJOINT) :: rho_kl_inner_core, &
beta_kl_inner_core, alpha_kl_inner_core
@@ -550,10 +550,10 @@
absorb_zmin_outer_core
integer nabs_xmin_cm,nabs_xmax_cm,nabs_ymin_cm,nabs_ymax_cm
integer nabs_xmin_oc,nabs_xmax_oc,nabs_ymin_oc,nabs_ymax_oc,nabs_zmin_oc
-
+
integer reclen_xmin_crust_mantle, reclen_xmax_crust_mantle, reclen_ymin_crust_mantle, &
reclen_ymax_crust_mantle, reclen_xmin_outer_core, reclen_xmax_outer_core,&
- reclen_ymin_outer_core, reclen_ymax_outer_core, reclen_zmin
+ reclen_ymin_outer_core, reclen_ymax_outer_core, reclen_zmin
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_OUTER_CORE) :: vector_accel_outer_core,&
vector_displ_outer_core, b_vector_displ_outer_core
@@ -563,11 +563,11 @@
integer npoin2D_faces_inner_core(NUMFACES_SHARED)
! parameters for the source
- integer it
+ integer it
integer, dimension(:), allocatable :: islice_selected_source,ispec_selected_source
real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: sourcearrays
double precision, dimension(:,:,:) ,allocatable:: nu_source
- double precision sec
+ double precision sec
double precision, dimension(:), allocatable :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
double precision, dimension(:), allocatable :: xi_source,eta_source,gamma_source
double precision, dimension(:), allocatable :: t_cmt,hdur,hdur_gaussian
@@ -579,7 +579,7 @@
integer nrec,nrec_local
integer, dimension(:), allocatable :: islice_selected_rec,ispec_selected_rec,number_receiver_global
double precision, dimension(:), allocatable :: xi_receiver,eta_receiver,gamma_receiver
- character(len=150) :: STATIONS,rec_filename
+ character(len=150) :: STATIONS,rec_filename
double precision, dimension(:,:,:), allocatable :: nu
double precision, allocatable, dimension(:) :: stlat,stlon,stele,stbur
character(len=MAX_LENGTH_STATION_NAME), dimension(:), allocatable :: station_name
@@ -670,14 +670,14 @@
integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_outer_core,npoin2D_eta_outer_core
integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_inner_core,npoin2D_eta_inner_core
- integer ichunk,iproc_xi,iproc_eta
-
+ integer ichunk,iproc_xi,iproc_eta
+
!ADJOINT
real(kind=CUSTOM_REAL) b_two_omega_earth
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ROT_ADJOINT) :: &
b_A_array_rotation,b_B_array_rotation
- double precision :: time_start
+ double precision :: time_start
! parameters read from parameter file
integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
@@ -693,7 +693,7 @@
RMOHO,R80,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH
-
+
logical 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, &
@@ -701,7 +701,7 @@
ROTATE_SEISMOGRAMS_RT,HONOR_1D_SPHERICAL_MOHO,WRITE_SEISMOGRAMS_BY_MASTER,&
SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
- character(len=150) OUTPUT_FILES,LOCAL_PATH
+ character(len=150) OUTPUT_FILES,LOCAL_PATH
logical COMPUTE_AND_STORE_STRAIN
@@ -711,13 +711,13 @@
double precision t_cmt_SAC,t_shift_SAC,elat_SAC,elon_SAC,depth_SAC, &
cmt_lat_SAC,cmt_lon_SAC,cmt_depth_SAC,cmt_hdur_SAC,sec_SAC
character(len=20) event_name_SAC
-
+
! this for all the regions
integer, dimension(MAX_NUM_REGIONS) :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
NSPEC2D_BOTTOM,NSPEC2D_TOP, &
NGLOB1D_RADIAL, &
NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
-
+
character(len=150) prname
! lookup table every km for gravity
@@ -736,7 +736,7 @@
double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
! Boundary Mesh and Kernels
- integer k_top,k_bot,iregion_code
+ integer k_top,k_bot,iregion_code
integer, dimension(NSPEC2D_MOHO) :: ibelm_moho_top,ibelm_moho_bot
integer, dimension(NSPEC2D_400) :: ibelm_400_top,ibelm_400_bot
integer, dimension(NSPEC2D_670) :: ibelm_670_top,ibelm_670_bot
@@ -750,7 +750,7 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_ICB) :: icb_kl, icb_kl_top, icb_kl_bot
logical :: fluid_solid_boundary
- integer i,ier
+ integer i,ier
! if running on MareNostrum in Barcelona
character(len=400) system_command
@@ -778,26 +778,26 @@
!
! when calling a function, additional storage will be allocated for the variables in that function.
! that storage will be allocated in the heap memory segment.
-!
+!
! most routine calls here will have rather long argument lists, probably because of this performance criteria.
! using modules/common data blocks together with dynamic allocation will put data into heap memory,
! thus it has longer latency to access variables than stack memory variables.
!
-! however, declaring the static arrays needed in compute_forces_crust_mantle_Dev()
+! however, declaring the static arrays needed in compute_forces_crust_mantle_Dev()
! like e.g. sum_terms, tempx1,...B1_m1_m2_5points,... in this main routine and
! passing them along as arguments to the routine makes the code slower.
! it seems that this stack/heap criterion is more complicated.
-!
+!
! another reason why modules are avoided, is to make the code thread safe.
! having different threads access the same data structure and modifying it at the same time
! would lead to problems. passing arguments is a way to avoid such complications.
!
-! nevertheless, it would be nice to test - where possible - , if using modules
+! nevertheless, it would be nice to test - where possible - , if using modules
! together with static arrays would perform as well as this.
! at least, it would make the code more elegant and less error prone...
!
! note 2: in general, most of the computation time for our earthquake simulations is spent
-! inside the time loop (mainly the compute_forces_crust_mantle_Dev() routine).
+! inside the time loop (mainly the compute_forces_crust_mantle_Dev() routine).
! any code performance tuning will be most effective in there.
!
! note 3: fortran is a code language that uses column-first ordering for arrays,
@@ -808,7 +808,7 @@
! note 4: Deville routines help compilers to better vectorize the do-loops and
! for most compilers, will result in a significant speedup ( > 30%).
!
-! note 5: one common technique in computational science to help compilers
+! note 5: one common technique in computational science to help compilers
! enhance pipelining is loop unrolling. we do attempt this here in a very simple
! and straigthforward way. so don't be confused about the somewhat
! bewildering do-loop writing...
@@ -858,7 +858,7 @@
hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,hprimewgll_xxT, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
rec_filename,STATIONS,nrec)
-
+
!
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
@@ -914,7 +914,7 @@
iboolcorner_outer_core, &
iboolleft_xi_inner_core,iboolright_xi_inner_core, &
iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
+ npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
iboolfaces_inner_core,npoin2D_faces_inner_core, &
iboolcorner_inner_core, &
iprocfrom_faces,iprocto_faces,imsg_type, &
@@ -944,88 +944,88 @@
jacobian2D_xmin_outer_core,jacobian2D_xmax_outer_core,jacobian2D_ymin_outer_core, &
jacobian2D_ymax_outer_core,jacobian2D_bottom_outer_core,jacobian2D_top_outer_core, &
nspec2D_xmin_inner_core,nspec2D_xmax_inner_core, &
- nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
+ nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
ibelm_xmin_inner_core,ibelm_xmax_inner_core,ibelm_ymin_inner_core, &
ibelm_ymax_inner_core,ibelm_bottom_inner_core,ibelm_top_inner_core, &
ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot, &
ibelm_670_top,ibelm_670_bot,normal_moho,normal_400,normal_670, &
k_top,k_bot,moho_kl,d400_kl,d670_kl,cmb_kl,icb_kl, &
LOCAL_PATH,SIMULATION_TYPE)
-
+
! absorbing boundaries
if(ABSORBING_CONDITIONS) then
! crust_mantle
if (nspec2D_xmin_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
.or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
nabs_xmin_cm = nspec2D_xmin_crust_mantle
- else
+ else
nabs_xmin_cm = 1
- endif
+ endif
allocate(absorb_xmin_crust_mantle(NDIM,NGLLY,NGLLZ,nabs_xmin_cm))
if (nspec2D_xmax_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
.or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
nabs_xmax_cm = nspec2D_xmax_crust_mantle
- else
+ else
nabs_xmax_cm = 1
- endif
+ endif
allocate(absorb_xmax_crust_mantle(NDIM,NGLLY,NGLLZ,nabs_xmax_cm))
if (nspec2D_ymin_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
.or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
nabs_ymin_cm = nspec2D_ymin_crust_mantle
- else
+ else
nabs_ymin_cm = 1
- endif
+ endif
allocate(absorb_ymin_crust_mantle(NDIM,NGLLX,NGLLZ,nabs_ymin_cm))
if (nspec2D_ymax_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
.or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
nabs_ymax_cm = nspec2D_ymax_crust_mantle
- else
+ else
nabs_ymax_cm = 1
- endif
+ endif
allocate(absorb_ymax_crust_mantle(NDIM,NGLLX,NGLLZ,nabs_ymax_cm))
! outer_core
if (nspec2D_xmin_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
.or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
nabs_xmin_oc = nspec2D_xmin_outer_core
- else
+ else
nabs_xmin_oc = 1
- endif
+ endif
allocate(absorb_xmin_outer_core(NGLLY,NGLLZ,nabs_xmin_oc))
if (nspec2D_xmax_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
.or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
nabs_xmax_oc = nspec2D_xmax_outer_core
- else
+ else
nabs_xmax_oc = 1
- endif
+ endif
allocate(absorb_xmax_outer_core(NGLLY,NGLLZ,nabs_xmax_oc))
if (nspec2D_ymin_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
.or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
nabs_ymin_oc = nspec2D_ymin_outer_core
- else
+ else
nabs_ymin_oc = 1
- endif
+ endif
allocate(absorb_ymin_outer_core(NGLLX,NGLLZ,nabs_ymin_oc))
if (nspec2D_ymax_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
.or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
nabs_ymax_oc = nspec2D_ymax_outer_core
- else
+ else
nabs_ymax_oc = 1
- endif
+ endif
allocate(absorb_ymax_outer_core(NGLLX,NGLLZ,nabs_ymax_oc))
if (NSPEC2D_BOTTOM(IREGION_OUTER_CORE) > 0 .and. &
(SIMULATION_TYPE == 3 .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
nabs_zmin_oc = NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
- else
+ else
nabs_zmin_oc = 1
- endif
+ endif
allocate(absorb_zmin_outer_core(NGLLX,NGLLY,nabs_zmin_oc))
! read arrays for Stacey conditions
@@ -1044,9 +1044,9 @@
reclen_ymin_outer_core,reclen_ymax_outer_core, &
reclen_zmin,NSPEC2D_BOTTOM, &
SIMULATION_TYPE,SAVE_FORWARD,LOCAL_PATH)
-
+
endif
-
+
!
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
@@ -1118,10 +1118,10 @@
xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
etax_crust_mantle,etay_crust_mantle,etaz_crust_mantle, &
gammax_crust_mantle,gammay_crust_mantle,gammaz_crust_mantle, &
- xigll,yigll,zigll,sourcearrays)
- endif
-
-
+ xigll,yigll,zigll,sourcearrays)
+ endif
+
+
if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
NSTEP_SUB_ADJ = ceiling( dble(NSTEP)/dble(NTSTEP_BETWEEN_READ_ADJSRC) )
allocate(iadj_vec(NSTEP))
@@ -1129,19 +1129,19 @@
do it=1,NSTEP
iadj_vec(it) = NSTEP-it+1 ! default is for reversing entire record
enddo
-
+
if(nadj_rec_local > 0) then
! allocate adjoint source arrays
allocate(adj_sourcearrays(NDIM,NGLLX,NGLLY,NGLLZ,nadj_rec_local,NTSTEP_BETWEEN_READ_ADJSRC))
- adj_sourcearrays = 0._CUSTOM_REAL
-
+ adj_sourcearrays = 0._CUSTOM_REAL
+
! allocate indexing arrays
allocate(iadjsrc(NSTEP_SUB_ADJ,2))
allocate(iadjsrc_len(NSTEP_SUB_ADJ))
! initializes iadjsrc, iadjsrc_len and iadj_vec
call setup_sources_receivers_adjindx(NSTEP,NSTEP_SUB_ADJ, &
NTSTEP_BETWEEN_READ_ADJSRC, &
- iadjsrc,iadjsrc_len,iadj_vec)
+ iadjsrc,iadjsrc_len,iadj_vec)
endif
endif
@@ -1158,7 +1158,7 @@
nadj_hprec_local = nrec_local
else
nadj_hprec_local = 1
- endif
+ endif
allocate(hpxir_store(nadj_hprec_local,NGLLX))
allocate(hpetar_store(nadj_hprec_local,NGLLY))
allocate(hpgammar_store(nadj_hprec_local,NGLLZ))
@@ -1172,7 +1172,7 @@
islice_selected_rec,number_receiver_global, &
xi_receiver,eta_receiver,gamma_receiver, &
hxir_store,hetar_store,hgammar_store, &
- nadj_hprec_local,hpxir_store,hpetar_store,hpgammar_store)
+ nadj_hprec_local,hpxir_store,hpetar_store,hpgammar_store)
! allocate seismogram array
if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
@@ -1184,11 +1184,11 @@
! allocate Frechet derivatives array
allocate(moment_der(NDIM,NDIM,nrec_local),sloc_der(NDIM,nrec_local))
moment_der = 0._CUSTOM_REAL
- sloc_der = 0._CUSTOM_REAL
+ sloc_der = 0._CUSTOM_REAL
endif
! initialize seismograms
seismograms(:,:,:) = 0._CUSTOM_REAL
- nit_written = 0
+ nit_written = 0
endif
! get information about event name and location for SAC seismograms
@@ -1314,7 +1314,7 @@
allocate(buffer_slices(npoin2D_cube_from_slices,NDIM))
allocate(buffer_slices2(npoin2D_cube_from_slices,NDIM))
allocate(ibool_central_cube(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices))
-
+
! handles the communications with the central cube if it was included in the mesh
call prepare_timerun_centralcube(myrank,rmass_inner_core, &
iproc_xi,iproc_eta,ichunk, &
@@ -1328,7 +1328,7 @@
nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube, &
npoin2D_cube_from_slices,receiver_cube_from_slices, &
sender_from_slices_to_cube,ibool_central_cube, &
- buffer_slices,buffer_slices2,buffer_all_cube_from_slices)
+ buffer_slices,buffer_slices2,buffer_all_cube_from_slices)
endif
! check that all the mass matrices are positive
@@ -1344,8 +1344,8 @@
rmass_crust_mantle = 1._CUSTOM_REAL / rmass_crust_mantle
rmass_outer_core = 1._CUSTOM_REAL / rmass_outer_core
rmass_inner_core = 1._CUSTOM_REAL / rmass_inner_core
-
+
! change x, y, z to r, theta and phi once and for all
! IMPROVE dangerous: old name kept (xstore ystore zstore) for new values
@@ -1409,7 +1409,7 @@
allocate(store_val_uy_all(nmovie_points,0:NPROCTOT_VAL-1))
allocate(store_val_uz_all(nmovie_points,0:NPROCTOT_VAL-1))
endif
-
+
! output point and element information for 3D movies
if(MOVIE_VOLUME) then
! the following has to be true for the the array dimensions of eps to match with those of xstore etc..
@@ -1426,7 +1426,7 @@
allocate(nu_3dmovie(3,3,npoints_3dmovie))
-
+
call write_movie_volume_mesh(npoints_3dmovie,prname,ibool_crust_mantle,xstore_crust_mantle, &
ystore_crust_mantle,zstore_crust_mantle, muvstore_crust_mantle_3dmovie, &
mask_3dmovie,mask_ibool_3dmovie,num_ibool_3dmovie,nu_3dmovie,MOVIE_COARSE)
@@ -1453,7 +1453,7 @@
call prepare_timerun_gravity(myrank, &
minus_g_cmb,minus_g_icb, &
minus_gravity_table,minus_deriv_gravity_table, &
- density_table,d_ln_density_dr_table,minus_rho_g_over_kappa_fluid, &
+ density_table,d_ln_density_dr_table,minus_rho_g_over_kappa_fluid, &
ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
@@ -1473,7 +1473,7 @@
c33store_inner_core,c44store_inner_core, &
alphaval,betaval,gammaval,b_alphaval,b_betaval,b_gammaval, &
deltat,b_deltat,LOCAL_PATH)
- endif
+ endif
! initialize arrays to zero
@@ -1524,7 +1524,7 @@
beta_kl_outer_core = 0._CUSTOM_REAL
endif
- ! initialize to be on the save side for adjoint runs SIMULATION_TYPE==2
+ ! initialize to be on the save side for adjoint runs SIMULATION_TYPE==2
eps_trace_over_3_crust_mantle(:,:,:,:) = 0._CUSTOM_REAL
epsilondev_crust_mantle(:,:,:,:,:) = 0._CUSTOM_REAL
eps_trace_over_3_inner_core(:,:,:,:) = 0._CUSTOM_REAL
@@ -1553,7 +1553,7 @@
endif
endif
- ! reads files back from local disk or MT tape system if restart file
+ ! reads files back from local disk or MT tape system if restart file
call read_forward_arrays(myrank,NSTEP, &
SIMULATION_TYPE,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN, &
it_begin,it_end, &
@@ -1568,7 +1568,7 @@
b_displ_outer_core,b_veloc_outer_core,b_accel_outer_core, &
b_R_memory_crust_mantle,b_R_memory_inner_core, &
b_epsilondev_crust_mantle,b_epsilondev_inner_core, &
- b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
+ b_A_array_rotation,b_B_array_rotation,LOCAL_PATH)
!
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
@@ -1644,9 +1644,9 @@
! way 2:
! One common technique in computational science to help enhance pipelining is loop unrolling
-!
+!
! we're accessing NDIM=3 components at each line,
-! that is, for an iteration, the register must contain
+! that is, for an iteration, the register must contain
! NDIM * displ_ + NDIM * veloc_ + NDIM * accel + deltat + deltatsq..
! in most cases a real (CUSTOM_REAL) value will have 4 bytes,
! assuming a default cache size of of about 128 bytes, we unroll here in steps of 3, thus 29 reals or 118 bytes,
@@ -1654,12 +1654,12 @@
do i = 1,mod(NGLOB_CRUST_MANTLE,3)
displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
+ deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
-
+
veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
+ deltatover2*accel_crust_mantle(:,i)
accel_crust_mantle(:,i) = 0._CUSTOM_REAL
- enddo
+ enddo
do i = mod(NGLOB_CRUST_MANTLE,3)+1,NGLOB_CRUST_MANTLE, 3 ! in steps of 3
displ_crust_mantle(:,i) = displ_crust_mantle(:,i) &
+ deltat*veloc_crust_mantle(:,i) + deltatsqover2*accel_crust_mantle(:,i)
@@ -1668,35 +1668,35 @@
displ_crust_mantle(:,i+2) = displ_crust_mantle(:,i+2) &
+ deltat*veloc_crust_mantle(:,i+2) + deltatsqover2*accel_crust_mantle(:,i+2)
-
+
veloc_crust_mantle(:,i) = veloc_crust_mantle(:,i) &
+ deltatover2*accel_crust_mantle(:,i)
veloc_crust_mantle(:,i+1) = veloc_crust_mantle(:,i+1) &
+ deltatover2*accel_crust_mantle(:,i+1)
veloc_crust_mantle(:,i+2) = veloc_crust_mantle(:,i+2) &
- + deltatover2*accel_crust_mantle(:,i+2)
-
+ + deltatover2*accel_crust_mantle(:,i+2)
+
! set acceleration to zero
! note: we do initialize acceleration in this loop since it is read already into the cache,
- ! otherwise it would have to be read in again for this explicitly,
+ ! otherwise it would have to be read in again for this explicitly,
! which would make this step more expensive
accel_crust_mantle(:,i) = 0._CUSTOM_REAL
accel_crust_mantle(:,i+1) = 0._CUSTOM_REAL
- accel_crust_mantle(:,i+2) = 0._CUSTOM_REAL
+ accel_crust_mantle(:,i+2) = 0._CUSTOM_REAL
enddo
-
+
! outer core
- do i = 1,mod(NGLOB_OUTER_CORE,4)
+ do i = 1,mod(NGLOB_OUTER_CORE,4)
displ_outer_core(i) = displ_outer_core(i) &
+ deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
-
+
veloc_outer_core(i) = veloc_outer_core(i) &
+ deltatover2*accel_outer_core(i)
-
- accel_outer_core(i) = 0._CUSTOM_REAL
- enddo
- do i = mod(NGLOB_OUTER_CORE,4)+1,NGLOB_OUTER_CORE, 4 ! in steps of 4
+
+ accel_outer_core(i) = 0._CUSTOM_REAL
+ enddo
+ do i = mod(NGLOB_OUTER_CORE,4)+1,NGLOB_OUTER_CORE, 4 ! in steps of 4
displ_outer_core(i) = displ_outer_core(i) &
+ deltat*veloc_outer_core(i) + deltatsqover2*accel_outer_core(i)
displ_outer_core(i+1) = displ_outer_core(i+1) &
@@ -1705,7 +1705,7 @@
+ deltat*veloc_outer_core(i+2) + deltatsqover2*accel_outer_core(i+2)
displ_outer_core(i+3) = displ_outer_core(i+3) &
+ deltat*veloc_outer_core(i+3) + deltatsqover2*accel_outer_core(i+3)
-
+
veloc_outer_core(i) = veloc_outer_core(i) &
+ deltatover2*accel_outer_core(i)
veloc_outer_core(i+1) = veloc_outer_core(i+1) &
@@ -1715,32 +1715,32 @@
veloc_outer_core(i+3) = veloc_outer_core(i+3) &
+ deltatover2*accel_outer_core(i+3)
- accel_outer_core(i) = 0._CUSTOM_REAL
- accel_outer_core(i+1) = 0._CUSTOM_REAL
- accel_outer_core(i+2) = 0._CUSTOM_REAL
- accel_outer_core(i+3) = 0._CUSTOM_REAL
+ accel_outer_core(i) = 0._CUSTOM_REAL
+ accel_outer_core(i+1) = 0._CUSTOM_REAL
+ accel_outer_core(i+2) = 0._CUSTOM_REAL
+ accel_outer_core(i+3) = 0._CUSTOM_REAL
enddo
-
-
+
+
! inner core
- do i = 1,mod(NGLOB_INNER_CORE,3)
+ do i = 1,mod(NGLOB_INNER_CORE,3)
displ_inner_core(:,i) = displ_inner_core(:,i) &
+ deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
-
+
veloc_inner_core(:,i) = veloc_inner_core(:,i) &
+ deltatover2*accel_inner_core(:,i)
-
- accel_inner_core(:,i) = 0._CUSTOM_REAL
+
+ accel_inner_core(:,i) = 0._CUSTOM_REAL
enddo
- do i = mod(NGLOB_INNER_CORE,3)+1,NGLOB_INNER_CORE, 3 ! in steps of 3
+ do i = mod(NGLOB_INNER_CORE,3)+1,NGLOB_INNER_CORE, 3 ! in steps of 3
displ_inner_core(:,i) = displ_inner_core(:,i) &
+ deltat*veloc_inner_core(:,i) + deltatsqover2*accel_inner_core(:,i)
displ_inner_core(:,i+1) = displ_inner_core(:,i+1) &
+ deltat*veloc_inner_core(:,i+1) + deltatsqover2*accel_inner_core(:,i+1)
displ_inner_core(:,i+2) = displ_inner_core(:,i+2) &
+ deltat*veloc_inner_core(:,i+2) + deltatsqover2*accel_inner_core(:,i+2)
-
-
+
+
veloc_inner_core(:,i) = veloc_inner_core(:,i) &
+ deltatover2*accel_inner_core(:,i)
veloc_inner_core(:,i+1) = veloc_inner_core(:,i+1) &
@@ -1748,9 +1748,9 @@
veloc_inner_core(:,i+2) = veloc_inner_core(:,i+2) &
+ deltatover2*accel_inner_core(:,i+2)
- accel_inner_core(:,i) = 0._CUSTOM_REAL
- accel_inner_core(:,i+1) = 0._CUSTOM_REAL
- accel_inner_core(:,i+2) = 0._CUSTOM_REAL
+ accel_inner_core(:,i) = 0._CUSTOM_REAL
+ accel_inner_core(:,i+1) = 0._CUSTOM_REAL
+ accel_inner_core(:,i+2) = 0._CUSTOM_REAL
enddo
@@ -1812,7 +1812,7 @@
+ b_deltat*b_veloc_outer_core(i) + b_deltatsqover2*b_accel_outer_core(i)
b_veloc_outer_core(i) = b_veloc_outer_core(i) &
+ b_deltatover2*b_accel_outer_core(i)
- b_accel_outer_core(i) = 0._CUSTOM_REAL
+ b_accel_outer_core(i) = 0._CUSTOM_REAL
enddo
do i=mod(NGLOB_OUTER_CORE,4)+1,NGLOB_OUTER_CORE,4
b_displ_outer_core(i) = b_displ_outer_core(i) &
@@ -1833,10 +1833,10 @@
b_veloc_outer_core(i+3) = b_veloc_outer_core(i+3) &
+ b_deltatover2*b_accel_outer_core(i+3)
- b_accel_outer_core(i) = 0._CUSTOM_REAL
- b_accel_outer_core(i+1) = 0._CUSTOM_REAL
- b_accel_outer_core(i+2) = 0._CUSTOM_REAL
- b_accel_outer_core(i+3) = 0._CUSTOM_REAL
+ b_accel_outer_core(i) = 0._CUSTOM_REAL
+ b_accel_outer_core(i+1) = 0._CUSTOM_REAL
+ b_accel_outer_core(i+2) = 0._CUSTOM_REAL
+ b_accel_outer_core(i+3) = 0._CUSTOM_REAL
enddo
@@ -1882,16 +1882,16 @@
! compute the maximum of the norm of the displacement
! in all the slices using an MPI reduction
! and output timestamp file to check that simulation is running fine
- if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) &
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) &
call check_simulation_stability(it,displ_crust_mantle,displ_inner_core,displ_outer_core, &
b_displ_crust_mantle,b_displ_inner_core,b_displ_outer_core, &
eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
SIMULATION_TYPE,OUTPUT_FILES,time_start,DT,t0,NSTEP, &
COMPUTE_AND_STORE_STRAIN,myrank)
-
+
! ****************************************************
! big loop over all spectral elements in the fluid
! ****************************************************
@@ -1941,7 +1941,7 @@
gammax_outer_core,gammay_outer_core,gammaz_outer_core, &
hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- ibool_outer_core)
+ ibool_outer_core)
else
call compute_forces_outer_core(time,b_deltat,b_two_omega_earth, &
b_A_array_rotation,b_B_array_rotation,d_ln_density_dr_table, &
@@ -2000,7 +2000,7 @@
accel_outer_core,b_accel_outer_core, &
normal_top_outer_core,jacobian2D_top_outer_core, &
wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
- SIMULATION_TYPE,NSPEC2D_TOP(IREGION_OUTER_CORE))
+ SIMULATION_TYPE,NSPEC2D_TOP(IREGION_OUTER_CORE))
!---
!--- couple with inner core at the bottom of the outer core
@@ -2040,7 +2040,7 @@
! veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
! enddo
-! way 2:
+! way 2:
do i=1,mod(NGLOB_OUTER_CORE,4)
accel_outer_core(i) = accel_outer_core(i)*rmass_outer_core(i)
veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
@@ -2050,15 +2050,15 @@
accel_outer_core(i+1) = accel_outer_core(i+1)*rmass_outer_core(i+1)
accel_outer_core(i+2) = accel_outer_core(i+2)*rmass_outer_core(i+2)
accel_outer_core(i+3) = accel_outer_core(i+3)*rmass_outer_core(i+3)
-
+
veloc_outer_core(i) = veloc_outer_core(i) + deltatover2*accel_outer_core(i)
veloc_outer_core(i+1) = veloc_outer_core(i+1) + deltatover2*accel_outer_core(i+1)
veloc_outer_core(i+2) = veloc_outer_core(i+2) + deltatover2*accel_outer_core(i+2)
veloc_outer_core(i+3) = veloc_outer_core(i+3) + deltatover2*accel_outer_core(i+3)
- enddo
-
-
+ enddo
+
+
if (SIMULATION_TYPE == 3) then
call assemble_MPI_scalar(myrank,b_accel_outer_core,NGLOB_OUTER_CORE, &
iproc_xi,iproc_eta,ichunk,addressing, &
@@ -2096,8 +2096,8 @@
b_veloc_outer_core(i+1) = b_veloc_outer_core(i+1) + b_deltatover2*b_accel_outer_core(i+1)
b_veloc_outer_core(i+2) = b_veloc_outer_core(i+2) + b_deltatover2*b_accel_outer_core(i+2)
b_veloc_outer_core(i+3) = b_veloc_outer_core(i+3) + b_deltatover2*b_accel_outer_core(i+3)
- enddo
-
+ enddo
+
endif
@@ -2164,7 +2164,7 @@
size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5), &
COMPUTE_AND_STORE_STRAIN)
endif
-
+
if (SIMULATION_TYPE == 3) then
! for anisotropy and gravity, x y and z contain r theta and phi
if( USE_DEVILLE_VAL ) then
@@ -2219,7 +2219,7 @@
size(factor_common_crust_mantle,2), size(factor_common_crust_mantle,3), &
size(factor_common_crust_mantle,4), size(factor_common_crust_mantle,5), &
COMPUTE_AND_STORE_STRAIN)
-
+
endif
endif
@@ -2288,7 +2288,7 @@
factor_common_inner_core, &
size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
size(factor_common_inner_core,4), size(factor_common_inner_core,5), &
- COMPUTE_AND_STORE_STRAIN)
+ COMPUTE_AND_STORE_STRAIN)
endif
if (SIMULATION_TYPE == 3) then
@@ -2329,7 +2329,7 @@
factor_common_inner_core, &
size(factor_common_inner_core,2), size(factor_common_inner_core,3), &
size(factor_common_inner_core,4), size(factor_common_inner_core,5), &
- COMPUTE_AND_STORE_STRAIN)
+ COMPUTE_AND_STORE_STRAIN)
endif
endif
@@ -2338,7 +2338,7 @@
call compute_add_sources(myrank,NSOURCES, &
accel_crust_mantle,sourcearrays, &
DT,t0,t_cmt,hdur_gaussian,ibool_crust_mantle, &
- islice_selected_source,ispec_selected_source,it)
+ islice_selected_source,ispec_selected_source,it)
! add adjoint sources
if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
@@ -2352,7 +2352,7 @@
NSTEP_SUB_ADJ,iadjsrc_len,iadjsrc,iadj_vec, &
it,it_begin,station_name,network_name)
endif
-
+
! add sources for backward/reconstructed wavefield
if (SIMULATION_TYPE == 3) &
call compute_add_sources_backward(myrank,NSOURCES,NSTEP, &
@@ -2360,7 +2360,7 @@
DT,t0,t_cmt,hdur_gaussian,ibool_crust_mantle, &
islice_selected_source,ispec_selected_source,it)
-
+
! ****************************************************
! ********** add matching with fluid part **********
! ****************************************************
@@ -2379,7 +2379,7 @@
wgllwgll_xy,ibool_outer_core,ibelm_top_outer_core, &
RHO_TOP_OC,minus_g_cmb, &
SIMULATION_TYPE,NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE))
-
+
!---
!--- couple with outer core at the top of the inner core
!---
@@ -2721,15 +2721,15 @@
! write the seismograms with time shift
! store the seismograms only if there is at least one receiver located in this slice
- if (nrec_local > 0) then
+ if (nrec_local > 0) then
if (SIMULATION_TYPE == 1) then
call compute_seismograms(nrec_local,nrec,displ_crust_mantle, &
nu,hxir_store,hetar_store,hgammar_store, &
scale_displ,ibool_crust_mantle, &
ispec_selected_rec,number_receiver_global, &
seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismograms)
-
+ seismograms)
+
else if (SIMULATION_TYPE == 2 ) then
call compute_seismograms_adjoint(NSOURCES,nrec_local,displ_crust_mantle, &
eps_trace_over_3_crust_mantle,epsilondev_crust_mantle, &
@@ -2745,15 +2745,15 @@
NTSTEP_BETWEEN_OUTPUT_SEISMOS,seismograms,deltat, &
ibool_crust_mantle,ispec_selected_source,number_receiver_global, &
NSTEP,it,nit_written)
-
+
else if (SIMULATION_TYPE == 3 ) then
call compute_seismograms_backward(nrec_local,nrec,b_displ_crust_mantle, &
nu,hxir_store,hetar_store,hgammar_store, &
scale_displ,ibool_crust_mantle, &
ispec_selected_rec,number_receiver_global, &
seismo_current,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- seismograms)
-
+ seismograms)
+
endif
endif ! nrec_local
@@ -2800,12 +2800,12 @@
! crust mantle
call compute_kernels_crust_mantle(ibool_crust_mantle, &
rho_kl_crust_mantle,beta_kl_crust_mantle, &
- alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
+ alpha_kl_crust_mantle,cijkl_kl_crust_mantle, &
accel_crust_mantle,b_displ_crust_mantle, &
epsilondev_crust_mantle,b_epsilondev_crust_mantle, &
eps_trace_over_3_crust_mantle,b_eps_trace_over_3_crust_mantle, &
deltat)
-
+
! outer core
call compute_kernels_outer_core(ibool_outer_core, &
xix_outer_core,xiy_outer_core,xiz_outer_core, &
@@ -2825,7 +2825,7 @@
! inner core
call compute_kernels_inner_core(ibool_inner_core, &
rho_kl_inner_core,beta_kl_inner_core, &
- alpha_kl_inner_core, &
+ alpha_kl_inner_core, &
accel_inner_core,b_displ_inner_core, &
epsilondev_inner_core,b_epsilondev_inner_core, &
eps_trace_over_3_inner_core,b_eps_trace_over_3_inner_core, &
@@ -3046,7 +3046,7 @@
store_val_ux_all,store_val_uy_all,store_val_uz_all, &
ibelm_top_crust_mantle,ibool_crust_mantle, &
NSPEC2D_TOP(IREGION_CRUST_MANTLE), &
- NIT,it,OUTPUT_FILES)
+ NIT,it,OUTPUT_FILES)
endif
endif
@@ -3063,7 +3063,7 @@
muvstore_crust_mantle_3dmovie, &
mask_3dmovie,nu_3dmovie)
- else if (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) then
+ else if (MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3) then
! output the Time Integral of Strain, or \mu*TIS
call write_movie_volume_strains(myrank,npoints_3dmovie, &
LOCAL_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
@@ -3127,7 +3127,7 @@
! crust mantle
call save_kernels_crust_mantle(myrank,scale_t,scale_displ, &
cijkl_kl_crust_mantle,rho_kl_crust_mantle, &
- alpha_kl_crust_mantle,beta_kl_crust_mantle, &
+ alpha_kl_crust_mantle,beta_kl_crust_mantle, &
ystore_crust_mantle,zstore_crust_mantle, &
rhostore_crust_mantle,muvstore_crust_mantle, &
kappavstore_crust_mantle,ibool_crust_mantle, &
@@ -3145,7 +3145,7 @@
rho_kl_inner_core,beta_kl_inner_core,alpha_kl_inner_core, &
rhostore_inner_core,muvstore_inner_core,kappavstore_inner_core, &
LOCAL_PATH)
-
+
! boundary kernel
if (SAVE_BOUNDARY_MESH) then
call save_kernels_boundary_kl(myrank,scale_t,scale_displ, &
@@ -3158,7 +3158,7 @@
! save source derivatives for adjoint simulations
if (SIMULATION_TYPE == 2 .and. nrec_local > 0) then
call save_kernels_source_derivatives(nrec_local,NSOURCES,scale_displ,scale_t, &
- nu_source,moment_der,sloc_der,number_receiver_global)
+ nu_source,moment_der,sloc_der,number_receiver_global)
endif
@@ -3188,7 +3188,7 @@
! stop all the MPI processes, and exit
call MPI_FINALIZE(ier)
-
+
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
@@ -3196,7 +3196,7 @@
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
!
-
+
end program xspecfem3D
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/stretching_function.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/stretching_function.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/stretching_function.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -29,7 +29,7 @@
! define stretch_tab which contains r_top and r_bottom for each element layer in the crust for 3D models.
!
-! stretch_tab array uses indices index_radius & index_layer :
+! stretch_tab array uses indices index_radius & index_layer :
! stretch_tab( index_radius (1=top,2=bottom) , index_layer (1=first layer, 2=second layer,..) )
implicit none
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_chunks_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_chunks_data.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_chunks_data.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -32,18 +32,18 @@
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)
+ RMIDDLE_CRUST,ROCEAN,iregion_code)
implicit none
include "constants.h"
- integer nspec,myrank
+ integer nspec,myrank
integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
integer idoubling(nspec)
- logical iboun(6,nspec),ELLIPTICITY,ISOTROPIC_3D_MANTLE
+ logical iboun(6,nspec),ELLIPTICITY,ISOTROPIC_3D_MANTLE
double precision RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771, &
R400,R120,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
@@ -565,15 +565,15 @@
Qkappa,Qmu,RICB,RCMB, &
RTOPDDOUBLEPRIME,R80,R120,R220,R400,R600,R670,R771, &
RMOHO,RMIDDLE_CRUST,ROCEAN)
-
- ! calculates isotropic values
+
+ ! calculates isotropic values
vp = sqrt(((8.d0+4.d0*eta_aniso)*vph*vph + 3.d0*vpv*vpv &
+ (8.d0 - 8.d0*eta_aniso)*vsv*vsv)/15.d0)
vs = sqrt(((1.d0-2.d0*eta_aniso)*vph*vph + vpv*vpv &
+ 5.d0*vsh*vsh + (6.d0+4.d0*eta_aniso)*vsv*vsv)/15.d0)
-
+
if( abs(rhostore(i,j,k,ispec))< 1.e-20 ) then
- print*,' attention: rhostore close to zero',rhostore(i,j,k,ispec),r,i,j,k,ispec
+ print*,' attention: rhostore close to zero',rhostore(i,j,k,ispec),r,i,j,k,ispec
dvp = 0.0
dvs = 0.0
else if( abs(sngl(vp))< 1.e-20 ) then
@@ -584,9 +584,9 @@
dvs = 0.0
else
dvp = dvp + (sqrt((kappavstore(i,j,k,ispec)+4.*muvstore(i,j,k,ispec)/3.)/rhostore(i,j,k,ispec)) - sngl(vp))/sngl(vp)
- dvs = dvs + (sqrt(muvstore(i,j,k,ispec)/rhostore(i,j,k,ispec)) - sngl(vs))/sngl(vs)
+ dvs = dvs + (sqrt(muvstore(i,j,k,ispec)/rhostore(i,j,k,ispec)) - sngl(vs))/sngl(vs)
endif
-
+
enddo
enddo
enddo
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_data.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/write_AVS_DX_global_data.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -220,7 +220,7 @@
double precision:: Qmustore(NGLLX,NGLLY,NGLLZ,nspec)
logical :: ATTENUATION
-
+
! local parameters
double precision,dimension(8):: vp,vs,rho,Qmu
double precision:: vp_average,vs_average,rho_average,Qmu_average
@@ -249,9 +249,9 @@
write(10,*) numpoin,sngl(xstore(i,j,k,ispec)),&
sngl(ystore(i,j,k,ispec)),sngl(zstore(i,j,k,ispec))
flag(i,j,k,ispec) = numpoin
- end do
- end do
- end do
+ end do
+ end do
+ end do
enddo
close(10)
@@ -269,7 +269,7 @@
do k = 1,NGLLZ-1
do j = 1,NGLLY-1
do i = 1,NGLLX-1
- nelem = nelem + 1
+ nelem = nelem + 1
iglob1=flag(i,j,k,ispec)
iglob2=flag(i+1,j,k,ispec)
iglob3=flag(i+1,j+1,k,ispec)
@@ -278,13 +278,13 @@
iglob6=flag(i+1,j,k+1,ispec)
iglob7=flag(i+1,j+1,k+1,ispec)
iglob8=flag(i,j+1,k+1,ispec)
-
+
write(10,*) nelem,iglob1, &
iglob2,iglob3,iglob4,&
iglob5,iglob6,iglob7,iglob8
- end do
- end do
- end do
+ end do
+ end do
+ end do
enddo
close(10)
@@ -344,7 +344,7 @@
Qmu(7)=dble(Qmustore(i+1,j+1,k+1,ispec))
Qmu(8)=dble(Qmustore(i,j+1,k+1,ispec))
Qmu_average=Qmu(1)
- end if
+ end if
!rho_average=sum(rho(1:4))/4.d0
!vp_average=sum(vp(1:4))/4.d0
!vs_average=sum(vs(1:4))/4.d0
@@ -354,13 +354,13 @@
if (ATTENUATION) then
write(1001,*) nelem,rho_average,vp_average,vs_average,Qmu_average
- else
+ else
write(1001,*) nelem,rho_average,vp_average,vs_average
- end if
+ end if
- end do
- end do
end do
+ end do
+ end do
enddo
close(1001)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_surface.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_surface.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_surface.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -33,23 +33,23 @@
store_val_ux_all,store_val_uy_all,store_val_uz_all, &
ibelm_top_crust_mantle,ibool_crust_mantle,nspec_top, &
NIT,it,OUTPUT_FILES)
-
+
implicit none
-
+
include 'mpif.h'
include "precision.h"
include "constants.h"
include "OUTPUT_FILES/values_from_mesher.h"
-
+
integer myrank,nmovie_points
double precision :: scale_veloc
-
+
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: &
veloc_crust_mantle
real(kind=CUSTOM_REAL), dimension(NGLOB_CRUST_MANTLE) :: &
xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
-
+
real(kind=CUSTOM_REAL), dimension(nmovie_points) :: &
store_val_x,store_val_y,store_val_z, &
store_val_ux,store_val_uy,store_val_uz
@@ -67,17 +67,17 @@
! local parameters
character(len=150) :: outputname
integer :: ipoin,ispec2D,ispec,i,j,k,ier,iglob
-
+
! save velocity here to avoid static offset on displacement for movies
- ! get coordinates of surface mesh and surface displacement
+ ! get coordinates of surface mesh and surface displacement
ipoin = 0
do ispec2D = 1, nspec_top ! NSPEC2D_TOP(IREGION_CRUST_MANTLE)
ispec = ibelm_top_crust_mantle(ispec2D)
-
- !daniel: in case of global, NCHUNKS_VAL == 6 simulations, be aware that for
- ! the cubed sphere, the mapping changes for different chunks,
+
+ !daniel: in case of global, NCHUNKS_VAL == 6 simulations, be aware that for
+ ! the cubed sphere, the mapping changes for different chunks,
! i.e. e.g. x(1,1) and x(5,5) flip left and right sides of the elements in geographical coordinates.
! for future consideration, like in create_movie_GMT_global.f90 ...
k = NGLLZ
@@ -119,5 +119,5 @@
write(IOUT) store_val_uz_all
close(IOUT)
endif
-
- end subroutine write_movie_surface
\ No newline at end of file
+
+ end subroutine write_movie_surface
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_volume.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_volume.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/write_movie_volume.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -305,7 +305,7 @@
else
NIT = 1
endif
-
+
write(prname,"('proc',i6.6)") myrank
ipoints_3dmovie=0
do ispec=1,NSPEC_CRUST_MANTLE
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/write_seismograms.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/write_seismograms.f90 2010-03-03 01:51:05 UTC (rev 16370)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/write_seismograms.f90 2010-03-03 18:07:17 UTC (rev 16371)
@@ -542,7 +542,7 @@
STDP = stbur(irec)
!event values (hypocenter):
- ! note: this writes out the CMT location, which might be different
+ ! note: this writes out the CMT location, which might be different
! to the event location given in the first, PDE line
EVLA = cmt_lat
EVLO = cmt_lon
@@ -553,16 +553,16 @@
! by Ebru
! SAC headers will have new format
USER0 = cmt_hdur !half duration from CMT file if not changed to hdur=0.d0 (point source)
-
+
! we remove any PDE information, since the simulation could also start
! with a "pure" CMT solution, without having any PDE infos
!
- !USER1 = t_shift !time shift between PDE and CMT solutions
+ !USER1 = t_shift !time shift between PDE and CMT solutions
!PDE location values (different from CMT location, usually):
!USER2 = depth !PDE depth
!USER3 = elat !PDE event latitude
!USER4 = elon !PDE event longitude
- !
+ !
!cmt location values (different from hypocenter location, usually):
! USER0 = cmt_lat
! USER1 = cmt_lon
@@ -575,15 +575,15 @@
value1 = elat
value1 = elon
value1 = depth
-
- ! it is not clear, which magnitude to write out:
- ! should it be
+
+ ! it is not clear, which magnitude to write out:
+ ! should it be
! body-wave-magnitude (Mb), surface-wave-magnitude (Ms), moment magnitude (Mw)
! or leave magnitude and use scalar moment (M0, but calculated by which convention, Harvard?)
!
! it's confusing, and as a result, we will omit it.
- ! by Ebru
+ ! by Ebru
MAG = undef
IMAGTYP= undef
@@ -620,15 +620,15 @@
NZHOUR =ho
NZMIN =mi
- ! adds time-shift to get the CMT time in the headers as origin time of events
- ! by Ebru
+ ! adds time-shift to get the CMT time in the headers as origin time of events
+ ! by Ebru
NZSEC =int(sec+t_shift)
NZMSEC =int((sec+t_shift-int(sec+t_shift))*1000)
!NZSEC =int(sec)
!NZMSEC =int((sec-int(sec))*1000)
- ! Adjust event time and date after t_shift is added
+ ! Adjust event time and date after t_shift is added
if (NZSEC >= 60) then
time_sec = jda*24*3600 + ho*3600 + mi*60 + int(sec+t_shift)
NZJDAY = int(time_sec/(24*3600))
@@ -677,7 +677,7 @@
! writes out event id as event name
! by Ebru
KEVNM = event_name(1:len_trim(event_name)) ! A16
-
+
!if (NSOURCES == 1) then
! KEVNM = ename(1:len_trim(ename))//'_syn'! A16
!else
@@ -690,9 +690,9 @@
! indicates SEM synthetics
! by Ebru
KUSER0 = 'SEM' ! A8
- KUSER1 = 'v5.0.0 '
+ KUSER1 = 'v5.0.0 '
KUSER2 = 'Tiger' ! aka. awesome (princeton) tiger version :)
-
+
!KUSER0 = 'PDE_LAT_' ! A8
!KUSER1 = 'PDE_LON_' ! A8
!KUSER2 = 'PDEDEPTH' ! A8
More information about the CIG-COMMITS
mailing list