[cig-commits] r16126 - in seismo/3D/SPECFEM3D_SESAME/trunk: . EXAMPLES/waterlayered_halfspace UTILS decompose_mesh_SCOTCH
danielpeter at geodynamics.org
danielpeter at geodynamics.org
Wed Jan 6 15:41:15 PST 2010
Author: danielpeter
Date: 2010-01-06 15:41:13 -0800 (Wed, 06 Jan 2010)
New Revision: 16126
Added:
seismo/3D/SPECFEM3D_SESAME/trunk/PML_init.f90
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/plot_seismos.gmt.pl
seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic_PML.f90
seismo/3D/SPECFEM3D_SESAME/trunk/write_PNM_GIF_data.f90
Modified:
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_fig8.py
seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_vertical.py
seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in
seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_vector.f90
seismo/3D/SPECFEM3D_SESAME/trunk/check_mesh_resolution.f90
seismo/3D/SPECFEM3D_SESAME/trunk/combine_vol_data.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_gradient.f90
seismo/3D/SPECFEM3D_SESAME/trunk/constants.h.in
seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90
seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90
seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/part_decompose_mesh_SCOTCH.f90
seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90
seismo/3D/SPECFEM3D_SESAME/trunk/detect_surface.f90
seismo/3D/SPECFEM3D_SESAME/trunk/flags.guess
seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90
seismo/3D/SPECFEM3D_SESAME/trunk/get_element_face.f90
seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90
seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90
seismo/3D/SPECFEM3D_SESAME/trunk/parallel.f90
seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90
seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90
seismo/3D/SPECFEM3D_SESAME/trunk/serial.f90
seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90
seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90
seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90
seismo/3D/SPECFEM3D_SESAME/trunk/write_VTK_data.f90
Log:
added classical PML for acoustic domains (experimental feature, turned off by default); added writing GIF cross-section images
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_fig8.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_fig8.py 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_fig8.py 2010-01-06 23:41:13 UTC (rev 16126)
@@ -70,14 +70,16 @@
#### Define material properties for the 3 volumes ################
cubit.cmd('#### DEFINE MATERIAL PROPERTIES #######################')
-cubit.cmd('block 1 attribute count 6')
+cubit.cmd('block 1 name "acoustic" ') # material region
+cubit.cmd('block 1 attribute count 4')
cubit.cmd('block 1 attribute index 1 1 ') # volume 1
-cubit.cmd('block 1 attribute index 2 2800 ') # vp
-cubit.cmd('block 1 attribute index 3 1500 ') # vs
-cubit.cmd('block 1 attribute index 4 2300 ') # rho
-cubit.cmd('block 1 attribute index 5 6 ') # Q_flag
-cubit.cmd('block 1 attribute index 6 0 ') # anisotropy_flag
+cubit.cmd('block 1 attribute index 2 1480 ') # vp
+cubit.cmd('block 1 attribute index 3 0 ') # vs
+cubit.cmd('block 1 attribute index 4 1028 ') # rho
+#cubit.cmd('block 1 attribute index 5 0 ') # Q_flag
+#cubit.cmd('block 1 attribute index 6 0 ') # anisotropy_flag
+cubit.cmd('block 2 name "elastic" ') # material region
cubit.cmd('block 2 attribute count 6')
cubit.cmd('block 2 attribute index 1 2 ') # volume 2
cubit.cmd('block 2 attribute index 2 7500 ')
@@ -86,8 +88,9 @@
cubit.cmd('block 2 attribute index 5 6 ')
cubit.cmd('block 2 attribute index 6 0 ') # anisotropy_flag
+cubit.cmd('block 3 name "elastic" ') # material region
cubit.cmd('block 3 attribute count 6')
-cubit.cmd('block 3 attribute index 1 2 ') # same properties as for volume 2
+cubit.cmd('block 3 attribute index 1 3 ') # same properties as for volume 2
cubit.cmd('block 3 attribute index 2 7500 ')
cubit.cmd('block 3 attribute index 3 4300 ')
cubit.cmd('block 3 attribute index 4 3200 ')
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_vertical.py
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_vertical.py 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/EXAMPLES/waterlayered_halfspace/waterlayer_mesh_boundary_vertical.py 2010-01-06 23:41:13 UTC (rev 16126)
@@ -32,14 +32,14 @@
#### Define material properties for the 3 volumes ################
cubit.cmd('#### DEFINE MATERIAL PROPERTIES #######################')
-cubit.cmd('block 1 name "acoustic" ') # elastic material region
+cubit.cmd('block 1 name "acoustic" ') # material region
cubit.cmd('block 1 attribute count 4')
cubit.cmd('block 1 attribute index 1 1') # flag for material: 1 for 1. material
cubit.cmd('block 1 attribute index 2 3000') # vp
cubit.cmd('block 1 attribute index 3 0') # vs
cubit.cmd('block 1 attribute index 4 2300') # rho
-cubit.cmd('block 2 name "elastic" ') # elastic material region
+cubit.cmd('block 2 name "elastic" ') # material region
cubit.cmd('block 2 attribute count 6')
cubit.cmd('block 2 attribute index 1 2') # flag for material: 2 for 2. material
cubit.cmd('block 2 attribute index 2 3000') # vp
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in 2010-01-06 23:41:13 UTC (rev 16126)
@@ -129,14 +129,17 @@
# values_from_mesher.h anymore
SOLVER_ARRAY_OBJECTS = \
$O/specfem3D_par.o \
+ $O/PML_init.o \
$O/compute_forces_no_Deville.o \
$O/compute_forces_with_Deville.o \
- $O/compute_forces_elastic.o \
- $O/compute_forces_acoustic.o \
- $O/compute_gradient.o \
+ $O/compute_forces_elastic.o \
+ $O/compute_forces_acoustic_PML.o \
+ $O/compute_forces_acoustic.o \
+ $O/compute_gradient.o \
$O/initialize_simulation.o \
$O/read_mesh_databases.o \
$O/setup_GLL_points.o \
+ $O/write_PNM_GIF_data.o \
$O/detect_mesh_surfaces.o \
$O/setup_movie_meshes.o \
$O/read_topography_bathymetry.o \
@@ -234,8 +237,8 @@
xcheck_buffers_2D: $O/check_buffers_2D.o $(LIBSPECFEM)
${FCCOMPILE_CHECK} -o xcheck_buffers_2D $O/check_buffers_2D.o $(LIBSPECFEM)
-xcombine_vol_data: $O/combine_vol_data.o $O/write_c_binary.o
- ${FCCOMPILE_CHECK} -o xcombine_vol_data $O/combine_vol_data.o $O/write_c_binary.o
+xcombine_vol_data: $O/combine_vol_data.o $O/write_c_binary.o $O/read_parameter_file.o $O/read_value_parameters.o $O/get_value_parameters.o
+ ${FCCOMPILE_CHECK} -o xcombine_vol_data $O/combine_vol_data.o $O/write_c_binary.o $O/read_parameter_file.o $O/read_value_parameters.o $O/get_value_parameters.o
xcombine_surf_data: $O/combine_surf_data.o $O/write_c_binary.o
${FCCOMPILE_CHECK} -o xcombine_surf_data $O/combine_surf_data.o $O/write_c_binary.o
@@ -419,6 +422,9 @@
$O/write_VTK_data.o: constants.h write_VTK_data.f90
${FCCOMPILE_CHECK} -c -o $O/write_VTK_data.o write_VTK_data.f90
+$O/write_PNM_GIF_data.o: constants.h write_PNM_GIF_data.f90
+ ${FCCOMPILE_CHECK} -c -o $O/write_PNM_GIF_data.o write_PNM_GIF_data.f90
+
$O/get_shape3D.o: constants.h get_shape3D.f90
${FCCOMPILE_CHECK} -c -o $O/get_shape3D.o get_shape3D.f90
@@ -482,6 +488,9 @@
$O/prepare_assemble_MPI.o: constants.h prepare_assemble_MPI.f90
${FCCOMPILE_CHECK} -c -o $O/prepare_assemble_MPI.o prepare_assemble_MPI.f90
+$O/PML_init.o: constants.h PML_init.f90
+ ${FCCOMPILE_CHECK} -c -o $O/PML_init.o PML_init.f90
+
### compilation with optimization
$O/specfem3D.o: constants.h specfem3D.f90
@@ -499,6 +508,9 @@
$O/compute_forces_acoustic.o: constants.h compute_forces_acoustic.f90
${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_acoustic.o compute_forces_acoustic.f90
+$O/compute_forces_acoustic_PML.o: constants.h compute_forces_acoustic_PML.f90
+ ${FCCOMPILE_NO_CHECK} -c -o $O/compute_forces_acoustic_PML.o compute_forces_acoustic_PML.f90
+
$O/compute_gradient.o: constants.h compute_gradient.f90
${FCCOMPILE_NO_CHECK} -c -o $O/compute_gradient.o compute_gradient.f90
Added: seismo/3D/SPECFEM3D_SESAME/trunk/PML_init.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/PML_init.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/PML_init.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -0,0 +1,1232 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+module PML_par
+
+ use constants,only: CUSTOM_REAL
+
+ !--------------------------------------------------------------------
+ ! USER PARAMETERS
+
+ ! damping profile coefficients:
+ ! R: theoretical reflection coefficient after discretization
+ real(kind=CUSTOM_REAL),parameter:: PML_damp_R = 1.e-3
+
+ ! number of element layers for PML region
+ ! default is 2 element layers
+ integer :: PML_LAYERS = 2
+
+ ! additional absorbing, Sommerfeld (^Stacey) condition at the boundaries
+ logical,parameter:: PML_USE_SOMMERFELD = .false.
+
+ !--------------------------------------------------------------------
+
+ real(kind=CUSTOM_REAL):: PML_width
+ real(kind=CUSTOM_REAL):: PML_width_min,PML_width_max
+
+ ! PML element type flag
+ integer,dimension(:),allocatable :: ispec_is_PML_inum
+
+ ! PML global points
+ integer,dimension(:),allocatable :: iglob_is_PML
+
+ ! PML spectral elements
+ integer,dimension(:),allocatable :: PML_ispec
+ integer :: num_PML_ispec
+
+ ! PML normal for each PML spectral element
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable :: PML_normal
+ ! PML damping coefficients d & dprime
+ real(kind=CUSTOM_REAL),dimension(:,:,:,:),allocatable :: PML_damping_d,PML_damping_dprime
+
+ !real(kind=CUSTOM_REAL),dimension(:),allocatable :: PML_damping_d_global
+
+ ! PML interface
+ integer,dimension(:),allocatable :: iglob_is_PML_interface
+
+ ! mask ibool needed for time marching
+ logical,dimension(:),allocatable :: PML_mask_ibool
+
+ ! PML damping flag
+ logical:: PML = .false.
+
+end module PML_par
+
+!--------
+
+module PML_par_acoustic
+
+ ! potentials split into 4 terms plus temporary potential:
+ ! chi = chi1 + chi2 + chi3 + chi4
+ ! temporary: chi2_t = (\partial_t + d ) chi2
+
+ use constants,only: CUSTOM_REAL
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ chi1,chi2,chi2_t,chi3,chi4
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
+
+end module PML_par_acoustic
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_damping_profile_l(d,x,vp,delta)
+
+! calculates damping coefficient value d for a given
+! x: distance x and
+! vp: p-velocity alpha
+! delta: PML width
+!
+! returns: d damping coefficients
+ use PML_par,only: CUSTOM_REAL,PML_damp_R
+ implicit none
+ real(kind=CUSTOM_REAL),intent(out):: d
+ real(kind=CUSTOM_REAL),intent(in):: x,vp,delta
+
+ ! damping profile coefficients:
+ ! d : damping function of (x)
+ ! vp: P-velocity
+ ! delta: width of PML layer
+ ! R: theoretical reflection coefficient after discretization
+
+ ! damping profile function: d = f(x)
+ ! Komatitsch & Tromp, 2003: eq. 24 page 150
+ d = 3.0*vp/(2.0*delta)*log(1.0/PML_damp_R)*x*x/(delta*delta)
+
+end subroutine PML_damping_profile_l
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_initialize()
+
+ use specfem_par,only: NGLOB_AB,NSPEC_AB,myrank, &
+ ibool,xstore,ystore,zstore,&
+ model_speed_max,hdur
+ use PML_par
+ use PML_par_acoustic
+ use constants,only: FIX_UNDERFLOW_PROBLEM,VERYSMALLVAL,IMAIN,&
+ NGLLX,NGLLY,NGLLZ,TINYVAL
+ use specfem_par_acoustic,only: ACOUSTIC_SIMULATION
+ implicit none
+
+ ! local parameters
+ real(kind=CUSTOM_REAL):: d,dprime,d_glob,dprime_glob
+ real(kind=CUSTOM_REAL) :: dominant_wavelength,hdur_max
+ integer :: count,ilayer,sign
+
+ ! sets flag
+ PML = .true.
+
+ ! user output
+ if( myrank == 0 ) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'incorporating PML '
+ write(IMAIN,*)
+ endif
+
+ ! PML element type array: 1 = face, 2 = edge, 3 = corner
+ allocate(ispec_is_PML_inum(NSPEC_AB))
+ num_PML_ispec = 0
+
+ ! PML interface points between PML and "regular" region
+ allocate(iglob_is_PML_interface(NGLOB_AB))
+ iglob_is_PML_interface(:) = 0
+
+ ! PML global points
+ allocate(iglob_is_PML(NGLOB_AB))
+ iglob_is_PML(:) = 0
+
+ ! PML ibool mask
+ allocate(PML_mask_ibool(NGLOB_AB))
+ PML_mask_ibool(:) = .false.
+
+ ! determines dominant wavelength based on maximum model speed
+ ! and source half time duration
+ hdur_max = maxval(hdur(:))
+ if( hdur_max > 0.0 ) then
+ dominant_wavelength = model_speed_max * 2.0 * hdur_max
+ else
+ dominant_wavelength = 0._CUSTOM_REAL
+ endif
+
+ ! for multiple PML element layers
+ ilayer = 0
+ do while( ilayer < PML_LAYERS )
+ ilayer = ilayer + 1
+
+ if( ilayer == 1 ) then
+ ! sets ispec occurrences for first element layer in PML region based on absorbing boundary elements
+ call PML_set_firstlayer()
+ else
+ ! adds an additional element layer based on adjacent elements on PML interface points
+ call PML_add_layer()
+ endif
+
+ ! update global interface points of PML region to "regular" domain
+ call PML_determine_interfacePoints()
+
+ ! optional? update PML width according to dominant wavelength
+ !call PML_get_width()
+ ! checks with wavelength criteria
+ !if( dominant_wavelength > 0.0 ) then
+ ! if( PML_width > dominant_wavelength/2.0 ) then
+ ! PML_LAYERS = ilayer
+ ! exit
+ ! else
+ ! PML_LAYERS = ilayer + 1
+ ! endif
+ !endif
+ enddo
+
+ ! checks PML normals at edges and corners,
+ ! tries to gather elements at edges & corners
+ do ilayer=1,PML_LAYERS-1
+ call PML_update_normals(ilayer)
+ enddo
+
+ ! updates statistics global PML width
+ call PML_get_width()
+
+ ! pre-calculates damping profiles on PML points
+ ! damping coefficients
+ call PML_set_local_dampingcoeff()
+
+ ! pre-calculates derivatives of damping coefficients
+ call PML_determine_dprime()
+
+ ! wavefield array initialization
+ allocate(chi1(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi2(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi2_t(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi3(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi4(NGLLX,NGLLY,NGLLZ,num_PML_ispec))
+ allocate(chi1_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi2_t_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi3_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi4_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec))
+ allocate(chi1_dot_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi2_t_dot_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi3_dot_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi4_dot_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec))
+
+ ! potentials
+ chi1 = 0._CUSTOM_REAL
+ chi2 = 0._CUSTOM_REAL
+ chi2_t = 0._CUSTOM_REAL
+ chi3 = 0._CUSTOM_REAL
+ chi4 = 0._CUSTOM_REAL
+
+ ! "velocity" potential
+ chi1_dot = 0._CUSTOM_REAL
+ chi2_t_dot = 0._CUSTOM_REAL
+ chi3_dot = 0._CUSTOM_REAL
+ chi4_dot = 0._CUSTOM_REAL
+
+ ! "acceleration"/pressure potential
+ chi1_dot_dot = 0._CUSTOM_REAL
+ chi2_t_dot_dot = 0._CUSTOM_REAL
+ chi3_dot_dot = 0._CUSTOM_REAL
+ chi4_dot_dot = 0._CUSTOM_REAL
+ if(FIX_UNDERFLOW_PROBLEM) then
+ chi1_dot_dot = VERYSMALLVAL
+ chi2_t_dot_dot = VERYSMALLVAL
+ chi3_dot_dot = VERYSMALLVAL
+ chi4_dot_dot = VERYSMALLVAL
+ endif
+
+ ! statistics user output
+ d = maxval(abs(PML_damping_d(:,:,:,:)))
+ if( d > TINYVAL ) then
+ sign = maxval(PML_damping_d(:,:,:,:)) / maxval(abs(PML_damping_d(:,:,:,:)))
+ else
+ sign = 1.0
+ endif
+ dprime = maxval(abs(PML_damping_dprime(:,:,:,:)))
+ call max_all_cr(d,d_glob)
+ call max_all_cr(dprime,dprime_glob)
+ call sum_all_i(num_PML_ispec,count)
+ if( myrank == 0 ) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'PML region: '
+ write(IMAIN,*) ' total spectral elements:',count
+ write(IMAIN,*) ' number of layers : ',PML_LAYERS
+ write(IMAIN,*) ' dominant wavelength max: ',dominant_wavelength
+ write(IMAIN,*) ' width min / max:',PML_width_min,PML_width_max
+ write(IMAIN,*) ' reflection coefficient:',PML_damp_R
+ write(IMAIN,*) ' maximum d : ',sign*d_glob
+ write(IMAIN,*) ' maximum dprime : ',sign*dprime_glob
+ write(IMAIN,*)
+ endif
+
+ ! VTK file output
+ call PML_output_VTKs()
+
+end subroutine PML_initialize
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_set_firstlayer()
+
+! sets ispec occurrences for first element layer in PML region based on absorbing boundary elements
+
+ use PML_par
+ use specfem_par,only: NSPEC_AB,NGLOB_AB, &
+ abs_boundary_ispec,abs_boundary_normal,num_abs_boundary_faces,&
+ abs_boundary_ijk,ibool,myrank
+ use constants,only: NDIM,TINYVAL,NGNOD,NGLLX,NGLLY,NGLLZ,NGLLSQUARE
+ implicit none
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable:: temp_ispec_pml_normal
+ integer,dimension(:),allocatable:: temp_is_pml_elem
+ integer:: iface,count,new_elemts,ispec,icorner,igll,iglobf
+ integer:: i,j,k,iglobcount,iglobcorners(NGNOD)
+ integer,dimension(3,NGNOD),parameter :: ielem_corner_ijk = &
+ reshape((/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ, &
+ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),(/3,NGNOD/))
+ ! temporary arrays
+ allocate(temp_is_pml_elem(NSPEC_AB))
+ allocate(temp_ispec_pml_normal(NDIM,NSPEC_AB))
+
+ temp_is_pml_elem(:) = 0
+ temp_ispec_pml_normal(:,:) = 0._CUSTOM_REAL
+
+ count = 0
+ do iface=1,num_abs_boundary_faces
+ ! gets spectral elements with boundary face
+ ispec = abs_boundary_ispec(iface)
+
+ ! counts new PML elements
+ if( temp_is_pml_elem(ispec) == 0 ) count = count + 1
+
+ ! counts number of occurrences
+ ! 1 : element with 1 face to regular one,
+ ! 2 : element with 2 faces (elements at edges)
+ ! 3 : element with 3 faces (elements at corners)
+ temp_is_pml_elem(ispec) = temp_is_pml_elem(ispec) + 1
+
+ ! adds contribution to element normal
+ temp_ispec_pml_normal(:,ispec) = temp_ispec_pml_normal(:,ispec) + abs_boundary_normal(:,1,iface)
+ enddo
+ new_elemts = count
+
+ ! doubling layers might have elements with only an edge on the absorbing surface
+ ! poses problems if not accounted for
+ count = 0
+ do ispec = 1,NSPEC_AB
+ ! only elements not recognized so far
+ if( temp_is_pml_elem(ispec) > 0 ) cycle
+
+ ! stores global indices of element corners
+ do icorner=1,NGNOD
+ i = ielem_corner_ijk(1,icorner)
+ j = ielem_corner_ijk(2,icorner)
+ k = ielem_corner_ijk(3,icorner)
+ iglobcorners(icorner) = ibool(i,j,k,ispec)
+ enddo
+
+ ! checks if element has an edge (two corner points) on a absorbing boundary
+ ! (refers mainly to elements in doubling layers)
+ do iface=1,num_abs_boundary_faces
+ ! checks if already encountered this element
+ if( abs_boundary_ispec(iface) == ispec ) exit
+
+ ! loops over face points
+ iglobcount = 0
+ do igll=1,NGLLSQUARE
+ i = abs_boundary_ijk(1,igll,iface)
+ j = abs_boundary_ijk(2,igll,iface)
+ k = abs_boundary_ijk(3,igll,iface)
+ iglobf = ibool(i,j,k,abs_boundary_ispec(iface))
+ ! checks with corners
+ do icorner=1,NGNOD
+ if( iglobcorners(icorner) == iglobf ) iglobcount = iglobcount + 1
+ enddo
+ enddo
+
+ ! adds as pml element
+ if( iglobcount >= 2 ) then
+ ! counter
+ if( temp_is_pml_elem(ispec) == 0 ) count = count + 1
+ temp_is_pml_elem(ispec) = temp_is_pml_elem(ispec) + 1
+ ! updates normal
+ temp_ispec_pml_normal(:,ispec) = temp_ispec_pml_normal(:,ispec) &
+ + abs_boundary_normal(:,1,iface)
+ exit
+ endif
+ enddo ! iface
+
+ enddo
+ new_elemts = new_elemts + count
+
+ ! stores PML element indices and resulting normal
+ call PML_set_elements(temp_is_pml_elem,temp_ispec_pml_normal,new_elemts)
+
+ deallocate( temp_is_pml_elem)
+ deallocate( temp_ispec_pml_normal)
+
+end subroutine PML_set_firstlayer
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_set_elements(temp_is_pml_elem,temp_ispec_pml_normal,new_elemts)
+
+! adds new elements to PML region
+
+ use PML_par
+ use specfem_par,only: NSPEC_AB,myrank
+ use constants,only: NDIM,TINYVAL
+ implicit none
+
+ integer:: temp_is_pml_elem(NSPEC_AB)
+ real(kind=CUSTOM_REAL):: temp_ispec_pml_normal(NDIM,NSPEC_AB)
+ integer:: new_elemts
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: length
+ integer :: ispec,ispecPML
+
+ ! sets new element type flags
+ ispec_is_PML_inum(:) = temp_is_pml_elem(:)
+
+ ! sets new number of elements
+ num_PML_ispec = new_elemts
+
+ ! re-allocates arrays
+ if( allocated(PML_normal) ) deallocate(PML_normal)
+ if( allocated(PML_ispec) ) deallocate(PML_ispec)
+ allocate(PML_ispec(num_PML_ispec))
+ allocate(PML_normal(NDIM,num_PML_ispec))
+
+ ! stores PML elements flags and normals
+ ispecPML = 0
+ do ispec=1,NSPEC_AB
+ if( ispec_is_PML_inum(ispec) > 0 ) then
+ ! stores indices
+ ispecPML = ispecPML+1
+ PML_ispec(ispecPML) = ispec
+
+ ! gets resulting element normal
+ PML_normal(:,ispecPML) = temp_ispec_pml_normal(:,ispec)
+
+ ! normalizes normal
+ length = sqrt( PML_normal(1,ispecPML)**2 &
+ + PML_normal(2,ispecPML)**2 &
+ + PML_normal(3,ispecPML)**2 )
+ if( length < TINYVAL ) then
+ print*,'error set elements: normal length:',length
+ print*,'elem:',ispec,ispecPML
+ print*,'num_pml_ispec:',num_PML_ispec
+ call exit_mpi(myrank,'error PML normal length')
+ else
+ ! normalizes normal
+ PML_normal(:,ispecPML) = PML_normal(:,ispecPML)/length
+ endif
+ endif
+ enddo
+ if( ispecPML /= num_PML_ispec) call exit_mpi(myrank,'PML add layer count error')
+
+end subroutine PML_set_elements
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_determine_interfacePoints()
+
+! finds global interface points of PML region to "regular" domain
+
+ use specfem_par,only: ibool,myrank,NGLOB_AB,NSPEC_AB, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh,NPROC
+ use PML_par
+ use PML_par_acoustic
+ use constants,only: NGLLX,NGLLY,NGLLZ
+ use specfem_par_acoustic,only: ispec_is_acoustic,ACOUSTIC_SIMULATION
+ implicit none
+
+ ! local parameters
+ integer,dimension(:),allocatable:: temp_regulardomain
+ integer:: i,j,k,ispec,iglob
+
+ ! PML interface points array
+ iglob_is_PML_interface(:) = 0
+
+ ! temporary arrays
+ allocate(temp_regulardomain(NGLOB_AB))
+ temp_regulardomain(:) = 0
+
+ ! global PML points
+ iglob_is_PML(:) = 0
+
+ ! sets flags on PML and regular domain points
+ do ispec=1,NSPEC_AB
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ ! sets flag for PML/regular domain
+ if( ispec_is_PML_inum(ispec) > 0 ) then
+ ! global points
+ iglob_is_PML(iglob) = iglob_is_PML(iglob) + 1
+ else
+ ! not a PML point
+ temp_regulardomain(iglob) = temp_regulardomain(iglob) + 1
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ! assemble on MPI interfaces
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,NGLOB_AB,iglob_is_PML, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh)
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,NGLOB_AB,temp_regulardomain, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh)
+
+ ! stores interface points
+ do ispec=1,NSPEC_AB
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ ! checks if it belongs to both, PML and regular domain
+ if( temp_regulardomain(iglob) > 0 .and. iglob_is_PML(iglob) > 0 ) then
+ ! increases flag on global point
+ iglob_is_PML_interface(iglob) = iglob_is_PML_interface(iglob) + 1
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+ deallocate(temp_regulardomain)
+
+end subroutine PML_determine_interfacePoints
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+subroutine PML_get_width()
+
+! calculates PML width for statistics
+
+ use specfem_par,only: abs_boundary_ispec,abs_boundary_normal,abs_boundary_ijk,&
+ num_abs_boundary_faces,&
+ ibool,xstore,ystore,zstore,myrank, &
+ NGLOB_AB
+ use PML_par
+ use constants,only: NGLLSQUARE,TINYVAL,HUGEVAL
+ implicit none
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: length,width
+ integer:: i,j,k,ispec,iglob,iface,igll,iglobf
+
+ ! determines global PML width
+ ! loops over domain surface
+ width = HUGEVAL
+ do iface=1,num_abs_boundary_faces
+
+ ispec = abs_boundary_ispec(iface)
+
+ ! avoids taking corner or edge elements for width
+ if( ispec_is_PML_inum(ispec) > 1 ) cycle
+
+ ! determines smallest distance to interface points
+ do iglob=1,NGLOB_AB
+ if( iglob_is_PML_interface(iglob) > 0 ) then
+ ! loops over face points
+ do igll=1,NGLLSQUARE
+ i = abs_boundary_ijk(1,igll,iface)
+ j = abs_boundary_ijk(2,igll,iface)
+ k = abs_boundary_ijk(3,igll,iface)
+
+ ! takes distance between two points
+ iglobf = ibool(i,j,k,ispec)
+ length = sqrt((xstore(iglobf)-xstore(iglob))**2 &
+ + (ystore(iglobf)-ystore(iglob))**2 &
+ + (zstore(iglobf)-zstore(iglob))**2 )
+
+ ! checks length
+ if( length < TINYVAL ) then
+ print*,'PML:',myrank,'length:',length
+ print*,' ijk:',i,j,k,ispec,'face:',iface,'iglob:',iglobf
+ print*,' ijk xyz:',xstore(iglobf),ystore(iglobf),zstore(iglobf)
+ print*,' iglob interface',iglob
+ print*,' iglob xyz:',xstore(iglob),ystore(iglob),zstore(iglob)
+ call exit_mpi(myrank,'PML length zero error')
+ endif
+
+ ! updates minimum width
+ if( length < width ) width = length
+
+ enddo
+ endif
+ enddo
+ enddo
+
+ ! determines maximum width on all MPI processes
+ ! all process gets overall maximum
+ call max_all_all_cr(width,PML_width_max)
+ call min_all_all_cr(width,PML_width_min)
+
+ ! sets PML width
+ if( PML_width_min > TINYVAL ) then
+ PML_width = PML_width_min
+ else
+ PML_width = PML_width_max
+ endif
+
+ ! checks
+ if( PML_width < TINYVAL ) call exit_mpi(myrank,'PML width error: width too small')
+
+end subroutine PML_get_width
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_set_local_dampingcoeff()
+
+! calculates damping profiles on PML points
+
+ use specfem_par,only: ibool,xstore,ystore,zstore,myrank, &
+ kappastore,mustore,NGLOB_AB,&
+ abs_boundary_ispec,abs_boundary_ijk,num_abs_boundary_faces
+ use specfem_par_acoustic,only: ACOUSTIC_SIMULATION,rhostore
+ use specfem_par_elastic,only: ELASTIC_SIMULATION,rho_vp
+ use PML_par
+ use constants,only: NGLLX,NGLLY,NGLLZ,HUGEVAL,FOUR_THIRDS,NGLLSQUARE,TINYVAL
+ implicit none
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: length
+ real(kind=CUSTOM_REAL) :: dist,vp
+ real(kind=CUSTOM_REAL) :: d
+ real(kind=CUSTOM_REAL) :: width
+
+ integer:: i,j,k,ispec,iglob,ispecPML,iglobf
+ integer:: ispecB,igll,iface
+
+ ! stores damping coefficient
+ allocate( PML_damping_d(NGLLX,NGLLY,NGLLZ,num_PML_ispec))
+ PML_damping_d(:,:,:,:) = 0._CUSTOM_REAL
+
+ ! loops over all PML elements
+ do ispecPML=1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! determines smallest distance to interface points
+ ! and determines smallest distance to absorbing boundary points
+ ! (note: MPI partitioning not considered here yet; might be a problem)
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! global index
+ iglobf = ibool(i,j,k,ispec)
+
+ ! ensures that PML interface points have zero damping coefficients
+ if( iglob_is_PML_interface(iglobf) > 0 ) then
+ PML_damping_d(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ cycle
+ endif
+
+ ! distance to PML interface points
+ dist = HUGEVAL
+ do iglob=1,NGLOB_AB
+ if( iglob_is_PML_interface(iglob) > 0 ) then
+ ! distance to interface
+ length = (xstore(iglobf)-xstore(iglob))**2 &
+ + (ystore(iglobf)-ystore(iglob))**2 &
+ + (zstore(iglobf)-zstore(iglob))**2
+ if( length < dist ) dist = length
+ endif
+ enddo !iglob
+ !dist = distances(i,j,k)
+ if( dist >= HUGEVAL ) then
+ dist = PML_width_max
+ else
+ dist = sqrt( dist )
+ endif
+
+ ! distance to boundary points
+ width = HUGEVAL
+ do iface=1,num_abs_boundary_faces
+ ispecB = abs_boundary_ispec(iface)
+ do igll=1,NGLLSQUARE
+ iglob = ibool(abs_boundary_ijk(1,igll,iface),&
+ abs_boundary_ijk(2,igll,iface),&
+ abs_boundary_ijk(3,igll,iface),ispecB)
+ ! distance to boundary
+ length = (xstore(iglobf)-xstore(iglob))**2 &
+ + (ystore(iglobf)-ystore(iglob))**2 &
+ + (zstore(iglobf)-zstore(iglob))**2
+ if( length < width ) width = length
+ enddo
+ enddo ! iface
+ ! apparent width of PML for this point
+ if( width >= HUGEVAL ) then
+ width = PML_width_max
+ else
+ width = sqrt( width ) + dist
+ endif
+
+ ! checks width
+ if( width < TINYVAL ) then
+ print*,'error: pml width ',width
+ print*,'ijk:',ispec,i,j,k
+ print*,'xyz:',xstore(ibool(i,j,k,ispec)),ystore(ibool(i,j,k,ispec)),zstore(ibool(i,j,k,ispec))
+ print*,'dist:',dist
+ print*,'pml min/max:',PML_width_max,PML_width_min
+ call exit_mpi(myrank,'PML error getting width')
+ endif
+
+ ! P-velocity
+ if( ACOUSTIC_SIMULATION ) then
+ vp = sqrt( kappastore(i,j,k,ispec)/rhostore(i,j,k,ispec) )
+ else if( ELASTIC_SIMULATION ) then
+ vp = (FOUR_THIRDS * mustore(i,j,k,ispec) + kappastore(i,j,k,ispec)) &
+ / rho_vp(i,j,k,ispec)
+ else
+ call exit_mpi(myrank,'PML error getting vp')
+ endif
+
+ ! gets damping coefficient
+ call PML_damping_profile_l(d,dist,vp,width)
+
+ ! stores d & dprime for this element's GLL points
+ PML_damping_d(i,j,k,ispecPML) = d
+
+ enddo
+ enddo
+ enddo
+ enddo !ispecPML
+
+end subroutine PML_set_local_dampingcoeff
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_determine_dprime()
+
+! calculates derivatives dprime of damping coefficients on GLL points
+
+ use PML_par
+ use PML_par_acoustic
+ use constants,only: NGLLX,NGLLY,NGLLZ
+ use specfem_par,only: xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,&
+ hprime_xx,hprime_yy,hprime_zz
+ implicit none
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLZ,NGLLZ) :: dprime_elem
+ real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl
+ real(kind=CUSTOM_REAL) :: nx,ny,nz
+ real(kind=CUSTOM_REAL) :: d_dx,d_dy,d_dz,tempd_dx,tempd_dy,tempd_dz
+ integer :: ispec,i,j,k,l,ispecPML
+
+ ! dprime derivatives
+ allocate( PML_damping_dprime(NGLLX,NGLLY,NGLLZ,num_PML_ispec))
+ PML_damping_dprime(:,:,:,:) = 0._CUSTOM_REAL
+
+ ! loops over all PML elements
+ do ispecPML=1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! PML normal
+ nx = PML_normal(1,ispecPML)
+ ny = PML_normal(2,ispecPML)
+ nz = PML_normal(3,ispecPML)
+
+ ! calculates terms:
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! derivative along x, y, z
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the loops because NGLLX == NGLLY == NGLLZ
+ tempd_dx = 0._CUSTOM_REAL
+ tempd_dy = 0._CUSTOM_REAL
+ tempd_dz = 0._CUSTOM_REAL
+ do l = 1,NGLLX
+ tempd_dx = tempd_dx + PML_damping_d(l,j,k,ispecPML)*hprime_xx(i,l)
+ tempd_dy = tempd_dy + PML_damping_d(i,l,k,ispecPML)*hprime_yy(j,l)
+ tempd_dz = tempd_dz + PML_damping_d(i,j,l,ispecPML)*hprime_zz(k,l)
+ enddo
+
+ ! get derivatives of potential with respect to x, y and z
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+
+ ! derivatives dprime
+ d_dx = xixl*tempd_dx + etaxl*tempd_dy + gammaxl*tempd_dz
+ d_dy = xiyl*tempd_dx + etayl*tempd_dy + gammayl*tempd_dz
+ d_dz = xizl*tempd_dx + etazl*tempd_dy + gammazl*tempd_dz
+ dprime_elem(i,j,k) = d_dx*nx + d_dy*ny + d_dz*nz
+
+ enddo
+ enddo
+ enddo
+
+ ! stores dprime coefficients
+ PML_damping_dprime(:,:,:,ispecPML) = dprime_elem(:,:,:)
+
+ enddo
+
+end subroutine PML_determine_dprime
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_add_layer()
+
+! adds an element layer to the PML region
+
+ use PML_par
+ use specfem_par,only: NSPEC_AB,NGLOB_AB, &
+ abs_boundary_ispec,abs_boundary_normal,num_abs_boundary_faces,&
+ ibool,myrank,&
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh,NPROC
+ use constants,only: NDIM,TINYVAL,NGLLX,NGLLY,NGLLZ,NGNOD2D
+ implicit none
+
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable:: iglob_pml_normal
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable:: ispec_pml_normal
+ integer,dimension(:),allocatable:: is_pml_elem
+ integer:: i,j,k,iglob,count,ispecPML,ispec,new_elemts
+ integer :: iface,icorner,ipmlcorners
+
+ integer,dimension(3,4),parameter :: iface1_corner_ijk = &
+ reshape((/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ /),(/3,4/)) ! xmin
+ integer,dimension(3,4),parameter :: iface2_corner_ijk = &
+ reshape((/ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),(/3,4/)) ! xmax
+ integer,dimension(3,4),parameter :: iface3_corner_ijk = &
+ reshape((/ 1,1,1, 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,1,1 /),(/3,4/)) ! ymin
+ integer,dimension(3,4),parameter :: iface4_corner_ijk = &
+ reshape((/ 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! ymax
+ integer,dimension(3,4),parameter :: iface5_corner_ijk = &
+ reshape((/ 1,1,1, 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,1,1 /),(/3,4/)) ! bottom
+ integer,dimension(3,4),parameter :: iface6_corner_ijk = &
+ reshape((/ 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! top
+ integer,dimension(3,4,6),parameter :: iface_all_corner_ijk = &
+ reshape((/ iface1_corner_ijk,iface2_corner_ijk, &
+ iface3_corner_ijk,iface4_corner_ijk, &
+ iface5_corner_ijk,iface6_corner_ijk /),(/3,4,6/)) ! all faces
+ ! midpoint indices for each face (xmin,xmax,ymin,ymax,zmin,zmax)
+ integer,dimension(3,6),parameter :: iface_all_midpointijk = &
+ reshape( (/ 1,2,2, NGLLX,2,2, 2,1,2, 2,NGLLY,2, 2,2,1, 2,2,NGLLZ /),(/3,6/))
+ logical :: is_done
+
+ ! temporary arrays
+ allocate(is_pml_elem(NSPEC_AB))
+ allocate(iglob_pml_normal(NDIM,NGLOB_AB))
+ allocate(ispec_pml_normal(NDIM,NSPEC_AB))
+
+ iglob_pml_normal(:,:) = 0._CUSTOM_REAL
+ ispec_pml_normal(:,:) = 0._CUSTOM_REAL
+
+ ! sets pml normals on PML interface, global points
+ do ispecPML=1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+ ! checks
+ if( ispec_is_PML_inum(ispec) < 1 ) call exit_mpi(myrank,'PML error add ispec layer')
+
+ ! starts from first layer elements
+ ! stores normal information on temporary global points
+ if( ispec_is_PML_inum(ispec) >= 1 ) then
+ ! stores PML normal on interface points
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ if( iglob_is_PML_interface(iglob) > 0 ) then
+ iglob_pml_normal(:,iglob) = iglob_pml_normal(:,iglob) + PML_normal(:,ispecPML)
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+
+ enddo
+
+ ! assembles with other MPI processes
+ call assemble_MPI_vector_ext_mesh(NPROC,NGLOB_AB,iglob_pml_normal, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+
+ ! adds new elements sharing PML interface
+ count = 0
+ is_pml_elem(:) = 0
+ do ispec=1,NSPEC_AB
+
+ ! checks if we already have this element set as pml element in first layer
+ is_done = .false.
+ do ispecPML=1,num_PML_ispec
+ if( PML_ispec(ispecPML) == ispec ) then
+ ! adds as pml element
+ if(is_pml_elem(ispec) == 0) count = count + 1
+ ! copies normal
+ ispec_pml_normal(:,ispec) = PML_normal(:,ispecPML)
+ ! copies element type flag
+ is_pml_elem(ispec) = ispec_is_PML_inum(ispec)
+
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) cycle
+
+ ! loops over element faces
+ do iface=1,6
+ ipmlcorners = 0
+ do icorner=1,NGNOD2D
+ i = iface_all_corner_ijk(1,icorner,iface)
+ j = iface_all_corner_ijk(2,icorner,iface)
+ k = iface_all_corner_ijk(3,icorner,iface)
+ iglob = ibool(i,j,k,ispec)
+ if( iglob_is_PML_interface(iglob) > 0 ) ipmlcorners = ipmlcorners + 1
+ enddo
+
+ ! face is pml interface
+ if( ipmlcorners == NGNOD2D ) then
+ ! counts new pml elements
+ if(is_pml_elem(ispec) == 0) count = count + 1
+
+ ! increments flag
+ is_pml_elem(ispec) = is_pml_elem(ispec) + 1
+
+ ! sets normal
+ ! reference midpoint on face
+ i = iface_all_midpointijk(1,iface)
+ j = iface_all_midpointijk(2,iface)
+ k = iface_all_midpointijk(3,iface)
+ iglob = ibool(i,j,k,ispec)
+ if( iglob_is_PML_interface(iglob) < 1 ) call exit_mpi(myrank,'PML error midpoint interface')
+
+ ! checks new normal
+ if( sqrt(iglob_pml_normal(1,iglob)**2+iglob_pml_normal(2,iglob)**2 &
+ +iglob_pml_normal(3,iglob)**2) < TINYVAL ) then
+ print*,'error add layer: normal length zero: iglob',iglob
+ print*,'face ',iface,ipmlcorners
+ print*,'ijk ispec',i,j,k,ispec
+ call exit_mpi(myrank,'PML add layer has new normal length error')
+ endif
+
+ ! adds contribution to normal
+ ispec_pml_normal(:,ispec) = ispec_pml_normal(:,ispec) + iglob_pml_normal(:,iglob)
+ endif
+
+ enddo ! iface
+ enddo ! ispec
+ new_elemts = count
+
+ ! adds new pml elements to PML region
+ call PML_set_elements(is_pml_elem,ispec_pml_normal,new_elemts)
+
+end subroutine PML_add_layer
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_update_normals(ilayer)
+
+! updates normal's directions for elements in PML region
+
+ use PML_par
+ use specfem_par,only: NSPEC_AB,NGLOB_AB, &
+ ibool,myrank,&
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh,NPROC
+ use constants,only: NGNOD2D,NGLLX,NGLLY,NGLLZ
+ implicit none
+ integer :: ilayer
+
+ ! local parameters
+ integer:: iglob,ispecPML,ispec
+ integer :: iface,icorner
+ integer :: ipmlcorners,ipmledges,ipmlsngl
+ integer :: ipmlcorners_tot,ipmledges_tot,ipmlsngl_tot
+
+ integer,dimension(3,4),parameter :: iface1_corner_ijk = &
+ reshape((/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ /),(/3,4/)) ! xmin
+ integer,dimension(3,4),parameter :: iface2_corner_ijk = &
+ reshape((/ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),(/3,4/)) ! xmax
+ integer,dimension(3,4),parameter :: iface3_corner_ijk = &
+ reshape((/ 1,1,1, 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,1,1 /),(/3,4/)) ! ymin
+ integer,dimension(3,4),parameter :: iface4_corner_ijk = &
+ reshape((/ 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! ymax
+ integer,dimension(3,4),parameter :: iface5_corner_ijk = &
+ reshape((/ 1,1,1, 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,1,1 /),(/3,4/)) ! bottom
+ integer,dimension(3,4),parameter :: iface6_corner_ijk = &
+ reshape((/ 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! top
+ integer,dimension(3,4,6),parameter :: iface_all_corner_ijk = &
+ reshape((/ iface1_corner_ijk,iface2_corner_ijk, &
+ iface3_corner_ijk,iface4_corner_ijk, &
+ iface5_corner_ijk,iface6_corner_ijk /),(/3,4,6/)) ! all faces
+ integer:: ispecngb,iadj,ipmlinterface
+ integer :: ispecPMLngb_corner,ispecPMLngb_edge,ispecPMLngb_sngl
+ integer,dimension(:),allocatable :: iglob_nadj,ispec_is_PML_inum_org
+ integer,dimension(:,:,:),allocatable :: iglob_adj
+
+
+ ! checks normals for elements adjacent to edge/corner elements
+ ! assigns element information to each global point
+ ! (note: mpi partitioning/interface between elements not considered yet)
+ allocate(iglob_nadj(NGLOB_AB),iglob_adj(2,32,NGLOB_AB))
+ iglob_nadj(:) = 0
+ iglob_adj(:,:,:) = 0
+ do ispecPML=1,num_PML_ispec
+ ispec = PML_ispec(ispecPML)
+ ! sets element corners
+ do iface=1,2
+ do icorner=1,NGNOD2D
+ iglob = ibool(iface_all_corner_ijk(1,icorner,iface),&
+ iface_all_corner_ijk(2,icorner,iface),&
+ iface_all_corner_ijk(3,icorner,iface),ispec)
+ ! number of occurrences
+ iglob_nadj(iglob) = iglob_nadj(iglob) + 1
+ ! first parameter is assigned element id ispec
+ iglob_adj(1,iglob_nadj(iglob),iglob) = ispec
+ ! second parameter is corresponding pml element id ispecPML
+ iglob_adj(2,iglob_nadj(iglob),iglob) = ispecPML
+ enddo
+ enddo
+ enddo
+ if( maxval(iglob_nadj(:)) > 32 ) then
+ print*,'info neighbors:',myrank
+ print*,'max number of adjacents:',maxval(iglob_nadj(:)),maxloc(iglob_nadj(:))
+ call exit_mpi(myrank,'error iglob number of adj')
+ endif
+
+ ! finds neighbors based on common nodes and changes type and normal accordingly
+ ! for edges and corners
+ allocate(ispec_is_PML_inum_org(NSPEC_AB))
+ ispec_is_PML_inum_org(:) = ispec_is_PML_inum(:)
+ do ispecPML=1,num_PML_ispec
+ ispec = PML_ispec(ispecPML)
+
+ ! only non-corner elements
+ if( ispec_is_PML_inum_org(ispec) <= 2 ) then
+ ipmlsngl_tot = 0
+ ipmlcorners_tot = 0
+ ipmledges_tot = 0
+ ipmlinterface = 0
+ ! loops over element corners
+ do iface=1,2
+ ! checks corner neighbors
+ do icorner=1,NGNOD2D
+ iglob = ibool(iface_all_corner_ijk(1,icorner,iface),&
+ iface_all_corner_ijk(2,icorner,iface),&
+ iface_all_corner_ijk(3,icorner,iface),ispec)
+ ! adjacent elements
+ ipmlsngl = 0
+ ipmlcorners = 0
+ ipmledges = 0
+ do iadj=1,iglob_nadj(iglob)
+ ispecngb = iglob_adj(1,iadj,iglob)
+ if( ispecngb /= ispec ) then
+ ! counts single normal neighbors
+ if( ispec_is_PML_inum_org(ispecngb) == 1 ) then
+ ipmlsngl = ipmlsngl + 1
+ ispecPMLngb_sngl = iglob_adj(2,iadj,iglob)
+ endif
+ ! counts corner neighbors
+ if( ispec_is_PML_inum_org(ispecngb) == 3 ) then
+ ipmlcorners = ipmlcorners + 1
+ ispecPMLngb_corner = iglob_adj(2,iadj,iglob)
+ endif
+ ! counts edge neighbors
+ if( ispec_is_PML_inum_org(ispecngb) == 2 ) then
+ ipmledges = ipmledges + 1
+ ispecPMLngb_edge = iglob_adj(2,iadj,iglob)
+ endif
+ endif
+ enddo
+ if( ipmlsngl > 0 ) ipmlsngl_tot = ipmlsngl_tot + 1
+ if( ipmlcorners > 0 ) ipmlcorners_tot = ipmlcorners_tot + 1
+ if( ipmledges > 0 ) ipmledges_tot = ipmledges_tot + 1
+
+ ! interface points
+ if( iglob_is_PML_interface(iglob) > 0 ) ipmlinterface = ipmlinterface + 1
+
+ enddo !icorner
+ enddo
+
+ ! elements inside PML
+ if( ipmlinterface < 4 ) then
+
+ ! shares two faces with edge elements, so it becomes an edge element too
+ if( ispec_is_PML_inum_org(ispec) == 1 ) then
+ if( ipmledges_tot >= 6 ) then
+ ispec_is_PML_inum(ispec) = 2
+ PML_normal(:,ispecPML) = PML_normal(:,ispecPMLngb_edge)
+ endif
+ if( ipmlcorners_tot >= 5 ) then
+ ispec_is_PML_inum(ispec) = 3
+ PML_normal(:,ispecPML) = PML_normal(:,ispecPMLngb_corner)
+ endif
+ else if( ispec_is_PML_inum_org(ispec) == 2 ) then
+
+ ! shares at least a face and a face edge with a corner element,
+ ! so it becomes a corner element too
+ if( ipmlcorners_tot >= 5 ) then
+ ispec_is_PML_inum(ispec) = 3
+ PML_normal(:,ispecPML) = PML_normal(:,ispecPMLngb_corner)
+ endif
+ endif
+ endif
+ ! avoid elements between two edges and next to corner to become edge elements
+ if( ispec_is_PML_inum(ispec) == 2 .and. ilayer > 1 ) then
+ if( ipmlsngl_tot == 8 .and. ipmlcorners_tot == 2 ) then
+ ispec_is_PML_inum(ispec) = 1
+ PML_normal(:,ispecPML) = PML_normal(:,ispecPMLngb_sngl)
+ endif
+ endif
+
+ endif
+ enddo
+ deallocate(iglob_adj,iglob_nadj)
+ deallocate(ispec_is_PML_inum_org)
+
+end subroutine PML_update_normals
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_output_VTKs()
+
+! outputs informations about PML elements
+
+ use PML_par
+ use specfem_par,only: NGLOB_AB,NSPEC_AB,myrank, &
+ prname,ibool,xstore,ystore,zstore
+ use constants,only: NGLLX,NGLLY,NGLLZ,IMAIN
+ implicit none
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable:: ispec_normal
+ real(kind=CUSTOM_REAL),dimension(:,:,:,:),allocatable:: temp_gllvalues
+ integer,dimension(:),allocatable :: temp_iglob
+ integer :: count,iglob,ispecPML,ispec
+ character(len=256) :: vtkfilename
+
+ ! element type flags
+ if( .false. ) then
+ vtkfilename = prname(1:len_trim(prname))//'PML_ispec_inum'
+ call write_VTK_data_elem_i(NSPEC_AB,NGLOB_AB,xstore,ystore,zstore,ibool,&
+ ispec_is_PML_inum,vtkfilename)
+ endif
+
+ ! interface points
+ if( .false. ) then
+ ! puts global points in a temporary array for plotting
+ count = 0
+ do iglob=1,NGLOB_AB
+ if( iglob_is_PML_interface(iglob) > 0 ) then
+ count = count+1
+ endif
+ enddo
+ allocate(temp_iglob(count))
+ count = 0
+ do iglob=1,NGLOB_AB
+ if( iglob_is_PML_interface(iglob) > 0 ) then
+ count = count+1
+ temp_iglob(count) = iglob
+ endif
+ enddo
+ vtkfilename = prname(1:len_trim(prname))//'PML_interface_points'
+ call write_VTK_data_points(NGLOB_AB,xstore,ystore,zstore, &
+ temp_iglob,count,vtkfilename)
+ deallocate(temp_iglob)
+ endif
+
+ ! pml normals
+ if( .false. ) then
+ allocate(ispec_normal(3,NSPEC_AB) )
+ ispec_normal(:,:) = 0._CUSTOM_REAL
+ do ispecPML=1,num_PML_ispec
+ ispec = PML_ispec(ispecPML)
+ ispec_normal(:,ispec) = PML_normal(:,ispecPML)
+ enddo
+ vtkfilename = prname(1:len_trim(prname))//'PML_normals'
+ call write_VTK_data_elem_vectors(NSPEC_AB,NGLOB_AB,xstore,ystore,zstore,ibool, &
+ ispec_normal,vtkfilename)
+ deallocate(ispec_normal)
+ endif
+
+ ! pml damping coefficients
+ if( .false. ) then
+ allocate(temp_gllvalues(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ temp_gllvalues = 0._CUSTOM_REAL
+ do ispecPML=1,num_PML_ispec
+ ispec = PML_ispec(ispecPML)
+ temp_gllvalues(:,:,:,ispec) = PML_damping_d(:,:,:,ispecPML)
+ enddo
+ vtkfilename = prname(1:len_trim(prname))//'PML_damping_d'
+ call write_VTK_data_gll_cr(NSPEC_AB,NGLOB_AB, &
+ xstore,ystore,zstore,ibool, &
+ temp_gllvalues,vtkfilename)
+ deallocate(temp_gllvalues)
+ endif ! VTK file output
+
+ if(myrank == 0) write(IMAIN,*)
+
+end subroutine PML_output_VTKs
\ No newline at end of file
Added: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/plot_seismos.gmt.pl
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/plot_seismos.gmt.pl (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/plot_seismos.gmt.pl 2010-01-06 23:41:13 UTC (rev 16126)
@@ -0,0 +1,100 @@
+#!/usr/bin/perl -w
+#
+# usage:
+#
+# ./plot_seismos.gmt.pl OUTPUT_FILES/Y*.BHZ.semd
+#
+# GMT package must be installed...
+use POSIX;
+use Getopt::Std;
+
+
+#---------------------------------------------------------------------------
+## PARAMETERS
+
+# min/max range scaling
+$SCALE = 10. ;
+
+#---------------------------------------------------------------------------
+
+sub Usage{
+ print STDERR <<END;
+
+Usage: e.g. ./plot_seismos.gmt.pl OUTPUT_FILES/Y*.BHZ.semd
+
+END
+exit(1);
+}
+
+ at ARGV > 0 or Usage();
+
+# find start and end time and a reasonable step
+$narg = @ARGV;
+$mid = int($narg/2.0);
+$trace = $ARGV[$mid];
+#print "trace: $trace\n";
+
+# set region
+$minmax=`minmax $trace -C `;
+chomp($minmax);
+
+($t_start,$t_end,$min,$max) = split(" ",$minmax);
+
+$min = $SCALE*$min;
+$max = $SCALE*$max;
+
+$region="$t_start/$t_end/$min/$max";
+
+#print "region: $region\n";
+
+$proj="X6/1.5";
+$color="0/0/200";
+
+open(GMT,">plot_gmtseismos.sh");
+print GMT "gmtset PAPER_MEDIA letter MEASURE_UNIT inch HEADER_FONT_SIZE 14p LABEL_FONT_SIZE 16p\n";
+
+
+# set output filename
+$out="seis.ps";
+print GMT "psbasemap -R$region -J$proj -B::.:'Time (s)':/S -K -P -Y1 > $out \n";
+
+
+#################################
+# plot seismograms
+#################################
+
+$offset = 8./$narg;
+
+$counter=0;
+$xoff = 0;
+$yoff = 0;
+foreach $file (@ARGV) {
+
+$counter++;
+
+$xoff=0;
+$yoff=$offset;
+
+# plots
+print GMT "psxy $file -R$region -J$proj -W2/$color -X$xoff -Y$yoff -O -K >> $out \n";
+
+}
+
+# finishes plot with annotations
+#print GMT "pstext -R$region -J$proj -N -O -K << END >> $out \n";
+#print GMT "$t_start $max 12 0 0 LT Seismograms \n";
+#print GMT "END \n";
+
+# end ps-file
+print GMT "psxy -J -R -O -P -V <<EOF >>$out\nEOF\n";
+
+print GMT "convert $out seis.pdf \n";
+print GMT "rm -f $out\n";
+
+close(GMT);
+
+system("sh plot_gmtseismos.sh");
+system("rm -f plot_gmtseismos.sh");
+
+print "plotted to: seis.pdf \n";
+
Property changes on: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/plot_seismos.gmt.pl
___________________________________________________________________
Name: svn:executable
+ *
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_vector.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_vector.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/assemble_MPI_vector.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -28,10 +28,9 @@
!----
subroutine assemble_MPI_vector_ext_mesh(NPROC,NGLOB_AB,array_val, &
- buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh, &
- num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,my_neighbours_ext_mesh, &
- request_send_vector_ext_mesh,request_recv_vector_ext_mesh)
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
implicit none
@@ -43,64 +42,82 @@
integer :: NPROC
integer :: NGLOB_AB
- real(kind=CUSTOM_REAL), dimension(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: &
- buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh
-
integer :: num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh
integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh,my_neighbours_ext_mesh
integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
- integer, dimension(num_interfaces_ext_mesh) :: request_send_vector_ext_mesh,request_recv_vector_ext_mesh
+ ! local parameters
+
+ ! send/receive temporary buffers
+ !real(kind=CUSTOM_REAL), dimension(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: &
+ ! buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: buffer_send_vector_ext_mesh
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: buffer_recv_vector_ext_mesh
+
+ ! requests
+ !integer, dimension(num_interfaces_ext_mesh) :: request_send_vector_ext_mesh,request_recv_vector_ext_mesh
+ integer, dimension(:), allocatable :: request_send_vector_ext_mesh
+ integer, dimension(:), allocatable :: request_recv_vector_ext_mesh
+
integer ipoin,iinterface
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
! here we have to assemble all the contributions between partitions using MPI
! assemble only if more than one partition
if(NPROC > 1) then
-! partition border copy into the buffer
- do iinterface = 1, num_interfaces_ext_mesh
- do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
- buffer_send_vector_ext_mesh(:,ipoin,iinterface) = array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface))
+ allocate(buffer_send_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(buffer_recv_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(request_send_vector_ext_mesh(num_interfaces_ext_mesh))
+ allocate(request_recv_vector_ext_mesh(num_interfaces_ext_mesh))
+
+ ! partition border copy into the buffer
+ do iinterface = 1, num_interfaces_ext_mesh
+ do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
+ buffer_send_vector_ext_mesh(:,ipoin,iinterface) = array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface))
+ enddo
enddo
- enddo
-! send messages
- do iinterface = 1, num_interfaces_ext_mesh
- call issend_cr(buffer_send_vector_ext_mesh(1,1,iinterface), &
- NDIM*nibool_interfaces_ext_mesh(iinterface), &
- my_neighbours_ext_mesh(iinterface), &
- itag, &
- request_send_vector_ext_mesh(iinterface) &
- )
- call irecv_cr(buffer_recv_vector_ext_mesh(1,1,iinterface), &
- NDIM*nibool_interfaces_ext_mesh(iinterface), &
- my_neighbours_ext_mesh(iinterface), &
- itag, &
- request_recv_vector_ext_mesh(iinterface) &
- )
- enddo
+ ! send messages
+ do iinterface = 1, num_interfaces_ext_mesh
+ call issend_cr(buffer_send_vector_ext_mesh(1,1,iinterface), &
+ NDIM*nibool_interfaces_ext_mesh(iinterface), &
+ my_neighbours_ext_mesh(iinterface), &
+ itag, &
+ request_send_vector_ext_mesh(iinterface) &
+ )
+ call irecv_cr(buffer_recv_vector_ext_mesh(1,1,iinterface), &
+ NDIM*nibool_interfaces_ext_mesh(iinterface), &
+ my_neighbours_ext_mesh(iinterface), &
+ itag, &
+ request_recv_vector_ext_mesh(iinterface) &
+ )
+ enddo
-! wait for communications completion (recv)
- do iinterface = 1, num_interfaces_ext_mesh
- call wait_req(request_recv_vector_ext_mesh(iinterface))
- enddo
+ ! wait for communications completion (recv)
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_recv_vector_ext_mesh(iinterface))
+ enddo
-! adding contributions of neighbours
- do iinterface = 1, num_interfaces_ext_mesh
- do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
- array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface)) = &
- array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface)) + buffer_recv_vector_ext_mesh(:,ipoin,iinterface)
+ ! adding contributions of neighbours
+ do iinterface = 1, num_interfaces_ext_mesh
+ do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
+ array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface)) = &
+ array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface)) + buffer_recv_vector_ext_mesh(:,ipoin,iinterface)
+ enddo
enddo
- enddo
-! wait for communications completion (send)
- do iinterface = 1, num_interfaces_ext_mesh
- call wait_req(request_send_vector_ext_mesh(iinterface))
- enddo
+ ! wait for communications completion (send)
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_send_vector_ext_mesh(iinterface))
+ enddo
+ deallocate(buffer_send_vector_ext_mesh)
+ deallocate(buffer_recv_vector_ext_mesh)
+ deallocate(request_send_vector_ext_mesh)
+ deallocate(request_recv_vector_ext_mesh)
+
endif
end subroutine assemble_MPI_vector_ext_mesh
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/check_mesh_resolution.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/check_mesh_resolution.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/check_mesh_resolution.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -26,9 +26,11 @@
subroutine check_mesh_resolution(myrank,NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore, &
kappastore,mustore,rho_vp,rho_vs, &
- DT )
+ DT, model_speed_max )
! check the mesh, stability and resolved period
+!
+! returns: maximum velocity in model ( model_speed_max )
implicit none
@@ -38,7 +40,10 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: kappastore,mustore,rho_vp,rho_vs
real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: xstore,ystore,zstore
integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-
+ double precision :: DT
+ real(kind=CUSTOM_REAL) :: model_speed_max
+
+ ! local parameters
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ):: vp_elem,vs_elem
real(kind=CUSTOM_REAL), dimension(1) :: val_min,val_max
real(kind=CUSTOM_REAL) :: vpmin,vpmax,vsmin,vsmax,vpmin_glob,vpmax_glob,vsmin_glob,vsmax_glob
@@ -46,7 +51,6 @@
real(kind=CUSTOM_REAL) :: cmax,cmax_glob,pmax,pmax_glob
real(kind=CUSTOM_REAL) :: dt_suggested,dt_suggested_glob
- double precision :: DT
logical:: DT_PRESENT
integer :: myrank
@@ -278,6 +282,17 @@
write(IMAIN,*)
endif
endif
+
+ ! returns the maximum velocity
+ if( myrank == 0 ) then
+ if( vpmax_glob > vsmax_glob ) then
+ model_speed_max = vpmax_glob
+ else
+ model_speed_max = vsmax_glob
+ endif
+ endif
+ call bcast_all_cr(model_speed_max,1)
+
end subroutine
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/combine_vol_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/combine_vol_data.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/combine_vol_data.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -42,7 +42,10 @@
integer :: NSPEC_AB, NGLOB_AB
! parameters
+ ! data must be of dimension: (NGLLX,NGLLY,NGLLZ,NSPEC_AB)
real(kind=CUSTOM_REAL),dimension(:,:,:,:),allocatable :: data
+
+ ! mesh coordinates
real(kind=CUSTOM_REAL),dimension(:),allocatable :: xstore, ystore, zstore
integer, dimension(:,:,:,:),allocatable :: ibool
@@ -55,11 +58,27 @@
integer :: iproc, proc1, proc2, num_node, node_list(300), nspec, nglob
integer :: np, ne, npp, nee, nelement, njunk
- character(len=256) :: sline, arg(6), filename, indir, outdir, prname
+ character(len=256) :: sline, arg(6), filename, indir, outdir
+ character(len=256) :: prname, prname_lp
character(len=256) :: mesh_file,local_data_file, local_ibool_file
logical :: HIGH_RESOLUTION_MESH
integer :: ires
+ ! for read_parameter_files
+ double precision :: DT
+ double precision :: HDUR_MOVIE
+ integer :: NPROC,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP, &
+ UTM_PROJECTION_ZONE,SIMULATION_TYPE
+ integer :: NSOURCES
+ integer :: NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
+ logical :: MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ USE_HIGHRES_FOR_MOVIES,SUPPRESS_UTM_PROJECTION
+ logical :: TOPOGRAPHY,ATTENUATION,USE_OLSEN_ATTENUATION, &
+ OCEANS
+ logical :: ABSORBING_CONDITIONS,SAVE_FORWARD
+ logical :: ANISOTROPY,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION
+ character(len=256) LOCAL_PATH
+
! checks given arguments
print *
print *,'Recombining ParaView data for slices'
@@ -72,12 +91,16 @@
print *, ' xcombine_data start_slice end_slice filename input_dir output_dir high/low-resolution'
print *, ' or '
print *, ' xcombine_data slice_list filename input_dir output_dir high/low-resolution'
+ print *
print *, ' possible filenames are '
print *, ' rho_vp, rho_vs, kappastore, mustore etc'
+ print *
print *, ' that are stored in the local directory as real(kind=CUSTOM_REAL) filename(NGLLX,NGLLY,NGLLZ,nspec) '
print *, ' in filename.bin'
+ print *
print *, ' files have been collected in input_dir, output mesh file goes to output_dir '
print *, ' give 0 for low resolution and 1 for high resolution'
+ print *
stop ' Reenter command line options'
endif
enddo
@@ -122,6 +145,19 @@
HIGH_RESOLUTION_MESH = .true.
endif
+ ! needs local_path for mesh files
+ call read_parameter_file( &
+ NPROC,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ ATTENUATION,USE_OLSEN_ATTENUATION,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
+ OCEANS,ANISOTROPY,ABSORBING_CONDITIONS, &
+ MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
+ SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
+
+
+
print *, 'Slice list: '
print *, node_list(1:num_node)
@@ -132,7 +168,8 @@
! counts total number of points (all slices)
npp = 0
nee = 0
- call combine_vol_data_count_totals_ext_mesh(num_node,node_list,indir,npp,nee,HIGH_RESOLUTION_MESH)
+ call combine_vol_data_count_totals_ext_mesh(num_node,node_list,LOCAL_PATH,&
+ npp,nee,HIGH_RESOLUTION_MESH)
! write point and scalar information
@@ -143,9 +180,10 @@
print *, ' '
print *, 'Reading slice ', iproc
- write(prname,'(a,i6.6,a)') trim(indir)//'/proc',iproc,'_'
+ write(prname_lp,'(a,i6.6,a)') trim(LOCAL_PATH)//'/proc',iproc,'_'
- open(unit=27,file=prname(1:len_trim(prname))//'external_mesh.bin',status='old',action='read',form='unformatted')
+ open(unit=27,file=prname_lp(1:len_trim(prname_lp))//'external_mesh.bin',&
+ status='old',action='read',form='unformatted')
read(27) NSPEC_AB
read(27) NGLOB_AB
close(27)
@@ -158,9 +196,23 @@
allocate(dat(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
allocate(xstore(NGLOB_AB),ystore(NGLOB_AB),zstore(NGLOB_AB))
+ ! ibool file
+ local_ibool_file = trim(prname_lp) // 'ibool' // '.bin'
+ open(unit = 28,file = trim(local_ibool_file),status='old',&
+ action='read', iostat = ios, form='unformatted')
+ if (ios /= 0) then
+ print *,'Error opening ',trim(local_data_file)
+ stop
+ endif
+ read(28) ibool
+ close(28)
+ print *, trim(local_ibool_file)
+
! data file
+ write(prname,'(a,i6.6,a)') trim(indir)//'proc',iproc,'_'
local_data_file = trim(prname) // trim(filename) // '.bin'
- open(unit = 27,file = trim(local_data_file),status='old',action='read', iostat = ios,form ='unformatted')
+ open(unit = 27,file = trim(local_data_file),status='old',&
+ action='read', iostat = ios,form ='unformatted')
if (ios /= 0) then
print *,'Error opening ',trim(local_data_file)
stop
@@ -172,28 +224,19 @@
! uses implicit conversion to real values
dat = data
- ! ibool file
- local_ibool_file = trim(prname) // 'ibool' // '.bin'
- open(unit = 28,file = trim(local_ibool_file),status='old',action='read', iostat = ios, form='unformatted')
- if (ios /= 0) then
- print *,'Error opening ',trim(local_data_file)
- stop
- endif
- read(28) ibool
- close(28)
- print *, trim(local_ibool_file)
+
! writes point coordinates and scalar value to mesh file
if (.not. HIGH_RESOLUTION_MESH) then
! writes out element corners only
call combine_vol_data_write_corners(nspec,nglob,ibool,mask_ibool,&
xstore,ystore,zstore,dat, &
- it,npp,prname,numpoin)
+ it,npp,prname_lp,numpoin)
else
! high resolution, all GLL points
call combine_vol_data_write_GLL_points(nspec,nglob,ibool,mask_ibool,&
xstore,ystore,zstore,dat,&
- it,npp,prname,numpoin)
+ it,npp,prname_lp,numpoin)
endif
print*,' points:',np,numpoin
@@ -218,9 +261,10 @@
iproc = node_list(it)
print *, 'Reading slice ', iproc
- write(prname,'(a,i6.6,a)') trim(indir)//'/proc',iproc,'_'
+ write(prname_lp,'(a,i6.6,a)') trim(LOCAL_PATH)//'/proc',iproc,'_'
- open(unit=27,file=prname(1:len_trim(prname))//'external_mesh.bin',status='old',action='read',form='unformatted')
+ open(unit=27,file=prname_lp(1:len_trim(prname_lp))//'external_mesh.bin',&
+ status='old',action='read',form='unformatted')
read(27) NSPEC_AB
read(27) NGLOB_AB
close(27)
@@ -232,8 +276,9 @@
allocate(num_ibool(NGLOB_AB))
! ibool file
- local_ibool_file = trim(prname) // 'ibool' // '.bin'
- open(unit = 28,file = trim(local_ibool_file),status='old',action='read', iostat = ios, form='unformatted')
+ local_ibool_file = trim(prname_lp) // 'ibool' // '.bin'
+ open(unit = 28,file = trim(local_ibool_file),status='old',&
+ action='read', iostat = ios, form='unformatted')
if (ios /= 0) then
print *,'Error opening ',trim(local_data_file)
stop
@@ -281,13 +326,14 @@
! counts total number of points and elements for external meshes in given slice list
- subroutine combine_vol_data_count_totals_ext_mesh(num_node,node_list,indir,npp,nee,HIGH_RESOLUTION_MESH)
+ subroutine combine_vol_data_count_totals_ext_mesh(num_node,node_list,LOCAL_PATH,&
+ npp,nee,HIGH_RESOLUTION_MESH)
implicit none
include 'constants.h'
integer,intent(in) :: num_node,node_list(300)
- character(len=256),intent(in) :: indir
+ character(len=256),intent(in) :: LOCAL_PATH
integer,intent(out) :: npp,nee
logical,intent(in) :: HIGH_RESOLUTION_MESH
@@ -297,15 +343,16 @@
integer :: NSPEC_AB, NGLOB_AB
integer :: it,iproc,npoint,nelement,ios,ispec
integer :: iglob1, iglob2, iglob3, iglob4, iglob5, iglob6, iglob7, iglob8
- character(len=256) :: prname
+ character(len=256) :: prname_lp
npp = 0
nee = 0
do it = 1, num_node
! gets number of elements and points for this slice
iproc = node_list(it)
- write(prname,'(a,i6.6,a)') trim(indir)//'/proc',iproc,'_'
- open(unit=27,file=prname(1:len_trim(prname))//'external_mesh.bin',status='old',action='read',form='unformatted')
+ write(prname_lp,'(a,i6.6,a)') trim(LOCAL_PATH)//'/proc',iproc,'_'
+ open(unit=27,file=prname_lp(1:len_trim(prname_lp))//'external_mesh.bin',&
+ status='old',action='read',form='unformatted')
read(27) NSPEC_AB
read(27) NGLOB_AB
close(27)
@@ -315,7 +362,8 @@
npp = npp + NGLOB_AB
! total number of elements
- ! each spectral elements gets subdivided by GLL points, which form (NGLLX-1)*(NGLLY-1)*(NGLLZ-1) sub-elements
+ ! each spectral elements gets subdivided by GLL points,
+ ! which form (NGLLX-1)*(NGLLY-1)*(NGLLZ-1) sub-elements
nelement = NSPEC_AB * (NGLLX-1) * (NGLLY-1) * (NGLLZ-1)
nee = nee + nelement
@@ -325,10 +373,11 @@
allocate(mask_ibool(NGLOB_AB))
! ibool file
- open(unit = 28,file = prname(1:len_trim(prname))//'ibool'//'.bin',status='old',action='read',&
+ open(unit = 28,file = prname_lp(1:len_trim(prname_lp))//'ibool'//'.bin',&
+ status='old',action='read',&
iostat = ios,form='unformatted')
if (ios /= 0) then
- print *,'Error opening: ',prname(1:len_trim(prname))//'ibool'//'.bin'
+ print *,'Error opening: ',prname_lp(1:len_trim(prname_lp))//'ibool'//'.bin'
stop
endif
read(28) ibool
@@ -375,7 +424,7 @@
subroutine combine_vol_data_write_corners(nspec,nglob,ibool,mask_ibool,&
xstore,ystore,zstore,dat,&
- it,npp,prname,numpoin)
+ it,npp,prname_lp,numpoin)
implicit none
include 'constants.h'
@@ -387,7 +436,7 @@
real,dimension(NGLLY,NGLLY,NGLLZ,nspec),intent(in) :: dat
integer:: it
integer :: npp,numpoin
- character(len=256) :: prname
+ character(len=256) :: prname_lp
!integer :: npoint,num_node
@@ -399,24 +448,24 @@
! corner locations
! reads in coordinate files
- local_file = trim(prname)//'x.bin'
- open(unit = 27,file = trim(prname)//'x.bin',status='old',action='read', iostat = ios,form ='unformatted')
+ local_file = trim(prname_lp)//'x.bin'
+ open(unit = 27,file = trim(prname_lp)//'x.bin',status='old',action='read', iostat = ios,form ='unformatted')
if (ios /= 0) then
print *,'Error opening ',trim(local_file)
stop
endif
read(27) xstore
close(27)
- local_file = trim(prname)//'y.bin'
- open(unit = 27,file = trim(prname)//'y.bin',status='old',action='read', iostat = ios,form ='unformatted')
+ local_file = trim(prname_lp)//'y.bin'
+ open(unit = 27,file = trim(prname_lp)//'y.bin',status='old',action='read', iostat = ios,form ='unformatted')
if (ios /= 0) then
print *,'Error opening ',trim(local_file)
stop
endif
read(27) ystore
close(27)
- local_file = trim(prname)//'z.bin'
- open(unit = 27,file = trim(prname)//'z.bin',status='old',action='read', iostat = ios,form ='unformatted')
+ local_file = trim(prname_lp)//'z.bin'
+ open(unit = 27,file = trim(prname_lp)//'z.bin',status='old',action='read', iostat = ios,form ='unformatted')
if (ios /= 0) then
print *,'Error opening ',trim(local_file)
stop
@@ -541,7 +590,7 @@
subroutine combine_vol_data_write_GLL_points(nspec,nglob,ibool,mask_ibool,&
xstore,ystore,zstore,dat,&
- it,npp,prname,numpoin)
+ it,npp,prname_lp,numpoin)
implicit none
include 'constants.h'
@@ -552,7 +601,7 @@
real(kind=CUSTOM_REAL),dimension(nglob) :: xstore, ystore, zstore
real,dimension(NGLLY,NGLLY,NGLLZ,nspec),intent(in) :: dat
integer:: it,npp,numpoin
- character(len=256) :: prname
+ character(len=256) :: prname_lp
! local parameters
real :: x, y, z
@@ -566,24 +615,27 @@
endif
! reads in coordinate files
- local_file = trim(prname)//'x.bin'
- open(unit = 27,file = trim(prname)//'x.bin',status='old',action='read', iostat = ios,form ='unformatted')
+ local_file = trim(prname_lp)//'x.bin'
+ open(unit = 27,file = trim(prname_lp)//'x.bin',status='old',&
+ action='read', iostat = ios,form ='unformatted')
if (ios /= 0) then
print *,'Error opening ',trim(local_file)
stop
endif
read(27) xstore
close(27)
- local_file = trim(prname)//'y.bin'
- open(unit = 27,file = trim(prname)//'y.bin',status='old',action='read', iostat = ios,form ='unformatted')
+ local_file = trim(prname_lp)//'y.bin'
+ open(unit = 27,file = trim(prname_lp)//'y.bin',status='old',&
+ action='read', iostat = ios,form ='unformatted')
if (ios /= 0) then
print *,'Error opening ',trim(local_file)
stop
endif
read(27) ystore
close(27)
- local_file = trim(prname)//'z.bin'
- open(unit = 27,file = trim(prname)//'z.bin',status='old',action='read', iostat = ios,form ='unformatted')
+ local_file = trim(prname_lp)//'z.bin'
+ open(unit = 27,file = trim(prname_lp)//'z.bin',status='old',&
+ action='read', iostat = ios,form ='unformatted')
if (ios /= 0) then
print *,'Error opening ',trim(local_file)
stop
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -56,19 +56,46 @@
use specfem_par_acoustic
use specfem_par_elastic
use specfem_par_poroelastic
+ use PML_par
+ use PML_par_acoustic
implicit none
-
+ ! local parameters
integer:: iphase
logical:: phase_is_inner
-
+
+ ! time marching potentials
+ if(PML) call PML_acoustic_time_march(NSPEC_AB,NGLOB_AB,ibool,&
+ potential_acoustic,potential_dot_acoustic,&
+ deltat,deltatsqover2,deltatover2,&
+ num_PML_ispec,PML_ispec,PML_damping_d,&
+ chi1,chi2,chi2_t,chi3,chi4,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot,&
+ iglob_is_PML_interface,PML_mask_ibool,&
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh,&
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh,NPROC,&
+ ispec_is_acoustic)
+
! enforces free surface (zeroes potentials at free surface)
- call compute_forces_acoustic_enforce_free_surface(NSPEC_AB,NGLOB_AB, &
+ call acoustic_enforce_free_surface(NSPEC_AB,NGLOB_AB, &
potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
ibool, &
free_surface_ijk,free_surface_ispec, &
num_free_surface_faces, &
ispec_is_acoustic)
+ if(PML) call PML_acoustic_enforce_free_srfc(NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
+ ibool,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces, &
+ ispec_is_acoustic, &
+ num_PML_ispec,PML_ispec,&
+ chi1,chi2,chi2_t,chi3,chi4,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi2_t_dot_dot,&
+ chi3_dot_dot,chi4_dot_dot)
+
! distinguishes two runs: for points on MPI interfaces, and points within the partitions
do iphase=1,2
@@ -80,30 +107,68 @@
endif
! acoustic pressure term
- call compute_forces_acoustic_pressure( phase_is_inner, NSPEC_AB,NGLOB_AB, &
- potential_acoustic,potential_dot_dot_acoustic, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- rhostore,jacobian,ibool, &
- ispec_is_inner, &
- ispec_is_acoustic)
+ call acoustic_pressure( phase_is_inner, NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_dot_acoustic, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ rhostore,jacobian,ibool, &
+ ispec_is_inner,ispec_is_acoustic)
+
+
+ if(PML) then
+ call compute_forces_acoustic_PML(NSPEC_AB,NGLOB_AB, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ rhostore,ispec_is_acoustic,potential_acoustic, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,jacobian,&
+ wxgll,wygll,wzgll,&
+ PML_damping_dprime,num_PML_ispec,&
+ PML_ispec,PML_normal,&
+ chi1_dot_dot,chi2_t_dot_dot,&
+ chi3_dot_dot,chi4_dot_dot)
+ ! couples potential_dot_dot with PML interface contributions
+ call PML_acoustic_interface_coupling(phase_is_inner,NSPEC_AB,NGLOB_AB,&
+ potential_dot_dot_acoustic,&
+ ibool,ispec_is_inner,ispec_is_acoustic,&
+ num_PML_ispec,PML_ispec,iglob_is_PML_interface,&
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
+
+ endif
+
! absorbing boundaries
- if(ABSORBING_CONDITIONS) &
- call compute_forces_acoustic_absorbing_boundaries(NSPEC_AB,NGLOB_AB, &
- potential_dot_dot_acoustic,potential_dot_acoustic, &
- ibool,ispec_is_inner,phase_is_inner, &
- abs_boundary_jacobian2Dw, &
- abs_boundary_ijk,abs_boundary_ispec, &
- num_abs_boundary_faces, &
- rhostore,kappastore, &
- ispec_is_acoustic)
+ if(ABSORBING_CONDITIONS) then
+ if( PML .and. PML_USE_SOMMERFELD ) then
+ ! adds a Sommerfeld condition on the domain's absorbing boundaries
+ call PML_acoustic_abs_boundaries(phase_is_inner,NSPEC_AB,NGLOB_AB,&
+ abs_boundary_jacobian2Dw,abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces, &
+ kappastore,ibool,ispec_is_inner, &
+ rhostore,ispec_is_acoustic,&
+ potential_dot_acoustic,potential_dot_dot_acoustic,&
+ num_PML_ispec,PML_ispec,ispec_is_PML_inum,&
+ chi1_dot,chi2_t,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
+ else
+ call acoustic_absorbing_boundaries(NSPEC_AB,NGLOB_AB, &
+ potential_dot_dot_acoustic,potential_dot_acoustic, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ abs_boundary_jacobian2Dw, &
+ abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces, &
+ rhostore,kappastore, &
+ ispec_is_acoustic)
+ endif
+ endif
+
! elastic coupling
if(ELASTIC_SIMULATION ) &
- call compute_forces_acoustic_coupling_elastic(NSPEC_AB,NGLOB_AB, &
+ call acoustic_coupling_elastic(NSPEC_AB,NGLOB_AB, &
ibool,displ,potential_dot_dot_acoustic, &
num_coupling_ac_el_faces, &
coupling_ac_el_ispec,coupling_ac_el_ijk, &
@@ -113,46 +178,62 @@
! poroelastic coupling
if(POROELASTIC_SIMULATION ) &
- call compute_forces_acoustic_coupling_poroelastic()
+ call acoustic_coupling_poroelastic()
! sources
- call compute_forces_acoustic_sources(NSPEC_AB,NGLOB_AB,potential_dot_dot_acoustic, &
- ibool,ispec_is_inner,phase_is_inner, &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
- xi_source,eta_source,gamma_source, &
- hdur,hdur_gaussian,t_cmt,dt,stf,t0, &
- sourcearrays,kappastore, &
- ispec_is_acoustic)
+ call acoustic_sources(NSPEC_AB,NGLOB_AB,potential_dot_dot_acoustic, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
+ xi_source,eta_source,gamma_source, &
+ hdur,hdur_gaussian,t_cmt,dt,stf,t0, &
+ sourcearrays,kappastore, &
+ ispec_is_acoustic)
! assemble all the contributions between slices using MPI
if( phase_is_inner .eqv. .false. ) then
! sends potential_dot_dot_acoustic values to corresponding MPI interface neighbors (non-blocking)
call assemble_MPI_scalar_ext_mesh_s(NPROC,NGLOB_AB,potential_dot_dot_acoustic, &
- buffer_send_scalar_ext_mesh,buffer_recv_scalar_ext_mesh, &
- num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
- my_neighbours_ext_mesh, &
- request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
+ buffer_send_scalar_ext_mesh,buffer_recv_scalar_ext_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh, &
+ request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
else
! waits for send/receive requests to be completed and assembles values
call assemble_MPI_scalar_ext_mesh_w(NPROC,NGLOB_AB,potential_dot_dot_acoustic, &
- buffer_recv_scalar_ext_mesh,num_interfaces_ext_mesh,&
- max_nibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
- request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
+ buffer_recv_scalar_ext_mesh,num_interfaces_ext_mesh,&
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
endif
+
enddo
-! update pressure with mass
+ ! divides pressure with mass matrix
potential_dot_dot_acoustic(:) = potential_dot_dot_acoustic(:) * rmass_acoustic(:)
+ if(PML) then
+ ! divides local contributions with mass term
+ call PML_acoustic_mass_update(NSPEC_AB,NGLOB_AB,&
+ ispec_is_acoustic,rmass_acoustic,ibool,&
+ num_PML_ispec,PML_ispec,&
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot)
+
+ ! Newark time scheme corrector terms
+ call PML_acoustic_time_corrector(NSPEC_AB,ispec_is_acoustic,deltatover2,&
+ num_PML_ispec,PML_ispec,PML_damping_d,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot)
+ endif
+
+
! update velocity
! note: Newark finite-difference time scheme with acoustic domains:
! (see e.g. Hughes, 1987; Chaljub et al., 2003)
!
! chi(t+delta_t) = chi(t) + delta_t chi_dot(t) + 1/2 delta_t**2 chi_dot_dot(t)
-! chi_dot(t+delta_t) = chi_dot(t) + 1/2 delta_t chi_dot_dot(t) + 1/2 delta_t chi_dot_dot(t+delta_t)
+! chi_dot(t+delta_t) = chi_dot(t) + 1/2 delta_t chi_dot_dot(t) + 1/2 DELTA_T CHI_DOT_DOT( T + DELTA_T )
! chi_dot_dot(t+delta_t) = 1/M_acoustic( -K_acoustic chi(t+delta) + B_acoustic u(t+delta_t) + f(t+delta_t) )
!
! where
@@ -165,14 +246,40 @@
! updates the chi_dot term which requires chi_dot_dot(t+delta)
potential_dot_acoustic(:) = potential_dot_acoustic(:) + deltatover2*potential_dot_dot_acoustic(:)
+ ! updates potential_dot_acoustic and potential_dot_dot_acoustic inside PML region for plotting seismograms/movies
+ if(PML) call PML_acoustic_update_potentials(NGLOB_AB,NSPEC_AB, &
+ ibool,ispec_is_acoustic, &
+ potential_dot_acoustic,potential_dot_dot_acoustic,&
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh,NPROC,&
+ num_PML_ispec,PML_ispec,iglob_is_PML_interface,&
+ PML_mask_ibool,PML_damping_d,&
+ chi1,chi2,chi2_t,chi3,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
+
+
! enforces free surface (zeroes potentials at free surface)
- call compute_forces_acoustic_enforce_free_surface(NSPEC_AB,NGLOB_AB, &
+ call acoustic_enforce_free_surface(NSPEC_AB,NGLOB_AB, &
potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
ibool, &
free_surface_ijk,free_surface_ispec, &
num_free_surface_faces, &
ispec_is_acoustic)
+ if(PML) call PML_acoustic_enforce_free_srfc(NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
+ ibool,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces, &
+ ispec_is_acoustic, &
+ num_PML_ispec,PML_ispec,&
+ chi1,chi2,chi2_t,chi3,chi4,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi2_t_dot_dot,&
+ chi3_dot_dot,chi4_dot_dot)
+
+
end subroutine compute_forces_acoustic
@@ -180,25 +287,24 @@
!-------------------------------------------------------------------------------------------------
!
-subroutine compute_forces_acoustic_pressure( phase_is_inner, NSPEC_AB,NGLOB_AB, &
- potential_acoustic,potential_dot_dot_acoustic, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- rhostore,jacobian,ibool, &
- ispec_is_inner, &
- ispec_is_acoustic )
+subroutine acoustic_pressure( phase_is_inner, NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_dot_acoustic, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ rhostore,jacobian,ibool, &
+ ispec_is_inner,ispec_is_acoustic )
! compute forces for the acoustic elements
!
! note that pressure is defined as:
! p = - Chi_dot_dot
!
+ use constants,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,TINYVAL_SNGL
+ use PML_par,only:PML,ispec_is_PML_inum
implicit none
-
- include "constants.h"
-
+ !include "constants.h"
integer :: NSPEC_AB,NGLOB_AB
! acoustic potentials
@@ -228,6 +334,7 @@
logical, dimension(NSPEC_AB) :: ispec_is_acoustic
! local variables
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: chi_elem
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: temp1,temp2,temp3
real(kind=CUSTOM_REAL) temp1l,temp2l,temp3l
@@ -235,21 +342,37 @@
real(kind=CUSTOM_REAL) dpotentialdxl,dpotentialdyl,dpotentialdzl
real(kind=CUSTOM_REAL) rho_invl
- integer :: ispec,iglob
- integer :: i,j,k,l
+ integer :: ispec,iglob,i,j,k,l
-
! loop over spectral elements
do ispec = 1,NSPEC_AB
- if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+ if ( (ispec_is_inner(ispec) .eqv. phase_is_inner) ) then
+ ! only elements outside PML, inside "regular" domain
+ if( PML ) then
+ if( ispec_is_PML_inum(ispec) > 0 ) then
+ cycle
+ endif
+ endif
+
if( ispec_is_acoustic(ispec) ) then
-
+
+ ! gets values for element
do k=1,NGLLZ
do j=1,NGLLY
do i=1,NGLLX
+ chi_elem(i,j,k) = potential_acoustic(ibool(i,j,k,ispec))
+ enddo
+ enddo
+ enddo
+ ! would check if anything to do, but might lower accuracy of computation
+ !if( maxval( abs( chi_elem ) ) < TINYVAL_SNGL ) cycle
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
! density (reciproc)
rho_invl = 1.0_CUSTOM_REAL / rhostore(i,j,k,ispec)
@@ -260,9 +383,12 @@
temp2l = 0._CUSTOM_REAL
temp3l = 0._CUSTOM_REAL
do l = 1,NGLLX
- temp1l = temp1l + potential_acoustic(ibool(l,j,k,ispec))*hprime_xx(i,l)
- temp2l = temp2l + potential_acoustic(ibool(i,l,k,ispec))*hprime_yy(j,l)
- temp3l = temp3l + potential_acoustic(ibool(i,j,l,ispec))*hprime_zz(k,l)
+ !temp1l = temp1l + potential_acoustic(ibool(l,j,k,ispec))*hprime_xx(i,l)
+ !temp2l = temp2l + potential_acoustic(ibool(i,l,k,ispec))*hprime_yy(j,l)
+ !temp3l = temp3l + potential_acoustic(ibool(i,j,l,ispec))*hprime_zz(k,l)
+ temp1l = temp1l + chi_elem(l,j,k)*hprime_xx(i,l)
+ temp2l = temp2l + chi_elem(i,l,k)*hprime_yy(j,l)
+ temp3l = temp3l + chi_elem(i,j,l)*hprime_zz(k,l)
enddo
! get derivatives of potential with respect to x, y and z
@@ -322,16 +448,18 @@
endif ! end of test if acoustic element
endif ! ispec_is_inner
+
enddo ! end of loop over all spectral elements
-end subroutine compute_forces_acoustic_pressure
+end subroutine acoustic_pressure
!
!-------------------------------------------------------------------------------------------------
!
-subroutine compute_forces_acoustic_absorbing_boundaries(NSPEC_AB,NGLOB_AB, &
+
+subroutine acoustic_absorbing_boundaries(NSPEC_AB,NGLOB_AB, &
potential_dot_dot_acoustic,potential_dot_acoustic, &
ibool,ispec_is_inner,phase_is_inner, &
abs_boundary_jacobian2Dw, &
@@ -368,7 +496,7 @@
real(kind=CUSTOM_REAL) :: rhol,cpl,jacobianw !weight,jacobianl
integer :: ispec,iglob,i,j,k,iface,igll
-! absorbs absorbing-boundary surface using Stacey condition (Clayton & Enquist)
+! absorbs absorbing-boundary surface using Sommerfeld condition (vanishing field in the outer-space)
do iface=1,num_abs_boundary_faces
ispec = abs_boundary_ispec(iface)
@@ -405,13 +533,13 @@
endif ! ispec_is_inner
enddo ! num_abs_boundary_faces
-end subroutine compute_forces_acoustic_absorbing_boundaries
+end subroutine acoustic_absorbing_boundaries
!
!-------------------------------------------------------------------------------------------------
!
-subroutine compute_forces_acoustic_coupling_elastic(NSPEC_AB,NGLOB_AB, &
+subroutine acoustic_coupling_elastic(NSPEC_AB,NGLOB_AB, &
ibool,displ,potential_dot_dot_acoustic, &
num_coupling_ac_el_faces, &
coupling_ac_el_ispec,coupling_ac_el_ijk, &
@@ -506,24 +634,24 @@
enddo ! iface
-end subroutine compute_forces_acoustic_coupling_elastic
+end subroutine acoustic_coupling_elastic
!
!-------------------------------------------------------------------------------------------------
!
-subroutine compute_forces_acoustic_coupling_poroelastic()
+subroutine acoustic_coupling_poroelastic()
implicit none
stop 'not yet implemented'
-end subroutine compute_forces_acoustic_coupling_poroelastic
+end subroutine acoustic_coupling_poroelastic
!
!-------------------------------------------------------------------------------------------------
!
-subroutine compute_forces_acoustic_sources(NSPEC_AB,NGLOB_AB,potential_dot_dot_acoustic, &
+subroutine acoustic_sources(NSPEC_AB,NGLOB_AB,potential_dot_dot_acoustic, &
ibool,ispec_is_inner,phase_is_inner, &
NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
xi_source,eta_source,gamma_source, &
@@ -654,13 +782,13 @@
enddo ! NSOURCES
-end subroutine compute_forces_acoustic_sources
+end subroutine acoustic_sources
!
!-------------------------------------------------------------------------------------------------
!
-subroutine compute_forces_acoustic_enforce_free_surface(NSPEC_AB,NGLOB_AB, &
+subroutine acoustic_enforce_free_surface(NSPEC_AB,NGLOB_AB, &
potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
ibool, &
free_surface_ijk,free_surface_ispec, &
@@ -709,4 +837,5 @@
enddo
-end subroutine compute_forces_acoustic_enforce_free_surface
+end subroutine acoustic_enforce_free_surface
+
Added: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic_PML.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic_PML.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_acoustic_PML.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -0,0 +1,1186 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+subroutine compute_forces_acoustic_PML(NSPEC_AB,NGLOB_AB, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ rhostore,ispec_is_acoustic,potential_acoustic, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,jacobian,&
+ wxgll,wygll,wzgll,&
+ PML_damping_dprime,num_PML_ispec,&
+ PML_ispec,PML_normal,&
+ chi1_dot_dot,chi2_t_dot_dot,&
+ chi3_dot_dot,chi4_dot_dot)
+
+ use constants,only: NGLLX,NGLLY,NGLLZ,NDIM,TINYVAL_SNGL,CUSTOM_REAL
+ implicit none
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+ ! potential
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_acoustic
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+ ! split-potentials
+ integer :: num_PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ PML_damping_dprime
+ integer,dimension(num_PML_ispec):: PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NDIM,num_PML_ispec):: PML_normal
+
+ ! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rhostore
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,jacobian
+
+ ! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+ double precision, dimension(NGLLX) :: wxgll
+ double precision, dimension(NGLLY) :: wygll
+ double precision, dimension(NGLLZ) :: wzgll
+
+ ! local parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: chi_elem
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: temp1_n,temp2_n,temp3_n
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: temp1_p,temp2_p,temp3_p
+ real(kind=CUSTOM_REAL) :: rho_invl
+ real(kind=CUSTOM_REAL) :: temp1l,temp2l,temp3l
+ real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) :: dpotentialdxl,dpotentialdyl,dpotentialdzl
+ real(kind=CUSTOM_REAL) :: dpotentialdxl_n,dpotentialdyl_n,dpotentialdzl_n
+ real(kind=CUSTOM_REAL) :: dpotentialdxl_p,dpotentialdyl_p,dpotentialdzl_p
+ real(kind=CUSTOM_REAL) :: nx,ny,nz,grad_n,dprime,weights
+ integer :: ispec,iglob,i,j,k,l,ispecPML
+
+ ! loops over all PML elements
+ do ispecPML=1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! checks with MPI interface flag
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ ! only acoustic part
+ if( ispec_is_acoustic(ispec) ) then
+
+ ! gets values for element
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ chi_elem(i,j,k) = potential_acoustic(ibool(i,j,k,ispec))
+ enddo
+ enddo
+ enddo
+ ! checks if anything to do
+ if( maxval( abs( chi_elem ) ) < TINYVAL_SNGL ) cycle
+
+ ! PML normal
+ nx = PML_normal(1,ispecPML)
+ ny = PML_normal(2,ispecPML)
+ nz = PML_normal(3,ispecPML)
+
+ ! calculates terms:
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ ! density (reciproc)
+ rho_invl = 1.0_CUSTOM_REAL / rhostore(i,j,k,ispec)
+
+ ! derivative along x, y, z
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the loops because NGLLX == NGLLY == NGLLZ
+ temp1l = 0._CUSTOM_REAL
+ temp2l = 0._CUSTOM_REAL
+ temp3l = 0._CUSTOM_REAL
+
+ do l = 1,NGLLX
+ temp1l = temp1l + chi_elem(l,j,k)*hprime_xx(i,l)
+ temp2l = temp2l + chi_elem(i,l,k)*hprime_yy(j,l)
+ temp3l = temp3l + chi_elem(i,j,l)*hprime_zz(k,l)
+ enddo
+
+ ! get derivatives of potential with respect to x, y and z
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+ jacobianl = jacobian(i,j,k,ispec)
+
+ ! derivatives of potential
+ ! \npartial_i \chi
+ dpotentialdxl = xixl*temp1l + etaxl*temp2l + gammaxl*temp3l
+ dpotentialdyl = xiyl*temp1l + etayl*temp2l + gammayl*temp3l
+ dpotentialdzl = xizl*temp1l + etazl*temp2l + gammazl*temp3l
+
+ ! splits derivatives of potential into normal and parallel components
+ ! dpotential normal to PML plane
+ ! \hat{n} \partial_n \chi
+ grad_n = dpotentialdxl*nx + dpotentialdyl*ny + dpotentialdzl*nz
+ dpotentialdxl_n = nx * grad_n
+ dpotentialdyl_n = ny * grad_n
+ dpotentialdzl_n = nz * grad_n
+
+
+ ! dpotential parallel to plane
+ ! \nabla^{parallel} \chi
+ dpotentialdxl_p = dpotentialdxl - dpotentialdxl_n
+ dpotentialdyl_p = dpotentialdyl - dpotentialdyl_n
+ dpotentialdzl_p = dpotentialdzl - dpotentialdzl_n
+
+ ! normal incidence term: ( 1/rho J \hat{n} \partial_n \chi )
+ ! (note: we can add two weights at this point to save some computations )
+ temp1_n(i,j,k) = rho_invl * jacobianl * dpotentialdxl_n
+ temp2_n(i,j,k) = rho_invl * jacobianl * dpotentialdyl_n
+ temp3_n(i,j,k) = rho_invl * jacobianl * dpotentialdzl_n
+
+ ! parallel incidence 1/rho J \nabla^{parallel} \chi
+ temp1_p(i,j,k) = rho_invl * jacobianl * dpotentialdxl_p
+ temp2_p(i,j,k) = rho_invl * jacobianl * dpotentialdyl_p
+ temp3_p(i,j,k) = rho_invl * jacobianl * dpotentialdzl_p
+ enddo
+ enddo
+ enddo
+
+ ! second double-loop over GLL to compute all the terms
+ do k = 1,NGLLZ
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,k,ispec)
+
+ ! 1. split term:
+ !-----------------
+ ! normal derivative of w dotted with normal dpotential
+ ! ( \hat{n} \nabla_n w ) \cdot ( 1/rho \hat{n} \nabla_n \chi )
+ temp1l = 0._CUSTOM_REAL
+ temp2l = 0._CUSTOM_REAL
+ temp3l = 0._CUSTOM_REAL
+ do l=1,NGLLX
+ ! derivatives
+ xixl = xix(l,j,k,ispec)
+ xiyl = xiy(l,j,k,ispec)
+ xizl = xiz(l,j,k,ispec)
+ ! note: hprimewgll_xx(l,i) = hprime_xx(l,i)*wxgll(l)
+ ! don't confuse order of indices in hprime_xx: they are l and i
+ ! -> lagrangian (hprime) function i evaluated at point xi_{ l }
+ temp1l = temp1l + hprimewgll_xx(l,i) &
+ *(nx*temp1_n(l,j,k)+ny*temp2_n(l,j,k)+nz*temp3_n(l,j,k)) &
+ *(nx*xixl+ny*xiyl+nz*xizl)
+
+ etaxl = etax(i,l,k,ispec)
+ etayl = etay(i,l,k,ispec)
+ etazl = etaz(i,l,k,ispec)
+
+ temp2l = temp2l + hprimewgll_yy(l,j) &
+ *(nx*temp1_n(i,l,k)+ny*temp2_n(i,l,k)+nz*temp3_n(i,l,k)) &
+ *(nx*etaxl+ny*etayl+nz*etazl)
+
+ gammaxl = gammax(i,j,l,ispec)
+ gammayl = gammay(i,j,l,ispec)
+ gammazl = gammaz(i,j,l,ispec)
+
+ temp3l = temp3l + hprimewgll_zz(l,k) &
+ *(nx*temp1_n(i,j,l)+ny*temp2_n(i,j,l)+nz*temp3_n(i,j,l)) &
+ *(nx*gammaxl+ny*gammayl+nz*gammazl)
+ enddo
+ temp1l = temp1l * wgllwgll_yz(j,k)
+ temp2l = temp2l * wgllwgll_xz(i,k)
+ temp3l = temp3l * wgllwgll_xy(i,j)
+
+ chi1_dot_dot(i,j,k,ispecPML) = - (temp1l + temp2l + temp3l)
+
+ ! 2. split term:
+ !-----------------
+ ! dprime times normal w dotted with normal dpotential
+ ! w dprime \hat{n} \cdot ( 1/rho \hat{n} \nabla_n \chi )
+
+ weights = wxgll(i)*wygll(j)*wzgll(k)
+
+ temp1l = nx*temp1_n(i,j,k)*weights
+ temp2l = ny*temp2_n(i,j,k)*weights
+ temp3l = nz*temp3_n(i,j,k)*weights
+
+ dprime = PML_damping_dprime(i,j,k,ispecPML)
+
+ ! contribution has negative sign?
+ chi2_t_dot_dot(i,j,k,ispecPML) = - dprime*(temp1l + temp2l + temp3l )
+
+
+ ! 3. split term:
+ !-----------------
+ ! parallel derivative of w dotted with normal dpotential
+ ! ( \nabla^{parallel} w ) \cdot ( 1/rho \hat{n} \nabla_n \chi )
+ ! and
+ ! normal derivative of w dotted with parallel dpotential
+ ! ( \hat{n} \nabla_n w ) \cdot ( 1/rho \nabla_{parallel} \chi )
+ temp1l = 0._CUSTOM_REAL
+ temp2l = 0._CUSTOM_REAL
+ temp3l = 0._CUSTOM_REAL
+ do l=1,NGLLX
+ ! derivatives
+ xixl = xix(l,j,k,ispec)
+ xiyl = xiy(l,j,k,ispec)
+ xizl = xiz(l,j,k,ispec)
+ etaxl = etax(i,l,k,ispec)
+ etayl = etay(i,l,k,ispec)
+ etazl = etaz(i,l,k,ispec)
+ gammaxl = gammax(i,j,l,ispec)
+ gammayl = gammay(i,j,l,ispec)
+ gammazl = gammaz(i,j,l,ispec)
+
+ ! normal derivative of w dotted with parallel dpotential
+ temp1l = temp1l + hprimewgll_xx(l,i) &
+ *(nx*temp1_p(l,j,k)+ny*temp2_p(l,j,k)+nz*temp3_p(l,j,k)) &
+ *(nx*xixl+ny*xiyl+nz*xizl)
+
+ temp2l = temp2l + hprimewgll_yy(l,j) &
+ *(nx*temp1_p(i,l,k)+ny*temp2_p(i,l,k)+nz*temp3_p(i,l,k)) &
+ *(nx*etaxl+ny*etayl+nz*etazl)
+
+ temp3l = temp3l + hprimewgll_zz(l,k) &
+ *(nx*temp1_p(i,j,l)+ny*temp2_p(i,j,l)+nz*temp3_p(i,j,l)) &
+ *(nx*gammaxl+ny*gammayl+nz*gammazl)
+
+
+ ! parallel derivative of w dotted with normal dpotential
+ temp1l = temp1l + hprimewgll_xx(l,i) &
+ *( (xixl - nx*(nx*xixl+ny*xiyl+nz*xizl))*temp1_n(l,j,k) &
+ +(xiyl - ny*(nx*xixl+ny*xiyl+nz*xizl))*temp2_n(l,j,k) &
+ +(xizl - nz*(nx*xixl+ny*xiyl+nz*xizl))*temp3_n(l,j,k) )
+
+ temp2l = temp2l + hprimewgll_yy(l,j) &
+ *( (etaxl - nx*(nx*etaxl+ny*etayl+nz*etazl))*temp1_n(i,l,k) &
+ +(etayl - ny*(nx*etaxl+ny*etayl+nz*etazl))*temp2_n(i,l,k) &
+ +(etazl - nz*(nx*etaxl+ny*etayl+nz*etazl))*temp3_n(i,l,k) )
+
+ temp3l = temp3l + hprimewgll_zz(l,k) &
+ *( (gammaxl - nx*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp1_n(i,j,l) &
+ +(gammayl - ny*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp2_n(i,j,l) &
+ +(gammazl - nz*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp3_n(i,j,l) )
+ enddo
+ temp1l = temp1l * wgllwgll_yz(j,k)
+ temp2l = temp2l * wgllwgll_xz(i,k)
+ temp3l = temp3l * wgllwgll_xy(i,j)
+
+ chi3_dot_dot(i,j,k,ispecPML) = - (temp1l + temp2l + temp3l)
+
+
+ ! 4. split term:
+ !-----------------
+ ! parallel derivative of w dotted with parallel dpotential
+ ! ( \nabla_{parallel} w ) \cdot ( 1/rho \nabla_{parallel} \chi )
+ temp1l = 0._CUSTOM_REAL
+ temp2l = 0._CUSTOM_REAL
+ temp3l = 0._CUSTOM_REAL
+ do l=1,NGLLX
+ ! derivatives
+ xixl = xix(l,j,k,ispec)
+ xiyl = xiy(l,j,k,ispec)
+ xizl = xiz(l,j,k,ispec)
+ etaxl = etax(i,l,k,ispec)
+ etayl = etay(i,l,k,ispec)
+ etazl = etaz(i,l,k,ispec)
+ gammaxl = gammax(i,j,l,ispec)
+ gammayl = gammay(i,j,l,ispec)
+ gammazl = gammaz(i,j,l,ispec)
+
+ temp1l = temp1l + hprimewgll_xx(l,i) &
+ *( (xixl - nx*(nx*xixl+ny*xiyl+nz*xizl))*temp1_p(l,j,k) &
+ +(xiyl - ny*(nx*xixl+ny*xiyl+nz*xizl))*temp2_p(l,j,k) &
+ +(xizl - nz*(nx*xixl+ny*xiyl+nz*xizl))*temp3_p(l,j,k) )
+
+ temp2l = temp2l + hprimewgll_yy(l,j) &
+ *( (etaxl - nx*(nx*etaxl+ny*etayl+nz*etazl))*temp1_p(i,l,k) &
+ +(etayl - ny*(nx*etaxl+ny*etayl+nz*etazl))*temp2_p(i,l,k) &
+ +(etazl - nz*(nx*etaxl+ny*etayl+nz*etazl))*temp3_p(i,l,k) )
+
+ temp3l = temp3l + hprimewgll_zz(l,k) &
+ *( (gammaxl - nx*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp1_p(i,j,l) &
+ +(gammayl - ny*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp2_p(i,j,l) &
+ +(gammazl - nz*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp3_p(i,j,l) )
+ enddo
+ temp1l = temp1l * wgllwgll_yz(j,k)
+ temp2l = temp2l * wgllwgll_xz(i,k)
+ temp3l = temp3l * wgllwgll_xy(i,j)
+
+ chi4_dot_dot(i,j,k,ispecPML) = - (temp1l + temp2l + temp3l)
+
+ enddo
+ enddo
+ enddo
+
+ ! note: the surface integral expressions would be needed for points on a free surface
+ !
+ ! BUT at the free surface: potentials are set to zero (zero pressure condition),
+ ! thus the additional surface term contributions would be zeored again.
+
+ endif ! ispec_is_acoustic
+ endif ! ispec_is_inner
+ enddo ! num_PML_ispec
+
+end subroutine compute_forces_acoustic_PML
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_acoustic_abs_boundaries(phase_is_inner,NSPEC_AB,NGLOB_AB,&
+ abs_boundary_jacobian2Dw,abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces, &
+ kappastore,ibool,ispec_is_inner, &
+ rhostore,ispec_is_acoustic,&
+ potential_dot_acoustic,potential_dot_dot_acoustic,&
+ num_PML_ispec,PML_ispec,ispec_is_PML_inum,&
+ chi1_dot,chi2_t,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
+
+! absorbs absorbing-boundary surface using Sommerfeld condition (vanishing field in the outer-space)
+
+ use constants,only: NGLLX,NGLLY,NGLLZ,NGLLSQUARE,CUSTOM_REAL
+ implicit none
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+ ! split-potentials
+ integer :: num_PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot,chi2_t,chi2_t_dot,chi3_dot,chi4_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot
+ integer,dimension(num_PML_ispec):: PML_ispec
+ integer,dimension(NSPEC_AB):: ispec_is_PML_inum
+
+ ! potentials
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic,&
+ potential_dot_acoustic
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+ ! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rhostore,kappastore
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+ ! absorbing boundary surface
+ integer :: num_abs_boundary_faces
+ real(kind=CUSTOM_REAL) :: abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ispec(num_abs_boundary_faces)
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: rhol,cpl,jacobianw,temp
+ integer :: ispec,iglob,i,j,k,iface,igll,ispecPML
+
+ ! absorbs absorbing-boundary surface using Sommerfeld condition (vanishing field in the outer-space)
+ do iface=1,num_abs_boundary_faces
+
+ ispec = abs_boundary_ispec(iface)
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_acoustic(ispec) .and. ispec_is_PML_inum(ispec) > 0 ) then
+
+ do ispecPML=1,num_PML_ispec
+
+ if( PML_ispec(ispecPML) == ispec) then
+
+ ! reference gll points on boundary face
+ do igll = 1,NGLLSQUARE
+
+ ! gets local indices for GLL point
+ i = abs_boundary_ijk(1,igll,iface)
+ j = abs_boundary_ijk(2,igll,iface)
+ k = abs_boundary_ijk(3,igll,iface)
+
+ ! gets global index
+ iglob=ibool(i,j,k,ispec)
+
+ ! determines bulk sound speed
+ rhol = rhostore(i,j,k,ispec)
+ cpl = sqrt( kappastore(i,j,k,ispec) / rhol )
+
+ ! gets associated, weighted jacobian
+ jacobianw = abs_boundary_jacobian2Dw(igll,iface)
+
+ temp = jacobianw / cpl / rhol
+
+ ! Sommerfeld condition
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - potential_dot_acoustic(iglob) * jacobianw / cpl / rhol
+ ! split-potentials
+ chi1_dot_dot(i,j,k,ispecPML) = chi1_dot_dot(i,j,k,ispecPML) - chi1_dot(i,j,k,ispecPML) * temp
+ chi3_dot_dot(i,j,k,ispecPML) = chi3_dot_dot(i,j,k,ispecPML) - chi3_dot(i,j,k,ispecPML) * temp
+ chi4_dot_dot(i,j,k,ispecPML) = chi4_dot_dot(i,j,k,ispecPML) - chi4_dot(i,j,k,ispecPML) * temp
+
+ ! chi2 potential?
+ chi2_t_dot(i,j,k,ispecPML) = chi2_t_dot(i,j,k,ispecPML) - chi2_t(i,j,k,ispecPML) * temp
+
+ enddo
+ endif
+ enddo
+ endif ! ispec_is_acoustic
+ endif ! ispec_is_inner
+ enddo ! num_abs_boundary_faces
+
+end subroutine PML_acoustic_abs_boundaries
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_acoustic_interface_coupling(phase_is_inner,NSPEC_AB,NGLOB_AB,&
+ potential_dot_dot_acoustic,&
+ ibool,ispec_is_inner,ispec_is_acoustic,&
+ num_PML_ispec,PML_ispec,iglob_is_PML_interface,&
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
+
+! couples potential_dot_dot with PML interface contributions
+
+ use constants,only: NGLLX,NGLLY,NGLLZ,CUSTOM_REAL
+ implicit none
+
+ integer :: NGLOB_AB,NSPEC_AB
+
+ ! split-potentials
+ integer :: num_PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot
+ integer,dimension(num_PML_ispec):: PML_ispec
+ integer,dimension(NGLOB_AB):: iglob_is_PML_interface
+
+ ! potential
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+ ! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+
+ !local parameters
+ integer :: iglob,ispecPML,i,j,k,ispec
+
+ ! experimental:
+ ! updates with the contribution from potential_dot_dot_acoustic on split potentials and vice versa
+
+ do ispecPML = 1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ if( ispec_is_inner(ispec) .eqv. phase_is_inner ) then
+
+ ! acoustic potentials
+ if( ispec_is_acoustic(ispec) ) then
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! sums contributions to PML potentials on interface points
+ if( iglob_is_PML_interface(iglob) > 0 ) then
+
+ ! this would be the contribution to the potential_dot_dot array
+ ! note: on PML interface, damping coefficient d should to be zero
+ ! as well as dprime (-> no chi2 contribution)
+
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ + chi1_dot_dot(i,j,k,ispecPML) &
+ + chi3_dot_dot(i,j,k,ispecPML) &
+ + chi4_dot_dot(i,j,k,ispecPML)
+
+ endif ! interface iglob
+ enddo
+ enddo
+ enddo
+
+ endif ! ispec_is_acoustic
+ endif ! ispec_is_inner
+ enddo ! ispecPML
+
+
+end subroutine PML_acoustic_interface_coupling
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+subroutine PML_acoustic_mass_update(NSPEC_AB,NGLOB_AB,&
+ ispec_is_acoustic,rmass_acoustic,ibool,&
+ num_PML_ispec,PML_ispec,&
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot)
+
+! updates split-potentials with local mass in PML region
+
+ use constants,only: NGLLX,NGLLY,NGLLZ,CUSTOM_REAL
+ implicit none
+ integer :: NSPEC_AB,NGLOB_AB
+
+ ! split-potentials
+ integer :: num_PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
+ integer,dimension(num_PML_ispec):: PML_ispec
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: rmass_acoustic
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+ !local parameters
+ real(kind=CUSTOM_REAL):: mass
+ integer :: ispec,ispecPML,i,j,k,iglob
+
+ ! updates the dot_dot potentials for the PML
+ do ispecPML = 1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! acoustic potentials
+ if( ispec_is_acoustic(ispec) ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! global mass ( sum over elements included)
+ mass = rmass_acoustic(iglob)
+
+ chi1_dot_dot(i,j,k,ispecPML) = chi1_dot_dot(i,j,k,ispecPML) * mass
+ chi2_t_dot_dot(i,j,k,ispecPML) = chi2_t_dot_dot(i,j,k,ispecPML) * mass
+ chi3_dot_dot(i,j,k,ispecPML) = chi3_dot_dot(i,j,k,ispecPML) * mass
+ chi4_dot_dot(i,j,k,ispecPML) = chi4_dot_dot(i,j,k,ispecPML) * mass
+
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+end subroutine PML_acoustic_mass_update
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_acoustic_time_march(NSPEC_AB,NGLOB_AB,ibool,&
+ potential_acoustic,potential_dot_acoustic,&
+ deltat,deltatsqover2,deltatover2,&
+ num_PML_ispec,PML_ispec,PML_damping_d,&
+ chi1,chi2,chi2_t,chi3,chi4,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot,&
+ iglob_is_PML_interface,PML_mask_ibool,&
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh,&
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh,NPROC,&
+ ispec_is_acoustic)
+
+
+! time marching scheme - updates with corrector terms
+!
+! note that the value of d changes according to the distance to the boundary,
+! thus instead of updating the whole arrays chi1(:) this scheme updates every given,single value chi1,...
+
+ use constants,only: NGLLX,NGLLY,NGLLZ,CUSTOM_REAL
+ implicit none
+
+ integer :: NSPEC_AB,NGLOB_AB
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+ ! potentials
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_acoustic
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_acoustic
+
+ real(kind=CUSTOM_REAL):: deltat,deltatsqover2,deltatover2
+
+ ! split-potentials
+ integer :: num_PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1,chi2,chi2_t,chi3,chi4
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ PML_damping_d
+
+ integer,dimension(num_PML_ispec):: PML_ispec
+ integer,dimension(NGLOB_AB) :: iglob_is_PML_interface
+ logical,dimension(NGLOB_AB) :: PML_mask_ibool
+
+ ! MPI communication
+ integer :: NPROC
+ integer :: num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh,my_neighbours_ext_mesh
+ integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
+
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+ !local parameters
+ real(kind=CUSTOM_REAL),dimension(:),allocatable:: contributions,contributions_dot
+ real(kind=CUSTOM_REAL):: d
+ integer :: ispec,ispecPML,i,j,k,iglob
+
+ ! updates local points in PML
+ allocate(contributions_dot(NGLOB_AB))
+ allocate(contributions(NGLOB_AB))
+ contributions_dot(:) = 0._CUSTOM_REAL
+ contributions(:) = 0._CUSTOM_REAL
+
+ do ispecPML = 1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! acoustic potentials
+ if( ispec_is_acoustic(ispec) ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ ! updates split-potential arrays
+ d = PML_damping_d(i,j,k,ispecPML)
+
+ call PML_acoustic_time_march_s(chi1(i,j,k,ispecPML),chi2(i,j,k,ispecPML),&
+ chi2_t(i,j,k,ispecPML),chi3(i,j,k,ispecPML),chi4(i,j,k,ispecPML), &
+ chi1_dot(i,j,k,ispecPML),chi2_t_dot(i,j,k,ispecPML),&
+ chi3_dot(i,j,k,ispecPML),chi4_dot(i,j,k,ispecPML), &
+ chi1_dot_dot(i,j,k,ispecPML),chi2_t_dot_dot(i,j,k,ispecPML),&
+ chi3_dot_dot(i,j,k,ispecPML),chi4_dot_dot(i,j,k,ispecPML), &
+ deltat,deltatsqover2,deltatover2,d)
+
+ ! adds new contributions
+ iglob = ibool(i,j,k,ispec)
+ if( iglob_is_PML_interface(iglob) > 0 ) then
+ ! on interface points, the time marched global potential from the regular domains applies
+ contributions(iglob) = 0._CUSTOM_REAL
+ contributions_dot(iglob) = 0._CUSTOM_REAL
+ else
+ contributions(iglob) = contributions(iglob) &
+ + chi1(i,j,k,ispecPML) &
+ + chi2(i,j,k,ispecPML) &
+ + chi3(i,j,k,ispecPML) &
+ + chi4(i,j,k,ispecPML)
+
+ contributions_dot(iglob) = contributions_dot(iglob) &
+ + chi1_dot(i,j,k,ispecPML) - d*chi1(i,j,k,ispecPML) &
+ + chi2_t(i,j,k,ispecPML) - d*chi2(i,j,k,ispecPML) &
+ + chi3_dot(i,j,k,ispecPML) - d*chi3(i,j,k,ispecPML) &
+ + chi4_dot(i,j,k,ispecPML)
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+ ! assembles contributions from different MPI processes
+ call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,contributions, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh)
+ call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,contributions_dot, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh)
+
+ ! separates contributions from regular domain
+ PML_mask_ibool = .false.
+
+ !do ispec = 1,NSPEC_AB
+ do ispecPML = 1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! acoustic potentials
+ if( ispec_is_acoustic(ispec) ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ if( PML_mask_ibool(iglob) .eqv. .false. ) then
+ ! on interface points, leave contribution from regular domain
+
+ ! inside PML region, split potentials determine the global acoustic potential
+ if( iglob_is_PML_interface(iglob) == 0 ) then
+ potential_acoustic(iglob) = contributions(iglob)
+ potential_dot_acoustic(iglob) = contributions_dot(iglob)
+ endif
+
+ PML_mask_ibool(iglob) = .true.
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+end subroutine PML_acoustic_time_march
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_acoustic_time_march_s(chi1,chi2,chi2_t,chi3,chi4, &
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot, &
+ chi1_dot_dot,chi2_t_dot_dot, &
+ chi3_dot_dot,chi4_dot_dot, &
+ deltat,deltatsqover2,deltatover2,d)
+
+! time marching scheme
+!
+! note that the value of d changes according to the distance to the boundary,
+! thus instead of updating the whole arrays chi1(:) this scheme updates every given,single value chi1,...
+ use constants,only: CUSTOM_REAL
+ implicit none
+ real(kind=CUSTOM_REAL):: chi1,chi2,chi2_t,chi3,chi4
+ real(kind=CUSTOM_REAL):: chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
+ real(kind=CUSTOM_REAL):: chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
+ real(kind=CUSTOM_REAL):: deltat,deltatsqover2,deltatover2,d
+ !local parameters
+ real(kind=CUSTOM_REAL):: fac1,fac2,fac3,fac4
+
+ ! pre-computes some factors
+ fac1 = 1._CUSTOM_REAL/(1.0_CUSTOM_REAL + deltatover2*d)
+ fac2 = 1._CUSTOM_REAL/(d + 1.0_CUSTOM_REAL/deltatover2)
+ fac3 = 1._CUSTOM_REAL/(2.0_CUSTOM_REAL + deltat*d)
+ fac4 = deltatsqover2*d*d - deltat*d
+
+ ! first term: chi1(t+deltat) update
+ chi1 = chi1 + deltat*chi1_dot + deltatsqover2*chi1_dot_dot &
+ + fac4*chi1 - deltat*deltat*d*chi1_dot
+
+ ! chi1_dot predictor
+ chi1_dot = fac1 * chi1_dot - d*fac2 * chi1_dot + fac2 * chi1_dot_dot
+ chi1_dot_dot = 0._CUSTOM_REAL
+
+ ! second term: chi2
+ ! note that it uses chi2_t at time ( t )
+ chi2 = 2.0*fac3 * chi2 - deltat*d*fac3 * chi2 + deltat*fac3 * chi2_t
+
+ ! temporary chi2_t(t+deltat) update
+ chi2_t = chi2_t + deltat*chi2_t_dot + deltatsqover2*chi2_t_dot_dot &
+ + fac4*chi2_t - deltat*deltat*d*chi2_t_dot
+
+ ! chi2 - corrector using updated chi2_t(t+deltat)
+ chi2 = chi2 + deltat*fac3 * chi2_t
+
+ ! temporary chi2_t_dot - predictor
+ chi2_t_dot = fac1 * chi2_t_dot - d*fac2 * chi2_t_dot + fac2 * chi2_t_dot_dot
+ chi2_t_dot_dot = 0._CUSTOM_REAL
+
+ ! third term: chi3 (t+deltat) update
+ chi3 = chi3 + deltat*chi3_dot + deltatsqover2*chi3_dot_dot &
+ + fac4*chi3 - deltatsqover2*d*chi3_dot
+ chi3_dot = chi3_dot + deltatover2*chi3_dot_dot
+ chi3_dot_dot = 0._CUSTOM_REAL
+
+ ! fourth term: chi4 (t+deltat) update
+ chi4 = chi4 + deltat*chi4_dot + deltatsqover2*chi4_dot_dot
+ chi4_dot = chi4_dot + deltatover2*chi4_dot_dot
+ chi4_dot_dot = 0._CUSTOM_REAL
+
+end subroutine PML_acoustic_time_march_s
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_acoustic_time_corrector(NSPEC_AB,ispec_is_acoustic,deltatover2,&
+ num_PML_ispec,PML_ispec,PML_damping_d,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot)
+
+! time marching scheme - updates with corrector terms
+!
+! note that the value of d changes according to the distance to the boundary,
+! thus instead of updating the whole arrays chi1(:) this scheme updates every given,single value chi1,...
+
+ use constants,only: NGLLX,NGLLY,NGLLZ,CUSTOM_REAL
+ implicit none
+
+ ! split-potentials
+ integer :: num_PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: PML_damping_d
+
+ integer,dimension(num_PML_ispec):: PML_ispec
+
+ real(kind=CUSTOM_REAL):: deltatover2
+
+ integer :: NSPEC_AB
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+ !local parameters
+ real(kind=CUSTOM_REAL):: d
+ integer :: ispec,ispecPML,i,j,k
+
+ ! updates "velocity" potentials in PML with corrector terms
+ do ispecPML = 1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! acoustic potentials
+ if( ispec_is_acoustic(ispec) ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ ! time marches chi_dot,.. potentials
+ d = PML_damping_d(i,j,k,ispecPML)
+
+ call PML_acoustic_time_corrector_s(chi1_dot(i,j,k,ispecPML),chi2_t_dot(i,j,k,ispecPML), &
+ chi3_dot(i,j,k,ispecPML),chi4_dot(i,j,k,ispecPML), &
+ chi1_dot_dot(i,j,k,ispecPML),chi2_t_dot_dot(i,j,k,ispecPML), &
+ chi3_dot_dot(i,j,k,ispecPML),chi4_dot_dot(i,j,k,ispecPML), &
+ deltatover2,d)
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+
+end subroutine PML_acoustic_time_corrector
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_acoustic_time_corrector_s(chi1_dot,chi2_t_dot,chi3_dot,chi4_dot, &
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot, &
+ deltatover2,d)
+
+! time marching scheme - updates with corrector terms
+!
+! note that the value of d changes according to the distance to the boundary,
+! thus instead of updating the whole arrays chi1(:) this scheme updates every given,single value chi1,...
+ use constants,only: CUSTOM_REAL
+ implicit none
+ real(kind=CUSTOM_REAL):: chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
+ real(kind=CUSTOM_REAL):: chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
+ real(kind=CUSTOM_REAL):: deltatover2,d
+ real(kind=CUSTOM_REAL):: fac1
+
+ fac1 = 1.0_CUSTOM_REAL/(d + 1.0_CUSTOM_REAL/deltatover2)
+
+ ! first term:
+ chi1_dot = chi1_dot + fac1*chi1_dot_dot
+
+ ! second term:
+ chi2_t_dot = chi2_t_dot + fac1*chi2_t_dot_dot
+
+ ! third term:
+ chi3_dot = chi3_dot + deltatover2*chi3_dot_dot
+
+ ! fourth term:
+ chi4_dot = chi4_dot + deltatover2*chi4_dot_dot
+
+end subroutine PML_acoustic_time_corrector_s
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_acoustic_enforce_free_srfc(NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
+ ibool,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces, &
+ ispec_is_acoustic, &
+ num_PML_ispec,PML_ispec,&
+ chi1,chi2,chi2_t,chi3,chi4,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi2_t_dot_dot,&
+ chi3_dot_dot,chi4_dot_dot)
+
+ use constants,only: NGLLX,NGLLY,NGLLZ,NGLLSQUARE,CUSTOM_REAL
+ implicit none
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+ ! split-potentials
+ integer :: num_PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1,chi2,chi2_t,chi3,chi4
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
+ integer,dimension(num_PML_ispec):: PML_ispec
+
+ ! acoustic potentials
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+ ! free surface
+ integer :: num_free_surface_faces
+ integer :: free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces)
+ integer :: free_surface_ispec(num_free_surface_faces)
+
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+! local parameters
+ integer :: iface,igll,i,j,k,ispec,iglob,ispecPML
+
+ ! enforce potentials to be zero at surface
+ do iface = 1, num_free_surface_faces
+
+ ispec = free_surface_ispec(iface)
+
+ if( ispec_is_acoustic(ispec) ) then
+
+ do ispecPML=1,num_PML_ispec
+ if( PML_ispec(ispecPML) == ispec ) then
+
+ do igll = 1, NGLLSQUARE
+ i = free_surface_ijk(1,igll,iface)
+ j = free_surface_ijk(2,igll,iface)
+ k = free_surface_ijk(3,igll,iface)
+ iglob = ibool(i,j,k,ispec)
+
+ ! sets potentials to zero
+ potential_acoustic(iglob) = 0._CUSTOM_REAL
+ potential_dot_acoustic(iglob) = 0._CUSTOM_REAL
+ potential_dot_dot_acoustic(iglob) = 0._CUSTOM_REAL
+
+ ! sets PML potentials to zero
+ chi1(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi1_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi1_dot_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
+
+ chi2(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi2_t(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi2_t_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi2_t_dot_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
+
+ chi3(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi3_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi3_dot_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
+
+ chi4(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi4_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi4_dot_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ enddo
+ endif
+ enddo
+ endif
+
+ enddo
+
+end subroutine PML_acoustic_enforce_free_srfc
+
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+subroutine PML_acoustic_update_potentials(NGLOB_AB,NSPEC_AB, &
+ ibool,ispec_is_acoustic, &
+ potential_dot_acoustic,potential_dot_dot_acoustic,&
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh,NPROC,&
+ num_PML_ispec,PML_ispec,iglob_is_PML_interface,&
+ PML_mask_ibool,PML_damping_d,&
+ chi1,chi2,chi2_t,chi3,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
+
+! updates potential_dot_acoustic and potential_dot_dot_acoustic inside PML region
+
+ use constants,only: NGLLX,NGLLY,NGLLZ,CUSTOM_REAL
+ implicit none
+
+ integer :: NGLOB_AB,NSPEC_AB
+
+ ! split-potentials
+ integer :: num_PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1,chi2,chi2_t,chi3
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ PML_damping_d
+ integer,dimension(num_PML_ispec):: PML_ispec
+ integer,dimension(NGLOB_AB):: iglob_is_PML_interface
+ logical,dimension(NGLOB_AB):: PML_mask_ibool
+
+
+ ! potentials
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_acoustic
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+ ! MPI communication
+ integer :: NPROC
+ integer :: num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh,my_neighbours_ext_mesh
+ integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
+
+ !local parameters
+ real(kind=CUSTOM_REAL),dimension(:),allocatable :: contributions_dot_dot,contributions_dot
+ real(kind=CUSTOM_REAL):: d
+ integer :: ispec,ispecPML,i,j,k,iglob
+
+ allocate(contributions_dot_dot(NGLOB_AB),contributions_dot(NGLOB_AB))
+ contributions_dot_dot = 0._CUSTOM_REAL
+ contributions_dot = 0._CUSTOM_REAL
+
+ ! updates the potential_dot & potential_dot_dot_acoustic array inside the PML
+ do ispecPML = 1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! acoustic potentials
+ if( ispec_is_acoustic(ispec) ) then
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! for points inside PML region
+ if( iglob_is_PML_interface(iglob) == 0 ) then
+
+ ! damping coefficient
+ d = PML_damping_d(i,j,k,ispecPML)
+
+ ! inside PML region: at this stage, this is only needed for seismogram/plotting output
+ ! afterwards potential_dot_dot, resp. chi1_dot_dot,.. get reset to zero
+
+ ! potential_dot: note that we defined
+ ! chi1_dot = (\partial_t + d) chi1
+ ! chi2_t = (\partial_t + d) chi2
+ ! chi3_dot = (\partial_t + d) chi3
+ ! chi4_dot = \partial_t chi4
+ ! where \partial_t is the time derivative, thus \partial_t (chi1+chi2+chi3+chi4) equals
+ contributions_dot(iglob) = contributions_dot(iglob) &
+ + chi1_dot(i,j,k,ispecPML) - d*chi1(i,j,k,ispecPML) &
+ + chi2_t(i,j,k,ispecPML) - d*chi2(i,j,k,ispecPML) &
+ + chi3_dot(i,j,k,ispecPML) - d*chi3(i,j,k,ispecPML) &
+ + chi4_dot(i,j,k,ispecPML)
+
+ ! potential_dot_dot: note that we defined
+ ! chi1_dot_dot = (\partial_t + d)**2 chi1
+ ! chi2_t_dot = (\partial_t + d)**2 chi2
+ ! chi3_dot = \partial_t (\partial_t + d) chi3
+ ! chi4_dot = \partial_t**2 chi4
+ ! where \partial_t is the time derivative, thus \partial_t**2 (chi1+chi2+chi3+chi4) equals
+ contributions_dot_dot(iglob) = contributions_dot_dot(iglob) &
+ + chi1_dot_dot(i,j,k,ispecPML) - 2.0*d*chi1_dot(i,j,k,ispecPML) + d*d*chi1(i,j,k,ispecPML) &
+ + chi2_t_dot(i,j,k,ispecPML) - 2.0*d*chi2_t(i,j,k,ispecPML) + d*d*chi2(i,j,k,ispecPML) &
+ + chi3_dot_dot(i,j,k,ispecPML) - d*chi3_dot(i,j,k,ispecPML) + d*d*chi3(i,j,k,ispecPML) &
+ + chi4_dot_dot(i,j,k,ispecPML)
+
+ endif
+
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+ ! assembles contributions from different MPI processes
+ call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,contributions_dot, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh)
+ call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,contributions_dot_dot, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh)
+
+ ! updates the potential_dot & potential_dot_dot_acoustic array inside the PML
+ PML_mask_ibool = .false.
+ do ispecPML = 1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! acoustic potentials
+ if( ispec_is_acoustic(ispec) ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ if( PML_mask_ibool(iglob) .eqv. .false. ) then
+ ! for points inside PML region
+ if( iglob_is_PML_interface(iglob) == 0 ) then
+ potential_dot_acoustic(iglob) = contributions_dot(iglob)
+ potential_dot_dot_acoustic(iglob) = contributions_dot(iglob)
+ endif
+ PML_mask_ibool(iglob) = .true.
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+end subroutine PML_acoustic_update_potentials
+
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_elastic.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -49,42 +49,35 @@
! elastic term
if(USE_DEVILLE_PRODUCTS) then
- call compute_forces_with_Deville(phase_is_inner, NSPEC_AB,NGLOB_AB, &
- displ,accel, &
+ call compute_forces_with_Deville(phase_is_inner, NSPEC_AB,NGLOB_AB,displ,accel, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_xxT, &
- hprimewgll_xx,hprimewgll_xxT, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT, &
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool, &
- ispec_is_inner, &
+ kappastore,mustore,jacobian,ibool,ispec_is_inner, &
ATTENUATION,USE_OLSEN_ATTENUATION, &
one_minus_sum_beta,factor_common,alphaval,betaval,gammaval, &
NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
epsilondev_xx,epsilondev_yy,epsilondev_xy, &
epsilondev_xz,epsilondev_yz,iflag_attenuation_store, &
- rho_vs, &
- ANISOTROPY,NSPEC_ANISO, &
+ rho_vs,ANISOTROPY,NSPEC_ANISO, &
c11store,c12store,c13store,c14store,c15store,c16store,&
c22store,c23store,c24store,c25store,c26store,c33store,&
c34store,c35store,c36store,c44store,c45store,c46store,&
c55store,c56store,c66store, &
ispec_is_elastic )
else
- call compute_forces_no_Deville( phase_is_inner, NSPEC_AB,NGLOB_AB, &
- displ,accel, &
+ call compute_forces_no_Deville( phase_is_inner, NSPEC_AB,NGLOB_AB,displ,accel, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
hprime_xx,hprime_yy,hprime_zz, &
hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,&
wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool, &
- ispec_is_inner, &
+ kappastore,mustore,jacobian,ibool,ispec_is_inner, &
ATTENUATION,USE_OLSEN_ATTENUATION,&
one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,&
NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
epsilondev_xx,epsilondev_yy,epsilondev_xy,&
epsilondev_xz,epsilondev_yz,iflag_attenuation_store,&
- rho_vs, &
- ANISOTROPY,NSPEC_ANISO, &
+ rho_vs,ANISOTROPY,NSPEC_ANISO, &
c11store,c12store,c13store,c14store,c15store,c16store,&
c22store,c23store,c24store,c25store,c26store,c33store,&
c34store,c35store,c36store,c44store,c45store,c46store,&
@@ -94,7 +87,7 @@
! adds elastic absorbing boundary term to acceleration (Stacey conditions)
if(ABSORBING_CONDITIONS) &
- call compute_forces_elastic_absorbing_boundaries(NSPEC_AB,NGLOB_AB,accel, &
+ call elastic_absorbing_boundaries(NSPEC_AB,NGLOB_AB,accel, &
ibool,ispec_is_inner,phase_is_inner, &
abs_boundary_normal,abs_boundary_jacobian2Dw, &
abs_boundary_ijk,abs_boundary_ispec, &
@@ -104,7 +97,7 @@
! acoustic coupling
if( ACOUSTIC_SIMULATION ) &
- call compute_forces_elastic_coupling_acoustic(NSPEC_AB,NGLOB_AB, &
+ call elastic_coupling_acoustic(NSPEC_AB,NGLOB_AB, &
ibool,accel,potential_dot_dot_acoustic, &
num_coupling_ac_el_faces, &
coupling_ac_el_ispec,coupling_ac_el_ijk, &
@@ -114,10 +107,10 @@
! poroelastic coupling
if( POROELASTIC_SIMULATION ) &
- call compute_forces_elastic_coupling_poroelastic()
+ call elastic_coupling_poroelastic()
! adds source term (single-force/moment-tensor solution)
- call compute_forces_elastic_sources( NSPEC_AB,NGLOB_AB,accel, &
+ call elastic_sources( NSPEC_AB,NGLOB_AB,accel, &
ibool,ispec_is_inner,phase_is_inner, &
NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
xi_source,eta_source,gamma_source,nu_source, &
@@ -165,7 +158,7 @@
! updates acceleration with ocean load term
if(OCEANS) then
- call compute_forces_elastic_ocean_load(NSPEC_AB,NGLOB_AB, &
+ call elastic_ocean_load(NSPEC_AB,NGLOB_AB, &
ibool,rmass,rmass_ocean_load,accel, &
free_surface_normal,free_surface_ijk,free_surface_ispec, &
num_free_surface_faces)
@@ -202,7 +195,7 @@
! absorbing boundary term for elastic media (Stacey conditions)
-subroutine compute_forces_elastic_absorbing_boundaries(NSPEC_AB,NGLOB_AB,accel, &
+subroutine elastic_absorbing_boundaries(NSPEC_AB,NGLOB_AB,accel, &
ibool,ispec_is_inner,phase_is_inner, &
abs_boundary_normal,abs_boundary_jacobian2Dw, &
abs_boundary_ijk,abs_boundary_ispec, &
@@ -293,13 +286,13 @@
endif ! ispec_is_inner
enddo
-end subroutine compute_forces_elastic_absorbing_boundaries
+end subroutine elastic_absorbing_boundaries
!
!-------------------------------------------------------------------------------------------------
!
-subroutine compute_forces_elastic_coupling_acoustic(NSPEC_AB,NGLOB_AB, &
+subroutine elastic_coupling_acoustic(NSPEC_AB,NGLOB_AB, &
ibool,accel,potential_dot_dot_acoustic, &
num_coupling_ac_el_faces, &
coupling_ac_el_ispec,coupling_ac_el_ijk, &
@@ -391,22 +384,22 @@
enddo ! iface
-end subroutine compute_forces_elastic_coupling_acoustic
+end subroutine elastic_coupling_acoustic
!
!-------------------------------------------------------------------------------------------------
!
-subroutine compute_forces_elastic_coupling_poroelastic()
+subroutine elastic_coupling_poroelastic()
implicit none
-end subroutine compute_forces_elastic_coupling_poroelastic
+end subroutine elastic_coupling_poroelastic
!
!-------------------------------------------------------------------------------------------------
!
-subroutine compute_forces_elastic_sources( NSPEC_AB,NGLOB_AB,accel, &
+subroutine elastic_sources( NSPEC_AB,NGLOB_AB,accel, &
ibool,ispec_is_inner,phase_is_inner, &
NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
xi_source,eta_source,gamma_source,nu_source, &
@@ -515,13 +508,13 @@
enddo ! NSOURCES
-end subroutine compute_forces_elastic_sources
+end subroutine elastic_sources
!
!-------------------------------------------------------------------------------------------------
!
-subroutine compute_forces_elastic_ocean_load(NSPEC_AB,NGLOB_AB, &
+subroutine elastic_ocean_load(NSPEC_AB,NGLOB_AB, &
ibool,rmass,rmass_ocean_load,accel, &
free_surface_normal,free_surface_ijk,free_surface_ispec, &
num_free_surface_faces)
@@ -625,5 +618,5 @@
enddo ! igll
enddo ! iface
-end subroutine compute_forces_elastic_ocean_load
+end subroutine elastic_ocean_load
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/compute_gradient.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_gradient.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_gradient.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -34,6 +34,7 @@
! note:
! displacement s = (rho)^{-1} \del \chi
! velocity v = (rho)^{-1} \del \ddot \chi
+!
! returns: gradient vector field (vector_field_element) in specified element
implicit none
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/constants.h.in
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/constants.h.in 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/constants.h.in 2010-01-06 23:41:13 UTC (rev 16126)
@@ -94,9 +94,15 @@
! use directory OUTPUT_FILES/ for seismogram output
logical,parameter :: USE_OUTPUT_FILES_PATH = .true.
-! absorb top surface ( defined in mesh as 'free_surface_file' )
+! absorb top surface
+! (defined in mesh as 'free_surface_file')
logical,parameter :: ABSORB_FREE_SURFACE = .false.
+! absorb boundaries using a PML region
+! (EXPERIMENTAL feature: only acoustic domains supported...
+! user parameters can be specified in PML_init.f90)
+ logical,parameter :: ABSORB_USE_PML = .false.
+
! ---------------------------------------------------------------------------------------
! LQY -- Following 3 variables stays here temporarily,
! we need to move them to Par_file at a proper time
@@ -140,12 +146,17 @@
logical, parameter :: EXTERNAL_MESH_MOVIE_SURFACE = .false.
logical, parameter :: EXTERNAL_MESH_CREATE_SHAKEMAP = .false.
-! plots cross-section planes instead of model surface
+! plots VTK cross-section planes instead of model surface
+! (EXPERIMENTAL feature)
logical, parameter :: PLOT_CROSS_SECTIONS = .false.
real(kind=CUSTOM_REAL),parameter :: CROSS_SECTION_X = 67000.0
real(kind=CUSTOM_REAL),parameter :: CROSS_SECTION_Y = 65500.0
real(kind=CUSTOM_REAL),parameter :: CROSS_SECTION_Z = -30000.0
+! plots GIF cross-section image
+! (cross-section plane parameters can be specified in write_PNM_GIF_data.f90)
+ logical, parameter :: PNM_GIF_IMAGE = .false.
+
! number of nodes per element as provided by the external mesh
integer, parameter :: ESIZE = 8
@@ -188,6 +199,7 @@
! very large real value declared independently of the machine
real(kind=CUSTOM_REAL), parameter :: HUGEVAL_SNGL = 1.e+30_CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: TINYVAL_SNGL = 1.e-25_CUSTOM_REAL
! very large integer value
integer, parameter :: HUGEINT = 100000000
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -209,10 +209,10 @@
integer, dimension(NX_TOPO,NY_TOPO) :: itopo_bathy
! local parameters
-
! static memory size needed by the solver
double precision :: static_memory_size
-
+ real(kind=CUSTOM_REAL) :: model_speed_max
+
! for vtk output
! character(len=256) prname_file
! integer,dimension(:),allocatable :: itest_flag
@@ -348,22 +348,16 @@
jacobianstore, rho_vp,rho_vs,iflag_attenuation_store, &
rhostore,kappastore,mustore, &
rmass,rmass_acoustic,rmass_solid_poroelastic,rmass_fluid_poroelastic, &
- OCEANS,rmass_ocean_load,NGLOB_OCEAN,&
- ibool, &
- xstore_dummy,ystore_dummy,zstore_dummy, &
+ OCEANS,rmass_ocean_load,NGLOB_OCEAN,ibool,xstore_dummy,ystore_dummy,zstore_dummy, &
abs_boundary_normal,abs_boundary_jacobian2Dw, &
- abs_boundary_ijk,abs_boundary_ispec, &
- num_abs_boundary_faces, &
+ abs_boundary_ijk,abs_boundary_ispec,num_abs_boundary_faces, &
free_surface_normal,free_surface_jacobian2Dw, &
- free_surface_ijk,free_surface_ispec, &
- num_free_surface_faces, &
+ free_surface_ijk,free_surface_ispec,num_free_surface_faces, &
coupling_ac_el_normal,coupling_ac_el_jacobian2Dw, &
- coupling_ac_el_ijk,coupling_ac_el_ispec, &
- num_coupling_ac_el_faces, &
+ coupling_ac_el_ijk,coupling_ac_el_ispec,num_coupling_ac_el_faces, &
num_interfaces_ext_mesh,my_neighbours_ext_mesh,nibool_interfaces_ext_mesh, &
max_interface_size_ext_mesh,ibool_interfaces_ext_mesh, &
- prname,SAVE_MESH_FILES, &
- ANISOTROPY,NSPEC_ANISO, &
+ prname,SAVE_MESH_FILES,ANISOTROPY,NSPEC_ANISO, &
c11store,c12store,c13store,c14store,c15store,c16store, &
c22store,c23store,c24store,c25store,c26store,c33store, &
c34store,c35store,c36store,c44store,c45store,c46store, &
@@ -379,7 +373,7 @@
call check_mesh_resolution(myrank,nspec,nglob,ibool,&
xstore_dummy,ystore_dummy,zstore_dummy, &
kappastore,mustore,rho_vp,rho_vs, &
- -1.0d0 )
+ -1.0d0, model_speed_max )
! VTK file output
! if( SAVE_MESH_FILES ) then
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -166,6 +166,19 @@
mat(2,:) = 1
! reads material definitions
+ !
+ ! note: format of nummaterial_velocity_file must be
+ !
+ ! #(1)material_domain_id #(2)material_id #(3)rho #(4)vp #(5)vs #(6)Q_flag #(7)anisotropy_flag
+ !
+ ! where
+ ! material_domain_id : 1=acoustic / 2=elastic / 3=poroelastic
+ ! material_id : number of material/volume
+ ! rho : density
+ ! vp : P-velocity
+ ! vs : S-velocity
+ ! Q_flag : 0=no attenuation/1=IATTENUATION_SEDIMENTS_40, 2=..., 13=IATTENUATION_BEDROCK
+ ! anisotropy_flag : 0=no anisotropy/ 1,2,.. check with implementation in aniso_model.f90
count_def_mat = 0
count_undef_mat = 0
open(unit=98, file=localpath_name(1:len_trim(localpath_name))//'/nummaterial_velocity_file',&
@@ -198,7 +211,11 @@
open(unit=98, file=localpath_name(1:len_trim(localpath_name))//'/nummaterial_velocity_file', &
status='old', form='formatted')
do imat=1,count_def_mat
- ! format: #(6) material_domain_id #(0) material_id #(1) rho #(2) vp #(3) vs #(4) Q_flag #(5) anisotropy_flag
+ ! material definitions
+ !
+ ! format: note that we save the arguments in a slightly different order in mat_prop(:,:)
+ ! #(6) material_domain_id #(0) material_id #(1) rho #(2) vp #(3) vs #(4) Q_flag #(5) anisotropy_flag
+ !
read(98,*) idomain_id,num_mat,rho,vp,vs,q_flag,aniso_flag
!read(98,*) num_mat, mat_prop(1,num_mat),mat_prop(2,num_mat),&
! mat_prop(3,num_mat),mat_prop(4,num_mat),mat_prop(5,num_mat)
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/part_decompose_mesh_SCOTCH.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/part_decompose_mesh_SCOTCH.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/part_decompose_mesh_SCOTCH.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -569,7 +569,12 @@
write(IIN_database,*) count_def_mat,count_undef_mat
do i = 1, count_def_mat
+ ! database material definition
+ !
! format: #rho #vp #vs #Q_flag #anisotropy_flag #domain_id
+ !
+ ! (note that this order of the properties is different than the input in nummaterial_velocity_file)
+ !
write(IIN_database,*) mat_prop(1,i), mat_prop(2,i), mat_prop(3,i), &
mat_prop(4,i), mat_prop(5,i), mat_prop(6,i)
end do
@@ -1070,7 +1075,11 @@
!--------------------------------------------------
subroutine acoustic_elastic_load (elmnts_load,nelmnts,nb_materials,num_material,mat_prop)
-
+ !
+ ! note:
+ ! acoustic material = domainID 1 (stored in mat_prop(6,..) )
+ ! elastic material = domainID 2
+ !
implicit none
integer(long),intent(in) :: nelmnts
@@ -1091,9 +1100,11 @@
is_acoustic(:) = .false.
is_elastic(:) = .false.
do i = 1, nb_materials
+ ! acoustic material has idomain_id 1
if (mat_prop(6,i) == 1 ) then
is_acoustic(i) = .true.
endif
+ ! elastic material has idomain_id 2
if (mat_prop(6,i) == 2 ) then
is_elastic(i) = .true.
endif
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -29,6 +29,8 @@
use specfem_par
use specfem_par_movie
+ use specfem_par_acoustic
+ use specfem_par_elastic
implicit none
! detecting surface points/elements (based on valence check on NGLL points) for external mesh
@@ -42,11 +44,11 @@
! returns surface points/elements
! in ispec_is_surface_external_mesh / iglob_is_surface_external_mesh and
- ! number of faces in nfaces_surface_external_mesh
+ ! number of faces in nfaces_surface_ext_mesh
call detect_surface(NPROC,NGLOB_AB,NSPEC_AB,ibool,&
ispec_is_surface_external_mesh, &
iglob_is_surface_external_mesh, &
- nfaces_surface_external_mesh, &
+ nfaces_surface_ext_mesh, &
num_interfaces_ext_mesh, &
max_nibool_interfaces_ext_mesh, &
nibool_interfaces_ext_mesh, &
@@ -60,7 +62,7 @@
call detect_surface_cross_section(NPROC,NGLOB_AB,NSPEC_AB,ibool,&
ispec_is_surface_external_mesh, &
iglob_is_surface_external_mesh, &
- nfaces_surface_external_mesh, &
+ nfaces_surface_ext_mesh, &
num_interfaces_ext_mesh, &
max_nibool_interfaces_ext_mesh, &
nibool_interfaces_ext_mesh, &
@@ -73,7 +75,7 @@
! takes number of faces for top, free surface only
if( MOVIE_SURFACE .or. CREATE_SHAKEMAP ) then
- nfaces_surface_external_mesh = num_free_surface_faces
+ nfaces_surface_ext_mesh = num_free_surface_faces
! face corner indices
iorderi(1) = 1
iorderi(2) = NGLLX
@@ -94,16 +96,25 @@
endif
if (MOVIE_VOLUME) then
- allocate(div(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(curl_x(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(curl_y(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(curl_z(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- div(:,:,:,:) = 0._CUSTOM_REAL
- curl_x(:,:,:,:) = 0._CUSTOM_REAL
- curl_y(:,:,:,:) = 0._CUSTOM_REAL
- curl_z(:,:,:,:) = 0._CUSTOM_REAL
+ if( ACOUSTIC_SIMULATION .or. ELASTIC_SIMULATION ) then
+ allocate(velocity_movie(NDIM,NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ endif
+ if( ELASTIC_SIMULATION ) then
+ allocate(div(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(curl_x(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(curl_y(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(curl_z(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ div(:,:,:,:) = 0._CUSTOM_REAL
+ curl_x(:,:,:,:) = 0._CUSTOM_REAL
+ curl_y(:,:,:,:) = 0._CUSTOM_REAL
+ curl_z(:,:,:,:) = 0._CUSTOM_REAL
+ endif
endif
+ ! handles cross-section gif image
+ if( PNM_GIF_IMAGE ) then
+ call write_PNM_GIF_initialize()
+ endif
! obsolete...
! allocate files to save movies and shaking map
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/detect_surface.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/detect_surface.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/detect_surface.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -26,7 +26,7 @@
subroutine detect_surface(NPROC,nglob,nspec,ibool,&
ispec_is_surface_external_mesh, &
iglob_is_surface_external_mesh, &
- nfaces_surface_external_mesh, &
+ nfaces_surface_ext_mesh, &
num_interfaces_ext_mesh, &
max_nibool_interfaces_ext_mesh, &
nibool_interfaces_ext_mesh, &
@@ -36,7 +36,7 @@
! detects surface (points/elements) of model based upon valence
!
! returns: ispec_is_surface_external_mesh, iglob_is_surface_external_mesh
-! and nfaces_surface_external_mesh
+! and nfaces_surface_ext_mesh
implicit none
@@ -49,7 +49,7 @@
! surface
logical, dimension(nspec) :: ispec_is_surface_external_mesh
logical, dimension(nglob) :: iglob_is_surface_external_mesh
- integer :: nfaces_surface_external_mesh
+ integer :: nfaces_surface_ext_mesh
! MPI partitions
integer :: num_interfaces_ext_mesh
@@ -140,31 +140,31 @@
enddo ! nspec
! counts faces for external-mesh movies and shakemaps
- nfaces_surface_external_mesh = 0
+ nfaces_surface_ext_mesh = 0
do ispec = 1, nspec
iglob = ibool(2,2,1,ispec)
if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
endif
iglob = ibool(2,2,NGLLZ,ispec)
if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
endif
iglob = ibool(2,1,2,ispec)
if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
endif
iglob = ibool(2,NGLLY,2,ispec)
if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
endif
iglob = ibool(1,2,2,ispec)
if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
endif
iglob = ibool(NGLLX,2,2,ispec)
if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
endif
enddo
@@ -177,7 +177,7 @@
subroutine detect_surface_cross_section(NPROC,nglob,nspec,ibool,&
ispec_is_surface_external_mesh, &
iglob_is_surface_external_mesh, &
- nfaces_surface_external_mesh, &
+ nfaces_surface_ext_mesh, &
num_interfaces_ext_mesh, &
max_nibool_interfaces_ext_mesh, &
nibool_interfaces_ext_mesh, &
@@ -189,11 +189,11 @@
! instead of surface of model, this returns cross-section surfaces through model
! at specified x,y,z - coordinates
!
-! note: x,y,z coordinates must coincide with the element (outer-)faces, no planes inside element are taken
+! note: x,y,z coordinates must coincide with the element (outer-)faces, no planes inside elements are taken
! (this is only a quick & dirty cross-section implementation, no sophisticated interpolation of points considered...)
!
! returns: ispec_is_surface_external_mesh, iglob_is_surface_external_mesh
-! and nfaces_surface_external_mesh
+! and nfaces_surface_ext_mesh
implicit none
@@ -206,7 +206,7 @@
! surface
logical, dimension(nspec) :: ispec_is_surface_external_mesh
logical, dimension(nglob) :: iglob_is_surface_external_mesh
- integer :: nfaces_surface_external_mesh
+ integer :: nfaces_surface_ext_mesh
! MPI partitions
integer :: num_interfaces_ext_mesh
@@ -222,27 +222,55 @@
real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
!local parameters
- real(kind=CUSTOM_REAL) :: mindist
+ real(kind=CUSTOM_REAL),dimension(6) :: midpoint_faces_x,midpoint_faces_y, &
+ midpoint_faces_z
+ real(kind=CUSTOM_REAL),dimension(6) :: midpoint_dist_x,midpoint_dist_y,midpoint_dist_z
+ real(kind=CUSTOM_REAL),dimension(NGNOD2D) :: xcoord_face,ycoord_face,zcoord_face
+ real(kind=CUSTOM_REAL) :: mindist,normal(NDIM)
integer, dimension(:), allocatable :: valence_external_mesh
+ integer,dimension(3,NGLLX,NGLLX) :: face_ijk
integer :: ispec,i,j,k,ii,jj,kk,iglob,ier,count
+ integer :: iface,icorner
+ logical, dimension(:),allocatable :: ispec_has_points
logical :: has_face
+ ! corners indices of reference cube faces
+ integer,dimension(3,4),parameter :: iface1_corner_ijk = &
+ reshape((/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ /),(/3,4/)) ! xmin
+ integer,dimension(3,4),parameter :: iface2_corner_ijk = &
+ reshape((/ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),(/3,4/)) !xmax
+ integer,dimension(3,4),parameter :: iface3_corner_ijk = &
+ reshape((/ 1,1,1, 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,1,1 /),(/3,4/)) !ymin
+ integer,dimension(3,4),parameter :: iface4_corner_ijk = &
+ reshape((/ 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! ymax
+ integer,dimension(3,4),parameter :: iface5_corner_ijk = &
+ reshape((/ 1,1,1, 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,1,1 /),(/3,4/)) ! bottom
+ integer,dimension(3,4),parameter :: iface6_corner_ijk = &
+ reshape((/ 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) !top
+ integer,dimension(3,4,6),parameter :: iface_all_corner_ijk = &
+ reshape((/ iface1_corner_ijk,iface2_corner_ijk, &
+ iface3_corner_ijk,iface4_corner_ijk, &
+ iface5_corner_ijk,iface6_corner_ijk /),(/3,4,6/)) ! all faces
+ integer,dimension(3,6),parameter :: iface_midpoint_ijk = &
+ reshape( (/ 1,3,3, NGLLX,3,3, 3,1,3, 3,NGLLY,3, 3,3,1, 3,3,NGLLZ /),(/3,6/)) ! top
! detecting surface points/elements (based on valence check on NGLL points) for external mesh
- allocate(valence_external_mesh(nglob),stat=ier)
+ allocate(valence_external_mesh(nglob),ispec_has_points(nspec),stat=ier)
if( ier /= 0 ) stop 'error allocate valence array'
! initialize surface indices
ispec_is_surface_external_mesh(:) = .false.
iglob_is_surface_external_mesh(:) = .false.
+
valence_external_mesh(:) = 0
-
-! an estimation of the minimum distance between global points
- mindist = minval( (xstore(ibool(1,1,1,:)) - xstore(ibool(2,1,1,:)))**2 &
- + (ystore(ibool(1,1,1,:)) - ystore(ibool(2,1,1,:)))**2 &
- + (zstore(ibool(1,1,1,:)) - zstore(ibool(2,1,1,:)))**2 )
+ ispec_has_points(:) = .false.
+
+! an estimation of the minimum distance between global points (for an element width)
+ mindist = minval( (xstore(ibool(1,3,3,:)) - xstore(ibool(NGLLX,3,3,:)))**2 &
+ + (ystore(ibool(1,3,3,:)) - ystore(ibool(NGLLX,3,3,:)))**2 &
+ + (zstore(ibool(1,3,3,:)) - zstore(ibool(NGLLX,3,3,:)))**2 )
mindist = sqrt(mindist)
-! sets valence to corresponding to process rank for points on cross-sections
+! sets valence value to one corresponding to process rank for points on cross-sections
count = 0
do ispec = 1, nspec
do k = 1, NGLLZ
@@ -251,24 +279,27 @@
iglob = ibool(i,j,k,ispec)
! x cross-section
- if( abs( xstore(iglob) - x_section ) < 0.5*mindist ) then
+ if( abs( xstore(iglob) - x_section ) < 0.2*mindist ) then
! sets valence to 1 for points on cross-sections
valence_external_mesh(iglob) = myrank+1
count = count + 1
+ ispec_has_points(ispec) = .true.
endif
! y cross-section
- if( abs( ystore(iglob) - y_section ) < 0.5*mindist ) then
+ if( abs( ystore(iglob) - y_section ) < 0.2*mindist ) then
! sets valence to 1 for points on cross-sections
valence_external_mesh(iglob) = myrank+1
count = count + 1
+ ispec_has_points(ispec) = .true.
endif
! z cross-section
- if( abs( zstore(iglob) - z_section ) < 0.5*mindist ) then
+ if( abs( zstore(iglob) - z_section ) < 0.2*mindist ) then
! sets valence to 1 for points on cross-sections
valence_external_mesh(iglob) = myrank+1
count = count + 1
+ ispec_has_points(ispec) = .true.
endif
enddo
@@ -292,6 +323,13 @@
do k = 1, NGLLZ
do j = 1, NGLLY
do i = 1, NGLLX
+
+ iglob = ibool(i,j,k,ispec)
+
+ ! sets flag if element has points
+ if( valence_external_mesh(iglob) > 0 ) ispec_has_points(ispec) = .true.
+
+ ! checks element surfaces for valence points
if ( ((k == 1 .or. k == NGLLZ) .and. (j == 2 .and. i == 2)) .or. &
((j == 1 .or. j == NGLLY) .and. (k == 2 .and. i == 2)) .or. &
((i == 1 .or. i == NGLLX) .and. (k == 2 .and. j == 2)) ) then
@@ -313,7 +351,7 @@
do ii = 1, NGLLX
iglob_is_surface_external_mesh(ibool(ii,jj,k,ispec)) = .true.
! resets valence to count face only once
- valence_external_mesh(ibool(ii,jj,k,ispec)) = 0
+ valence_external_mesh(ibool(ii,jj,k,ispec)) = -1
enddo
enddo
endif
@@ -325,7 +363,7 @@
do ii = 1, NGLLX
iglob_is_surface_external_mesh(ibool(ii,j,kk,ispec)) = .true.
! resets valence to count face only once
- valence_external_mesh(ibool(ii,j,kk,ispec)) = 0
+ valence_external_mesh(ibool(ii,j,kk,ispec)) = -1
enddo
enddo
endif
@@ -337,7 +375,7 @@
do jj = 1, NGLLY
iglob_is_surface_external_mesh(ibool(i,jj,kk,ispec)) = .true.
! resets valence to count face only once
- valence_external_mesh(ibool(i,jj,kk,ispec)) = 0
+ valence_external_mesh(ibool(i,jj,kk,ispec)) = -1
enddo
enddo
endif
@@ -357,38 +395,293 @@
enddo ! nspec
+
+! tries to find closest face if points are inside
+ do ispec = 1,nspec
+ ! checks if already assigned
+ !if( ispec_is_surface_external_mesh(ispec) ) cycle
+
+ ! in case element has still unresolved points in interior,
+ ! we take closest element face to cross-section plane
+ if( ispec_has_points(ispec) ) then
+
+ ! an estimation of the element width
+ mindist = sqrt((xstore(ibool(1,3,3,ispec)) - xstore(ibool(NGLLX,3,3,ispec)))**2 &
+ + (ystore(ibool(1,3,3,ispec)) - ystore(ibool(NGLLX,3,3,ispec)))**2 &
+ + (zstore(ibool(1,3,3,ispec)) - zstore(ibool(NGLLX,3,3,ispec)))**2 )
+
+ ! determines element face by minimum distance of midpoints
+ midpoint_faces_x(:) = 0.0
+ midpoint_faces_y(:) = 0.0
+ midpoint_faces_z(:) = 0.0
+ do iface=1,6
+ ! face corners
+ do icorner = 1,NGNOD2D
+ i = iface_all_corner_ijk(1,icorner,iface)
+ j = iface_all_corner_ijk(2,icorner,iface)
+ k = iface_all_corner_ijk(3,icorner,iface)
+
+ ! coordinates
+ iglob = ibool(i,j,k,ispec)
+ xcoord_face(icorner) = xstore(iglob)
+ ycoord_face(icorner) = ystore(iglob)
+ zcoord_face(icorner) = zstore(iglob)
+
+ ! face midpoint coordinates
+ midpoint_faces_x(iface) = midpoint_faces_x(iface) + xcoord_face(icorner)
+ midpoint_faces_y(iface) = midpoint_faces_y(iface) + ycoord_face(icorner)
+ midpoint_faces_z(iface) = midpoint_faces_z(iface) + zcoord_face(icorner)
+
+ enddo
+ midpoint_faces_x(iface) = midpoint_faces_x(iface) / 4.0
+ midpoint_faces_y(iface) = midpoint_faces_y(iface) / 4.0
+ midpoint_faces_z(iface) = midpoint_faces_z(iface) / 4.0
+
+ ! gets face normal
+ normal(:) = 0._CUSTOM_REAL
+ call get_element_face_normal(ispec,iface,xcoord_face,ycoord_face,zcoord_face,&
+ ibool,nspec,nglob,xstore,ystore,zstore,&
+ normal)
+
+ ! distance to cross-section planes
+ midpoint_dist_x(iface) = abs(midpoint_faces_x(iface) - x_section)
+ midpoint_dist_y(iface) = abs(midpoint_faces_y(iface) - y_section)
+ midpoint_dist_z(iface) = abs(midpoint_faces_z(iface) - z_section)
+
+
+ ! x cross-section plane
+ !minface = minloc(midpoint_dist_x)
+ !iface = minface(1)
+ i = iface_midpoint_ijk(1,iface)
+ j = iface_midpoint_ijk(2,iface)
+ k = iface_midpoint_ijk(3,iface)
+ if( midpoint_dist_x(iface) < 0.5*mindist .and. &
+ valence_external_mesh(ibool(i,j,k,ispec)) /= -1 ) then
+ ! checks face normal points in similar direction as cross-section normal
+ if( abs(normal(1)) > 0.6 ) then
+ call get_element_face_gll_indices(iface,face_ijk,NGLLX,NGLLX)
+ do jj = 1, NGLLY
+ do ii = 1, NGLLX
+ i = face_ijk(1,ii,jj)
+ j = face_ijk(2,ii,jj)
+ k = face_ijk(3,ii,jj)
+ ! sets iglob flag on face points
+ iglob_is_surface_external_mesh(ibool(i,j,k,ispec)) = .true.
+ ! sets ispec flag
+ ispec_is_surface_external_mesh(ispec) = .true.
+ ! resets valence
+ valence_external_mesh(ibool(i,j,k,ispec)) = -1
+ enddo
+ enddo
+ endif
+ endif
+
+ ! y cross-section plane
+ !minface = minloc(midpoint_dist_y)
+ !iface = minface(1)
+ i = iface_midpoint_ijk(1,iface)
+ j = iface_midpoint_ijk(2,iface)
+ k = iface_midpoint_ijk(3,iface)
+ if( midpoint_dist_y(iface) < 0.5*mindist .and. &
+ valence_external_mesh(ibool(i,j,k,ispec)) /= -1) then
+ ! checks face normal points in similar direction as cross-section normal
+ if( abs(normal(2)) > 0.6 ) then
+ call get_element_face_gll_indices(iface,face_ijk,NGLLX,NGLLX)
+ do jj = 1, NGLLY
+ do ii = 1, NGLLX
+ i = face_ijk(1,ii,jj)
+ j = face_ijk(2,ii,jj)
+ k = face_ijk(3,ii,jj)
+ ! sets iglob flag on face points
+ iglob_is_surface_external_mesh(ibool(i,j,k,ispec)) = .true.
+ ! sets ispec flag
+ ispec_is_surface_external_mesh(ispec) = .true.
+ ! resets valence
+ valence_external_mesh(ibool(i,j,k,ispec)) = -1
+ enddo
+ enddo
+ endif
+ endif
+
+ ! z cross-section plane
+ !minface = minloc(midpoint_dist_z)
+ !iface = minface(1)
+ i = iface_midpoint_ijk(1,iface)
+ j = iface_midpoint_ijk(2,iface)
+ k = iface_midpoint_ijk(3,iface)
+ if( midpoint_dist_z(iface) < 0.5*mindist .and. &
+ valence_external_mesh(ibool(i,j,k,ispec)) /= -1) then
+ ! checks face normal points in similar direction as cross-section normal
+ if( abs(normal(3)) > 0.6 ) then
+ call get_element_face_gll_indices(iface,face_ijk,NGLLX,NGLLX)
+ do jj = 1, NGLLY
+ do ii = 1, NGLLX
+ i = face_ijk(1,ii,jj)
+ j = face_ijk(2,ii,jj)
+ k = face_ijk(3,ii,jj)
+ ! sets iglob flag on face points
+ iglob_is_surface_external_mesh(ibool(i,j,k,ispec)) = .true.
+ ! sets ispec flag
+ ispec_is_surface_external_mesh(ispec) = .true.
+ ! resets valence
+ valence_external_mesh(ibool(i,j,k,ispec)) = -1
+ enddo
+ enddo
+ endif
+ endif
+
+ enddo ! iface
+
+ endif
+ enddo
+
! counts faces for external-mesh movies and shakemaps
- nfaces_surface_external_mesh = 0
+ nfaces_surface_ext_mesh = 0
do ispec = 1, nspec
if( ispec_is_surface_external_mesh(ispec) ) then
! zmin face
if (iglob_is_surface_external_mesh(ibool(2,2,1,ispec))) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
endif
! zmax
if (iglob_is_surface_external_mesh(ibool(2,2,NGLLZ,ispec))) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
endif
! ymin
if (iglob_is_surface_external_mesh(ibool(2,1,2,ispec))) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
endif
! ymax
if (iglob_is_surface_external_mesh(ibool(2,NGLLY,2,ispec))) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
endif
!xmin
if (iglob_is_surface_external_mesh(ibool(1,2,2,ispec))) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
endif
!xmax
if (iglob_is_surface_external_mesh(ibool(NGLLX,2,2,ispec))) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
endif
endif
enddo
end subroutine detect_surface_cross_section
+!
+!-------------------------------------------------------------------------------------------------
+!
+ subroutine detect_surface_PNM_GIF_image(NPROC,nglob,nspec,ibool,&
+ ispec_is_image_surface, &
+ iglob_is_image_surface, &
+ num_iglob_image_surface, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,my_neighbours_ext_mesh, &
+ ibool_interfaces_ext_mesh,&
+ section_xorg,section_yorg,section_zorg,&
+ section_nx,section_ny,section_nz,&
+ xstore,ystore,zstore,myrank)
+
+! this returns points on a cross-section surface through model
+!
+! returns: ispec_is_image_surface, iglob_is_image_surface & num_iglob_image_surface
+
+ implicit none
+
+ include "constants.h"
+
+! global indexing
+ integer :: NPROC,nglob,nspec,myrank
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec):: ibool
+
+! surface
+ logical, dimension(nspec) :: ispec_is_image_surface
+ logical, dimension(nglob) :: iglob_is_image_surface
+ integer :: num_iglob_image_surface
+
+! MPI partitions
+ integer :: num_interfaces_ext_mesh
+ integer :: max_nibool_interfaces_ext_mesh
+ integer,dimension(num_interfaces_ext_mesh):: nibool_interfaces_ext_mesh
+ integer,dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh):: ibool_interfaces_ext_mesh
+ integer,dimension(num_interfaces_ext_mesh) :: my_neighbours_ext_mesh
+
+! specified x,y,z - coordinates of cross-section origin and normal to cross-section
+ real(kind=CUSTOM_REAL):: section_xorg,section_yorg,section_zorg
+ real(kind=CUSTOM_REAL):: section_nx,section_ny,section_nz
+
+! mesh global point coordinates
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
+
+!local parameters
+ real(kind=CUSTOM_REAL) :: mindist
+ integer, dimension(:), allocatable :: valence_external_mesh
+ integer :: ispec,i,j,k,iglob,ier,count
+
+! detecting surface points/elements (based on valence check on NGLL points) for external mesh
+ allocate(valence_external_mesh(nglob),stat=ier)
+ if( ier /= 0 ) stop 'error allocate valence array'
+
+! initialize surface indices
+ ispec_is_image_surface(:) = .false.
+ iglob_is_image_surface(:) = .false.
+ valence_external_mesh(:) = 0
+
+! an estimation of the minimum distance between global points
+ mindist = minval( (xstore(ibool(1,1,1,:)) - xstore(ibool(2,1,1,:)))**2 &
+ + (ystore(ibool(1,1,1,:)) - ystore(ibool(2,1,1,:)))**2 &
+ + (zstore(ibool(1,1,1,:)) - zstore(ibool(2,1,1,:)))**2 )
+ mindist = sqrt(mindist)
+
+! sets valence value to one corresponding to process rank for points on cross-sections
+ do ispec = 1, nspec
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! chooses points close to cross-section
+ if( abs((xstore(iglob)-section_xorg)*section_nx + (ystore(iglob)-section_yorg)*section_ny &
+ + (zstore(iglob)-section_zorg)*section_nz ) < 0.8*mindist ) then
+ ! sets valence to 1 for points on cross-sections
+ valence_external_mesh(iglob) = myrank+1
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+! adds contributions from different partitions to valence_external_mesh
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,nglob,valence_external_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+
+! determines spectral elements containing points on surface
+ count = 0
+ do ispec = 1, nspec
+ ! loops over GLL points not on edges or corners, but inside faces
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+ ! considers only points in same process or, if point is shared between two processes,
+ ! only with higher process ranks than itself
+ if (valence_external_mesh(iglob) == myrank+1 .or. valence_external_mesh(iglob) > 2*(myrank+1) ) then
+ if( iglob_is_image_surface(iglob) .eqv. .false. ) count = count+1
+ iglob_is_image_surface(iglob) = .true.
+ ispec_is_image_surface(ispec) = .true.
+ endif
+ enddo
+ enddo
+ enddo
+ enddo ! nspec
+ num_iglob_image_surface = count
+
+ end subroutine detect_surface_PNM_GIF_image
+
+
+
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/flags.guess
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/flags.guess 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/flags.guess 2010-01-06 23:41:13 UTC (rev 16126)
@@ -29,8 +29,8 @@
#FLAGS_CHECK="-O3 -vec-report0 -e95 -std95 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -warn alignments -warn ignore_loc -warn usage -check nobounds -align sequence -assume byterecl -fpe0 -ftz -traceback -ftrapuv" # -mcmodel=medium
# ifort v 10.1 with these flags shows best performance
- #FLAGS_CHECK="-O2 -ftz -xT -vec-report0 -std95 -implicitnone -check nobounds -assume byterecl -static-intel -warn truncated_source -warn argument_checking -warn unused -warn declarations -warn alignments -warn ignore_loc -warn usage "
- FLAGS_CHECK="-O2 -xT -static-intel -r8 -mcmodel=large -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -check nobounds -align sequence -assume byterecl -ftrapuv -fpe0 -ftz -traceback"
+ FLAGS_CHECK="-O2 -ftz -xT -fpe0 -ftz -traceback -ftrapuv -vec-report0 -std95 -implicitnone -check nobounds -assume byterecl -static-intel -warn truncated_source -warn argument_checking -warn unused -warn declarations -warn alignments -warn ignore_loc -warn usage "
+ #FLAGS_CHECK="-O2 -xT -static-intel -r8 -mcmodel=large -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -check nobounds -align sequence -assume byterecl -ftrapuv -fpe0 -ftz -traceback"
fi
if test x"$FLAGS_NO_CHECK" = x; then
# standard options (leave option -ftz, which is *critical* for performance)
@@ -39,8 +39,8 @@
#FLAGS_NO_CHECK="-O3 -xP -vec-report0 -e95 -std95 -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -warn alignments -warn ignore_loc -warn usage -check nobounds -align sequence -assume byterecl -fpe3 -ftz" # -mcmodel=medium
# ifort v 10.1 with these flags shows best performance
- #FLAGS_NO_CHECK="-O2 -ftz -xT -vec-report0 -std95 -implicitnone -check nobounds -assume byterecl -static-intel -warn truncated_source -warn argument_checking -warn unused -warn declarations -warn alignments -warn ignore_loc -warn usage "
- FLAGS_NO_CHECK="-O2 -xT -static-intel -r8 -mcmodel=large -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -check nobounds -align sequence -assume byterecl -ftrapuv -fpe0 -ftz -traceback"
+ FLAGS_NO_CHECK="-O2 -ftz -xT -fpe3 -ftz -vec-report0 -std95 -implicitnone -check nobounds -assume byterecl -static-intel -warn truncated_source -warn argument_checking -warn unused -warn declarations -warn alignments -warn ignore_loc -warn usage "
+ #FLAGS_NO_CHECK="-O2 -xT -static-intel -r8 -mcmodel=large -implicitnone -warn truncated_source -warn argument_checking -warn unused -warn declarations -check nobounds -align sequence -assume byterecl -ftrapuv -fpe0 -ftz -traceback"
fi
;;
gfortran|*/gfortran|f95|*/f95)
@@ -48,7 +48,10 @@
# GNU gfortran
#
if test x"$FLAGS_NO_CHECK" = x; then
- FLAGS_NO_CHECK="-std=f95 -fimplicit-none -frange-check -O3 -fmax-errors=10 -pedantic -pedantic-errors -Waliasing -Wampersand -Wcharacter-truncation -Wline-truncation -Wsurprising -Wno-tabs -Wunderflow -fno-trapping-math" # -mcmodel=medium
+# works with: GNU Fortran (GCC) 4.1.2 20080704
+ FLAGS_NO_CHECK="-std=gnu -fimplicit-none -frange-check -O3 -pedantic -pedantic-errors -Waliasing -Wampersand -Wline-truncation -Wsurprising -Wunderflow -fno-trapping-math"
+
+# FLAGS_NO_CHECK="-std=f95 -fimplicit-none -frange-check -O3 -fmax-errors=10 -pedantic -pedantic-errors -Waliasing -Wampersand -Wcharacter-truncation -Wline-truncation -Wsurprising -Wno-tabs -Wunderflow -fno-trapping-math" # -mcmodel=medium
# older gfortran syntax
# FLAGS_NO_CHECK="-std=f95 -fimplicit-none -frange-check -O3 -Wunused-labels -Waliasing -Wampersand -Wsurprising -Wline-truncation -Wunderflow -fno-trapping-math" # -mcmodel=medium
fi
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -306,7 +306,7 @@
! integer ix,iy
integer,dimension(:),allocatable :: ispec_is_surface_external_mesh,iglob_is_surface_external_mesh
- integer :: nfaces_surface_external_mesh,nfaces_surface_glob_ext_mesh
+ integer :: nfaces_surface_ext_mesh,nfaces_surface_glob_ext_mesh
integer :: i
end module generate_databases_par
@@ -890,7 +890,7 @@
call detect_surface(NPROC,NGLOB_AB,NSPEC_AB,ibool, &
ispec_is_surface_external_mesh, &
iglob_is_surface_external_mesh, &
- nfaces_surface_external_mesh, &
+ nfaces_surface_ext_mesh, &
num_interfaces_ext_mesh, &
max_nibool_interfaces_ext_mesh, &
nibool_interfaces_ext_mesh, &
@@ -904,11 +904,11 @@
! takes number of faces for top, free surface only
if( MOVIE_SURFACE .or. CREATE_SHAKEMAP ) then
- nfaces_surface_external_mesh = NSPEC2D_TOP
+ nfaces_surface_ext_mesh = NSPEC2D_TOP
endif
! number of surface faces for all partitions together
- call sum_all_i(nfaces_surface_external_mesh,nfaces_surface_glob_ext_mesh)
+ call sum_all_i(nfaces_surface_ext_mesh,nfaces_surface_glob_ext_mesh)
! copy number of elements and points in an include file for the solver
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/get_element_face.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/get_element_face.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/get_element_face.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -383,7 +383,7 @@
if( abs(tmp) < TINYVAL ) then
print*,'error get face normal: length',tmp
print*,'normal:',face_n(:)
- stop 'error get element face normal'
+ call exit_mpi(0,'error get element face normal')
endif
face_n(:) = face_n(:)/tmp
@@ -415,8 +415,14 @@
if( tmp > 0.0 ) then
face_n(:) = - face_n(:)
endif
-
-! determines orientation normal and flips direction such that normal points outwards
+
+! in case given normal has zero length, sets it to computed face normal
+ if( ( normal(1)**2 + normal(2)**2 + normal(3)**2 ) < TINYVAL ) then
+ normal(:) = face_n(:)
+ return
+ endif
+
+! otherwise determines orientation of normal and flips direction such that normal points outwards
tmp = face_n(1)*normal(1) + face_n(2)*normal(2) + face_n(3)*normal(3)
if( tmp < 0.0 ) then
!print*,'element face normal: orientation ',ispec,iface,tmp
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -78,19 +78,20 @@
if(NGLLX /= 5 .or. NGLLY /= 5 .or. NGLLZ /= 5) &
stop 'optimized routines from Deville et al. (2002) such as mxm_m1_m2_5points can only be used if NGLL = 5'
endif
-
+
+! should be implemented now...
! absorbing surfaces
- if( ABSORBING_CONDITIONS ) then
- if( .not. USE_DEVILLE_PRODUCTS ) stop 'ABSORPTION only implemented for USE_DEVILLE_PRODUCTS routine'
+! if( ABSORBING_CONDITIONS ) then
+! if( .not. USE_DEVILLE_PRODUCTS ) stop 'ABSORPTION only implemented for USE_DEVILLE_PRODUCTS routine'
+!
+! ! for arbitrary orientation of elements, which face belongs to xmin... -
+! ! does it makes sense to have different NGLLX,NGLLY,NGLLZ?
+! ! there is a problem with absorbing boundaries for faces with different NGLLX,NGLLY,NGLLZ values
+! ! just to be sure for now..
+! if( NGLLX /= NGLLY .and. NGLLY /= NGLLZ ) &
+! stop 'must have NGLLX = NGLLY = NGLLZ'
+! endif
- ! for arbitrary orientation of elements, which face belongs to xmin... -
- ! does it makes sense to have different NGLLX,NGLLY,NGLLZ?
- ! there is a problem with absorbing boundaries for faces with different NGLLX,NGLLY,NGLLZ values
- ! just to be sure for now..
- if( NGLLX /= NGLLY .and. NGLLY /= NGLLZ ) &
- stop 'must have NGLLX = NGLLY = NGLLZ'
- endif
-
! exclusive movie flags
if( EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP ) then
MOVIE_SURFACE = .false.
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -66,11 +66,11 @@
! simulation status output and stability check
if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then
- call iterate_time_check_stability()
+ call it_check_stability()
endif
! update displacement using Newark time scheme
- call iterate_time_update_displacement_scheme()
+ call it_update_displacement_scheme()
! acoustic solver
! (needs to be done first, before elastic one)
@@ -84,22 +84,22 @@
! write the seismograms with time shift
if (nrec_local > 0) then
- call iterate_time_write_seismograms()
+ call it_write_seismograms()
endif
! resetting d/v/a/R/eps for the backward reconstruction with attenuation
if (ATTENUATION ) then
- call iterate_time_store_attenuation_arrays()
+ call it_store_attenuation_arrays()
endif ! ATTENUATION
! shakemap creation
if (EXTERNAL_MESH_CREATE_SHAKEMAP) then
- call iterate_time_create_shakemap_ext_mesh()
+ call it_create_shakemap_em()
endif
! movie file creation
if(EXTERNAL_MESH_MOVIE_SURFACE .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
- call iterate_time_create_movie_surface_ext_mesh()
+ call it_create_movie_surface_em()
endif
! save MOVIE on the SURFACE
@@ -107,7 +107,7 @@
!stop 'DK DK MOVIE_SURFACE has been removed for now because we need a flag to detect the surface elements'
- call iterate_time_movie_surface_output_obsolete()
+ call it_movie_surface_output_o()
endif
! compute SHAKING INTENSITY MAP
@@ -115,14 +115,18 @@
!stop 'DK DK CREATE_SHAKEMAP has been removed for now because we need a flag to detect the surface elements'
- call iterate_time_create_shakemap_obsolete()
+ call it_create_shakemap_o()
endif
! save MOVIE in full 3D MESH
if(MOVIE_VOLUME .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
- call iterate_time_movie_volume_output()
+ call it_movie_volume_output()
endif
+! creates cross-section GIF image
+ if(PNM_GIF_IMAGE .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0 ) then
+ call write_PNM_GIF_create_image()
+ endif
!
!---- end of time iteration loop
!
@@ -133,7 +137,7 @@
!=====================================================================
- subroutine iterate_time_check_stability()
+ subroutine it_check_stability()
! computes the maximum of the norm of the displacement
! in all the slices using an MPI reduction
@@ -246,12 +250,12 @@
endif ! myrank
- end subroutine iterate_time_check_stability
+ end subroutine it_check_stability
!=====================================================================
- subroutine iterate_time_update_displacement_scheme()
+ subroutine it_update_displacement_scheme()
! explicit Newark time scheme with acoustic & elastic domains:
! (see e.g. Hughes, 1987; Chaljub et al., 2003)
@@ -314,11 +318,11 @@
endif
- end subroutine iterate_time_update_displacement_scheme
+ end subroutine it_update_displacement_scheme
!=====================================================================
- subroutine iterate_time_write_seismograms()
+ subroutine it_write_seismograms()
! writes the seismograms with time shift
@@ -587,12 +591,12 @@
endif
endif
- end subroutine iterate_time_write_seismograms
+ end subroutine it_write_seismograms
!================================================================
- subroutine iterate_time_store_attenuation_arrays()
+ subroutine it_store_attenuation_arrays()
! resetting d/v/a/R/eps for the backward reconstruction with attenuation
@@ -640,11 +644,11 @@
endif ! SIMULATION_TYPE
endif ! it
- end subroutine iterate_time_store_attenuation_arrays
+ end subroutine it_store_attenuation_arrays
!================================================================
- subroutine iterate_time_create_shakemap_ext_mesh()
+ subroutine it_create_shakemap_em()
! creation of shapemap file
@@ -660,10 +664,10 @@
store_val_ux_external_mesh(:) = -HUGEVAL
store_val_uy_external_mesh(:) = -HUGEVAL
store_val_uz_external_mesh(:) = -HUGEVAL
- do ispec2D = 1,nfaces_surface_external_mesh
+ do ispec2D = 1,nfaces_surface_ext_mesh
if (USE_HIGHRES_FOR_MOVIES) then
do ipoin = 1, NGLLX*NGLLY
- iglob = faces_surface_external_mesh(ipoin,ispec2D)
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
! x,y,z coordinates
store_val_x_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = xstore(iglob)
store_val_y_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = ystore(iglob)
@@ -671,7 +675,7 @@
enddo
else
do ipoin = 1, 4
- iglob = faces_surface_external_mesh(ipoin,ispec2D)
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
! x,y,z coordinates
store_val_x_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = xstore(iglob)
store_val_y_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = ystore(iglob)
@@ -682,12 +686,12 @@
endif
! stores displacement, velocity and acceleration amplitudes
- do ispec2D = 1,nfaces_surface_external_mesh
- ispec = faces_surface_external_mesh_ispec(ispec2D)
+ do ispec2D = 1,nfaces_surface_ext_mesh
+ ispec = faces_surface_ext_mesh_ispec(ispec2D)
! high-resolution
if (USE_HIGHRES_FOR_MOVIES) then
do ipoin = 1, NGLLX*NGLLY
- iglob = faces_surface_external_mesh(ipoin,ispec2D)
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
! saves norm of displacement,velocity and acceleration vector
if( ispec_is_elastic(ispec) ) then
! norm of displacement
@@ -707,7 +711,7 @@
else
! low-resolution: only corner points outputted
do ipoin = 1, 4
- iglob = faces_surface_external_mesh(ipoin,ispec2D)
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
! saves norm of displacement,velocity and acceleration vector
if( ispec_is_elastic(ispec) ) then
! norm of displacement
@@ -730,41 +734,41 @@
! finalizes shakemap: master process collects all info
if (it == NSTEP) then
if (USE_HIGHRES_FOR_MOVIES) then
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
else
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
endif
@@ -782,12 +786,12 @@
endif
endif
- end subroutine iterate_time_create_shakemap_ext_mesh
+ end subroutine it_create_shakemap_em
!================================================================
- subroutine iterate_time_create_movie_surface_ext_mesh()
+ subroutine it_create_movie_surface_em()
! creation of moviedata files
@@ -803,10 +807,10 @@
! initializes arrays for point coordinates
if (it == NTSTEP_BETWEEN_FRAMES ) then
- do ispec2D = 1,nfaces_surface_external_mesh
+ do ispec2D = 1,nfaces_surface_ext_mesh
if (USE_HIGHRES_FOR_MOVIES) then
do ipoin = 1, NGLLX*NGLLY
- iglob = faces_surface_external_mesh(ipoin,ispec2D)
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
! x,y,z coordinates
store_val_x_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = xstore(iglob)
store_val_y_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = ystore(iglob)
@@ -814,7 +818,7 @@
enddo
else
do ipoin = 1, 4
- iglob = faces_surface_external_mesh(ipoin,ispec2D)
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
! x,y,z coordinates
store_val_x_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = xstore(iglob)
store_val_y_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = ystore(iglob)
@@ -825,8 +829,8 @@
endif
! saves surface velocities
- do ispec2D = 1,nfaces_surface_external_mesh
- ispec = faces_surface_external_mesh_ispec(ispec2D)
+ do ispec2D = 1,nfaces_surface_ext_mesh
+ ispec = faces_surface_ext_mesh_ispec(ispec2D)
if( ispec_is_acoustic(ispec) ) then
! velocity vector
@@ -839,7 +843,7 @@
if (USE_HIGHRES_FOR_MOVIES) then
do ipoin = 1, NGLLX*NGLLY
- iglob = faces_surface_external_mesh(ipoin,ispec2D)
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
! x,y,z coordinates
!store_val_x_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = xstore(iglob)
!store_val_y_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = ystore(iglob)
@@ -878,7 +882,7 @@
enddo
else
do ipoin = 1, 4
- iglob = faces_surface_external_mesh(ipoin,ispec2D)
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
! x,y,z coordinates
!store_val_x_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = xstore(iglob)
!store_val_y_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = ystore(iglob)
@@ -920,45 +924,49 @@
! master process collects all info
if (USE_HIGHRES_FOR_MOVIES) then
+ ! collects locations only once
if (it == NTSTEP_BETWEEN_FRAMES ) then
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
endif
- call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ ! updates/gathers velocity field (high-res)
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
else
+ ! collects locations only once
if (it == NTSTEP_BETWEEN_FRAMES ) then
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
endif
- call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ ! updates/gathers velocity field (low-res)
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
endif
@@ -976,12 +984,12 @@
close(IOUT)
endif
- end subroutine iterate_time_create_movie_surface_ext_mesh
+ end subroutine it_create_movie_surface_em
!=====================================================================
- subroutine iterate_time_movie_surface_output_obsolete()
+ subroutine it_movie_surface_output_o()
! outputs moviedata files
@@ -1108,44 +1116,44 @@
! master process collects all info
if (USE_HIGHRES_FOR_MOVIES) then
if (it == NTSTEP_BETWEEN_FRAMES ) then
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
endif
- call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
else
if (it == NTSTEP_BETWEEN_FRAMES ) then
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
endif
- call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
endif
@@ -1186,12 +1194,12 @@
! close(IOUT)
! endif
- end subroutine iterate_time_movie_surface_output_obsolete
+ end subroutine it_movie_surface_output_o
!=====================================================================
- subroutine iterate_time_create_shakemap_obsolete()
+ subroutine it_create_shakemap_o()
! outputs shakemap file
@@ -1262,41 +1270,41 @@
! save shakemap only at the end of the simulation
if(it == NSTEP) then
if (USE_HIGHRES_FOR_MOVIES) then
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
- call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_external_mesh*NGLLX*NGLLY,&
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
else
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
- call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_external_mesh*NGNOD2D,&
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
endif
@@ -1338,131 +1346,161 @@
!
endif ! NTSTEP
- end subroutine iterate_time_create_shakemap_obsolete
+ end subroutine it_create_shakemap_o
!=====================================================================
- subroutine iterate_time_movie_volume_output()
+ subroutine it_movie_volume_output()
! outputs movie files for div, curl and velocity
use specfem_par
use specfem_par_elastic
+ use specfem_par_acoustic
use specfem_par_movie
+ implicit none
- implicit none
-
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: veloc_element
integer :: ispec,i,j,k,l,iglob
! save velocity here to avoid static offset on displacement for movies
- if( .not. ELASTIC_SIMULATION ) return
+ velocity_movie(:,:,:,:,:) = 0._CUSTOM_REAL
+
+ if( ACOUSTIC_SIMULATION ) then
+ ! uses div as temporary array to store velocity on all gll points
+ do ispec=1,NSPEC_AB
+ if( .not. ispec_is_acoustic(ispec) ) cycle
+ ! calculates velocity
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ velocity_movie(:,:,:,:,ispec) = veloc_element(:,:,:,:)
+ enddo
+ endif ! acoustic
+
! save full snapshot data to local disk
+ if( ELASTIC_SIMULATION ) then
-! calculate strain div and curl
- do ispec=1,NSPEC_AB
+ ! calculate strain div and curl
+ do ispec=1,NSPEC_AB
+ if( .not. ispec_is_elastic(ispec) ) cycle
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
- tempx1l = 0._CUSTOM_REAL
- tempx2l = 0._CUSTOM_REAL
- tempx3l = 0._CUSTOM_REAL
+ tempy1l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
- tempy1l = 0._CUSTOM_REAL
- tempy2l = 0._CUSTOM_REAL
- tempy3l = 0._CUSTOM_REAL
+ tempz1l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
- tempz1l = 0._CUSTOM_REAL
- tempz2l = 0._CUSTOM_REAL
- tempz3l = 0._CUSTOM_REAL
+ do l=1,NGLLX
+ hp1 = hprime_xx(i,l)
+ iglob = ibool(l,j,k,ispec)
+ tempx1l = tempx1l + veloc(1,iglob)*hp1
+ tempy1l = tempy1l + veloc(2,iglob)*hp1
+ tempz1l = tempz1l + veloc(3,iglob)*hp1
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
- do l=1,NGLLX
- hp1 = hprime_xx(i,l)
- iglob = ibool(l,j,k,ispec)
- tempx1l = tempx1l + veloc(1,iglob)*hp1
- tempy1l = tempy1l + veloc(2,iglob)*hp1
- tempz1l = tempz1l + veloc(3,iglob)*hp1
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ hp2 = hprime_yy(j,l)
+ iglob = ibool(i,l,k,ispec)
+ tempx2l = tempx2l + veloc(1,iglob)*hp2
+ tempy2l = tempy2l + veloc(2,iglob)*hp2
+ tempz2l = tempz2l + veloc(3,iglob)*hp2
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- hp2 = hprime_yy(j,l)
- iglob = ibool(i,l,k,ispec)
- tempx2l = tempx2l + veloc(1,iglob)*hp2
- tempy2l = tempy2l + veloc(2,iglob)*hp2
- tempz2l = tempz2l + veloc(3,iglob)*hp2
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ hp3 = hprime_zz(k,l)
+ iglob = ibool(i,j,l,ispec)
+ tempx3l = tempx3l + veloc(1,iglob)*hp3
+ tempy3l = tempy3l + veloc(2,iglob)*hp3
+ tempz3l = tempz3l + veloc(3,iglob)*hp3
+ enddo
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- hp3 = hprime_zz(k,l)
- iglob = ibool(i,j,l,ispec)
- tempx3l = tempx3l + veloc(1,iglob)*hp3
- tempy3l = tempy3l + veloc(2,iglob)*hp3
- tempz3l = tempz3l + veloc(3,iglob)*hp3
- enddo
+ ! get derivatives of ux, uy and uz with respect to x, y and z
-! get derivatives of ux, uy and uz with respect to x, y and z
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
+ dvxdxl(i,j,k) = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ dvxdyl(i,j,k) = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ dvxdzl(i,j,k) = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
- dvxdxl(i,j,k) = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
- dvxdyl(i,j,k) = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
- dvxdzl(i,j,k) = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+ dvydxl(i,j,k) = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
+ dvydyl(i,j,k) = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
+ dvydzl(i,j,k) = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
- dvydxl(i,j,k) = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
- dvydyl(i,j,k) = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
- dvydzl(i,j,k) = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
+ dvzdxl(i,j,k) = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
+ dvzdyl(i,j,k) = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
+ dvzdzl(i,j,k) = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
- dvzdxl(i,j,k) = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
- dvzdyl(i,j,k) = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
- dvzdzl(i,j,k) = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
-
+ enddo
enddo
enddo
- enddo
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- div(i,j,k,ispec) = dvxdxl(i,j,k) + dvydyl(i,j,k) + dvzdzl(i,j,k)
- curl_x(i,j,k,ispec) = dvzdyl(i,j,k) - dvydzl(i,j,k)
- curl_y(i,j,k,ispec) = dvxdzl(i,j,k) - dvzdxl(i,j,k)
- curl_z(i,j,k,ispec) = dvydxl(i,j,k) - dvxdyl(i,j,k)
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ div(i,j,k,ispec) = dvxdxl(i,j,k) + dvydyl(i,j,k) + dvzdzl(i,j,k)
+ curl_x(i,j,k,ispec) = dvzdyl(i,j,k) - dvydzl(i,j,k)
+ curl_y(i,j,k,ispec) = dvxdzl(i,j,k) - dvzdxl(i,j,k)
+ curl_z(i,j,k,ispec) = dvydxl(i,j,k) - dvxdyl(i,j,k)
+
+ iglob = ibool(i,j,k,ispec)
+ velocity_movie(:,i,j,k,ispec) = veloc(:,iglob)
+ enddo
enddo
enddo
- enddo
- enddo !NSPEC_AB
+ enddo !NSPEC_AB
- write(outputname,"('div_proc',i6.6,'_it',i6.6,'.bin')") myrank,it
- open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
- write(27) div
- close(27)
- write(outputname,"('curl_x_proc',i6.6,'_it',i6.6,'.bin')") myrank,it
- open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
- write(27) curl_x
- close(27)
- write(outputname,"('curl_y_proc',i6.6,'_it',i6.6,'.bin')") myrank,it
- open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
- write(27) curl_y
- close(27)
- write(outputname,"('curl_z_proc',i6.6,'_it',i6.6,'.bin')") myrank,it
- open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
- write(27) curl_z
- close(27)
- write(outputname,"('veloc_proc',i6.6,'_it',i6.6,'.bin')") myrank,it
- open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
- write(27) veloc
- close(27)
-
- end subroutine iterate_time_movie_volume_output
+ write(outputname,"('/proc',i6.6,'_div_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file='OUTPUT_FILES'//trim(outputname),status='unknown',form='unformatted')
+ write(27) div
+ close(27)
+ write(outputname,"('/proc',i6.6,'_curl_x_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file='OUTPUT_FILES'//trim(outputname),status='unknown',form='unformatted')
+ write(27) curl_x
+ close(27)
+ write(outputname,"('/proc',i6.6,'_curl_y_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file='OUTPUT_FILES'//trim(outputname),status='unknown',form='unformatted')
+ write(27) curl_y
+ close(27)
+ write(outputname,"('/proc',i6.6,'_curl_z_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file='OUTPUT_FILES'//trim(outputname),status='unknown',form='unformatted')
+ write(27) curl_z
+ close(27)
+
+ !write(outputname,"('veloc_proc',i6.6,'_it',i6.6,'.bin')") myrank,it
+ !open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ !write(27) veloc
+ !close(27)
+
+ endif ! elastic
+
+ if( ACOUSTIC_SIMULATION .or. ELASTIC_SIMULATION ) then
+ write(outputname,"('/proc',i6.6,'_veloc_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file='OUTPUT_FILES'//trim(outputname),status='unknown',form='unformatted')
+ write(27) velocity_movie
+ close(27)
+ endif
+
+ end subroutine it_movie_volume_output
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/parallel.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/parallel.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/parallel.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -99,6 +99,29 @@
!----
!
+ subroutine bcast_all_cr(buffer, count)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer count
+ real(kind=CUSTOM_REAL), dimension(count) :: buffer
+
+ integer ier
+
+ call MPI_BCAST(buffer,count,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+
+ end subroutine bcast_all_cr
+
+!
+!----
+!
+
subroutine bcast_all_dp(buffer, count)
implicit none
@@ -191,6 +214,31 @@
!----
!
+ subroutine gather_all_all_cr(sendbuf, recvbuf, counts, NPROC)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer NPROC,counts
+ real(kind=CUSTOM_REAL), dimension(counts) :: sendbuf
+ real(kind=CUSTOM_REAL), dimension(counts,0:NPROC-1) :: recvbuf
+
+ integer ier
+
+ call MPI_ALLGATHER(sendbuf,counts,CUSTOM_MPI_TYPE,recvbuf,counts,CUSTOM_MPI_TYPE, &
+ MPI_COMM_WORLD,ier)
+
+ end subroutine gather_all_all_cr
+
+!
+!----
+!
+
subroutine gatherv_all_cr(sendbuf, sendcnt, recvbuf, recvcount, recvoffset,recvcounttot, NPROC)
implicit none
@@ -356,7 +404,6 @@
! standard include of the MPI library
include 'mpif.h'
-
include "constants.h"
include "precision.h"
@@ -368,10 +415,32 @@
end subroutine min_all_cr
+
!
!----
!
+ subroutine min_all_all_cr(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+ include "constants.h"
+ include "precision.h"
+
+ real(kind=CUSTOM_REAL):: sendbuf, recvbuf
+ integer ier
+
+ call MPI_ALLREDUCE(sendbuf,recvbuf,1,CUSTOM_MPI_TYPE, &
+ MPI_MIN,MPI_COMM_WORLD,ier)
+
+ end subroutine min_all_all_cr
+
+!
+!----
+!
+
subroutine max_all_i(sendbuf, recvbuf)
implicit none
@@ -394,6 +463,28 @@
!----
!
+ subroutine max_all_all_cr(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+ include "constants.h"
+ include "precision.h"
+
+ real(kind=CUSTOM_REAL):: sendbuf, recvbuf
+ integer ier
+
+ call MPI_ALLREDUCE(sendbuf,recvbuf,1,CUSTOM_MPI_TYPE, &
+ MPI_MAX,MPI_COMM_WORLD,ier)
+
+ end subroutine max_all_all_cr
+
+
+!
+!----
+!
+
subroutine min_all_i(sendbuf, recvbuf)
implicit none
@@ -455,6 +546,25 @@
!----
!
+ subroutine sum_all_all_i(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer sendbuf, recvbuf
+ integer ier
+
+ call MPI_ALLREDUCE(sendbuf,recvbuf,1,MPI_INTEGER, &
+ MPI_SUM,MPI_COMM_WORLD,ier)
+
+ end subroutine sum_all_all_i
+
+!
+!----
+!
+
subroutine any_all_l(sendbuf, recvbuf)
implicit none
@@ -622,7 +732,10 @@
! standard include of the MPI library
include 'mpif.h'
- integer recvbuf,recvcount,dest,recvtag
+ integer dest,recvtag
+ integer recvcount
+ !integer recvbuf
+ integer,dimension(recvcount):: recvbuf
integer req(MPI_STATUS_SIZE)
integer ier
@@ -666,7 +779,10 @@
! standard include of the MPI library
include 'mpif.h'
- integer sendbuf,sendcount,dest,sendtag
+ !integer sendbuf,sendcount,dest,sendtag
+ integer dest,sendtag
+ integer sendcount
+ integer,dimension(sendcount):: sendbuf
integer ier
call MPI_SEND(sendbuf,sendcount,MPI_INTEGER,dest,sendtag,MPI_COMM_WORLD,ier)
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -177,26 +177,15 @@
!! DK DK array not created yet for CUBIT
! if (SIMULATION_TYPE == 3) then ! kernel calculation, read in last frame
-
! open(unit=27,file=trim(prname)//'save_forward_arrays.bin',status='old',action='read',form='unformatted')
! read(27) b_displ
! read(27) b_veloc
! read(27) b_accel
-
! rho_kl(:,:,:,:) = 0._CUSTOM_REAL
! mu_kl(:,:,:,:) = 0._CUSTOM_REAL
! kappa_kl(:,:,:,:) = 0._CUSTOM_REAL
-
! endif
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) ' time step: ',sngl(DT),' s'
- write(IMAIN,*) 'number of time steps: ',NSTEP
- write(IMAIN,*) 'total simulated time: ',sngl(NSTEP*DT),' seconds'
- write(IMAIN,*)
- endif
-
! distinguish between single and double precision for reals
if(CUSTOM_REAL == SIZE_REAL) then
deltat = sngl(DT)
@@ -366,8 +355,7 @@
! endif
! close(27)
- endif
-
+ endif
! initialize Moho boundary index
! if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
@@ -377,4 +365,21 @@
! k_bot = NGLLZ
! endif
+ ! initializes PML arrays
+ if( ABSORBING_CONDITIONS ) then
+ if( ABSORB_USE_PML ) then
+ call PML_initialize()
+ endif
+ endif
+
+! user output
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' time step: ',sngl(DT),' s'
+ write(IMAIN,*) 'number of time steps: ',NSTEP
+ write(IMAIN,*) 'total simulated time: ',sngl(NSTEP*DT),' seconds'
+ write(IMAIN,*)
+ endif
+
+
end subroutine
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -300,7 +300,15 @@
! check courant criteria on mesh
if( ELASTIC_SIMULATION ) then
call check_mesh_resolution(myrank,NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore, &
- kappastore,mustore,rho_vp,rho_vs,DT )
+ kappastore,mustore,rho_vp,rho_vs,DT,model_speed_max )
+ else if( ACOUSTIC_SIMULATION ) then
+ allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ rho_vp = sqrt( kappastore / rhostore ) * rhostore
+ rho_vs = 0.0_CUSTOM_REAL
+ call check_mesh_resolution(myrank,NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore, &
+ kappastore,mustore,rho_vp,rho_vs,DT,model_speed_max )
+ deallocate(rho_vp,rho_vs)
endif
end subroutine
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/serial.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/serial.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/serial.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -62,6 +62,19 @@
!----
!
+ subroutine bcast_all_cr(buffer, count)
+
+ include "constants.h"
+
+ integer count
+ real(kind=CUSTOM_REAL), dimension(count) :: buffer
+
+ end subroutine bcast_all_cr
+
+!
+!----
+!
+
subroutine bcast_all_dp(buffer, count)
integer count
@@ -123,6 +136,24 @@
!----
!
+ subroutine gather_all_all_cr(sendbuf, recvbuf, counts,NPROC)
+
+ implicit none
+
+ include "constants.h"
+
+ integer NPROC,counts
+ real(kind=CUSTOM_REAL), dimension(counts) :: sendbuf
+ real(kind=CUSTOM_REAL), dimension(counts,0:NPROC-1) :: recvbuf
+
+ recvbuf(:,0) = sendbuf(:)
+
+ end subroutine gather_all_all_cr
+
+!
+!----
+!
+
subroutine gatherv_all_cr(sendbuf, sendcnt, recvbuf, recvcount, recvoffset,recvcounttot, NPROC)
implicit none
@@ -230,6 +261,22 @@
!----
!
+ subroutine max_all_all_cr(sendbuf, recvbuf)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL) sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine max_all_all_cr
+
+!
+!----
+!
+
subroutine min_all_cr(sendbuf, recvbuf)
implicit none
@@ -246,6 +293,22 @@
!----
!
+ subroutine min_all_all_cr(sendbuf, recvbuf)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL) sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine min_all_all_cr
+
+!
+!----
+!
+
subroutine max_all_i(sendbuf, recvbuf)
implicit none
@@ -297,10 +360,24 @@
end subroutine sum_all_i
+
!
!----
!
+ subroutine sum_all_all_i(sendbuf, recvbuf)
+ implicit none
+
+ integer sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine sum_all_all_i
+
+!
+!----
+!
+
subroutine any_all_l(sendbuf, recvbuf)
implicit none
@@ -408,7 +485,10 @@
implicit none
- integer recvbuf,recvcount,dest,recvtag
+ !integer recvbuf,recvcount,dest,recvtag
+ integer dest,recvtag
+ integer recvcount
+ integer,dimension(recvcount):: recvbuf
stop 'recv_i not implemented for serial code'
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -40,11 +40,11 @@
! initializes mesh arrays for movies and shakemaps
allocate(nfaces_perproc_surface_ext_mesh(NPROC))
allocate(faces_surface_offset_ext_mesh(NPROC))
- nfaces_org = nfaces_surface_external_mesh
- if (nfaces_surface_external_mesh == 0) then
+ nfaces_org = nfaces_surface_ext_mesh
+ if (nfaces_surface_ext_mesh == 0) then
! dummy arrays
if (USE_HIGHRES_FOR_MOVIES) then
- allocate(faces_surface_external_mesh(NGLLX*NGLLY,1))
+ allocate(faces_surface_ext_mesh(NGLLX*NGLLY,1))
allocate(store_val_x_external_mesh(NGLLX*NGLLY*1))
allocate(store_val_y_external_mesh(NGLLX*NGLLY*1))
allocate(store_val_z_external_mesh(NGLLX*NGLLY*1))
@@ -52,7 +52,7 @@
allocate(store_val_uy_external_mesh(NGLLX*NGLLY*1))
allocate(store_val_uz_external_mesh(NGLLX*NGLLY*1))
else
- allocate(faces_surface_external_mesh(NGNOD2D,1))
+ allocate(faces_surface_ext_mesh(NGNOD2D,1))
allocate(store_val_x_external_mesh(NGNOD2D*1))
allocate(store_val_y_external_mesh(NGNOD2D*1))
allocate(store_val_z_external_mesh(NGNOD2D*1))
@@ -62,30 +62,31 @@
endif
else
if (USE_HIGHRES_FOR_MOVIES) then
- allocate(faces_surface_external_mesh(NGLLX*NGLLY,nfaces_surface_external_mesh))
- allocate(store_val_x_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
- allocate(store_val_y_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
- allocate(store_val_z_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
- allocate(store_val_ux_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
- allocate(store_val_uy_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
- allocate(store_val_uz_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
+ allocate(faces_surface_ext_mesh(NGLLX*NGLLY,nfaces_surface_ext_mesh))
+ allocate(store_val_x_external_mesh(NGLLX*NGLLY*nfaces_surface_ext_mesh))
+ allocate(store_val_y_external_mesh(NGLLX*NGLLY*nfaces_surface_ext_mesh))
+ allocate(store_val_z_external_mesh(NGLLX*NGLLY*nfaces_surface_ext_mesh))
+ allocate(store_val_ux_external_mesh(NGLLX*NGLLY*nfaces_surface_ext_mesh))
+ allocate(store_val_uy_external_mesh(NGLLX*NGLLY*nfaces_surface_ext_mesh))
+ allocate(store_val_uz_external_mesh(NGLLX*NGLLY*nfaces_surface_ext_mesh))
else
- allocate(faces_surface_external_mesh(NGNOD2D,nfaces_surface_external_mesh))
- allocate(store_val_x_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
- allocate(store_val_y_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
- allocate(store_val_z_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
- allocate(store_val_ux_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
- allocate(store_val_uy_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
- allocate(store_val_uz_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
+ allocate(faces_surface_ext_mesh(NGNOD2D,nfaces_surface_ext_mesh))
+ allocate(store_val_x_external_mesh(NGNOD2D*nfaces_surface_ext_mesh))
+ allocate(store_val_y_external_mesh(NGNOD2D*nfaces_surface_ext_mesh))
+ allocate(store_val_z_external_mesh(NGNOD2D*nfaces_surface_ext_mesh))
+ allocate(store_val_ux_external_mesh(NGNOD2D*nfaces_surface_ext_mesh))
+ allocate(store_val_uy_external_mesh(NGNOD2D*nfaces_surface_ext_mesh))
+ allocate(store_val_uz_external_mesh(NGNOD2D*nfaces_surface_ext_mesh))
endif
endif
store_val_ux_external_mesh(:) = 0._CUSTOM_REAL
store_val_uy_external_mesh(:) = 0._CUSTOM_REAL
store_val_uz_external_mesh(:) = 0._CUSTOM_REAL
-! number of surface faces for all partitions together
- call sum_all_i(nfaces_surface_external_mesh,nfaces_surface_glob_ext_mesh)
-
+ ! number of surface faces for all partitions together
+ call sum_all_i(nfaces_surface_ext_mesh,nfaces_surface_glob_ext_mesh)
+
+ ! arrays used for collected/gathered fields
if (myrank == 0) then
if (USE_HIGHRES_FOR_MOVIES) then
allocate(store_val_x_all_external_mesh(NGLLX*NGLLY*nfaces_surface_glob_ext_mesh))
@@ -103,7 +104,7 @@
allocate(store_val_uz_all_external_mesh(NGNOD2D*nfaces_surface_glob_ext_mesh))
endif
endif
- call gather_all_i(nfaces_surface_external_mesh,1,nfaces_perproc_surface_ext_mesh,1,NPROC)
+ call gather_all_i(nfaces_surface_ext_mesh,1,nfaces_perproc_surface_ext_mesh,1,NPROC)
! array offsets
faces_surface_offset_ext_mesh(1) = 0
@@ -116,13 +117,13 @@
faces_surface_offset_ext_mesh(:) = faces_surface_offset_ext_mesh(:)*NGNOD2D
endif
-! stores global indices of GLL points on the surface to array faces_surface_external_mesh
+! stores global indices of GLL points on the surface to array faces_surface_ext_mesh
if( EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP ) then
- allocate( faces_surface_external_mesh_ispec(nfaces_surface_external_mesh))
+ allocate( faces_surface_ext_mesh_ispec(nfaces_surface_ext_mesh))
! stores global indices
- nfaces_surface_external_mesh = 0
+ nfaces_surface_ext_mesh = 0
do ispec = 1, NSPEC_AB
if (ispec_is_surface_external_mesh(ispec)) then
@@ -130,129 +131,129 @@
! zmin face
iglob = ibool(2,2,1,ispec)
if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- faces_surface_external_mesh_ispec(nfaces_surface_external_mesh) = ispec
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ faces_surface_ext_mesh_ispec(nfaces_surface_ext_mesh) = ispec
if (USE_HIGHRES_FOR_MOVIES) then
ipoin =0
do j = NGLLY, 1, -1
do i = 1, NGLLX
ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,j,1,ispec)
+ faces_surface_ext_mesh(ipoin,nfaces_surface_ext_mesh) = ibool(i,j,1,ispec)
enddo
enddo
else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,1,1,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(1,NGLLY,1,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,1,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(NGLLX,1,1,ispec)
+ faces_surface_ext_mesh(1,nfaces_surface_ext_mesh) = ibool(1,1,1,ispec)
+ faces_surface_ext_mesh(2,nfaces_surface_ext_mesh) = ibool(1,NGLLY,1,ispec)
+ faces_surface_ext_mesh(3,nfaces_surface_ext_mesh) = ibool(NGLLX,NGLLY,1,ispec)
+ faces_surface_ext_mesh(4,nfaces_surface_ext_mesh) = ibool(NGLLX,1,1,ispec)
endif
endif
! zmax face
iglob = ibool(2,2,NGLLZ,ispec)
if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- faces_surface_external_mesh_ispec(nfaces_surface_external_mesh) = ispec
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ faces_surface_ext_mesh_ispec(nfaces_surface_ext_mesh) = ispec
if (USE_HIGHRES_FOR_MOVIES) then
ipoin =0
do j = 1, NGLLY
do i = 1, NGLLX
ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,j,NGLLZ,ispec)
+ faces_surface_ext_mesh(ipoin,nfaces_surface_ext_mesh) = ibool(i,j,NGLLZ,ispec)
enddo
enddo
else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,1,NGLLZ,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
+ faces_surface_ext_mesh(1,nfaces_surface_ext_mesh) = ibool(1,1,NGLLZ,ispec)
+ faces_surface_ext_mesh(2,nfaces_surface_ext_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
+ faces_surface_ext_mesh(3,nfaces_surface_ext_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ faces_surface_ext_mesh(4,nfaces_surface_ext_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
endif
endif
! ymin face
iglob = ibool(2,1,2,ispec)
if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- faces_surface_external_mesh_ispec(nfaces_surface_external_mesh) = ispec
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ faces_surface_ext_mesh_ispec(nfaces_surface_ext_mesh) = ispec
if (USE_HIGHRES_FOR_MOVIES) then
ipoin =0
do k = 1, NGLLZ
do i = 1, NGLLX
ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,1,k,ispec)
+ faces_surface_ext_mesh(ipoin,nfaces_surface_ext_mesh) = ibool(i,1,k,ispec)
enddo
enddo
else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,1,1,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(NGLLX,1,1,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(1,1,NGLLZ,ispec)
+ faces_surface_ext_mesh(1,nfaces_surface_ext_mesh) = ibool(1,1,1,ispec)
+ faces_surface_ext_mesh(2,nfaces_surface_ext_mesh) = ibool(NGLLX,1,1,ispec)
+ faces_surface_ext_mesh(3,nfaces_surface_ext_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
+ faces_surface_ext_mesh(4,nfaces_surface_ext_mesh) = ibool(1,1,NGLLZ,ispec)
endif
endif
! ymax face
iglob = ibool(2,NGLLY,2,ispec)
if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- faces_surface_external_mesh_ispec(nfaces_surface_external_mesh) = ispec
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ faces_surface_ext_mesh_ispec(nfaces_surface_ext_mesh) = ispec
if (USE_HIGHRES_FOR_MOVIES) then
ipoin =0
do k = 1, NGLLZ
do i = NGLLX, 1, -1
ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,NGLLY,k,ispec)
+ faces_surface_ext_mesh(ipoin,nfaces_surface_ext_mesh) = ibool(i,NGLLY,k,ispec)
enddo
enddo
else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,1,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(1,NGLLY,1,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ faces_surface_ext_mesh(1,nfaces_surface_ext_mesh) = ibool(NGLLX,NGLLY,1,ispec)
+ faces_surface_ext_mesh(2,nfaces_surface_ext_mesh) = ibool(1,NGLLY,1,ispec)
+ faces_surface_ext_mesh(3,nfaces_surface_ext_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
+ faces_surface_ext_mesh(4,nfaces_surface_ext_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
endif
endif
! xmin face
iglob = ibool(1,2,2,ispec)
if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- faces_surface_external_mesh_ispec(nfaces_surface_external_mesh) = ispec
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ faces_surface_ext_mesh_ispec(nfaces_surface_ext_mesh) = ispec
if (USE_HIGHRES_FOR_MOVIES) then
ipoin =0
do k = 1, NGLLZ
do j = NGLLY, 1, -1
ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(1,j,k,ispec)
+ faces_surface_ext_mesh(ipoin,nfaces_surface_ext_mesh) = ibool(1,j,k,ispec)
enddo
enddo
else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,NGLLY,1,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(1,1,1,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(1,1,NGLLZ,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
+ faces_surface_ext_mesh(1,nfaces_surface_ext_mesh) = ibool(1,NGLLY,1,ispec)
+ faces_surface_ext_mesh(2,nfaces_surface_ext_mesh) = ibool(1,1,1,ispec)
+ faces_surface_ext_mesh(3,nfaces_surface_ext_mesh) = ibool(1,1,NGLLZ,ispec)
+ faces_surface_ext_mesh(4,nfaces_surface_ext_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
endif
endif
! xmax face
iglob = ibool(NGLLX,2,2,ispec)
if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- faces_surface_external_mesh_ispec(nfaces_surface_external_mesh) = ispec
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ faces_surface_ext_mesh_ispec(nfaces_surface_ext_mesh) = ispec
if (USE_HIGHRES_FOR_MOVIES) then
ipoin =0
do k = 1, NGLLZ
do j = 1, NGLLY
ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(NGLLX,j,k,ispec)
+ faces_surface_ext_mesh(ipoin,nfaces_surface_ext_mesh) = ibool(NGLLX,j,k,ispec)
enddo
enddo
else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(NGLLX,1,1,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,1,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
+ faces_surface_ext_mesh(1,nfaces_surface_ext_mesh) = ibool(NGLLX,1,1,ispec)
+ faces_surface_ext_mesh(2,nfaces_surface_ext_mesh) = ibool(NGLLX,NGLLY,1,ispec)
+ faces_surface_ext_mesh(3,nfaces_surface_ext_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ faces_surface_ext_mesh(4,nfaces_surface_ext_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
endif
endif
endif
enddo ! NSPEC_AB
! checks number of faces
- if( nfaces_surface_external_mesh /= nfaces_org ) then
- print*,'error number of movie faces: ',nfaces_surface_external_mesh,nfaces_org
+ if( nfaces_surface_ext_mesh /= nfaces_org ) then
+ print*,'error number of movie faces: ',nfaces_surface_ext_mesh,nfaces_org
call exit_mpi(myrank,'error number of faces')
endif
endif
@@ -260,7 +261,7 @@
! user output
if (myrank == 0) then
if( PLOT_CROSS_SECTIONS ) write(IMAIN,*) 'movie: cross-sections'
- write(IMAIN,*) 'movie: nfaces_surface_external_mesh = ',nfaces_surface_external_mesh
+ write(IMAIN,*) 'movie: nfaces_surface_ext_mesh = ',nfaces_surface_ext_mesh
write(IMAIN,*) 'movie: nfaces_perproc_surface_ext_mesh = ',nfaces_perproc_surface_ext_mesh
write(IMAIN,*) 'movie: nfaces_surface_glob_ext_mesh = ',nfaces_surface_glob_ext_mesh
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -51,7 +51,7 @@
call setup_sources_precompute_arrays()
! pre-compute receiver interpolation factors
- call setup_receivers_precompute_interpolations()
+ call setup_receivers_precompute_intp()
! write source and receiver VTK files for Paraview
call setup_sources_receivers_VTKfile()
@@ -152,10 +152,13 @@
implicit none
integer :: isource,ixmin,ixmax,iymin,iymax,izmin,izmax,iface,ispec
- logical :: is_on
+ logical :: is_on,is_on_all
! outputs a warning in case of an acoustic source lying on the free surface
do isource = 1,NSOURCES
+ ! checks if source is close to face
+ is_on = .false.
+
! only receivers in this process
if( myrank == islice_selected_source(isource) ) then
@@ -177,9 +180,6 @@
izmin = minval( free_surface_ijk(3,:,iface) )
izmax = maxval( free_surface_ijk(3,:,iface) )
-
- ! checks if receiver is close to face
- is_on = .false.
if( .not. USE_FORCE_POINT_SOURCE ) then
! xmin face
@@ -224,19 +224,22 @@
endif
endif
- ! user output
- if( is_on ) then
- print*, '**********************************************************************'
- print*, '*** source: ',isource,'in rank:',myrank,' ***'
- print*, '*** Warning: acoustic source located exactly on the free surface ***'
- print*, '*** will be zeroed ***'
- print*, '**********************************************************************'
- print*
- endif
endif ! free_surface_ispec
enddo ! iface
endif ! ispec_is_acoustic
endif ! islice_selected_rec
+
+ ! user output
+ call any_all_l( is_on, is_on_all )
+ if( myrank == 0 .and. is_on_all ) then
+ write(IMAIN,*) '**********************************************************************'
+ write(IMAIN,*) '*** source: ',isource,' ***'
+ write(IMAIN,*) '*** Warning: acoustic source located exactly on the free surface ***'
+ write(IMAIN,*) '*** will be zeroed ***'
+ write(IMAIN,*) '**********************************************************************'
+ write(IMAIN,*)
+ endif
+
enddo ! num_free_surface_faces
@@ -439,10 +442,14 @@
implicit none
integer :: irec,ixmin,ixmax,iymin,iymax,izmin,izmax,iface,ispec
- logical :: is_on
+ logical :: is_on,is_on_all
! outputs a warning in case the receiver is lying on the free surface
do irec = 1,nrec
+
+ ! checks if receiver is close to face
+ is_on = .false.
+
! only receivers in this process
if( myrank == islice_selected_rec(irec) ) then
@@ -464,9 +471,6 @@
izmin = minval( free_surface_ijk(3,:,iface) )
izmax = maxval( free_surface_ijk(3,:,iface) )
-
- ! checks if receiver is close to face
- is_on = .false.
! xmin face
if(ixmin==1 .and. ixmax==1) then
@@ -488,19 +492,22 @@
if( gamma_receiver(irec) > 0.99d0) is_on = .true.
endif
- ! user output
- if( is_on ) then
- print*, '**********************************************************************'
- print*, '*** receiver:',irec,'in rank:',myrank,' ***'
- print*, '*** Warning: acoustic receiver located exactly on the free surface ***'
- print*, '*** Warning: tangential component will be zero there ***'
- print*, '**********************************************************************'
- print*
- endif
endif ! free_surface_ispec
enddo ! iface
endif ! ispec_is_acoustic
endif ! islice_selected_rec
+
+ ! user output
+ call any_all_l( is_on, is_on_all )
+ if( myrank == 0 .and. is_on_all ) then
+ write(IMAIN,*) '**********************************************************************'
+ write(IMAIN,*) '*** station:',irec,' ***'
+ write(IMAIN,*) '*** Warning: acoustic receiver located exactly on the free surface ***'
+ write(IMAIN,*) '*** Warning: tangential component will be zero there ***'
+ write(IMAIN,*) '**********************************************************************'
+ write(IMAIN,*)
+ endif
+
enddo ! num_free_surface_faces
end subroutine setup_receivers_check_acoustic
@@ -510,7 +517,7 @@
!-------------------------------------------------------------------------------------------------
!
-subroutine setup_receivers_precompute_interpolations()
+subroutine setup_receivers_precompute_intp()
use specfem_par
implicit none
@@ -582,7 +589,7 @@
endif
-end subroutine setup_receivers_precompute_interpolations
+end subroutine setup_receivers_precompute_intp
!
!-------------------------------------------------------------------------------------------------
!
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -284,6 +284,9 @@
! real(kind=CUSTOM_REAL) b_Usolidnorm, b_Usolidnorm_all
! ADJOINT
+! maximum speed in velocity model
+ real(kind=CUSTOM_REAL):: model_speed_max
+
!daniel
! integer, dimension(:),allocatable :: spec_inner, spec_outer
! integer :: nspec_inner,nspec_outer
@@ -408,6 +411,8 @@
! to save full 3D snapshot of velocity (movie volume
real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable:: div, curl_x, curl_y, curl_z
+ real(kind=CUSTOM_REAL),dimension(:,:,:,:,:),allocatable:: velocity_movie
+
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dvxdxl,dvxdyl,&
dvxdzl,dvydxl,dvydyl,dvydzl,dvzdxl,dvzdyl,dvzdzl
@@ -439,9 +444,9 @@
! for storing surface of external mesh
integer,dimension(:),allocatable :: nfaces_perproc_surface_ext_mesh
integer,dimension(:),allocatable :: faces_surface_offset_ext_mesh
- integer,dimension(:,:),allocatable :: faces_surface_external_mesh
- integer,dimension(:),allocatable :: faces_surface_external_mesh_ispec
- integer :: nfaces_surface_external_mesh
+ integer,dimension(:,:),allocatable :: faces_surface_ext_mesh
+ integer,dimension(:),allocatable :: faces_surface_ext_mesh_ispec
+ integer :: nfaces_surface_ext_mesh
integer :: nfaces_surface_glob_ext_mesh
integer :: iorderi(NGNOD2D),iorderj(NGNOD2D)
Added: seismo/3D/SPECFEM3D_SESAME/trunk/write_PNM_GIF_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/write_PNM_GIF_data.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/write_PNM_GIF_data.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -0,0 +1,852 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ module image_PNM_GIF_par
+
+ use constants,only: CUSTOM_REAL,IMAIN
+ use specfem_par,only: myrank,NPROC,it
+
+ ! ----------------------------------------------
+ ! USER PARAMETER
+
+ ! image data output:
+ ! type = 1 : velocity V_x component
+ ! type = 2 : velocity V_y component
+ ! type = 3 : velocity V_z component
+ ! type = 4 : velocity V norm
+ integer,parameter:: IMAGE_TYPE = 2
+
+ ! cross-section surface
+ ! cross-section origin point
+ real(kind=CUSTOM_REAL),parameter:: section_xorg = 67000.0
+ real(kind=CUSTOM_REAL),parameter:: section_yorg = 0.0
+ real(kind=CUSTOM_REAL),parameter:: section_zorg = 0.0
+
+ ! cross-section surface normal
+ real(kind=CUSTOM_REAL),parameter:: section_nx = 1.0
+ real(kind=CUSTOM_REAL),parameter:: section_ny = 0.0
+ real(kind=CUSTOM_REAL),parameter:: section_nz = 0.0
+
+ ! cross-section (in-plane) horizontal-direction
+ real(kind=CUSTOM_REAL),parameter:: section_hdirx = 0.0
+ real(kind=CUSTOM_REAL),parameter:: section_hdiry = 1.0
+ real(kind=CUSTOM_REAL),parameter:: section_hdirz = 0.0
+
+ ! cross-section (in-plane) vertical-direction
+ real(kind=CUSTOM_REAL),parameter:: section_vdirx = 0.0
+ real(kind=CUSTOM_REAL),parameter:: section_vdiry = 0.0
+ real(kind=CUSTOM_REAL),parameter:: section_vdirz = 1.0
+
+ ! non linear display to enhance small amplitudes in color images
+ real(kind=CUSTOM_REAL), parameter :: POWER_DISPLAY_COLOR = 0.30_CUSTOM_REAL
+
+ ! amplitude threshold
+ real(kind=CUSTOM_REAL),parameter :: image_cutsnaps = 1.e-2
+
+ ! use vp as gray background
+ logical, parameter :: VP_BACKGROUND = .false.
+
+ ! create temporary image files in binary PNM P6 format (smaller)
+ ! or ASCII PNM P3 format (easier to edit)
+ logical, parameter :: BINARY_FILE = .true.
+
+ ! only keeps GIF file
+ logical, parameter :: REMOVE_PNM_FILE = .false.
+ ! ----------------------------------------------
+
+ ! image data
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable:: image_color_vp_display
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable:: image_color_data
+
+ integer,dimension(:,:),allocatable :: iglob_image_color
+ integer,dimension(:,:),allocatable :: ispec_image_color
+
+ ! pixel data
+ real(kind=CUSTOM_REAL),dimension(:),allocatable :: data_pixel_recv
+ real(kind=CUSTOM_REAL),dimension(:),allocatable :: data_pixel_send
+ integer,dimension(:),allocatable :: num_pixel_loc
+ integer,dimension(:),allocatable :: nb_pixel_per_proc
+ integer,dimension(:,:),allocatable :: num_pixel_recv
+ integer :: NX_IMAGE_color,NZ_IMAGE_color
+ integer :: nb_pixel_loc
+
+ end module image_PNM_GIF_par
+
+!=============================================================
+
+ subroutine write_PNM_GIF_initialize()
+
+ use image_PNM_GIF_par
+ use specfem_par,only: NGLOB_AB,NSPEC_AB,ibool,xstore,ystore,zstore,&
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,my_neighbours_ext_mesh, &
+ ibool_interfaces_ext_mesh,prname
+ use constants,only: HUGEVAL,NGLLX,NGLLY,NGLLZ
+ implicit none
+ ! local parameters
+ ! image sizes
+ real(kind=CUSTOM_REAL):: xmin_color_image_loc,xmax_color_image_loc
+ real(kind=CUSTOM_REAL):: xmin_color_image,xmax_color_image
+ real(kind=CUSTOM_REAL):: zmin_color_image_loc,zmax_color_image_loc
+ real(kind=CUSTOM_REAL):: zmin_color_image,zmax_color_image
+ ! image pixels
+ real(kind=CUSTOM_REAL):: size_pixel_horizontal,size_pixel_vertical
+ real(kind=CUSTOM_REAL):: dist_pixel,dist_min_pixel
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable :: dist_pixel_image,dist_pixel_recv
+ real(kind=CUSTOM_REAL):: pixel_midpoint_x,pixel_midpoint_z,x_loc,z_loc,xtmp,ztmp
+ real(kind=CUSTOM_REAL):: ratio
+ integer:: npgeo,npgeo_glob
+ integer:: i,j,k,iproc,iglob,ispec,ier
+ ! data from mesh
+ real(kind=CUSTOM_REAL),dimension(:),allocatable:: xcoord,zcoord
+ integer,dimension(:),allocatable :: iglob_coord,ispec_coord
+ logical,dimension(:),allocatable:: ispec_is_image_surface,iglob_is_image_surface
+ integer :: num_iglob_image_surface
+ integer :: count,loc(1),irank
+ !character(len=256) :: vtkfilename
+ integer :: zoom_factor = 4
+ logical :: zoom
+
+ ! checks image type
+ if(IMAGE_TYPE > 4 .or. IMAGE_TYPE < 1) then
+ call exit_MPI('GIF image type not implemented yet')
+ endif
+
+ ! user output
+ if( myrank == 0 ) then
+ write(IMAIN,*)
+ write(IMAIN,*) '********'
+ ! type = 1 : velocity V_x component
+ if( IMAGE_TYPE == 1 ) write(IMAIN,*) 'GIF image: velocity V_x component'
+ ! type = 2 : velocity V_y component
+ if( IMAGE_TYPE == 2 ) write(IMAIN,*) 'GIF image: velocity V_y component'
+ ! type = 3 : velocity V_z component
+ if( IMAGE_TYPE == 3 ) write(IMAIN,*) 'GIF image: velocity V_z component'
+ ! type = 4 : velocity V norm
+ if( IMAGE_TYPE == 4 ) write(IMAIN,*) 'GIF image: velocity norm'
+ endif
+
+ ! finds global points on image surface
+ allocate(ispec_is_image_surface(NSPEC_AB),iglob_is_image_surface(NGLOB_AB),stat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating image ispec & iglob ')
+
+ call detect_surface_PNM_GIF_image(NPROC,NGLOB_AB,NSPEC_AB,ibool,&
+ ispec_is_image_surface, &
+ iglob_is_image_surface, &
+ num_iglob_image_surface, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,my_neighbours_ext_mesh, &
+ ibool_interfaces_ext_mesh,&
+ section_xorg,section_yorg,section_zorg, &
+ section_nx,section_ny,section_nz, &
+ xstore,ystore,zstore,myrank)
+
+ ! extracts points on surface
+ allocate( xcoord(num_iglob_image_surface),&
+ zcoord(num_iglob_image_surface),&
+ iglob_coord(num_iglob_image_surface),&
+ ispec_coord(num_iglob_image_surface),stat=ier )
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating xyz image coordinates')
+
+ count=0
+ do ispec=1,NSPEC_AB
+ if( ispec_is_image_surface(ispec) ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ if( iglob_is_image_surface(iglob) ) then
+ count = count+1
+ ! coordinates with respect to horizontal and vertical direction
+ xcoord(count)= xstore(iglob)*section_hdirx &
+ + ystore(iglob)*section_hdiry &
+ + zstore(iglob)*section_hdirz
+ zcoord(count)= xstore(iglob)*section_vdirx &
+ + ystore(iglob)*section_vdiry &
+ + zstore(iglob)*section_vdirz
+ iglob_coord(count) = iglob
+ ispec_coord(count) = ispec
+
+ ! reset iglob flag
+ iglob_is_image_surface(iglob) = .false.
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+ if( count /= num_iglob_image_surface) call exit_mpi(myrank,'error image point number')
+
+ !daniel: outputs found global points into vtk file
+ !vtkfilename = prname(1:len_trim(prname))//'GIF_image_points'
+ !call write_VTK_data_points(NGLOB_AB,xstore,ystore,zstore, &
+ ! iglob_coord,count,vtkfilename)
+
+ ! horizontal size of the image
+ xmin_color_image_loc = minval( xcoord(:) )
+ xmax_color_image_loc = maxval( xcoord(:) )
+
+ ! vertical size
+ zmin_color_image_loc = minval( zcoord(:) )
+ zmax_color_image_loc = maxval( zcoord(:) )
+
+ ! global values
+ xmin_color_image = xmin_color_image_loc
+ xmax_color_image = xmax_color_image_loc
+ zmin_color_image = zmin_color_image_loc
+ zmax_color_image = zmax_color_image_loc
+
+ ! global number of points on image slice
+ npgeo = num_iglob_image_surface
+ npgeo_glob = npgeo
+
+ !MPI for all processes
+ ! takes minimum of all process and stores it in xmin_color_image
+ call min_all_all_cr(xmin_color_image_loc,xmin_color_image)
+ call min_all_all_cr(zmin_color_image_loc,zmin_color_image)
+ call max_all_all_cr(xmax_color_image_loc,xmax_color_image)
+ call max_all_all_cr(zmax_color_image_loc,zmax_color_image)
+ call sum_all_all_i(npgeo,npgeo_glob)
+
+ ! compute number of pixels in the horizontal direction and pixels in the vertical
+ ! direction based on ratio of sizes
+ ratio = abs(xmax_color_image - xmin_color_image)/abs(zmax_color_image - zmin_color_image)
+ NX_IMAGE_color = nint( sqrt( ratio * dble(npgeo_glob) ) )
+ NZ_IMAGE_color = nint( dble(npgeo_glob) / NX_IMAGE_color )
+
+ ! convert pixel sizes to even numbers because easier to reduce size,
+ ! create MPEG movies in postprocessing
+ NX_IMAGE_color = 2 * (NX_IMAGE_color / 2)
+ NZ_IMAGE_color = 2 * (NZ_IMAGE_color / 2)
+
+ ! check that image size is not too big
+ if( NX_IMAGE_color > 4096 .or. NZ_IMAGE_color > 4096 ) then
+ ! half of it
+ NX_IMAGE_color = NX_IMAGE_color / 2
+ NZ_IMAGE_color = NZ_IMAGE_color / 2
+ ! even numbers
+ NX_IMAGE_color = 2 * (NX_IMAGE_color / 2)
+ NZ_IMAGE_color = 2 * (NZ_IMAGE_color / 2)
+ endif
+
+ ! ...and not too small
+ zoom = .false.
+ if( NX_IMAGE_color < 200 .or. NZ_IMAGE_color < 200 ) then
+ ! increases it
+ NX_IMAGE_color = NX_IMAGE_color * zoom_factor
+ NZ_IMAGE_color = NZ_IMAGE_color * zoom_factor
+ zoom = .true.
+ endif
+
+ ! create all the pixels
+ size_pixel_horizontal = (xmax_color_image - xmin_color_image) / dble(NX_IMAGE_color)
+ size_pixel_vertical = (zmax_color_image - zmin_color_image) / dble(NZ_IMAGE_color)
+
+ if (myrank == 0) then
+ write(IMAIN,*) ' image points: ',npgeo_glob
+ write(IMAIN,*) ' xmin/xmax: ',xmin_color_image,'/',xmax_color_image
+ write(IMAIN,*) ' zmin/zmax: ',zmin_color_image,'/',zmax_color_image
+ write(IMAIN,*) ' pixel numbers: ',NX_IMAGE_color,' x ',NZ_IMAGE_color
+ write(IMAIN,*) ' pixel sizes : ',size_pixel_horizontal,' x ',size_pixel_vertical
+ endif
+
+ ! allocate an array for the grid point that corresponds to a given image data point
+ allocate(iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color),&
+ ispec_image_color(NX_IMAGE_color,NZ_IMAGE_color),stat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating iglob_image_color')
+
+ allocate(dist_pixel_image(NX_IMAGE_color,NZ_IMAGE_color),stat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating dist pixel image')
+
+ iglob_image_color(:,:) = -1
+ ispec_image_color(:,:) = 0
+ dist_pixel_image(:,:) = HUGEVAL
+ do j=1,NZ_IMAGE_color
+ do i=1,NX_IMAGE_color
+ ! calculates midpoint of pixel
+ xtmp = xmin_color_image + (i-1)*size_pixel_horizontal
+ ztmp = zmin_color_image + (j-1)*size_pixel_vertical
+ pixel_midpoint_x = xtmp + 0.5*size_pixel_horizontal
+ pixel_midpoint_z = ztmp + 0.5*size_pixel_vertical
+
+ ! avoid points on image border rim
+ if( pixel_midpoint_x < xmin_color_image_loc &
+ .or. pixel_midpoint_x > xmax_color_image_loc ) cycle
+ if( pixel_midpoint_z < zmin_color_image_loc &
+ .or. pixel_midpoint_z > zmax_color_image_loc ) cycle
+
+ ! looks for closest point to midpoint of pixel
+ dist_min_pixel = HUGEVAL
+ do iglob=1,num_iglob_image_surface
+ ! point location with respect to image surface
+ x_loc = xcoord(iglob)
+ z_loc = zcoord(iglob)
+
+ ! checks if inside pixel range for larger numbers of points, minimizing computation time
+ if( zoom ) then
+ if( x_loc < xtmp-zoom_factor*size_pixel_horizontal .or. &
+ x_loc > xtmp + (zoom_factor+1)*size_pixel_horizontal ) cycle
+ if( z_loc < ztmp-zoom_factor*size_pixel_vertical .or. &
+ z_loc > ztmp + (zoom_factor+1)*size_pixel_vertical ) cycle
+ else
+ if( x_loc < xtmp .or. x_loc > xtmp + size_pixel_horizontal ) cycle
+ if( z_loc < ztmp .or. z_loc > ztmp + size_pixel_vertical ) cycle
+ endif
+
+ ! stores closest iglob
+ x_loc = pixel_midpoint_x - x_loc
+ z_loc = pixel_midpoint_z - z_loc
+ dist_pixel = x_loc*x_loc + z_loc*z_loc
+ if( dist_pixel < dist_min_pixel) then
+ dist_min_pixel = dist_pixel
+ dist_pixel_image(i,j) = dist_min_pixel
+ iglob_image_color(i,j) = iglob_coord(iglob)
+ ispec_image_color(i,j) = ispec_coord(iglob)
+ endif
+ enddo
+ enddo
+ enddo
+ deallocate(xcoord,zcoord,iglob_coord,ispec_coord)
+
+ ! gather info from other processes as well
+ allocate(dist_pixel_recv(NX_IMAGE_color,0:NPROC-1),stat=ier)
+ if(ier /= 0 ) call exit_mpi(myrank,'error allocating dist pixel recv')
+ dist_pixel_recv(:,:) = HUGEVAL
+ nb_pixel_loc = 0
+ do j=1,NZ_IMAGE_color
+ ! compares with other processes
+ call gather_all_all_cr(dist_pixel_image(:,j),dist_pixel_recv,NX_IMAGE_color,NPROC)
+
+ ! selects entries
+ do i=1,NX_IMAGE_color
+ ! note: minimum location will be between 1 and NPROC
+ loc = minloc(dist_pixel_recv(i,:))
+ irank = loc(1) - 1
+ ! store only own best points
+ if( irank == myrank .and. dist_pixel_recv(i,irank) < HUGEVAL) then
+ ! increases count
+ nb_pixel_loc = nb_pixel_loc + 1
+ else
+ ! resets index
+ iglob_image_color(i,j) = -1
+ ispec_image_color(i,j) = 0
+ endif
+ enddo
+ enddo
+ deallocate(dist_pixel_recv,dist_pixel_image)
+
+ ! creating and filling array num_pixel_loc with the positions of each colored
+ ! pixel owned by the local process (useful for parallel jobs)
+ allocate(num_pixel_loc(nb_pixel_loc))
+ nb_pixel_loc = 0
+ do i = 1, NX_IMAGE_color
+ do j = 1, NZ_IMAGE_color
+ if ( iglob_image_color(i,j) /= -1 ) then
+ nb_pixel_loc = nb_pixel_loc + 1
+ num_pixel_loc(nb_pixel_loc) = (j-1)*NX_IMAGE_color + i
+ endif
+ enddo
+ enddo
+
+ ! filling array iglob_image_color, containing info on which process owns which pixels.
+ allocate(nb_pixel_per_proc(0:NPROC-1))
+ call gather_all_i(nb_pixel_loc,1,nb_pixel_per_proc,1,NPROC)
+
+ ! allocates receiving array
+ if ( myrank == 0 ) then
+ allocate( num_pixel_recv(maxval(nb_pixel_per_proc(:)),0:NPROC-1) )
+ endif
+ ! fills iglob_image_color index array
+ if( NPROC > 1 ) then
+ if (myrank == 0) then
+ do iproc = 1, NPROC-1
+ call recv_i(num_pixel_recv(:,iproc),nb_pixel_per_proc(iproc),iproc,42)
+
+ ! stores proc number instead where iglob_image_color wouldn't be defined (=-1)
+ do k = 1, nb_pixel_per_proc(iproc)
+ j = ceiling(real(num_pixel_recv(k,iproc)) / real(NX_IMAGE_color))
+ i = num_pixel_recv(k,iproc) - (j-1)*NX_IMAGE_color
+ iglob_image_color(i,j) = iproc
+ enddo
+ enddo
+ else
+ call send_i(num_pixel_loc(:),nb_pixel_loc,0,42)
+ endif
+ endif
+
+ ! allocate an array for image data
+ allocate(image_color_data(NX_IMAGE_color,NZ_IMAGE_color), &
+ image_color_vp_display(NX_IMAGE_color,NZ_IMAGE_color),stat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating image data')
+
+ image_color_data(:,:) = 0._CUSTOM_REAL
+ image_color_vp_display(:,:) = 0._CUSTOM_REAL
+
+ if ( myrank == 0 ) then
+ allocate( data_pixel_recv(maxval(nb_pixel_per_proc(:))) )
+ data_pixel_recv(:) = 0._CUSTOM_REAL
+ endif
+ allocate(data_pixel_send(nb_pixel_loc),stat=ier)
+ if(ier /= 0 ) call exit_mpi(myrank,'error allocating image send data')
+ data_pixel_send(:) = 0._CUSTOM_REAL
+
+ ! handles vp background data
+ call write_PNM_GIF_vp_background()
+
+ ! user output
+ if( myrank == 0 ) then
+ write(IMAIN,*) '******** '
+ write(IMAIN,*)
+ endif
+
+
+ end subroutine write_PNM_GIF_initialize
+
+
+!=============================================================
+
+
+ subroutine write_PNM_GIF_vp_background
+
+ use image_PNM_GIF_par
+ use specfem_par,only:myrank
+ implicit none
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: vp
+ integer :: i,j,k,iglob,ispec,iproc
+
+ ! getting velocity for each local pixels
+ image_color_vp_display(:,:) = 0.d0
+
+ do k = 1, nb_pixel_loc
+ j = ceiling(real(num_pixel_loc(k)) / real(NX_IMAGE_color))
+ i = num_pixel_loc(k) - (j-1)*NX_IMAGE_color
+
+ iglob = iglob_image_color(i,j)
+ ispec = ispec_image_color(i,j)
+ call get_iglob_vp(iglob,ispec,vp)
+
+ data_pixel_send(k) = vp
+ image_color_vp_display(i,j) = vp
+ enddo
+
+ ! MPI assembling array image_color_vp_display on process zero for color output
+ if (NPROC > 1) then
+ ! master collects
+ if (myrank == 0) then
+ do iproc = 1, NPROC-1
+ call recvv_cr(data_pixel_recv(1),nb_pixel_per_proc(iproc),iproc,43)
+ ! fills vp display array
+ do k = 1, nb_pixel_per_proc(iproc)
+ j = ceiling(real(num_pixel_recv(k,iproc)) / real(NX_IMAGE_color))
+ i = num_pixel_recv(k,iproc) - (j-1)*NX_IMAGE_color
+ image_color_vp_display(i,j) = data_pixel_recv(k)
+ enddo
+ enddo
+ else
+ ! slave processes send
+ call sendv_cr(data_pixel_send,nb_pixel_loc,0,43)
+ endif
+ endif
+
+ end subroutine write_PNM_GIF_vp_background
+
+
+!================================================================
+
+ subroutine write_PNM_GIF_create_image
+
+! creates color PNM/GIF image
+
+ use image_PNM_GIF_par
+ use constants,only: NDIM
+ implicit none
+
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(NDIM) :: veloc_val
+ real(kind=CUSTOM_REAL):: temp
+ integer :: i,j,k,iglob,ispec,iproc
+
+ ! initializes color data
+ image_color_data(:,:) = 0.d0
+
+ ! reads/retrieves color data
+ do k = 1, nb_pixel_loc
+ j = ceiling(real(num_pixel_loc(k)) / real(NX_IMAGE_color))
+ i = num_pixel_loc(k) - (j-1)*NX_IMAGE_color
+
+ ! gets velocity for iglob
+ iglob = iglob_image_color(i,j)
+ ispec = ispec_image_color(i,j)
+ call get_iglob_veloc(iglob,ispec,veloc_val)
+
+ ! data type
+ if( IMAGE_TYPE == 4 ) then
+ ! velocity norm
+ temp = sqrt( veloc_val(1)**2 + veloc_val(2)**2 + veloc_val(3)**2 )
+ else
+ ! velocity component
+ temp = veloc_val(IMAGE_TYPE)
+ endif
+
+ ! stores data
+ image_color_data(i,j) = temp
+ data_pixel_send(k) = temp
+ enddo
+
+ ! MPI assembling array image_color_data on process zero for color output
+ if (NPROC > 1) then
+ if (myrank == 0) then
+ do iproc = 1, NPROC-1
+ call recvv_cr(data_pixel_recv(1),nb_pixel_per_proc(iproc),iproc,43)
+ ! distributes on image pixels
+ do k = 1, nb_pixel_per_proc(iproc)
+ j = ceiling(real(num_pixel_recv(k,iproc)) / real(NX_IMAGE_color))
+ i = num_pixel_recv(k,iproc) - (j-1)*NX_IMAGE_color
+ image_color_data(i,j) = data_pixel_recv(k)
+ enddo
+ enddo
+ else
+ ! slave processes send
+ call sendv_cr(data_pixel_send(1),nb_pixel_loc,0,43)
+ endif
+ endif
+
+ ! master process writes out file
+ if (myrank == 0) then
+ ! writes output file
+ call write_PNM_GIF_data(image_color_data,iglob_image_color,&
+ NX_IMAGE_color,NZ_IMAGE_color,it,image_cutsnaps,image_color_vp_display)
+ endif
+
+
+ end subroutine write_PNM_GIF_create_image
+
+
+!================================================================
+
+
+ subroutine write_PNM_GIF_data(color_image_2D_data,iglob_image_color_2D,&
+ NX,NY,it,cutsnaps,image_color_vp_display)
+
+! display a given field as a red and blue color image
+! to display the snapshots : display image*.gif
+! when compiling with Intel ifort, use " -assume byterecl " option to create binary PNM images
+ use constants,only: HUGEVAL,TINYVAL,CUSTOM_REAL
+ use image_PNM_GIF_par,only: BINARY_FILE,VP_BACKGROUND,&
+ POWER_DISPLAY_COLOR,REMOVE_PNM_FILE
+ implicit none
+
+ integer :: NX,NY,it
+ real(kind=CUSTOM_REAL) :: cutsnaps
+
+ integer, dimension(NX,NY) :: iglob_image_color_2D
+
+ real(kind=CUSTOM_REAL), dimension(NX,NY) :: color_image_2D_data
+ real(kind=CUSTOM_REAL), dimension(NX,NY) :: image_color_vp_display
+
+ ! local parameter
+ integer :: ix,iy,R,G,B,tenthousands,thousands,hundreds,tens,units,remainder,current_rec
+ real(kind=CUSTOM_REAL) :: amplitude_max,normalized_value,vpmin,vpmax,x1
+ character(len=256) :: file_name,system_command
+ ! ASCII code of character '0' and of carriage return character
+ integer, parameter :: ascii_code_of_zero = 48, ascii_code_of_carriage_return = 10
+
+ ! open the image file
+ write(file_name,"('OUTPUT_FILES/image',i7.7,'.pnm')") it
+
+ if(BINARY_FILE) then
+ open(unit=27,file=file_name,status='unknown',access='direct',recl=1)
+ write(27,rec=1) 'P'
+ write(27,rec=2) '6' ! write P6 = binary PNM image format
+ write(27,rec=3) char(ascii_code_of_carriage_return)
+
+ ! compute and write horizontal size
+ remainder = NX
+
+ tenthousands = remainder / 10000
+ remainder = remainder - 10000 * tenthousands
+
+ thousands = remainder / 1000
+ remainder = remainder - 1000 * thousands
+
+ hundreds = remainder / 100
+ remainder = remainder - 100 * hundreds
+
+ tens = remainder / 10
+ remainder = remainder - 10 * tens
+
+ units = remainder
+
+ write(27,rec=4) char(tenthousands + ascii_code_of_zero)
+ write(27,rec=5) char(thousands + ascii_code_of_zero)
+ write(27,rec=6) char(hundreds + ascii_code_of_zero)
+ write(27,rec=7) char(tens + ascii_code_of_zero)
+ write(27,rec=8) char(units + ascii_code_of_zero)
+ write(27,rec=9) ' '
+
+ ! compute and write vertical size
+ remainder = NY
+
+ tenthousands = remainder / 10000
+ remainder = remainder - 10000 * tenthousands
+
+ thousands = remainder / 1000
+ remainder = remainder - 1000 * thousands
+
+ hundreds = remainder / 100
+ remainder = remainder - 100 * hundreds
+
+ tens = remainder / 10
+ remainder = remainder - 10 * tens
+
+ units = remainder
+
+ write(27,rec=10) char(tenthousands + ascii_code_of_zero)
+ write(27,rec=11) char(thousands + ascii_code_of_zero)
+ write(27,rec=12) char(hundreds + ascii_code_of_zero)
+ write(27,rec=13) char(tens + ascii_code_of_zero)
+ write(27,rec=14) char(units + ascii_code_of_zero)
+ write(27,rec=15) char(ascii_code_of_carriage_return)
+
+ ! number of shades
+ write(27,rec=16) '2'
+ write(27,rec=17) '5'
+ write(27,rec=18) '5'
+ write(27,rec=19) char(ascii_code_of_carriage_return)
+
+ ! block of image data starts at sixteenth character
+ current_rec = 20
+ else
+ open(unit=27,file=file_name,status='unknown')
+ write(27,"('P3')") ! write P3 = ASCII PNM image format
+ write(27,*) NX,NY ! write image size
+ write(27,*) '255' ! number of shades
+ endif
+
+ ! compute maximum amplitude
+ vpmin = HUGEVAL
+ vpmax = TINYVAL
+ do iy=1,NY
+ do ix=1,NX
+ if ( iglob_image_color_2D(ix,iy) > -1 ) then
+ vpmin = min(vpmin,image_color_vp_display(ix,iy))
+ vpmax = max(vpmax,image_color_vp_display(ix,iy))
+ endif
+ enddo
+ enddo
+ amplitude_max = maxval(abs(color_image_2D_data))
+ if( amplitude_max < TINYVAL ) amplitude_max = HUGEVAL
+
+ ! in the PNM format, the image starts in the upper-left corner
+ do iy=NY,1,-1
+ do ix=1,NX
+ ! check if pixel is defined or not (can be above topography for instance)
+ if(iglob_image_color_2D(ix,iy) == -1) then
+ ! use black (/light blue) to display undefined region above topography
+ R = 0 !204
+ G = 0 !255
+ B = 0 !255
+
+ ! suppress small amplitudes considered as noise
+ else if (abs(color_image_2D_data(ix,iy)) < amplitude_max * cutsnaps) then
+
+ if( VP_BACKGROUND ) then
+ ! use P velocity model as background where amplitude is negligible
+ if((vpmax-vpmin)/vpmin > 0.02d0) then
+ x1 = (image_color_vp_display(ix,iy)-vpmin)/(vpmax-vpmin)
+ else
+ x1 = 0.5d0
+ endif
+
+ ! rescale to avoid very dark gray levels
+ x1 = x1*0.7 + 0.2
+ if(x1 > 1.d0) x1=1.d0
+
+ ! invert scale: white = vpmin, dark gray = vpmax
+ x1 = 1.d0 - x1
+
+ ! map to [0,255]
+ x1 = x1 * 255.d0
+
+ R = nint(x1)
+ if(R < 0) R = 0
+ if(R > 255) R = 255
+ G = R
+ B = R
+ else
+ ! white
+ R = 255
+ G = 255
+ B = 255
+ endif
+
+ else
+ ! define normalized image data in [-1:1] and convert to nearest integer
+ ! keeping in mind that data values can be negative
+ normalized_value = color_image_2D_data(ix,iy) / amplitude_max
+
+ ! suppress values outside of [-1:+1]
+ if(normalized_value < -1.d0) normalized_value = -1.d0
+ if(normalized_value > 1.d0) normalized_value = 1.d0
+
+ ! use red if positive value, blue if negative, no green
+ if(normalized_value >= 0.d0) then
+ R = nint(255.d0*normalized_value**POWER_DISPLAY_COLOR)
+ G = 0
+ B = 0
+ else
+ R = 0
+ G = 0
+ B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY_COLOR)
+ endif
+ endif
+
+ ! write color image
+ if(BINARY_FILE) then
+ ! first write red
+ write(27,rec=current_rec) char(R)
+ current_rec = current_rec + 1
+ ! then write green
+ write(27,rec=current_rec) char(G)
+ current_rec = current_rec + 1
+ ! then write blue
+ write(27,rec=current_rec) char(B)
+ current_rec = current_rec + 1
+ else
+ write(27,"(i3,' ',i3,' ',i3)") R,G,B
+ endif
+ enddo
+ enddo
+
+ ! close the file
+ close(27)
+
+ ! open image file and create system command to convert image to more convenient format
+ write(system_command,"('cd OUTPUT_FILES ; convert image',i7.7,'.pnm image',i7.7,'.gif')") it,it
+
+ ! call the system to convert image to GIF
+ call system(system_command)
+
+ ! removes pnm file
+ if( REMOVE_PNM_FILE ) then
+ write(system_command,"('cd OUTPUT_FILES ; rm -f image',i7.7,'.pnm')") it
+ call system(system_command)
+ endif
+
+ end subroutine write_PNM_GIF_data
+
+!=============================================================
+
+ subroutine get_iglob_vp(iglob,ispec,vp)
+
+ use constants,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,FOUR_THIRDS
+ use specfem_par,only: mustore,kappastore,ibool,myrank,NSPEC_AB
+ use specfem_par_acoustic,only: ACOUSTIC_SIMULATION,rhostore
+ use specfem_par_elastic,only: ELASTIC_SIMULATION,rho_vp
+ implicit none
+
+ integer,intent(in) :: iglob,ispec
+ real(kind=CUSTOM_REAL),intent(out):: vp
+
+ !local parameters
+ integer :: i,j,k
+
+ ! returns first vp encountered for iglob index
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( ibool(i,j,k,ispec) == iglob ) then
+ ! calculates vp
+ if( ELASTIC_SIMULATION ) then
+ vp = (FOUR_THIRDS * mustore(i,j,k,ispec) + kappastore(i,j,k,ispec)) / rho_vp(i,j,k,ispec)
+ else if( ACOUSTIC_SIMULATION ) then
+ vp = sqrt( kappastore(i,j,k,ispec) / rhostore(i,j,k,ispec) )
+ else
+ call exit_mpi(myrank,'error vp not implemented')
+ endif
+ return
+ endif
+ enddo
+ enddo
+ enddo
+
+ end subroutine get_iglob_vp
+
+!=============================================================
+
+ subroutine get_iglob_veloc(iglob,ispec,veloc_val)
+
+ use constants,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,NDIM
+ use specfem_par_acoustic,only: ACOUSTIC_SIMULATION,potential_dot_acoustic,&
+ rhostore,ispec_is_acoustic
+ use specfem_par_elastic,only: ELASTIC_SIMULATION,veloc,ispec_is_elastic
+ use specfem_par,only: NSPEC_AB,NGLOB_AB,hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool
+ implicit none
+
+ integer,intent(in) :: iglob,ispec
+ real(kind=CUSTOM_REAL),dimension(NDIM),intent(out):: veloc_val
+
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: veloc_element
+ integer :: i,j,k
+
+ ! returns first element encountered for iglob index
+ if( ELASTIC_SIMULATION ) then
+ if( ispec_is_elastic(ispec) ) then
+ veloc_val(:) = veloc(:,iglob)
+ return
+ endif
+ endif
+ if( ACOUSTIC_SIMULATION ) then
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! returns corresponding iglob velocity entry
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( ibool(i,j,k,ispec) == iglob ) then
+ veloc_val(:) = veloc_element(:,i,j,k)
+ return
+ endif
+ enddo
+ enddo
+ enddo
+
+ endif
+ endif
+
+ ! should not reach this point
+ call exit_mpi(0,'error image velocity not found')
+
+ end subroutine get_iglob_veloc
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/write_VTK_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/write_VTK_data.f90 2010-01-05 18:43:28 UTC (rev 16125)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/write_VTK_data.f90 2010-01-06 23:41:13 UTC (rev 16126)
@@ -27,8 +27,8 @@
! routine for saving vtk file holding integer flag on each spectral element
subroutine write_VTK_data_elem_i(nspec,nglob, &
- xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
- elem_flag,prname_file)
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ elem_flag,prname_file)
implicit none
@@ -57,26 +57,26 @@
write(IOVTK,'(a)') 'material model VTK file'
write(IOVTK,'(a)') 'ASCII'
write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
- write(IOVTK, '(a,i,a)') 'POINTS ', nglob, ' float'
+ write(IOVTK, '(a,i12,a)') 'POINTS ', nglob, ' float'
do i=1,nglob
- write(IOVTK,'(3f)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
+ write(IOVTK,'(3e18.6)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
enddo
write(IOVTK,*) ""
! note: indices for vtk start at 0
- write(IOVTK,'(a,i,i)') "CELLS ",nspec,nspec*9
+ write(IOVTK,'(a,i12,i12)') "CELLS ",nspec,nspec*9
do ispec=1,nspec
- write(IOVTK,'(9i)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
+ write(IOVTK,'(9i12)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
ibool(1,1,NGLLZ,ispec)-1,ibool(NGLLX,1,NGLLZ,ispec)-1,ibool(NGLLX,NGLLY,NGLLZ,ispec)-1,ibool(1,NGLLY,NGLLZ,ispec)-1
enddo
write(IOVTK,*) ""
! type: hexahedrons
- write(IOVTK,'(a,i)') "CELL_TYPES ",nspec
+ write(IOVTK,'(a,i12)') "CELL_TYPES ",nspec
write(IOVTK,*) (12,ispec=1,nspec)
write(IOVTK,*) ""
- write(IOVTK,'(a,i)') "CELL_DATA ",nspec
+ write(IOVTK,'(a,i12)') "CELL_DATA ",nspec
write(IOVTK,'(a)') "SCALARS elem_flag integer"
write(IOVTK,'(a)') "LOOKUP_TABLE default"
do ispec = 1,nspec
@@ -128,22 +128,22 @@
write(IOVTK,'(a)') 'material model VTK file'
write(IOVTK,'(a)') 'ASCII'
write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
- write(IOVTK, '(a,i,a)') 'POINTS ', nglob, ' float'
+ write(IOVTK, '(a,i12,a)') 'POINTS ', nglob, ' float'
do i=1,nglob
- write(IOVTK,'(3f)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
+ write(IOVTK,'(3e18.6)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
enddo
write(IOVTK,*) ""
! note: indices for vtk start at 0
- write(IOVTK,'(a,i,i)') "CELLS ",nspec,nspec*9
+ write(IOVTK,'(a,i12,i12)') "CELLS ",nspec,nspec*9
do ispec=1,nspec
- write(IOVTK,'(9i)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
+ write(IOVTK,'(9i12)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
ibool(1,1,NGLLZ,ispec)-1,ibool(NGLLX,1,NGLLZ,ispec)-1,ibool(NGLLX,NGLLY,NGLLZ,ispec)-1,ibool(1,NGLLY,NGLLZ,ispec)-1
enddo
write(IOVTK,*) ""
! type: hexahedrons
- write(IOVTK,'(a,i)') "CELL_TYPES ",nspec
+ write(IOVTK,'(a,i12)') "CELL_TYPES ",nspec
write(IOVTK,*) (12,ispec=1,nspec)
write(IOVTK,*) ""
@@ -166,7 +166,7 @@
enddo
enddo
- write(IOVTK,'(a,i)') "POINT_DATA ",nglob
+ write(IOVTK,'(a,i12)') "POINT_DATA ",nglob
write(IOVTK,'(a)') "SCALARS gll_data float"
write(IOVTK,'(a)') "LOOKUP_TABLE default"
do i = 1,nglob
@@ -218,22 +218,22 @@
write(IOVTK,'(a)') 'material model VTK file'
write(IOVTK,'(a)') 'ASCII'
write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
- write(IOVTK, '(a,i,a)') 'POINTS ', nglob, ' float'
+ write(IOVTK, '(a,i12,a)') 'POINTS ', nglob, ' float'
do i=1,nglob
- write(IOVTK,'(3f)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
+ write(IOVTK,'(3e18.6)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
enddo
write(IOVTK,*) ""
! note: indices for vtk start at 0
- write(IOVTK,'(a,i,i)') "CELLS ",nspec,nspec*9
+ write(IOVTK,'(a,i12,i12)') "CELLS ",nspec,nspec*9
do ispec=1,nspec
- write(IOVTK,'(9i)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
+ write(IOVTK,'(9i12)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
ibool(1,1,NGLLZ,ispec)-1,ibool(NGLLX,1,NGLLZ,ispec)-1,ibool(NGLLX,NGLLY,NGLLZ,ispec)-1,ibool(1,NGLLY,NGLLZ,ispec)-1
enddo
write(IOVTK,*) ""
! type: hexahedrons
- write(IOVTK,'(a,i)') "CELL_TYPES ",nspec
+ write(IOVTK,'(a,i12)') "CELL_TYPES ",nspec
write(IOVTK,*) (12,ispec=1,nspec)
write(IOVTK,*) ""
@@ -256,7 +256,7 @@
enddo
enddo
- write(IOVTK,'(a,i)') "POINT_DATA ",nglob
+ write(IOVTK,'(a,i12)') "POINT_DATA ",nglob
write(IOVTK,'(a)') "SCALARS gll_data float"
write(IOVTK,'(a)') "LOOKUP_TABLE default"
do i = 1,nglob
@@ -305,7 +305,7 @@
write(IOVTK,'(a)') 'material model VTK file'
write(IOVTK,'(a)') 'ASCII'
write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
- write(IOVTK, '(a,i,a)') 'POINTS ', num_points_globalindices, ' float'
+ write(IOVTK, '(a,i12,a)') 'POINTS ', num_points_globalindices, ' float'
do i=1,num_points_globalindices
iglob = points_globalindices(i)
if( iglob <= 0 .or. iglob > nglob ) then
@@ -315,7 +315,7 @@
stop 'error vtk points file'
endif
- write(IOVTK,'(3f)') xstore_dummy(iglob),ystore_dummy(iglob),zstore_dummy(iglob)
+ write(IOVTK,'(3e18.6)') xstore_dummy(iglob),ystore_dummy(iglob),zstore_dummy(iglob)
enddo
write(IOVTK,*) ""
@@ -323,3 +323,72 @@
end subroutine write_VTK_data_points
+
+
+!=============================================================
+
+! external mesh routine for saving vtk files for points locations
+
+ subroutine write_VTK_data_elem_vectors(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ elem_vector,prname_file)
+
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nspec,nglob
+
+ ! global coordinates
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
+
+ ! element flag array
+ real(kind=CUSTOM_REAL), dimension(3,nspec) :: elem_vector
+ integer :: ispec,i
+
+ ! file name
+ character(len=256) prname_file
+
+ ! write source and receiver VTK files for Paraview
+ write(IMAIN,*) ' vtk file: '
+ write(IMAIN,*) ' ',prname_file(1:len_trim(prname_file))//'.vtk'
+
+ open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
+ write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
+ write(IOVTK,'(a)') 'material model VTK file'
+ write(IOVTK,'(a)') 'ASCII'
+ write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
+ write(IOVTK, '(a,i12,a)') 'POINTS ', nglob, ' float'
+ do i=1,nglob
+ write(IOVTK,'(3e18.6)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
+ enddo
+ write(IOVTK,*) ""
+
+ ! note: indices for vtk start at 0
+ write(IOVTK,'(a,i12,i12)') "CELLS ",nspec,nspec*9
+ do ispec=1,nspec
+ write(IOVTK,'(9i12)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
+ ibool(1,1,NGLLZ,ispec)-1,ibool(NGLLX,1,NGLLZ,ispec)-1,ibool(NGLLX,NGLLY,NGLLZ,ispec)-1,ibool(1,NGLLY,NGLLZ,ispec)-1
+ enddo
+ write(IOVTK,*) ""
+
+ ! type: hexahedrons
+ write(IOVTK,'(a,i12)') "CELL_TYPES ",nspec
+ write(IOVTK,*) (12,ispec=1,nspec)
+ write(IOVTK,*) ""
+
+ ! vector data for each cell
+ write(IOVTK,'(a,i12)') "CELL_DATA ",nspec
+ write(IOVTK,'(a)') "VECTORS _vectors_ float"
+ do i=1,nspec
+ write(IOVTK,*) elem_vector(1,i),elem_vector(2,i),elem_vector(3,i)
+ enddo
+
+ write(IOVTK,*) ""
+ close(IOVTK)
+
+
+ end subroutine write_VTK_data_elem_vectors
+
More information about the CIG-COMMITS
mailing list