[cig-commits] r22481 - in seismo/3D/SPECFEM3D_GLOBE: branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D trunk/src/meshfem3D
dkomati1 at geodynamics.org
dkomati1 at geodynamics.org
Mon Jul 1 11:39:32 PDT 2013
Author: dkomati1
Date: 2013-07-01 11:39:32 -0700 (Mon, 01 Jul 2013)
New Revision: 22481
Modified:
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/calc_jacobian.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/compute_coordinates_grid.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/compute_element_properties.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_central_cube.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_chunk_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_doubling_elements.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_mass_matrices.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regions_mesh.F90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regular_elements.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_1D_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_absorb.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_global.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_jacobian_boundaries.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_model.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_perm_color.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/meshfem3D.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_1dref.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_ak135.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_aniso_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_atten3D_QRFSI12.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_attenuation.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_crust.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_crustmaps.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_epcrust.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_gll.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_jp3d.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_ppm.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_s20rts.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_s362ani.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_s40rts.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_sea1d.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/moho_stretching.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/sort_array_coordinates.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/calc_jacobian.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/compute_coordinates_grid.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/compute_element_properties.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_central_cube.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_chunk_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_doubling_elements.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_mass_matrices.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regions_mesh.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regular_elements.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_MPI_1D_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_MPI_cutplanes_eta.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_MPI_cutplanes_xi.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_absorb.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_global.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_perm_color.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_1dref.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_ak135.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_aniso_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_atten3D_QRFSI12.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_attenuation.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_crust.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_crustmaps.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_epcrust.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_eucrust.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_gapp2.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_gll.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_heterogen_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_jp3d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_ppm.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_s20rts.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_s362ani.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_s40rts.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_sea1d.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_sea99_s.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/moho_stretching.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/sort_array_coordinates.f90
Log:
done merging all easy modifications in "src/meshfem3D"
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/calc_jacobian.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/calc_jacobian.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/calc_jacobian.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -40,7 +40,7 @@
! gammaxstore,gammaystore,gammazstore ------ parameters used to calculate jacobian
- subroutine calc_jacobian_gll3D(myrank,xstore,ystore,zstore,xigll,yigll,zigll,&
+ subroutine recalc_jacobian_gll3D(myrank,xstore,ystore,zstore,xigll,yigll,zigll,&
ispec,nspec,&
xixstore,xiystore,xizstore, &
etaxstore,etaystore,etazstore, &
@@ -151,19 +151,19 @@
if (abs(xmesh - xstore(i,j,k,ispec)) > TINYVAL &
.or. abs(ymesh - ystore(i,j,k,ispec)) > TINYVAL &
.or. abs(zmesh - zstore(i,j,k,ispec)) > TINYVAL ) then
- call exit_MPI(myrank,'new mesh are wrong in recalc_jacobian_gall3D.f90')
+ call exit_MPI(myrank,'new mesh is wrong in recalc_jacobian_gll3D.f90')
endif
if(abs(sumshape-one) > TINYVAL) then
- call exit_MPI(myrank,'error shape functions in calc_jacobian_gll3D.f90')
+ call exit_MPI(myrank,'error shape functions in recalc_jacobian_gll3D.f90')
endif
if(abs(sumdershapexi) > TINYVAL) then
- call exit_MPI(myrank,'error derivative xi in calc_jacobian_gll3D.f90')
+ call exit_MPI(myrank,'error derivative xi in recalc_jacobian_gll3D.f90')
endif
if(abs(sumdershapeeta) > TINYVAL) then
- call exit_MPI(myrank,'error derivative eta in calc_jacobian_gll3D.f90')
+ call exit_MPI(myrank,'error derivative eta in recalc_jacobian_gll3D.f90')
endif
if(abs(sumdershapegamma) > TINYVAL) then
- call exit_MPI(myrank,'error derivative gamma in calc_jacobian_gll3D.f90')
+ call exit_MPI(myrank,'error derivative gamma in recalc_jacobian_gll3D.f90')
endif
! jacobian calculation
@@ -180,7 +180,7 @@
print*,' location r/lat/lon: ',r*R_EARTH_KM, &
(PI_OVER_TWO-theta)*RADIANS_TO_DEGREES,phi*RADIANS_TO_DEGREES
print*,' jacobian: ',jacobian
- call exit_MPI(myrank,'3D Jacobian undefined in calc_jacobian_gll3D.f90')
+ call exit_MPI(myrank,'3D Jacobian undefined in recalc_jacobian_gll3D.f90')
endif
! invert the relation (Fletcher p. 50 vol. 2)
@@ -223,7 +223,7 @@
enddo
enddo
- end subroutine calc_jacobian_gll3D
+ end subroutine recalc_jacobian_gll3D
!
@@ -239,7 +239,7 @@
! xigll,yigll,NSPEC2DMAX_AB,NGLLA,NGLLB
! output results: jacobian2D,normal
- subroutine calc_jacobian_gll2D(myrank,ispecb, &
+ subroutine recalc_jacobian_gll2D(myrank,ispecb, &
xelm2D,yelm2D,zelm2D,xigll,yigll,&
jacobian2D,normal,NGLLA,NGLLB,NSPEC2DMAX_AB)
@@ -318,16 +318,17 @@
if ( abs(xmesh - xelm2D(i,j)) > TINYVAL &
.or. abs(ymesh - yelm2D(i,j)) > TINYVAL &
.or. abs(zmesh - zelm2D(i,j)) > TINYVAL ) then
- call exit_MPI(myrank,'new boundary mesh is wrong in calc_jacobian_gll2D')
+ call exit_MPI(myrank,'new boundary mesh is wrong in recalc_jacobian_gll2D')
endif
+
if (abs(sumshape-one) > TINYVAL) then
- call exit_MPI(myrank,'error shape functions in calc_jacobian_gll2D')
+ call exit_MPI(myrank,'error shape functions in recalc_jacobian_gll2D')
endif
if (abs(sumdershapexi) > TINYVAL) then
- call exit_MPI(myrank,'error derivative xi in calc_jacobian_gll2D')
+ call exit_MPI(myrank,'error derivative xi in recalc_jacobian_gll2D')
endif
if (abs(sumdershapeeta) > TINYVAL) then
- call exit_MPI(myrank,'error derivative eta in calc_jacobian_gll2D')
+ call exit_MPI(myrank,'error derivative eta in recalc_jacobian_gll2D')
endif
! calculates j2D acobian
@@ -338,7 +339,7 @@
! checks
if (abs(jacobian) < TINYVAL ) &
- call exit_MPI(myrank,'2D Jacobian undefined in calc_jacobian_gll2D')
+ call exit_MPI(myrank,'2D Jacobian undefined in recalc_jacobian_gll2D')
! inverts jacobian
jacobian_inv = ONE / jacobian
@@ -357,5 +358,5 @@
enddo
enddo
- end subroutine calc_jacobian_gll2D
+ end subroutine recalc_jacobian_gll2D
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/compute_coordinates_grid.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/compute_coordinates_grid.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/compute_coordinates_grid.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -60,7 +60,6 @@
double precision :: ratio_xi, ratio_eta, fact_xi, fact_eta, &
fact_xi_,fact_eta_
-
! this to avoid compilation warnings
x_=0
y_=0
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/compute_element_properties.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/compute_element_properties.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/compute_element_properties.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -91,6 +91,16 @@
! attenuation
integer :: vx,vy,vz,nspec_att
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013: BEWARE, declared real(kind=CUSTOM_REAL) in trunk and
+!! DK DK to Daniel, Jul 2013: double precision in branch, let us check which one is right
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
double precision, dimension(vx,vy,vz,nspec_att) :: Qmu_store
double precision, dimension(N_SLS,vx,vy,vz,nspec_att) :: tau_e_store
double precision, dimension(N_SLS) :: tau_s
@@ -209,7 +219,7 @@
! problems with the jacobian. using the anchors is therefore more robust.
! adds surface topography
if( TOPOGRAPHY ) then
- if( idoubling(ispec) == IFLAG_CRUST .or. &
+ 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
@@ -274,7 +284,7 @@
! updates jacobian
! (only needed for second meshing phase)
if( ipass == 2 ) then
- call calc_jacobian_gll3D(myrank,xstore,ystore,zstore,xigll,yigll,zigll,&
+ call recalc_jacobian_gll3D(myrank,xstore,ystore,zstore,xigll,yigll,zigll,&
ispec,nspec,&
xixstore,xiystore,xizstore,&
etaxstore,etaystore,etazstore,&
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_central_cube.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_central_cube.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_central_cube.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -110,7 +110,17 @@
integer iproc_xi,iproc_eta,ichunk,ipass
! attenuation
- integer vx,vy,vz,nspec_att
+ integer :: vx,vy,vz,nspec_att
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013: BEWARE, declared real(kind=CUSTOM_REAL) in trunk and
+!! DK DK to Daniel, Jul 2013: double precision in branch, let us check which one is right
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
double precision, dimension(vx,vy,vz,nspec_att) :: Qmu_store
double precision, dimension(N_SLS,vx,vy,vz,nspec_att) :: tau_e_store
double precision, dimension(N_SLS) :: tau_s
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_chunk_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_chunk_buffers.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_chunk_buffers.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -76,6 +76,7 @@
integer :: nglob
integer :: NGLOB1D_RADIAL
character(len=150) :: OUTPUT_FILES,ERR_MSG
+
! mask for ibool to mark points already found
logical, dimension(:), allocatable :: mask_ibool
@@ -127,6 +128,7 @@
! this to avoid problem at compile time if less than six chunks
integer :: addressing_big(NCHUNKS_MAX,0:NPROC_XI-1,0:NPROC_ETA-1)
+! number of faces between chunks
integer :: NUM_FACES
integer :: NPROC_ONE_DIRECTION
integer :: ier
@@ -209,7 +211,6 @@
write(IMAIN,*) 'only one chunk, no need to create chunk buffers'
write(IMAIN,*)
endif
-
! exit routine
return
endif
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_doubling_elements.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_doubling_elements.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_doubling_elements.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -119,7 +119,17 @@
integer iproc_xi,iproc_eta
! attenuation
- integer vx,vy,vz,nspec_att
+ integer :: vx,vy,vz,nspec_att
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013: BEWARE, declared real(kind=CUSTOM_REAL) in trunk and
+!! DK DK to Daniel, Jul 2013: double precision in branch, let us check which one is right
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
double precision, dimension(vx,vy,vz,nspec_att) :: Qmu_store
double precision, dimension(N_SLS,vx,vy,vz,nspec_att) :: tau_e_store
double precision, dimension(N_SLS) :: tau_s
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_mass_matrices.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_mass_matrices.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_mass_matrices.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -93,6 +93,10 @@
do k = 1,NGLLZ
do j = 1,NGLLY
do i = 1,NGLLX
+
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+ iglob = ibool(i,j,k,ispec)
+
! compute the jacobian
xixl = xixstore(i,j,k,ispec)
xiyl = xiystore(i,j,k,ispec)
@@ -108,10 +112,6 @@
- xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ xizl*(etaxl*gammayl-etayl*gammaxl))
-
- iglob = ibool(i,j,k,ispec)
- weight = wxgll(i)*wygll(j)*wzgll(k)
-
! definition depends if region is fluid or solid
select case( iregion_code)
@@ -161,7 +161,7 @@
! gets spectral element index
ispec = ibelm_top(ispec2D)
- ! assumes elements are order such that k == NGLLZ is top surface
+ ! assumes elements are ordered such that k == NGLLZ is the top surface
k = NGLLZ
! loops over surface points
@@ -185,8 +185,11 @@
! map to latitude and longitude for bathymetry routine
! slightly move points to avoid roundoff problem when exactly on the polar axis
call xyz_2_rthetaphi_dble(xval,yval,zval,rval,theta,phi)
- theta = theta + 0.0000001d0
- phi = phi + 0.0000001d0
+!! DK DK Jul 2013: added a test to only do this if we are on the axis
+ if(abs(theta) > 89.99d0) then
+ theta = theta + 0.0000001d0
+ phi = phi + 0.0000001d0
+ endif
call reduce(theta,phi)
! convert the geocentric colatitude to a geographic colatitude
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regions_mesh.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regions_mesh.F90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regions_mesh.F90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -25,7 +25,6 @@
!
!=====================================================================
-
subroutine create_regions_mesh(iregion_code, &
nspec,nglob_theor,npointot, &
NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
@@ -472,8 +471,8 @@
! local parameters
integer :: ier
- ! New Attenuation definition on all GLL points
- ! Attenuation
+ ! new Attenuation definition on all GLL points
+ ! attenuation
if (ATTENUATION) then
T_c_source = AM_V%QT_c_source
tau_s(:) = AM_V%Qtau_s(:)
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regular_elements.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regular_elements.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regular_elements.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -124,7 +124,17 @@
integer iproc_xi,iproc_eta
! attenuation
- integer vx,vy,vz,nspec_att
+ integer :: vx,vy,vz,nspec_att
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013: BEWARE, declared real(kind=CUSTOM_REAL) in trunk and
+!! DK DK to Daniel, Jul 2013: double precision in branch, let us check which one is right
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
double precision, dimension(vx,vy,vz,nspec_att) :: Qmu_store
double precision, dimension(N_SLS,vx,vy,vz,nspec_att) :: tau_e_store
double precision, dimension(N_SLS) :: tau_s
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_1D_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_1D_buffers.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_1D_buffers.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -26,8 +26,7 @@
!=====================================================================
subroutine get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta, &
- ibool,idoubling, &
- xstore,ystore,zstore,mask_ibool,npointot, &
+ ibool,idoubling,xstore,ystore,zstore,mask_ibool,npointot, &
NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion, &
ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
ibool1D_leftxi_righteta,ibool1D_rightxi_righteta, &
@@ -299,6 +298,7 @@
ispeccount=0
do ispec=1,nspec
+
! remove central cube for chunk buffers
if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
@@ -314,6 +314,7 @@
ix = NGLLX
iy = NGLLY
do iz=1,NGLLZ
+
! select point, if not already selected
if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_absorb.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_absorb.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_absorb.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -36,7 +36,7 @@
include "constants.h"
- integer :: nspec,myrank, iregion
+ integer :: nspec,myrank,iregion
integer :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_global.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_global.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_global.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -190,7 +190,8 @@
enddo
! cleanup
- deallocate(copy_ibool_ori,mask_ibool)
+ deallocate(copy_ibool_ori,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(mask_ibool,stat=ier); if(ier /= 0) stop 'error in deallocate'
end subroutine get_global_indirect_addressing
@@ -220,7 +221,7 @@
if (n == 1) return
- L = floor(n/2.0) + 1
+ L = n/2 + 1
ir = n
do while( .true. )
@@ -235,7 +236,7 @@
ind(ir) = ind(1)
ir = ir-1
- ! checks exit criteria
+ ! checks exit criterion
if (ir == 1) then
ind(1) = indx
return
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_jacobian_boundaries.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_jacobian_boundaries.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_jacobian_boundaries.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -153,7 +153,7 @@
enddo
enddo
! recalculate jacobian according to 2D GLL points
- call calc_jacobian_gll2D(myrank,ispecb1,xelm2D,yelm2D,zelm2D, &
+ call recalc_jacobian_gll2D(myrank,ispecb1,xelm2D,yelm2D,zelm2D, &
yigll,zigll,jacobian2D_xmin,normal_xmin,&
NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
endif
@@ -209,7 +209,7 @@
enddo
enddo
! recalculate jacobian according to 2D GLL points
- call calc_jacobian_gll2D(myrank,ispecb2,xelm2D,yelm2D,zelm2D,&
+ call recalc_jacobian_gll2D(myrank,ispecb2,xelm2D,yelm2D,zelm2D,&
yigll,zigll,jacobian2D_xmax,normal_xmax,&
NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
endif
@@ -265,7 +265,7 @@
enddo
enddo
! recalcualte 2D jacobian according to GLL points
- call calc_jacobian_gll2D(myrank,ispecb3,xelm2D,yelm2D,zelm2D,&
+ call recalc_jacobian_gll2D(myrank,ispecb3,xelm2D,yelm2D,zelm2D,&
xigll,zigll,jacobian2D_ymin,normal_ymin,&
NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
endif
@@ -321,7 +321,7 @@
enddo
enddo
! recalculate jacobian for 2D GLL points
- call calc_jacobian_gll2D(myrank,ispecb4,xelm2D,yelm2D,zelm2D,&
+ call recalc_jacobian_gll2D(myrank,ispecb4,xelm2D,yelm2D,zelm2D,&
xigll,zigll,jacobian2D_ymax,normal_ymax,&
NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
endif
@@ -376,7 +376,7 @@
enddo
enddo
! recalcuate 2D jacobian according to GLL points
- call calc_jacobian_gll2D(myrank,ispecb5,xelm2D,yelm2D,zelm2D,&
+ call recalc_jacobian_gll2D(myrank,ispecb5,xelm2D,yelm2D,zelm2D,&
xigll,yigll,jacobian2D_bottom,normal_bottom,&
NGLLX,NGLLY,NSPEC2D_BOTTOM)
endif
@@ -431,7 +431,7 @@
enddo
enddo
! recalcuate jacobian according to 2D gll points
- call calc_jacobian_gll2D(myrank,ispecb6,xelm2D,yelm2D,zelm2D,&
+ call recalc_jacobian_gll2D(myrank,ispecb6,xelm2D,yelm2D,zelm2D,&
xigll,yigll,jacobian2D_top,normal_top,&
NGLLX,NGLLY,NSPEC2D_TOP)
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_model.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_model.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -68,6 +68,16 @@
! attenuation values
integer :: vx,vy,vz,vnspec
double precision, dimension(N_SLS) :: tau_s
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013: BEWARE, declared real(kind=CUSTOM_REAL) in trunk and
+!! DK DK to Daniel, Jul 2013: double precision in branch, let us check which one is right
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
double precision, dimension(vx, vy, vz, vnspec) :: Qmu_store
double precision, dimension(N_SLS, vx, vy, vz, vnspec) :: tau_e_store
double precision :: T_c_source
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_perm_color.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_perm_color.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_perm_color.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -25,7 +25,6 @@
!
!=====================================================================
-
! define sets of colors that contain disconnected elements for the CUDA solver.
! also split the elements into two subsets: inner and outer elements, in order
! to be able to compute the outer elements first in the solver and then
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/meshfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/meshfem3D.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/meshfem3D.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -61,6 +61,20 @@
! pages = {1-32},
! number = {1}}
!
+! @ARTICLE{PeKoLuMaLeCaLeMaLiBlNiBaTr11,
+! author = {Daniel Peter and Dimitri Komatitsch and Yang Luo and Roland Martin
+! and Nicolas {Le Goff} and Emanuele Casarotti and Pieyre {Le Loher}
+! and Federica Magnoni and Qinya Liu and C\'eline Blitz and Tarje Nissen-Meyer
+! and Piero Basini and Jeroen Tromp},
+! title = {Forward and adjoint simulations of seismic wave propagation on fully
+! unstructured hexahedral meshes},
+! journal={Geophys. J. Int.},
+! year = {2011},
+! volume = {186},
+! pages = {721-739},
+! number = {2},
+! doi = {10.1111/j.1365-246X.2011.05044.x}}
+!
! or
!
! @INCOLLECTION{ChKoViCaVaFe07,
@@ -139,7 +153,19 @@
! pages = {1-32},
! number = {1}}
!
-! or
+! @ARTICLE{PeKoLuMaLeCaLeMaLiBlNiBaTr11,
+! author = {Daniel Peter and Dimitri Komatitsch and Yang Luo and Roland Martin
+! and Nicolas {Le Goff} and Emanuele Casarotti and Pieyre {Le Loher}
+! and Federica Magnoni and Qinya Liu and C\'eline Blitz and Tarje Nissen-Meyer
+! and Piero Basini and Jeroen Tromp},
+! title = {Forward and adjoint simulations of seismic wave propagation on fully
+! unstructured hexahedral meshes},
+! journal={Geophys. J. Int.},
+! year = {2011},
+! volume = {186},
+! pages = {721-739},
+! number = {2},
+! doi = {10.1111/j.1365-246X.2011.05044.x}}
!
! @ARTICLE{LiTr06,
! author={Qinya Liu and Jeroen Tromp},
@@ -197,7 +223,7 @@
! new convention for the name of seismograms, to conform to the IRIS standard;
! new directory structure
!
-! v. 5.0 aka Tiger, many developers some with Princeton Tiger logo on their shirts, February 2010:
+! v. 5.0, many developers, February 2010:
! new moho mesh stretching honoring crust2.0 moho depths,
! new attenuation assignment, new SAC headers, new general crustal models,
! faster performance due to Deville routines and enhanced loop unrolling,
@@ -216,7 +242,7 @@
! added AK135 and 1066a, fixed topography/bathymetry routine,
! new attenuation routines, faster and better I/Os on very large
! systems, many small improvements and bug fixes, new "configure"
-! script, new Pyre version, new user's manual etc.
+! script, new user's manual etc.
!
! v. 3.5 Dimitri Komatitsch, Brian Savage and Jeroen Tromp, Caltech, July 2004:
! any size of chunk, 3D attenuation, case of two chunks,
@@ -280,6 +306,7 @@
! ************** PROGRAM STARTS HERE **************
+
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_1dref.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_1dref.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_1dref.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -7427,6 +7427,5 @@
Mref_V_Qkappa_ref(718:750) = Mref_V_Qkappa_ref(717)
endif
-
end subroutine define_model_1dref
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_ak135.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_ak135.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_ak135.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -26,7 +26,6 @@
!=====================================================================
!--------------------------------------------------------------------------------------------------
-! AK135
!
! Modified AK135 model:
!
@@ -44,6 +43,14 @@
! DOI: 10.1111/j.1365-246X.1995.tb03540.x
!--------------------------------------------------------------------------------------------------
+! J. P. Montagner and B. L. N. Kennett,
+! How to reconcile body-wave and normal-mode reference Earth models?,
+! Geophysical Journal International, volume 122, issue 1, pages 229-248 (1995)
+
+!! DK DK values below entirely checked and fixed by Dimitri Komatitsch in December 2012.
+
+!--------------------------------------------------------------------------------------------------
+
module model_ak135_par
! number of layers in DATA/ak135/ak135.dat
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_aniso_mantle.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_aniso_mantle.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_aniso_mantle.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -92,8 +92,8 @@
subroutine model_aniso_mantle(r,theta,phi,rho, &
- c11,c12,c13,c14,c15,c16, &
- c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66)
+ c11,c12,c13,c14,c15,c16, &
+ c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66)
use model_aniso_mantle_par
@@ -109,6 +109,7 @@
! local parameters
double precision :: d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26, &
d33,d34,d35,d36,d44,d45,d46,d55,d56,d66
+
double precision :: colat,lon
lon = phi / DEGREES_TO_RADIANS
@@ -177,8 +178,11 @@
! dimensionalize
depth = R_EARTH_KM*(R_UNIT_SPHERE - r)
if(depth <= pro(nz0) .or. depth >= pro(1)) call exit_MPI_without_rank('r out of range in build_cij')
- itheta = int(theta + pxy0)/pxy0
- ilon = int(phi + pxy0)/pxy0
+!! DK DK itheta = int(theta + pxy0)/pxy0
+!! DK DK ilon = int(phi + pxy0)/pxy0
+!! DK DK fixed that because the above contained an automatic conversion from real to int
+ itheta = int(int(theta + pxy0)/pxy0)
+ ilon = int(int(phi + pxy0)/pxy0)
tet = theta
ph = phi
@@ -911,7 +915,5 @@
(cosphifour + sinphifour)*(d66*costhetasq + &
d44*sinthetasq + d46*sintwotheta)
-
end subroutine rotate_aniso_tensor
-!--------------------------------------------------------------------
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_atten3D_QRFSI12.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_atten3D_QRFSI12.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_atten3D_QRFSI12.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -295,486 +295,3 @@
endif
end subroutine model_atten3D_QRFSI12
-
-!
-!----------------------------------
-!
-
-!!$ subroutine vbspl(x,np,xarr,splcon,splcond)
-!!$!
-!!$!---- this subroutine returns the spline contributions at a particular value of x
-!!$!
-!!$ implicit none
-!!$
-!!$ integer :: np
-!!$
-!!$ real(kind=4) :: xarr(np),x
-!!$ real(kind=4) :: splcon(np)
-!!$ real(kind=4) :: splcond(np)
-!!$
-!!$ real(kind=4) :: r1,r2,r3,r4,r5,r6,r7,r8,r9,r10,r11,r12,r13
-!!$ real(kind=4) :: r1d,r2d,r3d,r4d,r5d,r6d,r7d,r8d,r9d,r10d,r11d,r12d,r13d,val,vald
-!!$
-!!$ real(kind=4) :: rr1,rr2,rr3,rr4,rr5,rr6,rr7,rr8,rr9,rr10,rr11,rr12
-!!$ real(kind=4) :: rr1d,rr2d,rr3d,rr4d,rr5d,rr6d,rr7d,rr8d,rr9d,rr10d,rr11d,rr12d
-!!$
-!!$ integer :: iflag,interval,ik,ib
-!!$
-!!$!
-!!$!---- iflag=1 ==>> second derivative is 0 at end points
-!!$!---- iflag=0 ==>> first derivative is 0 at end points
-!!$!
-!!$ iflag=1
-!!$!
-!!$!---- first, find out within which interval x falls
-!!$!
-!!$ interval=0
-!!$ ik=1
-!!$ do while(interval == 0.and.ik < np)
-!!$ ik=ik+1
-!!$ if(x >= xarr(ik-1).and.x <= xarr(ik)) interval=ik-1
-!!$ enddo
-!!$ if(x > xarr(np)) then
-!!$ interval=np
-!!$ endif
-!!$
-!!$ if(interval == 0) then
-!!$! write(6,"('low value:',2f10.3)") x,xarr(1)
-!!$ else if(interval > 0.and.interval < np) then
-!!$! write(6,"('bracket:',i5,3f10.3)") interval,xarr(interval),x,xarr(interval+1)
-!!$ else
-!!$! write(6,"('high value:',2f10.3)") xarr(np),x
-!!$ endif
-!!$
-!!$ do ib=1,np
-!!$ val=0.
-!!$ vald=0.
-!!$ if(ib == 1) then
-!!$
-!!$ r1=(x-xarr(1))/(xarr(2)-xarr(1))
-!!$ r2=(xarr(3)-x)/(xarr(3)-xarr(1))
-!!$ r4=(xarr(2)-x)/(xarr(2)-xarr(1))
-!!$ r5=(x-xarr(1))/(xarr(2)-xarr(1))
-!!$ r6=(xarr(3)-x)/(xarr(3)-xarr(1))
-!!$ r10=(xarr(2)-x)/(xarr(2)-xarr(1))
-!!$ r11=(x-xarr(1)) /(xarr(2)-xarr(1))
-!!$ r12=(xarr(3)-x)/(xarr(3)-xarr(2))
-!!$ r13=(xarr(2)-x)/(xarr(2)-xarr(1))
-!!$
-!!$ r1d=1./(xarr(2)-xarr(1))
-!!$ r2d=-1./(xarr(3)-xarr(1))
-!!$ r4d=-1./(xarr(2)-xarr(1))
-!!$ r5d=1./(xarr(2)-xarr(1))
-!!$ r6d=-1./(xarr(3)-xarr(1))
-!!$ r10d=-1./(xarr(2)-xarr(1))
-!!$ r11d=1./(xarr(2)-xarr(1))
-!!$ r12d=-1./(xarr(3)-xarr(2))
-!!$ r13d=-1./(xarr(2)-xarr(1))
-!!$
-!!$ if(interval == ib.or.interval == 0) then
-!!$ if(iflag == 0) then
-!!$ val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11 +r13**3
-!!$ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
-!!$ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
-!!$ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
-!!$ vald=vald+3.*r13d*r13**2
-!!$ else if(iflag == 1) then
-!!$ val=0.6667*(r1*r4*r10 + r2*r5*r10 + r2*r6*r11 &
-!!$ + 1.5*r13**3)
-!!$ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
-!!$ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
-!!$ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
-!!$ vald=vald+4.5*r13d*r13**2
-!!$ vald=0.6667*vald
-!!$ endif
-!!$ else if(interval == ib+1) then
-!!$ if(iflag == 0) then
-!!$ val=r2*r6*r12
-!!$ vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d
-!!$ else if(iflag == 1) then
-!!$ val=0.6667*r2*r6*r12
-!!$ vald=0.6667*(r2d*r6*r12+r2*r6d*r12+r2*r6*r12d)
-!!$ endif
-!!$ else
-!!$ val=0.
-!!$ endif
-!!$
-!!$ else if(ib == 2) then
-!!$
-!!$ rr1=(x-xarr(1))/(xarr(2)-xarr(1))
-!!$ rr2=(xarr(3)-x)/(xarr(3)-xarr(1))
-!!$ rr4=(xarr(2)-x)/(xarr(2)-xarr(1))
-!!$ rr5=(x-xarr(1))/(xarr(2)-xarr(1))
-!!$ rr6=(xarr(3)-x)/(xarr(3)-xarr(1))
-!!$ rr10=(xarr(2)-x)/(xarr(2)-xarr(1))
-!!$ rr11=(x-xarr(1)) /(xarr(2)-xarr(1))
-!!$ rr12=(xarr(3)-x)/(xarr(3)-xarr(2))
-!!$
-!!$ rr1d=1./(xarr(2)-xarr(1))
-!!$ rr2d=-1./(xarr(3)-xarr(1))
-!!$ rr4d=-1./(xarr(2)-xarr(1))
-!!$ rr5d=1./(xarr(2)-xarr(1))
-!!$ rr6d=-1./(xarr(3)-xarr(1))
-!!$ rr10d=-1./(xarr(2)-xarr(1))
-!!$ rr11d=1./(xarr(2)-xarr(1))
-!!$ rr12d=-1./(xarr(3)-xarr(2))
-!!$
-!!$ r1=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
-!!$ r2=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib-1))
-!!$ r3=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
-!!$ r4=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
-!!$ r5=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
-!!$ r6=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib))
-!!$ r8=(xarr(ib)-x)/ (xarr(ib)-xarr(ib-1))
-!!$ r9=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
-!!$ r10=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
-!!$ r11=(x-xarr(ib)) /(xarr(ib+1)-xarr(ib))
-!!$ r12=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib+1))
-!!$
-!!$ r1d=1./(xarr(ib+1)-xarr(ib-1))
-!!$ r2d=-1./(xarr(ib+2)-xarr(ib-1))
-!!$ r3d=1./(xarr(ib)-xarr(ib-1))
-!!$ r4d=-1./(xarr(ib+1)-xarr(ib-1))
-!!$ r5d=1./(xarr(ib+1)-xarr(ib-1))
-!!$ r6d=-1./(xarr(ib+2)-xarr(ib))
-!!$ r8d=-1./ (xarr(ib)-xarr(ib-1))
-!!$ r9d=1./(xarr(ib)-xarr(ib-1))
-!!$ r10d=-1./(xarr(ib+1)-xarr(ib))
-!!$ r11d=1./(xarr(ib+1)-xarr(ib))
-!!$ r12d=-1./(xarr(ib+2)-xarr(ib+1))
-!!$
-!!$ if(interval == ib-1.or.interval == 0) then
-!!$ val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9
-!!$ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
-!!$ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
-!!$ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
-!!$ if(iflag == 1) then
-!!$ val=val+0.3333*(rr1*rr4*rr10 + rr2*rr5*rr10 + &
-!!$ rr2*rr6*rr11)
-!!$ vald=vald+0.3333*(rr1d*rr4*rr10+rr1*rr4d*rr10+ &
-!!$ rr1*rr4*rr10d)
-!!$ vald=vald+0.3333*(rr2d*rr5*rr10+rr2*rr5d*rr10+ &
-!!$ rr2*rr5*rr10d)
-!!$ vald=vald+0.3333*(rr2d*rr6*rr11+rr2*rr6d*rr11+ &
-!!$ rr2*rr6*rr11d)
-!!$ endif
-!!$ else if(interval == ib) then
-!!$ val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11
-!!$ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
-!!$ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
-!!$ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
-!!$ if(iflag == 1) then
-!!$ val=val+0.3333*rr2*rr6*rr12
-!!$ vald=vald+0.3333*(rr2d*rr6*rr12+rr2*rr6d*rr12+ &
-!!$ rr2*rr6*rr12d)
-!!$ endif
-!!$ else if(interval == ib+1) then
-!!$ val=r2*r6*r12
-!!$ vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d
-!!$ else
-!!$ val=0.
-!!$ endif
-!!$ else if(ib == np-1) then
-!!$
-!!$ rr1=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
-!!$ rr2=(xarr(np)-x)/(xarr(np)-xarr(np-1))
-!!$ rr3=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
-!!$ rr4=(xarr(np)-x)/(xarr(np)-xarr(np-1))
-!!$ rr5=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
-!!$ rr7=(x-xarr(np-2))/(xarr(np-1)-xarr(np-2))
-!!$ rr8=(xarr(np)-x)/ (xarr(np)-xarr(np-1))
-!!$ rr9=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
-!!$
-!!$ rr1d=1./(xarr(np)-xarr(np-2))
-!!$ rr2d=-1./(xarr(np)-xarr(np-1))
-!!$ rr3d=1./(xarr(np)-xarr(np-2))
-!!$ rr4d=-1./(xarr(np)-xarr(np-1))
-!!$ rr5d=1./(xarr(np)-xarr(np-1))
-!!$ rr7d=1./(xarr(np-1)-xarr(np-2))
-!!$ rr8d=-1./ (xarr(np)-xarr(np-1))
-!!$ rr9d=1./(xarr(np)-xarr(np-1))
-!!$
-!!$ r1=(x-xarr(ib-2))/(xarr(ib+1)-xarr(ib-2))
-!!$ r2=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
-!!$ r3=(x-xarr(ib-2))/(xarr(ib)-xarr(ib-2))
-!!$ r4=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
-!!$ r5=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
-!!$ r6=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
-!!$ r7=(x-xarr(ib-2))/(xarr(ib-1)-xarr(ib-2))
-!!$ r8=(xarr(ib)-x)/ (xarr(ib)-xarr(ib-1))
-!!$ r9=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
-!!$ r10=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
-!!$ r11=(x-xarr(ib)) /(xarr(ib+1)-xarr(ib))
-!!$
-!!$ r1d=1./(xarr(ib+1)-xarr(ib-2))
-!!$ r2d=-1./(xarr(ib+1)-xarr(ib-1))
-!!$ r3d=1./(xarr(ib)-xarr(ib-2))
-!!$ r4d=-1./(xarr(ib+1)-xarr(ib-1))
-!!$ r5d=1./(xarr(ib+1)-xarr(ib-1))
-!!$ r6d=-1./(xarr(ib+1)-xarr(ib))
-!!$ r7d=1./(xarr(ib-1)-xarr(ib-2))
-!!$ r8d=-1./(xarr(ib)-xarr(ib-1))
-!!$ r9d=1./(xarr(ib)-xarr(ib-1))
-!!$ r10d=-1./(xarr(ib+1)-xarr(ib))
-!!$ r11d=1./(xarr(ib+1)-xarr(ib))
-!!$
-!!$ if(interval == ib-2) then
-!!$ val=r1*r3*r7
-!!$ vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d
-!!$ else if(interval == ib-1) then
-!!$ val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9
-!!$ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
-!!$ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
-!!$ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
-!!$ if(iflag == 1) then
-!!$ val=val+0.3333*rr1*rr3*rr7
-!!$ vald=vald+0.3333*(rr1d*rr3*rr7+rr1*rr3d*rr7+ &
-!!$ rr1*rr3*rr7d)
-!!$ endif
-!!$ else if(interval == ib.or.interval == np) then
-!!$ val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11
-!!$ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
-!!$ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
-!!$ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
-!!$ if(iflag == 1) then
-!!$ val=val+0.3333*(rr1*rr3*rr8 + rr1*rr4*rr9 + &
-!!$ rr2*rr5*rr9)
-!!$ vald=vald+0.3333*(rr1d*rr3*rr8+rr1*rr3d*rr8+ &
-!!$ rr1*rr3*rr8d)
-!!$ vald=vald+0.3333*(rr1d*rr4*rr9+rr1*rr4d*rr9+ &
-!!$ rr1*rr4*rr9d)
-!!$ vald=vald+0.3333*(rr2d*rr5*rr9+rr2*rr5d*rr9+ &
-!!$ rr2*rr5*rr9d)
-!!$ endif
-!!$ else
-!!$ val=0.
-!!$ endif
-!!$ else if(ib == np) then
-!!$
-!!$ r1=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
-!!$ r2=(xarr(np)-x)/(xarr(np)-xarr(np-1))
-!!$ r3=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
-!!$ r4=(xarr(np)-x)/(xarr(np)-xarr(np-1))
-!!$ r5=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
-!!$ r7=(x-xarr(np-2))/(xarr(np-1)-xarr(np-2))
-!!$ r8=(xarr(np)-x)/ (xarr(np)-xarr(np-1))
-!!$ r9=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
-!!$ r13=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
-!!$
-!!$ r1d=1./(xarr(np)-xarr(np-2))
-!!$ r2d=-1./(xarr(np)-xarr(np-1))
-!!$ r3d=1./(xarr(np)-xarr(np-2))
-!!$ r4d=-1./(xarr(np)-xarr(np-1))
-!!$ r5d=1./(xarr(np)-xarr(np-1))
-!!$ r7d=1./(xarr(np-1)-xarr(np-2))
-!!$ r8d=-1./ (xarr(np)-xarr(np-1))
-!!$ r9d=1./(xarr(np)-xarr(np-1))
-!!$ r13d=1./(xarr(np)-xarr(np-1))
-!!$
-!!$ if(interval == np-2) then
-!!$ if(iflag == 0) then
-!!$ val=r1*r3*r7
-!!$ vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d
-!!$ else if(iflag == 1) then
-!!$ val=0.6667*r1*r3*r7
-!!$ vald=0.6667*(r1d*r3*r7+r1*r3d*r7+r1*r3*r7d)
-!!$ endif
-!!$ else if(interval == np-1.or.interval == np) then
-!!$ if(iflag == 0) then
-!!$ val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9 + r13**3
-!!$ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
-!!$ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
-!!$ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
-!!$ vald=vald+3.*r13d*r13**2
-!!$ else if(iflag == 1) then
-!!$ val=0.6667*(r1*r3*r8 + r1*r4*r9 + r2*r5*r9 + &
-!!$ 1.5*r13**3)
-!!$ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
-!!$ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
-!!$ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
-!!$ vald=vald+4.5*r13d*r13**2
-!!$ vald=0.6667*vald
-!!$ endif
-!!$ else
-!!$ val=0.
-!!$ endif
-!!$ else
-!!$
-!!$ r1=(x-xarr(ib-2))/(xarr(ib+1)-xarr(ib-2))
-!!$ r2=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib-1))
-!!$ r3=(x-xarr(ib-2))/(xarr(ib)-xarr(ib-2))
-!!$ r4=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
-!!$ r5=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
-!!$ r6=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib))
-!!$ r7=(x-xarr(ib-2))/(xarr(ib-1)-xarr(ib-2))
-!!$ r8=(xarr(ib)-x)/ (xarr(ib)-xarr(ib-1))
-!!$ r9=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
-!!$ r10=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
-!!$ r11=(x-xarr(ib)) /(xarr(ib+1)-xarr(ib))
-!!$ r12=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib+1))
-!!$
-!!$ r1d=1./(xarr(ib+1)-xarr(ib-2))
-!!$ r2d=-1./(xarr(ib+2)-xarr(ib-1))
-!!$ r3d=1./(xarr(ib)-xarr(ib-2))
-!!$ r4d=-1./(xarr(ib+1)-xarr(ib-1))
-!!$ r5d=1./(xarr(ib+1)-xarr(ib-1))
-!!$ r6d=-1./(xarr(ib+2)-xarr(ib))
-!!$ r7d=1./(xarr(ib-1)-xarr(ib-2))
-!!$ r8d=-1./ (xarr(ib)-xarr(ib-1))
-!!$ r9d=1./(xarr(ib)-xarr(ib-1))
-!!$ r10d=-1./(xarr(ib+1)-xarr(ib))
-!!$ r11d=1./(xarr(ib+1)-xarr(ib))
-!!$ r12d=-1./(xarr(ib+2)-xarr(ib+1))
-!!$
-!!$ if(interval == ib-2) then
-!!$ val=r1*r3*r7
-!!$ vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d
-!!$ else if(interval == ib-1) then
-!!$ val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9
-!!$ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
-!!$ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
-!!$ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
-!!$ else if(interval == ib) then
-!!$ val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11
-!!$ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
-!!$ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
-!!$ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
-!!$ else if(interval == ib+1) then
-!!$ val=r2*r6*r12
-!!$ vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d
-!!$ else
-!!$ val=0.
-!!$ endif
-!!$ endif
-!!$ splcon(ib)=val
-!!$ splcond(ib)=vald
-!!$ enddo
-!!$
-!!$ end subroutine vbspl
-
-!----------------------------------
-!----------------------------------
-
-!!$ subroutine ylm(XLAT,XLON,LMAX,Y,WK1,WK2,WK3)
-!!$
-!!$ implicit none
-!!$
-!!$ complex TEMP,FAC,DFAC
-!!$
-!!$ real(kind=4) WK1(1),WK2(1),WK3(1),Y(1),XLAT,XLON
-!!$
-!!$ integer :: LMAX
-!!$
-!!$!
-!!$! WK1,WK2,WK3 SHOULD BE DIMENSIONED AT LEAST (LMAX+1)*4
-!!$!
-!!$ real(kind=4), parameter :: RADIAN = 57.2957795
-!!$
-!!$ integer :: IM,IL1,IND,LM1,L
-!!$
-!!$ real(kind=4) :: THETA,PHI
-!!$
-!!$ THETA=(90.-XLAT)/RADIAN
-!!$ PHI=XLON/RADIAN
-!!$
-!!$ IND=0
-!!$ LM1=LMAX+1
-!!$
-!!$ DO IL1=1,LM1
-!!$
-!!$ L=IL1-1
-!!$ CALL legndr(THETA,L,L,WK1,WK2,WK3)
-!!$
-!!$ FAC=(1.,0.)
-!!$ DFAC=CEXP(CMPLX(0.,PHI))
-!!$
-!!$ do IM=1,IL1
-!!$ TEMP=FAC*CMPLX(WK1(IM),0.)
-!!$ IND=IND+1
-!!$ Y(IND)=REAL(TEMP)
-!!$ IF(IM == 1) GOTO 20
-!!$ IND=IND+1
-!!$ Y(IND)=AIMAG(TEMP)
-!!$ 20 FAC=FAC*DFAC
-!!$ enddo
-!!$
-!!$ enddo
-!!$
-!!$ end subroutine ylm
-
-!!$ subroutine legndr(THETA,L,M,X,XP,XCOSEC)
-!!$ implicit none
-!!$
-!!$ integer :: L,M,i,k,LP1,MP1
-!!$ real(kind=4) :: THETA,X,XP,XCOSEC,SFL3
-!!$
-!!$ DIMENSION X(2),XP(2),XCOSEC(2)
-!!$ DOUBLE PRECISION SMALL,SUM,COMPAR,CT,ST,FCT,COT,FPI,X1,X2,X3,F1,F2,XM,TH,DSFL3,COSEC
-!!$ DATA FPI/12.56637062D0/
-!!$! DFLOAT(I)=FLOAT(I)
-!!$ SUM=0.D0
-!!$ LP1=L+1
-!!$ TH=THETA
-!!$ CT=DCOS(TH)
-!!$ ST=DSIN(TH)
-!!$ MP1=M+1
-!!$ FCT=DSQRT(dble(FLOAT(2*L+1))/FPI)
-!!$ SFL3=SQRT(FLOAT(L*(L+1)))
-!!$ COMPAR=dble(FLOAT(2*L+1))/FPI
-!!$ DSFL3=SFL3
-!!$ SMALL=1.D-16*COMPAR
-!!$ do I=1,MP1
-!!$ X(I)=0.
-!!$ XCOSEC(I)=0.
-!!$ XP(I)=0.
-!!$ enddo
-!!$ IF(L>1.AND.ABS(THETA)>1.E-5) GO TO 3
-!!$ X(1)=FCT
-!!$ IF(L==0) RETURN
-!!$ X(1)=CT*FCT
-!!$ X(2)=-ST*FCT/DSFL3
-!!$ XP(1)=-ST*FCT
-!!$ XP(2)=-.5D0*CT*FCT*DSFL3
-!!$ IF(ABS(THETA)<1.E-5) XCOSEC(2)=XP(2)
-!!$ IF(ABS(THETA)>=1.E-5) XCOSEC(2)=X(2)/ST
-!!$ RETURN
-!!$ 3 X1=1.D0
-!!$ X2=CT
-!!$ DO I=2,L
-!!$ X3=(dble(FLOAT(2*I-1))*CT*X2-dble(FLOAT(I-1))*X1)/dble(FLOAT(I))
-!!$ X1=X2
-!!$ X2=X3
-!!$ enddo
-!!$ COT=CT/ST
-!!$ COSEC=1./ST
-!!$ X3=X2*FCT
-!!$ X2=dble(FLOAT(L))*(X1-CT*X2)*FCT/ST
-!!$ X(1)=X3
-!!$ X(2)=X2
-!!$ SUM=X3*X3
-!!$ XP(1)=-X2
-!!$ XP(2)=dble(FLOAT(L*(L+1)))*X3-COT*X2
-!!$ X(2)=-X(2)/SFL3
-!!$ XCOSEC(2)=X(2)*COSEC
-!!$ XP(2)=-XP(2)/SFL3
-!!$ SUM=SUM+2.D0*X(2)*X(2)
-!!$ IF(SUM-COMPAR>SMALL) RETURN
-!!$ X1=X3
-!!$ X2=-X2/DSQRT(dble(FLOAT(L*(L+1))))
-!!$ DO I=3,MP1
-!!$ K=I-1
-!!$ F1=DSQRT(dble(FLOAT((L+I-1)*(L-I+2))))
-!!$ F2=DSQRT(dble(FLOAT((L+I-2)*(L-I+3))))
-!!$ XM=K
-!!$ X3=-(2.D0*COT*(XM-1.D0)*X2+F2*X1)/F1
-!!$ SUM=SUM+2.D0*X3*X3
-!!$ IF(SUM-COMPAR>SMALL.AND.I/=LP1) RETURN
-!!$ X(I)=X3
-!!$ XCOSEC(I)=X(I)*COSEC
-!!$ X1=X2
-!!$ XP(I)=-(F1*X2+XM*COT*X3)
-!!$ X2=X3
-!!$ enddo
-!!$ RETURN
-!!$ end subroutine legndr
-
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_attenuation.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_attenuation.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_attenuation.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -34,8 +34,6 @@
! Univeristy of Rhode Island
!
! <savage at uri.edu>.
-! <savage13 at gps.caltech.edu>
-! <savage13 at dtm.ciw.edu>
!
! It is based upon formulation in the following references:
!
@@ -46,11 +44,23 @@
! Velocity dispersion due to anelasticity: implications for seismology and mantle composition
! Geophys, J. R. asts. Soc, Vol 47, pp. 41-58
!
-! The methodology can be found in Savage and Tromp, 2006, unpublished
+! The methodology can be found in Brian Savage, Dimitri Komatitsch and Jeroen Tromp,
+! Effects of 3D attenuation on seismic wave amplitude and phase measurements, Bulletin of the Seismological Society of America,
+! vol. 100(3), p. 1241-1251, doi: 10.1785/0120090263 (2010).
!
+! @ARTICLE{SaKoTr10,
+! author = {Brian Savage and Dimitri Komatitsch and Jeroen Tromp},
+! title = {Effects of {3D} attenuation on seismic wave amplitude and phase measurements},
+! journal = {Bull. Seismol. Soc. Am.},
+! year = {2010},
+! volume = {100},
+! pages = {1241-1251},
+! number = {3},
+! doi = {10.1785/0120090263}}
+!
+!
!--------------------------------------------------------------------------------------------------
-
subroutine model_attenuation_broadcast(myrank,AM_V,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD)
! standard routine to setup model
@@ -99,7 +109,6 @@
call MPI_BCAST(AM_V%QT_c_source, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
call MPI_BCAST(AM_V%Qtau_s, N_SLS, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
-
end subroutine model_attenuation_broadcast
!
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_crust.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_crust.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_crust.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -546,4 +546,3 @@
endif
end subroutine CAP_vardegree
-
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_crustmaps.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_crustmaps.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_crustmaps.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -140,7 +140,7 @@
eucrustp3,eucrustp4,eucrustp5,eucrustp6,eucrustp7,&
eucrusts3,eucrusts4,eucrusts5,eucrusts6,eucrusts7
-!Matthias Meschede
+! Matthias Meschede
call get_value_string(eucrustt3, 'model.eucrustt3','DATA/crustmap/eucrustt3.cmap')
call get_value_string(eucrustt4, 'model.eucrustt4','DATA/crustmap/eucrustt4.cmap')
call get_value_string(eucrustt5, 'model.eucrustt5','DATA/crustmap/eucrustt5.cmap')
@@ -165,8 +165,6 @@
call get_value_string(eucrusts6, 'model.eucrusts6','DATA/crustmap/eucrusts6.cmap')
call get_value_string(eucrusts7, 'model.eucrusts7','DATA/crustmap/eucrusts7.cmap')
-
-
open(unit=1,file=eucrustt3,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
read(1,*) (thickness(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
@@ -197,8 +195,6 @@
enddo
close(1)
-
-
open(unit=1,file=eucrustr3,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
read(1,*) (density(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
@@ -261,8 +257,6 @@
enddo
close(1)
-
-
open(unit=1,file=eucrusts3,status='old',action='read')
do ila=1,180*CRUSTMAP_RESOLUTION
read(1,*) (velocs(ila,iln,1),iln=1,360*CRUSTMAP_RESOLUTION)
@@ -656,4 +650,3 @@
if(ileftlng>360*CRUSTMAP_RESOLUTION) ileftlng=1
end subroutine ibilinearmap
-
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_epcrust.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_epcrust.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_epcrust.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -59,7 +59,6 @@
!--------------------------------------------------------------------------------------------------
!
-
subroutine model_epcrust_broadcast(myrank)
use model_epcrust_par
@@ -118,7 +117,7 @@
character(len=150) EPCRUST_FNM
character(len=150),dimension(15) :: header
double precision,dimension(15) :: tmp
- integer:: ilon, jlat,ier
+ integer:: ilon,jlat,ier
call get_value_string(EPCRUST_FNM,'model.EPCRUST_FNM',PATHNAME_EPCRUST)
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_gll.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_gll.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_gll.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -33,7 +33,6 @@
! used for iterative inversion procedures
!--------------------------------------------------------------------------------------------------
-
subroutine model_gll_broadcast(myrank,MGLL_V,NSPEC)
! standard routine to setup model
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_jp3d.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_jp3d.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_jp3d.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -211,7 +211,6 @@
call MPI_BCAST(JP3DM_RA,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(JP3DM_DEPJ,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
end subroutine model_jp3d_broadcast
!
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_ppm.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_ppm.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_ppm.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -133,7 +133,6 @@
end subroutine model_ppm_broadcast
-
!
!--------------------------------------------------------------------------------------------------
!
@@ -158,8 +157,8 @@
counter=0
open(unit=10,file=trim(filename),status='old',action='read',iostat=ier)
if( ier /= 0 ) then
- write(IMAIN,*) ' error count opening: ',trim(filename)
- call exit_mpi(0,"error count opening model ppm")
+ write(IMAIN,*) ' error opening: ',trim(filename)
+ call exit_mpi(0,"error opening model ppm")
endif
! first line is text and will be ignored
@@ -227,7 +226,6 @@
call exit_mpi(0,' error model PPM ')
endif
-
! gets depths (in km) of upper and lower limit
PPM_minlat = minval( PPM_lat(1:PPM_num_v) )
PPM_maxlat = maxval( PPM_lat(1:PPM_num_v) )
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_s20rts.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_s20rts.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_s20rts.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -169,6 +169,7 @@
! local parameters
! factor to convert perturbations in shear speed to perturbations in density
double precision, parameter :: SCALE_RHO = 0.40d0
+
double precision, parameter :: RMOHO_ = 6346600.d0
double precision, parameter :: RCMB_ = 3480000.d0
double precision, parameter :: R_EARTH_ = 6371000.d0
@@ -240,8 +241,6 @@
implicit none
include "constants.h"
-!!!!!!!!!!!!!!!!!!! double precision spknt(NK_20+1),qq0(NK_20+1,NK_20+1),qq(3,NK_20+1,NK_20+1)
-
! local parameters
integer :: i,j
double precision :: qqwk(3,NK_20+1)
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_s362ani.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_s362ani.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_s362ani.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -164,7 +164,6 @@
integer numvar
integer ierror
-
lu=1 ! --- log unit: input 3-D model
if(THREE_D_MODEL == THREE_D_MODEL_S362ANI) then
modeldef='DATA/s362ani/S362ANI'
@@ -966,9 +965,10 @@
integer :: ncoef,i,ihor,ifst,ilst,ifst1,ios,lstr,nmodkern,idummy,nhorpar,lmax
- open(lu,file=filename,iostat=ios)
- if(ios /= 0) then
- stop 'error opening 3-d model'
+ open(lu,file=filename,status='old',action='read',iostat=ios)
+ if ( ios /= 0 ) then
+ write(IMAIN,*) 'error opening "', trim(filename), '": ', ios
+ call exit_MPI(0, 'error model s362ani')
endif
do while (ios == 0)
read(lu,"(a)",iostat=ios) string
@@ -1084,7 +1084,7 @@
integer :: ncon,nver
-! originally define
+! Daniel Peter: original define
!
! real(kind=4) verlat(1)
! real(kind=4) verlon(1)
@@ -1093,7 +1093,7 @@
! integer icon(1)
! real(kind=4) con(1)
-! avoiding out-of-bounds errors
+! Daniel Peter: avoiding out-of-bounds errors
real(kind=4) verlat(nver)
real(kind=4) verlon(nver)
real(kind=4) verrad(nver)
@@ -1832,7 +1832,6 @@
real(kind=4) :: X(M+1),XP(M+1),XCOSEC(M+1) !! X, XP, XCOSEC should go from 1 to M+1
-
!!!!!! illegal statement, removed by Dimitri Komatitsch DFLOAT(I)=FLOAT(I)
SUM=0.D0
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_s40rts.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_s40rts.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_s40rts.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -40,7 +40,6 @@
! Geophys. J. Int., DOI: 10.1111/j.1365-246X.2010.04884.x
!--------------------------------------------------------------------------------------------------
-
module model_s40rts_par
! three_d_mantle_model_constants
@@ -64,7 +63,6 @@
!--------------------------------------------------------------------------------------------------
!
-
subroutine model_s40rts_broadcast(myrank)
! standard routine to setup model
@@ -173,6 +171,7 @@
! local parameters
! factor to convert perturbations in shear speed to perturbations in density
double precision, parameter :: SCALE_RHO = 0.40d0
+
double precision, parameter :: RMOHO_ = 6346600.d0
double precision, parameter :: RCMB_ = 3480000.d0
double precision, parameter :: R_EARTH_ = 6371000.d0
@@ -244,8 +243,6 @@
implicit none
include "constants.h"
-!!!!!!!!!!!!!!!!!!! double precision spknt(NK_20+1),qq0(NK_20+1,NK_20+1),qq(3,NK_20+1,NK_20+1)
-
! local parameters
integer :: i,j
double precision :: qqwk(3,NK_20+1)
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_sea1d.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_sea1d.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/model_sea1d.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -103,9 +103,9 @@
double precision :: r,frac,scaleval
integer :: i
-!! DK DK UGLY implementation of model sea1d below and its radii in
-!! DK DK UGLY subroutine read_parameter_file.f90 has not been thoroughly
-!! DK DK UGLY checked yet
+!! DK DK implementation of model sea1d below and its radii in
+!! DK DK subroutine read_parameter_file.f90 has not been thoroughly
+!! DK DK checked yet
! compute real physical radius in meters
r = x * R_EARTH
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/moho_stretching.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/moho_stretching.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/moho_stretching.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -25,7 +25,6 @@
!
!=====================================================================
-
subroutine moho_stretching_honor_crust(myrank,xelm,yelm,zelm, &
elem_in_crust,elem_in_mantle)
@@ -54,8 +53,8 @@
double precision :: vpc,vsc,rhoc,moho,elevation,gamma
double precision :: x,y,z
double precision :: R_moho,R_middlecrust
- integer:: ia,count_crust,count_mantle
- logical:: found_crust
+ integer :: ia,count_crust,count_mantle
+ logical :: found_crust
! minimum/maximum allowed moho depths (5km/90km non-dimensionalized)
double precision,parameter :: MOHO_MINIMUM = 5.0 / R_EARTH_KM
@@ -85,6 +84,9 @@
lon = phi * RADIANS_TO_DEGREES
if( lon > 180.0d0 ) lon = lon - 360.0d0
+ ! initializes
+ moho = 0.d0
+
! gets smoothed moho depth
call meshfem3D_model_crust(lat,lon,r,vpc,vsc,rhoc,moho,found_crust,elem_in_crust)
@@ -206,12 +208,10 @@
end subroutine moho_stretching_honor_crust
-
!
!------------------------------------------------------------------------------------------------
!
-
subroutine moho_stretching_honor_crust_reg(myrank,xelm,yelm,zelm, &
elem_in_crust,elem_in_mantle)
@@ -316,8 +316,6 @@
end subroutine moho_stretching_honor_crust_reg
-
-
!
!-------------------------------------------------------------------------------------------------
!
@@ -636,295 +634,3 @@
r = dsqrt(xelm(ia)*xelm(ia) + yelm(ia)*yelm(ia) + zelm(ia)*zelm(ia))
end subroutine move_point
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-! obsolete...
-!
-! subroutine moho_stretching(myrank,xelm,yelm,zelm,RMOHO,R220)
-!
-! implicit none
-!
-! include "constants.h"
-!
-!! ocean-continent function maximum spherical harmonic degree
-! integer, parameter :: NL_OCEAN_CONTINENT = 12
-!
-!! spherical harmonic coefficients of the ocean-continent function (km)
-! double precision A_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT), &
-! B_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT)
-!
-! common /smooth_moho/ A_lm,B_lm
-!
-! integer myrank
-!
-! double precision xelm(NGNOD)
-! double precision yelm(NGNOD)
-! double precision zelm(NGNOD)
-!
-! double precision RMOHO,R220
-!
-! integer ia
-!
-! integer l,m
-! double precision r,theta,phi
-! double precision sint,cost,x(2*NL_OCEAN_CONTINENT+1),dx(2*NL_OCEAN_CONTINENT+1)
-! double precision elevation
-! double precision gamma
-!
-!! we loop on all the points of the element
-! do ia = 1,NGNOD
-!
-!! convert to r theta phi
-! call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
-! call reduce(theta,phi)
-!
-! elevation = 0.0d0
-! do l = 0,NL_OCEAN_CONTINENT
-! sint = dsin(theta)
-! cost = dcos(theta)
-! call lgndr(l,cost,sint,x,dx)
-! m = 0
-! elevation = elevation + A_lm(l,m)*x(m+1)
-! do m = 1,l
-! elevation = elevation + (A_lm(l,m)*dcos(dble(m)*phi)+B_lm(l,m)*dsin(dble(m)*phi))*x(m+1)
-! enddo
-! enddo
-! elevation = -0.25d0*elevation/R_EARTH_KM
-!
-! gamma = 0.0d0
-! if(r >= RMOHO/R_EARTH) then
-!! stretching above the Moho
-! gamma = (1.0d0 - r) / (1.0d0 - RMOHO/R_EARTH)
-! else if(r>= R220/R_EARTH .and. r< RMOHO/R_EARTH) then
-!! stretching between R220 and RMOHO
-! gamma = (r - R220/R_EARTH) / (RMOHO/R_EARTH - R220/R_EARTH)
-! endif
-! if(gamma < -0.0001 .or. gamma > 1.0001) &
-! call exit_MPI(myrank,'incorrect value of gamma for Moho topography')
-!
-! xelm(ia) = xelm(ia)*(ONE + gamma * elevation / r)
-! yelm(ia) = yelm(ia)*(ONE + gamma * elevation / r)
-! zelm(ia) = zelm(ia)*(ONE + gamma * elevation / r)
-!
-! enddo
-!
-! end subroutine moho_stretching
-!
-!
-!-------------------------------------------------------------------------------------------------
-!
-!
-! subroutine read_smooth_moho
-!
-! implicit none
-!
-!! ocean-continent function maximum spherical harmonic degree
-! integer, parameter :: NL_OCEAN_CONTINENT = 12
-!
-!! spherical harmonic coefficients of the ocean-continent function (km)
-! double precision A_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT), &
-! B_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT)
-!
-! common /smooth_moho/ A_lm,B_lm
-!
-!! integer l,m
-!!
-!! ocean-continent function (km)
-!! open(unit=10,file='DATA/ocean_continent_function/ocean_continent_function.txt', &
-!! status='old',action='read')
-!! do l=0,NL_OCEAN_CONTINENT
-!! read(10,*) A_lm(l,0),(A_lm(l,m),B_lm(l,m),m=1,l)
-!! enddo
-!! close(10)
-!
-! A_lm(0,0) = -3.8201999E-04
-! B_lm(0,0) = 0.
-! A_lm(1,0) = 13.88800
-! B_lm(1,0) = 0.
-! A_lm(1,1) = -15.24000
-! B_lm(1,1) = -9.187200
-! A_lm(2,0) = 11.21500
-! B_lm(2,0) = 0.
-! A_lm(2,1) = -6.754500
-! B_lm(2,1) = -8.516700
-! A_lm(2,2) = -8.327800
-! B_lm(2,2) = -5.029200
-! A_lm(3,0) = -3.614500
-! B_lm(3,0) = 0.
-! A_lm(3,1) = 5.394800
-! B_lm(3,1) = -0.9220800
-! A_lm(3,2) = -10.05100
-! B_lm(3,2) = 13.98100
-! A_lm(3,3) = -2.711200
-! B_lm(3,3) = -13.57100
-! A_lm(4,0) = 7.523300
-! B_lm(4,0) = 0.
-! A_lm(4,1) = 5.156100
-! B_lm(4,1) = 2.184400
-! A_lm(4,2) = -10.67300
-! B_lm(4,2) = 2.640600
-! A_lm(4,3) = -7.786300
-! B_lm(4,3) = 0.3674500
-! A_lm(4,4) = -3.076400
-! B_lm(4,4) = 16.83000
-! A_lm(5,0) = -9.681000
-! B_lm(5,0) = 0.
-! A_lm(5,1) = 0.5026800
-! B_lm(5,1) = 2.111300
-! A_lm(5,2) = -2.931000
-! B_lm(5,2) = -4.329000
-! A_lm(5,3) = -1.766800
-! B_lm(5,3) = -3.621200
-! A_lm(5,4) = 16.08200
-! B_lm(5,4) = -4.493900
-! A_lm(5,5) = -0.3705800
-! B_lm(5,5) = -5.574500
-! A_lm(6,0) = 4.407900
-! B_lm(6,0) = 0.
-! A_lm(6,1) = 0.3799000
-! B_lm(6,1) = 1.589400
-! A_lm(6,2) = -1.886400
-! B_lm(6,2) = -0.5686300
-! A_lm(6,3) = -0.9816800
-! B_lm(6,3) = -5.827800
-! A_lm(6,4) = 3.620600
-! B_lm(6,4) = -2.713100
-! A_lm(6,5) = 1.445600
-! B_lm(6,5) = 3.964100
-! A_lm(6,6) = 1.167400
-! B_lm(6,6) = 2.134100
-! A_lm(7,0) = -4.086100
-! B_lm(7,0) = 0.
-! A_lm(7,1) = 0.5462000
-! B_lm(7,1) = -4.488100
-! A_lm(7,2) = 3.116400
-! B_lm(7,2) = 1.793600
-! A_lm(7,3) = 2.594600
-! B_lm(7,3) = -2.129100
-! A_lm(7,4) = -5.445000
-! B_lm(7,4) = 0.5381500
-! A_lm(7,5) = -2.178100
-! B_lm(7,5) = 1.766700
-! A_lm(7,6) = -1.040000
-! B_lm(7,6) = -5.541000
-! A_lm(7,7) = 1.536500
-! B_lm(7,7) = 3.700600
-! A_lm(8,0) = -2.562200
-! B_lm(8,0) = 0.
-! A_lm(8,1) = 0.3736200
-! B_lm(8,1) = 1.488000
-! A_lm(8,2) = 1.347500
-! B_lm(8,2) = 0.5288200
-! A_lm(8,3) = -0.8493700
-! B_lm(8,3) = -1.626500
-! A_lm(8,4) = 0.2423400
-! B_lm(8,4) = 4.202800
-! A_lm(8,5) = 2.052200
-! B_lm(8,5) = 0.6880400
-! A_lm(8,6) = 2.838500
-! B_lm(8,6) = 2.835700
-! A_lm(8,7) = -4.981400
-! B_lm(8,7) = -1.883100
-! A_lm(8,8) = -1.102800
-! B_lm(8,8) = -1.951700
-! A_lm(9,0) = -1.202100
-! B_lm(9,0) = 0.
-! A_lm(9,1) = 1.020300
-! B_lm(9,1) = 1.371000
-! A_lm(9,2) = -0.3430100
-! B_lm(9,2) = 0.8782800
-! A_lm(9,3) = -0.4462500
-! B_lm(9,3) = -0.3046100
-! A_lm(9,4) = 0.7750700
-! B_lm(9,4) = 2.351600
-! A_lm(9,5) = -2.092600
-! B_lm(9,5) = -2.377100
-! A_lm(9,6) = 0.3126900
-! B_lm(9,6) = 4.996000
-! A_lm(9,7) = -2.284000
-! B_lm(9,7) = 1.183700
-! A_lm(9,8) = 1.445900
-! B_lm(9,8) = 1.080000
-! A_lm(9,9) = 1.146700
-! B_lm(9,9) = 1.457800
-! A_lm(10,0) = -2.516900
-! B_lm(10,0) = 0.
-! A_lm(10,1) = -0.9739500
-! B_lm(10,1) = -0.7195500
-! A_lm(10,2) = -2.846000
-! B_lm(10,2) = -1.464700
-! A_lm(10,3) = 2.720100
-! B_lm(10,3) = 0.8241400
-! A_lm(10,4) = -1.247800
-! B_lm(10,4) = 1.220300
-! A_lm(10,5) = -1.638500
-! B_lm(10,5) = -1.099500
-! A_lm(10,6) = 3.043000
-! B_lm(10,6) = -1.976400
-! A_lm(10,7) = -1.007300
-! B_lm(10,7) = -1.604900
-! A_lm(10,8) = 0.6620500
-! B_lm(10,8) = -1.135000
-! A_lm(10,9) = -3.576800
-! B_lm(10,9) = 0.5554900
-! A_lm(10,10) = 2.418700
-! B_lm(10,10) = -1.482200
-! A_lm(11,0) = 0.7158800
-! B_lm(11,0) = 0.
-! A_lm(11,1) = -3.694800
-! B_lm(11,1) = 0.8491400
-! A_lm(11,2) = 9.3208998E-02
-! B_lm(11,2) = -1.276000
-! A_lm(11,3) = 1.575600
-! B_lm(11,3) = 0.1972100
-! A_lm(11,4) = 0.8989600
-! B_lm(11,4) = -1.063000
-! A_lm(11,5) = -0.6301000
-! B_lm(11,5) = -1.329400
-! A_lm(11,6) = 1.389000
-! B_lm(11,6) = 1.184100
-! A_lm(11,7) = 0.5640700
-! B_lm(11,7) = 2.286200
-! A_lm(11,8) = 1.530300
-! B_lm(11,8) = 0.7677500
-! A_lm(11,9) = 0.8495500
-! B_lm(11,9) = 0.7247500
-! A_lm(11,10) = 2.106800
-! B_lm(11,10) = 0.6588000
-! A_lm(11,11) = 0.6067800
-! B_lm(11,11) = 0.1366800
-! A_lm(12,0) = -2.598700
-! B_lm(12,0) = 0.
-! A_lm(12,1) = -1.150500
-! B_lm(12,1) = -0.8425700
-! A_lm(12,2) = -0.1593300
-! B_lm(12,2) = -1.241400
-! A_lm(12,3) = 1.508600
-! B_lm(12,3) = 0.3385500
-! A_lm(12,4) = -1.941200
-! B_lm(12,4) = 1.120000
-! A_lm(12,5) = -0.4630500
-! B_lm(12,5) = -6.4753003E-02
-! A_lm(12,6) = 0.8967000
-! B_lm(12,6) = 4.7417998E-02
-! A_lm(12,7) = 4.5407999E-02
-! B_lm(12,7) = 0.8876400
-! A_lm(12,8) = -2.444400
-! B_lm(12,8) = 1.172500
-! A_lm(12,9) = -2.593400
-! B_lm(12,9) = 0.1703700
-! A_lm(12,10) = 0.5662700
-! B_lm(12,10) = 0.7050800
-! A_lm(12,11) = -0.1930000
-! B_lm(12,11) = -2.008100
-! A_lm(12,12) = -3.187900
-! B_lm(12,12) = -1.672000
-!
-! end subroutine read_smooth_moho
-
-
-
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -255,7 +255,6 @@
close(27) ! solver_data.bin
-
! absorbing boundary parameters
open(unit=27,file=prname(1:len_trim(prname))//'boundary.bin', &
status='unknown',form='unformatted',action='write',iostat=ier)
@@ -312,7 +311,6 @@
close(27)
endif
-
! uncomment for vp & vs model storage
if( SAVE_MESH_FILES ) then
! outputs model files in binary format
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/sort_array_coordinates.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/sort_array_coordinates.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/sort_array_coordinates.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -147,7 +147,7 @@
if(n == 1) return
- L = floor(n/2.0) + 1
+ L = n/2 + 1
ir = n
do while( .true. )
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/calc_jacobian.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/calc_jacobian.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/calc_jacobian.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -76,11 +76,10 @@
double precision,dimension(NGLLY):: hetar,hpetar
double precision,dimension(NGLLZ):: hgammar,hpgammar
double precision:: hlagrange,hlagrange_xi,hlagrange_eta,hlagrange_gamma
- double precision:: jacobian
+ double precision:: jacobian,jacobian_inv
double precision:: xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
double precision:: r,theta,phi
-
! test parameters which can be deleted
double precision:: xmesh,ymesh,zmesh
double precision:: sumshape,sumdershapexi,sumdershapeeta,sumdershapegamma
@@ -118,84 +117,88 @@
ymesh = ZERO
zmesh = ZERO
+ do k1 = 1,NGLLZ
+ do j1 = 1,NGLLY
+ do i1 = 1,NGLLX
+ hlagrange = hxir(i1)*hetar(j1)*hgammar(k1)
+ hlagrange_xi = hpxir(i1)*hetar(j1)*hgammar(k1)
+ hlagrange_eta = hxir(i1)*hpetar(j1)*hgammar(k1)
+ hlagrange_gamma = hxir(i1)*hetar(j1)*hpgammar(k1)
- do k1 = 1,NGLLZ
- do j1 = 1,NGLLY
- do i1 = 1,NGLLX
- hlagrange = hxir(i1)*hetar(j1)*hgammar(k1)
- hlagrange_xi = hpxir(i1)*hetar(j1)*hgammar(k1)
- hlagrange_eta = hxir(i1)*hpetar(j1)*hgammar(k1)
- hlagrange_gamma = hxir(i1)*hetar(j1)*hpgammar(k1)
+ xxi = xxi + xstore(i1,j1,k1,ispec)*hlagrange_xi
+ xeta = xeta + xstore(i1,j1,k1,ispec)*hlagrange_eta
+ xgamma = xgamma + xstore(i1,j1,k1,ispec)*hlagrange_gamma
+ yxi = yxi + ystore(i1,j1,k1,ispec)*hlagrange_xi
+ yeta = yeta + ystore(i1,j1,k1,ispec)*hlagrange_eta
+ ygamma = ygamma + ystore(i1,j1,k1,ispec)*hlagrange_gamma
- xxi = xxi + xstore(i1,j1,k1,ispec)*hlagrange_xi
- xeta = xeta + xstore(i1,j1,k1,ispec)*hlagrange_eta
- xgamma = xgamma + xstore(i1,j1,k1,ispec)*hlagrange_gamma
+ zxi = zxi + zstore(i1,j1,k1,ispec)*hlagrange_xi
+ zeta = zeta + zstore(i1,j1,k1,ispec)*hlagrange_eta
+ zgamma = zgamma + zstore(i1,j1,k1,ispec)*hlagrange_gamma
- yxi = yxi + ystore(i1,j1,k1,ispec)*hlagrange_xi
- yeta = yeta + ystore(i1,j1,k1,ispec)*hlagrange_eta
- ygamma = ygamma + ystore(i1,j1,k1,ispec)*hlagrange_gamma
+ ! test the lagrange polynomial and its derivate
+ xmesh = xmesh + xstore(i1,j1,k1,ispec)*hlagrange
+ ymesh = ymesh + ystore(i1,j1,k1,ispec)*hlagrange
+ zmesh = zmesh + zstore(i1,j1,k1,ispec)*hlagrange
+ sumshape = sumshape + hlagrange
+ sumdershapexi = sumdershapexi + hlagrange_xi
+ sumdershapeeta = sumdershapeeta + hlagrange_eta
+ sumdershapegamma = sumdershapegamma + hlagrange_gamma
- zxi = zxi + zstore(i1,j1,k1,ispec)*hlagrange_xi
- zeta = zeta + zstore(i1,j1,k1,ispec)*hlagrange_eta
- zgamma = zgamma + zstore(i1,j1,k1,ispec)*hlagrange_gamma
-
- ! test the lagrange polynomial and its derivate
- xmesh = xmesh + xstore(i1,j1,k1,ispec)*hlagrange
- ymesh = ymesh + ystore(i1,j1,k1,ispec)*hlagrange
- zmesh = zmesh + zstore(i1,j1,k1,ispec)*hlagrange
- sumshape = sumshape + hlagrange
- sumdershapexi = sumdershapexi + hlagrange_xi
- sumdershapeeta = sumdershapeeta + hlagrange_eta
- sumdershapegamma = sumdershapegamma + hlagrange_gamma
-
- enddo
- enddo
enddo
+ enddo
+ enddo
- ! Check the lagrange polynomial and its derivative
- if (abs(xmesh - xstore(i,j,k,ispec)) > TINYVAL &
- .or. abs(ymesh - ystore(i,j,k,ispec)) > TINYVAL &
- .or. abs(zmesh - zstore(i,j,k,ispec)) > TINYVAL ) then
- call exit_MPI(myrank,'new mesh are wrong in recalc_jacobian_gall3D.f90')
- endif
- if(abs(sumshape-one) > TINYVAL) then
- call exit_MPI(myrank,'error shape functions in recalc_jacobian_gll3D.f90')
- endif
- if(abs(sumdershapexi) > TINYVAL) then
- call exit_MPI(myrank,'error derivative xi in recalc_jacobian_gll3D.f90')
- endif
- if(abs(sumdershapeeta) > TINYVAL) then
- call exit_MPI(myrank,'error derivative eta in recalc_jacobian_gll3D.f90')
- endif
- if(abs(sumdershapegamma) > TINYVAL) then
- call exit_MPI(myrank,'error derivative gamma in recalc_jacobian_gll3D.f90')
- endif
+ ! Check the lagrange polynomial and its derivative
+ if (abs(xmesh - xstore(i,j,k,ispec)) > TINYVAL &
+ .or. abs(ymesh - ystore(i,j,k,ispec)) > TINYVAL &
+ .or. abs(zmesh - zstore(i,j,k,ispec)) > TINYVAL ) then
+ call exit_MPI(myrank,'new mesh is wrong in recalc_jacobian_gll3D.f90')
+ endif
+ if(abs(sumshape-one) > TINYVAL) then
+ call exit_MPI(myrank,'error shape functions in recalc_jacobian_gll3D.f90')
+ endif
+ if(abs(sumdershapexi) > TINYVAL) then
+ call exit_MPI(myrank,'error derivative xi in recalc_jacobian_gll3D.f90')
+ endif
+ if(abs(sumdershapeeta) > TINYVAL) then
+ call exit_MPI(myrank,'error derivative eta in recalc_jacobian_gll3D.f90')
+ endif
+ if(abs(sumdershapegamma) > TINYVAL) then
+ call exit_MPI(myrank,'error derivative gamma in recalc_jacobian_gll3D.f90')
+ endif
+ ! jacobian calculation
+ jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
+ xeta*(yxi*zgamma-ygamma*zxi) + &
+ xgamma*(yxi*zeta-yeta*zxi)
- jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
- xeta*(yxi*zgamma-ygamma*zxi) + &
- xgamma*(yxi*zeta-yeta*zxi)
+ ! Check the jacobian
+ ! note: when honoring the moho, we squeeze and stretch elements
+ ! thus, it can happen that with a coarse mesh resolution, the jacobian encounters problems
+ if(jacobian <= VERYSMALLVAL) then
+ call xyz_2_rthetaphi_dble(xmesh,ymesh,zmesh,r,theta,phi)
+ print*,'error jacobian rank:',myrank
+ print*,' location r/lat/lon: ',r*R_EARTH_KM, &
+ (PI_OVER_TWO-theta)*RADIANS_TO_DEGREES,phi*RADIANS_TO_DEGREES
+ print*,' jacobian: ',jacobian
+ call exit_MPI(myrank,'3D Jacobian undefined in recalc_jacobian_gll3D.f90')
+ endif
- ! 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')
- endif
+ ! invert the relation (Fletcher p. 50 vol. 2)
+ jacobian_inv = ONE / jacobian
- ! invert the relation (Fletcher p. 50 vol. 2)
- xix = (yeta*zgamma-ygamma*zeta) / jacobian
- xiy = (xgamma*zeta-xeta*zgamma) / jacobian
- xiz = (xeta*ygamma-xgamma*yeta) / jacobian
- etax = (ygamma*zxi-yxi*zgamma) / jacobian
- etay = (xxi*zgamma-xgamma*zxi) / jacobian
- etaz = (xgamma*yxi-xxi*ygamma) / jacobian
- gammax = (yxi*zeta-yeta*zxi) / jacobian
- gammay = (xeta*zxi-xxi*zeta) / jacobian
- gammaz = (xxi*yeta-xeta*yxi) / jacobian
+ xix = (yeta*zgamma-ygamma*zeta) * jacobian_inv
+ xiy = (xgamma*zeta-xeta*zgamma) * jacobian_inv
+ xiz = (xeta*ygamma-xgamma*yeta) * jacobian_inv
+ etax = (ygamma*zxi-yxi*zgamma) * jacobian_inv
+ etay = (xxi*zgamma-xgamma*zxi) * jacobian_inv
+ etaz = (xgamma*yxi-xxi*ygamma) * jacobian_inv
+ gammax = (yxi*zeta-yeta*zxi) * jacobian_inv
+ gammay = (xeta*zxi-xxi*zeta) * jacobian_inv
+ gammaz = (xxi*yeta-xeta*yxi) * jacobian_inv
-
! resave the derivatives and the jacobian
! distinguish between single and double precision for reals
if (ACTUALLY_STORE_ARRAYS) then
@@ -261,12 +264,11 @@
real(kind=CUSTOM_REAL),dimension(NGLLA,NGLLB,NSPEC2DMAX_AB)::jacobian2D
real(kind=CUSTOM_REAL),dimension(3,NGLLA,NGLLB,NSPEC2DMAX_AB)::normal
-
! local parameters in this subroutine
integer::i,j,i1,j1
double precision::xxi,xeta,yxi,yeta,zxi,zeta,&
- xi,eta,xmesh,ymesh,zmesh,hlagrange,hlagrange_xi,hlagrange_eta,&
- sumshape,sumdershapexi,sumdershapeeta,unx,uny,unz,jacobian
+ xi,eta,xmesh,ymesh,zmesh,hlagrange,hlagrange_xi,hlagrange_eta,&
+ sumshape,sumdershapexi,sumdershapeeta,unx,uny,unz,jacobian,jacobian_inv
double precision,dimension(NGLLA)::hxir,hpxir
double precision,dimension(NGLLB)::hetar,hpetar
@@ -285,13 +287,13 @@
call lagrange_any(xi,NGLLA,xigll,hxir,hpxir)
call lagrange_any(eta,NGLLB,yigll,hetar,hpetar)
+ xmesh = ZERO
+ ymesh = ZERO
+ zmesh = ZERO
+ sumshape = ZERO
+ sumdershapexi = ZERO
+ sumdershapeeta = ZERO
- xmesh = 0.0
- ymesh = 0.0
- zmesh = 0.0
- sumshape = 0.0
- sumdershapexi = 0.0
- sumdershapeeta = 0.0
do j1 = 1,NGLLB
do i1 = 1,NGLLA
hlagrange = hxir(i1)*hetar(j1)
@@ -334,22 +336,29 @@
call exit_MPI(myrank,'error derivative eta in recalc_jacobian_gll2D')
endif
+ ! calculates j2D acobian
unx = yxi*zeta - yeta*zxi
uny = zxi*xeta - zeta*xxi
unz = xxi*yeta - xeta*yxi
- jacobian = dsqrt(unx**2+uny**2+unz**2)
- if (abs(jacobian) < TINYVAL ) call exit_MPI(myrank,'2D Jacobian undefined in recalc_jacobian_gll2D')
+ jacobian = dsqrt(unx*unx + uny*uny + unz*unz)
+ ! checks
+ if (abs(jacobian) < TINYVAL ) &
+ call exit_MPI(myrank,'2D Jacobian undefined in recalc_jacobian_gll2D')
+
+ ! inverts jacobian
+ jacobian_inv = ONE / jacobian
+
if (CUSTOM_REAL == SIZE_REAL) then
- jacobian2D(i,j,ispecb)=sngl(jacobian)
- normal(1,i,j,ispecb)=sngl(unx/jacobian)
- normal(2,i,j,ispecb)=sngl(uny/jacobian)
- normal(3,i,j,ispecb)=sngl(unz/jacobian)
+ jacobian2D(i,j,ispecb) = sngl(jacobian)
+ normal(1,i,j,ispecb) = sngl(unx * jacobian_inv)
+ normal(2,i,j,ispecb) = sngl(uny * jacobian_inv)
+ normal(3,i,j,ispecb) = sngl(unz * jacobian_inv)
else
- jacobian2D(i,j,ispecb)=jacobian
- normal(1,i,j,ispecb)=unx/jacobian
- normal(2,i,j,ispecb)=uny/jacobian
- normal(3,i,j,ispecb)=unz/jacobian
+ jacobian2D(i,j,ispecb) = jacobian
+ normal(1,i,j,ispecb) = unx * jacobian_inv
+ normal(2,i,j,ispecb) = uny * jacobian_inv
+ normal(3,i,j,ispecb) = unz * jacobian_inv
endif
enddo
enddo
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/compute_coordinates_grid.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/compute_coordinates_grid.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/compute_coordinates_grid.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -60,9 +60,6 @@
double precision :: ratio_xi, ratio_eta, fact_xi, fact_eta, &
fact_xi_,fact_eta_
- double precision, parameter :: PI_OVER_TWO = PI / 2.d0
-
-
! this to avoid compilation warnings
x_=0
y_=0
@@ -297,7 +294,6 @@
! local variables
double precision :: ratio_x,ratio_y,ratio_z
double precision :: fact_x,fact_y,fact_z,xi,eta,gamma
- double precision, parameter :: PI_OVER_TWO = PI / 2.d0
! the slice extends to the entire cube along Z
! but only to current block along X and Y
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/compute_element_properties.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/compute_element_properties.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/compute_element_properties.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -56,12 +56,10 @@
R400,R120,R80,RMIDDLE_CRUST,ROCEAN,RMOHO_FICTITIOUS_IN_MESHER
! arrays with the mesh in double precision
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
! code for the four regions of the mesh
- integer iregion_code
+ integer :: iregion_code
! 3D shape functions and their derivatives
double precision, dimension(NGNOD,NGLLX,NGLLY,NGLLZ) :: shape3D
@@ -70,42 +68,52 @@
! parameters needed to store the radii of the grid points
! in the spherically symmetric Earth
- integer idoubling(nspec)
- double precision rmin,rmax
+ integer,dimension(nspec) :: idoubling
+ double precision :: rmin,rmax
! for model density and anisotropy
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rhostore,dvpstore,kappavstore, &
kappahstore,muvstore,muhstore,eta_anisostore
! the 21 coefficients for an anisotropic medium in reduced notation
- integer nspec_ani
+ integer :: nspec_ani
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_ani) :: &
c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
c36store,c44store,c45store,c46store,c55store,c56store,c66store
! arrays with mesh parameters
- integer nspec_actually
+ integer :: nspec_actually
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_actually) :: &
xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
! proc numbers for MPI
- integer myrank
+ integer :: myrank
! Stacey, indices for Clayton-Engquist absorbing conditions
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_stacey) :: rho_vp,rho_vs
! attenuation
- integer nspec_att
+ integer :: nspec_att
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013: BEWARE, declared real(kind=CUSTOM_REAL) in trunk and
+!! DK DK to Daniel, Jul 2013: double precision in branch, let us check which one is right
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_att) :: Qmu_store
real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,nspec_att) :: tau_e_store
double precision, dimension(N_SLS) :: tau_s
- double precision T_c_source
+ double precision :: T_c_source
! Parameters used to calculate Jacobian based upon 125 GLL points
- double precision:: xigll(NGLLX)
- double precision:: yigll(NGLLY)
- double precision:: zigll(NGLLZ)
+ double precision :: xigll(NGLLX)
+ double precision :: yigll(NGLLY)
+ double precision :: zigll(NGLLZ)
logical, dimension(nspec) :: ispec_is_tiso
@@ -114,7 +122,7 @@
! flag for transverse isotropic elements
logical:: elem_is_tiso
- ! add topography of the Moho *before* adding the 3D crustal velocity model so that the streched
+ ! add topography of the Moho *before* adding the 3D crustal velocity model so that the stretched
! mesh gets assigned the right model values
elem_in_crust = .false.
elem_in_mantle = .false.
@@ -129,13 +137,11 @@
! differentiate between regional and global meshing
if( REGIONAL_MOHO_MESH ) then
- call moho_stretching_honor_crust_reg(myrank, &
- xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER,&
- R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
+ call moho_stretching_honor_crust_reg(myrank,xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER, &
+ R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
else
- call moho_stretching_honor_crust(myrank, &
- xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER,&
- R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
+ call moho_stretching_honor_crust(myrank,xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER, &
+ R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
endif
else
! element below 220km
@@ -215,8 +221,9 @@
! problems with the jacobian. using the anchors is therefore more robust.
! adds surface topography
if( TOPOGRAPHY ) then
- if (idoubling(ispec)==IFLAG_CRUST .or. idoubling(ispec)==IFLAG_220_80 &
- .or. idoubling(ispec)==IFLAG_80_MOHO) then
+ if(idoubling(ispec) == IFLAG_CRUST .or. &
+ idoubling(ispec) == IFLAG_220_80 .or. &
+ idoubling(ispec) == IFLAG_80_MOHO) then
! stretches mesh between surface and R220 accordingly
if( USE_GLL ) then
! stretches every gll point accordingly
@@ -304,21 +311,17 @@
include "constants.h"
- integer ispec,nspec
+ integer :: ispec,nspec
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
+ double precision,dimension(NGNOD) :: xelm,yelm,zelm
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
- double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
+ double precision,dimension(NGNOD,NGLLX,NGLLY,NGLLZ) :: shape3D
! local parameters
- double precision xmesh,ymesh,zmesh
- integer i,j,k,ia
+ double precision :: xmesh,ymesh,zmesh
+ integer :: i,j,k,ia
do k=1,NGLLZ
do j=1,NGLLY
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_central_cube.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_central_cube.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_central_cube.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -113,7 +113,17 @@
integer iproc_xi,iproc_eta,ichunk
! attenuation
- integer nspec_att
+ integer :: nspec_att
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013: BEWARE, declared real(kind=CUSTOM_REAL) in trunk and
+!! DK DK to Daniel, Jul 2013: double precision in branch, let us check which one is right
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_att) :: Qmu_store
real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,nspec_att) :: tau_e_store
double precision, dimension(N_SLS) :: tau_s
@@ -268,8 +278,8 @@
c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- nspec_ani,nspec_stacey,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
- rho_vp,rho_vs,ACTUALLY_STORE_ARRAYS,&
+ nspec_ani,nspec_stacey,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
+ rho_vp,rho_vs,ACTUALLY_STORE_ARRAYS, &
xigll,yigll,zigll,ispec_is_tiso)
enddo
enddo
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_chunk_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_chunk_buffers.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_chunk_buffers.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -44,25 +44,33 @@
include "constants.h"
include "precision.h"
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_CORNER
+ integer :: iregion_code
+ integer :: nspec
- integer nglob,nglob_ori
- integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
- integer NPROC,NPROC_XI,NPROC_ETA,NPROCTOT,NGLOB1D_RADIAL_MAX,NGLOB1D_RADIAL
- integer NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
- integer nspec
- integer myrank,NCHUNKS
+ ! array with the local to global mapping per slice
+ integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ integer,dimension(nspec) :: idoubling
! arrays with the mesh
double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
- character(len=150) OUTPUT_FILES,LOCAL_PATH,ERR_MSG
+ integer :: nglob_ori
+ integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
+ integer NPROC,NPROC_XI,NPROC_ETA,NPROCTOT
+ integer myrank,NCHUNKS
-! array with the local to global mapping per slice
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+ character(len=150) LOCAL_PATH
- integer idoubling(nspec)
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_CORNER
+ integer :: NGLOB1D_RADIAL_MAX
+ integer :: NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
+
+ ! local parameters
+ integer :: nglob
+ integer :: NGLOB1D_RADIAL
+ character(len=150) :: OUTPUT_FILES,ERR_MSG
+
! mask for ibool to mark points already found
logical, dimension(:), allocatable :: mask_ibool
@@ -80,19 +88,17 @@
! pairs generated theoretically
! four sides for each of the three types of messages
- integer, dimension(:), allocatable :: iproc_sender,iproc_receiver,npoin2D_send,npoin2D_receive
+ integer, dimension(:), allocatable :: npoin2D_send,npoin2D_receive,iproc_sender,iproc_receiver
+ integer :: ibool1D(NGLOB1D_RADIAL_MAX)
+ double precision,dimension(NGLOB1D_RADIAL_MAX) :: xread1D,yread1D,zread1D
! 1D buffers to remove points belonging to corners
integer ibool1D_leftxi_lefteta(NGLOB1D_RADIAL_MAX)
integer ibool1D_rightxi_lefteta(NGLOB1D_RADIAL_MAX)
integer ibool1D_leftxi_righteta(NGLOB1D_RADIAL_MAX)
integer ibool1D_rightxi_righteta(NGLOB1D_RADIAL_MAX)
- integer ibool1D(NGLOB1D_RADIAL_MAX)
- double precision xread1D(NGLOB1D_RADIAL_MAX)
- double precision yread1D(NGLOB1D_RADIAL_MAX)
- double precision zread1D(NGLOB1D_RADIAL_MAX)
double precision xdummy,ydummy,zdummy
- integer ipoin1D
+ integer :: ipoin1D
! arrays to assemble the corners (3 processors for each corner)
integer, dimension(:,:), allocatable :: iprocscorners,itypecorner
@@ -103,39 +109,40 @@
integer :: iproc_xi_loop_inv,iproc_eta_loop_inv
integer :: imember_corner
- integer iregion_code
+ integer :: iproc_edge_send,iproc_edge_receive
+ integer :: iside,imode_comm,iedge,itype
- integer iproc_edge_send,iproc_edge_receive
- integer imsg_type,iside,imode_comm,iedge
-
! boundary parameters per slice
integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, njunk
integer ibelm_xmin(NSPEC2DMAX_XMIN_XMAX),ibelm_xmax(NSPEC2DMAX_XMIN_XMAX)
integer ibelm_ymin(NSPEC2DMAX_YMIN_YMAX),ibelm_ymax(NSPEC2DMAX_YMIN_YMAX)
- integer npoin2D,npoin2D_send_local,npoin2D_receive_local
+ integer :: npoin2D,npoin2D_send_local,npoin2D_receive_local
- integer i,j,k,ispec,ispec2D,ipoin2D,ier
+ integer :: i,j,k,ispec,ispec2D,ipoin2D
! current message number
- integer imsg
+ integer :: imsg
-! names of the data files for all the processors in MPI
- character(len=150) prname,filename_in,filename_out
+ ! names of the data files for all the processors in MPI
+ character(len=150) :: prname,filename_in,filename_out
-! for addressing of the slices
- integer ichunk,iproc_xi,iproc_eta,iproc
+ ! for addressing of the slices
+ integer :: ichunk,iproc_xi,iproc_eta,iproc
+
+ ! this to avoid problem at compile time if less than six chunks
+ integer :: addressing_big(NCHUNKS_MAX,0:NPROC_XI-1,0:NPROC_ETA-1)
+
integer addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1)
integer ichunk_slice(0:NPROCTOT-1)
integer iproc_xi_slice(0:NPROCTOT-1)
-
integer iproc_eta_slice(0:NPROCTOT-1)
-! this to avoid problem at compile time if less than six chunks
- integer addressing_big(NCHUNKS_MAX,0:NPROC_XI-1,0:NPROC_ETA-1)
-
! number of faces between chunks
- integer NUM_FACES,NUMMSGS_FACES
+ integer :: NUM_FACES
+ integer :: NPROC_ONE_DIRECTION
+ integer :: NUMMSGS_FACES
+ integer :: ier
! number of corners between chunks
integer NCORNERSCHUNKS
@@ -143,10 +150,9 @@
! number of message types
integer NUM_MSG_TYPES
- integer NPROC_ONE_DIRECTION
+ logical,parameter :: DEBUG = .false.
-! ************** subroutine starts here **************
-
+ ! user output
if(myrank == 0) then
write(IMAIN,*)
write(IMAIN,*) '----- creating chunk buffers -----'
@@ -195,8 +201,11 @@
! total number of messages corresponding to these common faces
NUMMSGS_FACES = NPROC_ONE_DIRECTION*NUM_FACES*NUM_MSG_TYPES
-! check that there is more than one chunk, otherwise nothing to do
- if(NCHUNKS == 1) return
+ ! user output
+ if(myrank == 0) then
+ write(IMAIN,*) 'There is a total of ',NUMMSGS_FACES,' messages to assemble faces between chunks'
+ write(IMAIN,*)
+ endif
! same number of GLL points in each direction for several chunks
if(NGLLY /= NGLLX) call exit_MPI(myrank,'must have NGLLY = NGLLX for several chunks')
@@ -219,9 +228,16 @@
iprocscorners(:,:) = 0
itypecorner(:,:) = 0
- if(myrank == 0) then
- write(IMAIN,*) 'There is a total of ',NUMMSGS_FACES,' messages to assemble faces between chunks'
- write(IMAIN,*)
+ ! checks that there is more than one chunk, otherwise nothing to do
+ if(NCHUNKS == 1) then
+ ! user output
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'only one chunk, no need to create chunk buffers'
+ write(IMAIN,*)
+ endif
+ ! exit routine
+ return
endif
! define maximum size for message buffers
@@ -257,7 +273,7 @@
endif
! create theoretical communication pattern
- do imsg_type = 1,NUM_MSG_TYPES
+ do itype = 1,NUM_MSG_TYPES
do iside = 1,NUM_FACES
do iproc_loop = 0,NPROC_ONE_DIRECTION-1
@@ -283,7 +299,7 @@
! define the 12 different messages
! message type M1
- if(imsg_type == 1) then
+ if(itype == 1) then
if(iside == 1) then
ichunk_send = CHUNK_AB
@@ -332,7 +348,7 @@
endif
! message type M2
- if(imsg_type == 2) then
+ if(itype == 2) then
if(iside == 1) then
ichunk_send = CHUNK_AB
@@ -381,7 +397,7 @@
endif
! message type M3
- if(imsg_type == 3) then
+ if(itype == 3) then
if(iside == 1) then
ichunk_send = CHUNK_AC
@@ -429,16 +445,16 @@
endif
-
-! store addressing generated
+ ! store addressing generated
iproc_sender(imsg) = addressing(ichunk_send,iproc_xi_send,iproc_eta_send)
iproc_receiver(imsg) = addressing(ichunk_receive,iproc_xi_receive,iproc_eta_receive)
-! check that sender/receiver pair is ordered
- if(iproc_sender(imsg) > iproc_receiver(imsg)) call exit_MPI(myrank,'incorrect order in sender/receiver pair')
+ ! check that sender/receiver pair is ordered
+ if(iproc_sender(imsg) > iproc_receiver(imsg)) &
+ call exit_MPI(myrank,'incorrect order in sender/receiver pair')
-! save message type and pair of processors in list of messages
- if(myrank == 0) write(IOUT,*) imsg_type,iproc_sender(imsg),iproc_receiver(imsg)
+ ! save message type and pair of processors in list of messages
+ if(myrank == 0) write(IOUT,*) itype,iproc_sender(imsg),iproc_receiver(imsg)
! loop on sender/receiver (1=sender 2=receiver)
do imode_comm=1,2
@@ -722,13 +738,21 @@
! write list of selected points to output buffer
- write(IOUT_BUFFERS,*) npoin2D
+ ! debug file output
+ if( DEBUG ) then
+ write(IOUT_BUFFERS,*) npoin2D
+ endif
+
+ ! stores face infos
do ipoin2D = 1,npoin2D
write(IOUT_BUFFERS,*) ibool_selected(ipoin2D), &
xstore_selected(ipoin2D),ystore_selected(ipoin2D),zstore_selected(ipoin2D)
enddo
- close(IOUT_BUFFERS)
+ ! debug file output
+ if( DEBUG ) then
+ close(IOUT_BUFFERS)
+ endif
! store result to compare number of points for sender and for receiver
if(imode_comm == 1) then
@@ -748,7 +772,10 @@
enddo
enddo
- if(myrank == 0) close(IOUT)
+ ! debug file output
+ if( DEBUG ) then
+ if(myrank == 0) close(IOUT)
+ endif
! check that total number of messages is correct
if(imsg /= NUMMSGS_FACES) call exit_MPI(myrank,'incorrect total number of messages')
@@ -878,8 +905,12 @@
endif
-! file to store the list of processors for each message for corners
- if(myrank == 0) open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_corners.txt',status='unknown')
+ ! debug file output
+ if( DEBUG ) then
+ ! file to store the list of processors for each message for corners
+ if(myrank == 0) &
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_corners.txt',status='unknown')
+ endif
! loop over all the messages to create the addressing
do imsg = 1,NCORNERSCHUNKS
@@ -954,7 +985,10 @@
enddo
- if(myrank == 0) close(IOUT)
+ ! debug file output
+ if( DEBUG ) then
+ if(myrank == 0) close(IOUT)
+ endif
! deallocate arrays
deallocate(iproc_sender)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_doubling_elements.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_doubling_elements.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_doubling_elements.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -124,7 +124,17 @@
integer iproc_xi,iproc_eta
! attenuation
- integer nspec_att
+ integer :: nspec_att
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013: BEWARE, declared real(kind=CUSTOM_REAL) in trunk and
+!! DK DK to Daniel, Jul 2013: double precision in branch, let us check which one is right
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_att) :: Qmu_store
real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,nspec_att) :: tau_e_store
double precision, dimension(N_SLS) :: tau_s
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_mass_matrices.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_mass_matrices.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_mass_matrices.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -73,9 +73,7 @@
real(kind=CUSTOM_REAL), dimension(nglob_oceans) :: rmass_ocean_load
! arrays with the mesh in double precision
- double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore
- double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ystore
- double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: zstore
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
double precision :: RHO_OCEANS
@@ -263,10 +261,13 @@
! for surface elements exactly at the top of the crust (ocean bottom)
do ispec2D_top_crust = 1,NSPEC2D_TOP
+ ! gets spectral element index
ispec_oceans = ibelm_top(ispec2D_top_crust)
+ ! assumes elements are ordered such that k == NGLLZ is the top surface
iz_oceans = NGLLZ
+ ! loops over surface points
do ix_oceans = 1,NGLLX
do iy_oceans = 1,NGLLY
@@ -293,7 +294,6 @@
! get geographic latitude and longitude in degrees
lat = 90.0d0 - colat*180.0d0/PI
lon = phival*180.0d0/PI
- elevation = 0.d0
! compute elevation at current point
call get_topo_bathy(lat,lon,elevation,ibathy_topo)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regions_mesh.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regions_mesh.F90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regions_mesh.F90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -50,15 +50,10 @@
implicit none
-!****************************************************************************************************
-! Mila
-
! include "constants.h"
! standard include of the MPI library
include 'mpif.h'
-!****************************************************************************************************
-
! this to cut the doubling brick
integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE
@@ -227,9 +222,6 @@
logical :: ACTUALLY_STORE_ARRAYS
-!****************************************************************************************************
-! Mila
-
! added for color permutation
integer :: nb_colors_outer_elements,nb_colors_inner_elements,nspec_outer
integer, dimension(:), allocatable :: perm
@@ -239,19 +231,11 @@
integer :: icolor,ispec_counter
integer :: nspec_outer_min_global,nspec_outer_max_global
-!****************************************************************************************************
-
-!///////////////////////////////////////////////////////////////////////////////
-! Manh Ha - 18-11-2011
-! Adding new variables
-
integer :: NSTEP
integer, save :: npoin2D_xi,npoin2D_eta
double precision :: DT
-!///////////////////////////////////////////////////////////////////////////////
-
- ! Boundary Mesh
+ ! boundary mesh
integer NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho
integer, dimension(:), allocatable :: ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot, &
ibelm_670_top,ibelm_670_bot
@@ -272,8 +256,8 @@
! create the name for the database of the current slide and region
call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
- ! New Attenuation definition on all GLL points
- ! Attenuation
+ ! new Attenuation definition on all GLL points
+ ! attenuation
if (ATTENUATION) then
T_c_source = AM_V%QT_c_source
tau_s(:) = AM_V%Qtau_s(:)
@@ -511,7 +495,6 @@
! note: stretch_tab uses (dimensionalized) radii from r_top and r_bottom
!(with stretch_tab( index_radius(1=top,2=bottom), index_layer( 1=first layer, 2=second layer, 3= ...) )
RMIDDLE_CRUST = stretch_tab(2,1)
-
endif
!----
@@ -640,9 +623,9 @@
! check total number of spectral elements created
if(ispec /= nspec) call exit_MPI(myrank,'ispec should equal nspec')
-! if any of these flags is true, the element is on a communication edge
-! this is not enough because it can also be in contact by an edge or a corner but not a full face
-! therefore we will have to fix array "is_on_a_slice_edge" later in the solver to take this into account
+ ! if any of these flags is true, the element is on a communication edge
+ ! this is not enough because it can also be in contact by an edge or a corner but not a full face
+ ! therefore we will have to fix array "is_on_a_slice_edge" later in the solver to take this into account
is_on_a_slice_edge(:) = &
iMPIcut_xi(1,:) .or. iMPIcut_xi(2,:) .or. &
iMPIcut_eta(1,:) .or. iMPIcut_eta(2,:) .or. &
@@ -650,8 +633,8 @@
iboun(3,:) .or. iboun(4,:) .or. &
iboun(5,:) .or. iboun(6,:)
-! no need to count fictitious elements on the edges
-! for which communications cannot be overlapped with calculations
+ ! no need to count fictitious elements on the edges
+ ! for which communications cannot be overlapped with calculations
where(idoubling == IFLAG_IN_FICTITIOUS_CUBE) is_on_a_slice_edge = .false.
! only create global addressing and the MPI buffers in the first pass
@@ -787,9 +770,6 @@
!nspec_tiso = count(idoubling(1:nspec) == IFLAG_220_80) + count(idoubling(1:nspec) == IFLAG_80_MOHO)
nspec_tiso = count(ispec_is_tiso(:))
-!****************************************************************************************************
-! Mila
-
if(SORT_MESH_INNER_OUTER) then
!!!! David Michea: detection of the edges, coloring and permutation separately
@@ -1190,7 +1170,7 @@
end subroutine create_regions_mesh
!
-!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
!
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regular_elements.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regular_elements.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regular_elements.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -129,7 +129,17 @@
integer iproc_xi,iproc_eta
! attenuation
- integer nspec_att
+ integer :: nspec_att
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013: BEWARE, declared real(kind=CUSTOM_REAL) in trunk and
+!! DK DK to Daniel, Jul 2013: double precision in branch, let us check which one is right
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec_att) :: Qmu_store
real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,nspec_att) :: tau_e_store
double precision, dimension(N_SLS) :: tau_s
@@ -264,8 +274,8 @@
c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- nspec_ani,nspec_stacey,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
- rho_vp,rho_vs,ACTUALLY_STORE_ARRAYS,&
+ nspec_ani,nspec_stacey,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
+ rho_vp,rho_vs,ACTUALLY_STORE_ARRAYS, &
xigll,yigll,zigll,ispec_is_tiso)
! boundary mesh
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_MPI_1D_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_MPI_1D_buffers.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_MPI_1D_buffers.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -25,9 +25,9 @@
!
!=====================================================================
- subroutine get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, &
- idoubling,xstore,ystore,zstore,mask_ibool,npointot, &
- NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion)
+ subroutine get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta, &
+ ibool,idoubling,xstore,ystore,zstore,mask_ibool,npointot, &
+ NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion)
! routine to create the MPI 1D chunk buffers for edges
@@ -35,32 +35,33 @@
include "constants.h"
- integer nspec,myrank,iregion
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
+ integer :: nspec,myrank
- logical iMPIcut_xi(2,nspec)
- logical iMPIcut_eta(2,nspec)
+ logical,dimension(2,nspec) :: iMPIcut_xi,iMPIcut_eta
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+ integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ integer,dimension(nspec) :: idoubling
- integer idoubling(nspec)
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+ ! logical mask used to create arrays ibool1D
+ integer :: npointot
+ logical,dimension(npointot) :: mask_ibool
-! logical mask used to create arrays ibool1D
- integer npointot
- logical mask_ibool(npointot)
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
+ integer :: iregion
-! global element numbering
- integer ispec
+ ! processor identification
+ character(len=150) :: prname
-! MPI 1D buffer element numbering
- integer ispeccount,npoin1D,ix,iy,iz
+ ! local parameters
+ ! global element numbering
+ integer :: ispec
+ ! MPI 1D buffer element numbering
+ integer :: ispeccount,npoin1D,ix,iy,iz
-! processor identification
- character(len=150) prname
+ ! debug file output
+ logical,parameter :: DEBUG = .false.
! write the MPI buffers for the left and right edges of the slice
! and the position of the points to check that the buffers are fine
@@ -99,8 +100,9 @@
do iz=1,NGLLZ
! select point, if not already selected
if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin1D = npoin1D + 1
+ ! adds this point
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin1D = npoin1D + 1
write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
endif
@@ -149,8 +151,8 @@
do iz=1,NGLLZ
! select point, if not already selected
if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin1D = npoin1D + 1
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin1D = npoin1D + 1
write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
endif
@@ -190,14 +192,14 @@
do ispec=1,nspec
-! remove central cube for chunk buffers
- if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
+ ! remove central cube for chunk buffers
+ if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
-! corner detection here
- if(iMPIcut_xi(1,ispec) .and. iMPIcut_eta(2,ispec)) then
+ ! corner detection here
+ if(iMPIcut_xi(1,ispec) .and. iMPIcut_eta(2,ispec)) then
ispeccount=ispeccount+1
@@ -207,8 +209,8 @@
do iz=1,NGLLZ
! select point, if not already selected
if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin1D = npoin1D + 1
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin1D = npoin1D + 1
write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
endif
@@ -244,26 +246,26 @@
do ispec=1,nspec
-! remove central cube for chunk buffers
- if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
+ ! remove central cube for chunk buffers
+ if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
-! corner detection here
- if(iMPIcut_xi(2,ispec) .and. iMPIcut_eta(2,ispec)) then
+ ! corner detection here
+ if(iMPIcut_xi(2,ispec) .and. iMPIcut_eta(2,ispec)) then
- ispeccount=ispeccount+1
+ ispeccount=ispeccount+1
-! loop on all the points
- ix = NGLLX
- iy = NGLLY
- do iz=1,NGLLZ
+ ! loop on all the points
+ ix = NGLLX
+ iy = NGLLY
+ do iz=1,NGLLZ
! select point, if not already selected
if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin1D = npoin1D + 1
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin1D = npoin1D + 1
write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
endif
@@ -279,7 +281,7 @@
close(10)
-! compare number of edge elements and points detected to analytical value
+ ! compare number of edge elements and points detected to analytical value
if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,3) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,3)) &
call exit_MPI(myrank,'error MPI 1D buffer detection in xi=right')
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_MPI_cutplanes_eta.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_MPI_cutplanes_eta.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_MPI_cutplanes_eta.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -38,32 +38,37 @@
include "constants.h"
- integer :: nspec,myrank,iregion
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE
+ integer :: nspec,myrank
+ logical,dimension(2,nspec) :: iMPIcut_eta
- logical iMPIcut_eta(2,nspec)
+ integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+ ! logical mask used to create arrays iboolleft_eta and iboolright_eta
+ integer :: npointot
+ logical,dimension(npointot) :: mask_ibool
-! logical mask used to create arrays iboolleft_eta and iboolright_eta
- integer npointot
- logical mask_ibool(npointot)
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE
-! global element numbering
- integer ispec
+ integer :: iregion
+ integer :: npoin2D_eta
-! MPI cut-plane element numbering
- integer ispecc1,ispecc2,npoin2D_eta,ix,iy,iz
- integer nspec2Dtheor
+ ! processor identification
+ character(len=150) :: prname
-! processor identification
- character(len=150) prname
+ ! local parameters
+ ! global element numbering
+ integer :: ispec
+ ! MPI cut-plane element numbering
+ integer :: ispecc1,ispecc2,ix,iy,iz
+ integer :: nspec2Dtheor
+
+ ! debug: file output
+ logical,parameter :: DEBUG = .false.
+
! theoretical number of surface elements in the buffers
! cut planes along eta=constant correspond to XI faces
nspec2Dtheor = NSPEC2D_XI_FACE(iregion,1)
@@ -96,8 +101,8 @@
do iz=1,NGLLZ
! select point, if not already selected
if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin2D_eta = npoin2D_eta + 1
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_eta = npoin2D_eta + 1
write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
endif
@@ -143,8 +148,8 @@
do iz=1,NGLLZ
! select point, if not already selected
if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin2D_eta = npoin2D_eta + 1
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_eta = npoin2D_eta + 1
write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
endif
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_MPI_cutplanes_xi.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_MPI_cutplanes_xi.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_MPI_cutplanes_xi.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -38,31 +38,38 @@
include "constants.h"
- integer :: nspec,myrank,iregion
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_ETA_FACE
+ integer :: nspec,myrank
- logical iMPIcut_xi(2,nspec)
+ logical,dimension(2,nspec) :: iMPIcut_xi
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+ integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
-! logical mask used to create arrays iboolleft_xi and iboolright_xi
- integer npointot
- logical mask_ibool(npointot)
+ ! logical mask used to create arrays iboolleft_xi and iboolright_xi
+ integer :: npointot
+ logical,dimension(npointot) :: mask_ibool
-! global element numbering
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_ETA_FACE
+
+ integer :: iregion
+ integer :: npoin2D_xi
+
+ ! processor identification
+ character(len=150) :: prname
+
+ ! local parameters
+ ! global element numbering
integer :: ispec
+ ! MPI cut-plane element numbering
+ integer :: ispecc1,ispecc2,ix,iy,iz
+ integer :: nspec2Dtheor
+ integer :: ier
-! MPI cut-plane element numbering
- integer ispecc1,ispecc2,npoin2D_xi,ix,iy,iz
- integer nspec2Dtheor
- integer ier
+ character(len=150) :: errmsg
-! processor identification
- character(len=150) prname,errmsg
+ ! debug: file output
+ logical,parameter :: DEBUG = .false.
! theoretical number of surface elements in the buffers
! cut planes along xi=constant correspond to ETA faces
@@ -107,8 +114,8 @@
do iz=1,NGLLZ
! select point, if not already selected
if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin2D_xi = npoin2D_xi + 1
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_xi = npoin2D_xi + 1
write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
endif
@@ -157,8 +164,8 @@
do iz=1,NGLLZ
! select point, if not already selected
if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin2D_xi = npoin2D_xi + 1
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_xi = npoin2D_xi + 1
write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
endif
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_absorb.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_absorb.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_absorb.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -39,14 +39,15 @@
integer :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM
- integer nimin(2,NSPEC2DMAX_YMIN_YMAX),nimax(2,NSPEC2DMAX_YMIN_YMAX)
- integer njmin(2,NSPEC2DMAX_XMIN_XMAX),njmax(2,NSPEC2DMAX_XMIN_XMAX)
- integer nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX),nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX)
+ integer,dimension(2,NSPEC2DMAX_YMIN_YMAX) :: nimin,nimax
+ integer,dimension(2,NSPEC2DMAX_XMIN_XMAX) :: njmin,njmax
+ integer,dimension(2,NSPEC2DMAX_XMIN_XMAX) :: nkmin_xi
+ integer,dimension(2,NSPEC2DMAX_YMIN_YMAX) :: nkmin_eta
logical :: iboun(6,nspec)
-! global element numbering
- integer ispecg
+ ! global element numbering
+ integer :: ispec
! counters to keep track of the number of elements on each of the
! five absorbing boundaries
@@ -63,11 +64,11 @@
ispecb4=0
ispecb5=0
- do ispecg=1,nspec
+ do ispec=1,nspec
! determine if the element falls on an absorbing boundary
- if(iboun(1,ispecg)) then
+ if(iboun(1,ispec)) then
! on boundary 1: xmin
ispecb1=ispecb1+1
@@ -76,12 +77,12 @@
njmin(1,ispecb1)=1
njmax(1,ispecb1)=NGLLY
-! check for ovelap with other boundaries
- nkmin_xi(1,ispecb1)=1
- if(iboun(5,ispecg)) nkmin_xi(1,ispecb1)=2
- endif
+ ! check for ovelap with other boundaries
+ nkmin_xi(1,ispecb1)=1
+ if(iboun(5,ispec)) nkmin_xi(1,ispecb1)=2
+ endif
- if(iboun(2,ispecg)) then
+ if(iboun(2,ispec)) then
! on boundary 2: xmax
ispecb2=ispecb2+1
@@ -90,41 +91,41 @@
njmin(2,ispecb2)=1
njmax(2,ispecb2)=NGLLY
-! check for ovelap with other boundaries
- nkmin_xi(2,ispecb2)=1
- if(iboun(5,ispecg)) nkmin_xi(2,ispecb2)=2
- endif
+ ! check for ovelap with other boundaries
+ nkmin_xi(2,ispecb2)=1
+ if(iboun(5,ispec)) nkmin_xi(2,ispecb2)=2
+ endif
- if(iboun(3,ispecg)) then
+ if(iboun(3,ispec)) then
! on boundary 3: ymin
ispecb3=ispecb3+1
-! check for ovelap with other boundaries
- nimin(1,ispecb3)=1
- if(iboun(1,ispecg)) nimin(1,ispecb3)=2
- nimax(1,ispecb3)=NGLLX
- if(iboun(2,ispecg)) nimax(1,ispecb3)=NGLLX-1
- nkmin_eta(1,ispecb3)=1
- if(iboun(5,ispecg)) nkmin_eta(1,ispecb3)=2
- endif
+ ! check for ovelap with other boundaries
+ nimin(1,ispecb3)=1
+ if(iboun(1,ispec)) nimin(1,ispecb3)=2
+ nimax(1,ispecb3)=NGLLX
+ if(iboun(2,ispec)) nimax(1,ispecb3)=NGLLX-1
+ nkmin_eta(1,ispecb3)=1
+ if(iboun(5,ispec)) nkmin_eta(1,ispecb3)=2
+ endif
- if(iboun(4,ispecg)) then
+ if(iboun(4,ispec)) then
! on boundary 4: ymax
ispecb4=ispecb4+1
-! check for ovelap with other boundaries
- nimin(2,ispecb4)=1
- if(iboun(1,ispecg)) nimin(2,ispecb4)=2
- nimax(2,ispecb4)=NGLLX
- if(iboun(2,ispecg)) nimax(2,ispecb4)=NGLLX-1
- nkmin_eta(2,ispecb4)=1
- if(iboun(5,ispecg)) nkmin_eta(2,ispecb4)=2
- endif
+ ! check for ovelap with other boundaries
+ nimin(2,ispecb4)=1
+ if(iboun(1,ispec)) nimin(2,ispecb4)=2
+ nimax(2,ispecb4)=NGLLX
+ if(iboun(2,ispec)) nimax(2,ispecb4)=NGLLX-1
+ nkmin_eta(2,ispecb4)=1
+ if(iboun(5,ispec)) nkmin_eta(2,ispecb4)=2
+ endif
-! on boundary 5: bottom
- if(iboun(5,ispecg)) ispecb5=ispecb5+1
+ ! on boundary 5: bottom
+ if(iboun(5,ispec)) ispecb5=ispecb5+1
enddo
@@ -132,7 +133,7 @@
if(ispecb5 /= NSPEC2D_BOTTOM) &
call exit_MPI(myrank,'ispecb5 should equal NSPEC2D_BOTTOM in absorbing boundary detection')
-! save these temporary arrays for the solver for Stacey conditions
+ ! save these temporary arrays for the solver for Stacey conditions
open(unit=27,file=prname(1:len_trim(prname))//'stacey.bin',status='unknown',form='unformatted',action='write')
write(27) nimin
write(27) nimax
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_global.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_global.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_global.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -40,26 +40,28 @@
! input parameters
integer, intent(in) :: npointot,nspec
- double precision, intent(in) :: xp(npointot),yp(npointot),zp(npointot)
- integer, intent(out) :: iglob(npointot),loc(npointot)
- logical, intent(out) :: ifseg(npointot)
+ double precision, dimension(npointot), intent(in) :: xp,yp,zp
+
+ integer, dimension(npointot), intent(out) :: iglob,loc
+ logical, dimension(npointot), intent(out) :: ifseg
integer, intent(out) :: nglob
-! variables
- integer ispec,i,j
- integer ieoff,ilocnum,nseg,ioff,iseg,ig
-
+ ! local variables
+ double precision, dimension(:), allocatable :: work
integer, dimension(:), allocatable :: ind,ninseg,iwork
- double precision, dimension(:), allocatable :: work
+ integer :: ispec,i,j,ier
+ integer :: ieoff,ilocnum,nseg,ioff,iseg,ig
-! dynamically allocate arrays
- allocate(ind(npointot))
- allocate(ninseg(npointot))
- allocate(iwork(npointot))
- allocate(work(npointot))
+ ! dynamically allocate arrays
+ allocate(ind(npointot), &
+ ninseg(npointot), &
+ iwork(npointot), &
+ work(npointot), &
+ stat=ier)
+ if( ier /= 0 ) stop 'error allocating local array in get_global'
-! establish initial pointers
+ ! establish initial pointers
do ispec=1,nspec
ieoff=NGLLX * NGLLY * NGLLZ * (ispec-1)
do ilocnum=1,NGLLX * NGLLY * NGLLZ
@@ -158,9 +160,12 @@
integer:: i,j,k,ispec,ier
! copies original array
- allocate(copy_ibool_ori(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate'
- allocate(mask_ibool(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(copy_ibool_ori(NGLLX,NGLLY,NGLLZ,nspec), &
+ mask_ibool(nglob), &
+ stat=ier)
+ if(ier /= 0) stop 'error allocating local arrays in get_global_indirect_addressing'
+ ! initializes arrays
mask_ibool(:) = -1
copy_ibool_ori(:,:,:,:) = ibool(:,:,:,:)
@@ -188,7 +193,7 @@
deallocate(copy_ibool_ori,stat=ier); if(ier /= 0) stop 'error in deallocate'
deallocate(mask_ibool,stat=ier); if(ier /= 0) stop 'error in deallocate'
-end subroutine get_global_indirect_addressing
+ end subroutine get_global_indirect_addressing
!
!-------------------------------------------------------------------------------------------------
@@ -202,12 +207,13 @@
!
implicit none
- integer n
- double precision A(n)
- integer IND(n)
+ integer :: n
+ double precision,dimension(n) :: A
+ integer,dimension(n) :: IND
- integer i,j,l,ir,indx
- double precision q
+ ! local parameters
+ integer :: i,j,l,ir,indx
+ double precision :: q
do j=1,n
IND(j)=j
@@ -215,41 +221,47 @@
if (n == 1) return
- L=n/2+1
- ir=n
- 100 CONTINUE
- IF (l>1) THEN
- l=l-1
- indx=ind(l)
- q=a(indx)
- ELSE
- indx=ind(ir)
- q=a(indx)
- ind(ir)=ind(1)
- ir=ir-1
+ L = n/2 + 1
+ ir = n
+
+ do while( .true. )
+
+ IF ( l > 1 ) THEN
+ l = l-1
+ indx = ind(l)
+ q = a(indx)
+ ELSE
+ indx = ind(ir)
+ q = a(indx)
+ ind(ir) = ind(1)
+ ir = ir-1
+
+ ! checks exit criterion
if (ir == 1) then
- ind(1)=indx
+ ind(1) = indx
return
endif
- ENDIF
- i=l
- j=l+l
- 200 CONTINUE
- IF (J <= IR) THEN
- IF (J<IR) THEN
- IF ( A(IND(j))<A(IND(j+1)) ) j=j+1
+ ENDIF
+
+ i = l
+ j = l+l
+
+ do while( J <= IR )
+ IF ( J < IR ) THEN
+ IF ( A(IND(j)) < A(IND(j+1)) ) j=j+1
ENDIF
- IF (q<A(IND(j))) THEN
- IND(I)=IND(J)
- I=J
- J=J+J
+ IF ( q < A(IND(j)) ) THEN
+ IND(I) = IND(J)
+ I = J
+ J = J+J
ELSE
- J=IR+1
+ J = IR+1
ENDIF
- goto 200
- ENDIF
- IND(I)=INDX
- goto 100
+ enddo
+
+ IND(I)=INDX
+ enddo
+
end subroutine rank
!
@@ -262,14 +274,14 @@
!
implicit none
- integer n
+ integer :: n
+ integer,dimension(n) :: IND
+ integer,dimension(n) :: IA,IW
+ double precision,dimension(n) :: A,B,C,W
- integer IND(n)
- integer IA(n),IW(n)
- double precision A(n),B(n),C(n),W(n)
+ ! local parameter
+ integer :: i
- integer i
-
IW(:) = IA(:)
W(:) = A(:)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_model.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_model.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -65,6 +65,16 @@
! attenuation values
integer :: vx,vy,vz,vnspec
double precision, dimension(N_SLS) :: tau_s
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013: BEWARE, declared real(kind=CUSTOM_REAL) in trunk and
+!! DK DK to Daniel, Jul 2013: double precision in branch, let us check which one is right
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
+!! DK DK to Daniel, Jul 2013
real(kind=CUSTOM_REAL), dimension(vx, vy, vz, vnspec) :: Qmu_store
real(kind=CUSTOM_REAL), dimension(N_SLS, vx, vy, vz, vnspec) :: tau_e_store
double precision :: T_c_source
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_perm_color.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_perm_color.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_perm_color.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -25,15 +25,13 @@
!
!=====================================================================
-
! define sets of colors that contain disconnected elements for the CUDA solver.
! also split the elements into two subsets: inner and outer elements, in order
! to be able to compute the outer elements first in the solver and then
! start non-blocking MPI calls and overlap them with the calculation of the inner elements
! (which works fine because there are always far more inner elements than outer elements)
-!*********************************************************************************************************
-! Mila
+
subroutine get_perm_color_faster(is_on_a_slice_edge,ibool,perm,nspec,nglob, &
nb_colors_outer_elements,nb_colors_inner_elements,nspec_outer,first_elem_number_in_this_color,myrank)
@@ -41,12 +39,10 @@
include "constants.h"
-! local variables
- integer nspec, nglob
+ integer, intent(in) :: nspec, nglob
+ logical, dimension(nspec), intent(in) :: is_on_a_slice_edge
- logical, dimension(nspec) :: is_on_a_slice_edge
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec), intent(in) :: ibool
integer, dimension(nspec) :: perm
integer, dimension(nspec) :: color
integer, dimension(MAX_NUMBER_OF_COLORS) :: first_elem_number_in_this_color
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -484,7 +484,7 @@
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
-! initialize the MPI communicator and start the NPROCTOT MPI processes.
+ ! initialize the MPI communicator and start the NPROCTOT MPI processes.
call MPI_INIT(ier)
! sizeprocs returns number of processes started (should be equal to NPROCTOT).
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_1dref.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_1dref.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_1dref.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -121,16 +121,15 @@
! shear quality factor Qmu
! bulk quality factor Qkappa
- integer iregion_code
+ double precision :: x,rho,vpv,vph,vsv,vsh,eta,Qmu,Qkappa
+ integer :: iregion_code
+ logical :: CRUSTAL
- double precision x,rho,vpv,vph,vsv,vsh,eta,Qmu,Qkappa
+ ! local parameters
+ double precision :: r,frac,scaleval
+ integer :: i
- integer i
-
- double precision r,frac,scaleval
- logical CRUSTAL
-
-! compute real physical radius in meters
+ ! compute real physical radius in meters
r = x * R_EARTH
i = 1
@@ -201,6 +200,7 @@
subroutine define_model_1dref(USE_EXTERNAL_CRUSTAL_MODEL,Mref_V)
implicit none
+
include "constants.h"
! model_1dref_variables
@@ -7425,7 +7425,7 @@
1.00000000000000 , &
1.00000000000000 /)
-! strip the crust and replace it by mantle
+ ! strip the crust and replace it by mantle
if (SUPPRESS_CRUSTAL_MESH .or. USE_EXTERNAL_CRUSTAL_MODEL) then
! sets values for depths less than 24.4 km to mantle values below
Mref_V%density_ref(718:750) = Mref_V%density_ref(717)
@@ -7437,6 +7437,5 @@
Mref_V%Qkappa_ref(718:750) = Mref_V%Qkappa_ref(717)
endif
-
end subroutine define_model_1dref
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_ak135.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_ak135.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_ak135.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -112,15 +112,14 @@
! compressional wave speed vp: km/s
! shear wave speed vs: km/s
- integer iregion_code
+ double precision :: x,rho,vp,vs,Qmu,Qkappa
+ integer :: iregion_code
- double precision x,rho,vp,vs,Qmu,Qkappa
+ ! local parameters
+ double precision :: r,frac,scaleval
+ integer :: i
- integer i
-
- double precision r,frac,scaleval
-
-! compute real physical radius in meters
+ ! compute real physical radius in meters
r = x * R_EARTH
i = 1
@@ -1022,7 +1021,7 @@
Mak135_V%Qmu_ak135(135) = 599.990000000000
Mak135_V%Qmu_ak135(136) = 599.990000000000
-! strip the crust and replace it with mantle
+ ! strip the crust and replace it with mantle
if (SUPPRESS_CRUSTAL_MESH .or. USE_EXTERNAL_CRUSTAL_MODEL) then
Mak135_V%vp_ak135(133:136) = Mak135_V%vp_ak135(132)
Mak135_V%vs_ak135(133:136) = Mak135_V%vs_ak135(132)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_aniso_mantle.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_aniso_mantle.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_aniso_mantle.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -83,7 +83,8 @@
subroutine model_aniso_mantle(r,theta,phi,rho, &
- c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66,&
+ c11,c12,c13,c14,c15,c16, &
+ c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66, &
AMM_V)
implicit none
@@ -102,15 +103,16 @@
type (model_aniso_mantle_variables) AMM_V
! model_aniso_mantle_variables
- double precision r,theta,phi
- double precision rho
- double precision c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26, &
+ double precision :: r,theta,phi
+ double precision :: rho
+ double precision :: c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26, &
c33,c34,c35,c36,c44,c45,c46,c55,c56,c66
- double precision d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26, &
+ ! local parameters
+ double precision :: d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26, &
d33,d34,d35,d36,d44,d45,d46,d55,d56,d66
- double precision colat,lon
+ double precision :: colat,lon
lon = phi / DEGREES_TO_RADIANS
colat = theta / DEGREES_TO_RADIANS
@@ -142,17 +144,24 @@
include "constants.h"
- integer npar1,ndepth,idep,ipar,itheta,ilon,icz0,nx0,ny0,nz0,&
- ict0,ict1,icp0,icp1,icz1
+ double precision :: pro(47)
+ integer :: npar1
- double precision d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26, &
+ double precision :: rho
+ double precision :: beta(14,34,37,73)
+
+ double precision :: r,theta,phi
+ double precision :: d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26, &
d33,d34,d35,d36,d44,d45,d46,d55,d56,d66
- double precision r,theta,phi,rho,depth,tei,tet,ph,fi,x0,y0,pxy0
- double precision d1,d2,d3,d4,sd,thickness,dprof1,dprof2,eps,pc1,pc2,pc3,pc4,&
+
+ ! local parameters
+ double precision :: depth,tei,tet,ph,fi,x0,y0,pxy0
+ double precision :: d1,d2,d3,d4,sd,thickness,dprof1,dprof2,eps,pc1,pc2,pc3,pc4,&
dpr1,dpr2,param,scale_GPa,scaleval
- double precision A,C,F,AL,AN,BC,BS,GC,GS,HC,HS,EC,ES,C1p,C1sv,C1sh,C3,S1p,S1sv,S1sh,S3
- double precision beta(14,34,37,73),pro(47)
- double precision anispara(14,2,4),elpar(14)
+ double precision :: A,C,F,AL,AN,BC,BS,GC,GS,HC,HS,EC,ES,C1p,C1sv,C1sh,C3,S1p,S1sv,S1sh,S3
+ double precision :: anispara(14,2,4),elpar(14)
+ integer :: ndepth,idep,ipar,itheta,ilon,icz0,nx0,ny0,nz0,&
+ ict0,ict1,icp0,icp1,icz1
ndepth = npar1
pxy0 = 5.
@@ -363,7 +372,9 @@
end subroutine build_cij
-!--------------------------------------------------------------
+!
+!-------------------------------------------------------------------------------------------------
+!
subroutine read_aniso_mantle_model(AMM_V)
@@ -539,9 +550,11 @@
enddo
enddo
- end subroutine read_aniso_mantle_model
+ end subroutine read_aniso_mantle_model
+!
!--------------------------------------------------------------------
+!
subroutine lecmod(nri,pari,ra)
@@ -562,8 +575,8 @@
character(len=80) null
character(len=150) Adrem119
- ifanis = 1
- nri = 47
+ ifanis = 1
+ nri = 47
call get_value_string(Adrem119, 'model.Adrem119', 'DATA/Montagner_model/Adrem119')
open(unit=13,file=Adrem119,status='old',action='read',iostat=ier)
@@ -943,7 +956,5 @@
(cosphifour + sinphifour)*(d66*costhetasq + &
d44*sinthetasq + d46*sintwotheta)
-
end subroutine rotate_aniso_tensor
-!--------------------------------------------------------------------
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_atten3D_QRFSI12.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_atten3D_QRFSI12.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_atten3D_QRFSI12.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -71,6 +71,8 @@
! model_atten3D_QRFSI12_variables
integer :: myrank
+
+ ! local parameters
integer :: ier
if(myrank == 0) call read_atten_model_3D_QRFSI12(QRFSI12_Q)
@@ -193,13 +195,17 @@
type (model_atten3D_QRFSI12_variables) QRFSI12_Q
! model_atten3D_QRFSI12_variables
- integer i,j,k,n,idoubling
- integer ifnd
- double precision radius,theta,phi,Qmu,smallq,dqmu,smallq_ref
- real(kind=4) splpts(NKQ),splcon(NKQ),splcond(NKQ)
- real(kind=4) depth,ylat,xlon
- real(kind=4) shdep(NSQ)
- real(kind=4) xlmvec(NSQ),wk1(NSQ),wk2(NSQ),wk3(NSQ)
+ double precision :: radius,theta,phi,Qmu
+ integer :: idoubling
+
+ ! local parameters
+ integer :: i,j,k,n
+ integer :: ifnd
+ double precision :: smallq,dqmu,smallq_ref
+ real(kind=4) :: splpts(NKQ),splcon(NKQ),splcond(NKQ)
+ real(kind=4) :: depth,ylat,xlon
+ real(kind=4) :: shdep(NSQ)
+ real(kind=4) :: xlmvec(NSQ),wk1(NSQ),wk2(NSQ),wk3(NSQ)
double precision, parameter :: rmoho_prem = 6371.0-24.4
double precision, parameter :: rcmb = 3480.0
@@ -268,497 +274,16 @@
enddo
smallq = smallq_ref + dqmu
endif
- ! if smallq is small and negative (due to numerical error), Qmu is very large:
+
+ ! if smallq is small and negative (due to numerical error), Qmu is very large:
if(smallq < 0.0d0) smallq = 1.0d0/ATTENUATION_COMP_MAXIMUM
Qmu = 1/smallq
- ! Qmu is larger than MAX_ATTENUATION_VALUE, set it to ATTENUATION_COMP_MAXIMUM. This assumes that this
- ! value is high enough that at this point there is almost no attenuation at all.
+
+ ! if Qmu is larger than MAX_ATTENUATION_VALUE, set it to ATTENUATION_COMP_MAXIMUM.
+ ! This assumes that this value is high enough that at this point there is almost no attenuation at all.
if(Qmu >= ATTENUATION_COMP_MAXIMUM) Qmu = 0.99d0*ATTENUATION_COMP_MAXIMUM
endif
end subroutine model_atten3D_QRFSI12
-
-!
-!----------------------------------
-!
-
-!!$ subroutine vbspl(x,np,xarr,splcon,splcond)
-!!$!
-!!$!---- this subroutine returns the spline contributions at a particular value of x
-!!$!
-!!$ implicit none
-!!$
-!!$ integer :: np
-!!$
-!!$ real(kind=4) :: xarr(np),x
-!!$ real(kind=4) :: splcon(np)
-!!$ real(kind=4) :: splcond(np)
-!!$
-!!$ real(kind=4) :: r1,r2,r3,r4,r5,r6,r7,r8,r9,r10,r11,r12,r13
-!!$ real(kind=4) :: r1d,r2d,r3d,r4d,r5d,r6d,r7d,r8d,r9d,r10d,r11d,r12d,r13d,val,vald
-!!$
-!!$ real(kind=4) :: rr1,rr2,rr3,rr4,rr5,rr6,rr7,rr8,rr9,rr10,rr11,rr12
-!!$ real(kind=4) :: rr1d,rr2d,rr3d,rr4d,rr5d,rr6d,rr7d,rr8d,rr9d,rr10d,rr11d,rr12d
-!!$
-!!$ integer :: iflag,interval,ik,ib
-!!$
-!!$!
-!!$!---- iflag=1 ==>> second derivative is 0 at end points
-!!$!---- iflag=0 ==>> first derivative is 0 at end points
-!!$!
-!!$ iflag=1
-!!$!
-!!$!---- first, find out within which interval x falls
-!!$!
-!!$ interval=0
-!!$ ik=1
-!!$ do while(interval == 0.and.ik < np)
-!!$ ik=ik+1
-!!$ if(x >= xarr(ik-1).and.x <= xarr(ik)) interval=ik-1
-!!$ enddo
-!!$ if(x > xarr(np)) then
-!!$ interval=np
-!!$ endif
-!!$
-!!$ if(interval == 0) then
-!!$! write(6,"('low value:',2f10.3)") x,xarr(1)
-!!$ else if(interval > 0.and.interval < np) then
-!!$! write(6,"('bracket:',i5,3f10.3)") interval,xarr(interval),x,xarr(interval+1)
-!!$ else
-!!$! write(6,"('high value:',2f10.3)") xarr(np),x
-!!$ endif
-!!$
-!!$ do ib=1,np
-!!$ val=0.
-!!$ vald=0.
-!!$ if(ib == 1) then
-!!$
-!!$ r1=(x-xarr(1))/(xarr(2)-xarr(1))
-!!$ r2=(xarr(3)-x)/(xarr(3)-xarr(1))
-!!$ r4=(xarr(2)-x)/(xarr(2)-xarr(1))
-!!$ r5=(x-xarr(1))/(xarr(2)-xarr(1))
-!!$ r6=(xarr(3)-x)/(xarr(3)-xarr(1))
-!!$ r10=(xarr(2)-x)/(xarr(2)-xarr(1))
-!!$ r11=(x-xarr(1)) /(xarr(2)-xarr(1))
-!!$ r12=(xarr(3)-x)/(xarr(3)-xarr(2))
-!!$ r13=(xarr(2)-x)/(xarr(2)-xarr(1))
-!!$
-!!$ r1d=1./(xarr(2)-xarr(1))
-!!$ r2d=-1./(xarr(3)-xarr(1))
-!!$ r4d=-1./(xarr(2)-xarr(1))
-!!$ r5d=1./(xarr(2)-xarr(1))
-!!$ r6d=-1./(xarr(3)-xarr(1))
-!!$ r10d=-1./(xarr(2)-xarr(1))
-!!$ r11d=1./(xarr(2)-xarr(1))
-!!$ r12d=-1./(xarr(3)-xarr(2))
-!!$ r13d=-1./(xarr(2)-xarr(1))
-!!$
-!!$ if(interval == ib.or.interval == 0) then
-!!$ if(iflag == 0) then
-!!$ val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11 +r13**3
-!!$ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
-!!$ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
-!!$ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
-!!$ vald=vald+3.*r13d*r13**2
-!!$ else if(iflag == 1) then
-!!$ val=0.6667*(r1*r4*r10 + r2*r5*r10 + r2*r6*r11 &
-!!$ + 1.5*r13**3)
-!!$ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
-!!$ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
-!!$ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
-!!$ vald=vald+4.5*r13d*r13**2
-!!$ vald=0.6667*vald
-!!$ endif
-!!$ else if(interval == ib+1) then
-!!$ if(iflag == 0) then
-!!$ val=r2*r6*r12
-!!$ vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d
-!!$ else if(iflag == 1) then
-!!$ val=0.6667*r2*r6*r12
-!!$ vald=0.6667*(r2d*r6*r12+r2*r6d*r12+r2*r6*r12d)
-!!$ endif
-!!$ else
-!!$ val=0.
-!!$ endif
-!!$
-!!$ else if(ib == 2) then
-!!$
-!!$ rr1=(x-xarr(1))/(xarr(2)-xarr(1))
-!!$ rr2=(xarr(3)-x)/(xarr(3)-xarr(1))
-!!$ rr4=(xarr(2)-x)/(xarr(2)-xarr(1))
-!!$ rr5=(x-xarr(1))/(xarr(2)-xarr(1))
-!!$ rr6=(xarr(3)-x)/(xarr(3)-xarr(1))
-!!$ rr10=(xarr(2)-x)/(xarr(2)-xarr(1))
-!!$ rr11=(x-xarr(1)) /(xarr(2)-xarr(1))
-!!$ rr12=(xarr(3)-x)/(xarr(3)-xarr(2))
-!!$
-!!$ rr1d=1./(xarr(2)-xarr(1))
-!!$ rr2d=-1./(xarr(3)-xarr(1))
-!!$ rr4d=-1./(xarr(2)-xarr(1))
-!!$ rr5d=1./(xarr(2)-xarr(1))
-!!$ rr6d=-1./(xarr(3)-xarr(1))
-!!$ rr10d=-1./(xarr(2)-xarr(1))
-!!$ rr11d=1./(xarr(2)-xarr(1))
-!!$ rr12d=-1./(xarr(3)-xarr(2))
-!!$
-!!$ r1=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
-!!$ r2=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib-1))
-!!$ r3=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
-!!$ r4=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
-!!$ r5=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
-!!$ r6=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib))
-!!$ r8=(xarr(ib)-x)/ (xarr(ib)-xarr(ib-1))
-!!$ r9=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
-!!$ r10=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
-!!$ r11=(x-xarr(ib)) /(xarr(ib+1)-xarr(ib))
-!!$ r12=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib+1))
-!!$
-!!$ r1d=1./(xarr(ib+1)-xarr(ib-1))
-!!$ r2d=-1./(xarr(ib+2)-xarr(ib-1))
-!!$ r3d=1./(xarr(ib)-xarr(ib-1))
-!!$ r4d=-1./(xarr(ib+1)-xarr(ib-1))
-!!$ r5d=1./(xarr(ib+1)-xarr(ib-1))
-!!$ r6d=-1./(xarr(ib+2)-xarr(ib))
-!!$ r8d=-1./ (xarr(ib)-xarr(ib-1))
-!!$ r9d=1./(xarr(ib)-xarr(ib-1))
-!!$ r10d=-1./(xarr(ib+1)-xarr(ib))
-!!$ r11d=1./(xarr(ib+1)-xarr(ib))
-!!$ r12d=-1./(xarr(ib+2)-xarr(ib+1))
-!!$
-!!$ if(interval == ib-1.or.interval == 0) then
-!!$ val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9
-!!$ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
-!!$ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
-!!$ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
-!!$ if(iflag == 1) then
-!!$ val=val+0.3333*(rr1*rr4*rr10 + rr2*rr5*rr10 + &
-!!$ rr2*rr6*rr11)
-!!$ vald=vald+0.3333*(rr1d*rr4*rr10+rr1*rr4d*rr10+ &
-!!$ rr1*rr4*rr10d)
-!!$ vald=vald+0.3333*(rr2d*rr5*rr10+rr2*rr5d*rr10+ &
-!!$ rr2*rr5*rr10d)
-!!$ vald=vald+0.3333*(rr2d*rr6*rr11+rr2*rr6d*rr11+ &
-!!$ rr2*rr6*rr11d)
-!!$ endif
-!!$ else if(interval == ib) then
-!!$ val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11
-!!$ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
-!!$ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
-!!$ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
-!!$ if(iflag == 1) then
-!!$ val=val+0.3333*rr2*rr6*rr12
-!!$ vald=vald+0.3333*(rr2d*rr6*rr12+rr2*rr6d*rr12+ &
-!!$ rr2*rr6*rr12d)
-!!$ endif
-!!$ else if(interval == ib+1) then
-!!$ val=r2*r6*r12
-!!$ vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d
-!!$ else
-!!$ val=0.
-!!$ endif
-!!$ else if(ib == np-1) then
-!!$
-!!$ rr1=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
-!!$ rr2=(xarr(np)-x)/(xarr(np)-xarr(np-1))
-!!$ rr3=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
-!!$ rr4=(xarr(np)-x)/(xarr(np)-xarr(np-1))
-!!$ rr5=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
-!!$ rr7=(x-xarr(np-2))/(xarr(np-1)-xarr(np-2))
-!!$ rr8=(xarr(np)-x)/ (xarr(np)-xarr(np-1))
-!!$ rr9=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
-!!$
-!!$ rr1d=1./(xarr(np)-xarr(np-2))
-!!$ rr2d=-1./(xarr(np)-xarr(np-1))
-!!$ rr3d=1./(xarr(np)-xarr(np-2))
-!!$ rr4d=-1./(xarr(np)-xarr(np-1))
-!!$ rr5d=1./(xarr(np)-xarr(np-1))
-!!$ rr7d=1./(xarr(np-1)-xarr(np-2))
-!!$ rr8d=-1./ (xarr(np)-xarr(np-1))
-!!$ rr9d=1./(xarr(np)-xarr(np-1))
-!!$
-!!$ r1=(x-xarr(ib-2))/(xarr(ib+1)-xarr(ib-2))
-!!$ r2=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
-!!$ r3=(x-xarr(ib-2))/(xarr(ib)-xarr(ib-2))
-!!$ r4=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
-!!$ r5=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
-!!$ r6=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
-!!$ r7=(x-xarr(ib-2))/(xarr(ib-1)-xarr(ib-2))
-!!$ r8=(xarr(ib)-x)/ (xarr(ib)-xarr(ib-1))
-!!$ r9=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
-!!$ r10=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
-!!$ r11=(x-xarr(ib)) /(xarr(ib+1)-xarr(ib))
-!!$
-!!$ r1d=1./(xarr(ib+1)-xarr(ib-2))
-!!$ r2d=-1./(xarr(ib+1)-xarr(ib-1))
-!!$ r3d=1./(xarr(ib)-xarr(ib-2))
-!!$ r4d=-1./(xarr(ib+1)-xarr(ib-1))
-!!$ r5d=1./(xarr(ib+1)-xarr(ib-1))
-!!$ r6d=-1./(xarr(ib+1)-xarr(ib))
-!!$ r7d=1./(xarr(ib-1)-xarr(ib-2))
-!!$ r8d=-1./(xarr(ib)-xarr(ib-1))
-!!$ r9d=1./(xarr(ib)-xarr(ib-1))
-!!$ r10d=-1./(xarr(ib+1)-xarr(ib))
-!!$ r11d=1./(xarr(ib+1)-xarr(ib))
-!!$
-!!$ if(interval == ib-2) then
-!!$ val=r1*r3*r7
-!!$ vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d
-!!$ else if(interval == ib-1) then
-!!$ val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9
-!!$ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
-!!$ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
-!!$ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
-!!$ if(iflag == 1) then
-!!$ val=val+0.3333*rr1*rr3*rr7
-!!$ vald=vald+0.3333*(rr1d*rr3*rr7+rr1*rr3d*rr7+ &
-!!$ rr1*rr3*rr7d)
-!!$ endif
-!!$ else if(interval == ib.or.interval == np) then
-!!$ val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11
-!!$ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
-!!$ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
-!!$ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
-!!$ if(iflag == 1) then
-!!$ val=val+0.3333*(rr1*rr3*rr8 + rr1*rr4*rr9 + &
-!!$ rr2*rr5*rr9)
-!!$ vald=vald+0.3333*(rr1d*rr3*rr8+rr1*rr3d*rr8+ &
-!!$ rr1*rr3*rr8d)
-!!$ vald=vald+0.3333*(rr1d*rr4*rr9+rr1*rr4d*rr9+ &
-!!$ rr1*rr4*rr9d)
-!!$ vald=vald+0.3333*(rr2d*rr5*rr9+rr2*rr5d*rr9+ &
-!!$ rr2*rr5*rr9d)
-!!$ endif
-!!$ else
-!!$ val=0.
-!!$ endif
-!!$ else if(ib == np) then
-!!$
-!!$ r1=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
-!!$ r2=(xarr(np)-x)/(xarr(np)-xarr(np-1))
-!!$ r3=(x-xarr(np-2))/(xarr(np)-xarr(np-2))
-!!$ r4=(xarr(np)-x)/(xarr(np)-xarr(np-1))
-!!$ r5=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
-!!$ r7=(x-xarr(np-2))/(xarr(np-1)-xarr(np-2))
-!!$ r8=(xarr(np)-x)/ (xarr(np)-xarr(np-1))
-!!$ r9=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
-!!$ r13=(x-xarr(np-1))/(xarr(np)-xarr(np-1))
-!!$
-!!$ r1d=1./(xarr(np)-xarr(np-2))
-!!$ r2d=-1./(xarr(np)-xarr(np-1))
-!!$ r3d=1./(xarr(np)-xarr(np-2))
-!!$ r4d=-1./(xarr(np)-xarr(np-1))
-!!$ r5d=1./(xarr(np)-xarr(np-1))
-!!$ r7d=1./(xarr(np-1)-xarr(np-2))
-!!$ r8d=-1./ (xarr(np)-xarr(np-1))
-!!$ r9d=1./(xarr(np)-xarr(np-1))
-!!$ r13d=1./(xarr(np)-xarr(np-1))
-!!$
-!!$ if(interval == np-2) then
-!!$ if(iflag == 0) then
-!!$ val=r1*r3*r7
-!!$ vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d
-!!$ else if(iflag == 1) then
-!!$ val=0.6667*r1*r3*r7
-!!$ vald=0.6667*(r1d*r3*r7+r1*r3d*r7+r1*r3*r7d)
-!!$ endif
-!!$ else if(interval == np-1.or.interval == np) then
-!!$ if(iflag == 0) then
-!!$ val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9 + r13**3
-!!$ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
-!!$ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
-!!$ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
-!!$ vald=vald+3.*r13d*r13**2
-!!$ else if(iflag == 1) then
-!!$ val=0.6667*(r1*r3*r8 + r1*r4*r9 + r2*r5*r9 + &
-!!$ 1.5*r13**3)
-!!$ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
-!!$ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
-!!$ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
-!!$ vald=vald+4.5*r13d*r13**2
-!!$ vald=0.6667*vald
-!!$ endif
-!!$ else
-!!$ val=0.
-!!$ endif
-!!$ else
-!!$
-!!$ r1=(x-xarr(ib-2))/(xarr(ib+1)-xarr(ib-2))
-!!$ r2=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib-1))
-!!$ r3=(x-xarr(ib-2))/(xarr(ib)-xarr(ib-2))
-!!$ r4=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib-1))
-!!$ r5=(x-xarr(ib-1))/(xarr(ib+1)-xarr(ib-1))
-!!$ r6=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib))
-!!$ r7=(x-xarr(ib-2))/(xarr(ib-1)-xarr(ib-2))
-!!$ r8=(xarr(ib)-x)/ (xarr(ib)-xarr(ib-1))
-!!$ r9=(x-xarr(ib-1))/(xarr(ib)-xarr(ib-1))
-!!$ r10=(xarr(ib+1)-x)/(xarr(ib+1)-xarr(ib))
-!!$ r11=(x-xarr(ib)) /(xarr(ib+1)-xarr(ib))
-!!$ r12=(xarr(ib+2)-x)/(xarr(ib+2)-xarr(ib+1))
-!!$
-!!$ r1d=1./(xarr(ib+1)-xarr(ib-2))
-!!$ r2d=-1./(xarr(ib+2)-xarr(ib-1))
-!!$ r3d=1./(xarr(ib)-xarr(ib-2))
-!!$ r4d=-1./(xarr(ib+1)-xarr(ib-1))
-!!$ r5d=1./(xarr(ib+1)-xarr(ib-1))
-!!$ r6d=-1./(xarr(ib+2)-xarr(ib))
-!!$ r7d=1./(xarr(ib-1)-xarr(ib-2))
-!!$ r8d=-1./ (xarr(ib)-xarr(ib-1))
-!!$ r9d=1./(xarr(ib)-xarr(ib-1))
-!!$ r10d=-1./(xarr(ib+1)-xarr(ib))
-!!$ r11d=1./(xarr(ib+1)-xarr(ib))
-!!$ r12d=-1./(xarr(ib+2)-xarr(ib+1))
-!!$
-!!$ if(interval == ib-2) then
-!!$ val=r1*r3*r7
-!!$ vald=r1d*r3*r7+r1*r3d*r7+r1*r3*r7d
-!!$ else if(interval == ib-1) then
-!!$ val=r1*r3*r8 + r1*r4*r9 + r2*r5*r9
-!!$ vald=r1d*r3*r8+r1*r3d*r8+r1*r3*r8d
-!!$ vald=vald+r1d*r4*r9+r1*r4d*r9+r1*r4*r9d
-!!$ vald=vald+r2d*r5*r9+r2*r5d*r9+r2*r5*r9d
-!!$ else if(interval == ib) then
-!!$ val=r1*r4*r10 + r2*r5*r10 + r2*r6*r11
-!!$ vald=r1d*r4*r10+r1*r4d*r10+r1*r4*r10d
-!!$ vald=vald+r2d*r5*r10+r2*r5d*r10+r2*r5*r10d
-!!$ vald=vald+r2d*r6*r11+r2*r6d*r11+r2*r6*r11d
-!!$ else if(interval == ib+1) then
-!!$ val=r2*r6*r12
-!!$ vald=r2d*r6*r12+r2*r6d*r12+r2*r6*r12d
-!!$ else
-!!$ val=0.
-!!$ endif
-!!$ endif
-!!$ splcon(ib)=val
-!!$ splcond(ib)=vald
-!!$ enddo
-!!$
-!!$ end subroutine vbspl
-
-!----------------------------------
-!----------------------------------
-
-!!$ subroutine ylm(XLAT,XLON,LMAX,Y,WK1,WK2,WK3)
-!!$
-!!$ implicit none
-!!$
-!!$ complex TEMP,FAC,DFAC
-!!$
-!!$ real(kind=4) WK1(1),WK2(1),WK3(1),Y(1),XLAT,XLON
-!!$
-!!$ integer :: LMAX
-!!$
-!!$!
-!!$! WK1,WK2,WK3 SHOULD BE DIMENSIONED AT LEAST (LMAX+1)*4
-!!$!
-!!$ real(kind=4), parameter :: RADIAN = 57.2957795
-!!$
-!!$ integer :: IM,IL1,IND,LM1,L
-!!$
-!!$ real(kind=4) :: THETA,PHI
-!!$
-!!$ THETA=(90.-XLAT)/RADIAN
-!!$ PHI=XLON/RADIAN
-!!$
-!!$ IND=0
-!!$ LM1=LMAX+1
-!!$
-!!$ DO IL1=1,LM1
-!!$
-!!$ L=IL1-1
-!!$ CALL legndr(THETA,L,L,WK1,WK2,WK3)
-!!$
-!!$ FAC=(1.,0.)
-!!$ DFAC=CEXP(CMPLX(0.,PHI))
-!!$
-!!$ do IM=1,IL1
-!!$ TEMP=FAC*CMPLX(WK1(IM),0.)
-!!$ IND=IND+1
-!!$ Y(IND)=REAL(TEMP)
-!!$ IF(IM == 1) GOTO 20
-!!$ IND=IND+1
-!!$ Y(IND)=AIMAG(TEMP)
-!!$ 20 FAC=FAC*DFAC
-!!$ enddo
-!!$
-!!$ enddo
-!!$
-!!$ end subroutine ylm
-
-!!$ subroutine legndr(THETA,L,M,X,XP,XCOSEC)
-!!$ implicit none
-!!$
-!!$ integer :: L,M,i,k,LP1,MP1
-!!$ real(kind=4) :: THETA,X,XP,XCOSEC,SFL3
-!!$
-!!$ DIMENSION X(2),XP(2),XCOSEC(2)
-!!$ DOUBLE PRECISION SMALL,SUM,COMPAR,CT,ST,FCT,COT,FPI,X1,X2,X3,F1,F2,XM,TH,DSFL3,COSEC
-!!$ DATA FPI/12.56637062D0/
-!!$! DFLOAT(I)=FLOAT(I)
-!!$ SUM=0.D0
-!!$ LP1=L+1
-!!$ TH=THETA
-!!$ CT=DCOS(TH)
-!!$ ST=DSIN(TH)
-!!$ MP1=M+1
-!!$ FCT=DSQRT(dble(FLOAT(2*L+1))/FPI)
-!!$ SFL3=SQRT(FLOAT(L*(L+1)))
-!!$ COMPAR=dble(FLOAT(2*L+1))/FPI
-!!$ DSFL3=SFL3
-!!$ SMALL=1.D-16*COMPAR
-!!$ do I=1,MP1
-!!$ X(I)=0.
-!!$ XCOSEC(I)=0.
-!!$ XP(I)=0.
-!!$ enddo
-!!$ IF(L>1.AND.ABS(THETA)>1.E-5) GO TO 3
-!!$ X(1)=FCT
-!!$ IF(L==0) RETURN
-!!$ X(1)=CT*FCT
-!!$ X(2)=-ST*FCT/DSFL3
-!!$ XP(1)=-ST*FCT
-!!$ XP(2)=-.5D0*CT*FCT*DSFL3
-!!$ IF(ABS(THETA)<1.E-5) XCOSEC(2)=XP(2)
-!!$ IF(ABS(THETA)>=1.E-5) XCOSEC(2)=X(2)/ST
-!!$ RETURN
-!!$ 3 X1=1.D0
-!!$ X2=CT
-!!$ DO I=2,L
-!!$ X3=(dble(FLOAT(2*I-1))*CT*X2-dble(FLOAT(I-1))*X1)/dble(FLOAT(I))
-!!$ X1=X2
-!!$ X2=X3
-!!$ enddo
-!!$ COT=CT/ST
-!!$ COSEC=1./ST
-!!$ X3=X2*FCT
-!!$ X2=dble(FLOAT(L))*(X1-CT*X2)*FCT/ST
-!!$ X(1)=X3
-!!$ X(2)=X2
-!!$ SUM=X3*X3
-!!$ XP(1)=-X2
-!!$ XP(2)=dble(FLOAT(L*(L+1)))*X3-COT*X2
-!!$ X(2)=-X(2)/SFL3
-!!$ XCOSEC(2)=X(2)*COSEC
-!!$ XP(2)=-XP(2)/SFL3
-!!$ SUM=SUM+2.D0*X(2)*X(2)
-!!$ IF(SUM-COMPAR>SMALL) RETURN
-!!$ X1=X3
-!!$ X2=-X2/DSQRT(dble(FLOAT(L*(L+1))))
-!!$ DO I=3,MP1
-!!$ K=I-1
-!!$ F1=DSQRT(dble(FLOAT((L+I-1)*(L-I+2))))
-!!$ F2=DSQRT(dble(FLOAT((L+I-2)*(L-I+3))))
-!!$ XM=K
-!!$ X3=-(2.D0*COT*(XM-1.D0)*X2+F2*X1)/F1
-!!$ SUM=SUM+2.D0*X3*X3
-!!$ IF(SUM-COMPAR>SMALL.AND.I/=LP1) RETURN
-!!$ X(I)=X3
-!!$ XCOSEC(I)=X(I)*COSEC
-!!$ X1=X2
-!!$ XP(I)=-(F1*X2+XM*COT*X3)
-!!$ X2=X3
-!!$ enddo
-!!$ RETURN
-!!$ end subroutine legndr
-
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_attenuation.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_attenuation.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_attenuation.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -101,6 +101,8 @@
if(myrank == 0) call read_attenuation_model(MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD, AM_V)
if(myrank /= 0) allocate(AM_V%Qtau_s(N_SLS))
+
+ ! broadcasts to all others
call MPI_BCAST(AM_V%min_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
call MPI_BCAST(AM_V%max_period, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
call MPI_BCAST(AM_V%QT_c_source, 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
@@ -108,7 +110,6 @@
call MPI_BCAST(AM_V%Qtau_s(2), 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
call MPI_BCAST(AM_V%Qtau_s(3), 1, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ier)
-
end subroutine
!
@@ -144,7 +145,7 @@
type (model_attenuation_variables) AM_V
! model_attenuation_variables
- integer min_att_period, max_att_period
+ integer :: min_att_period, max_att_period
AM_V%min_period = min_att_period * 1.0d0
AM_V%max_period = max_att_period * 1.0d0
@@ -286,15 +287,16 @@
type(attenuation_simplex_variables) AS_V
! attenuation_simplex_variables
- integer myrank
- integer REFERENCE_1D_MODEL
- double precision RICB, RCMB, R670, R220, R80
- double precision tau_e(N_SLS)
+ integer :: myrank,REFERENCE_1D_MODEL
+ double precision :: RICB, RCMB, R670, R220, R80
- integer i,ier
- double precision Qb
- double precision R120
+ ! local parameters
+ double precision :: tau_e(N_SLS)
+ double precision :: Qb
+ double precision :: R120
+ integer :: i,ier
+ ! parameter definitions
Qb = 57287.0d0
R120 = 6251.d3 ! as defined by IASP91
@@ -356,8 +358,8 @@
endif
do i = 1, AM_V%Qn
- call model_attenuation_getstored_tau(AM_V%Qmu(i), AM_V%QT_c_source, AM_V%Qtau_s, tau_e, AM_V, AM_S,AS_V)
- AM_V%Qtau_e(:,i) = tau_e(:)
+ call model_attenuation_getstored_tau(AM_V%Qmu(i), AM_V%QT_c_source, AM_V%Qtau_s, tau_e, AM_V, AM_S,AS_V)
+ AM_V%Qtau_e(:,i) = tau_e(:)
enddo
end subroutine model_attenuation_setup
@@ -367,6 +369,7 @@
!
subroutine model_attenuation_getstored_tau(Qmu_in, T_c_source, tau_s, tau_e, AM_V, AM_S, AS_V)
+
! includes min_period, max_period, and N_SLS
implicit none
@@ -425,10 +428,11 @@
type(attenuation_simplex_variables) AS_V
! attenuation_simplex_variables
- double precision Qmu_in, T_c_source
+ double precision :: Qmu_in, T_c_source
double precision, dimension(N_SLS) :: tau_s, tau_e
- integer rw
+ ! local parameters
+ integer :: rw
! READ
rw = 1
@@ -465,12 +469,15 @@
type (model_attenuation_storage_var) AM_S
! model_attenuation_storage_var
- integer myrank, ier
- double precision Qmu, Qmu_new
+ integer ier
+ double precision :: Qmu
double precision, dimension(N_SLS) :: tau_e
- integer rw
+ integer :: rw
- integer Qtmp
+ ! local parameters
+ double precision :: Qmu_new
+ integer :: myrank
+ integer :: Qtmp
integer, save :: first_time_called = 1
if(first_time_called == 1) then
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_crust.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_crust.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_crust.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -35,7 +35,6 @@
! reads and smooths crust2.0 model
!--------------------------------------------------------------------------------------------------
-
subroutine model_crust_broadcast(myrank,CM_V)
! standard routine to setup model
@@ -107,14 +106,14 @@
logical found_crust,elem_in_crust
! local parameters
- double precision h_sed,h_uc
- double precision x3,x4,x5,x6,x7,scaleval
- double precision vps(NLAYERS_CRUST),vss(NLAYERS_CRUST),rhos(NLAYERS_CRUST),thicks(NLAYERS_CRUST)
+ double precision :: h_sed,h_uc
+ double precision :: x3,x4,x5,x6,x7,scaleval
+ double precision,dimension(NLAYERS_CRUST):: vps,vss,rhos,thicks
! initializes
- vp = 0.d0
- vs = 0.d0
- rho = 0.d0
+ vp = ZERO
+ vs = ZERO
+ rho = ZERO
! gets smoothed crust2.0 structure
call crust_CAPsmoothed(lat,lon,vps,vss,rhos,thicks,CM_V%abbreviation, &
@@ -130,6 +129,13 @@
found_crust = .true.
+ ! checks moho value
+ !moho = h_uc + thicks(6) + thicks(7)
+ !if( moho /= thicks(NLAYERS_CRUST) ) then
+ ! print*,'moho:',moho,thicks(NLAYERS_CRUST)
+ ! print*,' lat/lon/x:',lat,lon,x
+ !endif
+
! if(x > x3 .and. INCLUDE_SEDIMENTS_CRUST &
! .and. h_sed >= MINIMUM_SEDIMENT_THICKNESS) then
if(x > x3 .and. INCLUDE_SEDIMENTS_CRUST ) then
@@ -190,6 +196,7 @@
subroutine read_crust_model(CM_V)
implicit none
+
include "constants.h"
! model_crust_variables
@@ -207,14 +214,12 @@
type (model_crust_variables) CM_V
! model_crust_variables
-! local variables
- integer i,ier
- integer ila,icolat
- integer ikey
+ ! local variables
+ integer :: i,ila,icolat,ikey,ier
- double precision h_moho_min,h_moho_max
+ double precision :: h_moho_min,h_moho_max
- character(len=150) CNtype2, CNtype2_key_modif
+ character(len=150) :: CNtype2, CNtype2_key_modif
call get_value_string(CNtype2, 'model.CNtype2', 'DATA/crust2.0/CNtype2.txt')
call get_value_string(CNtype2_key_modif, 'model.CNtype2_key_modif', 'DATA/crust2.0/CNtype2_key_modif.txt')
@@ -266,6 +271,7 @@
! The cap is rotated to the North Pole.
implicit none
+
include "constants.h"
! sampling rate for CAP points
@@ -273,12 +279,13 @@
integer, parameter :: NPHI = 20
! argument variables
- double precision lat,lon
- double precision rho(NLAYERS_CRUST),thick(NLAYERS_CRUST),velp(NLAYERS_CRUST),vels(NLAYERS_CRUST)
- double precision thlr(NKEYS_CRUST,NLAYERS_CRUST),velocp(NKEYS_CRUST,NLAYERS_CRUST)
- double precision velocs(NKEYS_CRUST,NLAYERS_CRUST),dens(NKEYS_CRUST,NLAYERS_CRUST)
- character(len=2) code(NKEYS_CRUST),abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+ double precision :: lat,lon
+ double precision,dimension(NLAYERS_CRUST) :: rho,thick,velp,vels
+ double precision,dimension(NKEYS_CRUST,NLAYERS_CRUST) :: thlr,velocp,velocs,dens
+ character(len=2) :: code(NKEYS_CRUST)
+ character(len=2) :: abbreviation(NCAP_CRUST/2,NCAP_CRUST)
+
!-------------------------------
! work-around to avoid jacobian problems when stretching mesh elements;
! one could also try to slightly change the shape of the doulbing element bricks (which cause the problem)...
@@ -318,9 +325,9 @@
if( dist < CRITICAL_RANGE ) then
! increases cap smoothing degree
! scales between -1 at center and 0 at border
- dist = dist / CRITICAL_RANGE - 1.0d0
+ dist = dist / CRITICAL_RANGE - ONE
! shifts value to 1 at center and 0 to the border with exponential decay
- dist = 1.0d0 - exp( - dist*dist*10.0d0 )
+ dist = ONE - exp( - dist*dist*10.0d0 )
! increases smoothing degree inside of critical region to 2 degree
cap_degree = cap_degree + dist
endif
@@ -330,10 +337,10 @@
call CAP_vardegree(lon,lat,xlon,xlat,weight,cap_degree,NTHETA,NPHI)
! initializes
- velp(:) = 0.0d0
- vels(:) = 0.0d0
- rho(:) = 0.0d0
- thick(:) = 0.0d0
+ velp(:) = ZERO
+ vels(:) = ZERO
+ rho(:) = ZERO
+ thick(:) = ZERO
! loops over weight points
do i=1,NTHETA*NPHI
@@ -378,14 +385,14 @@
! argument variables
- double precision xlat,xlon
- integer icolat,ilon
+ double precision :: xlat,xlon
+ integer :: icolat,ilon
if(xlat > 90.0d0 .or. xlat < -90.0d0 .or. xlon > 180.0d0 .or. xlon < -180.0d0) &
stop 'error in latitude/longitude range in icolat_ilon'
- icolat=int(1+((90.d0-xlat)/2.d0))
+ icolat=int(1+( (90.d0-xlat)*0.5d0 ))
if(icolat == 91) icolat=90
- ilon=int(1+((180.d0+xlon)/2.d0))
+ ilon=int(1+( (180.d0+xlon)*0.5d0 ))
if(ilon == 181) ilon=1
if(icolat>90 .or. icolat<1) stop 'error in routine icolat_ilon'
@@ -401,8 +408,7 @@
implicit none
include "constants.h"
-
-! argument variables
+ ! argument variables
integer ierr
double precision rhtyp(NLAYERS_CRUST),thtp(NLAYERS_CRUST)
double precision vptyp(NLAYERS_CRUST),vstyp(NLAYERS_CRUST)
@@ -410,7 +416,7 @@
double precision thlr(NKEYS_CRUST,NLAYERS_CRUST),velocp(NKEYS_CRUST,NLAYERS_CRUST)
double precision velocs(NKEYS_CRUST,NLAYERS_CRUST),dens(NKEYS_CRUST,NLAYERS_CRUST)
-! local variables
+ ! local variables
integer i,ikey
ierr=1
@@ -450,29 +456,26 @@
! sampling rate
integer :: NTHETA
integer :: NPHI
+
! smoothing size (in degrees)
double precision :: CAP_DEGREE
! argument variables
- double precision lat,lon
- double precision xlon(NTHETA*NPHI),xlat(NTHETA*NPHI),weight(NTHETA*NPHI)
+ double precision :: lat,lon
+ double precision,dimension(NTHETA*NPHI) :: xlon,xlat,weight
! local variables
- double precision CAP
- double precision theta,phi,sint,cost,sinp,cosp,wght,total
- double precision r_rot,theta_rot,phi_rot
- double precision rotation_matrix(3,3),x(3),xc(3)
- double precision dtheta,dphi,cap_area,dweight,pi_over_nphi
- integer i,j,k
- integer itheta,iphi
+ double precision :: CAP
+ double precision :: theta,phi,sint,cost,sinp,cosp,wght,total
+ double precision :: r_rot,theta_rot,phi_rot
+ double precision :: rotation_matrix(3,3),x(3),xc(3)
+ double precision :: dtheta,dphi,cap_area,dweight,pi_over_nphi
+ integer :: i,j,k,itheta,iphi
- double precision, parameter :: RADIANS_TO_DEGREES = 180.d0 / PI
- double precision, parameter :: PI_OVER_TWO = PI / 2.0d0
-
! initializes
- xlon(:) = 0.d0
- xlat(:) = 0.d0
- weight(:) = 0.d0
+ xlon(:) = ZERO
+ xlat(:) = ZERO
+ weight(:) = ZERO
! checks cap degree size
if( CAP_DEGREE < TINYVAL ) then
@@ -483,10 +486,11 @@
endif
! pre-compute parameters
- CAP = CAP_DEGREE * PI/180.0d0
+ CAP = CAP_DEGREE * DEGREES_TO_RADIANS
dtheta = 0.5d0 * CAP / dble(NTHETA)
dphi = TWO_PI / dble(NPHI)
- cap_area = TWO_PI * (1.0d0 - dcos(CAP))
+
+ cap_area = TWO_PI * ( ONE - dcos(CAP) )
dweight = CAP / dble(NTHETA) * dphi / cap_area
pi_over_nphi = PI/dble(NPHI)
@@ -508,12 +512,12 @@
rotation_matrix(2,2) = cosp
rotation_matrix(2,3) = sinp*sint
rotation_matrix(3,1) = -sint
- rotation_matrix(3,2) = 0.0d0
+ rotation_matrix(3,2) = ZERO
rotation_matrix(3,3) = cost
! calculates points over a cap at the North pole and rotates them to specified lat/lon point
i = 0
- total = 0.0d0
+ total = ZERO
do itheta = 1,NTHETA
theta = dble(2*itheta-1)*dtheta
@@ -540,7 +544,7 @@
! get x,y,z coordinates in cap around point of interest
do j=1,3
- x(j) = 0.0d0
+ x(j) = ZERO
do k=1,3
x(j) = x(j)+rotation_matrix(j,k)*xc(k)
enddo
@@ -556,197 +560,9 @@
enddo
enddo
- if(abs(total-1.0d0) > 0.001d0) then
+ if(abs(total - ONE) > 0.001d0) then
print*,'error cap:',total,CAP_DEGREE
stop 'error in cap integration for variable degree'
endif
- end subroutine
-
-
-!---------------------------
-! unused routines...
-!
-! subroutine crust_singlevalue(lat,lon,velp,vels,rho,thick,abbreviation,&
-! code,thlr,velocp,velocs,dens)
-!
-!! crustal vp and vs in km/s, layer thickness in km
-!
-!! uses crust2.0 as is, without smoothing
-!
-! implicit none
-! include "constants.h"
-!
-!! argument variables
-! double precision lat,lon
-! double precision rho(NLAYERS_CRUST),thick(NLAYERS_CRUST),velp(NLAYERS_CRUST),vels(NLAYERS_CRUST)
-! double precision thlr(NKEYS_CRUST,NLAYERS_CRUST),velocp(NKEYS_CRUST,NLAYERS_CRUST)
-! double precision velocs(NKEYS_CRUST,NLAYERS_CRUST),dens(NKEYS_CRUST,NLAYERS_CRUST)
-! character(len=2) code(NKEYS_CRUST),abbreviation(NCAP_CRUST/2,NCAP_CRUST)
-!
-!! local variables
-! integer icolat,ilon,ierr
-! character(len=2) crustaltype
-!
-!
-!! get integer colatitude and longitude of crustal cap
-!! -90<lat<90 -180<lon<180
-! if(lat > 90.0d0 .or. lat < -90.0d0 .or. lon > 180.0d0 .or. lon < -180.0d0) &
-! stop 'error in latitude/longitude range in crust'
-! if(lat==90.0d0) lat=89.9999d0
-! if(lat==-90.0d0) lat=-89.9999d0
-! if(lon==180.0d0) lon=179.9999d0
-! if(lon==-180.0d0) lon=-179.9999d0
-!
-! call icolat_ilon(lat,lon,icolat,ilon)
-! crustaltype = abbreviation(icolat,ilon)
-! call get_crust_structure(crustaltype,velp,vels,rho,thick, &
-! code,thlr,velocp,velocs,dens,ierr)
-! if( ierr /= 0 ) stop 'error in routine get_crust_structure'
-!
-! end subroutine crust_singlevalue
-!
-!---------------------------
-!
-!
-! subroutine crust_org(lat,lon,velp,vels,rho,thick,abbreviation,code,thlr,velocp,velocs,dens)
-!
-!! crustal vp and vs in km/s, layer thickness in km
-!! crust2.0 is smoothed with a cap of size CAP using NTHETA points
-!! in the theta direction and NPHI in the phi direction.
-!! The cap is rotated to the North Pole.
-!
-! implicit none
-! include "constants.h"
-!! Change the CAP function to smooth crustal model
-! integer, parameter :: NTHETA = 4 !2
-! integer, parameter :: NPHI = 20 !10
-! double precision, parameter :: CAP = 1.0d0*PI/180.0d0 ! 2.0d0*PI/180.0d0
-!
-!! argument variables
-! double precision lat,lon
-! double precision rho(NLAYERS_CRUST),thick(NLAYERS_CRUST),velp(NLAYERS_CRUST),vels(NLAYERS_CRUST)
-! double precision thlr(NKEYS_CRUST,NLAYERS_CRUST),velocp(NKEYS_CRUST,NLAYERS_CRUST)
-! double precision velocs(NKEYS_CRUST,NLAYERS_CRUST),dens(NKEYS_CRUST,NLAYERS_CRUST)
-! character(len=2) code(NKEYS_CRUST),abbreviation(NCAP_CRUST/2,NCAP_CRUST)
-!
-!! local variables
-! integer i,j,k,icolat,ilon,ierr
-! integer itheta,iphi,npoints
-! double precision theta,phi,sint,cost,sinp,cosp,dtheta,dphi,cap_area,wght,total
-! double precision r_rot,theta_rot,phi_rot
-! double precision rotation_matrix(3,3),x(3),xc(3)
-! double precision xlon(NTHETA*NPHI),xlat(NTHETA*NPHI),weight(NTHETA*NPHI)
-! double precision rhol(NLAYERS_CRUST),thickl(NLAYERS_CRUST),velpl(NLAYERS_CRUST),velsl(NLAYERS_CRUST)
-! character(len=2) crustaltype
-!
-!! get integer colatitude and longitude of crustal cap
-!! -90<lat<90 -180<lon<180
-! if(lat > 90.0d0 .or. lat < -90.0d0 .or. lon > 180.0d0 .or. lon < -180.0d0) &
-! stop 'error in latitude/longitude range in crust'
-! if(lat==90.0d0) lat=89.9999d0
-! if(lat==-90.0d0) lat=-89.9999d0
-! if(lon==180.0d0) lon=179.9999d0
-! if(lon==-180.0d0) lon=-179.9999d0
-!
-! call icolat_ilon(lat,lon,icolat,ilon)
-! crustaltype=abbreviation(icolat,ilon)
-! call get_crust_structure(crustaltype,velp,vels,rho,thick, &
-! code,thlr,velocp,velocs,dens,ierr)
-!
-!! uncomment the following line to use crust2.0 as is, without smoothing
-!!
-!! return
-!
-! theta = (90.0-lat)*PI/180.0
-! phi = lon*PI/180.0
-!
-! sint = sin(theta)
-! cost = cos(theta)
-! sinp = sin(phi)
-! cosp = cos(phi)
-!
-!! set up rotation matrix to go from cap at North pole
-!! to cap around point of interest
-! rotation_matrix(1,1) = cosp*cost
-! rotation_matrix(1,2) = -sinp
-! rotation_matrix(1,3) = cosp*sint
-! rotation_matrix(2,1) = sinp*cost
-! rotation_matrix(2,2) = cosp
-! rotation_matrix(2,3) = sinp*sint
-! rotation_matrix(3,1) = -sint
-! rotation_matrix(3,2) = 0.0
-! rotation_matrix(3,3) = cost
-!
-! dtheta = CAP/dble(NTHETA)
-! dphi = 2.0*PI/dble(NPHI)
-! cap_area = 2.0*PI*(1.0-cos(CAP))
-!
-!! integrate over a cap at the North pole
-! i = 0
-! total = 0.0
-! do itheta = 1,NTHETA
-!
-! theta = 0.5*dble(2*itheta-1)*CAP/dble(NTHETA)
-! cost = cos(theta)
-! sint = sin(theta)
-! wght = sint*dtheta*dphi/cap_area
-!
-! do iphi = 1,NPHI
-!
-! i = i+1
-!! get the weight associated with this integration point (same for all phi)
-! weight(i) = wght
-! total = total + weight(i)
-! phi = dble(2*iphi-1)*PI/dble(NPHI)
-! cosp = cos(phi)
-! sinp = sin(phi)
-!! x,y,z coordinates of integration point in cap at North pole
-! xc(1) = sint*cosp
-! xc(2) = sint*sinp
-! xc(3) = cost
-!! get x,y,z coordinates in cap around point of interest
-! do j=1,3
-! x(j) = 0.0
-! do k=1,3
-! x(j) = x(j)+rotation_matrix(j,k)*xc(k)
-! enddo
-! enddo
-!! get latitude and longitude (degrees) of integration point
-! call xyz_2_rthetaphi_dble(x(1),x(2),x(3),r_rot,theta_rot,phi_rot)
-! call reduce(theta_rot,phi_rot)
-! xlat(i) = (PI/2.0-theta_rot)*180.0/PI
-! xlon(i) = phi_rot*180.0/PI
-! if(xlon(i) > 180.0) xlon(i) = xlon(i)-360.0
-!
-! enddo
-!
-! enddo
-!
-! if(abs(total-1.0) > 0.001) stop 'error in cap integration for crust2.0'
-!
-! npoints = i
-!
-! do j=1,NLAYERS_CRUST
-! rho(j)=0.0d0
-! thick(j)=0.0d0
-! velp(j)=0.0d0
-! vels(j)=0.0d0
-! enddo
-!
-! do i=1,npoints
-! call icolat_ilon(xlat(i),xlon(i),icolat,ilon)
-! crustaltype=abbreviation(icolat,ilon)
-! call get_crust_structure(crustaltype,velpl,velsl,rhol,thickl, &
-! code,thlr,velocp,velocs,dens,ierr)
-! if(ierr /= 0) stop 'error in routine get_crust_structure'
-! do j=1,NLAYERS_CRUST
-! rho(j)=rho(j)+weight(i)*rhol(j)
-! thick(j)=thick(j)+weight(i)*thickl(j)
-! velp(j)=velp(j)+weight(i)*velpl(j)
-! vels(j)=vels(j)+weight(i)*velsl(j)
-! enddo
-! enddo
-!
-! end subroutine crust_org
-
+ end subroutine CAP_vardegree
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_crustmaps.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_crustmaps.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_crustmaps.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -121,7 +121,7 @@
implicit none
include "constants.h"
-!Matthias Meschede
+! Matthias Meschede
!model_crustmaps_variables
type model_crustmaps_variables
sequence
@@ -273,11 +273,11 @@
!model_crustmaps_variables
- double precision lat,lon,x,vp,vs,rho,moho
- logical found_crust,elem_in_crust
- double precision h_sed,h_uc
- double precision x3,x4,x5,x6,x7,scaleval
- double precision vps(NLAYERS_CRUSTMAP),vss(NLAYERS_CRUSTMAP),rhos(NLAYERS_CRUSTMAP),thicks(NLAYERS_CRUSTMAP)
+ double precision :: lat,lon,x,vp,vs,rho,moho
+ logical :: found_crust,elem_in_crust
+ double precision :: h_sed,h_uc
+ double precision :: x3,x4,x5,x6,x7,scaleval
+ double precision,dimension(NLAYERS_CRUSTMAP) :: vps,vss,rhos,thicks
call read_crustmaps(lat,lon,vps,vss,rhos,thicks,GC_V)
@@ -346,13 +346,15 @@
! crustal vp and vs in km/s, layer thickness in km
implicit none
+
include "constants.h"
-! argument variables
+ ! argument variables
double precision lat,lon
double precision rhos(5),thicks(5),velp(5),vels(5)
-!Matthias Meschede
+
+! Matthias Meschede
!model_crustmaps_variables
type model_crustmaps_variables
sequence
@@ -569,10 +571,10 @@
subroutine ibilinearmap(lat,lng,iupcolat,ileftlng,weightup,weightleft)
implicit none
+
include "constants.h"
-
-! argument variables
+ ! argument variables
double precision weightup,weightleft
double precision lat,lng, xlng
double precision buffer
@@ -603,42 +605,4 @@
if(ileftlng<1) ileftlng=360*CRUSTMAP_RESOLUTION
if(ileftlng>360*CRUSTMAP_RESOLUTION) ileftlng=1
-
-
end subroutine ibilinearmap
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-!
-! subroutine ilatlng(lat,lng,icolat,ilng)
-!
-! implicit none
-! include "constants.h"
-!
-!
-! ! argument variables
-! double precision lat,lng, xlng
-! integer icolat,ilng
-!
-! if(lat > 90.0d0 .or. lat < -90.0d0 .or. lng > 180.0d0 .or. lng < -180.0d0) &
-! stop 'error in latitude/longitude range in icolat_ilon'
-!
-! if(lng<0) then
-! xlng=lng+360.0
-! else
-! xlng=lng
-! endif
-!
-! icolat=int(1+((90.0-lat)*CRUSTMAP_RESOLUTION))
-! ! icolat=10
-! if(icolat == 180*CRUSTMAP_RESOLUTION+1) icolat=180*CRUSTMAP_RESOLUTION
-! ilng=int(1+(xlng*CRUSTMAP_RESOLUTION))
-! ! ilng=10
-! if(ilng == 360*CRUSTMAP_RESOLUTION+1) ilng=360*CRUSTMAP_RESOLUTION
-!
-! if(icolat>180*CRUSTMAP_RESOLUTION .or. icolat<1) stop 'error in routine icolat_ilon'
-! if(ilng<1 .or. ilng>360*CRUSTMAP_RESOLUTION) stop 'error in routine icolat_ilon'
-!
-! end subroutine ilatlng
-
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_epcrust.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_epcrust.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_epcrust.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -79,6 +79,7 @@
subroutine read_epcrust_model(EPCRUST)
implicit none
+
include "constants.h"
type model_epcrust_variables
@@ -94,7 +95,7 @@
character(len=150) EPCRUST_FNM
character(len=150),dimension(15) :: header
double precision,dimension(15) :: tmp
- integer:: ier, ilon, jlat
+ integer:: ilon,jlat,ier
call get_value_string(EPCRUST_FNM,'model.EPCRUST_FNM',PATHNAME_EPCRUST)
@@ -158,9 +159,9 @@
! stop 'incorrect enter EPCRUST model, check lat and lon'
!endif
- vp=0.0d0
- vs=0.0d0
- rho=0.0d0
+ vp = ZERO
+ vs = ZERO
+ rho = ZERO
if ( .not. flag_smooth_epcrust) then
call ilon_jlat(lon,lat,ilon,jlat)
@@ -171,11 +172,11 @@
rhosmooth(:)=EPCRUST%rho_ep(ilon,jlat,:)
else
call epcrust_smooth_base(lon,lat,x1,y1,weight)
- z0=0.d0
- zsmooth(:)=0.0d0
- vpsmooth(:)=0.0d0
- vssmooth(:)=0.0d0
- rhosmooth(:)=0.0d0
+ z0 = ZERO
+ zsmooth(:) = ZERO
+ vpsmooth(:) = ZERO
+ vssmooth(:) = ZERO
+ rhosmooth(:) = ZERO
do k = 1,NTHETA_EP*NPHI_EP
call ilon_jlat(x1(k),y1(k),ilon,jlat)
@@ -258,12 +259,10 @@
double precision,dimension(3,3):: rotation_matrix
double precision,dimension(3):: xx,xc
integer:: i,j,k,itheta,iphi
- double precision:: RADIANS_TO_DEGREES = 180.d0/PI
- double precision:: PI_OVER_TWO = PI/2.0d0
- x1(:)=0.0d0
- y1(:)=0.0d0
- weight(:)=0.0d0
+ x1(:)=ZERO
+ y1(:)=ZERO
+ weight(:)=ZERO
if (cap_degree_EP < TINYVAL ) then
print*, 'error cap:', cap_degree_EP
@@ -271,9 +270,10 @@
stop 'error cap_degree too small'
endif
- CAP=cap_degree_EP*PI/180.0d0
+ CAP=cap_degree_EP * DEGREES_TO_RADIANS
dtheta=0.5d0*CAP/dble(NTHETA_EP)
dphi=TWO_PI/dble(NPHI_EP)
+
cap_area=TWO_PI*(1.0d0-dcos(CAP))
dweight=CAP/dble(NTHETA_EP)*dphi/cap_area
pi_over_nphi=PI/dble(NPHI_EP)
@@ -293,7 +293,7 @@
rotation_matrix(2,2)=cosp
rotation_matrix(2,3)=sinp*sint
rotation_matrix(3,1)=-sint
- rotation_matrix(3,2)=0.0d0
+ rotation_matrix(3,2)=ZERO
rotation_matrix(3,3)=cost
i=0
@@ -343,6 +343,7 @@
subroutine ilon_jlat(lon,lat,ilon,jlat)
implicit none
+
include "constants.h"
double precision:: lon,lat
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_eucrust.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_eucrust.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_eucrust.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -63,6 +63,7 @@
! 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)
+ ! allocates on all other processes
if( myrank /= 0 ) then
allocate(EUCM_V%eucrust_vp_uppercrust(EUCM_V%num_eucrust),EUCM_V%eucrust_vp_lowercrust(EUCM_V%num_eucrust),&
EUCM_V%eucrust_mohodepth(EUCM_V%num_eucrust),EUCM_V%eucrust_basement(EUCM_V%num_eucrust),&
@@ -98,11 +99,10 @@
end type model_eucrust_variables
type (model_eucrust_variables) EUCM_V
-
! local variables
character(len=80):: line
character(len=150):: filename
- integer:: i,ierror
+ integer:: i,ier
double precision:: vp_uppercrust,vp_lowercrust,vp_avg,topo,basement
double precision:: upper_lower_depth,moho_depth,lat,lon
@@ -122,9 +122,9 @@
! opens data file
call get_value_string(filename, 'model.eu', 'DATA/eucrust-07/ds01.txt')
- open(unit=11,file=filename,status='old',action='read',iostat=ierror)
- if ( ierror /= 0 ) then
- write(IMAIN,*) 'error opening "', trim(filename), '": ', ierror
+ open(unit=11,file=filename,status='old',action='read',iostat=ier)
+ if ( ier /= 0 ) then
+ write(IMAIN,*) 'error opening "', trim(filename), '": ', ier
call exit_MPI(0, 'error model eucrust')
endif
@@ -134,8 +134,8 @@
! data
do i=1,36058
- read(11,'(a80)',iostat=ierror) line
- if(ierror /= 0 ) stop
+ read(11,'(a80)',iostat=ier) line
+ if( ier /= 0 ) stop 'error reading EUcrust file'
read(line,*)lon,lat,vp_uppercrust,vp_lowercrust,vp_avg,topo,basement,upper_lower_depth,moho_depth
@@ -297,6 +297,7 @@
! The cap is rotated to the North Pole.
implicit none
+
include "constants.h"
! argument variables
@@ -316,7 +317,7 @@
integer, parameter :: NTHETA = 4
integer, parameter :: NPHI = 10
- double precision, parameter :: CAP = 1.0d0*PI/180.0d0 ! 1 degree smoothing
+ double precision, parameter :: CAP = 1.0d0 * DEGREES_TO_RADIANS ! 1 degree smoothing
double precision,external :: crust_eu
@@ -345,8 +346,8 @@
! value = func(lat,lon,x,value,found,EUCM_V)
! return
- theta = (90.0-lat)*PI/180.0
- phi = lon*PI/180.0
+ theta = (90.0-lat)*DEGREES_TO_RADIANS
+ phi = lon*DEGREES_TO_RADIANS
sint = sin(theta)
cost = cos(theta)
@@ -366,8 +367,8 @@
rotation_matrix(3,3) = cost
dtheta = CAP/dble(NTHETA)
- dphi = 2.0*PI/dble(NPHI)
- cap_area = 2.0*PI*(1.0-cos(CAP))
+ dphi = TWO_PI/dble(NPHI)
+ cap_area = TWO_PI*(1.0-cos(CAP))
! integrate over a cap at the North pole
i = 0
@@ -402,8 +403,8 @@
! get latitude and longitude (degrees) of integration point
call xyz_2_rthetaphi_dble(x(1),x(2),x(3),r_rot,theta_rot,phi_rot)
call reduce(theta_rot,phi_rot)
- xlat(i) = (PI/2.0-theta_rot)*180.0/PI
- xlon(i) = phi_rot*180.0/PI
+ xlat(i) = (PI_OVER_TWO-theta_rot)*RADIANS_TO_DEGREES
+ xlon(i) = phi_rot*RADIANS_TO_DEGREES
if(xlon(i) > 180.0) xlon(i) = xlon(i)-360.0
enddo
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_gapp2.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_gapp2.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_gapp2.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -105,10 +105,7 @@
! reads in GAP-P2 model from Obayashi
open(unit=10,file=GAPP2,status='old',action='read',iostat=ier)
- if ( ier /= 0 ) then
- write(IMAIN,*) 'error opening "', trim(GAPP2), '": ', ier
- call exit_MPI(0, 'error model GAPP2')
- endif
+ if( ier /= 0 ) call exit_MPI(0,'error opening file for GAPP2 model')
read(10,*) no,na,nnr,dela,delo
@@ -197,8 +194,8 @@
drho = ZERO_
! increments in latitude/longitude (in rad)
- dtheta = dela * PI / 180.0
- dphi = delo * PI / 180.0
+ dtheta = dela * DEGREES_TO_RADIANS
+ dphi = delo * DEGREES_TO_RADIANS
! depth given in km
d=R_EARTH_-radius*R_EARTH_
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_gll.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_gll.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_gll.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -33,7 +33,6 @@
! used for iterative inversion procedures
!--------------------------------------------------------------------------------------------------
-
subroutine model_gll_broadcast(myrank,MGLL_V,NSPEC)
! standard routine to setup model
@@ -256,8 +255,8 @@
! vp mesh
open(unit=27,file=prname(1:len_trim(prname))//'vp_new.bin',&
status='old',action='read',form='unformatted',iostat=ier)
- if ( ier /= 0 ) then
- write(IMAIN,*) 'error opening "',prname(1:len_trim(prname))//'vp_new.bin', '": ', ier
+ if( ier /= 0 ) then
+ write(IMAIN,*) 'error opening: ',prname(1:len_trim(prname))//'vp_new.bin'
call exit_MPI(myrank,'error model gll')
endif
read(27) MGLL_V%vp_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
@@ -266,8 +265,8 @@
! vs mesh
open(unit=27,file=prname(1:len_trim(prname))//'vs_new.bin', &
status='old',action='read',form='unformatted',iostat=ier)
- if ( ier /= 0 ) then
- print*,'error opening "',prname(1:len_trim(prname))//'vs_new.bin', '": ', ier
+ if( ier /= 0 ) then
+ print*,'error opening: ',prname(1:len_trim(prname))//'vs_new.bin'
call exit_MPI(myrank,'error model gll')
endif
read(27) MGLL_V%vs_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
@@ -279,8 +278,8 @@
! vp mesh
open(unit=27,file=prname(1:len_trim(prname))//'vpv_new.bin',&
status='old',action='read',form='unformatted',iostat=ier)
- if ( ier /= 0 ) then
- write(IMAIN,*) 'error opening "',prname(1:len_trim(prname))//'vpv_new.bin', '": ', ier
+ if( ier /= 0 ) then
+ write(IMAIN,*) 'error opening: ',prname(1:len_trim(prname))//'vpv_new.bin'
call exit_MPI(myrank,'error model gll')
endif
read(27) MGLL_V%vpv_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
@@ -288,8 +287,8 @@
open(unit=27,file=prname(1:len_trim(prname))//'vph_new.bin',&
status='old',action='read',form='unformatted',iostat=ier)
- if ( ier /= 0 ) then
- write(IMAIN,*) 'error opening "',prname(1:len_trim(prname))//'vph_new.bin', '": ', ier
+ if( ier /= 0 ) then
+ write(IMAIN,*) 'error opening: ',prname(1:len_trim(prname))//'vph_new.bin'
call exit_MPI(myrank,'error model gll')
endif
read(27) MGLL_V%vph_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
@@ -298,8 +297,8 @@
! vs mesh
open(unit=27,file=prname(1:len_trim(prname))//'vsv_new.bin', &
status='old',action='read',form='unformatted',iostat=ier)
- if ( ier /= 0 ) then
- print*,'error opening "',prname(1:len_trim(prname))//'vsv_new.bin', '": ', ier
+ if( ier /= 0 ) then
+ print*,'error opening: ',prname(1:len_trim(prname))//'vsv_new.bin'
call exit_MPI(myrank,'error model gll')
endif
read(27) MGLL_V%vsv_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
@@ -307,8 +306,8 @@
open(unit=27,file=prname(1:len_trim(prname))//'vsh_new.bin', &
status='old',action='read',form='unformatted',iostat=ier)
- if ( ier /= 0 ) then
- print*,'error opening "',prname(1:len_trim(prname))//'vsh_new.bin', '": ', ier
+ if( ier /= 0 ) then
+ print*,'error opening: ',prname(1:len_trim(prname))//'vsh_new.bin'
call exit_MPI(myrank,'error model gll')
endif
read(27) MGLL_V%vsh_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
@@ -317,8 +316,8 @@
! eta mesh
open(unit=27,file=prname(1:len_trim(prname))//'eta_new.bin', &
status='old',action='read',form='unformatted',iostat=ier)
- if ( ier /= 0 ) then
- print*,'error opening "',prname(1:len_trim(prname))//'eta_new.bin', '": ', ier
+ if( ier /= 0 ) then
+ print*,'error opening: ',prname(1:len_trim(prname))//'eta_new.bin'
call exit_MPI(myrank,'error model gll')
endif
read(27) MGLL_V%eta_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
@@ -329,8 +328,8 @@
! rho mesh
open(unit=27,file=prname(1:len_trim(prname))//'rho_new.bin', &
status='old',action='read',form='unformatted',iostat=ier)
- if ( ier /= 0 ) then
- print*,'error opening "',prname(1:len_trim(prname))//'rho_new.bin', '": ', ier
+ if( ier /= 0 ) then
+ print*,'error opening: ',prname(1:len_trim(prname))//'rho_new.bin'
call exit_MPI(myrank,'error model gll')
endif
read(27) MGLL_V%rho_new(:,:,:,1:nspec(IREGION_CRUST_MANTLE))
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_heterogen_mantle.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_heterogen_mantle.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_heterogen_mantle.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -51,6 +51,8 @@
! model_heterogen_m_variables
integer :: myrank
+
+ ! local parameters
integer :: ier
if(myrank == 0) then
@@ -85,7 +87,8 @@
include "constants.h"
- integer i,j,ier
+ ! local parameters
+ integer :: i,j,ier
! model_heterogen_m_variables
type model_heterogen_m_variables
@@ -97,13 +100,10 @@
! model_heterogen_m_variables
-! open heterogen.dat
+ ! open heterogen.dat
open(unit=10,file='./DATA/heterogen/heterogen.dat',access='direct',&
form='formatted',recl=20,status='old',action='read',iostat=ier)
- if ( ier /= 0 ) then
- write(IMAIN,*) 'error opening "./DATA/heterogen/heterogen.dat": ', ier
- call exit_MPI(0, 'error model heterogen')
- endif
+ if( ier /= 0 ) call exit_MPI(0,'error opening model file heterogen.dat')
j = N_R*N_THETA*N_PHI
@@ -115,7 +115,9 @@
end subroutine read_heterogen_mantle_model
-!====================================================================
+!
+!-------------------------------------------------------------------------------------------------
+!
subroutine model_heterogen_mantle(radius,theta,phi,dvs,dvp,drho,HMM)
@@ -124,18 +126,19 @@
include "constants.h"
! variable declaration
- double precision radius,theta,phi ! input coordinates
- double precision x,y,z ! input converted to cartesian
- double precision drho,dvp,dvs ! output anomaly values
- double precision x_low,x_high ! x values used to interpolate
- double precision y_low,y_high ! y values used to interpolate
- double precision z_low,z_high ! z values used to interpolate
- double precision delta,delta2 ! weigts in record# and in interpolation
- double precision rho1,rho2,rho3,rho4,rho5,rho6,rho7,rho8 ! rho values at the interpolation points
- double precision r_inner,r_outer ! lower and upper domain bounds for r
- integer rec_read ! nr of record to be read from heterogen.dat (direct access file)
- double precision a,b,c ! substitutions in interpolation algorithm (weights)
+ double precision :: radius,theta,phi ! input coordinates
+ double precision :: drho,dvp,dvs ! output anomaly values
+ ! local parameters
+ double precision :: x,y,z ! input converted to cartesian
+ double precision :: x_low,x_high ! x values used to interpolate
+ double precision :: y_low,y_high ! y values used to interpolate
+ double precision :: z_low,z_high ! z values used to interpolate
+ double precision :: delta,delta2 ! weigts in record# and in interpolation
+ double precision :: rho1,rho2,rho3,rho4,rho5,rho6,rho7,rho8 ! rho values at the interpolation points
+ double precision :: r_inner,r_outer ! lower and upper domain bounds for r
+ integer :: rec_read ! nr of record to be read from heterogen.dat (direct access file)
+ double precision :: a,b,c ! substitutions in interpolation algorithm (weights)
! model_heterogen_m_variables
type model_heterogen_m_variables
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_jp3d.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_jp3d.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_jp3d.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -143,6 +143,7 @@
integer :: myrank
integer :: ier
+ ! master reads in values
if(myrank == 0) call read_jp3d_iso_zhao_model(JP3DM_V)
! JP3DM_V
@@ -201,7 +202,6 @@
call MPI_BCAST(JP3DM_V%RA,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(JP3DM_V%DEPJ,29,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
-
end subroutine model_jp3d_broadcast
!
@@ -294,7 +294,7 @@
end subroutine read_jp3d_iso_zhao_model
!
-!==========================================================================
+!-------------------------------------------------------------------------------------------------
!
subroutine model_jp3d_iso_zhao(radius,theta,phi,vp,vs,dvp,dvs,rho,found_crust,JP3DM_V)
@@ -434,13 +434,15 @@
END subroutine model_jp3d_iso_zhao
!
-!---------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
!
SUBROUTINE INPUT1(JP3DM_V)
+
implicit none
include "constants.h"
+
! model_jp3d_variables
type model_jp3d_variables
sequence
@@ -630,15 +632,17 @@
DO 3 I = NP,1,-1
READ(3,130) (JP3DM_V%DEPC(I,J),J=1,NNR)
3 CONTINUE
+
100 FORMAT(2I6)
110 FORMAT(5(10F7.2/),F7.2)
120 FORMAT(6(10F7.2/),3F7.2)
130 FORMAT(6(10F7.1/),3F7.1)
- RETURN
- END
+ RETURN
+ END
+
!
-!-----------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
!
SUBROUTINE BLDMAP(JP3DM_V)
@@ -723,6 +727,9 @@
RETURN
END
+!
+!-------------------------------------------------------------------------------------------------
+!
SUBROUTINE LOCX(PNX,RNX,HNX,NPX,NRX,NHX,MKX, &
PLX,RLX,HLX,IPLOCX,IRLOCX,IHLOCX)
integer :: NPX,NRX,NHX,MKX,IPLOCX(MKX),IRLOCX(MKX),IHLOCX(MKX)
@@ -881,7 +888,6 @@
include "constants.h"
-
! model_jp3d_variables
type model_jp3d_variables
sequence
@@ -962,14 +968,22 @@
RETURN
END
- SUBROUTINE INTMAP(R,IRLOC,NNR,RL,IR)
- integer :: NNR,IRLOC(NNR),IS,IR
- double precision :: R,RL
- IS = IDNINT(R+RL)
- IR = IRLOC(IS)
- RETURN
- END
+!
+!-------------------------------------------------------------------------------------------------
+!
+ SUBROUTINE INTMAP(R,IRLOC,NNR,RL,IR)
+
+ implicit none
+ integer :: NNR,IRLOC(NNR),IS,IR
+ double precision :: R,RL
+
+ IS = IDNINT(R+RL)
+ IR = IRLOC(IS)
+
+ RETURN
+ END
+
!
!------------------------------------------------------------------------------------------------
!
@@ -1189,19 +1203,27 @@
+ WV3*JP3DM_V%DEPC(I,J1) + WV4*JP3DM_V%DEPC(I1,J1)
ELSE
endif
- RETURN
- END SUBROUTINE HLAY
+ RETURN
+ END SUBROUTINE HLAY
- SUBROUTINE LIMIT(C1,C2,C)
- double precision :: A1,A2,C1,C2,C
- A1 = dmin1(C1,C2)
- A2 = dmax1(C1,C2)
- IF(C<A1) C = A1
- IF(C>A2) C = A2
- END SUBROUTINE LIMIT
+!
+!-------------------------------------------------------------------------------------------------
+!
+ SUBROUTINE LIMIT(C1,C2,C)
+
+ implicit none
+ double precision :: A1,A2,C1,C2,C
+
+ A1 = dmin1(C1,C2)
+ A2 = dmax1(C1,C2)
+ IF(C<A1) C = A1
+ IF(C>A2) C = A2
+
+ END SUBROUTINE LIMIT
+
!
-!-----------------------------
+!-------------------------------------------------------------------------------------------------
!
SUBROUTINE VEL1D(HE,V,LAY,IPS,JP3DM_V)
implicit none
@@ -1296,9 +1318,14 @@
endif
ELSE
endif
- RETURN
- END
+ RETURN
+ END
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
SUBROUTINE INPUTJP(JP3DM_V)
implicit none
@@ -1393,11 +1420,12 @@
JP3DM_V%RA(L) = RA1(L)
JP3DM_V%DEPJ(L) = 40.0+6325.59*(1.0-RA1(L))
1 CONTINUE
- RETURN
- END
+ RETURN
+ END
+
!
-!---------------------------------------------
+!-------------------------------------------------------------------------------------------------
!
SUBROUTINE JPMODEL(IPS,H,V,JP3DM_V)
implicit none
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_ppm.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_ppm.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_ppm.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -62,6 +62,7 @@
double precision,parameter:: radtodeg = 180.0d0/PI
! ----------------------
+
! scale perturbations in shear speed to perturbations in density and vp
logical,parameter:: SCALE_MODEL = .false.
@@ -140,7 +141,6 @@
end subroutine model_ppm_broadcast
-
!
!--------------------------------------------------------------------------------------------------
!
@@ -173,9 +173,9 @@
! counts entries
counter=0
open(unit=10,file=trim(filename),status='old',action='read',iostat=ier)
- if ( ier /= 0 ) then
- write(IMAIN,*) 'error opening "', trim(filename), '": ', ier
- call exit_mpi(0, "error opening model ppm")
+ if( ier /= 0 ) then
+ write(IMAIN,*) ' error opening: ',trim(filename)
+ call exit_mpi(0,"error opening model ppm")
endif
! first line is text and will be ignored
@@ -214,7 +214,7 @@
! vs values
open(unit=10,file=trim(filename),status='old',action='read',iostat=ier)
if( ier /= 0 ) then
- write(IMAIN,*) ' error opening "', trim(filename), '": ', ier
+ write(IMAIN,*) ' error opening: ',trim(filename)
call exit_mpi(0,"error opening model ppm")
endif
read(10,'(a150)') line ! first line is text
@@ -243,7 +243,6 @@
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) )
@@ -345,7 +344,7 @@
end type model_ppm_variables
type (model_ppm_variables) PPM_V
- double precision radius,theta,phi,dvs,dvp,drho
+ double precision :: radius,theta,phi,dvs,dvp,drho
! local parameters
integer:: i,j,k
@@ -363,10 +362,10 @@
r_depth = R_EARTH_KM*(1.0 - radius) ! radius is normalized between [0,1]
if(r_depth>PPM_V%maxdepth .or. r_depth < PPM_V%mindepth) return
- lat=(pi_by2-theta)*radtodeg
+ lat=(PI_OVER_TWO-theta)*RADIANS_TO_DEGREES
if( lat < PPM_V%minlat .or. lat > PPM_V%maxlat ) return
- lon=phi*radtodeg
+ lon=phi*RADIANS_TO_DEGREES
if(lon>180.0d0) lon=lon-360.0d0
if( lon < PPM_V%minlon .or. lon > PPM_V%maxlon ) return
@@ -391,12 +390,12 @@
call get_PPMmodel_value(g_lat,g_lon,g_depth,PPM_V,g_dvs)
! horizontal weighting
- x = (g_lat-lat)*degtokm
+ x = (g_lat-lat)*DEGREES_TO_RADIANS*R_EARTH_KM
call get_Gaussianweight(x,sigma_h,g_weight)
g_dvs = g_dvs*g_weight
weight_prod = g_weight
- x = (g_lon-lon)*degtokm
+ x = (g_lon-lon)*DEGREES_TO_RADIANS*R_EARTH_KM
call get_Gaussianweight(x,sigma_h,g_weight)
g_dvs = g_dvs*g_weight
weight_prod = weight_prod * g_weight
@@ -534,14 +533,14 @@
!
subroutine smooth_model(myrank, nproc_xi,nproc_eta,&
- rho_vp,rho_vs,nspec_stacey, &
- iregion_code,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore, &
- xstore,ystore,zstore,rhostore,dvpstore, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,&
- nspec,HETEROGEN_3D_MANTLE, &
- NEX_XI,NCHUNKS,ABSORBING_CONDITIONS,PPM_V )
+ rho_vp,rho_vs,nspec_stacey, &
+ iregion_code,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore, &
+ xstore,ystore,zstore,rhostore,dvpstore, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,&
+ nspec,HETEROGEN_3D_MANTLE, &
+ NEX_XI,NCHUNKS,ABSORBING_CONDITIONS,PPM_V )
! smooth model parameters
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_s20rts.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_s20rts.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_s20rts.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -61,6 +61,8 @@
! model_s20rts_variables
integer :: myrank
+
+ ! local parameters
integer :: ier
! the variables read are declared and stored in structure S20RTS_V
@@ -76,6 +78,7 @@
call MPI_BCAST(S20RTS_V%qq,3*(NK_20+1)*(NK_20+1),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
end subroutine model_s20rts_broadcast
+
!
!-------------------------------------------------------------------------------------------------
!
@@ -101,19 +104,18 @@
type (model_s20rts_variables) S20RTS_V
! model_s20rts_variables
- integer k,l,m,ier
+ ! local parameters
+ integer :: k,l,m,ier
character(len=150) S20RTS, P12
call get_value_string(S20RTS, 'model.S20RTS', 'DATA/s20rts/S20RTS.dat')
call get_value_string(P12, 'model.P12', 'DATA/s20rts/P12.dat')
-! S20RTS degree 20 S model from Ritsema
+ ! S20RTS degree 20 S model from Ritsema
open(unit=10,file=S20RTS,status='old',action='read',iostat=ier)
- if ( ier /= 0 ) then
- write(IMAIN,*) 'error opening "', trim(S20RTS), '": ', ier
- call exit_MPI(0, 'error model s20rts')
- endif
+ if( ier /= 0 ) call exit_MPI(0,'error opening file S20RTS.dat')
+
do k=0,NK_20
do l=0,NS_20
read(10,*) S20RTS_V%dvs_a(k,l,0),(S20RTS_V%dvs_a(k,l,m),S20RTS_V%dvs_b(k,l,m),m=1,l)
@@ -121,12 +123,10 @@
enddo
close(10)
-! P12 degree 12 P model from Ritsema
+ ! P12 degree 12 P model from Ritsema
open(unit=10,file=P12,status='old',action='read',iostat=ier)
- if ( ier /= 0 ) then
- write(IMAIN,*) 'error opening "', trim(P12), '": ', ier
- call exit_MPI(0, 'error model s20rts')
- endif
+ if( ier /= 0 ) call exit_MPI(0,'error opening file P12.dat')
+
do k=0,NK_20
do l=0,12
read(10,*) S20RTS_V%dvp_a(k,l,0),(S20RTS_V%dvp_a(k,l,m),S20RTS_V%dvp_b(k,l,m),m=1,l)
@@ -141,7 +141,7 @@
enddo
close(10)
-! set up the splines used as radial basis functions by Ritsema
+ ! set up the splines used as radial basis functions by Ritsema
call s20rts_splhsetup(S20RTS_V)
end subroutine read_model_s20rts
@@ -169,22 +169,23 @@
type (model_s20rts_variables) S20RTS_V
! model_s20rts_variables
-! factor to convert perturbations in shear speed to perturbations in density
+ double precision :: radius,theta,phi,dvs,dvp,drho
+
+ ! local parameters
+ ! factor to convert perturbations in shear speed to perturbations in density
double precision, parameter :: SCALE_RHO = 0.40d0
- double precision radius,theta,phi,dvs,dvp,drho
-
double precision, parameter :: RMOHO_ = 6346600.d0
double precision, parameter :: RCMB_ = 3480000.d0
double precision, parameter :: R_EARTH_ = 6371000.d0
double precision, parameter :: ZERO_ = 0.d0
- integer l,m,k
- double precision r_moho,r_cmb,xr
- double precision dvs_alm,dvs_blm
- double precision dvp_alm,dvp_blm
- double precision s20rts_rsple,radial_basis(0:NK_20)
- double precision sint,cost,x(2*NS_20+1),dx(2*NS_20+1)
+ integer :: l,m,k
+ double precision :: r_moho,r_cmb,xr
+ double precision :: dvs_alm,dvs_blm
+ double precision :: dvp_alm,dvp_blm
+ double precision :: s20rts_rsple,radial_basis(0:NK_20)
+ double precision :: sint,cost,x(2*NS_20+1),dx(2*NS_20+1)
dvs = ZERO_
dvp = ZERO_
@@ -234,15 +235,15 @@
end subroutine mantle_s20rts
+!
!----------------------------------
+!
subroutine s20rts_splhsetup(S20RTS_V)!!!!!!!!!!!!!!(spknt,qq0,qq)
implicit none
include "constants.h"
-!!!!!!!!!!!!!!!!!!! double precision spknt(NK_20+1),qq0(NK_20+1,NK_20+1),qq(3,NK_20+1,NK_20+1)
-
! model_s20rts_variables
type model_s20rts_variables
sequence
@@ -299,7 +300,9 @@
end subroutine s20rts_splhsetup
+!
!----------------------------------
+!
! changed the obsolecent f77 features in the two routines below
! now still awful Fortran, but at least conforms to f90 standard
@@ -378,7 +381,9 @@
end function s20rts_rsple
+!
!----------------------------------
+!
subroutine s20rts_rspln(I1,I2,X,Y,Q,F)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_s362ani.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_s362ani.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_s362ani.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -57,7 +57,7 @@
integer THREE_D_MODEL
-! used for 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
+ ! used for 3D Harvard models s362ani, s362wmani, s362ani_prem and s2.9ea
integer, parameter :: maxker=200
integer, parameter :: maxl=72
integer, parameter :: maxcoe=2000
@@ -127,7 +127,6 @@
call MPI_BCAST(refmdl,80,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
call MPI_BCAST(varstr,40*maxker,MPI_CHARACTER,0,MPI_COMM_WORLD,ier)
-
end subroutine model_s362ani_broadcast
!
@@ -197,18 +196,17 @@
inquire(file=modeldef,exist=exists)
if(exists) then
call gt3dmodl(lu,modeldef, &
- maxhpa,maxker,maxcoe, &
- numhpa,numker,numcoe,lmxhpa, &
- ihpakern,itypehpa,coe, &
- itpspl,xlaspl,xlospl,radspl, &
- numvar,ivarkern,varstr, &
- refmdl,kerstr,hsplfl,dskker,ierror)
+ maxhpa,maxker,maxcoe, &
+ numhpa,numker,numcoe,lmxhpa, &
+ ihpakern,itypehpa,coe, &
+ itpspl,xlaspl,xlospl,radspl, &
+ numvar,ivarkern,varstr, &
+ refmdl,kerstr,hsplfl,dskker,ierror)
else
write(6,"('the model ',a,' does not exits')") modeldef(1:len_trim(modeldef))
endif
-! --- check arrays
-
+ ! check arrays
if(numker > maxker) stop 'numker > maxker'
do ihpa=1,numhpa
if(itypehpa(ihpa) == 1) then
@@ -817,12 +815,12 @@
subroutine gt3dmodl(lu,targetfile, &
- maxhpa,maxker,maxcoe, &
- numhpa,numker,numcoe,lmxhpa, &
- ihpakern,itypehpa,coe, &
- itpspl,xlatspl,xlonspl,radispl, &
- numvar,ivarkern,varstr, &
- refmdl,kerstr,hsplfl,dskker,ierror)
+ maxhpa,maxker,maxcoe, &
+ numhpa,numker,numcoe,lmxhpa, &
+ ihpakern,itypehpa,coe, &
+ itpspl,xlatspl,xlonspl,radispl, &
+ numvar,ivarkern,varstr, &
+ refmdl,kerstr,hsplfl,dskker,ierror)
implicit none
@@ -1104,7 +1102,7 @@
integer :: ncon,nver
-!daniel: original
+! Daniel Peter: original define
!
! real(kind=4) verlat(1)
! real(kind=4) verlon(1)
@@ -1113,7 +1111,7 @@
! integer icon(1)
! real(kind=4) con(1)
-!daniel: avoiding out-of-bounds errors
+! Daniel Peter: avoiding out-of-bounds errors
real(kind=4) verlat(nver)
real(kind=4) verlon(nver)
real(kind=4) verrad(nver)
@@ -1257,7 +1255,12 @@
call ylm(y,x,lmax,ylmcof(1,ihpa),wk1,wk2,wk3)
else if(itypehpa(ihpa) == 2) then
numcof=numcoe(ihpa)
+! originally called
+! call splcon(y,x,numcof,xlaspl(1,ihpa), &
+! xlospl(1,ihpa),radspl(1,ihpa), &
+! nconpt(ihpa),iconpt(1,ihpa),conpt(1,ihpa))
+! making sure of array bounds
call splcon(y,x,numcof,xlaspl(1:numcof,ihpa), &
xlospl(1:numcof,ihpa),radspl(1:numcof,ihpa), &
nconpt(ihpa),iconpt(1,ihpa),conpt(1,ihpa))
@@ -1414,6 +1417,12 @@
else if(itypehpa(ihpa) == 2) then
numcof=numcoe(ihpa)
+! originally called
+! call splcon(y,x,numcof,xlaspl(1,ihpa), &
+! xlospl(1,ihpa),radspl(1,ihpa), &
+! nconpt(ihpa),iconpt(1,ihpa),conpt(1,ihpa))
+
+! making sure array bounds
call splcon(y,x,numcof,xlaspl(1:numcof,ihpa), &
xlospl(1:numcof,ihpa),radspl(1:numcof,ihpa), &
nconpt(ihpa),iconpt(1:maxver,ihpa),conpt(1:maxver,ihpa))
@@ -1848,7 +1857,7 @@
!
real(kind=4) WK1(LMAX+1),WK2(LMAX+1),WK3(LMAX+1)
real(kind=4) XLAT,XLON
- real(kind=4) Y(1) !! Y should go at least from 1 to fac(LMAX)
+ real(kind=4),dimension((maxl+1)**2) :: Y !! Y should go at least from 1 to fac(LMAX)
real(kind=4), parameter :: RADIAN = 57.2957795
@@ -1908,7 +1917,6 @@
real(kind=4) :: X(M+1),XP(M+1),XCOSEC(M+1) !! X, XP, XCOSEC should go from 1 to M+1
-
!!!!!! illegal statement, removed by Dimitri Komatitsch DFLOAT(I)=FLOAT(I)
SUM=0.D0
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_s40rts.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_s40rts.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_s40rts.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -40,7 +40,6 @@
! Geophys. J. Int., DOI: 10.1111/j.1365-246X.2010.04884.x
!--------------------------------------------------------------------------------------------------
-
subroutine model_s40rts_broadcast(myrank,S40RTS_V)
! standard routine to setup model
@@ -127,7 +126,7 @@
enddo
close(10)
-! P12 degree 12 P model from Ritsema
+ ! P12 degree 12 P model from Ritsema
open(unit=10,file=P12,status='old',action='read',iostat=ier)
if ( ier /= 0 ) then
write(IMAIN,*) 'error opening "', trim(P12), '": ', ier
@@ -147,7 +146,7 @@
enddo
close(10)
-! set up the splines used as radial basis functions by Ritsema
+ ! set up the splines used as radial basis functions by Ritsema
call s40rts_splhsetup(S40RTS_V)
end subroutine read_model_s40rts
@@ -160,6 +159,8 @@
include "constants.h"
+ double precision :: radius,theta,phi,dvs,dvp,drho
+
! model_s40rts_variables
type model_s40rts_variables
sequence
@@ -175,11 +176,10 @@
type (model_s40rts_variables) S40RTS_V
! model_s40rts_variables
-! factor to convert perturbations in shear speed to perturbations in density
+ ! local parameters
+ ! factor to convert perturbations in shear speed to perturbations in density
double precision, parameter :: SCALE_RHO = 0.40d0
- double precision radius,theta,phi,dvs,dvp,drho
-
double precision, parameter :: RMOHO_ = 6346600.d0
double precision, parameter :: RCMB_ = 3480000.d0
double precision, parameter :: R_EARTH_ = 6371000.d0
@@ -249,8 +249,6 @@
implicit none
include "constants.h"
-!!!!!!!!!!!!!!!!!!! double precision spknt(NK_20+1),qq0(NK_20+1,NK_20+1),qq(3,NK_20+1,NK_20+1)
-
! model_s40rts_variables
type model_s40rts_variables
sequence
@@ -266,10 +264,10 @@
type (model_s40rts_variables) S40RTS_V
! model_s40rts_variables
+ ! local parameters
+ integer :: i,j
+ double precision :: qqwk(3,NK_20+1)
- integer i,j
- double precision qqwk(3,NK_20+1)
-
S40RTS_V%spknt(1) = -1.00000d0
S40RTS_V%spknt(2) = -0.78631d0
S40RTS_V%spknt(3) = -0.59207d0
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_sea1d.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_sea1d.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_sea1d.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -31,7 +31,6 @@
! used as 1-D reference model for SEA 99, Vs model by Lebedev & Nolet 2003
!--------------------------------------------------------------------------------------------------
-
subroutine model_sea1d_broadcast(CRUSTAL, SEA1DM_V)
! standard routine to setup model
@@ -93,14 +92,13 @@
! compressional wave speed vp: km/s
! shear wave speed vs: km/s
- integer iregion_code
+ double precision :: x,rho,vp,vs,Qmu,Qkappa
+ integer :: iregion_code
- double precision x,rho,vp,vs,Qmu,Qkappa
+ ! local parameters
+ double precision :: r,frac,scaleval
+ integer :: i
- integer i
-
- double precision r,frac,scaleval
-
!! DK DK implementation of model sea1d below and its radii in
!! DK DK subroutine read_parameter_file.f90 has not been thoroughly
!! DK DK checked yet
@@ -177,9 +175,10 @@
type (model_sea1d_variables) SEA1DM_V
! model_sea1d_variables
- logical USE_EXTERNAL_CRUSTAL_MODEL
+ logical :: USE_EXTERNAL_CRUSTAL_MODEL
- integer i
+ ! local parameters
+ integer :: i
! define all the values in the model
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_sea99_s.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_sea99_s.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/model_sea99_s.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -71,8 +71,10 @@
! model_sea99_s_variables
integer :: myrank
+
integer :: ier
+ ! master proc reads in values
if(myrank == 0) call read_sea99_s_model(SEA99M_V)
! broadcast the information read on the master to the nodes
@@ -126,10 +128,7 @@
open(1,file='DATA/Lebedev_sea99/sea99_dvsvs',status='old',action='read',iostat=ier)
- if ( ier /= 0 ) then
- write(IMAIN,*) 'error opening "DATA/Lebedev_sea99/sea99_dvsvs": ', ier
- call exit_MPI(0, 'error model sea99_s')
- endif
+ if( ier /= 0 ) call exit_MPI(0,'error opening file sea99_dvsvs')
!----------------------- read input file: ------------------
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/moho_stretching.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/moho_stretching.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/moho_stretching.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -25,10 +25,9 @@
!
!=====================================================================
+ subroutine moho_stretching_honor_crust(myrank,xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER, &
+ R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
- subroutine moho_stretching_honor_crust(myrank,xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER,&
- R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
-
! stretching the moho according to the crust 2.0
! input: myrank, xelm, yelm, zelm, RMOHO_FICTITIOUS_IN_MESHER R220,RMIDDLE_CRUST, CM_V
! Dec, 30, 2009
@@ -40,25 +39,19 @@
include "constants.h"
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
double precision R220,RMIDDLE_CRUST
double precision RMOHO_FICTITIOUS_IN_MESHER
integer :: myrank
+ double precision,dimension(NGNOD) :: xelm,yelm,zelm
logical :: elem_in_crust,elem_in_mantle
! local parameters
- integer:: ia,count_crust,count_mantle
- double precision:: r,theta,phi,lat,lon
- double precision:: vpc,vsc,rhoc,moho,elevation,gamma
- logical:: found_crust
-
- double precision, parameter :: RADIANS_TO_DEGREES = 180.d0 / PI
- double precision, parameter :: PI_OVER_TWO = PI / 2.0d0
- !double precision :: stretch_factor
+ double precision :: r,theta,phi,lat,lon
+ double precision :: vpc,vsc,rhoc,moho,elevation,gamma
double precision :: x,y,z
double precision :: R_moho,R_middlecrust
+ integer :: ia,count_crust,count_mantle
+ logical :: found_crust
! radii for stretching criteria
R_moho = RMOHO_FICTITIOUS_IN_MESHER/R_EARTH
@@ -68,16 +61,21 @@
count_crust = 0
count_mantle = 0
do ia = 1,NGNOD
+ ! gets anchor point location
x = xelm(ia)
y = yelm(ia)
z = zelm(ia)
+ ! converts location to lat/lon
call xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
call reduce(theta,phi)
- lat = 90.d0 - theta * RADIANS_TO_DEGREES
+ ! get geographic latitude and longitude in degrees
+ ! note: at this point, the mesh is still perfectly spherical, thus no need to
+ ! convert the geocentric colatitude to a geographic colatitude
+ lat = (PI_OVER_TWO - theta) * RADIANS_TO_DEGREES
lon = phi * RADIANS_TO_DEGREES
- if( lon > 180.d0 ) lon = lon - 360.0d0
+ if( lon > 180.0d0 ) lon = lon - 360.0d0
! initializes
moho = 0.d0
@@ -189,16 +187,13 @@
end subroutine moho_stretching_honor_crust
-
!
!------------------------------------------------------------------------------------------------
!
+ subroutine moho_stretching_honor_crust_reg(myrank,xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER, &
+ R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
- subroutine moho_stretching_honor_crust_reg(myrank, &
- xelm,yelm,zelm,RMOHO_FICTITIOUS_IN_MESHER,&
- R220,RMIDDLE_CRUST,elem_in_crust,elem_in_mantle)
-
! regional routine: for REGIONAL_MOHO_MESH adaptations
!
! uses a 3-layer crust region
@@ -211,12 +206,12 @@
include "constants.h"
- double precision xelm(NGNOD)
- double precision yelm(NGNOD)
- double precision zelm(NGNOD)
double precision R220,RMIDDLE_CRUST
double precision RMOHO_FICTITIOUS_IN_MESHER
integer :: myrank
+
+ double precision,dimension(NGNOD) :: xelm,yelm,zelm
+
logical :: elem_in_crust,elem_in_mantle
! local parameters
@@ -224,9 +219,6 @@
double precision:: r,theta,phi,lat,lon
double precision:: vpc,vsc,rhoc,moho
logical:: found_crust
-
- double precision, parameter :: RADIANS_TO_DEGREES = 180.d0 / PI
- double precision, parameter :: PI_OVER_TWO = PI / 2.0d0
double precision :: x,y,z
! loops over element's anchor points
@@ -302,8 +294,6 @@
end subroutine moho_stretching_honor_crust_reg
-
-
!
!-------------------------------------------------------------------------------------------------
!
@@ -624,295 +614,3 @@
r = dsqrt(xelm(ia)*xelm(ia) + yelm(ia)*yelm(ia) + zelm(ia)*zelm(ia))
end subroutine move_point
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-! obsolete...
-!
-! subroutine moho_stretching(myrank,xelm,yelm,zelm,RMOHO,R220)
-!
-! implicit none
-!
-! include "constants.h"
-!
-!! ocean-continent function maximum spherical harmonic degree
-! integer, parameter :: NL_OCEAN_CONTINENT = 12
-!
-!! spherical harmonic coefficients of the ocean-continent function (km)
-! double precision A_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT), &
-! B_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT)
-!
-! common /smooth_moho/ A_lm,B_lm
-!
-! integer myrank
-!
-! double precision xelm(NGNOD)
-! double precision yelm(NGNOD)
-! double precision zelm(NGNOD)
-!
-! double precision RMOHO,R220
-!
-! integer ia
-!
-! integer l,m
-! double precision r,theta,phi
-! double precision sint,cost,x(2*NL_OCEAN_CONTINENT+1),dx(2*NL_OCEAN_CONTINENT+1)
-! double precision elevation
-! double precision gamma
-!
-!! we loop on all the points of the element
-! do ia = 1,NGNOD
-!
-!! convert to r theta phi
-! call xyz_2_rthetaphi_dble(xelm(ia),yelm(ia),zelm(ia),r,theta,phi)
-! call reduce(theta,phi)
-!
-! elevation = 0.0d0
-! do l = 0,NL_OCEAN_CONTINENT
-! sint = dsin(theta)
-! cost = dcos(theta)
-! call lgndr(l,cost,sint,x,dx)
-! m = 0
-! elevation = elevation + A_lm(l,m)*x(m+1)
-! do m = 1,l
-! elevation = elevation + (A_lm(l,m)*dcos(dble(m)*phi)+B_lm(l,m)*dsin(dble(m)*phi))*x(m+1)
-! enddo
-! enddo
-! elevation = -0.25d0*elevation/R_EARTH_KM
-!
-! gamma = 0.0d0
-! if(r >= RMOHO/R_EARTH) then
-!! stretching above the Moho
-! gamma = (1.0d0 - r) / (1.0d0 - RMOHO/R_EARTH)
-! else if(r>= R220/R_EARTH .and. r< RMOHO/R_EARTH) then
-!! stretching between R220 and RMOHO
-! gamma = (r - R220/R_EARTH) / (RMOHO/R_EARTH - R220/R_EARTH)
-! endif
-! if(gamma < -0.0001 .or. gamma > 1.0001) &
-! call exit_MPI(myrank,'incorrect value of gamma for Moho topography')
-!
-! xelm(ia) = xelm(ia)*(ONE + gamma * elevation / r)
-! yelm(ia) = yelm(ia)*(ONE + gamma * elevation / r)
-! zelm(ia) = zelm(ia)*(ONE + gamma * elevation / r)
-!
-! enddo
-!
-! end subroutine moho_stretching
-!
-!
-!-------------------------------------------------------------------------------------------------
-!
-!
-! subroutine read_smooth_moho
-!
-! implicit none
-!
-!! ocean-continent function maximum spherical harmonic degree
-! integer, parameter :: NL_OCEAN_CONTINENT = 12
-!
-!! spherical harmonic coefficients of the ocean-continent function (km)
-! double precision A_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT), &
-! B_lm(0:NL_OCEAN_CONTINENT,0:NL_OCEAN_CONTINENT)
-!
-! common /smooth_moho/ A_lm,B_lm
-!
-!! integer l,m
-!!
-!! ocean-continent function (km)
-!! open(unit=10,file='DATA/ocean_continent_function/ocean_continent_function.txt', &
-!! status='old',action='read')
-!! do l=0,NL_OCEAN_CONTINENT
-!! read(10,*) A_lm(l,0),(A_lm(l,m),B_lm(l,m),m=1,l)
-!! enddo
-!! close(10)
-!
-! A_lm(0,0) = -3.8201999E-04
-! B_lm(0,0) = 0.
-! A_lm(1,0) = 13.88800
-! B_lm(1,0) = 0.
-! A_lm(1,1) = -15.24000
-! B_lm(1,1) = -9.187200
-! A_lm(2,0) = 11.21500
-! B_lm(2,0) = 0.
-! A_lm(2,1) = -6.754500
-! B_lm(2,1) = -8.516700
-! A_lm(2,2) = -8.327800
-! B_lm(2,2) = -5.029200
-! A_lm(3,0) = -3.614500
-! B_lm(3,0) = 0.
-! A_lm(3,1) = 5.394800
-! B_lm(3,1) = -0.9220800
-! A_lm(3,2) = -10.05100
-! B_lm(3,2) = 13.98100
-! A_lm(3,3) = -2.711200
-! B_lm(3,3) = -13.57100
-! A_lm(4,0) = 7.523300
-! B_lm(4,0) = 0.
-! A_lm(4,1) = 5.156100
-! B_lm(4,1) = 2.184400
-! A_lm(4,2) = -10.67300
-! B_lm(4,2) = 2.640600
-! A_lm(4,3) = -7.786300
-! B_lm(4,3) = 0.3674500
-! A_lm(4,4) = -3.076400
-! B_lm(4,4) = 16.83000
-! A_lm(5,0) = -9.681000
-! B_lm(5,0) = 0.
-! A_lm(5,1) = 0.5026800
-! B_lm(5,1) = 2.111300
-! A_lm(5,2) = -2.931000
-! B_lm(5,2) = -4.329000
-! A_lm(5,3) = -1.766800
-! B_lm(5,3) = -3.621200
-! A_lm(5,4) = 16.08200
-! B_lm(5,4) = -4.493900
-! A_lm(5,5) = -0.3705800
-! B_lm(5,5) = -5.574500
-! A_lm(6,0) = 4.407900
-! B_lm(6,0) = 0.
-! A_lm(6,1) = 0.3799000
-! B_lm(6,1) = 1.589400
-! A_lm(6,2) = -1.886400
-! B_lm(6,2) = -0.5686300
-! A_lm(6,3) = -0.9816800
-! B_lm(6,3) = -5.827800
-! A_lm(6,4) = 3.620600
-! B_lm(6,4) = -2.713100
-! A_lm(6,5) = 1.445600
-! B_lm(6,5) = 3.964100
-! A_lm(6,6) = 1.167400
-! B_lm(6,6) = 2.134100
-! A_lm(7,0) = -4.086100
-! B_lm(7,0) = 0.
-! A_lm(7,1) = 0.5462000
-! B_lm(7,1) = -4.488100
-! A_lm(7,2) = 3.116400
-! B_lm(7,2) = 1.793600
-! A_lm(7,3) = 2.594600
-! B_lm(7,3) = -2.129100
-! A_lm(7,4) = -5.445000
-! B_lm(7,4) = 0.5381500
-! A_lm(7,5) = -2.178100
-! B_lm(7,5) = 1.766700
-! A_lm(7,6) = -1.040000
-! B_lm(7,6) = -5.541000
-! A_lm(7,7) = 1.536500
-! B_lm(7,7) = 3.700600
-! A_lm(8,0) = -2.562200
-! B_lm(8,0) = 0.
-! A_lm(8,1) = 0.3736200
-! B_lm(8,1) = 1.488000
-! A_lm(8,2) = 1.347500
-! B_lm(8,2) = 0.5288200
-! A_lm(8,3) = -0.8493700
-! B_lm(8,3) = -1.626500
-! A_lm(8,4) = 0.2423400
-! B_lm(8,4) = 4.202800
-! A_lm(8,5) = 2.052200
-! B_lm(8,5) = 0.6880400
-! A_lm(8,6) = 2.838500
-! B_lm(8,6) = 2.835700
-! A_lm(8,7) = -4.981400
-! B_lm(8,7) = -1.883100
-! A_lm(8,8) = -1.102800
-! B_lm(8,8) = -1.951700
-! A_lm(9,0) = -1.202100
-! B_lm(9,0) = 0.
-! A_lm(9,1) = 1.020300
-! B_lm(9,1) = 1.371000
-! A_lm(9,2) = -0.3430100
-! B_lm(9,2) = 0.8782800
-! A_lm(9,3) = -0.4462500
-! B_lm(9,3) = -0.3046100
-! A_lm(9,4) = 0.7750700
-! B_lm(9,4) = 2.351600
-! A_lm(9,5) = -2.092600
-! B_lm(9,5) = -2.377100
-! A_lm(9,6) = 0.3126900
-! B_lm(9,6) = 4.996000
-! A_lm(9,7) = -2.284000
-! B_lm(9,7) = 1.183700
-! A_lm(9,8) = 1.445900
-! B_lm(9,8) = 1.080000
-! A_lm(9,9) = 1.146700
-! B_lm(9,9) = 1.457800
-! A_lm(10,0) = -2.516900
-! B_lm(10,0) = 0.
-! A_lm(10,1) = -0.9739500
-! B_lm(10,1) = -0.7195500
-! A_lm(10,2) = -2.846000
-! B_lm(10,2) = -1.464700
-! A_lm(10,3) = 2.720100
-! B_lm(10,3) = 0.8241400
-! A_lm(10,4) = -1.247800
-! B_lm(10,4) = 1.220300
-! A_lm(10,5) = -1.638500
-! B_lm(10,5) = -1.099500
-! A_lm(10,6) = 3.043000
-! B_lm(10,6) = -1.976400
-! A_lm(10,7) = -1.007300
-! B_lm(10,7) = -1.604900
-! A_lm(10,8) = 0.6620500
-! B_lm(10,8) = -1.135000
-! A_lm(10,9) = -3.576800
-! B_lm(10,9) = 0.5554900
-! A_lm(10,10) = 2.418700
-! B_lm(10,10) = -1.482200
-! A_lm(11,0) = 0.7158800
-! B_lm(11,0) = 0.
-! A_lm(11,1) = -3.694800
-! B_lm(11,1) = 0.8491400
-! A_lm(11,2) = 9.3208998E-02
-! B_lm(11,2) = -1.276000
-! A_lm(11,3) = 1.575600
-! B_lm(11,3) = 0.1972100
-! A_lm(11,4) = 0.8989600
-! B_lm(11,4) = -1.063000
-! A_lm(11,5) = -0.6301000
-! B_lm(11,5) = -1.329400
-! A_lm(11,6) = 1.389000
-! B_lm(11,6) = 1.184100
-! A_lm(11,7) = 0.5640700
-! B_lm(11,7) = 2.286200
-! A_lm(11,8) = 1.530300
-! B_lm(11,8) = 0.7677500
-! A_lm(11,9) = 0.8495500
-! B_lm(11,9) = 0.7247500
-! A_lm(11,10) = 2.106800
-! B_lm(11,10) = 0.6588000
-! A_lm(11,11) = 0.6067800
-! B_lm(11,11) = 0.1366800
-! A_lm(12,0) = -2.598700
-! B_lm(12,0) = 0.
-! A_lm(12,1) = -1.150500
-! B_lm(12,1) = -0.8425700
-! A_lm(12,2) = -0.1593300
-! B_lm(12,2) = -1.241400
-! A_lm(12,3) = 1.508600
-! B_lm(12,3) = 0.3385500
-! A_lm(12,4) = -1.941200
-! B_lm(12,4) = 1.120000
-! A_lm(12,5) = -0.4630500
-! B_lm(12,5) = -6.4753003E-02
-! A_lm(12,6) = 0.8967000
-! B_lm(12,6) = 4.7417998E-02
-! A_lm(12,7) = 4.5407999E-02
-! B_lm(12,7) = 0.8876400
-! A_lm(12,8) = -2.444400
-! B_lm(12,8) = 1.172500
-! A_lm(12,9) = -2.593400
-! B_lm(12,9) = 0.1703700
-! A_lm(12,10) = 0.5662700
-! B_lm(12,10) = 0.7050800
-! A_lm(12,11) = -0.1930000
-! B_lm(12,11) = -2.008100
-! A_lm(12,12) = -3.187900
-! B_lm(12,12) = -1.672000
-!
-! end subroutine read_smooth_moho
-
-
-
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/sort_array_coordinates.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/sort_array_coordinates.f90 2013-07-01 15:46:27 UTC (rev 22480)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/sort_array_coordinates.f90 2013-07-01 18:39:32 UTC (rev 22481)
@@ -40,25 +40,24 @@
integer :: npointot,nglob
- integer ibool(npointot),iglob(npointot),loc(npointot)
- integer ind(npointot),ninseg(npointot)
- logical ifseg(npointot)
- double precision x(npointot),y(npointot),z(npointot)
- integer iwork(npointot)
- double precision work(npointot)
+ double precision,dimension(npointot) :: x,y,z
- integer ipoin,i,j
- integer nseg,ioff,iseg,ig
- double precision xtol
+ integer,dimension(npointot) :: ibool,iglob,loc
+ integer,dimension(npointot) :: ind,ninseg
+ logical,dimension(npointot) :: ifseg
-! establish initial pointers
+ integer,dimension(npointot) :: iwork
+ double precision,dimension(npointot) :: work
+
+ ! local parameters
+ integer :: ipoin,i,j
+ integer :: nseg,ioff,iseg,ig
+
+ ! establish initial pointers
do ipoin=1,npointot
loc(ipoin)=ipoin
enddo
-! define a tolerance, normalized radius is 1., so let's use a small value
- xtol = SMALLVALTOL
-
ifseg(:)=.false.
nseg=1
@@ -67,55 +66,51 @@
do j=1,NDIM
-! sort within each segment
- ioff=1
- do iseg=1,nseg
- if(j == 1) then
+ ! sort within each segment
+ ioff=1
+ do iseg=1,nseg
+ if(j == 1) then
+ call rank_buffers(x(ioff),ind,ninseg(iseg))
+ else if(j == 2) then
+ call rank_buffers(y(ioff),ind,ninseg(iseg))
+ else
+ call rank_buffers(z(ioff),ind,ninseg(iseg))
+ endif
- call rank_buffers(x(ioff),ind,ninseg(iseg))
+ call swap_all_buffers(ibool(ioff),loc(ioff), &
+ x(ioff),y(ioff),z(ioff),iwork,work,ind,ninseg(iseg))
+ ioff=ioff+ninseg(iseg)
+ enddo
+
+ ! check for jumps in current coordinate
+ ! define a tolerance, normalized radius is 1., so let's use a small value
+ if(j == 1) then
+ do i=2,npointot
+ if(dabs(x(i)-x(i-1)) > SMALLVALTOL ) ifseg(i)=.true.
+ enddo
else if(j == 2) then
-
- call rank_buffers(y(ioff),ind,ninseg(iseg))
-
+ do i=2,npointot
+ if(dabs(y(i)-y(i-1)) > SMALLVALTOL ) ifseg(i)=.true.
+ enddo
else
-
- call rank_buffers(z(ioff),ind,ninseg(iseg))
-
+ do i=2,npointot
+ if(dabs(z(i)-z(i-1)) > SMALLVALTOL ) ifseg(i)=.true.
+ enddo
endif
- call swap_all_buffers(ibool(ioff),loc(ioff), &
- x(ioff),y(ioff),z(ioff),iwork,work,ind,ninseg(iseg))
-
- ioff=ioff+ninseg(iseg)
- enddo
-
-! check for jumps in current coordinate
- if(j == 1) then
- do i=2,npointot
- if(dabs(x(i)-x(i-1)) > xtol) ifseg(i)=.true.
+ ! count up number of different segments
+ nseg=0
+ do i=1,npointot
+ if(ifseg(i)) then
+ nseg=nseg+1
+ ninseg(nseg)=1
+ else
+ ninseg(nseg)=ninseg(nseg)+1
+ endif
enddo
- else if(j == 2) then
- do i=2,npointot
- if(dabs(y(i)-y(i-1)) > xtol) ifseg(i)=.true.
- enddo
- else
- do i=2,npointot
- if(dabs(z(i)-z(i-1)) > xtol) ifseg(i)=.true.
- enddo
- endif
-! count up number of different segments
- nseg=0
- do i=1,npointot
- if(ifseg(i)) then
- nseg=nseg+1
- ninseg(nseg)=1
- else
- ninseg(nseg)=ninseg(nseg)+1
- endif
enddo
- enddo
! assign global node numbers (now sorted lexicographically)
ig=0
@@ -152,41 +147,49 @@
if(n == 1) return
- L=n/2+1
- ir=n
- 100 CONTINUE
- IF(l>1) THEN
- l=l-1
- indx=ind(l)
- q=a(indx)
- ELSE
- indx=ind(ir)
- q=a(indx)
- ind(ir)=ind(1)
- ir=ir-1
+ L = n/2 + 1
+ ir = n
+
+ do while( .true. )
+
+ IF ( l > 1 ) THEN
+ l = l-1
+ indx = ind(l)
+ q = a(indx)
+ ELSE
+ indx = ind(ir)
+ q = a(indx)
+ ind(ir) = ind(1)
+ ir = ir-1
+
+ ! checks exit criteria
if (ir == 1) then
ind(1) = indx
return
endif
- ENDIF
- i=l
- j=l+l
- 200 CONTINUE
- IF(J <= IR) THEN
- IF(J < IR) THEN
- IF(A(IND(j)) < A(IND(j+1))) j=j+1
+
+ ENDIF
+
+ i = l
+ j = l+l
+
+ do while( J <= IR )
+ IF ( J < IR ) THEN
+ IF ( A(IND(j)) < A(IND(j+1)) ) j=j+1
ENDIF
- IF (q < A(IND(j))) THEN
- IND(I)=IND(J)
- I=J
- J=J+J
+ IF ( q < A(IND(j)) ) THEN
+ IND(I) = IND(J)
+ I = J
+ J = J+J
ELSE
- J=IR+1
+ J = IR+1
ENDIF
- goto 200
- ENDIF
- IND(I)=INDX
- goto 100
+
+ enddo
+
+ IND(I)=INDX
+ enddo
+
end subroutine rank_buffers
! -------------------------------------------------------------------
More information about the CIG-COMMITS
mailing list