[cig-commits] r15507 - in seismo/2D/SPECFEM2D/trunk: . DATA
cmorency at geodynamics.org
cmorency at geodynamics.org
Mon Aug 3 10:08:31 PDT 2009
Author: cmorency
Date: 2009-08-03 10:08:30 -0700 (Mon, 03 Aug 2009)
New Revision: 15507
Modified:
seismo/2D/SPECFEM2D/trunk/DATA/Par_file
seismo/2D/SPECFEM2D/trunk/Makefile
seismo/2D/SPECFEM2D/trunk/assemble_MPI.F90
seismo/2D/SPECFEM2D/trunk/checkgrid.F90
seismo/2D/SPECFEM2D/trunk/compute_arrays_source.f90
seismo/2D/SPECFEM2D/trunk/compute_curl_one_element.f90
seismo/2D/SPECFEM2D/trunk/compute_energy.f90
seismo/2D/SPECFEM2D/trunk/compute_forces_acoustic.f90
seismo/2D/SPECFEM2D/trunk/compute_forces_elastic.f90
seismo/2D/SPECFEM2D/trunk/compute_pressure.f90
seismo/2D/SPECFEM2D/trunk/compute_vector_field.f90
seismo/2D/SPECFEM2D/trunk/constants.h
seismo/2D/SPECFEM2D/trunk/gmat01.f90
seismo/2D/SPECFEM2D/trunk/meshfem2D.F90
seismo/2D/SPECFEM2D/trunk/part_unstruct.F90
seismo/2D/SPECFEM2D/trunk/plotpost.F90
seismo/2D/SPECFEM2D/trunk/read_value_parameters.f90
seismo/2D/SPECFEM2D/trunk/specfem2D.F90
Log:
Merging with BIOT
Modified: seismo/2D/SPECFEM2D/trunk/DATA/Par_file
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/Par_file 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/DATA/Par_file 2009-08-03 17:08:30 UTC (rev 15507)
@@ -1,7 +1,7 @@
# title of job, and file that contains interface data
title = Test for M2 UPPA
-interfacesfile = interfaces_M2_UPPA_curved.dat
+interfacesfile = interfaces_reg2layers.dat
# data concerning mesh, when generated using third-party app (more info in README)
read_external_mesh = .false.
@@ -19,16 +19,18 @@
# geometry of the model (origin lower-left corner = 0,0) and mesh description
xmin = 0.d0 # abscissa of left side of the model
-xmax = 4000.d0 # abscissa of right side of the model
-nx = 80 # number of elements along X
+xmax = 4800.d0 # abscissa of right side of the model
+nx = 200 # number of elements along X
ngnod = 9 # number of control nodes per element (4 or 9)
initialfield = .false. # use a plane wave as source or not
add_Bielak_conditions = .false. # add Bielak conditions or not if initial plane wave
assign_external_model = .false. # define external earth model or not
TURN_ANISOTROPY_ON = .false. # turn anisotropy on or off for solid medium
TURN_ATTENUATION_ON = .false. # turn attenuation on or off for solid medium
+TURN_VISCATTENUATION_ON = .false. # turn viscous attenuation on or off
+Q0 = 1 # quality factor for viscous attenuation
+freq0 = 10 # frequency for viscous attenuation
-
# absorbing boundaries parameters
absorbing_conditions = .true. # absorbing boundary active or not
absorbbottom = .true.
@@ -37,21 +39,12 @@
absorbleft = .true.
# time step parameters
-nt = 1600 # total number of time steps
-deltat = 1.d-3 # duration of a time step
+nt = 2600 # total number of time steps
+deltat = 0.5d-3 # duration of a time step
+isolver = 1 # type of simulation 1=forward 2=adjoint + kernels
# source parameters
-source_surf = .false. # source inside the medium or at the surface
-xs = 2000. # source location x in meters
-zs = 1600. # source location z in meters
-source_type = 1 # elastic force or acoustic pressure = 1 or moment tensor = 2
-time_function_type = 1 # Ricker = 1, first derivative = 2, Gaussian = 3, Dirac = 4, Heaviside = 5
-f0 = 8.0 # dominant source frequency (Hz) if not Dirac or Heaviside
-angleforce = 20. # angle of the source (for a force only)
-Mxx = 1. # Mxx component (for a moment tensor source only)
-Mzz = 1. # Mzz component (for a moment tensor source only)
-Mxz = 0. # Mxz component (for a moment tensor source only)
-factor = 1.d10 # amplification factor
+NSOURCE = 1 # number of sources [source info read in CMTSOLUTION file]
force_normal_to_surface = .false. # angleforce normal to surface (external mesh and curve file needed)
# constants for attenuation
@@ -63,22 +56,31 @@
f0_attenuation = 5.196152422706633 # (Hz) relevant only if source is a Dirac or a Heaviside, else it is f0
# receiver line parameters for seismograms
-seismotype = 1 # record 1=displ 2=veloc 3=accel 4=pressure
+seismotype = 1 # record 1=displ 2=veloc 3=accel 4=pressure 5=curl 6=potential
+save_forward = .true. # save the last frame, needed for adjoint simulation
generate_STATIONS = .true. # creates a STATION file in ./DATA
-nreceiverlines = 1 # number of receiver lines
+nreceiverlines = 2 # number of receiver lines
anglerec = 0.d0 # angle to rotate components at receivers
rec_normal_to_surface = .false. # base anglerec normal to surface (external mesh and curve file needed)
# first receiver line
-nrec = 11 # number of receivers
-xdeb = 300. # first receiver x in meters
-zdeb = 2200. # first receiver z in meters
-xfin = 3700. # last receiver x in meters (ignored if onlyone receiver)
-zfin = 2200. # last receiver z in meters (ignored if onlyone receiver)
-enreg_surf = .true. # receivers inside the medium or at the surface
+nrec = 1 # number of receivers
+xdeb = 2000. # first receiver x in meters
+zdeb = 2933.33 # first receiver z in meters
+xfin = 3777. # last receiver x in meters (ignored if onlyone receiver)
+zfin = 1866.67 # last receiver z in meters (ignored if onlyone receiver)
+enreg_surf = .false. # receivers inside the medium or at the surface
+# second receiver line
+nrec = 1 # number of receivers
+xdeb = 2000. # first receiver x in meters
+zdeb = 1866.67 # first receiver z in meters
+xfin = 3777. # last receiver x in meters (ignored if onlyone receiver)
+zfin = 1866.67 # last receiver z in meters (ignored if onlyone receiver)
+enreg_surf = .false. # receivers inside the medium or at the surface
+
# display parameters
-NTSTEP_BETWEEN_OUTPUT_INFO = 100 # display frequency in time steps
+NTSTEP_BETWEEN_OUTPUT_INFO = 200 # display frequency in time steps
output_postscript_snapshot = .true. # output Postscript snapshot of the results
output_color_image = .true. # output color image of the results
imagetype = 1 # display 1=displ 2=veloc 3=accel 4=pressure
@@ -94,17 +96,13 @@
outputgrid = .false. # save the grid in a text file or not
# velocity and density models
-nbmodels = 4 # nb of different models
-# define models as (model_number,1,rho,Vp,Vs,0,0,Qp,Qs) or (model_number,2,rho,c11,c13,c33,c44,Qp,Qs)
-# set Vs to zero to make a given model acoustic
-# the mesh can contain both acoustic and elastic models simultaneously
-1 1 2700.d0 3000.d0 1732.051d0 0 0 10.d0 10.d0
-2 1 2500.d0 2700.d0 0 0 0 136.d0 136.d0 #1558.89d0 0 0 136.d0 136.d0
-3 1 2200.d0 2500.d0 1443.375d0 0 0 136.d0 136.d0
-4 1 2200.d0 2200.d0 1343.375d0 0 0 136.d0 136.d0
+nbmodels = 2 # nb of different models
+# define models as I: (model_number,1,rho,Vp,Vs,0,0,Qp,Qs) or II: (model_number,2,rho,c11,c13,c33,c44,Qp,Qs) or III: (model_number,3,rhos,rhof,phi,c,kxx,kxz,kzz,Ks,Kf,Kfr,etaf,mufr,Qs).
+# For istropic elastic/acoustic material use I and set Vs to zero to make a given model acoustic, for anisotropic elastic use II,
+# and for isotropic poroelastic material use III. The mesh can contain acoustic, elastic, & poroelastic models simultaneously
+1 3 2200.d0 1040.d0 0.4d0 2.0 1d-11 0.d0 1d-11 6.9d9 4.0d9 6.7d9 0.0d-3 3.d9 10.d0 # 2700.d0 3000.d0 1732.051d0 0 0 10.d0 10.d0 0 0 0 0 0 0
+2 1 2500.d0 3000.d0 2000.d0 0 0 10.d0 10.d0 0 0 0 0 0 0 #1558.89d0 0 0 136.d0 136.d0 0 0 0 0 0 0
# define the different regions of the model in the (nx,nz) spectral element mesh
-nbregions = 4 # nb of regions and model number for each
-1 80 1 20 1
-1 80 21 40 2
-1 80 41 60 3
-60 70 21 40 4
+nbregions = 2 # nb of regions and model number for each
+1 200 1 70 2
+1 200 71 140 1
Modified: seismo/2D/SPECFEM2D/trunk/Makefile
===================================================================
--- seismo/2D/SPECFEM2D/trunk/Makefile 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/Makefile 2009-08-03 17:08:30 UTC (rev 15507)
@@ -67,12 +67,19 @@
#FLAGS_CHECK = $(FLAGS_NOCHECK)
# GNU gfortran
-F90 = gfortran
+#F90 = gfortran
#F90 = mpif90 -DUSE_MPI -DUSE_METIS -DUSE_SCOTCH
#F90 = /opt/openmpi-1.2.1/gfortran64/bin/mpif90 -DUSE_MPI -DUSE_METIS -DUSE_SCOTCH
+#CC = gcc
+##FLAGS_NOCHECK = -O3 -march=opteron -m64 -mfpmath=sse,387
+#FLAGS_NOCHECK = -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
+#FLAGS_CHECK = $(FLAGS_NOCHECK) -fbounds-check
+
+# GNU gfortran (yucca)
+#F90 = /opt/openmpi-1.2.1/gfortran64/bin/mpif90 -DUSE_MPI -DUSE_METIS -DUSE_SCOTCH
+F90 = gfortran
CC = gcc
-#FLAGS_NOCHECK = -O3 -march=opteron -m64 -mfpmath=sse,387
-FLAGS_NOCHECK = -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
+FLAGS_NOCHECK = -std=gnu -fimplicit-none -frange-check -O2 -Wunused-labels -Waliasing -Wampersand -Wsurprising -Wline-truncation -Wunderflow
FLAGS_CHECK = $(FLAGS_NOCHECK) -fbounds-check
# IBM
@@ -96,6 +103,7 @@
OBJS_SPECFEM2D = $O/checkgrid.o $O/datim.o $O/enforce_acoustic_free_surface.o\
$O/compute_forces_acoustic.o $O/compute_forces_elastic.o\
+ $O/compute_forces_solid.o $O/compute_forces_fluid.o\
$O/lagrange_poly.o $O/gmat01.o $O/gll_library.o $O/plotgll.o $O/define_derivation_matrices.o\
$O/plotpost.o $O/locate_receivers.o $O/locate_source_force.o $O/compute_gradient_attenuation.o\
$O/specfem2D.o $O/write_seismograms.o $O/define_external_model.o $O/createnum_fast.o $O/createnum_slow.o\
@@ -196,6 +204,14 @@
${F90} $(FLAGS_NOCHECK) -c -o $O/compute_forces_elastic.o compute_forces_elastic.f90
### use optimized compilation option for solver only
+$O/compute_forces_solid.o: compute_forces_solid.f90 constants.h
+ ${F90} $(FLAGS_NOCHECK) -c -o $O/compute_forces_solid.o compute_forces_solid.f90
+
+### use optimized compilation option for solver only
+$O/compute_forces_fluid.o: compute_forces_fluid.f90 constants.h
+ ${F90} $(FLAGS_NOCHECK) -c -o $O/compute_forces_fluid.o compute_forces_fluid.f90
+
+### use optimized compilation option for solver only
$O/compute_gradient_attenuation.o: compute_gradient_attenuation.f90 constants.h
${F90} $(FLAGS_NOCHECK) -c -o $O/compute_gradient_attenuation.o compute_gradient_attenuation.f90
Modified: seismo/2D/SPECFEM2D/trunk/assemble_MPI.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/assemble_MPI.F90 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/assemble_MPI.F90 2009-08-03 17:08:30 UTC (rev 15507)
@@ -42,7 +42,7 @@
!
! This file contains subroutines related to assembling (of the mass matrix, potential_dot_dot and
-! accel_elastic).
+! accel_elastic, accels_poroelastic, accelw_poroelastic).
! These subroutines are for the most part not used in the sequential version.
!
@@ -51,18 +51,18 @@
! build the communication buffers, and determines which elements are considered 'inner'
! (no points in common with other partitions) and 'outer' (at least one point in common
! with neighbouring partitions).
-! We have both acoustic and elastic buffers, for coupling between acoustic and elastic elements
+! We have both acoustic and (poro)elastic buffers, for coupling between acoustic and (poro)elastic elements
! led us to have two sets of communications.
!-----------------------------------------------
subroutine prepare_assemble_MPI (nspec,ibool, &
knods, ngnod, &
- npoin, elastic, &
+ npoin, elastic, poroelastic, &
ninterface, max_interface_size, &
my_nelmnts_neighbours, my_interfaces, &
- ibool_interfaces_acoustic, ibool_interfaces_elastic, &
- nibool_interfaces_acoustic, nibool_interfaces_elastic, &
- inum_interfaces_acoustic, inum_interfaces_elastic, &
- ninterface_acoustic, ninterface_elastic, &
+ ibool_interfaces_acoustic, ibool_interfaces_elastic, ibool_interfaces_poroelastic, &
+ nibool_interfaces_acoustic, nibool_interfaces_elastic, nibool_interfaces_poroelastic, &
+ inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic, &
+ ninterface_acoustic, ninterface_elastic, ninterface_poroelastic, &
mask_ispec_inner_outer &
)
@@ -71,7 +71,7 @@
include 'constants.h'
integer, intent(in) :: nspec, npoin, ngnod
- logical, dimension(nspec), intent(in) :: elastic
+ logical, dimension(nspec), intent(in) :: elastic, poroelastic
integer, dimension(ngnod,nspec), intent(in) :: knods
integer, dimension(NGLLX,NGLLZ,nspec), intent(in) :: ibool
@@ -80,13 +80,13 @@
integer, dimension(ninterface) :: my_nelmnts_neighbours
integer, dimension(4,max_interface_size,ninterface) :: my_interfaces
integer, dimension(NGLLX*max_interface_size,ninterface) :: &
- ibool_interfaces_acoustic,ibool_interfaces_elastic
+ ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
integer, dimension(ninterface) :: &
- nibool_interfaces_acoustic,nibool_interfaces_elastic
+ nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic
integer, dimension(ninterface), intent(out) :: &
- inum_interfaces_acoustic, inum_interfaces_elastic
- integer, intent(out) :: ninterface_acoustic, ninterface_elastic
+ inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic
+ integer, intent(out) :: ninterface_acoustic, ninterface_elastic, ninterface_poroelastic
integer :: num_interface
integer :: ispec_interface
@@ -95,6 +95,7 @@
logical, dimension(npoin) :: mask_ibool_acoustic
logical, dimension(npoin) :: mask_ibool_elastic
+ logical, dimension(npoin) :: mask_ibool_poroelastic
integer :: ixmin, ixmax
integer :: izmin, izmax
@@ -106,6 +107,7 @@
integer :: k
integer :: npoin_interface_acoustic
integer :: npoin_interface_elastic
+ integer :: npoin_interface_poroelastic
integer :: ix,iz
@@ -115,12 +117,16 @@
nibool_interfaces_acoustic(:) = 0
ibool_interfaces_elastic(:,:) = 0
nibool_interfaces_elastic(:) = 0
+ ibool_interfaces_poroelastic(:,:) = 0
+ nibool_interfaces_poroelastic(:) = 0
do num_interface = 1, ninterface
npoin_interface_acoustic = 0
npoin_interface_elastic = 0
+ npoin_interface_poroelastic = 0
mask_ibool_acoustic(:) = .false.
mask_ibool_elastic(:) = .false.
+ mask_ibool_poroelastic(:) = .false.
do ispec_interface = 1, my_nelmnts_neighbours(num_interface)
ispec = my_interfaces(1,ispec_interface,num_interface)
@@ -144,7 +150,16 @@
ibool_interfaces_elastic(npoin_interface_elastic,num_interface)=&
ibool(ix,iz,ispec)
end if
+ else if ( poroelastic(ispec) ) then
+
+ if(.not. mask_ibool_poroelastic(ibool(ix,iz,ispec))) then
+ mask_ibool_poroelastic(ibool(ix,iz,ispec)) = .true.
+ npoin_interface_poroelastic = npoin_interface_poroelastic + 1
+ ibool_interfaces_poroelastic(npoin_interface_poroelastic,num_interface)=&
+ ibool(ix,iz,ispec)
+ end if
else
+
if(.not. mask_ibool_acoustic(ibool(ix,iz,ispec))) then
mask_ibool_acoustic(ibool(ix,iz,ispec)) = .true.
npoin_interface_acoustic = npoin_interface_acoustic + 1
@@ -158,12 +173,14 @@
end do
nibool_interfaces_acoustic(num_interface) = npoin_interface_acoustic
nibool_interfaces_elastic(num_interface) = npoin_interface_elastic
+ nibool_interfaces_poroelastic(num_interface) = npoin_interface_poroelastic
do ispec = 1, nspec
do iz = 1, NGLLZ
do ix = 1, NGLLX
if ( mask_ibool_acoustic(ibool(ix,iz,ispec)) &
- .or. mask_ibool_elastic(ibool(ix,iz,ispec)) ) then
+ .or. mask_ibool_elastic(ibool(ix,iz,ispec)) &
+ .or. mask_ibool_poroelastic(ibool(ix,iz,ispec)) ) then
mask_ispec_inner_outer(ispec) = .true.
endif
@@ -175,6 +192,7 @@
ninterface_acoustic = 0
ninterface_elastic = 0
+ ninterface_poroelastic = 0
do num_interface = 1, ninterface
if ( nibool_interfaces_acoustic(num_interface) > 0 ) then
ninterface_acoustic = ninterface_acoustic + 1
@@ -184,6 +202,10 @@
ninterface_elastic = ninterface_elastic + 1
inum_interfaces_elastic(ninterface_elastic) = num_interface
end if
+ if ( nibool_interfaces_poroelastic(num_interface) > 0 ) then
+ ninterface_poroelastic = ninterface_poroelastic + 1
+ inum_interfaces_poroelastic(ninterface_poroelastic) = num_interface
+ end if
end do
end subroutine prepare_assemble_MPI
@@ -298,9 +320,11 @@
!-----------------------------------------------
! Assembling the mass matrix.
!-----------------------------------------------
-subroutine assemble_MPI_scalar(array_val1, array_val2,npoin, &
+subroutine assemble_MPI_scalar(array_val1, array_val2, array_val3, array_val4,npoin, &
ninterface, max_interface_size, max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el, &
- ibool_interfaces_acoustic,ibool_interfaces_elastic, nibool_interfaces_acoustic,nibool_interfaces_elastic, my_neighbours)
+ max_ibool_interfaces_size_po, &
+ ibool_interfaces_acoustic,ibool_interfaces_elastic, ibool_interfaces_poroelastic, &
+ nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic,my_neighbours)
implicit none
@@ -308,18 +332,19 @@
include 'mpif.h'
! array to assemble
- real(kind=CUSTOM_REAL), dimension(npoin), intent(inout) :: array_val1, array_val2
+ real(kind=CUSTOM_REAL), dimension(npoin), intent(inout) :: array_val1,array_val2,array_val3,array_val4
integer, intent(in) :: npoin
integer, intent(in) :: ninterface
integer, intent(in) :: max_interface_size
- integer, intent(in) :: max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el
+ integer, intent(in) :: max_ibool_interfaces_size_ac,max_ibool_interfaces_size_el,max_ibool_interfaces_size_po
integer, dimension(NGLLX*max_interface_size,ninterface), intent(in) :: &
- ibool_interfaces_acoustic,ibool_interfaces_elastic
- integer, dimension(ninterface), intent(in) :: nibool_interfaces_acoustic,nibool_interfaces_elastic
+ ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
+ integer, dimension(ninterface), intent(in) :: nibool_interfaces_acoustic,nibool_interfaces_elastic, &
+ nibool_interfaces_poroelastic
integer, dimension(ninterface), intent(in) :: my_neighbours
- double precision, dimension(max_ibool_interfaces_size_ac+max_ibool_interfaces_size_el, ninterface) :: &
+ double precision, dimension(max_ibool_interfaces_size_ac+max_ibool_interfaces_size_el+2*max_ibool_interfaces_size_po, ninterface) :: &
buffer_send_faces_scalar, &
buffer_recv_faces_scalar
integer :: msg_status(MPI_STATUS_SIZE)
@@ -344,8 +369,21 @@
array_val2(ibool_interfaces_elastic(i,num_interface))
end do
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ ipoin = ipoin + 1
+ buffer_send_faces_scalar(ipoin,num_interface) = &
+ array_val3(ibool_interfaces_poroelastic(i,num_interface))
+ end do
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ ipoin = ipoin + 1
+ buffer_send_faces_scalar(ipoin,num_interface) = &
+ array_val4(ibool_interfaces_poroelastic(i,num_interface))
+ end do
+
call MPI_ISSEND( buffer_send_faces_scalar(1,num_interface), &
- nibool_interfaces_acoustic(num_interface)+nibool_interfaces_elastic(num_interface), MPI_DOUBLE_PRECISION, &
+ nibool_interfaces_acoustic(num_interface)+nibool_interfaces_elastic(num_interface)+&
+ nibool_interfaces_poroelastic(num_interface)+nibool_interfaces_poroelastic(num_interface), &
+ MPI_DOUBLE_PRECISION, &
my_neighbours(num_interface), 11, &
MPI_COMM_WORLD, msg_requests(num_interface), ier)
@@ -353,7 +391,9 @@
do num_interface = 1, ninterface
call MPI_recv ( buffer_recv_faces_scalar(1,num_interface), &
- nibool_interfaces_acoustic(num_interface)+nibool_interfaces_elastic(num_interface), MPI_DOUBLE_PRECISION, &
+ nibool_interfaces_acoustic(num_interface)+nibool_interfaces_elastic(num_interface)+&
+ nibool_interfaces_poroelastic(num_interface)+nibool_interfaces_poroelastic(num_interface), &
+ MPI_DOUBLE_PRECISION, &
my_neighbours(num_interface), 11, &
MPI_COMM_WORLD, msg_status(1), ier)
@@ -370,6 +410,17 @@
buffer_recv_faces_scalar(ipoin,num_interface)
end do
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ ipoin = ipoin + 1
+ array_val3(ibool_interfaces_poroelastic(i,num_interface)) = array_val3(ibool_interfaces_poroelastic(i,num_interface)) + &
+ buffer_recv_faces_scalar(ipoin,num_interface)
+ end do
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ ipoin = ipoin + 1
+ array_val4(ibool_interfaces_poroelastic(i,num_interface)) = array_val4(ibool_interfaces_poroelastic(i,num_interface)) + &
+ buffer_recv_faces_scalar(ipoin,num_interface)
+ end do
+
end do
call MPI_BARRIER(mpi_comm_world,ier)
@@ -597,6 +648,149 @@
end subroutine assemble_MPI_vector_el
+
+!-----------------------------------------------
+! Assembling accel_elastic for elastic elements :
+! the buffers are filled, the Isend and Irecv are started here, then
+! contributions are added.
+! The previous version included communication overlap using persistent
+! communication, but the merging of the outer and inner elements rendered
+! overlap no longer possible, while persistent communications were removed
+! because trace tool MPITrace does not yet instrument those.
+! Particular care should be taken concerning possible optimisations of the
+! communication scheme.
+!-----------------------------------------------
+subroutine assemble_MPI_vector_po(array_val3,array_val4,npoin, &
+ ninterface, ninterface_poroelastic, &
+ inum_interfaces_poroelastic, &
+ max_interface_size, max_ibool_interfaces_size_po,&
+ ibool_interfaces_poroelastic, nibool_interfaces_poroelastic, &
+ tab_requests_send_recv_poroelastic, &
+ buffer_send_faces_vector_pos,buffer_send_faces_vector_pow, &
+ buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow, &
+ my_neighbours &
+ )
+
+ implicit none
+
+ include 'constants.h'
+ include 'mpif.h'
+ include 'precision_mpi.h'
+
+ ! array to assemble
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin), intent(inout) :: array_val3,array_val4
+
+ integer, intent(in) :: npoin
+ integer, intent(in) :: ninterface, ninterface_poroelastic
+ integer, dimension(ninterface), intent(in) :: inum_interfaces_poroelastic
+ integer, intent(in) :: max_interface_size
+ integer, intent(in) :: max_ibool_interfaces_size_po
+ integer, dimension(NGLLX*max_interface_size,ninterface), intent(in) :: ibool_interfaces_poroelastic
+ integer, dimension(ninterface), intent(in) :: nibool_interfaces_poroelastic
+ integer, dimension(ninterface_poroelastic*4), intent(inout) :: tab_requests_send_recv_poroelastic
+ real(CUSTOM_REAL), dimension(max_ibool_interfaces_size_po,ninterface_poroelastic), intent(inout) :: &
+ buffer_send_faces_vector_pos,buffer_send_faces_vector_pow
+ real(CUSTOM_REAL), dimension(max_ibool_interfaces_size_po,ninterface_poroelastic), intent(inout) :: &
+ buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow
+ integer, dimension(ninterface), intent(in) :: my_neighbours
+
+ integer :: ipoin, num_interface, inum_interface
+ integer :: ier
+ integer, dimension(MPI_STATUS_SIZE) :: status_poroelastic
+
+ integer :: i
+
+
+ do inum_interface = 1, ninterface_poroelastic
+
+ num_interface = inum_interfaces_poroelastic(inum_interface)
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ buffer_send_faces_vector_pos(ipoin+1:ipoin+2,inum_interface) = &
+ array_val3(:,ibool_interfaces_poroelastic(i,num_interface))
+ ipoin = ipoin + 2
+ end do
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ buffer_send_faces_vector_pow(ipoin+1:ipoin+2,inum_interface) = &
+ array_val4(:,ibool_interfaces_poroelastic(i,num_interface))
+ ipoin = ipoin + 2
+ end do
+
+ end do
+
+ do inum_interface = 1, ninterface_poroelastic
+
+ num_interface = inum_interfaces_poroelastic(inum_interface)
+
+ call MPI_ISSEND( buffer_send_faces_vector_pos(1,inum_interface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poroelastic(inum_interface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_pos')
+ end if
+
+ call MPI_Irecv ( buffer_recv_faces_vector_pos(1,inum_interface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poroelastic(ninterface_poroelastic+inum_interface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector_pos')
+ end if
+
+ call MPI_ISSEND( buffer_send_faces_vector_pow(1,inum_interface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poroelastic(ninterface_poroelastic*2+inum_interface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_ISSEND unsuccessful in assemble_MPI_vector_pow')
+ end if
+
+ call MPI_Irecv ( buffer_recv_faces_vector_pow(1,inum_interface), &
+ NDIM*nibool_interfaces_poroelastic(num_interface), CUSTOM_MPI_TYPE, &
+ my_neighbours(num_interface), 12, MPI_COMM_WORLD, &
+ tab_requests_send_recv_poroelastic(ninterface_poroelastic*3+inum_interface), ier)
+
+ if ( ier /= MPI_SUCCESS ) then
+ call exit_mpi('MPI_Irecv unsuccessful in assemble_MPI_vector_pow')
+ end if
+
+ end do
+
+ do inum_interface = 1, ninterface_poroelastic*4
+
+ call MPI_Wait (tab_requests_send_recv_poroelastic(inum_interface), status_poroelastic, ier)
+
+ enddo
+
+ do inum_interface = 1, ninterface_poroelastic
+
+ num_interface = inum_interfaces_poroelastic(inum_interface)
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ array_val3(:,ibool_interfaces_poroelastic(i,num_interface)) = array_val3(:,ibool_interfaces_poroelastic(i,num_interface)) + &
+ buffer_recv_faces_vector_pos(ipoin+1:ipoin+2,inum_interface)
+ ipoin = ipoin + 2
+ end do
+
+ ipoin = 0
+ do i = 1, nibool_interfaces_poroelastic(num_interface)
+ array_val4(:,ibool_interfaces_poroelastic(i,num_interface)) = array_val4(:,ibool_interfaces_poroelastic(i,num_interface)) + &
+ buffer_recv_faces_vector_pow(ipoin+1:ipoin+2,inum_interface)
+ ipoin = ipoin + 2
+ end do
+
+ end do
+
+end subroutine assemble_MPI_vector_po
+
#endif
Modified: seismo/2D/SPECFEM2D/trunk/checkgrid.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/checkgrid.F90 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/checkgrid.F90 2009-08-03 17:08:30 UTC (rev 15507)
@@ -40,9 +40,10 @@
!
!========================================================================
- subroutine checkgrid(vpext,vsext,rhoext,density,elastcoef,ibool,kmato,coord,npoin,vpmin,vpmax, &
- assign_external_model,nspec,UPPER_LIMIT_DISPLAY,numat,deltat,f0,t0,initialfield,time_function_type, &
- coorg,xinterp,zinterp,shapeint,knods,simulation_title,npgeo,pointsdisp,ngnod,any_elastic,myrank,nproc)
+ subroutine checkgrid(vpext,vsext,rhoext,density,poroelastcoef,porosity,tortuosity,ibool,kmato,coord,npoin, &
+ vpImin,vpImax,vpIImin,vpIImax,assign_external_model,nspec,UPPER_LIMIT_DISPLAY,numat,deltat, &
+ f0,t0,initialfield,time_function_type,coorg,xinterp,zinterp,shapeint,knods,simulation_title, &
+ npgeo,pointsdisp,ngnod,any_elastic,any_poroelastic,myrank,nproc,NSOURCE,poroelastic)
! check the mesh, stability and number of points per wavelength
@@ -65,25 +66,34 @@
integer :: icol
#endif
- integer i,j,ispec,material,npoin,nspec,numat,time_function_type
+ integer i,j,ispec,material,npoin,nspec,numat,NSOURCE
+ integer, dimension(NSOURCE) :: time_function_type
+
integer, dimension(nspec) :: kmato
+ logical, dimension(nspec) :: poroelastic
integer, dimension(NGLLX,NGLLX,nspec) :: ibool
- double precision, dimension(numat) :: density
- double precision, dimension(4,numat) :: elastcoef
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(4,3,numat) :: poroelastcoef
+ double precision, dimension(numat) :: porosity,tortuosity
double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
double precision coord(NDIM,npoin)
- double precision vpmin,vpmax,vsmin,vsmax,densmin,densmax,vpmax_local,vpmin_local,vsmin_local
- double precision lambdaplus2mu,mu,denst,cploc,csloc
+ double precision vpImin,vpImax,vsmin,vsmax,densmin,densmax,vpImax_local,vpImin_local,vsmin_local
+ double precision vpIImin,vpIImax,vpIImax_local,vpIImin_local
+ double precision kappa_s,kappa_f,kappa_fr,mu_s,mu_fr,denst_s,denst_f,denst,phi,tort,cpIloc,cpIIloc,csloc
+ double precision afactor,bfactor,cfactor,D_biot,H_biot,C_biot,M_biot,cpIsquare,cpIIsquare,cssquare
+ double precision f0min,f0max
+ double precision lambdaplus2mu,mu
double precision distance_min,distance_max,distance_min_local,distance_max_local
- double precision courant_stability_number_max,lambdaPmin,lambdaPmax,lambdaSmin,lambdaSmax
- double precision f0,t0,deltat,distance_1,distance_2,distance_3,distance_4
+ double precision courant_stability_number_max,lambdaPImin,lambdaPImax,lambdaPIImin,lambdaPIImax, &
+ lambdaSmin,lambdaSmax
+ double precision deltat,distance_1,distance_2,distance_3,distance_4
+ double precision, dimension(NSOURCE) :: f0,t0
+ logical assign_external_model,initialfield,any_elastic,any_poroelastic
- logical assign_external_model,initialfield,any_elastic
-
! for the stability condition
! maximum polynomial degree for which we can compute the stability condition
integer, parameter :: NGLLX_MAX_STABILITY = 15
@@ -92,16 +102,18 @@
integer pointsdisp,npgeo,ngnod,is,ir,in,nnum
double precision :: xmax,zmax,height,usoffset,sizex,sizez,courant_stability_number
- double precision :: x1,z1,x2,z2,ratio_page,xmin,zmin,lambdaS_local,lambdaP_local
+ double precision :: x1,z1,x2,z2,ratio_page,xmin,zmin,lambdaS_local,lambdaPI_local
#ifdef USE_MPI
- double precision :: vpmin_glob,vpmax_glob,vsmin_glob,vsmax_glob,densmin_glob,densmax_glob
+ double precision :: vpImin_glob,vpImax_glob,vsmin_glob,vsmax_glob,densmin_glob,densmax_glob
+ double precision :: vpIImin_glob,vpIImax_glob
double precision :: distance_min_glob,distance_max_glob
- double precision :: courant_stability_max_glob,lambdaPmin_glob,lambdaPmax_glob,lambdaSmin_glob,lambdaSmax_glob
+ double precision :: courant_stability_max_glob,lambdaPImin_glob,lambdaPImax_glob,&
+ lambdaPIImin_glob,lambdaPIImax_glob,lambdaSmin_glob,lambdaSmax_glob
double precision :: xmin_glob, xmax_glob, zmin_glob, zmax_glob
#endif
- logical :: any_elastic_glob
+ logical :: any_elastic_glob,any_poroelastic_glob
double precision, dimension(2,nspec*5) :: coorg_send
double precision, dimension(:,:), allocatable :: coorg_recv
integer, dimension(nspec) :: RGB_send
@@ -1350,10 +1362,10 @@
!---- compute parameters for the spectral elements
- vpmin = HUGEVAL
- vpmax = -HUGEVAL
+ vpImin = HUGEVAL
+ vpImax = -HUGEVAL
- if(any_elastic) then
+ if(any_elastic .or. any_poroelastic) then
vsmin = HUGEVAL
vsmax = -HUGEVAL
else
@@ -1361,6 +1373,14 @@
vsmax = 0
endif
+ if(any_poroelastic) then
+ vpIImin = HUGEVAL
+ vpIImax = -HUGEVAL
+ else
+ vpIImin = 0
+ vpIImax = 0
+ endif
+
densmin = HUGEVAL
densmax = -HUGEVAL
@@ -1369,10 +1389,10 @@
courant_stability_number_max = -HUGEVAL
- lambdaPmin = HUGEVAL
- lambdaPmax = -HUGEVAL
+ lambdaPImin = HUGEVAL
+ lambdaPImax = -HUGEVAL
- if(any_elastic) then
+ if(any_elastic .or. any_poroelastic) then
lambdaSmin = HUGEVAL
lambdaSmax = -HUGEVAL
else
@@ -1380,19 +1400,62 @@
lambdaSmax = 0
endif
+ if(any_poroelastic) then
+ lambdaPIImin = HUGEVAL
+ lambdaPIImax = -HUGEVAL
+ else
+ lambdaPIImin = 0
+ lambdaPIImax = 0
+ endif
+
do ispec=1,nspec
material = kmato(ispec)
+
+ if(poroelastic(ispec)) then
+ phi = porosity(material)
+ tort = tortuosity(material)
+!solid properties
+ mu_s = poroelastcoef(2,1,material)
+ kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
+ denst_s = density(1,material)
+!fluid properties
+ kappa_f = poroelastcoef(1,2,material)
+ denst_f = density(2,material)
+!frame properties
+ mu_fr = poroelastcoef(2,3,material)
+ kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
+ denst = (1.d0 - phi)*denst_s + phi*denst_f
+!Biot coefficients for the input phi
+ D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
+ H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
+ C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
+ M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
+! Approximated velocities (no viscous dissipation)
+ afactor = denst - phi/tort*denst_f
+ bfactor = H_biot + phi*denst/(tort*denst_f)*M_biot - 2.d0*phi/tort*C_biot
+ cfactor = phi/(tort*denst_f)*(H_biot*M_biot - C_biot*C_biot)
+ cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cssquare = mu_fr/afactor
- mu = elastcoef(2,material)
- lambdaplus2mu = elastcoef(3,material)
- denst = density(material)
+ cpIloc = sqrt(cpIsquare)
+ cpIIloc = sqrt(cpIIsquare)
+ csloc = sqrt(cssquare)
+ else
+ mu = poroelastcoef(2,1,material)
+ lambdaplus2mu = poroelastcoef(3,1,material)
+ denst = density(1,material)
- cploc = sqrt(lambdaplus2mu/denst)
+ cpIloc = sqrt(lambdaplus2mu/denst)
+ cpIIloc = 0.d0
csloc = sqrt(mu/denst)
+ endif
- vpmax_local = -HUGEVAL
- vpmin_local = HUGEVAL
+ vpImax_local = -HUGEVAL
+ vpImin_local = HUGEVAL
+ vpIImax_local = -HUGEVAL
+ vpIImin_local = HUGEVAL
vsmin_local = HUGEVAL
distance_min_local = HUGEVAL
@@ -1403,15 +1466,19 @@
!--- if heterogeneous formulation with external velocity model
if(assign_external_model) then
- cploc = vpext(i,j,ispec)
+ cpIloc = vpext(i,j,ispec)
csloc = vsext(i,j,ispec)
denst = rhoext(i,j,ispec)
endif
!--- compute min and max of velocity and density models
- vpmin = min(vpmin,cploc)
- vpmax = max(vpmax,cploc)
+ vpImin = min(vpImin,cpIloc)
+ vpImax = max(vpImax,cpIloc)
+! ignore acoustic and elastic regions with cpII = 0
+ if(cpIIloc > 0.0001d0) vpIImin = min(vpIImin,cpIIloc)
+ vpIImax = max(vpIImax,cpIIloc)
+
! ignore fluid regions with Vs = 0
if(csloc > 0.0001d0) vsmin = min(vsmin,csloc)
vsmax = max(vsmax,csloc)
@@ -1419,9 +1486,11 @@
densmin = min(densmin,denst)
densmax = max(densmax,denst)
- vpmax_local = max(vpmax_local,cploc)
- vpmin_local = min(vpmin_local,cploc)
- vsmin_local = min(vsmin_local,csloc)
+ vpImax_local = max(vpImax_local,vpImax)
+ vpImin_local = min(vpImin_local,vpImin)
+ vpIImax_local = max(vpIImax_local,vpIImax)
+ vpIImin_local = min(vpIImin_local,vpIImin)
+ vsmin_local = min(vsmin_local,vsmin)
enddo
enddo
@@ -1445,7 +1514,7 @@
distance_min = min(distance_min,distance_min_local)
distance_max = max(distance_max,distance_max_local)
- courant_stability_number_max = max(courant_stability_number_max,vpmax_local * deltat / (distance_min_local * percent_GLL(NGLLX)))
+ courant_stability_number_max = max(courant_stability_number_max,vpImax_local * deltat / (distance_min_local * percent_GLL(NGLLX)))
! ignore fluid regions with Vs = 0
if(csloc > 0.0001d0) then
@@ -1453,15 +1522,23 @@
lambdaSmax = max(lambdaSmax,vsmin_local / (distance_max_local / (NGLLX - 1)))
endif
- lambdaPmin = min(lambdaPmin,vpmin_local / (distance_max_local / (NGLLX - 1)))
- lambdaPmax = max(lambdaPmax,vpmin_local / (distance_max_local / (NGLLX - 1)))
+ lambdaPImin = min(lambdaPImin,vpImin_local / (distance_max_local / (NGLLX - 1)))
+ lambdaPImax = max(lambdaPImax,vpImin_local / (distance_max_local / (NGLLX - 1)))
+ if(cpIIloc > 0.0001d0) then
+ lambdaPIImin = min(lambdaPIImin,vpIImin_local / (distance_max_local / (NGLLX - 1)))
+ lambdaPIImax = max(lambdaPIImax,vpIImin_local / (distance_max_local / (NGLLX - 1)))
+ endif
+
enddo
any_elastic_glob = any_elastic
+ any_poroelastic_glob = any_poroelastic
#ifdef USE_MPI
- call MPI_ALLREDUCE (vpmin, vpmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (vpmax, vpmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (vpImin, vpImin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (vpImax, vpImax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (vpIImin, vpIImin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (vpIImax, vpIImax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
call MPI_ALLREDUCE (vsmin, vsmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
call MPI_ALLREDUCE (vsmax, vsmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
call MPI_ALLREDUCE (densmin, densmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
@@ -1470,13 +1547,18 @@
call MPI_ALLREDUCE (distance_max, distance_max_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
call MPI_ALLREDUCE (courant_stability_number_max, courant_stability_max_glob, 1, MPI_DOUBLE_PRECISION, &
MPI_MAX, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (lambdaPmin, lambdaPmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
- call MPI_ALLREDUCE (lambdaPmax, lambdaPmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaPImin, lambdaPImin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaPImax, lambdaPImax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaPIImin, lambdaPIImin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
+ call MPI_ALLREDUCE (lambdaPIImax, lambdaPIImax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
call MPI_ALLREDUCE (lambdaSmin, lambdaSmin_glob, 1, MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, ier)
call MPI_ALLREDUCE (lambdaSmax, lambdaSmax_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
call MPI_ALLREDUCE (any_elastic, any_elastic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
- vpmin = vpmin_glob
- vpmax = vpmax_glob
+ call MPI_ALLREDUCE (any_poroelastic, any_poroelastic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
+ vpImin = vpImin_glob
+ vpImax = vpImax_glob
+ vpIImin = vpIImin_glob
+ vpIImax = vpIImax_glob
vsmin = vsmin_glob
vsmax = vsmax_glob
densmin = densmin_glob
@@ -1484,8 +1566,10 @@
distance_min = distance_min_glob
distance_max = distance_max_glob
courant_stability_number_max = courant_stability_max_glob
- lambdaPmin = lambdaPmin_glob
- lambdaPmax = lambdaPmax_glob
+ lambdaPImin = lambdaPImin_glob
+ lambdaPImax = lambdaPImax_glob
+ lambdaPIImin = lambdaPIImin_glob
+ lambdaPIImax = lambdaPIImax_glob
lambdaSmin = lambdaSmin_glob
lambdaSmax = lambdaSmax_glob
@@ -1494,7 +1578,8 @@
if ( myrank == 0 ) then
write(IOUT,*)
write(IOUT,*) '********'
- write(IOUT,*) 'Model: P velocity min,max = ',vpmin,vpmax
+ write(IOUT,*) 'Model: P (or PI) velocity min,max = ',vpImin,vpImax
+ write(IOUT,*) 'Model: PII velocity min,max = ',vpIImin,vpIImax
write(IOUT,*) 'Model: S velocity min,max = ',vsmin,vsmax
write(IOUT,*) 'Model: density min,max = ',densmin,densmax
write(IOUT,*) '********'
@@ -1515,23 +1600,38 @@
! only if time source is not a Dirac or Heaviside (otherwise maximum frequency of spectrum undefined)
! and if source is not an initial field, for the same reason
- if(.not. initialfield .and. time_function_type /= 4 .and. time_function_type /= 5) then
+ if(.not. initialfield) then
+ f0max = -HUGEVAL
+ f0min = HUGEVAL
+ do i = 1,NSOURCE
+ if(time_function_type(i) /= 4 .and. time_function_type(i) /= 5) then
- write(IOUT,*) ' Onset time = ',t0
- write(IOUT,*) ' Fundamental period = ',1.d0/f0
- write(IOUT,*) ' Fundamental frequency = ',f0
- if(t0 <= 1.d0/f0) then
+ write(IOUT,*) ' Onset time = ',t0(i)
+ write(IOUT,*) ' Fundamental period = ',1.d0/f0(i)
+ write(IOUT,*) ' Fundamental frequency = ',f0(i)
+ if(f0(i) > f0max) f0max = f0(i)
+ if(f0(i) < f0min) f0min = f0(i)
+ if(t0(i) <= 1.d0/f0(i)) then
call exit_MPI('Onset time too small')
else
write(IOUT,*) ' --> onset time ok'
endif
+
+ if(i==NSOURCE)then
write(IOUT,*) '----'
- write(IOUT,*) ' Nb pts / lambdaPmin_fmax max = ',lambdaPmax/(2.5d0*f0)
- write(IOUT,*) ' Nb pts / lambdaPmin_fmax min = ',lambdaPmin/(2.5d0*f0)
+ write(IOUT,*) ' Nb pts / lambdaPImin_fmax max = ',lambdaPImax/(2.5d0*f0min)
+ write(IOUT,*) ' Nb pts / lambdaPImin_fmax min = ',lambdaPImin/(2.5d0*f0max)
write(IOUT,*) '----'
- write(IOUT,*) ' Nb pts / lambdaSmin_fmax max = ',lambdaSmax/(2.5d0*f0)
- write(IOUT,*) ' Nb pts / lambdaSmin_fmax min = ',lambdaSmin/(2.5d0*f0)
+ write(IOUT,*) ' Nb pts / lambdaPIImin_fmax max = ',lambdaPIImax/(2.5d0*f0min)
+ write(IOUT,*) ' Nb pts / lambdaPIImin_fmax min = ',lambdaPIImin/(2.5d0*f0max)
write(IOUT,*) '----'
+ write(IOUT,*) ' Nb pts / lambdaSmin_fmax max = ',lambdaSmax/(2.5d0*f0min)
+ write(IOUT,*) ' Nb pts / lambdaSmin_fmax min = ',lambdaSmin/(2.5d0*f0max)
+ write(IOUT,*) '----'
+ endif
+
+ endif
+ enddo
endif
endif
@@ -1775,17 +1875,41 @@
material = kmato(ispec)
- mu = elastcoef(2,material)
- lambdaplus2mu = elastcoef(3,material)
- denst = density(material)
+ if(poroelastic(ispec)) then
+ phi=porosity(material)
+ tort=tortuosity(material)
+!solid properties
+ mu_s = poroelastcoef(2,1,material)
+ kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
+ denst_s = density(1,material)
+!fluid properties
+ kappa_f = poroelastcoef(1,2,material)
+ denst_f = density(2,material)
+!frame properties
+ mu_fr = poroelastcoef(2,3,material)
+ kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
+ denst = (1.d0 - phi)*denst_s + phi*denst_f
+!Biot coefficients for the input phi
+ D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
+ H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
+ C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
+ M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
+! Approximated velocities (no viscous dissipation)
+ afactor = denst - phi/tort*denst_f
+ bfactor = H_biot + phi*denst/(tort*denst_f)*M_biot - 2.d0*phi/tort*C_biot
+ cfactor = phi/(tort*denst_f)*(H_biot*M_biot - C_biot*C_biot)
+ cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
- cploc = sqrt(lambdaplus2mu/denst)
- csloc = sqrt(mu/denst)
+ cpIloc = sqrt(cpIsquare)
+ else
+ lambdaplus2mu = poroelastcoef(3,1,material)
+ denst = density(1,material)
- vpmax_local = -HUGEVAL
- vpmin_local = HUGEVAL
- vsmin_local = HUGEVAL
+ cpIloc = sqrt(lambdaplus2mu/denst)
+ endif
+ vpImax_local = -HUGEVAL
+
distance_min_local = HUGEVAL
distance_max_local = -HUGEVAL
@@ -1794,14 +1918,11 @@
!--- if heterogeneous formulation with external velocity model
if(assign_external_model) then
- cploc = vpext(i,j,ispec)
- csloc = vsext(i,j,ispec)
+ cpIloc = vpext(i,j,ispec)
denst = rhoext(i,j,ispec)
endif
- vpmax_local = max(vpmax_local,cploc)
- vpmin_local = min(vpmin_local,cploc)
- vsmin_local = min(vsmin_local,csloc)
+ vpImax_local = max(vpImax_local,cpIloc)
enddo
enddo
@@ -1825,7 +1946,7 @@
distance_min = min(distance_min,distance_min_local)
distance_max = max(distance_max,distance_max_local)
- courant_stability_number = vpmax_local * deltat / (distance_min_local * percent_GLL(NGLLX))
+ courant_stability_number = vpImax_local * deltat / (distance_min_local * percent_GLL(NGLLX))
! display bad elements that are above 80% of the threshold
if(courant_stability_number >= 0.80 * courant_stability_number_max) then
@@ -1907,7 +2028,7 @@
!
!---- open PostScript file
!
- if(any_elastic_glob) then
+ if(any_elastic_glob .or. any_poroelastic) then
open(unit=24,file='OUTPUT_FILES/mesh_S_wave_dispersion.ps',status='unknown')
else
open(unit=24,file='OUTPUT_FILES/mesh_P_wave_dispersion.ps',status='unknown')
@@ -2105,16 +2226,47 @@
endif
material = kmato(ispec)
+
+ if(poroelastic(ispec)) then
+ phi = porosity(material)
+ tort = tortuosity(material)
+!solid properties
+ mu_s = poroelastcoef(2,1,material)
+ kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
+ denst_s = density(1,material)
+!fluid properties
+ kappa_f = poroelastcoef(1,2,material)
+ denst_f = density(2,material)
+!frame properties
+ mu_fr = poroelastcoef(2,3,material)
+ kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
+ denst = (1.d0 - phi)*denst_s + phi*denst_f
+!Biot coefficients for the input phi
+ D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
+ H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
+ C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
+ M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
+! Approximated velocities (no viscous dissipation)
+ afactor = denst - phi/tort*denst_f
+ bfactor = H_biot + phi*denst/(tort*denst_f)*M_biot - 2.d0*phi/tort*C_biot
+ cfactor = phi/(tort*denst_f)*(H_biot*M_biot - C_biot*C_biot)
+ cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cssquare = mu_fr/afactor
- mu = elastcoef(2,material)
- lambdaplus2mu = elastcoef(3,material)
- denst = density(material)
+ cpIloc = sqrt(cpIsquare)
+ csloc = sqrt(cssquare)
+ else
+ mu = poroelastcoef(2,1,material)
+ lambdaplus2mu = poroelastcoef(3,1,material)
+ denst = density(1,material)
- cploc = sqrt(lambdaplus2mu/denst)
+ cpIloc = sqrt(lambdaplus2mu/denst)
csloc = sqrt(mu/denst)
+ endif
- vpmax_local = -HUGEVAL
- vpmin_local = HUGEVAL
+ vpImax_local = -HUGEVAL
+ vpImin_local = HUGEVAL
vsmin_local = HUGEVAL
distance_min_local = HUGEVAL
@@ -2125,13 +2277,13 @@
!--- if heterogeneous formulation with external velocity model
if(assign_external_model) then
- cploc = vpext(i,j,ispec)
+ cpIloc = vpext(i,j,ispec)
csloc = vsext(i,j,ispec)
denst = rhoext(i,j,ispec)
endif
- vpmax_local = max(vpmax_local,cploc)
- vpmin_local = min(vpmin_local,cploc)
+ vpImax_local = max(vpImax_local,cpIloc)
+ vpImin_local = min(vpImin_local,cpIloc)
vsmin_local = min(vsmin_local,csloc)
enddo
@@ -2157,7 +2309,7 @@
distance_max = max(distance_max,distance_max_local)
! display mesh dispersion for S waves if there is at least one elastic element in the mesh
- if(any_elastic_glob) then
+ if(any_elastic_glob .or. any_poroelastic_glob) then
! ignore fluid regions with Vs = 0
if(csloc > 0.0001d0) then
@@ -2201,10 +2353,10 @@
! display mesh dispersion for P waves if there is no elastic element in the mesh
else
- lambdaP_local = vpmin_local / (distance_max_local / (NGLLX - 1))
+ lambdaPI_local = vpImin_local / (distance_max_local / (NGLLX - 1))
! display very good elements that are above 80% of the threshold in red
- if(lambdaP_local >= 0.80 * lambdaPmax) then
+ if(lambdaPI_local >= 0.80 * lambdaPImax) then
if ( myrank == 0 ) then
write(24,*) '1 0 0 RG GF 0 setgray ST'
else
@@ -2212,7 +2364,7 @@
endif
! display bad elements that are below 120% of the threshold in blue
- else if(lambdaP_local <= 1.20 * lambdaPmin) then
+ else if(lambdaPI_local <= 1.20 * lambdaPImin) then
if ( myrank == 0 ) then
write(24,*) '0 0 1 RG GF 0 setgray ST'
else
@@ -2487,17 +2639,43 @@
coorg_send(2,(ispec-1)*5+5) = z2
endif
- if((vpmax-vpmin)/vpmin > 0.02d0) then
+ if((vpImax-vpImin)/vpImin > 0.02d0) then
if(assign_external_model) then
! use lower-left corner
- x1 = (vpext(1,1,ispec)-vpmin) / (vpmax-vpmin)
+ x1 = (vpext(1,1,ispec)-vpImin) / (vpImax-vpImin)
else
material = kmato(ispec)
- mu = elastcoef(2,material)
- lambdaplus2mu = elastcoef(3,material)
- denst = density(material)
- cploc = sqrt(lambdaplus2mu/denst)
- x1 = (cploc-vpmin)/(vpmax-vpmin)
+ if(poroelastic(ispec)) then
+ phi = porosity(material)
+ tort = tortuosity(material)
+!solid properties
+ mu_s = poroelastcoef(2,1,material)
+ kappa_s = poroelastcoef(3,1,material) - FOUR_THIRDS*mu_s
+ denst_s = density(1,material)
+!fluid properties
+ kappa_f = poroelastcoef(1,2,material)
+ denst_f = density(2,material)
+!frame properties
+ mu_fr = poroelastcoef(2,3,material)
+ kappa_fr = poroelastcoef(3,3,material) - FOUR_THIRDS*mu_fr
+ denst = (1.d0 - phi)*denst_s + phi*denst_f
+!Biot coefficients for the input phi
+ D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
+ H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
+ C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
+ M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
+! Approximated velocities (no viscous dissipation)
+ afactor = denst - phi/tort*denst_f
+ bfactor = H_biot + phi*denst/(tort*denst_f)*M_biot - 2.d0*phi/tort*C_biot
+ cfactor = phi/(tort*denst_f)*(H_biot*M_biot - C_biot*C_biot)
+ cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cpIloc = sqrt(cpIsquare)
+ else
+ lambdaplus2mu = poroelastcoef(3,1,material)
+ denst = density(1,material)
+ cpIloc = sqrt(lambdaplus2mu/denst)
+ endif
+ x1 = (cpIloc-vpImin)/(vpImax-vpImin)
endif
else
x1 = 0.5d0
Modified: seismo/2D/SPECFEM2D/trunk/compute_arrays_source.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_arrays_source.f90 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/compute_arrays_source.f90 2009-08-03 17:08:30 UTC (rev 15507)
@@ -125,3 +125,64 @@
end subroutine compute_arrays_source
+! ------------------------------------------------------------------------------------------------------
+
+
+ subroutine compute_arrays_adj_source(myrank,adj_source_file,xi_receiver,gamma_receiver,adj_sourcearray, &
+ xigll,zigll,NSTEP)
+
+ implicit none
+
+ include 'constants.h'
+
+! input
+ integer myrank, NSTEP
+
+ double precision xi_receiver, gamma_receiver
+
+ character(len=*) adj_source_file
+
+! output
+ real(kind=CUSTOM_REAL), dimension(NSTEP,NDIM,NGLLX,NGLLZ) :: adj_sourcearray
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLZ) :: zigll
+
+
+ double precision :: hxir(NGLLX), hpxir(NGLLX), hgammar(NGLLZ), hpgammar(NGLLZ)
+ real(kind=CUSTOM_REAL) :: adj_src_s(NSTEP,NDIM)
+
+ integer icomp, itime, i, k, ios
+ double precision :: junk
+ character(len=3) :: comp(2)
+ character(len=150) :: filename
+
+ call lagrange_any(xi_receiver,NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(gamma_receiver,NGLLZ,zigll,hgammar,hpgammar)
+
+ adj_sourcearray(:,:,:,:) = 0.
+
+ comp = (/"BHX","BHZ"/)
+
+ do icomp = 1, NDIM
+
+ filename = 'OUTPUT_FILES/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
+ open(unit = IIN, file = trim(filename), iostat = ios)
+ if (ios /= 0) call exit_MPI(myrank, ' file '//trim(filename)//'does not exist')
+
+ do itime = 1, NSTEP
+ read(IIN,*) junk, adj_src_s(itime,icomp)
+ enddo
+ close(IIN)
+
+ enddo
+
+ do k = 1, NGLLZ
+ do i = 1, NGLLX
+ adj_sourcearray(:,:,i,k) = hxir(i) * hgammar(k) * adj_src_s(:,:)
+ enddo
+ enddo
+
+
+end subroutine compute_arrays_adj_source
Modified: seismo/2D/SPECFEM2D/trunk/compute_curl_one_element.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_curl_one_element.f90 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/compute_curl_one_element.f90 2009-08-03 17:08:30 UTC (rev 15507)
@@ -40,10 +40,10 @@
!
!========================================================================
-subroutine compute_curl_one_element(curl_element,displ_elastic,elastic, &
+subroutine compute_curl_one_element(curl_element,displ_elastic,displs_poroelastic,elastic,poroelastic, &
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec)
- ! compute curl in elastic elements (for rotational study)
+ ! compute curl in (poro)elastic elements (for rotational study)
implicit none
@@ -58,8 +58,8 @@
! curl in this element
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: curl_element
- logical, dimension(nspec) :: elastic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displ_elastic
+ logical, dimension(nspec) :: elastic,poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displ_elastic,displs_poroelastic
! array with derivatives of Lagrange polynomials
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
@@ -111,6 +111,42 @@
enddo
enddo
+ elseif(poroelastic(ispec)) then
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ ! derivative along x and along z
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+ ! derivatives of displacement
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+
+ ! store pressure
+ curl_element(i,j) = - 0.5d0 * (dux_dzl - duz_dxl)
+
+ enddo
+ enddo
+
else
call exit_MPI('no curl in acoustic')
Modified: seismo/2D/SPECFEM2D/trunk/compute_energy.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_energy.f90 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/compute_energy.f90 2009-08-03 17:08:30 UTC (rev 15507)
@@ -40,9 +40,11 @@
!
!========================================================================
- subroutine compute_energy(displ_elastic,veloc_elastic, &
- xix,xiz,gammax,gammaz,jacobian,ibool,elastic,hprime_xx,hprime_zz, &
+ subroutine compute_energy(displ_elastic,veloc_elastic,displs_poroelastic,velocs_poroelastic, &
+ displw_poroelastic,velocw_poroelastic, &
+ xix,xiz,gammax,gammaz,jacobian,ibool,elastic,poroelastic,hprime_xx,hprime_zz, &
nspec,npoin,assign_external_model,it,deltat,t0,kmato,elastcoef,density, &
+ porosity,tortuosity, &
vpext,vsext,rhoext,wxgll,wzgll,numat, &
pressure_element,vector_field_element,e1,e11, &
potential_dot_acoustic,potential_dot_dot_acoustic,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,Mu_nu1,Mu_nu2,N_SLS)
@@ -74,7 +76,7 @@
integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- logical, dimension(nspec) :: elastic
+ logical, dimension(nspec) :: elastic,poroelastic
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
@@ -82,11 +84,14 @@
logical :: assign_external_model
- double precision, dimension(numat) :: density
- double precision, dimension(4,numat) :: elastcoef
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(4,3,numat) :: elastcoef
double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,vsext,rhoext
real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displ_elastic,veloc_elastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displs_poroelastic,velocs_poroelastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displw_poroelastic,velocw_poroelastic
! Gauss-Lobatto-Legendre points and weights
real(kind=CUSTOM_REAL), dimension(NGLLX) :: wxgll
@@ -102,12 +107,19 @@
! spatial derivatives
real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
+ real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
! jacobian
real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
real(kind=CUSTOM_REAL) :: kinetic_energy,potential_energy
real(kind=CUSTOM_REAL) :: cpl,csl,rhol,mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,kappal
+ real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
+ real(kind=CUSTOM_REAL) :: kappal_f,rhol_f
+ real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl
+ real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
+ real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G,mul_C,lambdal_C,lambdalplus2mul_C,mul_M,lambdal_M,lambdalplus2mul_M
kinetic_energy = ZERO
potential_energy = ZERO
@@ -121,10 +133,10 @@
if(elastic(ispec)) then
! get relaxed elastic parameters of current spectral element
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
- lambdalplus2mul_relaxed = elastcoef(3,kmato(ispec))
- rhol = density(kmato(ispec))
+ lambdal_relaxed = elastcoef(1,1,kmato(ispec))
+ mul_relaxed = elastcoef(2,1,kmato(ispec))
+ lambdalplus2mul_relaxed = elastcoef(3,1,kmato(ispec))
+ rhol = density(1,kmato(ispec))
! double loop over GLL points
do j = 1,NGLLZ
@@ -183,6 +195,115 @@
enddo
!---
+!--- poroelastic spectral element
+!---
+ elseif(poroelastic(ispec)) then
+
+! get relaxed elastic parameters of current spectral element
+!for now replaced by solid, fluid, and frame parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+!solid properties
+ mul_s = elastcoef(2,1,kmato(ispec))
+ kappal_s = elastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
+ rhol_s = density(1,kmato(ispec))
+!fluid properties
+ kappal_f = elastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+!frame properties
+ mul_fr = elastcoef(2,3,kmato(ispec))
+ kappal_fr = elastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
+ rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + kappal_fr + FOUR_THIRDS*mul_fr
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+!The RHS has the form : div T -phi/c div T_f + phi/ceta_fk^-1.partial t w
+!where T = G:grad u_s + C div w I
+!and T_f = C div u_s I + M div w I
+!we are expressing lambdaplus2mu, lambda, and mu for G, C, and M
+ mul_G = mul_fr
+ lambdal_G = H_biot - TWO*mul_fr
+ lambdalplus2mul_G = lambdal_G + TWO*mul_G
+
+! first double loop over GLL points to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+! derivative along x and along z
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+ jacobianl = jacobian(i,j,ispec)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
+
+ dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+! compute potential energy
+ potential_energy = potential_energy + ( lambdalplus2mul_G*dux_dxl**2 &
+ + lambdalplus2mul_G*duz_dzl**2 &
+ + two*lambdal_G*dux_dxl*duz_dzl + mul_G*(dux_dzl + duz_dxl)**2 &
+ + two*C_biot*dwx_dxl*dux_dxl + two*C_biot*dwz_dzl*duz_dzl &
+ + two*C_biot*(dwx_dxl*duz_dzl + dwz_dzl*dux_dxl) &
+ + M_biot*dwx_dxl**2 + M_biot*dwz_dzl**2 &
+ + two*M_biot*dwx_dxl*dwz_dzl )*wxgll(i)*wzgll(j)*jacobianl / TWO
+
+! compute kinetic energy
+ if(phil > 0.0d0) then
+ kinetic_energy = kinetic_energy + ( &
+ rhol_bar*(velocs_poroelastic(1,ibool(i,j,ispec))**2 + velocs_poroelastic(2,ibool(i,j,ispec))**2) &
+ + rhol_f*tortl/phil*(velocw_poroelastic(1,ibool(i,j,ispec))**2 + velocw_poroelastic(2,ibool(i,j,ispec))**2) &
+ + rhol_f*(velocs_poroelastic(1,ibool(i,j,ispec))*velocw_poroelastic(1,ibool(i,j,ispec)) &
+ + velocs_poroelastic(2,ibool(i,j,ispec))*velocw_poroelastic(2,ibool(i,j,ispec))) &
+ )*wxgll(i)*wzgll(j)*jacobianl / TWO
+ else
+ kinetic_energy = kinetic_energy + &
+ rhol_s*(velocs_poroelastic(1,ibool(i,j,ispec))**2 + velocs_poroelastic(2,ibool(i,j,ispec))**2) &
+ *wxgll(i)*wzgll(j)*jacobianl / TWO
+ endif
+ enddo
+ enddo
+
+!---
!--- acoustic spectral element
!---
else
@@ -209,9 +330,9 @@
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,density,rhoext,assign_external_model)
! get density of current spectral element
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
- rhol = density(kmato(ispec))
+ lambdal_relaxed = elastcoef(1,1,kmato(ispec))
+ mul_relaxed = elastcoef(2,1,kmato(ispec))
+ rhol = density(1,kmato(ispec))
kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
cpl = sqrt((kappal + 4._CUSTOM_REAL*mul_relaxed/3._CUSTOM_REAL)/rhol)
Modified: seismo/2D/SPECFEM2D/trunk/compute_forces_acoustic.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_forces_acoustic.f90 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/compute_forces_acoustic.f90 2009-08-03 17:08:30 UTC (rev 15507)
@@ -40,14 +40,18 @@
!
!========================================================================
- subroutine compute_forces_acoustic(npoin,nspec,nelemabs,numat, &
+ subroutine compute_forces_acoustic(npoin,nspec,nelemabs,numat,it,NSTEP, &
anyabs,assign_external_model,ibool,kmato,numabs, &
- elastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic,density,elastcoef,xix,xiz,gammax,gammaz,jacobian, &
+ elastic,poroelastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,b_potential_dot_dot_acoustic,b_potential_acoustic, &
+ density,elastcoef,xix,xiz,gammax,gammaz,jacobian, &
vpext,rhoext,hprime_xx,hprimewgll_xx, &
hprime_zz,hprimewgll_zz,wxgll,wzgll, &
ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
- jbegin_left,jend_left,jbegin_right,jend_right)
+ jbegin_left,jend_left,jbegin_right,jend_right,isolver,save_forward,b_absorb_acoustic_left,&
+ b_absorb_acoustic_right,b_absorb_acoustic_bottom,&
+ b_absorb_acoustic_top,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax,kappa_ac_k)
! compute forces for the acoustic elements
@@ -55,24 +59,38 @@
include "constants.h"
- integer :: npoin,nspec,nelemabs,numat
+ integer :: npoin,nspec,nelemabs,numat,it,NSTEP,isolver
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(nspec_xmin) :: ib_xmin
+ integer, dimension(nspec_xmax) :: ib_xmax
+ integer, dimension(nspec_zmin) :: ib_zmin
+ integer, dimension(nspec_zmax) :: ib_zmax
+
logical :: anyabs,assign_external_model
+ logical :: save_forward
integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
integer, dimension(nspec) :: kmato
integer, dimension(nelemabs) :: numabs,ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
jbegin_left,jend_left,jbegin_right,jend_right
- logical, dimension(nspec) :: elastic
+ logical, dimension(nspec) :: elastic,poroelastic
logical, dimension(4,nelemabs) :: codeabs
real(kind=CUSTOM_REAL), dimension(npoin) :: potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
- double precision, dimension(numat) :: density
- double precision, dimension(4,numat) :: elastcoef
+ real(kind=CUSTOM_REAL), dimension(npoin) :: b_potential_dot_dot_acoustic,b_potential_acoustic
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(4,3,numat) :: elastcoef
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,rhoext
+ real(kind=CUSTOM_REAL), dimension(npoin) :: kappa_ac_k
+ double precision, dimension(NGLLZ,nspec_xmin,NSTEP) :: b_absorb_acoustic_left
+ double precision, dimension(NGLLZ,nspec_xmax,NSTEP) :: b_absorb_acoustic_right
+ double precision, dimension(NGLLX,nspec_zmax,NSTEP) :: b_absorb_acoustic_top
+ double precision, dimension(NGLLX,nspec_zmin,NSTEP) :: b_absorb_acoustic_bottom
+
! derivatives of Lagrange polynomials
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
@@ -89,9 +107,11 @@
! spatial derivatives
real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,dux_dxl,dux_dzl
+ real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_dux_dxl,b_dux_dzl
real(kind=CUSTOM_REAL) :: weight,xxi,zxi,xgamma,zgamma,jacobian1D
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2
! Jacobian matrix and determinant
real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
@@ -110,9 +130,9 @@
!---
!--- acoustic spectral element
!---
- if(.not. elastic(ispec)) then
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
- rhol = density(kmato(ispec))
+ rhol = density(1,kmato(ispec))
! first double loop over GLL points to compute and store gradients
do j = 1,NGLLZ
@@ -122,11 +142,21 @@
dux_dxi = ZERO
dux_dgamma = ZERO
+ if(isolver == 2) then
+ b_dux_dxi = ZERO
+ b_dux_dgamma = ZERO
+ endif
+
! first double loop over GLL points to compute and store gradients
! we can merge the two loops because NGLLX == NGLLZ
do k = 1,NGLLX
dux_dxi = dux_dxi + potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
dux_dgamma = dux_dgamma + potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
+
+ if(isolver == 2) then
+ b_dux_dxi = b_dux_dxi + b_potential_acoustic(ibool(k,j,ispec))*hprime_xx(i,k)
+ b_dux_dgamma = b_dux_dgamma + b_potential_acoustic(ibool(i,k,ispec))*hprime_zz(j,k)
+ endif
enddo
xixl = xix(i,j,ispec)
@@ -138,6 +168,15 @@
dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+ if(isolver == 2) then
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+! kernels calculation
+ iglob = ibool(i,j,ispec)
+ kappa_ac_k(iglob) = dux_dxl * b_dux_dxl + dux_dzl * b_dux_dzl
+ endif
+
jacobianl = jacobian(i,j,ispec)
! if external density model
@@ -148,6 +187,11 @@
tempx1(i,j) = wzgll(j)*jacobianl*(xixl*dux_dxl + xizl*dux_dzl) / rhol
tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*dux_dxl + gammazl*dux_dzl) / rhol
+ if(isolver == 2) then
+ b_tempx1(i,j) = wzgll(j)*jacobianl*(xixl*b_dux_dxl + xizl*b_dux_dzl) /rhol
+ b_tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*b_dux_dxl + gammazl*b_dux_dzl) /rhol
+ endif
+
enddo
enddo
@@ -164,6 +208,11 @@
do k = 1,NGLLX
potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - &
(tempx1(k,j)*hprimewgll_xx(k,i) + tempx2(i,k)*hprimewgll_zz(k,j))
+
+ if(isolver == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) - &
+ (b_tempx1(k,j)*hprimewgll_xx(k,i) + b_tempx2(i,k)*hprimewgll_zz(k,j))
+ endif
enddo
enddo ! second loop over the GLL points
@@ -183,12 +232,13 @@
ispec = numabs(ispecabs)
! get elastic parameters of current spectral element
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
+ lambdal_relaxed = elastcoef(1,1,kmato(ispec))
+ mul_relaxed = elastcoef(2,1,kmato(ispec))
kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
- rhol = density(kmato(ispec))
- cpl = sqrt((kappal + 4._CUSTOM_REAL*mul_relaxed/3._CUSTOM_REAL)/rhol)
+ rhol = density(1,kmato(ispec))
+ cpl = sqrt(kappal/rhol)
+
!--- left absorbing boundary
if(codeabs(ILEFT,ispecabs)) then
@@ -214,9 +264,17 @@
weight = jacobian1D * wzgll(j)
! Sommerfeld condition if acoustic
- if(.not. elastic(ispec)) &
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
+ if(save_forward .and. isolver ==1) then
+ b_absorb_acoustic_left(j,ib_xmin(ispecabs),it) = potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(isolver == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) - &
+ b_absorb_acoustic_left(j,ib_xmin(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
enddo
endif ! end of left absorbing boundary
@@ -246,9 +304,18 @@
weight = jacobian1D * wzgll(j)
! Sommerfeld condition if acoustic
- if(.not. elastic(ispec)) &
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
+
+ if(save_forward .and. isolver ==1) then
+ b_absorb_acoustic_right(j,ib_xmax(ispecabs),it) = potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(isolver == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) - &
+ b_absorb_acoustic_right(j,ib_xmax(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
enddo
endif ! end of right absorbing boundary
@@ -282,9 +349,17 @@
weight = jacobian1D * wxgll(i)
! Sommerfeld condition if acoustic
- if(.not. elastic(ispec)) &
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
+ if(save_forward .and. isolver ==1) then
+ b_absorb_acoustic_bottom(i,ib_zmin(ispecabs),it) = potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(isolver == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) - &
+ b_absorb_acoustic_bottom(i,ib_zmin(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
enddo
endif ! end of bottom absorbing boundary
@@ -318,9 +393,17 @@
weight = jacobian1D * wxgll(i)
! Sommerfeld condition if acoustic
- if(.not. elastic(ispec)) &
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl/rhol
+ if(save_forward .and. isolver ==1) then
+ b_absorb_acoustic_top(i,ib_zmax(ispecabs),it) = potential_dot_acoustic(iglob)*weight/cpl/rhol
+ elseif(isolver == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) - &
+ b_absorb_acoustic_top(i,ib_zmax(ispecabs),NSTEP-it+1)
+ endif
+ endif
+
enddo
endif ! end of top absorbing boundary
Modified: seismo/2D/SPECFEM2D/trunk/compute_forces_elastic.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_forces_elastic.f90 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/compute_forces_elastic.f90 2009-08-03 17:08:30 UTC (rev 15507)
@@ -40,19 +40,23 @@
!
!========================================================================
- subroutine compute_forces_elastic(npoin,nspec,nelemabs,numat, &
- ispec_selected_source,is_proc_source,source_type,it,NSTEP,anyabs,assign_external_model, &
+ subroutine compute_forces_elastic(npoin,nspec,myrank,nelemabs,numat, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver, &
+ source_type,it,NSTEP,anyabs,assign_external_model, &
initialfield,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,angleforce,deltatcube, &
deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,elastic,codeabs, &
- accel_elastic,veloc_elastic,displ_elastic,density,elastcoef,xix,xiz,gammax,gammaz, &
- jacobian,vpext,vsext,rhoext,source_time_function,sourcearray,e1,e11, &
+ accel_elastic,veloc_elastic,displ_elastic,b_accel_elastic,b_displ_elastic, &
+ density,elastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,vpext,vsext,rhoext,source_time_function,sourcearray,adj_sourcearrays,e1,e11, &
e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2,Mu_nu1,Mu_nu2,N_SLS, &
deltat,coord,add_Bielak_conditions, &
x0_source, z0_source, A_plane, B_plane, C_plane, angleforce_refl, c_inc, c_refl, time_offset,f0, &
v0x_left,v0z_left,v0x_right,v0z_right,v0x_bot,v0z_bot,t0x_left,t0z_left,t0x_right,t0z_right,t0x_bot,t0z_bot,&
- nleft,nright,nbot,over_critical_angle)
+ nleft,nright,nbot,over_critical_angle,NSOURCE,nrec,isolver,save_forward,b_absorb_elastic_left,&
+ b_absorb_elastic_right,b_absorb_elastic_bottom,b_absorb_elastic_top,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax,mu_k,kappa_k)
! compute forces for the elastic elements
@@ -60,12 +64,25 @@
include "constants.h"
- integer :: npoin,nspec,nelemabs,numat,ispec_selected_source,is_proc_source,source_type,it,NSTEP
+ integer :: NSOURCE, i_source
+ integer :: npoin,nspec,myrank,nelemabs,numat,it,NSTEP
+ integer, dimension(NSOURCE) :: ispec_selected_source,is_proc_source,source_type
+ integer :: nrec,isolver
+ integer, dimension(nrec) :: ispec_selected_rec,which_proc_receiver
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(nspec_xmin) :: ib_xmin
+ integer, dimension(nspec_xmax) :: ib_xmax
+ integer, dimension(nspec_zmin) :: ib_zmin
+ integer, dimension(nspec_zmax) :: ib_zmax
+
logical :: anyabs,assign_external_model,initialfield,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,add_Bielak_conditions
- double precision :: angleforce,deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
+ logical :: save_forward
+ double precision :: deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
+ double precision, dimension(NSOURCE) :: angleforce
+
integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
integer, dimension(nspec) :: kmato
integer, dimension(nelemabs) :: numabs
@@ -74,13 +91,21 @@
logical, dimension(4,nelemabs) :: codeabs
real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: accel_elastic,veloc_elastic,displ_elastic
- double precision, dimension(numat) :: density
- double precision, dimension(4,numat) :: elastcoef
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(4,3,numat) :: elastcoef
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,vsext,rhoext
- real(kind=CUSTOM_REAL), dimension(NSTEP) :: source_time_function
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ) :: sourcearray
+ real(kind=CUSTOM_REAL), dimension(NSOURCE,NSTEP) :: source_time_function
+ real(kind=CUSTOM_REAL), dimension(NSOURCE,NDIM,NGLLX,NGLLZ) :: sourcearray
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: b_accel_elastic,b_displ_elastic
+ real(kind=CUSTOM_REAL), dimension(nrec,NSTEP,NDIM,NGLLX,NGLLZ) :: adj_sourcearrays
+ real(kind=CUSTOM_REAL), dimension(npoin) :: mu_k,kappa_k
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmin,NSTEP) :: b_absorb_elastic_left
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLZ,nspec_xmax,NSTEP) :: b_absorb_elastic_right
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmax,NSTEP) :: b_absorb_elastic_top
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,nspec_zmin,NSTEP) :: b_absorb_elastic_bottom
+
integer :: N_SLS
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec,N_SLS) :: e1,e11,e13
double precision, dimension(NGLLX,NGLLZ,nspec,N_SLS) :: inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2
@@ -104,15 +129,21 @@
!--- local variables
!---
- integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend
+ integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,irec,irec_local
! spatial derivatives
real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ real(kind=CUSTOM_REAL) :: b_dux_dxi,b_dux_dgamma,b_duz_dxi,b_duz_dgamma
+ real(kind=CUSTOM_REAL) :: b_dux_dxl,b_duz_dxl,b_dux_dzl,b_duz_dzl
+ real(kind=CUSTOM_REAL) :: dsxx,dsxz,dszz
+ real(kind=CUSTOM_REAL) :: b_dsxx,b_dsxz,b_dszz
real(kind=CUSTOM_REAL) :: sigma_xx,sigma_xz,sigma_zz
+ real(kind=CUSTOM_REAL) :: b_sigma_xx,b_sigma_xz,b_sigma_zz
real(kind=CUSTOM_REAL) :: nx,nz,vx,vz,vn,rho_vp,rho_vs,tx,tz,weight,xxi,zxi,xgamma,zgamma,jacobian1D
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: tempx1,tempx2,tempz1,tempz2
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: b_tempx1,b_tempx2,b_tempz1,b_tempz2
! Jacobian matrix and determinant
real(kind=CUSTOM_REAL) :: xixl,xizl,gammaxl,gammazl,jacobianl
@@ -155,9 +186,9 @@
if(elastic(ispec)) then
! get relaxed elastic parameters of current spectral element
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
- lambdalplus2mul_relaxed = elastcoef(3,kmato(ispec))
+ lambdal_relaxed = elastcoef(1,1,kmato(ispec))
+ mul_relaxed = elastcoef(2,1,kmato(ispec))
+ lambdalplus2mul_relaxed = elastcoef(3,1,kmato(ispec))
! first double loop over GLL points to compute and store gradients
do j = 1,NGLLZ
@@ -180,6 +211,14 @@
dux_dgamma = ZERO
duz_dgamma = ZERO
+ if(isolver == 2) then ! Adjoint calculation, backward wavefield
+ b_dux_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duz_dgamma = ZERO
+ endif
+
! first double loop over GLL points to compute and store gradients
! we can merge the two loops because NGLLX == NGLLZ
do k = 1,NGLLX
@@ -187,6 +226,13 @@
duz_dxi = duz_dxi + displ_elastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
duz_dgamma = duz_dgamma + displ_elastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ if(isolver == 2) then ! Adjoint calculation, backward wavefield
+ b_dux_dxi = b_dux_dxi + b_displ_elastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_duz_dxi = b_duz_dxi + b_displ_elastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ b_dux_dgamma = b_dux_dgamma + b_displ_elastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ b_duz_dgamma = b_duz_dgamma + b_displ_elastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+ endif
enddo
xixl = xix(i,j,ispec)
@@ -201,6 +247,14 @@
duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+ if(isolver == 2) then ! Adjoint calculation, backward wavefield
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+ endif
+
! compute stress tensor (include attenuation or anisotropy if needed)
if(TURN_ATTENUATION_ON) then
@@ -244,6 +298,12 @@
sigma_xz = mul_relaxed*(duz_dxl + dux_dzl)
sigma_zz = lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
+ if(isolver == 2) then ! Adjoint calculation, backward wavefield
+ b_sigma_xx = lambdalplus2mul_relaxed*b_dux_dxl + lambdal_relaxed*b_duz_dzl
+ b_sigma_xz = mul_relaxed*(b_duz_dxl + b_dux_dzl)
+ b_sigma_zz = lambdalplus2mul_relaxed*b_duz_dzl + lambdal_relaxed*b_dux_dxl
+ endif
+
endif
! full anisotropy
@@ -256,6 +316,22 @@
endif
+! Pre-kernels calculation
+ if(isolver == 2) then
+ iglob = ibool(i,j,ispec)
+ dsxx = dux_dxl
+ dsxz = HALF * (duz_dxl + dux_dzl)
+ dszz = duz_dzl
+
+ b_dsxx = b_dux_dxl
+ b_dsxz = HALF * (b_duz_dxl + b_dux_dzl)
+ b_dszz = b_duz_dzl
+
+ kappa_k(iglob) = (dux_dxl + duz_dzl) * (b_dux_dxl + b_duz_dzl)
+ mu_k(iglob) = dsxx * b_dsxx + dszz * b_dszz + &
+ 2._CUSTOM_REAL * dsxz * b_dsxz - 1._CUSTOM_REAL/3._CUSTOM_REAL * kappa_k(iglob)
+ endif
+
jacobianl = jacobian(i,j,ispec)
! weak formulation term based on stress tensor (non-symmetric form)
@@ -266,6 +342,14 @@
tempx2(i,j) = wxgll(i)*jacobianl*(sigma_xx*gammaxl+sigma_xz*gammazl)
tempz2(i,j) = wxgll(i)*jacobianl*(sigma_xz*gammaxl+sigma_zz*gammazl)
+ if(isolver == 2) then ! Adjoint calculation, backward wavefield
+ b_tempx1(i,j) = wzgll(j)*jacobianl*(b_sigma_xx*xixl+b_sigma_xz*xizl)
+ b_tempz1(i,j) = wzgll(j)*jacobianl*(b_sigma_xz*xixl+b_sigma_zz*xizl)
+
+ b_tempx2(i,j) = wxgll(i)*jacobianl*(b_sigma_xx*gammaxl+b_sigma_xz*gammazl)
+ b_tempz2(i,j) = wxgll(i)*jacobianl*(b_sigma_xz*gammaxl+b_sigma_zz*gammazl)
+ endif
+
enddo
enddo
@@ -283,6 +367,13 @@
do k = 1,NGLLX
accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tempx1(k,j)*hprimewgll_xx(k,i) + tempx2(i,k)*hprimewgll_zz(k,j))
accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tempz1(k,j)*hprimewgll_xx(k,i) + tempz2(i,k)*hprimewgll_zz(k,j))
+
+ if(isolver == 2) then ! Adjoint calculation, backward wavefield
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - &
+ (b_tempx1(k,j)*hprimewgll_xx(k,i) + b_tempx2(i,k)*hprimewgll_zz(k,j))
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - &
+ (b_tempz1(k,j)*hprimewgll_xx(k,i) + b_tempz2(i,k)*hprimewgll_zz(k,j))
+ endif
enddo
enddo ! second loop over the GLL points
@@ -306,9 +397,9 @@
ispec = numabs(ispecabs)
! get elastic parameters of current spectral element
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
- rhol = density(kmato(ispec))
+ lambdal_relaxed = elastcoef(1,1,kmato(ispec))
+ mul_relaxed = elastcoef(2,1,kmato(ispec))
+ rhol = density(1,kmato(ispec))
kappal = lambdal_relaxed + TWO*mul_relaxed/3._CUSTOM_REAL
cpl = sqrt((kappal + 4._CUSTOM_REAL*mul_relaxed/3._CUSTOM_REAL)/rhol)
csl = sqrt(mul_relaxed/rhol)
@@ -375,6 +466,15 @@
accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx + traction_x_t0)*weight
accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tz + traction_z_t0)*weight
+
+ if(save_forward .and. isolver ==1) then
+ b_absorb_elastic_left(1,j,ib_xmin(ispecabs),it) = tx*weight
+ b_absorb_elastic_left(2,j,ib_xmin(ispecabs),it) = tz*weight
+ elseif(isolver == 2) then
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - b_absorb_elastic_left(1,j,ib_xmin(ispecabs),NSTEP-it+1)
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - b_absorb_elastic_left(2,j,ib_xmin(ispecabs),NSTEP-it+1)
+ endif
+
endif
enddo
@@ -443,6 +543,16 @@
accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx - traction_x_t0)*weight
accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tz - traction_z_t0)*weight
+
+
+ if(save_forward .and. isolver ==1) then
+ b_absorb_elastic_right(1,j,ib_xmax(ispecabs),it) = tx*weight
+ b_absorb_elastic_right(2,j,ib_xmax(ispecabs),it) = tz*weight
+ elseif(isolver == 2) then
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - b_absorb_elastic_right(1,j,ib_xmax(ispecabs),NSTEP-it+1)
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - b_absorb_elastic_right(2,j,ib_xmax(ispecabs),NSTEP-it+1)
+ endif
+
endif
enddo
@@ -517,6 +627,15 @@
accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx + traction_x_t0)*weight
accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tz + traction_z_t0)*weight
+
+ if(save_forward .and. isolver ==1) then
+ b_absorb_elastic_bottom(1,i,ib_zmin(ispecabs),it) = tx*weight
+ b_absorb_elastic_bottom(2,i,ib_zmin(ispecabs),it) = tz*weight
+ elseif(isolver == 2) then
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - b_absorb_elastic_bottom(1,i,ib_zmin(ispecabs),NSTEP-it+1)
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - b_absorb_elastic_bottom(2,i,ib_zmin(ispecabs),NSTEP-it+1)
+ endif
+
endif
enddo
@@ -583,6 +702,15 @@
accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tx - traction_x_t0)*weight
accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tz - traction_z_t0)*weight
+
+ if(save_forward .and. isolver ==1) then
+ b_absorb_elastic_top(1,i,ib_zmax(ispecabs),it) = tx*weight
+ b_absorb_elastic_top(2,i,ib_zmax(ispecabs),it) = tz*weight
+ elseif(isolver == 2) then
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - b_absorb_elastic_top(1,i,ib_zmax(ispecabs),NSTEP-it+1)
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - b_absorb_elastic_top(2,i,ib_zmax(ispecabs),NSTEP-it+1)
+ endif
+
endif
enddo
@@ -596,22 +724,58 @@
! --- add the source if it is a moment tensor
if(.not. initialfield) then
+ do i_source=1,NSOURCE
! if this processor carries the source and the source element is elastic
- if (is_proc_source == 1 .and. elastic(ispec_selected_source)) then
+ if (is_proc_source(i_source) == 1 .and. elastic(ispec_selected_source(i_source))) then
! moment tensor
- if(source_type == 2) then
+ if(source_type(i_source) == 2) then
+
+ if(isolver == 1) then ! forward wavefield
! add source array
do j=1,NGLLZ
do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_source)
- accel_elastic(:,iglob) = accel_elastic(:,iglob) + sourcearray(:,i,j)*source_time_function(it)
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ accel_elastic(:,iglob) = accel_elastic(:,iglob) + &
+ sourcearray(i_source,:,i,j)*source_time_function(i_source,it)
enddo
enddo
+ else ! backward wavefield
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_source(i_source))
+ b_accel_elastic(:,iglob) = b_accel_elastic(:,iglob) + &
+ sourcearray(i_source,:,i,j)*source_time_function(i_source,NSTEP-it+1)
+ enddo
+ enddo
+ endif !endif isolver == 1
+
endif
endif ! if this processor carries the source and the source element is elastic
+ enddo ! do i_source=1,NSOURCE
+ if(isolver == 2) then ! adjoint wavefield
+
+ irec_local = 0
+ do irec = 1,nrec
+! add the source (only if this proc carries the source)
+ if(myrank == which_proc_receiver(irec) .and. elastic(ispec_selected_rec(irec))) then
+
+ irec_local = irec_local + 1
+! add source array
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_rec(irec))
+ accel_elastic(:,iglob) = accel_elastic(:,iglob) + adj_sourcearrays(irec_local,NSTEP-it+1,:,i,j)
+ enddo
+ enddo
+
+ endif ! if this processor carries the adjoint source and the source element is elastic
+ enddo ! irec = 1,nrec
+
+ endif ! if isolver == 2 adjoint wavefield
+
endif ! if not using an initial field
! implement attenuation
Modified: seismo/2D/SPECFEM2D/trunk/compute_pressure.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_pressure.f90 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/compute_pressure.f90 2009-08-03 17:08:30 UTC (rev 15507)
@@ -40,9 +40,10 @@
!
!========================================================================
- subroutine compute_pressure_whole_medium(potential_dot_dot_acoustic,displ_elastic,elastic,vector_field_display, &
+ subroutine compute_pressure_whole_medium(potential_dot_dot_acoustic,displ_elastic,&
+ displs_poroelastic,displw_poroelastic,elastic,poroelastic,vector_field_display, &
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
- numat,kmato,elastcoef,vpext,vsext,rhoext,e1,e11, &
+ numat,kmato,density,porosity,tortuosity,elastcoef,vpext,vsext,rhoext,e1,e11, &
TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,Mu_nu1,Mu_nu2,N_SLS)
! compute pressure in acoustic elements and in elastic elements
@@ -56,14 +57,16 @@
integer, dimension(nspec) :: kmato
integer, dimension(NGLLX,NGLLX,nspec) :: ibool
- double precision, dimension(4,numat) :: elastcoef
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(4,3,numat) :: elastcoef
double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
- logical, dimension(nspec) :: elastic
+ logical, dimension(nspec) :: elastic,poroelastic
real(kind=CUSTOM_REAL), dimension(npoin) :: potential_dot_dot_acoustic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displ_elastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displ_elastic,displs_poroelastic,displw_poroelastic
double precision, dimension(NDIM,npoin) :: vector_field_display
! array with derivatives of Lagrange polynomials
@@ -86,9 +89,10 @@
do ispec = 1,nspec
! compute pressure in this element
- call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,elastic, &
+ call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,&
+ displs_poroelastic,displw_poroelastic,elastic,poroelastic,&
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
- numat,kmato,elastcoef,vpext,vsext,rhoext,ispec,e1,e11, &
+ numat,kmato,density,porosity,tortuosity,elastcoef,vpext,vsext,rhoext,ispec,e1,e11, &
TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,Mu_nu1,Mu_nu2,N_SLS)
! use vector_field_display as temporary storage, store pressure in its second component
@@ -107,9 +111,10 @@
!=====================================================================
!
- subroutine compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,elastic, &
+ subroutine compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,&
+ displs_poroelastic,displw_poroelastic,elastic,poroelastic,&
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
- numat,kmato,elastcoef,vpext,vsext,rhoext,ispec,e1,e11, &
+ numat,kmato,density,porosity,tortuosity,elastcoef,vpext,vsext,rhoext,ispec,e1,e11, &
TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,Mu_nu1,Mu_nu2,N_SLS)
! compute pressure in acoustic elements and in elastic elements
@@ -123,7 +128,9 @@
integer, dimension(nspec) :: kmato
integer, dimension(NGLLX,NGLLX,nspec) :: ibool
- double precision, dimension(4,numat) :: elastcoef
+ double precision, dimension(2,numat) :: density
+ double precision, dimension(numat) :: porosity,tortuosity
+ double precision, dimension(4,3,numat) :: elastcoef
double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
@@ -131,9 +138,9 @@
! pressure in this element
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: pressure_element
- logical, dimension(nspec) :: elastic
+ logical, dimension(nspec) :: elastic,poroelastic
real(kind=CUSTOM_REAL), dimension(npoin) :: potential_dot_dot_acoustic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displ_elastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: displ_elastic,displs_poroelastic,displw_poroelastic
! array with derivatives of Lagrange polynomials
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
@@ -156,12 +163,20 @@
! spatial derivatives
real(kind=CUSTOM_REAL) :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
real(kind=CUSTOM_REAL) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
- real(kind=CUSTOM_REAL) :: sigma_xx,sigma_zz
+ real(kind=CUSTOM_REAL) :: sigma_xx,sigma_zz,sigmap
+ real(kind=CUSTOM_REAL) :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
+ real(kind=CUSTOM_REAL) :: dwx_dxl,dwz_dzl
! material properties of the elastic medium
real(kind=CUSTOM_REAL) :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,denst
real(kind=CUSTOM_REAL) :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed,cpl,csl
+ real(kind=CUSTOM_REAL) :: mul_s,kappal_s,rhol_s
+ real(kind=CUSTOM_REAL) :: kappal_f,rhol_f
+ real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr,phil,tortl
+ real(kind=CUSTOM_REAL) :: D_biot,H_biot,C_biot,M_biot,rhol_bar
+ real(kind=CUSTOM_REAL) :: mul_G,lambdal_G,lambdalplus2mul_G
+
! if elastic element
!
! from L. S. Bennethum, Compressibility Moduli for Porous Materials Incorporating Volume Fraction,
@@ -187,9 +202,9 @@
if(elastic(ispec)) then
! get relaxed elastic parameters of current spectral element
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
- lambdalplus2mul_relaxed = elastcoef(3,kmato(ispec))
+ lambdal_relaxed = elastcoef(1,1,kmato(ispec))
+ mul_relaxed = elastcoef(2,1,kmato(ispec))
+ lambdalplus2mul_relaxed = elastcoef(3,1,kmato(ispec))
do j = 1,NGLLZ
do i = 1,NGLLX
@@ -283,6 +298,126 @@
enddo
enddo
+ elseif(poroelastic(ispec)) then
+
+! get poroelastic parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+!solid properties
+ mul_s = elastcoef(2,1,kmato(ispec))
+ kappal_s = elastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
+ rhol_s = density(1,kmato(ispec))
+!fluid properties
+ kappal_f = elastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+!frame properties
+ mul_fr = elastcoef(2,3,kmato(ispec))
+ kappal_fr = elastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
+ rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + kappal_fr + FOUR_THIRDS*mul_fr
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+!where T = G:grad u_s + C div w I
+!and T_f = C div u_s I + M div w I
+!we are expressing lambdaplus2mu, lambda, and mu for G, C, and M
+ mul_G = mul_fr
+ lambdal_G = H_biot - TWO*mul_fr
+ lambdalplus2mul_G = lambdal_G + TWO*mul_G
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+! derivative along x and along z
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec))*hprime_xx(i,k)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec))*hprime_zz(j,k)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec))*hprime_zz(j,k)
+
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+! compute diagonal components of the stress tensor (include attenuation if needed)
+
+ if(TURN_ATTENUATION_ON) then
+!-------------------- ATTENTION TO BE DEFINED ------------------------------!
+
+! attenuation is implemented following the memory variable formulation of
+! J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
+! vol. 58(1), p. 110-120 (1993). More details can be found in
+! J. M. Carcione, D. Kosloff and R. Kosloff, Wave propagation simulation in a linear
+! viscoelastic medium, Geophysical Journal International, vol. 95, p. 597-611 (1988).
+
+! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
+ lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1(i,j,ispec) - mul_relaxed * Mu_nu2(i,j,ispec)
+ mul_unrelaxed = mul_relaxed * Mu_nu2(i,j,ispec)
+ lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed
+
+! compute the stress using the unrelaxed Lame parameters (Carcione 1993, page 111)
+ sigma_xx = lambdalplus2mul_unrelaxed*dux_dxl + lambdal_unrelaxed*duz_dzl
+ sigma_zz = lambdalplus2mul_unrelaxed*duz_dzl + lambdal_unrelaxed*dux_dxl
+
+! add the memory variables using the relaxed parameters (Carcione 1993, page 111)
+! beware: there is a bug in Carcione's equation (2c) for sigma_zz, we fixed it in the code below
+ e1_sum = 0._CUSTOM_REAL
+ e11_sum = 0._CUSTOM_REAL
+
+ do i_sls = 1,N_SLS
+ e1_sum = e1_sum + e1(i,j,ispec,i_sls)
+ e11_sum = e11_sum + e11(i,j,ispec,i_sls)
+ enddo
+
+ sigma_xx = sigma_xx + (lambdal_relaxed + mul_relaxed) * e1_sum + TWO * mul_relaxed * e11_sum
+ sigma_zz = sigma_zz + (lambdal_relaxed + mul_relaxed) * e1_sum - TWO * mul_relaxed * e11_sum
+
+ else
+
+! no attenuation
+ sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+
+ sigmap = C_biot*(dux_dxl + duz_dzl) + M_biot*(dwx_dxl + dwz_dzl)
+
+ endif
+
+! store pressure
+ pressure_element(i,j) = - (sigma_xx + sigma_zz) / 2.d0
+! pressure_element2(i,j) = - sigmap
+ enddo
+ enddo
+
! pressure = - Chi_dot_dot if acoustic element
else
Modified: seismo/2D/SPECFEM2D/trunk/compute_vector_field.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_vector_field.f90 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/compute_vector_field.f90 2009-08-03 17:08:30 UTC (rev 15507)
@@ -40,7 +40,8 @@
!
!========================================================================
- subroutine compute_vector_whole_medium(potential_acoustic,veloc_elastic,elastic,vector_field_display, &
+ subroutine compute_vector_whole_medium(potential_acoustic,veloc_elastic,velocs_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
! compute Grad(potential) in acoustic elements
@@ -58,15 +59,15 @@
double precision, dimension(NGLLX,NGLLX,nspec) :: rhoext
- double precision, dimension(numat) :: density
+ double precision, dimension(2,numat) :: density
integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
- logical, dimension(nspec) :: elastic
+ logical, dimension(nspec) :: elastic,poroelastic
real(kind=CUSTOM_REAL), dimension(npoin) :: potential_acoustic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: veloc_elastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: veloc_elastic,velocs_poroelastic
double precision, dimension(NDIM,npoin) :: vector_field_display
! array with derivatives of Lagrange polynomials
@@ -83,8 +84,9 @@
do ispec = 1,nspec
! compute vector field in this element
- call compute_vector_one_element(vector_field_element,potential_acoustic,veloc_elastic,elastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,density,rhoext,assign_external_model)
+ call compute_vector_one_element(vector_field_element,potential_acoustic,veloc_elastic,velocs_poroelastic,&
+ elastic,poroelastic,xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,&
+ density,rhoext,assign_external_model)
! store the result
do j = 1,NGLLZ
@@ -102,8 +104,9 @@
!=====================================================================
!
- subroutine compute_vector_one_element(vector_field_element,potential_acoustic,veloc_elastic,elastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,density,rhoext,assign_external_model)
+ subroutine compute_vector_one_element(vector_field_element,potential_acoustic,veloc_elastic,velocs_poroelastic,&
+ elastic,poroelastic,xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,&
+ density,rhoext,assign_external_model)
! compute Grad(potential) if acoustic element or copy existing vector if elastic element
@@ -119,7 +122,7 @@
double precision, dimension(NGLLX,NGLLX,nspec) :: rhoext
- double precision, dimension(numat) :: density
+ double precision, dimension(2,numat) :: density
integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
@@ -128,9 +131,9 @@
! vector field in this element
real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLX) :: vector_field_element
- logical, dimension(nspec) :: elastic
+ logical, dimension(nspec) :: elastic,poroelastic
real(kind=CUSTOM_REAL), dimension(npoin) :: potential_acoustic
- real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: veloc_elastic
+ real(kind=CUSTOM_REAL), dimension(NDIM,npoin) :: veloc_elastic,velocs_poroelastic
! array with derivatives of Lagrange polynomials
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
@@ -160,11 +163,20 @@
enddo
enddo
+ elseif(poroelastic(ispec)) then
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ vector_field_element(1,i,j) = velocs_poroelastic(1,iglob)
+ vector_field_element(2,i,j) = velocs_poroelastic(2,iglob)
+ enddo
+ enddo
+
! compute gradient of potential to calculate vector if acoustic element
! we then need to divide by density because the potential is a potential of (density * displacement)
else
- rhol = density(kmato(ispec))
+ rhol = density(1,kmato(ispec))
! double loop over GLL points to compute and store gradients
do j = 1,NGLLZ
Modified: seismo/2D/SPECFEM2D/trunk/constants.h
===================================================================
--- seismo/2D/SPECFEM2D/trunk/constants.h 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/constants.h 2009-08-03 17:08:30 UTC (rev 15507)
@@ -85,6 +85,9 @@
! uncomment this to write to file instead
! integer, parameter :: IOUT = 41
+! number of lines per source in CMTSOLUTION file
+ integer, parameter :: NLINES_PER_CMTSOLUTION_SOURCE = 13
+
! flags for absorbing boundaries
integer, parameter :: IBOTTOM = 1
integer, parameter :: IRIGHT = 2
Modified: seismo/2D/SPECFEM2D/trunk/gmat01.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/gmat01.f90 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/gmat01.f90 2009-08-03 17:08:30 UTC (rev 15507)
@@ -40,7 +40,8 @@
!
!========================================================================
- subroutine gmat01(density_array,elastcoef,numat,myrank,ipass,Qp_array,Qs_array)
+ subroutine gmat01(density_array,porosity_array,tortuosity_array,permeability,poroelastcoef,&
+ numat,myrank,ipass,Qp_array,Qs_array)
! read properties of a 2D isotropic or anisotropic linear elastic element
@@ -52,32 +53,46 @@
double precision lambdaplus2mu,kappa
integer numat,myrank,ipass
- double precision density_array(numat),elastcoef(4,numat),Qp_array(numat),Qs_array(numat)
+ double precision density_array(2,numat),poroelastcoef(4,3,numat),porosity_array(numat)
+ double precision tortuosity_array(numat),permeability(3,numat)
+ double precision Qp_array(numat),Qs_array(numat)
integer in,n,indic
- double precision young,poisson,density,cp,cs,mu,two_mu,lambda,Qp,Qs
+ double precision young,poisson,cp,cs,mu,two_mu,lambda,Qp,Qs
+ double precision lambdaplus2mu_s,lambdaplus2mu_fr,kappa_s,kappa_f,kappa_fr
+ double precision young_s,poisson_s,density(2),phi,tortuosity,permxx,permzz,permxz
+ double precision cpIsquare,cpIIsquare,cssquare,mu_s,mu_fr,eta_f,lambda_s,lambda_fr
double precision val1,val2,val3,val4,val5,val6
+ double precision val7,val8,val9,val10,val11,val12,val0
double precision c11,c13,c33,c44
+ double precision afactor,bfactor,cfactor,D_biot,H_biot,C_biot,M_biot,density_bar
!
!---- loop over the different material sets
!
- density_array(:) = zero
- elastcoef(:,:) = zero
+ density_array(:,:) = zero
+ porosity_array(:) = zero
+ tortuosity_array(:) = zero
+ permeability(:,:) = zero
+ poroelastcoef(:,:,:) = zero
Qp_array(:) = zero
Qs_array(:) = zero
if(myrank == 0 .and. ipass == 1) write(IOUT,100) numat
read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
do in = 1,numat
- read(IIN,*) n,indic,density,val1,val2,val3,val4,val5,val6
+ read(IIN,*) n,indic,val0,val1,val2,val3,val4,val5,val6,val7,val8,val9,val10,val11,val12
if(n<1 .or. n>numat) call exit_MPI('Wrong material set number')
-!---- isotropic material, P and S velocities given
+!---- isotropic material, P and S velocities given, allows for declaration of elastic/acoustic material
+!---- elastic (cs/=0) and acoustic (cs=0)
if(indic == 1) then
+ density(1) = val0
! P and S velocity
cp = val1
@@ -88,8 +103,8 @@
Qs = val6
! Lam'e parameters
- lambdaplus2mu = density*cp*cp
- mu = density*cs*cs
+ lambdaplus2mu = density(1)*cp*cp
+ mu = density(1)*cs*cs
two_mu = 2.d0*mu
lambda = lambdaplus2mu - two_mu
@@ -107,11 +122,66 @@
!---- anisotropic material, c11, c13, c33 and c44 given in Pascal
else if (indic == 2) then
+
+ density(1) =val0
c11 = val1
c13 = val2
c33 = val3
c44 = val4
+!---- isotropic material, moduli are given, allows for declaration of poroelastic material
+!---- poroelastic (<0phi<1)
+ else if (indic == 3) then
+! Qs values
+ Qs = val12
+
+ density(1) =val0
+ density(2) =val1
+
+! Solid properties
+ kappa_s = val7
+ mu_s = val11
+! Fluid properties
+ kappa_f = val8
+ eta_f = val10
+! Frame properties
+ kappa_fr = val9
+ mu_fr = val11
+! Lam'e parameters for the solid phase and the frame
+ lambdaplus2mu_s = kappa_s + FOUR_THIRDS*mu_s
+ lambda_s = lambdaplus2mu_s - 2.d0*mu_s
+ lambdaplus2mu_fr = kappa_fr + FOUR_THIRDS*mu_fr
+ lambda_fr = lambdaplus2mu_fr - 2.d0*mu_fr
+
+! Biot coefficients for the input phi
+ D_biot = kappa_s*(1.d0 + phi*(kappa_s/kappa_f - 1.d0))
+ H_biot = (kappa_s - kappa_fr)*(kappa_s - kappa_fr)/(D_biot - kappa_fr) + kappa_fr + FOUR_THIRDS*mu_fr
+ C_biot = kappa_s*(kappa_s - kappa_fr)/(D_biot - kappa_fr)
+ M_biot = kappa_s*kappa_s/(D_biot - kappa_fr)
+! Approximated velocities (no viscous dissipation)
+ density_bar = (1.d0 - phi)*density(1) + phi*density(2)
+ afactor = density_bar - phi/tortuosity*density(2)
+ bfactor = H_biot + phi*density_bar/(tortuosity*density(2))*M_biot - 2.d0*phi/tortuosity*C_biot
+ cfactor = phi/(tortuosity*density(2))*(H_biot*M_biot - C_biot*C_biot)
+ cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cssquare = val11/afactor
+
+ porosity_array(n) = val2
+ tortuosity_array(n) = val3
+ permeability(1,n) = val4
+ permeability(2,n) = val5
+ permeability(3,n) = val6
+
+! Young modulus for the solid phase
+ young_s = 9.d0*kappa_s*mu_s/(3.d0*kappa_s + mu_s)
+
+! Poisson's ratio for the solid phase
+ poisson_s = HALF*(3.d0*kappa_s- 2.d0*mu_s)/(3.d0*kappa_s+mu_s)
+
+! Poisson's ratio must be between -1 and +1/2
+ if (poisson_s < -1.d0 .or. poisson_s > 0.5d0) stop 'Poisson''s ratio for the solid phase out of range'
+
else
call exit_MPI('wrong model flag read')
@@ -124,20 +194,47 @@
! Transverse anisotropic : c11, c13, c33, c44
!
if(indic == 1) then
- elastcoef(1,n) = lambda
- elastcoef(2,n) = mu
- elastcoef(3,n) = lambdaplus2mu
- elastcoef(4,n) = zero
+ density_array(1,n) = density(1)
+ poroelastcoef(1,1,n) = lambda
+ poroelastcoef(2,1,n) = mu
+ poroelastcoef(3,1,n) = lambdaplus2mu
+ poroelastcoef(4,1,n) = zero
+ Qp_array(n) = Qp
+ Qs_array(n) = Qs
+ if(mu > TINYVAL) then
+ porosity_array(n) = 0.d0
+ else
+ porosity_array(n) = 1.d0
+ endif
+ elseif(indic == 2) then
+ density_array(1,n) = density(1)
+ poroelastcoef(1,1,n) = c11
+ poroelastcoef(2,1,n) = c13
+ poroelastcoef(3,1,n) = c33
+ poroelastcoef(4,1,n) = c44
+ Qp_array(n) = Qp
+ Qs_array(n) = Qs
+ porosity_array(n) = 0.d0
else
- elastcoef(1,n) = c11
- elastcoef(2,n) = c13
- elastcoef(3,n) = c33
- elastcoef(4,n) = c44
- endif
+ density_array(1,n) = density(1)
+ density_array(2,n) = density(2)
+ poroelastcoef(1,1,n) = lambda_s
+ poroelastcoef(2,1,n) = mu_s ! = mu_fr
+ poroelastcoef(3,1,n) = lambdaplus2mu_s
+ poroelastcoef(4,1,n) = zero
- density_array(n) = density
- Qp_array(n) = Qp
+ poroelastcoef(1,2,n) = kappa_f
+ poroelastcoef(2,2,n) = eta_f
+ poroelastcoef(3,2,n) = zero
+ poroelastcoef(4,2,n) = zero
+
+ poroelastcoef(1,3,n) = lambda_fr
+ poroelastcoef(2,3,n) = mu_fr
+ poroelastcoef(3,3,n) = lambdaplus2mu_fr
+ poroelastcoef(4,3,n) = zero
+ Qp_array(n) = 10.d0 ! dummy for attenuation_model
Qs_array(n) = Qs
+ endif
!
!---- check what has been read
@@ -145,13 +242,21 @@
if(myrank == 0 .and. ipass == 1) then
if(indic == 1) then
! material can be acoustic (fluid) or elastic (solid)
- if(elastcoef(2,n) > TINYVAL) then
- write(IOUT,200) n,cp,cs,density,poisson,lambda,mu,kappa,young,Qp,Qs
- else
- write(IOUT,300) n,cp,density,kappa,Qp,Qs
+ if(poroelastcoef(2,1,n) > TINYVAL) then ! elastic
+ write(IOUT,200) n,cp,cs,density(1),poisson,lambda,mu,kappa,young,Qp,Qs
+ else ! acoustic
+ write(IOUT,300) n,cp,density(1),kappa,Qp,Qs
endif
+ elseif(indic == 2) then ! elastic (anisotropic)
+ write(IOUT,400) n,c11,c13,c33,c44,density,sqrt(c33/density),sqrt(c11/density),sqrt(c44/density),sqrt(c44/density),Qp,Qs
else
- write(IOUT,400) n,c11,c13,c33,c44,density,sqrt(c33/density),sqrt(c11/density),sqrt(c44/density),sqrt(c44/density),Qp,Qs
+! material is poroelastic (solid/fluid)
+ write(iout,500) n,sqrt(cpIsquare),sqrt(cpIIsquare),sqrt(cssquare)
+ write(iout,600) density(1),poisson_s,lambda_s,mu_s,kappa_s,young_s
+ write(iout,700) density(2),kappa_f,eta_f
+ write(iout,800) lambda_fr,mu_fr,kappa_fr,porosity_array(n),tortuosity_array(n),&
+ permeability(1,n),permeability(2,n),permeability(3,n),Qs
+ write(iout,900) D_biot,H_biot,C_biot,M_biot
endif
endif
@@ -161,7 +266,7 @@
!---- formats
!
100 format(//,' M a t e r i a l s e t s : ', &
- ' 2 D e l a s t i c i t y', &
+ ' 2 D (p o r o) e l a s t i c i t y', &
/1x,54('='),//5x,'Number of material sets . . . . . . (numat) =',i6)
200 format(//5x,'----------------------------------------',/5x, &
@@ -205,5 +310,48 @@
'Qp_attenuation. . . . . . . . . . . .(Qp) =',1pe15.8,/5x, &
'Qs_attenuation. . . . . . . . . . . .(Qs) =',1pe15.8)
+ 500 format(//5x,'----------------------------------------',/5x, &
+ '-- Poroelastic isotropic material --',/5x, &
+ '----------------------------------------',/5x, &
+ 'Material set number. . . . . . . . (jmat) =',i6,/5x, &
+ 'First P-wave velocity. . . . . . . . . . . (cpI) =',1pe15.8,/5x, &
+ 'Second P-wave velocity. . . . . . . . . . . (cpII) =',1pe15.8,/5x, &
+ 'S-wave velocity. . . . . . . . . . . (cs) =',1pe15.8)
+
+ 600 format(//5x,'-------------------------------',/5x, &
+ '-- Solid phase properties --',/5x, &
+ 'Mass density. . . . . . . . . . (density_s) =',1pe15.8,/5x, &
+ 'Poisson''s ratio. . . . . . . . .(poisson_s) =',1pe15.8,/5x, &
+ 'First Lame parameter Lambda. . . (lambda_s) =',1pe15.8,/5x, &
+ 'Second Lame parameter Mu. . . . . . .(mu_s) =',1pe15.8,/5x, &
+ 'Solid bulk modulus Kappa . . . . . . . .(kappa_s) =',1pe15.8,/5x, &
+ 'Young''s modulus E. . . . . . . . .(young_s) =',1pe15.8)
+
+ 700 format(//5x,'-------------------------------',/5x, &
+ '-- Fluid phase properties --',/5x, &
+ 'Mass density. . . . . . . . . . (density_f) =',1pe15.8,/5x, &
+ 'Fluid bulk modulus Kappa . . . . . . . .(kappa_f) =',1pe15.8,/5x, &
+ 'Fluid viscosity Eta . . . . . . . .(eta_f) =',1pe15.8)
+
+ 800 format(//5x,'-------------------------------',/5x, &
+ '-- Frame properties --',/5x, &
+ 'First Lame parameter Lambda. . . (lambda_fr) =',1pe15.8,/5x, &
+ 'Second Lame parameter Mu. . . . . . .(mu_fr) =',1pe15.8,/5x, &
+ 'Frame bulk modulus Kappa . . . . . . . .(kappa_fr) =',1pe15.8,/5x, &
+ 'Porosity. . . . . . . . . . . . . . . . .(phi) =',1pe15.8,/5x,&
+ 'Tortuosity. . . . . . . . . . . . . . . . .(c) =',1pe15.8,/5x,&
+ 'Permeability xx component. . . . . . . . . . =',1pe15.8,/5x,&
+ 'Permeability zx component. . . . . . . . . . =',1pe15.8,/5x,&
+ 'Permeability zz component. . . . . . . . . . =',1pe15.8,/5x,&
+ 'Qs_attenuation. . . . . . . . . . . .(Qs) =',1pe15.8)
+
+ 900 format(//5x,'-------------------------------',/5x, &
+ '-- Biot coefficients --',/5x, &
+ '-------------------------------',/5x, &
+ 'D. . . . . . . . =',1pe15.8,/5x, &
+ 'H. . . . . . . . =',1pe15.8,/5x, &
+ 'C. . . . . . . . =',1pe15.8,/5x, &
+ 'M. . . . . . . . =',1pe15.8)
+
end subroutine gmat01
Modified: seismo/2D/SPECFEM2D/trunk/meshfem2D.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/meshfem2D.F90 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/meshfem2D.F90 2009-08-03 17:08:30 UTC (rev 15507)
@@ -96,7 +96,9 @@
double precision :: gamma,absx,a00,a01,bot0,top0
! to store density and velocity model
- double precision, dimension(:), allocatable :: rho,cp,cs,aniso3,aniso4,Qp,Qs
+ double precision, dimension(:), allocatable :: rho_s,cp,cs,aniso3,aniso4,Qp,Qs
+ double precision, dimension(:), allocatable :: rho_f,phi,tortuosity,permxx,permxz,&
+ permzz,kappa_s,kappa_f,kappa_fr,eta_f,mu_fr
integer, dimension(:), allocatable :: icodemat
integer, dimension(:), allocatable :: num_material
@@ -110,8 +112,15 @@
xinterface_top,zinterface_top,coefs_interface_top
! for the source and receivers
- integer source_type,time_function_type,nrec_total,irec_global_number
- double precision xs,zs,f0,t0,angleforce,Mxx,Mzz,Mxz,factor,xrec,zrec
+ integer, dimension(:), allocatable :: source_type,time_function_type
+ integer nrec_total,irec_global_number
+ double precision, dimension(:),allocatable :: xs,zs,f0,t0,angleforce,Mxx,Mzz,Mxz,factor
+ integer NSOURCE, NSOURCES, i_source, icounter, ios
+ logical, dimension(:),allocatable :: source_surf
+ double precision xrec,zrec
+! file number for source file
+ integer, parameter :: IIN_SOURCE = 22
+ character(len=150) dummystring
character(len=50) interfacesfile,title
@@ -131,23 +140,33 @@
double precision tang1,tangN,vpregion,vsregion,poisson_ratio
double precision cutsnaps,sizemax_arrows,anglerec,xmin,xmax,deltat
- double precision rhoread,cpread,csread,aniso3read,aniso4read,Qpread,Qsread
+ double precision val0read,val1read,val2read,val3read,val4read,val5read,val6read,val7read,&
+ val8read,val9read,val10read,val11read,val12read
double precision, dimension(:), allocatable :: xdeb,zdeb,xfin,zfin
logical interpol,gnuplot,assign_external_model,outputgrid
logical abstop,absbottom,absleft,absright,any_abs
- logical source_surf,meshvect,initialfield,modelvect,boundvect,add_Bielak_conditions
- logical TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
+ logical meshvect,initialfield,modelvect,boundvect,add_Bielak_conditions
+ logical TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON
+ double precision :: Q0,freq0
+
logical, dimension(:), allocatable :: enreg_surf
integer, external :: num_4, num_9
double precision, external :: value_spline
+! flag to save the last frame for kernels calculation purpose and type of simulation
+ logical :: save_forward
+ integer :: isolver
+
! flag to indicate an anisotropic material
integer, parameter :: ANISOTROPIC_MATERIAL = 2
+! flag to indicate a poroelastic material
+ integer, parameter :: POROELASTIC_MATERIAL = 3
+
! file number for interface file
integer, parameter :: IIN_INTERFACES = 15
@@ -182,8 +201,15 @@
integer, dimension(:), allocatable :: my_interfaces
integer, dimension(:), allocatable :: my_nb_interfaces
+! for acoustic/elastic coupled elements
integer :: nedges_coupled, nedges_coupled_loc
integer, dimension(:,:), pointer :: edges_coupled
+! for acoustic/poroelastic coupled elements
+ integer :: nedges_acporo_coupled, nedges_acporo_coupled_loc
+ integer, dimension(:,:), pointer :: edges_acporo_coupled
+! for poroelastic/elastic coupled elements
+ integer :: nedges_elporo_coupled, nedges_elporo_coupled_loc
+ integer, dimension(:,:), pointer :: edges_elporo_coupled
integer :: num_start
integer :: nelmnts
@@ -309,6 +335,11 @@
call read_value_logical(IIN,IGNORE_JUNK,TURN_ANISOTROPY_ON)
call read_value_logical(IIN,IGNORE_JUNK,TURN_ATTENUATION_ON)
+! read viscous attenuation parameters (poroelastic media)
+ call read_value_logical(IIN,IGNORE_JUNK,TURN_VISCATTENUATION_ON)
+ call read_value_double_precision(IIN,IGNORE_JUNK,Q0)
+ call read_value_double_precision(IIN,IGNORE_JUNK,freq0)
+
if ( read_external_mesh ) then
call read_mesh(mesh_file, nelmnts, elmnts, nnodes, num_start)
@@ -425,55 +456,92 @@
! read time step parameters
call read_value_integer(IIN,IGNORE_JUNK,nt)
call read_value_double_precision(IIN,IGNORE_JUNK,deltat)
+ call read_value_integer(IIN,IGNORE_JUNK,isolver)
! read source parameters
- call read_value_logical(IIN,IGNORE_JUNK,source_surf)
- call read_value_double_precision(IIN,IGNORE_JUNK,xs)
- call read_value_double_precision(IIN,IGNORE_JUNK,zs)
- call read_value_integer(IIN,IGNORE_JUNK,source_type)
- call read_value_integer(IIN,IGNORE_JUNK,time_function_type)
- call read_value_double_precision(IIN,IGNORE_JUNK,f0)
- call read_value_double_precision(IIN,IGNORE_JUNK,angleforce)
- call read_value_double_precision(IIN,IGNORE_JUNK,Mxx)
- call read_value_double_precision(IIN,IGNORE_JUNK,Mzz)
- call read_value_double_precision(IIN,IGNORE_JUNK,Mxz)
- call read_value_double_precision(IIN,IGNORE_JUNK,factor)
- call read_value_logical(IIN,IGNORE_JUNK,force_normal_to_surface)
+ call read_value_integer(IIN,IGNORE_JUNK,NSOURCE)
+ allocate(source_surf(NSOURCE))
+ allocate(xs(NSOURCE))
+ allocate(zs(NSOURCE))
+ allocate(source_type(NSOURCE))
+ allocate(time_function_type(NSOURCE))
+ allocate(f0(NSOURCE))
+ allocate(t0(NSOURCE))
+ allocate(angleforce(NSOURCE))
+ allocate(Mxx(NSOURCE))
+ allocate(Mxz(NSOURCE))
+ allocate(Mzz(NSOURCE))
+ allocate(factor(NSOURCE))
+ open(unit=IIN_SOURCE,file='DATA/CMTSOLUTION',iostat=ios,status='old',action='read')
+ if(ios /= 0) stop 'error opening CMTSOLUTION file'
+ icounter = 0
+ do while(ios == 0)
+ read(IIN_SOURCE,"(a)",iostat=ios) dummystring
+ if(ios == 0) icounter = icounter + 1
+ enddo
+ close(IIN_SOURCE)
+ if(mod(icounter,NLINES_PER_CMTSOLUTION_SOURCE) /= 0) &
+ stop 'total number of lines in CMTSOLUTION file should be a multiple of NLINES_PER_CMTSOLUTION_SOURCE'
+ NSOURCES = icounter / NLINES_PER_CMTSOLUTION_SOURCE
+ if(NSOURCES < 1) stop 'need at least one source in CMTSOLUTION file'
+ if(NSOURCES /= NSOURCE) &
+ stop 'total number of sources read is different than declared in Par_file'
+
+ open(unit=IIN_SOURCE,file='DATA/CMTSOLUTION',status='old',action='read')
+ do i_source=1,NSOURCE
+ call read_value_logical(IIN_SOURCE,IGNORE_JUNK,source_surf(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,xs(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,zs(i_source))
+ call read_value_integer(IIN_SOURCE,IGNORE_JUNK,source_type(i_source))
+ call read_value_integer(IIN_SOURCE,IGNORE_JUNK,time_function_type(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,f0(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,t0(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,angleforce(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,Mxx(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,Mzz(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,Mxz(i_source))
+ call read_value_double_precision(IIN_SOURCE,IGNORE_JUNK,factor(i_source))
+
! if Dirac source time function, use a very thin Gaussian instead
! if Heaviside source time function, use a very thin error function instead
- if(time_function_type == 4 .or. time_function_type == 5) f0 = 1.d0 / (10.d0 * deltat)
+ if(time_function_type(i_source) == 4 .or. time_function_type(i_source) == 5) f0(i_source) = 1.d0 / (10.d0 * deltat)
-! time delay of the source in seconds, use a 20 % security margin (use 2 / f0 if error function)
- if(time_function_type == 5) then
- t0 = 2.0d0 / f0
- else
- t0 = 1.20d0 / f0
- endif
+ ! time delay of the source in seconds, use a 20 % security margin (use 2 / f0 if error function)
+ if(time_function_type(i_source)== 5) then
+ t0(i_source) = 2.0d0 / f0(i_source)+t0(i_source)
+ else
+ t0(i_source) = 1.20d0 / f0(i_source)+t0(i_source)
+ endif
- print *
- print *,'Source:'
- print *,'Position xs, zs = ',xs,zs
- print *,'Frequency, delay = ',f0,t0
- print *,'Source type (1=force, 2=explosion): ',source_type
- print *,'Time function type (1=Ricker, 2=First derivative, 3=Gaussian, 4=Dirac, 5=Heaviside): ',time_function_type
- print *,'Angle of the source if force = ',angleforce
- print *,'Mxx of the source if moment tensor = ',Mxx
- print *,'Mzz of the source if moment tensor = ',Mzz
- print *,'Mxz of the source if moment tensor = ',Mxz
- print *,'Multiplying factor = ',factor
+ print *
+ print *,'Source', i_source
+ print *,'Position xs, zs = ',xs(i_source),zs(i_source)
+ print *,'Frequency, delay = ',f0(i_source),t0(i_source)
+ print *,'Source type (1=force, 2=explosion): ',source_type(i_source)
+ print *,'Time function type (1=Ricker, 2=First derivative, 3=Gaussian, 4=Dirac, 5=Heaviside): ',time_function_type(i_source)
+ print *,'Angle of the source if force = ',angleforce(i_source)
+ print *,'Mxx of the source if moment tensor = ',Mxx(i_source)
+ print *,'Mzz of the source if moment tensor = ',Mzz(i_source)
+ print *,'Mxz of the source if moment tensor = ',Mxz(i_source)
+ print *,'Multiplying factor = ',factor(i_source)
+ enddo ! do i_source=1,NSOURCE
+ close(IIN_SOURCE)
+ call read_value_logical(IIN,IGNORE_JUNK,force_normal_to_surface)
+
! read constants for attenuation
call read_value_integer(IIN,IGNORE_JUNK,N_SLS)
call read_value_double_precision(IIN,IGNORE_JUNK,f0_attenuation)
-! if source is not a Dirac or Heavyside then f0_attenuation is f0
- if(.not. (time_function_type == 4 .or. time_function_type == 5)) then
- f0_attenuation = f0
+! if source is not a Dirac or Heavyside then f0_attenuation is f0 of the first source
+ if(.not. (time_function_type(1) == 4 .or. time_function_type(1) == 5)) then
+ f0_attenuation = f0(1)
endif
! read receiver line parameters
call read_value_integer(IIN,IGNORE_JUNK,seismotype)
+ call read_value_logical(IIN,IGNORE_JUNK,save_forward)
call read_value_logical(IIN,IGNORE_JUNK,generate_STATIONS)
call read_value_integer(IIN,IGNORE_JUNK,nreceiverlines)
call read_value_double_precision(IIN,IGNORE_JUNK,anglerec)
@@ -531,57 +599,114 @@
if(nb_materials <= 0) stop 'Negative number of materials not allowed!'
allocate(icodemat(nb_materials))
- allocate(rho(nb_materials))
allocate(cp(nb_materials))
allocate(cs(nb_materials))
allocate(aniso3(nb_materials))
allocate(aniso4(nb_materials))
allocate(Qp(nb_materials))
allocate(Qs(nb_materials))
+ allocate(rho_s(nb_materials))
+ allocate(rho_f(nb_materials))
+ allocate(phi(nb_materials))
+ allocate(tortuosity(nb_materials))
+ allocate(permxx(nb_materials))
+ allocate(permxz(nb_materials))
+ allocate(permzz(nb_materials))
+ allocate(kappa_s(nb_materials))
+ allocate(kappa_f(nb_materials))
+ allocate(kappa_fr(nb_materials))
+ allocate(eta_f(nb_materials))
+ allocate(mu_fr(nb_materials))
allocate(num_material(nelmnts))
icodemat(:) = 0
- rho(:) = 0.d0
cp(:) = 0.d0
cs(:) = 0.d0
aniso3(:) = 0.d0
aniso4(:) = 0.d0
Qp(:) = 0.d0
Qs(:) = 0.d0
+ rho_s(:) = 0.d0
+ rho_f(:) = 0.d0
+ phi(:) = 0.d0
+ tortuosity(:) = 0.d0
+ permxx(:) = 0.d0
+ permxz(:) = 0.d0
+ permzz(:) = 0.d0
+ kappa_s(:) = 0.d0
+ kappa_f(:) = 0.d0
+ kappa_fr(:) = 0.d0
+ eta_f(:) = 0.d0
+ mu_fr(:) = 0.d0
num_material(:) = 0
do imaterial=1,nb_materials
- call read_material_parameters(IIN,DONT_IGNORE_JUNK,i,icodematread,rhoread,Qpread,Qsread,cpread,csread,aniso3read,aniso4read)
+ call read_material_parameters(IIN,DONT_IGNORE_JUNK,i,icodematread,val0read,val1read,val2read,val3read, &
+ val4read,val5read,val6read,val7read,val8read,val9read,val10read,val11read,val12read)
if(i < 1 .or. i > nb_materials) stop 'Wrong material number!'
icodemat(i) = icodematread
- rho(i) = rhoread
- cp(i) = cpread
- cs(i) = csread
- Qp(i) = Qpread
- Qs(i) = Qsread
- if(rho(i) <= 0.d0 .or. cp(i) <= 0.d0 .or. cs(i) < 0.d0) stop 'negative value of velocity or density'
+ if(icodemat(i) /= POROELASTIC_MATERIAL) then
+ rho_s(i) = val0read
+ cp(i) = val1read
+ cs(i) = val2read
+ Qp(i) = val5read
+ Qs(i) = val6read
+
+ if(rho_s(i) <= 0.d0 .or. cp(i) <= 0.d0 .or. cs(i) < 0.d0) stop 'negative value of velocity or density'
if(Qp(i) <= 0.d0 .or. Qs(i) <= 0.d0) stop 'negative value of Qp or Qs'
- aniso3(i) = aniso3read
- aniso4(i) = aniso4read
+ aniso3(i) = val3read
+ aniso4(i) = val4read
+ if(cs(i) /= 0.d0) then
+ phi(i) = 0.d0 ! elastic
+ else
+ phi(i) = 1.d0 ! acoustic
+ endif
+ else ! poroelastic
+ rho_s(i) = val0read
+ rho_f(i) = val1read
+ phi(i) = val2read
+ tortuosity(i) = val3read
+ permxx(i) = val4read
+ permxz(i) = val5read
+ permzz(i) = val6read
+ kappa_s(i) = val7read
+ kappa_f(i) = val8read
+ kappa_fr(i) = val9read
+ eta_f(i) = val10read
+ mu_fr(i) = val11read
+ Qs(i) = val12read
+
+ if(rho_s(i) <= 0.d0 .or. rho_f(i) <= 0.d0) stop 'negative value of density'
+ if(phi(i) <= 0.d0 .or. tortuosity(i) <= 0.d0) stop 'negative value of porosity or tortuosity'
+ if(kappa_s(i) <= 0.d0 .or. kappa_f(i) <= 0.d0 .or. kappa_fr(i) <= 0.d0 .or. mu_fr(i) <= 0.d0) stop 'negative value of modulus'
+ if(Qs(i) <= 0.d0) stop 'negative value of Qs'
+ endif
enddo
print *
- print *, 'Nb of solid or fluid materials = ',nb_materials
+ print *, 'Nb of solid, fluid or porous materials = ',nb_materials
print *
do i=1,nb_materials
- if(icodemat(i) /= ANISOTROPIC_MATERIAL) then
+ if(icodemat(i) /= ANISOTROPIC_MATERIAL .and. icodemat(i) /= POROELASTIC_MATERIAL) then
print *,'Material #',i,' isotropic'
- print *,'rho,cp,cs = ',rho(i),cp(i),cs(i),Qp(i),Qs(i)
+ print *,'rho,cp,cs = ',rho_s(i),cp(i),cs(i),Qp(i),Qs(i)
if(cs(i) < TINYVAL) then
print *,'Material is fluid'
else
print *,'Material is solid'
endif
+ elseif(icodemat(i) == POROELASTIC_MATERIAL) then
+ print *,'Material #',i,' isotropic'
+ print *,'rho_s, kappa_s= ',rho_s(i),kappa_s(i)
+ print *,'rho_f, kappa_f, eta_f= ',rho_f(i),kappa_f(i),eta_f(i)
+ print *,'phi, tortuosity, permxx, permxz, permzz= ',phi(i),tortuosity(i),permxx(i),permxz(i),permzz(i)
+ print *,'kappa_fr, mu_fr, Qs= ',kappa_fr(i),mu_fr(i),Qs(i)
+ print *,'Material is porous'
else
print *,'Material #',i,' anisotropic'
- print *,'rho,c11,c13,c33,c44 = ',rho(i),cp(i),cs(i),aniso3(i),aniso4(i),Qp(i),Qs(i)
+ print *,'rho,c11,c13,c33,c44 = ',rho_s(i),cp(i),cs(i),aniso3(i),aniso4(i),Qp(i),Qs(i)
endif
print *
enddo
@@ -626,7 +751,7 @@
print *,'IX from ',ixdebregion,' to ',ixfinregion
print *,'IZ from ',izdebregion,' to ',izfinregion
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL) then
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. icodemat(imaterial_number) /= POROELASTIC_MATERIAL) then
vpregion = cp(imaterial_number)
vsregion = cs(imaterial_number)
print *,'Material # ',imaterial_number,' isotropic'
@@ -637,19 +762,22 @@
endif
print *,'vp = ',vpregion
print *,'vs = ',vsregion
- print *,'rho = ',rho(imaterial_number)
+ print *,'rho = ',rho_s(imaterial_number)
poisson_ratio = 0.5d0*(vpregion*vpregion-2.d0*vsregion*vsregion) / (vpregion*vpregion-vsregion*vsregion)
print *,'Poisson''s ratio = ',poisson_ratio
if(poisson_ratio <= -1.00001d0 .or. poisson_ratio >= 0.50001d0) stop 'incorrect value of Poisson''s ratio'
print *,'Qp = ',Qp(imaterial_number)
print *,'Qs = ',Qs(imaterial_number)
+ elseif(icodemat(imaterial_number) == POROELASTIC_MATERIAL) then
+ print *,'Material # ',imaterial_number,' isotropic'
+ print *,'Material is poroelastic'
else
print *,'Material # ',imaterial_number,' anisotropic'
print *,'c11 = ',cp(imaterial_number)
print *,'c13 = ',cs(imaterial_number)
print *,'c33 = ',aniso3(imaterial_number)
print *,'c44 = ',aniso4(imaterial_number)
- print *,'rho = ',rho(imaterial_number)
+ print *,'rho = ',rho_s(imaterial_number)
print *,'Qp = ',Qp(imaterial_number)
print *,'Qs = ',Qs(imaterial_number)
endif
@@ -743,8 +871,10 @@
! check if we are in the last layer, which contains topography,
! and modify the position of the source accordingly if it is located exactly at the surface
- if(source_surf .and. ilayer == number_of_layers) &
- zs = value_spline(xs,xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
+ do i_source=1,NSOURCE
+ if(source_surf(i_source) .and. ilayer == number_of_layers) &
+ zs(i_source) = value_spline(xs(i_source),xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
+ enddo
! compute the offset of this layer in terms of number of spectral elements below along Z
if(ilayer > 1) then
@@ -818,7 +948,7 @@
if ( read_external_mesh ) then
call read_acoustic_surface(free_surface_file, nelem_acoustic_surface, acoustic_surface, &
- nelmnts, num_material, ANISOTROPIC_MATERIAL, nb_materials, icodemat, cs, num_start)
+ nelmnts, num_material, ANISOTROPIC_MATERIAL, nb_materials, icodemat, phi, num_start)
if ( any_abs ) then
call read_abs_surface(absorbing_surface_file, nelemabs, abs_surface, num_start)
@@ -835,7 +965,7 @@
j = nzread
do i = 1,nxread
imaterial_number = num_material((j-1)*nxread+i)
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. cs(imaterial_number) < TINYVAL ) then
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
nelem_acoustic_surface = nelem_acoustic_surface + 1
endif
enddo
@@ -846,7 +976,7 @@
j = nzread
do i = 1,nxread
imaterial_number = num_material((j-1)*nxread+i)
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. cs(imaterial_number) < TINYVAL ) then
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >=1.d0 ) then
nelem_acoustic_surface = nelem_acoustic_surface + 1
acoustic_surface(1,nelem_acoustic_surface) = (j-1)*nxread + (i-1)
acoustic_surface(2,nelem_acoustic_surface) = 2
@@ -1050,12 +1180,28 @@
! beware of fluid solid edges : coupled elements are transfered to the same partition
if ( ngnod == 9 ) then
- call acoustic_elastic_repartitioning (nelmnts, nnodes, elmnts_bis, nb_materials, cs, num_material, &
+ call acoustic_elastic_repartitioning (nelmnts, nnodes, elmnts_bis, nb_materials, phi, num_material, &
nproc, part, nedges_coupled, edges_coupled)
else
- call acoustic_elastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, cs, num_material, &
+ call acoustic_elastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi, num_material, &
nproc, part, nedges_coupled, edges_coupled)
endif
+! beware of fluid porous edges : coupled elements are transfered to the same partition
+ if ( ngnod == 9 ) then
+ call acoustic_poro_repartitioning (nelmnts, nnodes, elmnts_bis, nb_materials, phi, num_material, &
+ nproc, part, nedges_acporo_coupled, edges_acporo_coupled)
+ else
+ call acoustic_poro_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi, num_material, &
+ nproc, part, nedges_acporo_coupled, edges_acporo_coupled)
+ endif
+! beware of porous solid edges : coupled elements are transfered to the same partition
+ if ( ngnod == 9 ) then
+ call poro_elastic_repartitioning (nelmnts, nnodes, elmnts_bis, nb_materials, phi, num_material, &
+ nproc, part, nedges_elporo_coupled, edges_elporo_coupled)
+ else
+ call poro_elastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi, num_material, &
+ nproc, part, nedges_elporo_coupled, edges_elporo_coupled)
+ endif
! local number of each element for each partition
call Construct_glob2loc_elmnts(nelmnts, part, nproc, glob2loc_elmnts)
@@ -1098,10 +1244,10 @@
if ( nproc /= 1 ) then
if ( ngnod == 9 ) then
call Construct_interfaces(nelmnts, nproc, part, elmnts_bis, xadj, adjncy, tab_interfaces, &
- tab_size_interfaces, ninterfaces, nb_materials, cs, num_material)
+ tab_size_interfaces, ninterfaces, nb_materials, phi, num_material)
else
call Construct_interfaces(nelmnts, nproc, part, elmnts, xadj, adjncy, tab_interfaces, &
- tab_size_interfaces, ninterfaces, nb_materials, cs, num_material)
+ tab_size_interfaces, ninterfaces, nb_materials, phi, num_material)
endif
allocate(my_interfaces(0:ninterfaces-1))
allocate(my_nb_interfaces(0:ninterfaces-1))
@@ -1112,7 +1258,7 @@
call merge_abs_boundaries(nelemabs, nelemabs_merge, abs_surface, abs_surface_char, abs_surface_merge, &
ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
jbegin_left,jend_left,jbegin_right,jend_right, &
- nedges_coupled, edges_coupled, nb_materials, cs, num_material, &
+ nedges_coupled, edges_coupled, nb_materials, phi, num_material, &
nelmnts, &
elmnts, ngnod)
endif
@@ -1162,18 +1308,26 @@
write(15,*) 'initialfield add_Bielak_conditions'
write(15,*) initialfield,add_Bielak_conditions
- write(15,*) 'seismotype imagetype'
- write(15,*) seismotype,imagetype
+ write(15,*) 'seismotype imagetype save_forward'
+ write(15,*) seismotype,imagetype,save_forward
write(15,*) 'assign_external_model outputgrid TURN_ANISOTROPY_ON TURN_ATTENUATION_ON'
write(15,*) assign_external_model,outputgrid,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
- write(15,*) 'nt deltat'
- write(15,*) nt,deltat
+ write(15,*) 'TURN_VISCATTENUATION_ON Q0 freq0'
+ write(15,*) TURN_VISCATTENUATION_ON,Q0,freq0
- write(15,*) 'source'
- write(15,*) source_type,time_function_type,xs,zs,f0,t0,factor,angleforce,Mxx,Mzz,Mxz
+ write(15,*) 'nt deltat isolver'
+ write(15,*) nt,deltat,isolver
+ write(15,*) 'NSOURCE'
+ write(15,*) NSOURCE
+ do i_source=1,NSOURCE
+ write(15,*) 'source', i_source
+ write(15,*) source_type(i_source),time_function_type(i_source),xs(i_source),zs(i_source),f0(i_source),t0(i_source), &
+ factor(i_source),angleforce(i_source),Mxx(i_source),Mzz(i_source),Mxz(i_source)
+ enddo
+
write(15,*) 'attenuation'
write(15,*) N_SLS, f0_attenuation
@@ -1201,13 +1355,26 @@
call write_fluidsolid_edges_database(15, nedges_coupled, nedges_coupled_loc, &
edges_coupled, glob2loc_elmnts, part, iproc, 1)
+ call write_fluidsolid_edges_database(15, nedges_acporo_coupled, nedges_acporo_coupled_loc, &
+ edges_acporo_coupled, glob2loc_elmnts, part, iproc, 1)
+ call write_fluidsolid_edges_database(15, nedges_elporo_coupled, nedges_elporo_coupled_loc, &
+ edges_elporo_coupled, glob2loc_elmnts, part, iproc, 1)
- write(15,*) 'nelemabs nelem_acoustic_surface num_fluid_solid_edges nnodes_tangential_curve'
- write(15,*) nelemabs_loc,nelem_acoustic_surface_loc,nedges_coupled_loc,nnodes_tangential_curve
+ write(15,*) 'nelemabs nelem_acoustic_surface num_fluid_solid_edges num_fluid_poro_edges'
+ write(15,*) 'num_solid_poro_edges nnodes_tangential_curve'
+ write(15,*) nelemabs_loc,nelem_acoustic_surface_loc,nedges_coupled_loc,nedges_acporo_coupled_loc,&
+ nedges_elporo_coupled_loc,nnodes_tangential_curve
- write(15,*) 'Material sets (num 1 rho vp vs 0 0 Qp Qs) or (num 2 rho c11 c13 c33 c44 Qp Qs)'
+ write(15,*) 'Material sets (num 1 rho vp vs 0 0 Qp Qs 0 0 0 0 0 0) or '
+ write(15,*) '(num 2 rho c11 c13 c33 c44 Qp Qs 0 0 0 0 0 0) or '
+ write(15,*) '(num 3 rhos rhof phi c k_xx k_xz k_zz Ks Kf Kfr etaf mufr Qs)'
do i=1,nb_materials
- write(15,*) i,icodemat(i),rho(i),cp(i),cs(i),aniso3(i),aniso4(i),Qp(i),Qs(i)
+ if (icodemat(i) /= POROELASTIC_MATERIAL)then
+ write(15,*) i,icodemat(i),rho_s(i),cp(i),cs(i),aniso3(i),aniso4(i),Qp(i),Qs(i),0,0,0,0,0,0
+ else
+ write(15,*) i,icodemat(i),rho_s(i),rho_f(i),phi(i),tortuosity(i),permxx(i),permxz(i),permzz(i),kappa_s(i),&
+ kappa_f(i),kappa_fr(i),eta_f(i),mu_fr(i),Qs(i)
+ endif
enddo
write(15,*) 'Arrays kmato and knods for each bloc:'
@@ -1252,6 +1419,14 @@
call write_fluidsolid_edges_database(15, nedges_coupled, nedges_coupled_loc, &
edges_coupled, glob2loc_elmnts, part, iproc, 2)
+ write(15,*) 'List of acoustic poroelastic coupled edges:'
+ call write_fluidsolid_edges_database(15, nedges_acporo_coupled, nedges_acporo_coupled_loc, &
+ edges_acporo_coupled, glob2loc_elmnts, part, iproc, 2)
+
+ write(15,*) 'List of poroelastic elastic coupled edges:'
+ call write_fluidsolid_edges_database(15, nedges_elporo_coupled, nedges_elporo_coupled_loc, &
+ edges_elporo_coupled, glob2loc_elmnts, part, iproc, 2)
+
write(15,*) 'List of tangential detection curve nodes:'
!write(15,*) nnodes_tangential_curve
write(15,*) force_normal_to_surface,rec_normal_to_surface
@@ -1262,9 +1437,11 @@
! print position of the source
- print *
- print *,'Position (x,z) of the source = ',xs,zs
- print *
+ do i_source=1,NSOURCE
+ print *
+ print *,'Position (x,z) of the source = ',xs(i_source),zs(i_source)
+ print *
+ enddo
!--- compute position of the receivers and write the STATIONS file
Modified: seismo/2D/SPECFEM2D/trunk/part_unstruct.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/part_unstruct.F90 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/part_unstruct.F90 2009-08-03 17:08:30 UTC (rev 15507)
@@ -132,7 +132,7 @@
! 3/ first node on the free surface, 4/ second node on the free surface, if relevant (if 2/ is equal to 2)
!-----------------------------------------------
subroutine read_acoustic_surface(filename, nelem_acoustic_surface, acoustic_surface, &
- nelmnts, num_material, ANISOTROPIC_MATERIAL, nb_materials, icodemat, cs, num_start)
+ nelmnts, num_material, ANISOTROPIC_MATERIAL, nb_materials, icodemat, phi, num_start)
include "constants.h"
@@ -144,7 +144,7 @@
integer, intent(in) :: ANISOTROPIC_MATERIAL
integer, intent(in) :: nb_materials
integer, dimension(1:nb_materials), intent(in) :: icodemat
- double precision, dimension(1:nb_materials), intent(in) :: cs
+ double precision, dimension(1:nb_materials), intent(in) :: phi
integer, intent(in) :: num_start
@@ -172,7 +172,7 @@
nelem_acoustic_surface = 0
do i = 1, nelmnts_surface
imaterial_number = num_material(acoustic_surface_tmp(1,i))
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. cs(imaterial_number) < TINYVAL ) then
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
nelem_acoustic_surface = nelem_acoustic_surface + 1
endif
@@ -183,7 +183,7 @@
nelem_acoustic_surface = 0
do i = 1, nelmnts_surface
imaterial_number = num_material(acoustic_surface_tmp(1,i))
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. cs(imaterial_number) < TINYVAL ) then
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. phi(imaterial_number) >= 1.d0 ) then
nelem_acoustic_surface = nelem_acoustic_surface + 1
acoustic_surface(:,nelem_acoustic_surface) = acoustic_surface_tmp(:,i)
endif
@@ -461,10 +461,10 @@
! Two adjacent elements in distinct partitions make an entry in array tab_interfaces :
! 1/ first element, 2/ second element, 3/ number of common nodes, 4/ first node,
! 5/ second node, if relevant.
- ! No interface between acoustic and elastic elements.
+ ! No interface between acoustic, elastic, and poroelastic elements.
!--------------------------------------------------
subroutine Construct_interfaces(nelmnts, nparts, part, elmnts, xadj, adjncy, tab_interfaces, &
- tab_size_interfaces, ninterfaces, nb_materials, cs_material, num_material)
+ tab_size_interfaces, ninterfaces, nb_materials, phi_material, num_material)
include "constants.h"
@@ -476,14 +476,14 @@
integer, dimension(:),pointer :: tab_size_interfaces, tab_interfaces
integer, intent(out) :: ninterfaces
integer, dimension(1:nelmnts), intent(in) :: num_material
- double precision, dimension(1:nb_materials), intent(in) :: cs_material
+ double precision, dimension(1:nb_materials), intent(in) :: phi_material
integer, intent(in) :: nb_materials
integer :: num_part, num_part_bis, el, el_adj, num_interface, num_edge, ncommon_nodes, &
num_node, num_node_bis
integer :: i, j
- logical :: is_acoustic_el, is_acoustic_el_adj
+ logical :: is_acoustic_el, is_acoustic_el_adj, is_elastic_el, is_elastic_el_adj
ninterfaces = 0
do i = 0, nparts-1
@@ -502,18 +502,29 @@
do num_part_bis = num_part+1, nparts-1
do el = 0, nelmnts-1
if ( part(el) == num_part ) then
- if ( cs_material(num_material(el+1)) < TINYVAL) then
+ if ( phi_material(num_material(el+1)) < TINYVAL) then
+ is_acoustic_el = .false.
+ is_elastic_el = .true.
+ elseif ( phi_material(num_material(el+1)) >= 1.d0) then
is_acoustic_el = .true.
+ is_elastic_el = .false.
else
is_acoustic_el = .false.
+ is_elastic_el = .false.
endif
do el_adj = xadj(el), xadj(el+1)-1
- if ( cs_material(num_material(adjncy(el_adj)+1)) < TINYVAL) then
+ if ( phi_material(num_material(adjncy(el_adj)+1)) < TINYVAL) then
+ is_acoustic_el_adj = .false.
+ is_elastic_el_adj = .true.
+ elseif ( phi_material(num_material(adjncy(el_adj)+1)) >= 1.d0) then
is_acoustic_el_adj = .true.
+ is_elastic_el_adj = .false.
else
is_acoustic_el_adj = .false.
+ is_elastic_el_adj = .false.
endif
- if ( (part(adjncy(el_adj)) == num_part_bis) .and. (is_acoustic_el .eqv. is_acoustic_el_adj) ) then
+ if ( (part(adjncy(el_adj)) == num_part_bis) .and. (is_acoustic_el .eqv. is_acoustic_el_adj) &
+ .and. (is_elastic_el .eqv. is_elastic_el_adj) ) then
num_edge = num_edge + 1
endif
@@ -537,18 +548,29 @@
do num_part_bis = num_part+1, nparts-1
do el = 0, nelmnts-1
if ( part(el) == num_part ) then
- if ( cs_material(num_material(el+1)) < TINYVAL) then
+ if ( phi_material(num_material(el+1)) < TINYVAL) then
+ is_acoustic_el = .false.
+ is_elastic_el = .true.
+ elseif ( phi_material(num_material(el+1)) >= 1.d0) then
is_acoustic_el = .true.
+ is_elastic_el = .false.
else
is_acoustic_el = .false.
+ is_elastic_el = .false.
endif
do el_adj = xadj(el), xadj(el+1)-1
- if ( cs_material(num_material(adjncy(el_adj)+1)) < TINYVAL) then
+ if ( phi_material(num_material(adjncy(el_adj)+1)) < TINYVAL) then
+ is_acoustic_el_adj = .false.
+ is_elastic_el_adj = .true.
+ elseif ( phi_material(num_material(adjncy(el_adj)+1)) >= 1.d0) then
is_acoustic_el_adj = .true.
+ is_elastic_el_adj = .false.
else
is_acoustic_el_adj = .false.
+ is_elastic_el_adj = .false.
endif
- if ( (part(adjncy(el_adj)) == num_part_bis) .and. (is_acoustic_el .eqv. is_acoustic_el_adj) ) then
+ if ( (part(adjncy(el_adj)) == num_part_bis) .and. (is_acoustic_el .eqv. is_acoustic_el_adj) &
+ .and. (is_elastic_el .eqv. is_elastic_el_adj) ) then
tab_interfaces(tab_size_interfaces(num_interface)*5+num_edge*5+0) = el
tab_interfaces(tab_size_interfaces(num_interface)*5+num_edge*5+1) = adjncy(el_adj)
ncommon_nodes = 0
@@ -866,7 +888,7 @@
subroutine merge_abs_boundaries(nelemabs, nelemabs_merge, abs_surface, abs_surface_char, abs_surface_merge, &
ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
jbegin_left,jend_left,jbegin_right,jend_right, &
- nedges_coupled, edges_coupled, nb_materials, cs_material, num_material, &
+ nedges_coupled, edges_coupled, nb_materials, phi_material, num_material, &
nelmnts, &
elmnts, ngnod)
@@ -885,7 +907,7 @@
integer :: nedges_coupled
integer, dimension(:,:), pointer :: edges_coupled
integer :: nb_materials
- double precision, dimension(nb_materials), intent(in) :: cs_material
+ double precision, dimension(nb_materials), intent(in) :: phi_material
integer, dimension(1:nelmnts), intent(in) :: num_material
integer :: nelmnts
@@ -1009,10 +1031,9 @@
is_acoustic(:) = .false.
do i = 1, nb_materials
- if (cs_material(i) < TINYVAL) then
+ if (phi_material(i) >= 1.d0) then
is_acoustic(i) = .true.
endif
-
enddo
do num_edge = 1, nedge_bound
@@ -1271,7 +1292,7 @@
! Repartitioning : two coupled acoustic/elastic elements are transfered to the same partition
!--------------------------------------------------
-subroutine acoustic_elastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, cs_material, num_material, &
+ subroutine acoustic_elastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi_material, num_material, &
nproc, part, nedges_coupled, edges_coupled)
implicit none
@@ -1279,7 +1300,7 @@
include "constants.h"
integer, intent(in) :: nelmnts, nnodes, nproc, nb_materials
- double precision, dimension(nb_materials), intent(in) :: cs_material
+ double precision, dimension(nb_materials), intent(in) :: phi_material
integer, dimension(1:nelmnts), intent(in) :: num_material
integer, dimension(:), pointer :: elmnts
integer, dimension(:), pointer :: part
@@ -1287,7 +1308,7 @@
integer, dimension(:,:), pointer :: edges_coupled
- logical, dimension(nb_materials) :: is_acoustic
+ logical, dimension(nb_materials) :: is_acoustic, is_elastic
integer, dimension(:), pointer :: xadj
integer, dimension(:), pointer :: adjncy
integer, dimension(:), pointer :: nodes_elmnts
@@ -1298,11 +1319,14 @@
logical :: is_repartitioned
is_acoustic(:) = .false.
+ is_elastic(:) = .false.
do i = 1, nb_materials
- if (cs_material(i) < TINYVAL) then
+ if (phi_material(i) >= 1.d0) then
is_acoustic(i) = .true.
endif
-
+ if (phi_material(i) < TINYVAL) then
+ is_elastic(i) = .true.
+ endif
enddo
call mesh2dual_ncommonnodes(nelmnts, nnodes, elmnts, xadj, adjncy, nnodes_elmnts, nodes_elmnts,2)
@@ -1311,7 +1335,7 @@
do el = 0, nelmnts-1
if ( is_acoustic(num_material(el+1)) ) then
do el_adj = xadj(el), xadj(el+1) - 1
- if ( .not. is_acoustic(num_material(adjncy(el_adj)+1)) ) then
+ if ( is_elastic(num_material(adjncy(el_adj)+1)) ) then
nedges_coupled = nedges_coupled + 1
endif
@@ -1325,7 +1349,7 @@
do el = 0, nelmnts-1
if ( is_acoustic(num_material(el+1)) ) then
do el_adj = xadj(el), xadj(el+1) - 1
- if ( .not. is_acoustic(num_material(adjncy(el_adj)+1)) ) then
+ if ( is_elastic(num_material(adjncy(el_adj)+1)) ) then
nedges_coupled = nedges_coupled + 1
edges_coupled(1,nedges_coupled) = el
edges_coupled(2,nedges_coupled) = adjncy(el_adj)
@@ -1353,15 +1377,203 @@
endif
enddo
-end subroutine acoustic_elastic_repartitioning
+ end subroutine acoustic_elastic_repartitioning
!--------------------------------------------------
- ! Write fluid/solid edges (fluid elements and corresponding solid elements)
+ ! Repartitioning : two coupled acoustic/poroelastic elements are transfered to the same partition
+ !--------------------------------------------------
+
+ subroutine acoustic_poro_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi_material, num_material, &
+ nproc, part, nedges_acporo_coupled, edges_acporo_coupled)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nelmnts, nnodes, nproc, nb_materials
+ double precision, dimension(nb_materials), intent(in) :: phi_material
+ integer, dimension(1:nelmnts), intent(in) :: num_material
+ integer, dimension(:), pointer :: elmnts
+ integer, dimension(:), pointer :: part
+ integer, intent(out) :: nedges_acporo_coupled
+ integer, dimension(:,:), pointer :: edges_acporo_coupled
+
+
+ logical, dimension(nb_materials) :: is_acoustic,is_poroelastic
+ integer, dimension(:), pointer :: xadj
+ integer, dimension(:), pointer :: adjncy
+ integer, dimension(:), pointer :: nodes_elmnts
+ integer, dimension(:), pointer :: nnodes_elmnts
+
+ integer :: i, num_edge
+ integer :: el, el_adj
+ logical :: is_repartitioned
+
+ is_acoustic(:) = .false.
+ is_poroelastic(:) = .false.
+ do i = 1, nb_materials
+ if (phi_material(i) >=1.d0) then
+ is_acoustic(i) = .true.
+ endif
+ if (phi_material(i) <1.d0 .and. phi_material(i) > TINYVAL) then
+ is_poroelastic(i) = .true.
+ endif
+ enddo
+
+ call mesh2dual_ncommonnodes(nelmnts, nnodes, elmnts, xadj, adjncy, nnodes_elmnts, nodes_elmnts,2)
+
+ nedges_acporo_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_acoustic(num_material(el+1)) ) then
+ do el_adj = xadj(el), xadj(el+1) - 1
+ if ( is_poroelastic(num_material(adjncy(el_adj)+1)) ) then
+ nedges_acporo_coupled = nedges_acporo_coupled + 1
+ endif
+
+ enddo
+ endif
+ enddo
+
+ print *, 'nedges_coupled (acoustic/poroelastic)', nedges_acporo_coupled
+
+ allocate(edges_acporo_coupled(2,nedges_acporo_coupled))
+
+ nedges_acporo_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_acoustic(num_material(el+1)) ) then
+ do el_adj = xadj(el), xadj(el+1) - 1
+ if ( is_poroelastic(num_material(adjncy(el_adj)+1)) ) then
+ nedges_acporo_coupled = nedges_acporo_coupled + 1
+ edges_acporo_coupled(1,nedges_acporo_coupled) = el
+ edges_acporo_coupled(2,nedges_acporo_coupled) = adjncy(el_adj)
+ endif
+
+ enddo
+ endif
+ enddo
+
+ do i = 1, nedges_acporo_coupled*nproc
+ is_repartitioned = .false.
+ do num_edge = 1, nedges_acporo_coupled
+ if ( part(edges_acporo_coupled(1,num_edge)) /= part(edges_acporo_coupled(2,num_edge)) ) then
+ if ( part(edges_acporo_coupled(1,num_edge)) < part(edges_acporo_coupled(2,num_edge)) ) then
+ part(edges_acporo_coupled(2,num_edge)) = part(edges_acporo_coupled(1,num_edge))
+ else
+ part(edges_acporo_coupled(1,num_edge)) = part(edges_acporo_coupled(2,num_edge))
+ endif
+ is_repartitioned = .true.
+ endif
+
+ enddo
+ if ( .not. is_repartitioned ) then
+ exit
+ endif
+ enddo
+
+ end subroutine acoustic_poro_repartitioning
+
+
+ !--------------------------------------------------
+ ! Repartitioning : two coupled poroelastic/elastic elements are transfered to the same partition
+ !--------------------------------------------------
+
+ subroutine poro_elastic_repartitioning (nelmnts, nnodes, elmnts, nb_materials, phi_material, num_material, &
+ nproc, part, nedges_elporo_coupled, edges_elporo_coupled)
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: nelmnts, nnodes, nproc, nb_materials
+ double precision, dimension(nb_materials), intent(in) :: phi_material
+ integer, dimension(1:nelmnts), intent(in) :: num_material
+ integer, dimension(:), pointer :: elmnts
+ integer, dimension(:), pointer :: part
+ integer, intent(out) :: nedges_elporo_coupled
+ integer, dimension(:,:), pointer :: edges_elporo_coupled
+
+
+ logical, dimension(nb_materials) :: is_elastic,is_poroelastic
+ integer, dimension(:), pointer :: xadj
+ integer, dimension(:), pointer :: adjncy
+ integer, dimension(:), pointer :: nodes_elmnts
+ integer, dimension(:), pointer :: nnodes_elmnts
+
+ integer :: i, num_edge
+ integer :: el, el_adj
+ logical :: is_repartitioned
+
+ is_elastic(:) = .false.
+ is_poroelastic(:) = .false.
+ do i = 1, nb_materials
+ if (phi_material(i) < TINYVAL) then
+ is_elastic(i) = .true.
+ endif
+ if (phi_material(i) <1.d0 .and. phi_material(i) > TINYVAL) then
+ is_poroelastic(i) = .true.
+ endif
+ enddo
+
+ call mesh2dual_ncommonnodes(nelmnts, nnodes, elmnts, xadj, adjncy, nnodes_elmnts, nodes_elmnts,2)
+
+ nedges_elporo_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_poroelastic(num_material(el+1)) ) then
+ do el_adj = xadj(el), xadj(el+1) - 1
+ if ( is_elastic(num_material(adjncy(el_adj)+1)) ) then
+ nedges_elporo_coupled = nedges_elporo_coupled + 1
+ endif
+
+ enddo
+ endif
+ enddo
+
+ print *, 'nedges_coupled (poroelastic/elastic)', nedges_elporo_coupled
+
+ allocate(edges_elporo_coupled(2,nedges_elporo_coupled))
+
+ nedges_elporo_coupled = 0
+ do el = 0, nelmnts-1
+ if ( is_poroelastic(num_material(el+1)) ) then
+ do el_adj = xadj(el), xadj(el+1) - 1
+ if ( is_elastic(num_material(adjncy(el_adj)+1)) ) then
+ nedges_elporo_coupled = nedges_elporo_coupled + 1
+ edges_elporo_coupled(1,nedges_elporo_coupled) = el
+ edges_elporo_coupled(2,nedges_elporo_coupled) = adjncy(el_adj)
+ endif
+
+ enddo
+ endif
+ enddo
+
+ do i = 1, nedges_elporo_coupled*nproc
+ is_repartitioned = .false.
+ do num_edge = 1, nedges_elporo_coupled
+ if ( part(edges_elporo_coupled(1,num_edge)) /= part(edges_elporo_coupled(2,num_edge)) ) then
+ if ( part(edges_elporo_coupled(1,num_edge)) < part(edges_elporo_coupled(2,num_edge)) ) then
+ part(edges_elporo_coupled(2,num_edge)) = part(edges_elporo_coupled(1,num_edge))
+ else
+ part(edges_elporo_coupled(1,num_edge)) = part(edges_elporo_coupled(2,num_edge))
+ endif
+ is_repartitioned = .true.
+ endif
+
+ enddo
+ if ( .not. is_repartitioned ) then
+ exit
+ endif
+ enddo
+
+ end subroutine poro_elastic_repartitioning
+
+
+ !--------------------------------------------------
+ ! Write fluid/solid edges (fluid (or porous) elements and corresponding solid (or porous) elements)
! pertaining to iproc partition in the corresponding Database
!--------------------------------------------------
-subroutine write_fluidsolid_edges_database(IIN_database, nedges_coupled, nedges_coupled_loc, &
+ subroutine write_fluidsolid_edges_database(IIN_database, nedges_coupled, nedges_coupled_loc, &
edges_coupled, glob2loc_elmnts, part, iproc, num_phase)
implicit none
@@ -1395,7 +1607,7 @@
endif
-end subroutine write_fluidsolid_edges_database
+ end subroutine write_fluidsolid_edges_database
end module part_unstruct
Modified: seismo/2D/SPECFEM2D/trunk/plotpost.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/plotpost.F90 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/plotpost.F90 2009-08-03 17:08:30 UTC (rev 15507)
@@ -41,13 +41,17 @@
!========================================================================
subroutine plotpost(displ,coord,vpext,x_source,z_source,st_xval,st_zval,it,dt,coorg, &
- xinterp,zinterp,shapeint,Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ xinterp,zinterp,shapeint,Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,&
+ poroelastcoef,knods,kmato,ibool, &
numabs,codeabs,anyabs,nelem_acoustic_surface, acoustic_edges, &
- simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
+ simulation_title,npoin,npgeo,vpmin,vpmax,nrec,NSOURCE, &
colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
- nspec,ngnod,coupled_acoustic_elastic,any_acoustic,plot_lowerleft_corner_only, &
+ nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poroelastic,coupled_elastic_poroelastic, &
+ any_acoustic,any_poroelastic,plot_lowerleft_corner_only, &
fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges, &
+ fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge,num_fluid_poro_edges, &
+ solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge,num_solid_poro_edges, &
myrank,nproc,ier, &
d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
@@ -86,7 +90,7 @@
double precision, dimension(NUM_COLORS) :: red,green,blue
integer it,nrec,nelemabs,numat,pointsdisp,pointsdisp_loop,nspec
- integer i,npoin,npgeo,ngnod
+ integer i,npoin,npgeo,ngnod,NSOURCE
integer kmato(nspec),knods(ngnod,nspec)
integer ibool(NGLLX,NGLLZ,nspec)
@@ -96,9 +100,10 @@
double precision Uxinterp(pointsdisp,pointsdisp)
double precision Uzinterp(pointsdisp,pointsdisp)
double precision flagrange(NGLLX,pointsdisp)
- double precision density(numat),elastcoef(4,numat)
+ double precision density(2,numat),poroelastcoef(4,3,numat),porosity(numat),tortuosity(numat)
- double precision dt,timeval,x_source,z_source
+ double precision dt,timeval
+ double precision, dimension(NSOURCE) :: x_source,z_source
double precision displ(NDIM,npoin),coord(NDIM,npoin)
double precision vpext(NGLLX,NGLLZ,nspec)
@@ -106,11 +111,14 @@
double precision, dimension(nrec) :: st_xval,st_zval
integer numabs(nelemabs),codeabs(4,nelemabs)
- logical anyabs,coupled_acoustic_elastic,any_acoustic,plot_lowerleft_corner_only
+ logical anyabs,coupled_acoustic_elastic,coupled_acoustic_poroelastic,coupled_elastic_poroelastic, &
+ any_acoustic,any_poroelastic,plot_lowerleft_corner_only
! for fluid/solid edge detection
- integer :: num_fluid_solid_edges
+ integer :: num_fluid_solid_edges,num_fluid_poro_edges,num_solid_poro_edges
integer, dimension(num_fluid_solid_edges) :: fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge
+ integer, dimension(num_fluid_poro_edges) :: fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge
+ integer, dimension(num_solid_poro_edges) :: solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge
double precision xmax,zmax,height,xw,zw,usoffset,sizex,sizez,vpmin,vpmax
@@ -123,9 +131,15 @@
equivalence (postscript_line,ch1)
logical :: first
- double precision convert,x1,rlamda,rmu,denst,rKvol,cploc,xa,za,xb,zb
+ double precision convert,x1,rlamda,rmu,denst,rKvol,cpIloc,xa,za,xb,zb
double precision z1,x2,z2,d,d1,d2,dummy,theta,thetaup,thetadown
+ double precision :: mul_s,kappal_s,rhol_s
+ double precision :: kappal_f,rhol_f
+ double precision :: mul_fr,kappal_fr,phil,tortl
+ double precision :: afactor,bfactor,cfactor,D_biot,H_biot,C_biot,M_biot,rhol_bar
+ double precision :: cpIsquare
+
integer k,j,ispec,material,is,ir,imat,icol,l,line_length
integer index_char,ii,ipoin,in,nnum,inum,ideb,ifin,iedge
@@ -155,7 +169,8 @@
integer :: nb_coorg_per_elem, nb_color_per_elem
integer :: iproc, num_spec
integer :: ier
- logical :: anyabs_glob, coupled_acoustic_elastic_glob
+ logical :: anyabs_glob, coupled_acoustic_elastic_glob, coupled_acoustic_poroelastic_glob, &
+ coupled_elastic_poroelastic_glob
#ifdef USE_MPI
integer, dimension(MPI_STATUS_SIZE) :: request_mpi_status
#endif
@@ -1600,8 +1615,14 @@
if(coupled_acoustic_elastic) then
write(24,*) '(Coupled Acoustic/Elastic Wave 2D - SEM) show'
+ else if(coupled_acoustic_poroelastic) then
+ write(24,*) '(Coupled Acoustic/Poroelastic Wave 2D - SEM) show'
+ else if(coupled_elastic_poroelastic) then
+ write(24,*) '(Coupled Elastic/Poroelastic Wave 2D - SEM) show'
else if(any_acoustic) then
write(24,*) '(Acoustic Wave 2D - Spectral Element Method) show'
+ else if(any_poroelastic) then
+ write(24,*) '(Poroelastic Wave 2D - Spectral Element Method) show'
else
write(24,*) '(Elastic Wave 2D - Spectral Element Method) show'
endif
@@ -1638,12 +1659,32 @@
x1 = (vpext(i,j,ispec)-vpmin) / (vpmax-vpmin)
else
material = kmato(ispec)
- rlamda = elastcoef(1,material)
- rmu = elastcoef(2,material)
- denst = density(material)
- rKvol = rlamda + 2.d0*rmu/3.d0
- cploc = sqrt((rKvol + 4.d0*rmu/3.d0)/denst)
- x1 = (cploc-vpmin)/(vpmax-vpmin)
+! get elastic parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - FOUR_THIRDS*mul_s
+ rhol_s = density(1,kmato(ispec))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec)) - FOUR_THIRDS*mul_fr
+ rhol_bar = (1.d0 - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1.d0 + phil*(kappal_s/kappal_f - 1.d0))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + kappal_fr + FOUR_THIRDS*mul_fr
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+! Approximated velocities (no viscous dissipation)
+ afactor = rhol_bar - phil/tortl*rhol_f
+ bfactor = H_biot + phil*rhol_bar/(tortl*rhol_f)*M_biot - 2.d0*phil/tortl*C_biot
+ cfactor = phil/(tortl*rhol_f)*(H_biot*M_biot - C_biot*C_biot)
+ cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4.d0*afactor*cfactor))/(2.d0*afactor)
+ cpIloc = sqrt(cpIsquare)
+ x1 = (cpIloc-vpmin)/(vpmax-vpmin)
endif
else
x1 = 0.5d0
@@ -2426,6 +2467,220 @@
endif
!
+!---- draw the fluid-porous coupling edges with a thick color line
+!
+ coupled_acoustic_poroelastic_glob = coupled_acoustic_poroelastic
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(coupled_acoustic_poroelastic, coupled_acoustic_poroelastic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
+ if(coupled_acoustic_poroelastic_glob .and. boundvect) then
+
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) '% fluid-porous coupling edges in the mesh'
+ write(24,*) '%'
+
+ write(24,*) '0.10 CM setlinewidth'
+ write(24,*) '% uncomment this when zooming on parts of the mesh'
+ write(24,*) '% 0.02 CM setlinewidth'
+ endif
+
+ if ( myrank /= 0 .and. num_fluid_poro_edges > 0 ) allocate(coorg_send(4,num_fluid_poro_edges))
+ buffer_offset = 0
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec = fluid_poro_acoustic_ispec(inum)
+ iedge = fluid_poro_acoustic_iedge(inum)
+
+! use pink color
+ if ( myrank == 0 ) write(24,*) '1 0.75 0.8 RG'
+
+ if(iedge == ITOP) then
+ ideb = 3
+ ifin = 4
+ else if(iedge == IBOTTOM) then
+ ideb = 1
+ ifin = 2
+ else if(iedge == ILEFT) then
+ ideb = 4
+ ifin = 1
+ else if(iedge == IRIGHT) then
+ ideb = 2
+ ifin = 3
+ else
+ call exit_MPI('Wrong fluid-solid coupling edge code')
+ endif
+
+ x1 = (coorg(1,knods(ideb,ispec))-xmin)*ratio_page + orig_x
+ z1 = (coorg(2,knods(ideb,ispec))-zmin)*ratio_page + orig_z
+ x2 = (coorg(1,knods(ifin,ispec))-xmin)*ratio_page + orig_x
+ z2 = (coorg(2,knods(ifin,ispec))-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,602) x1,z1,x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send(1,buffer_offset) = x1
+ coorg_send(2,buffer_offset) = z1
+ coorg_send(3,buffer_offset) = x2
+ coorg_send(4,buffer_offset) = z2
+ endif
+
+ enddo
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
+ if ( nspec_recv > 0 ) then
+ allocate(coorg_recv(4,nspec_recv))
+ call MPI_RECV (coorg_recv(1,1), 4*nspec_recv, &
+ MPI_DOUBLE_PRECISION, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ buffer_offset = 0
+ do ispec = 1, nspec_recv
+ buffer_offset = buffer_offset + 1
+ write(24,*) '1 0.75 0.8 RG'
+ write(24,602) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset), &
+ coorg_recv(3,buffer_offset), coorg_recv(4,buffer_offset)
+ enddo
+ deallocate(coorg_recv)
+ endif
+ enddo
+ else
+ call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 45, MPI_COMM_WORLD, ier)
+ if ( buffer_offset > 0 ) then
+ call MPI_SEND (coorg_send(1,1), 4*buffer_offset, &
+ MPI_DOUBLE_PRECISION, 0, 45, MPI_COMM_WORLD, ier)
+ deallocate(coorg_send)
+ endif
+ endif
+
+#endif
+
+ if ( myrank == 0 ) then
+ write(24,*) '0 setgray'
+ write(24,*) '0.01 CM setlinewidth'
+ endif
+
+ endif
+
+!
+!---- draw the solid-porous coupling edges with a thick color line
+!
+ coupled_elastic_poroelastic_glob = coupled_elastic_poroelastic
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(coupled_elastic_poroelastic, coupled_elastic_poroelastic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
+ if(coupled_elastic_poroelastic_glob .and. boundvect) then
+
+ if ( myrank == 0 ) then
+ write(24,*) '%'
+ write(24,*) '% solid-porous coupling edges in the mesh'
+ write(24,*) '%'
+
+ write(24,*) '0.10 CM setlinewidth'
+ write(24,*) '% uncomment this when zooming on parts of the mesh'
+ write(24,*) '% 0.02 CM setlinewidth'
+ endif
+
+ if ( myrank /= 0 .and. num_solid_poro_edges > 0 ) allocate(coorg_send(4,num_solid_poro_edges))
+ buffer_offset = 0
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the poroelastic element
+ ispec = solid_poro_poroelastic_ispec(inum)
+ iedge = solid_poro_poroelastic_iedge(inum)
+
+! use pink color
+ if ( myrank == 0 ) write(24,*) '1 0.75 0.8 RG'
+
+ if(iedge == ITOP) then
+ ideb = 3
+ ifin = 4
+ else if(iedge == IBOTTOM) then
+ ideb = 1
+ ifin = 2
+ else if(iedge == ILEFT) then
+ ideb = 4
+ ifin = 1
+ else if(iedge == IRIGHT) then
+ ideb = 2
+ ifin = 3
+ else
+ call exit_MPI('Wrong fluid-solid coupling edge code')
+ endif
+
+ x1 = (coorg(1,knods(ideb,ispec))-xmin)*ratio_page + orig_x
+ z1 = (coorg(2,knods(ideb,ispec))-zmin)*ratio_page + orig_z
+ x2 = (coorg(1,knods(ifin,ispec))-xmin)*ratio_page + orig_x
+ z2 = (coorg(2,knods(ifin,ispec))-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ if ( myrank == 0 ) then
+ write(24,602) x1,z1,x2,z2
+ else
+ buffer_offset = buffer_offset + 1
+ coorg_send(1,buffer_offset) = x1
+ coorg_send(2,buffer_offset) = z1
+ coorg_send(3,buffer_offset) = x2
+ coorg_send(4,buffer_offset) = z2
+ endif
+
+ enddo
+
+#ifdef USE_MPI
+ if (myrank == 0 ) then
+
+ do iproc = 1, nproc-1
+ call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
+ if ( nspec_recv > 0 ) then
+ allocate(coorg_recv(4,nspec_recv))
+ call MPI_RECV (coorg_recv(1,1), 4*nspec_recv, &
+ MPI_DOUBLE_PRECISION, iproc, 45, MPI_COMM_WORLD, request_mpi_status, ier)
+
+ buffer_offset = 0
+ do ispec = 1, nspec_recv
+ buffer_offset = buffer_offset + 1
+ write(24,*) '1 0.75 0.8 RG'
+ write(24,602) coorg_recv(1,buffer_offset), coorg_recv(2,buffer_offset), &
+ coorg_recv(3,buffer_offset), coorg_recv(4,buffer_offset)
+ enddo
+ deallocate(coorg_recv)
+ endif
+ enddo
+ else
+ call MPI_SEND (buffer_offset, 1, MPI_INTEGER, 0, 45, MPI_COMM_WORLD, ier)
+ if ( buffer_offset > 0 ) then
+ call MPI_SEND (coorg_send(1,1), 4*buffer_offset, &
+ MPI_DOUBLE_PRECISION, 0, 45, MPI_COMM_WORLD, ier)
+ deallocate(coorg_send)
+ endif
+ endif
+
+#endif
+
+ if ( myrank == 0 ) then
+ write(24,*) '0 setgray'
+ write(24,*) '0.01 CM setlinewidth'
+ endif
+
+ endif
+
+!
!---- draw the normalized vector field
!
@@ -2764,14 +3019,18 @@
!
!---- write position of the source
!
- xw = x_source
- zw = z_source
+ do i=1,NSOURCE
+ if(i == 1) write(24,*) '% beginning of source line'
+ if(i == NSOURCE) write(24,*) '% end of source line'
+ xw = x_source(i)
+ zw = z_source(i)
xw = (xw-xmin)*ratio_page + orig_x
zw = (zw-zmin)*ratio_page + orig_z
xw = xw * centim
zw = zw * centim
write(24,500) xw,zw
write(24,*) 'Cross'
+ enddo
!
!---- write position of the receivers
Modified: seismo/2D/SPECFEM2D/trunk/read_value_parameters.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/read_value_parameters.f90 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/read_value_parameters.f90 2009-08-03 17:08:30 UTC (rev 15507)
@@ -139,19 +139,25 @@
!--------------------
- subroutine read_material_parameters(iin,ignore_junk,i,icodematread,rhoread,Qpread,Qsread,cpread,csread,aniso3read,aniso4read)
+ subroutine read_material_parameters(iin,ignore_junk,i,icodematread,val0read,val1read,val2read,val3read, &
+ val4read,val5read,val6read,val7read,val8read,val9read,val10read,val11read,val12read)
+
implicit none
integer iin
logical ignore_junk
integer i,icodematread
- double precision rhoread,Qpread,Qsread,cpread,csread,aniso3read,aniso4read
+ double precision val0read,val1read,val2read,val3read,val4read,val5read,val6read,val7read,&
+ val8read,val9read,val10read,val11read,val12read
+
character(len=100) string_read
call read_next_line(iin,ignore_junk,string_read)
- read(string_read,*) i,icodematread,rhoread,cpread,csread,aniso3read,aniso4read,Qpread,Qsread
+ read(string_read,*) i,icodematread,val0read,val1read,val2read,val3read,val4read,val5read,&
+ val6read,val7read,val8read,val9read,val10read,val11read,val12read
+
end subroutine read_material_parameters
!--------------------
Modified: seismo/2D/SPECFEM2D/trunk/specfem2D.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/specfem2D.F90 2009-08-03 16:59:47 UTC (rev 15506)
+++ seismo/2D/SPECFEM2D/trunk/specfem2D.F90 2009-08-03 17:08:30 UTC (rev 15507)
@@ -151,9 +151,11 @@
character(len=80) datlin
- integer :: source_type,time_function_type
- double precision :: x_source,z_source,xi_source,gamma_source,Mxx,Mzz,Mxz,f0,t0,factor,angleforce,hdur,hdur_gauss
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ) :: sourcearray
+ integer NSOURCE,i_source
+ integer, dimension(:), allocatable :: source_type,time_function_type
+ double precision, dimension(:), allocatable :: x_source,z_source,xi_source,gamma_source,&
+ Mxx,Mzz,Mxz,f0,t0,factor,angleforce,hdur,hdur_gauss
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable :: sourcearray
double precision, dimension(:,:), allocatable :: coorg
double precision, dimension(:), allocatable :: coorgread
@@ -199,16 +201,37 @@
double precision :: xixl,xizl,gammaxl,gammazl,jacobianl
! material properties of the elastic medium
- double precision :: mul_relaxed,lambdal_relaxed,kappal
+ double precision :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,kappal
real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: accel_elastic,veloc_elastic,displ_elastic
- double precision, dimension(:,:), allocatable :: coord, flagrange,xinterp,zinterp,Uxinterp,Uzinterp,elastcoef,vector_field_display
+ double precision, dimension(:,:), allocatable :: coord, flagrange,xinterp,zinterp,Uxinterp,Uzinterp,vector_field_display
+! material properties of the poroelastic medium (solid phase:s and fluid phase [defined as w=phi(u_f-u_s)]: w)
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: accels_poroelastic,velocs_poroelastic,displs_poroelastic
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: accelw_poroelastic,velocw_poroelastic,displw_poroelastic
+ double precision, dimension(:), allocatable :: porosity,tortuosity
+ double precision, dimension(:,:), allocatable :: density,permeability
+
+! poroelastic and elastic coefficients
+ double precision, dimension(:,:,:), allocatable :: poroelastcoef
+
! for acoustic medium
real(kind=CUSTOM_REAL), dimension(:), allocatable :: potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
+
+! inverse mass matrices
real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_inverse_elastic,rmass_inverse_acoustic
- double precision, dimension(:), allocatable :: density
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_s_inverse_poroelastic,rmass_w_inverse_poroelastic
+! to evaluate cpI, cpII, and cs, and rI (poroelastic medium)
+ real(kind=CUSTOM_REAL) :: rhol_s,rhol_f,rhol_bar,phil,tortl
+ real(kind=CUSTOM_REAL) :: mul_s,kappal_s
+ real(kind=CUSTOM_REAL) :: kappal_f
+! double precision :: etal_f
+ real(kind=CUSTOM_REAL) :: mul_fr,kappal_fr
+! double precision :: permlxx,permlxz,permlzz
+ real(kind=CUSTOM_REAL) :: afactor,bfactor,cfactor,D_biot,H_biot,C_biot,M_biot,B_biot,cpIsquare,cpIIsquare,cssquare
+ real(kind=CUSTOM_REAL) :: gamma1,gamma2,gamma3,gamma4,ratio,dd1
+
double precision, dimension(:), allocatable :: vp_display
double precision, dimension(:,:,:), allocatable :: vpext,vsext,rhoext
@@ -224,12 +247,14 @@
integer, dimension(:), allocatable :: kmato,numabs, &
ibegin_bottom,iend_bottom,ibegin_top,iend_top,jbegin_left,jend_left,jbegin_right,jend_right
- integer ispec_selected_source,iglob_source,ix_source,iz_source,is_proc_source,nb_proc_source
- double precision aval,displnorm_all,displnorm_all_glob
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: source_time_function
+ integer, dimension(:), allocatable :: ispec_selected_source,iglob_source,ix_source,iz_source,&
+ is_proc_source,nb_proc_source
+ double precision displnorm_all,displnorm_all_glob
+ double precision, dimension(:), allocatable :: aval
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: source_time_function
double precision, external :: netlib_specfun_erf
- double precision :: vpmin,vpmax
+ double precision :: vpImin,vpImax,vpIImin,vpIImax
integer :: colors,numbers,subsamp,imagetype,NTSTEP_BETWEEN_OUTPUT_INFO,NTSTEP_BETWEEN_OUTPUT_SEISMO,seismotype
integer :: numat,ngnod,nspec,pointsdisp,nelemabs,nelem_acoustic_surface,ispecabs,UPPER_LIMIT_DISPLAY
@@ -264,6 +289,20 @@
real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: &
dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
+! for viscous attenuation
+ double precision, dimension(:,:,:), allocatable :: &
+ rx_viscous,rz_viscous,viscox,viscoz
+ double precision :: theta_e,theta_s,Q0,freq0
+ double precision :: alphaval,betaval,gammaval,thetainv
+ logical :: TURN_VISCATTENUATION_ON
+ double precision, dimension(NGLLX,NGLLZ) :: viscox_loc,viscoz_loc
+ double precision :: Sn,Snp1,etal_f
+ double precision, dimension(3):: bl_relaxed
+ double precision :: permlxx,permlxz,permlzz,invpermlxx,invpermlxz,invpermlzz,detk
+! adjoint
+ double precision, dimension(:), allocatable :: b_viscodampx,b_viscodampz
+ integer reclen,reclen1,reclen2
+
! for fluid/solid coupling and edge detection
logical, dimension(:), allocatable :: elastic
integer, dimension(NEDGES) :: i_begin,j_begin,i_end,j_end
@@ -274,8 +313,78 @@
integer :: num_fluid_solid_edges,ispec_acoustic,ispec_elastic, &
iedge_acoustic,iedge_elastic,ipoin1D,iglob2
logical :: any_acoustic,any_acoustic_glob,any_elastic,any_elastic_glob,coupled_acoustic_elastic
- real(kind=CUSTOM_REAL) :: displ_x,displ_z,displ_n,zxi,xgamma,jacobian1D,pressure
+ real(kind=CUSTOM_REAL) :: displ_x,displ_z,displ_n,displw_x,displw_z,zxi,xgamma,jacobian1D,pressure
+ real(kind=CUSTOM_REAL) :: b_displ_x,b_displ_z,b_displw_x,b_displw_z,b_pressure
+! for fluid/porous medium coupling and edge detection
+ logical, dimension(:), allocatable :: poroelastic
+ logical :: any_poroelastic,any_poroelastic_glob
+ integer, dimension(:), allocatable :: fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge, &
+ fluid_poro_poroelastic_ispec,fluid_poro_poroelastic_iedge
+ integer :: fluid_poro_acoustic_ispec_read, fluid_poro_poroelastic_ispec_read
+ integer :: num_fluid_poro_edges,num_fluid_poro_edges_alloc,iedge_poroelastic
+ logical :: coupled_acoustic_poroelastic
+ double precision :: mul_G,lambdal_G,lambdalplus2mul_G
+ double precision :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
+ double precision :: dwx_dxi,dwx_dgamma,dwz_dxi,dwz_dgamma
+ double precision :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ double precision :: dwx_dxl,dwz_dxl,dwx_dzl,dwz_dzl
+ double precision :: b_dux_dxi,b_dux_dgamma,b_duz_dxi,b_duz_dgamma
+ double precision :: b_dwx_dxi,b_dwx_dgamma,b_dwz_dxi,b_dwz_dgamma
+ double precision :: b_dux_dxl,b_duz_dxl,b_dux_dzl,b_duz_dzl
+ double precision :: b_dwx_dxl,b_dwz_dxl,b_dwx_dzl,b_dwz_dzl
+
+! for solid/porous medium coupling and edge detection
+ integer, dimension(:), allocatable :: solid_poro_elastic_ispec,solid_poro_elastic_iedge, &
+ solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge
+ integer :: solid_poro_elastic_ispec_read, solid_poro_poroelastic_ispec_read
+ integer :: num_solid_poro_edges,num_solid_poro_edges_alloc,ispec_poroelastic,ii2,jj2
+ logical :: coupled_elastic_poroelastic
+ double precision, dimension(:,:), allocatable :: displ,veloc
+ double precision :: sigma_xx,sigma_xz,sigma_zz
+ double precision :: b_sigma_xx,b_sigma_xz,b_sigma_zz
+ integer, dimension(:), allocatable :: ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,&
+ iend_top_poro,jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro
+
+! for adjoint method
+ logical :: save_forward ! whether or not the last frame is saved to reconstruct the forward field
+ integer :: isolver ! 1 = forward wavefield, 2 = backward and adjoint wavefields and kernels
+ double precision :: b_deltatover2,b_deltatsquareover2,b_deltat ! coefficients of the explicit Newmark time scheme
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accels_poroelastic,b_velocs_poroelastic,b_displs_poroelastic
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accelw_poroelastic,b_velocw_poroelastic,b_displw_poroelastic
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_accel_elastic,b_veloc_elastic,b_displ_elastic
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: b_potential_dot_dot_acoustic,b_potential_dot_acoustic,b_potential_acoustic
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rho_kl, mu_kl, kappa_kl
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhol_global, mul_global, kappal_global
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: mu_k, kappa_k,rho_k
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhop_kl, beta_kl, alpha_kl
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rho_ac_kl, kappa_ac_kl
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhol_ac_global, kappal_ac_global
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: kappa_ac_k,rho_ac_k
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhop_ac_kl, alpha_ac_kl
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhot_kl, rhof_kl, sm_kl, eta_kl, mufr_kl, B_kl, &
+ C_kl, M_kl, rhob_kl, rhofb_kl, phi_kl, Bb_kl, Cb_kl, Mb_kl, mufrb_kl, &
+ rhobb_kl, rhofbb_kl, phib_kl, cpI_kl, cpII_kl, cs_kl, ratio_kl
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rhot_k, rhof_k, sm_k, eta_k, mufr_k, B_k, &
+ C_k, M_k
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: phil_global,etal_f_global,rhol_s_global,rhol_f_global,rhol_bar_global, &
+ tortl_global,mulfr_global
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: permlxx_global,permlxz_global,permlzz_global
+ character(len=150) :: adj_source_file,filename,filename2,filename3
+ integer :: irec_local,nadj_rec_local
+ double precision :: xx,zz,rholb
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: adj_sourcearray
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: adj_sourcearrays
+ double precision :: rhopmin,rhopmax,alphamin,alphamax,betamin,betamax
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_left,b_absorb_poro_s_left,b_absorb_poro_w_left
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_right,b_absorb_poro_s_right,b_absorb_poro_w_right
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_bottom,b_absorb_poro_s_bottom,b_absorb_poro_w_bottom
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: b_absorb_elastic_top,b_absorb_poro_s_top,b_absorb_poro_w_top
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_absorb_acoustic_left,b_absorb_acoustic_right,&
+ b_absorb_acoustic_bottom, b_absorb_acoustic_top
+ integer :: nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax
+ integer, dimension(:), allocatable :: ib_xmin,ib_xmax,ib_zmin,ib_zmax
+
! for color images
integer :: NX_IMAGE_color,NZ_IMAGE_color
integer :: npgeo_glob
@@ -330,17 +439,18 @@
integer :: myrank
integer :: iproc
character(len=256) :: prname
+ character(len=150) :: outputname,outputname2
integer :: ninterface
integer :: max_interface_size
integer, dimension(:), allocatable :: my_neighbours
integer, dimension(:), allocatable :: my_nelmnts_neighbours
integer, dimension(:,:,:), allocatable :: my_interfaces
- integer, dimension(:,:), allocatable :: ibool_interfaces_acoustic,ibool_interfaces_elastic
- integer, dimension(:), allocatable :: nibool_interfaces_acoustic,nibool_interfaces_elastic
+ integer, dimension(:,:), allocatable :: ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic
+ integer, dimension(:), allocatable :: nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic
- integer :: ninterface_acoustic, ninterface_elastic
- integer, dimension(:), allocatable :: inum_interfaces_acoustic, inum_interfaces_elastic
+ integer :: ninterface_acoustic, ninterface_elastic,ninterface_poroelastic
+ integer, dimension(:), allocatable :: inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic
#ifdef USE_MPI
real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_ac
@@ -349,7 +459,10 @@
real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_el
real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_el
integer, dimension(:), allocatable :: tab_requests_send_recv_elastic
- integer :: max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_faces_vector_pos,buffer_send_faces_vector_pow
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow
+ integer, dimension(:), allocatable :: tab_requests_send_recv_poroelastic
+ integer :: max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el, max_ibool_interfaces_size_po
#endif
! for overlapping MPI communications with computation
@@ -431,7 +544,8 @@
double precision, dimension(:), allocatable :: cosrot_irec, sinrot_irec
double precision, dimension(:), allocatable :: x_final_receiver, z_final_receiver
logical :: force_normal_to_surface,rec_normal_to_surface
- integer :: nnodes_tangential_curve, source_courbe_eros
+ integer :: nnodes_tangential_curve
+ integer, dimension(:), allocatable :: source_courbe_eros
double precision, dimension(:,:), allocatable :: nodes_tangential_curve
integer :: n1_tangential_detection_curve
integer, dimension(4) :: n_tangential_detection_curve
@@ -465,6 +579,7 @@
ier = 0
ninterface_acoustic = 0
ninterface_elastic = 0
+ ninterface_poroelastic = 0
iproc = 0
ispec_inner = 0
ispec_outer = 0
@@ -547,13 +662,24 @@
if(add_Bielak_conditions .and. .not. initialfield) stop 'need to have an initial field to add Bielak plane wave conditions'
read(IIN,"(a80)") datlin
- read(IIN,*) seismotype,imagetype
- if(seismotype < 1 .or. seismotype > 5) call exit_MPI('Wrong type for seismogram output')
+ read(IIN,*) seismotype,imagetype,save_forward
+ if(seismotype < 1 .or. seismotype > 6) call exit_MPI('Wrong type for seismogram output')
if(imagetype < 1 .or. imagetype > 4) call exit_MPI('Wrong type for snapshots')
+ if(save_forward .and. (seismotype /= 1 .and. seismotype /= 6)) then
+ print*, '***** WARNING *****'
+ print*, 'seismotype =',seismotype
+ print*, 'Save forward wavefield => seismogram must be in displacement for (poro)elastic or potential for acoustic'
+ print*, 'Seismotype must be changed to 1 (elastic/poroelastic adjoint source) or 6 (acoustic adjoint source)'
+ stop
+ endif
+
read(IIN,"(a80)") datlin
read(IIN,*) assign_external_model,outputgrid,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
+ read(IIN,"(a80)") datlin
+ read(IIN,*) TURN_VISCATTENUATION_ON,Q0,freq0
+
!---- check parameters read
if (myrank == 0 .and. ipass == 1) then
write(IOUT,200) npgeo,NDIM
@@ -565,17 +691,56 @@
!---- read time step
read(IIN,"(a80)") datlin
- read(IIN,*) NSTEP,deltat
+ read(IIN,*) NSTEP,deltat,isolver
if (myrank == 0 .and. ipass == 1) write(IOUT,703) NSTEP,deltat,NSTEP*deltat
+ if(isolver == 1 .and. save_forward .and. (TURN_ANISOTROPY_ON .or. TURN_ATTENUATION_ON .or. TURN_VISCATTENUATION_ON)) then
+ print*, '*************** WARNING ***************'
+ print*, 'Anisotropy & Attenuation & Viscous damping are not presently implemented for adjoint calculations'
+ stop
+ endif
+
NTSTEP_BETWEEN_OUTPUT_SEISMO = min(NSTEP,NTSTEP_BETWEEN_OUTPUT_INFO)
!
!---- read source information
!
read(IIN,"(a80)") datlin
- read(IIN,*) source_type,time_function_type,x_source,z_source,f0,t0,factor,angleforce,Mxx,Mzz,Mxz
+ read(IIN,*) NSOURCE
+ if(ipass == 1) then
+ allocate( source_type(NSOURCE) )
+ allocate( time_function_type(NSOURCE) )
+ allocate( x_source(NSOURCE) )
+ allocate( z_source(NSOURCE) )
+ allocate( f0(NSOURCE) )
+ allocate( t0(NSOURCE) )
+ allocate( factor(NSOURCE) )
+ allocate( angleforce(NSOURCE) )
+ allocate( hdur(NSOURCE) )
+ allocate( hdur_gauss(NSOURCE) )
+ allocate( Mxx(NSOURCE) )
+ allocate( Mxz(NSOURCE) )
+ allocate( Mzz(NSOURCE) )
+ allocate( aval(NSOURCE) )
+ allocate( ispec_selected_source(NSOURCE) )
+ allocate( iglob_source(NSOURCE) )
+ allocate( source_courbe_eros(NSOURCE) )
+ allocate( ix_source(NSOURCE) )
+ allocate( iz_source(NSOURCE) )
+ allocate( xi_source(NSOURCE) )
+ allocate( gamma_source(NSOURCE) )
+ allocate( is_proc_source(NSOURCE) )
+ allocate( nb_proc_source(NSOURCE) )
+ allocate( sourcearray(NSOURCE,NDIM,NGLLX,NGLLZ) )
+ endif
+ do i_source=1,NSOURCE
+ read(IIN,"(a80)") datlin
+ read(IIN,*) source_type(i_source),time_function_type(i_source),x_source(i_source),z_source(i_source), &
+ f0(i_source),t0(i_source), &
+ factor(i_source),angleforce(i_source),Mxx(i_source),Mzz(i_source),Mxz(i_source)
+ enddo
+
!
!---- read attenuation information
!
@@ -585,34 +750,43 @@
!
!----- check the input
!
+ do i_source=1,NSOURCE
+
if(.not. initialfield) then
- if (source_type == 1) then
- if (myrank == 0) write(IOUT,212) x_source,z_source,f0,t0,factor,angleforce
- else if(source_type == 2) then
- if (myrank == 0) write(IOUT,222) x_source,z_source,f0,t0,factor,Mxx,Mzz,Mxz
+ if (source_type(i_source) == 1) then
+ if ( myrank == 0 ) then
+ write(IOUT,212) x_source(i_source),z_source(i_source),f0(i_source),t0(i_source), &
+ factor(i_source),angleforce(i_source)
+ endif
+ else if(source_type(i_source) == 2) then
+ if ( myrank == 0 ) then
+ write(IOUT,222) x_source(i_source),z_source(i_source),f0(i_source),t0(i_source), &
+ factor(i_source),Mxx(i_source),Mzz(i_source),Mxz(i_source)
+ endif
else
- call exit_MPI('Unknown source type number')
+ call exit_MPI('Unknown source type number !')
endif
endif
-
! if Dirac source time function, use a very thin Gaussian instead
! if Heaviside source time function, use a very thin error function instead
! time delay of the source in seconds, use a 20 % security margin (use 2 / f0 if error function)
- if(time_function_type == 4 .or. time_function_type == 5) then
- f0 = 1.d0 / (10.d0 * deltat)
- if(time_function_type == 5) then
- t0 = 2.0d0 / f0
+ if(time_function_type(i_source) == 4 .or. time_function_type(i_source) == 5) then
+ f0(i_source) = 1.d0 / (10.d0 * deltat)
+ if(time_function_type(i_source) == 5) then
+ t0(i_source) = 2.0d0 / f0(i_source)
else
- t0 = 1.20d0 / f0
+ t0(i_source) = 1.20d0 / f0(i_source)
endif
endif
! for the source time function
- aval = pi*pi*f0*f0
+ aval(i_source) = pi*pi*f0(i_source)*f0(i_source)
!----- convert angle from degrees to radians
- angleforce = angleforce * pi / 180.d0
+ angleforce(i_source) = angleforce(i_source) * pi / 180.d0
+ enddo ! do i_source=1,NSOURCE
+
!
!---- read the spectral macrobloc nodal coordinates
!
@@ -634,7 +808,9 @@
read(IIN,"(a80)") datlin
read(IIN,*) numat,ngnod,nspec,pointsdisp,plot_lowerleft_corner_only
read(IIN,"(a80)") datlin
- read(IIN,*) nelemabs,nelem_acoustic_surface,num_fluid_solid_edges,nnodes_tangential_curve
+ read(IIN,"(a80)") datlin
+ read(IIN,*) nelemabs,nelem_acoustic_surface,num_fluid_solid_edges,num_fluid_poro_edges,&
+ num_solid_poro_edges,nnodes_tangential_curve
!
!---- allocate arrays
@@ -654,14 +830,18 @@
allocate(zinterp(pointsdisp,pointsdisp))
allocate(Uxinterp(pointsdisp,pointsdisp))
allocate(Uzinterp(pointsdisp,pointsdisp))
- allocate(density(numat))
- allocate(elastcoef(4,numat))
+ allocate(density(2,numat))
+ allocate(porosity(numat))
+ allocate(tortuosity(numat))
+ allocate(permeability(3,numat))
+ allocate(poroelastcoef(4,3,numat))
allocate(Qp_attenuation(numat))
allocate(Qs_attenuation(numat))
allocate(kmato(nspec))
allocate(knods(ngnod,nspec))
allocate(ibool(NGLLX,NGLLZ,nspec))
allocate(elastic(nspec))
+ allocate(poroelastic(nspec))
allocate(inv_tau_sigma_nu1(NGLLX,NGLLZ,nspec,N_SLS))
allocate(inv_tau_sigma_nu2(NGLLX,NGLLZ,nspec,N_SLS))
allocate(phi_nu1(NGLLX,NGLLZ,nspec,N_SLS))
@@ -692,6 +872,16 @@
allocate(jend_left(nelemabs))
allocate(jbegin_right(nelemabs))
allocate(jend_right(nelemabs))
+
+ allocate(ibegin_bottom_poro(nelemabs))
+ allocate(iend_bottom_poro(nelemabs))
+ allocate(ibegin_top_poro(nelemabs))
+ allocate(iend_top_poro(nelemabs))
+
+ allocate(jbegin_left_poro(nelemabs))
+ allocate(jend_left_poro(nelemabs))
+ allocate(jbegin_right_poro(nelemabs))
+ allocate(jend_right_poro(nelemabs))
endif
!
@@ -708,7 +898,8 @@
!
!---- read the material properties
!
- call gmat01(density,elastcoef,numat,myrank,ipass,Qp_attenuation,Qs_attenuation)
+ call gmat01(density,porosity,tortuosity,permeability,poroelastcoef,numat,&
+ myrank,ipass,Qp_attenuation,Qs_attenuation)
!
!---- read spectral macrobloc data
@@ -730,22 +921,30 @@
enddo
deallocate(knods_read)
-!
-!---- determine if each spectral element is elastic or acoustic
-!
+!-------------------------------------------------------------------------------
+!---- determine if each spectral element is elastic, poroelastic, or acoustic
+!-------------------------------------------------------------------------------
any_acoustic = .false.
any_elastic = .false.
+ any_poroelastic = .false.
do ispec = 1,nspec
- mul_relaxed = elastcoef(2,kmato(ispec))
- if(mul_relaxed < TINYVAL) then
+
+ if(porosity(kmato(ispec)) == 1.d0) then ! acoustic domain
elastic(ispec) = .false.
+ poroelastic(ispec) = .false.
any_acoustic = .true.
- else
+ elseif(porosity(kmato(ispec)) < TINYVAL) then ! elastic domain
elastic(ispec) = .true.
+ poroelastic(ispec) = .false.
any_elastic = .true.
+ else ! poroelastic domain
+ elastic(ispec) = .false.
+ poroelastic(ispec) = .true.
+ any_poroelastic = .true.
endif
- enddo
+ enddo !do ispec = 1,nspec
+
if(TURN_ATTENUATION_ON) then
nspec_allocate = nspec
else
@@ -791,9 +990,25 @@
enddo
enddo
+! allocate memory variables for viscous attenuation (poroelastic media)
+ if(ipass == 1) then
+ if(TURN_VISCATTENUATION_ON) then
+ allocate(rx_viscous(NGLLX,NGLLZ,nspec))
+ allocate(rz_viscous(NGLLX,NGLLZ,nspec))
+ allocate(viscox(NGLLX,NGLLZ,nspec))
+ allocate(viscoz(NGLLX,NGLLZ,nspec))
+ else
+ allocate(rx_viscous(NGLLX,NGLLZ,1))
+ allocate(rz_viscous(NGLLX,NGLLZ,1))
+ allocate(viscox(NGLLX,NGLLZ,1))
+ allocate(viscoz(NGLLX,NGLLZ,1))
+ endif
+ endif
+
!
!---- read interfaces data
!
+
read(IIN,"(a80)") datlin
read(IIN,*) ninterface, max_interface_size
if ( ninterface > 0 ) then
@@ -803,10 +1018,13 @@
allocate(my_interfaces(4,max_interface_size,ninterface))
allocate(ibool_interfaces_acoustic(NGLLX*max_interface_size,ninterface))
allocate(ibool_interfaces_elastic(NGLLX*max_interface_size,ninterface))
+ allocate(ibool_interfaces_poroelastic(NGLLX*max_interface_size,ninterface))
allocate(nibool_interfaces_acoustic(ninterface))
allocate(nibool_interfaces_elastic(ninterface))
+ allocate(nibool_interfaces_poroelastic(ninterface))
allocate(inum_interfaces_acoustic(ninterface))
allocate(inum_interfaces_elastic(ninterface))
+ allocate(inum_interfaces_poroelastic(ninterface))
endif
do num_interface = 1, ninterface
@@ -852,8 +1070,68 @@
write(IOUT,*)
write(IOUT,*) 'Number of absorbing elements: ',nelemabs
endif
+
+ nspec_xmin = ZERO
+ nspec_xmax = ZERO
+ nspec_zmin = ZERO
+ nspec_zmax = ZERO
+ if(ipass == 1) then
+ allocate(ib_xmin(nelemabs))
+ allocate(ib_xmax(nelemabs))
+ allocate(ib_zmin(nelemabs))
+ allocate(ib_zmax(nelemabs))
+ endif
+ do inum = 1,nelemabs
+ if (codeabs(IBOTTOM,inum)) then
+ nspec_zmin = nspec_zmin + 1
+ ib_zmin(inum) = nspec_zmin
+ endif
+ if (codeabs(IRIGHT,inum)) then
+ nspec_xmax = nspec_xmax + 1
+ ib_xmax(inum) = nspec_xmax
+ endif
+ if (codeabs(ITOP,inum)) then
+ nspec_zmax = nspec_zmax + 1
+ ib_zmax(inum) = nspec_zmax
+ endif
+ if (codeabs(ILEFT,inum)) then
+ nspec_xmin = nspec_xmin + 1
+ ib_xmin(inum) = nspec_xmin
+ endif
+ enddo
+! Files to save absorbed waves needed to reconstruct backward wavefield for adjoint method
+ if(ipass == 1) then
+ if(any_elastic .and. (save_forward .or. isolver == 2)) then
+ allocate(b_absorb_elastic_left(NDIM,NGLLZ,nspec_xmin,NSTEP))
+ allocate(b_absorb_elastic_right(NDIM,NGLLZ,nspec_xmax,NSTEP))
+ allocate(b_absorb_elastic_bottom(NDIM,NGLLX,nspec_zmin,NSTEP))
+ allocate(b_absorb_elastic_top(NDIM,NGLLX,nspec_zmax,NSTEP))
+ endif
+ if(any_poroelastic .and. (save_forward .or. isolver == 2)) then
+ allocate(b_absorb_poro_s_left(NDIM,NGLLZ,nspec_xmin,NSTEP))
+ allocate(b_absorb_poro_s_right(NDIM,NGLLZ,nspec_xmax,NSTEP))
+ allocate(b_absorb_poro_s_bottom(NDIM,NGLLX,nspec_zmin,NSTEP))
+ allocate(b_absorb_poro_s_top(NDIM,NGLLX,nspec_zmax,NSTEP))
+ allocate(b_absorb_poro_w_left(NDIM,NGLLZ,nspec_xmin,NSTEP))
+ allocate(b_absorb_poro_w_right(NDIM,NGLLZ,nspec_xmax,NSTEP))
+ allocate(b_absorb_poro_w_bottom(NDIM,NGLLX,nspec_zmin,NSTEP))
+ allocate(b_absorb_poro_w_top(NDIM,NGLLX,nspec_zmax,NSTEP))
+ endif
+ if(any_acoustic .and. (save_forward .or. isolver == 2)) then
+ allocate(b_absorb_acoustic_left(NGLLZ,nspec_xmin,NSTEP))
+ allocate(b_absorb_acoustic_right(NGLLZ,nspec_xmax,NSTEP))
+ allocate(b_absorb_acoustic_bottom(NGLLX,nspec_zmin,NSTEP))
+ allocate(b_absorb_acoustic_top(NGLLX,nspec_zmax,NSTEP))
+ endif
+ endif
+
+ write(IOUT,*)
+ write(IOUT,*) 'nspec_xmin = ',nspec_xmin
+ write(IOUT,*) 'nspec_xmax = ',nspec_xmax
+ write(IOUT,*) 'nspec_zmin = ',nspec_zmin
+ write(IOUT,*) 'nspec_zmax = ',nspec_zmax
+
endif
-
!
!---- read acoustic free surface data
!
@@ -919,6 +1197,70 @@
endif
!
+!---- read acoustic poroelastic coupled edges
+!
+ read(IIN,"(a80)") datlin
+ if ( num_fluid_poro_edges > 0 ) then
+if(ipass == 1) then
+ allocate(fluid_poro_acoustic_ispec(num_fluid_poro_edges))
+ allocate(fluid_poro_acoustic_iedge(num_fluid_poro_edges))
+ allocate(fluid_poro_poroelastic_ispec(num_fluid_poro_edges))
+ allocate(fluid_poro_poroelastic_iedge(num_fluid_poro_edges))
+endif
+ do inum = 1, num_fluid_poro_edges
+ read(IIN,*) fluid_poro_acoustic_ispec_read,fluid_poro_poroelastic_ispec_read
+ if(ipass == 1) then
+ fluid_poro_acoustic_ispec(inum) = fluid_poro_acoustic_ispec_read
+ fluid_poro_poroelastic_ispec(inum) = fluid_poro_poroelastic_ispec_read
+ else if(ipass == 2) then
+ fluid_poro_acoustic_ispec(inum) = perm(antecedent_list(fluid_poro_acoustic_ispec_read))
+ fluid_poro_poroelastic_ispec(inum) = perm(antecedent_list(fluid_poro_poroelastic_ispec_read))
+ else
+ call exit_MPI('error: maximum number of passes is 2')
+ endif
+ enddo
+ else
+if(ipass == 1) then
+ allocate(fluid_poro_acoustic_ispec(1))
+ allocate(fluid_poro_acoustic_iedge(1))
+ allocate(fluid_poro_poroelastic_ispec(1))
+ allocate(fluid_poro_poroelastic_iedge(1))
+endif
+ endif
+
+!
+!---- read poroelastic elastic coupled edges
+!
+ read(IIN,"(a80)") datlin
+ if ( num_solid_poro_edges > 0 ) then
+if(ipass == 1) then
+ allocate(solid_poro_elastic_ispec(num_solid_poro_edges))
+ allocate(solid_poro_elastic_iedge(num_solid_poro_edges))
+ allocate(solid_poro_poroelastic_ispec(num_solid_poro_edges))
+ allocate(solid_poro_poroelastic_iedge(num_solid_poro_edges))
+endif
+ do inum = 1, num_solid_poro_edges
+ read(IIN,*) solid_poro_poroelastic_ispec_read,solid_poro_elastic_ispec_read
+ if(ipass == 1) then
+ solid_poro_elastic_ispec(inum) = solid_poro_elastic_ispec_read
+ solid_poro_poroelastic_ispec(inum) = solid_poro_poroelastic_ispec_read
+ else if(ipass == 2) then
+ solid_poro_elastic_ispec(inum) = perm(antecedent_list(solid_poro_elastic_ispec_read))
+ solid_poro_poroelastic_ispec(inum) = perm(antecedent_list(solid_poro_poroelastic_ispec_read))
+ else
+ call exit_MPI('error: maximum number of passes is 2')
+ endif
+ enddo
+ else
+if(ipass == 1) then
+ allocate(solid_poro_elastic_ispec(1))
+ allocate(solid_poro_elastic_iedge(1))
+ allocate(solid_poro_poroelastic_ispec(1))
+ allocate(solid_poro_poroelastic_iedge(1))
+endif
+ endif
+
+!
!---- read tangential detection curve
!
read(IIN,"(a80)") datlin
@@ -1188,8 +1530,8 @@
do j = 1,NGLLZ
do i = 1,NGLLX
iglob = ibool(i,j,ispec)
- call define_external_model(coord(1,iglob),coord(2,iglob),kmato(ispec),myrank, &
- rhoext(i,j,ispec),vpext(i,j,ispec),vsext(i,j,ispec))
+ call define_external_model(coord(1,iglob),coord(2,iglob),kmato(ispec),myrank, &
+ rhoext(i,j,ispec),vpext(i,j,ispec),vsext(i,j,ispec),myrank)
! stop if the same element is assigned both acoustic and elastic points in external model
if(.not. (i == 1 .and. j == 1) .and. &
((vsext(i,j,ispec) >= TINYVAL .and. previous_vsext < TINYVAL) .or. &
@@ -1197,9 +1539,11 @@
call exit_MPI('external velocity model cannot be both fluid and solid inside the same spectral element')
if(vsext(i,j,ispec) < TINYVAL) then
elastic(ispec) = .false.
+ poroelastic(ispec) = .false.
any_acoustic = .true.
else
elastic(ispec) = .true.
+ poroelastic(ispec) = .false.
any_elastic = .true.
endif
previous_vsext = vsext(i,j,ispec)
@@ -1216,6 +1560,11 @@
call MPI_ALLREDUCE(any_elastic, any_elastic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
#endif
+ any_poroelastic_glob = any_poroelastic
+#ifdef USE_MPI
+ call MPI_ALLREDUCE(any_poroelastic, any_poroelastic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
+#endif
+
any_acoustic_glob = any_acoustic
#ifdef USE_MPI
call MPI_ALLREDUCE(any_acoustic, any_acoustic_glob, 1, MPI_LOGICAL, MPI_LOR, MPI_COMM_WORLD, ier)
@@ -1223,10 +1572,10 @@
! for acoustic
if(TURN_ANISOTROPY_ON .and. .not. any_elastic_glob) &
- call exit_MPI('cannot have anisotropy if acoustic simulation only')
+ call exit_MPI('cannot have anisotropy if acoustic/poroelastic simulation only')
if(TURN_ATTENUATION_ON .and. .not. any_elastic_glob) &
- call exit_MPI('currently cannot have attenuation if acoustic simulation only')
+ call exit_MPI('currently cannot have attenuation if acoustic/poroelastic simulation only')
! for attenuation
if(TURN_ANISOTROPY_ON .and. TURN_ATTENUATION_ON) &
@@ -1238,30 +1587,41 @@
deltatover2 = HALF*deltat
deltatsquareover2 = HALF*deltat*deltat
+ if(isolver == 2) then
+! define coefficients of the Newmark time scheme for the backward wavefield
+ b_deltat = - deltat
+ b_deltatover2 = HALF*b_deltat
+ b_deltatsquareover2 = HALF*b_deltat*b_deltat
+ endif
+
!---- define actual location of source and receivers
- if(source_type == 1) then
+ do i_source=1,NSOURCE
+ if(source_type(i_source) == 1) then
+
! collocated force source
- call locate_source_force(coord,ibool,npoin,nspec,x_source,z_source, &
- ix_source,iz_source,ispec_selected_source,iglob_source,is_proc_source,nb_proc_source,ipass)
+ call locate_source_force(coord,ibool,npoin,nspec,x_source(i_source),z_source(i_source), &
+ ix_source(i_source),iz_source(i_source),ispec_selected_source(i_source),iglob_source(i_source), &
+ is_proc_source(i_source),nb_proc_source(i_source),ipass)
! get density at the source in order to implement collocated force with the right
! amplitude later
- if(is_proc_source == 1) then
- rho_at_source_location = density(kmato(ispec_selected_source))
+ if(is_proc_source(i_source) == 1) then
+ rho_at_source_location = density(1,kmato(ispec_selected_source(i_source)))
! external velocity model
- if(assign_external_model) rho_at_source_location = rhoext(ix_source,iz_source,ispec_selected_source)
+ if(assign_external_model) rho_at_source_location = &
+ rhoext(ix_source(i_source),iz_source(i_source),ispec_selected_source(i_source))
endif
! check that acoustic source is not exactly on the free surface because pressure is zero there
- if(is_proc_source == 1) then
+ if(is_proc_source(i_source) == 1) then
do ispec_acoustic_surface = 1,nelem_acoustic_surface
ispec = acoustic_surface(1,ispec_acoustic_surface)
- if( .not. elastic(ispec) .and. ispec == ispec_selected_source ) then
+ if( .not. elastic(ispec) .and. .not. poroelastic(ispec) .and. ispec == ispec_selected_source(i_source) ) then
do j = acoustic_surface(4,ispec_acoustic_surface), acoustic_surface(5,ispec_acoustic_surface)
do i = acoustic_surface(2,ispec_acoustic_surface), acoustic_surface(3,ispec_acoustic_surface)
iglob = ibool(i,j,ispec)
- if ( iglob_source == iglob ) then
+ if ( iglob_source(i_source) == iglob ) then
call exit_MPI('an acoustic source cannot be located exactly on the free surface because pressure is zero there')
endif
enddo
@@ -1270,25 +1630,58 @@
enddo
endif
- else if(source_type == 2) then
+ else if(source_type(i_source) == 2) then
! moment-tensor source
- call locate_source_moment_tensor(ibool,coord,nspec,npoin,xigll,zigll,x_source,z_source, &
- ispec_selected_source,is_proc_source,nb_proc_source,nproc,myrank,xi_source,gamma_source,coorg,knods,ngnod,npgeo,ipass)
+ call locate_source_moment_tensor(ibool,coord,nspec,npoin,xigll,zigll,x_source(i_source),z_source(i_source), &
+ ispec_selected_source(i_source),is_proc_source(i_source),nb_proc_source(i_source),&
+ nproc,myrank,xi_source(i_source),gamma_source(i_source),coorg,knods,ngnod,npgeo,ipass)
! compute source array for moment-tensor source
- call compute_arrays_source(ispec_selected_source,xi_source,gamma_source,sourcearray, &
- Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,nspec)
+ call compute_arrays_source(ispec_selected_source(i_source),xi_source(i_source),gamma_source(i_source),&
+ sourcearray(i_source,:,:,:), &
+ Mxx(i_source),Mzz(i_source),Mxz(i_source),xix,xiz,gammax,gammaz,xigll,zigll,nspec)
else if(.not.initialfield) then
call exit_MPI('incorrect source type')
endif
+
! locate receivers in the mesh
call locate_receivers(ibool,coord,nspec,npoin,xigll,zigll,nrec,nrecloc,recloc,which_proc_receiver,nproc,myrank,&
st_xval,st_zval,ispec_selected_rec, &
- xi_receiver,gamma_receiver,station_name,network_name,x_source,z_source,coorg,knods,ngnod,npgeo,ipass, &
+ xi_receiver,gamma_receiver,station_name,network_name,x_source(i_source),z_source(i_source),coorg,knods,ngnod,npgeo,ipass, &
x_final_receiver, z_final_receiver)
+ enddo ! do i_source=1,NSOURCE
+
+! compute source array for adjoint source
+ if(isolver == 2) then ! adjoint calculation
+ nadj_rec_local = 0
+ do irec = 1,nrec
+ if(myrank == which_proc_receiver(irec))then
+! check that the source proc number is okay
+ if(which_proc_receiver(irec) < 0 .or. which_proc_receiver(irec) > NPROC-1) &
+ call exit_MPI(myrank,'something is wrong with the source proc number in adjoint simulation')
+ nadj_rec_local = nadj_rec_local + 1
+ endif
+ enddo
+ if(ipass == 1) allocate(adj_sourcearray(NSTEP,NDIM,NGLLX,NGLLZ))
+ if (nadj_rec_local > 0 .and. ipass == 1) allocate(adj_sourcearrays(nadj_rec_local,NSTEP,NDIM,NGLLX,NGLLZ))
+ irec_local = 0
+ do irec = 1, nrec
+! compute only adjoint source arrays in the local proc
+ if(myrank == which_proc_receiver(irec))then
+ irec_local = irec_local + 1
+ adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
+ call compute_arrays_adj_source(myrank,adj_source_file, &
+ xi_receiver(irec), gamma_receiver(irec), &
+ adj_sourcearray, xigll,zigll,NSTEP)
+ adj_sourcearrays(irec_local,:,:,:,:) = adj_sourcearray(:,:,:,:)
+ endif
+ enddo
+ endif
+
+
if (ipass == 1) then
if (nrecloc > 0) then
allocate(anglerec_irec(nrecloc))
@@ -1310,6 +1703,7 @@
!--- tangential computation
!
if (ipass == NUMBER_OF_PASSES) then
+
! for receivers
if (rec_normal_to_surface) then
irecloc = 0
@@ -1343,13 +1737,15 @@
cosrot_irec(:) = cos(anglerec_irec(:))
sinrot_irec(:) = sin(anglerec_irec(:))
endif
-
! for the source
if (force_normal_to_surface) then
+
+ do i_source=1,NSOURCE
+ if (is_proc_source(i_source) == 1) then
distmin = HUGEVAL
do i = 1, nnodes_tangential_curve
- dist_current = sqrt((coord(1,iglob_source)-nodes_tangential_curve(1,i))**2 + &
- (coord(2,iglob_source)-nodes_tangential_curve(2,i))**2)
+ dist_current = sqrt((coord(1,iglob_source(i_source))-nodes_tangential_curve(1,i))**2 + &
+ (coord(2,iglob_source(i_source))-nodes_tangential_curve(2,i))**2)
if ( dist_current < distmin ) then
n1_tangential_detection_curve = i
distmin = dist_current
@@ -1359,7 +1755,7 @@
call tri_quad(n_tangential_detection_curve, n1_tangential_detection_curve, nnodes_tangential_curve)
- call calcul_normale( angleforce, nodes_tangential_curve(1,n_tangential_detection_curve(1)), &
+ call calcul_normale( angleforce(i_source), nodes_tangential_curve(1,n_tangential_detection_curve(1)), &
nodes_tangential_curve(1,n_tangential_detection_curve(2)), &
nodes_tangential_curve(1,n_tangential_detection_curve(3)), &
nodes_tangential_curve(1,n_tangential_detection_curve(4)), &
@@ -1367,33 +1763,36 @@
nodes_tangential_curve(2,n_tangential_detection_curve(2)), &
nodes_tangential_curve(2,n_tangential_detection_curve(3)), &
nodes_tangential_curve(2,n_tangential_detection_curve(4)) )
-
- source_courbe_eros = n1_tangential_detection_curve
- if ( myrank == 0 .and. is_proc_source == 1 .and. nb_proc_source == 1 ) then
- source_courbe_eros = n1_tangential_detection_curve
- angleforce_recv = angleforce
+
+ source_courbe_eros(i_source) = n1_tangential_detection_curve
+ if ( myrank == 0 .and. is_proc_source(i_source) == 1 .and. nb_proc_source(i_source) == 1 ) then
+ source_courbe_eros(i_source) = n1_tangential_detection_curve
+ angleforce_recv = angleforce(i_source)
#ifdef USE_MPI
else if ( myrank == 0 ) then
- do i = 1, nb_proc_source - is_proc_source
- call MPI_recv(source_courbe_eros,1,MPI_INTEGER,MPI_ANY_SOURCE,42,MPI_COMM_WORLD,request_mpi_status,ier)
+ do i = 1, nb_proc_source(i_source) - is_proc_source(i_source)
+ call MPI_recv(source_courbe_eros(i_source),1,MPI_INTEGER,MPI_ANY_SOURCE,42,MPI_COMM_WORLD,request_mpi_status,ier)
call MPI_recv(angleforce_recv,1,MPI_DOUBLE_PRECISION,MPI_ANY_SOURCE,43,MPI_COMM_WORLD,request_mpi_status,ier)
enddo
- else if ( is_proc_source == 1 ) then
+ else if ( is_proc_source(i_source) == 1 ) then
call MPI_send(n1_tangential_detection_curve,1,MPI_INTEGER,0,42,MPI_COMM_WORLD,ier)
- call MPI_send(angleforce,1,MPI_DOUBLE_PRECISION,0,43,MPI_COMM_WORLD,ier)
+ call MPI_send(angleforce(i_source),1,MPI_DOUBLE_PRECISION,0,43,MPI_COMM_WORLD,ier)
#endif
endif
#ifdef USE_MPI
call MPI_bcast(angleforce_recv,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
- angleforce = angleforce_recv
+ angleforce(i_source) = angleforce_recv
#endif
- endif
+ endif ! if (is_proc_source(i_source) == 1)
+ enddo ! do i_source=1,NSOURCE
+ endif ! if (force_normal_to_surface)
+! CHRIS --- how to deal with multiple source. Use first source now. ---
! compute distance from source to receivers following the curve
if (force_normal_to_surface .and. rec_normal_to_surface) then
- dist_tangential_detection_curve(source_courbe_eros) = 0
- do i = source_courbe_eros+1, nnodes_tangential_curve
+ dist_tangential_detection_curve(source_courbe_eros(1)) = 0
+ do i = source_courbe_eros(1)+1, nnodes_tangential_curve
dist_tangential_detection_curve(i) = dist_tangential_detection_curve(i-1) + &
sqrt((nodes_tangential_curve(1,i)-nodes_tangential_curve(1,i-1))**2 + &
(nodes_tangential_curve(2,i)-nodes_tangential_curve(2,i-1))**2)
@@ -1401,12 +1800,12 @@
dist_tangential_detection_curve(1) = dist_tangential_detection_curve(nnodes_tangential_curve) + &
sqrt((nodes_tangential_curve(1,1)-nodes_tangential_curve(1,nnodes_tangential_curve))**2 + &
(nodes_tangential_curve(2,1)-nodes_tangential_curve(2,nnodes_tangential_curve))**2)
- do i = 2, source_courbe_eros-1
+ do i = 2, source_courbe_eros(1)-1
dist_tangential_detection_curve(i) = dist_tangential_detection_curve(i-1) + &
sqrt((nodes_tangential_curve(1,i)-nodes_tangential_curve(1,i-1))**2 + &
(nodes_tangential_curve(2,i)-nodes_tangential_curve(2,i-1))**2)
enddo
- do i = source_courbe_eros-1, 1, -1
+ do i = source_courbe_eros(1)-1, 1, -1
dist_current = dist_tangential_detection_curve(i+1) + &
sqrt((nodes_tangential_curve(1,i)-nodes_tangential_curve(1,i+1))**2 + &
(nodes_tangential_curve(2,i)-nodes_tangential_curve(2,i+1))**2)
@@ -1420,7 +1819,7 @@
if ( dist_current < dist_tangential_detection_curve(nnodes_tangential_curve) ) then
dist_tangential_detection_curve(nnodes_tangential_curve) = dist_current
endif
- do i = nnodes_tangential_curve-1, source_courbe_eros+1, -1
+ do i = nnodes_tangential_curve-1, source_courbe_eros(1)+1, -1
dist_current = dist_tangential_detection_curve(i+1) + &
sqrt((nodes_tangential_curve(1,i)-nodes_tangential_curve(1,i+1))**2 + &
(nodes_tangential_curve(2,i)-nodes_tangential_curve(2,i+1))**2)
@@ -1501,7 +1900,7 @@
izmax = acoustic_surface(5,ispec_acoustic_surface)
do irecloc = 1,nrecloc
irec = recloc(irecloc)
- if(.not. elastic(ispec) .and. ispec == ispec_selected_rec(irec)) then
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec) .and. ispec == ispec_selected_rec(irec)) then
if ( (izmin==1 .and. izmax==1 .and. ixmin==1 .and. ixmax==NGLLX .and. &
gamma_receiver(irec) < -0.99d0) .or.&
(izmin==NGLLZ .and. izmax==NGLLZ .and. ixmin==1 .and. ixmax==NGLLX .and. &
@@ -1555,7 +1954,166 @@
allocate(accel_elastic(1,1))
allocate(rmass_inverse_elastic(1))
endif
+! extra array if adjoint and kernels calculation
+ if(isolver == 2 .and. any_elastic) then
+ allocate(b_displ_elastic(NDIM,npoin))
+ allocate(b_veloc_elastic(NDIM,npoin))
+ allocate(b_accel_elastic(NDIM,npoin))
+ allocate(rho_kl(npoin))
+ allocate(rho_k(npoin))
+ allocate(rhol_global(npoin))
+ allocate(mu_kl(npoin))
+ allocate(mu_k(npoin))
+ allocate(mul_global(npoin))
+ allocate(kappa_kl(npoin))
+ allocate(kappa_k(npoin))
+ allocate(kappal_global(npoin))
+ allocate(rhop_kl(npoin))
+ allocate(alpha_kl(npoin))
+ allocate(beta_kl(npoin))
+ else
+ allocate(b_displ_elastic(1,1))
+ allocate(b_veloc_elastic(1,1))
+ allocate(b_accel_elastic(1,1))
+ allocate(rho_kl(1))
+ allocate(rho_k(1))
+ allocate(rhol_global(1))
+ allocate(mu_kl(1))
+ allocate(mu_k(1))
+ allocate(mul_global(1))
+ allocate(kappa_kl(1))
+ allocate(kappa_k(1))
+ allocate(kappal_global(1))
+ allocate(rhop_kl(1))
+ allocate(alpha_kl(1))
+ allocate(beta_kl(1))
+ endif
+ if(any_poroelastic) then
+ allocate(displs_poroelastic(NDIM,npoin))
+ allocate(velocs_poroelastic(NDIM,npoin))
+ allocate(accels_poroelastic(NDIM,npoin))
+ allocate(rmass_s_inverse_poroelastic(npoin))
+ allocate(displw_poroelastic(NDIM,npoin))
+ allocate(velocw_poroelastic(NDIM,npoin))
+ allocate(accelw_poroelastic(NDIM,npoin))
+ allocate(rmass_w_inverse_poroelastic(npoin))
+ else
+! allocate unused arrays with fictitious size
+ allocate(displs_poroelastic(1,1))
+ allocate(velocs_poroelastic(1,1))
+ allocate(accels_poroelastic(1,1))
+ allocate(rmass_s_inverse_poroelastic(1))
+ allocate(displw_poroelastic(1,1))
+ allocate(velocw_poroelastic(1,1))
+ allocate(accelw_poroelastic(1,1))
+ allocate(rmass_w_inverse_poroelastic(1))
+ endif
+! extra array if adjoint and kernels calculation
+ if(isolver == 2 .and. any_poroelastic) then
+ allocate(b_displs_poroelastic(NDIM,npoin))
+ allocate(b_velocs_poroelastic(NDIM,npoin))
+ allocate(b_accels_poroelastic(NDIM,npoin))
+ allocate(b_displw_poroelastic(NDIM,npoin))
+ allocate(b_velocw_poroelastic(NDIM,npoin))
+ allocate(b_accelw_poroelastic(NDIM,npoin))
+ allocate(rhot_kl(npoin))
+ allocate(rhot_k(npoin))
+ allocate(rhof_kl(npoin))
+ allocate(rhof_k(npoin))
+ allocate(sm_kl(npoin))
+ allocate(sm_k(npoin))
+ allocate(eta_kl(npoin))
+ allocate(eta_k(npoin))
+ allocate(mufr_kl(npoin))
+ allocate(mufr_k(npoin))
+ allocate(B_kl(npoin))
+ allocate(B_k(npoin))
+ allocate(C_kl(npoin))
+ allocate(C_k(npoin))
+ allocate(M_kl(npoin))
+ allocate(M_k(npoin))
+ allocate(rhob_kl(npoin))
+ allocate(rhofb_kl(npoin))
+ allocate(phi_kl(npoin))
+ allocate(Bb_kl(npoin))
+ allocate(Cb_kl(npoin))
+ allocate(Mb_kl(npoin))
+ allocate(mufrb_kl(npoin))
+ allocate(rhobb_kl(npoin))
+ allocate(rhofbb_kl(npoin))
+ allocate(phib_kl(npoin))
+ allocate(cpI_kl(npoin))
+ allocate(cpII_kl(npoin))
+ allocate(cs_kl(npoin))
+ allocate(ratio_kl(npoin))
+ allocate(phil_global(npoin))
+ allocate(mulfr_global(npoin))
+ allocate(etal_f_global(npoin))
+ allocate(rhol_s_global(npoin))
+ allocate(rhol_f_global(npoin))
+ allocate(rhol_bar_global(npoin))
+ allocate(tortl_global(npoin))
+ allocate(permlxx_global(npoin))
+ allocate(permlxz_global(npoin))
+ allocate(permlzz_global(npoin))
+ else
+ allocate(b_displs_poroelastic(1,1))
+ allocate(b_velocs_poroelastic(1,1))
+ allocate(b_accels_poroelastic(1,1))
+ allocate(b_displw_poroelastic(1,1))
+ allocate(b_velocw_poroelastic(1,1))
+ allocate(b_accelw_poroelastic(1,1))
+ allocate(rhot_kl(1))
+ allocate(rhot_k(1))
+ allocate(rhof_kl(1))
+ allocate(rhof_k(1))
+ allocate(sm_kl(1))
+ allocate(sm_k(1))
+ allocate(eta_kl(1))
+ allocate(eta_k(1))
+ allocate(mufr_kl(1))
+ allocate(mufr_k(1))
+ allocate(B_kl(1))
+ allocate(B_k(1))
+ allocate(C_kl(1))
+ allocate(C_k(1))
+ allocate(M_kl(1))
+ allocate(M_k(1))
+ allocate(rhob_kl(1))
+ allocate(rhofb_kl(1))
+ allocate(phi_kl(1))
+ allocate(Bb_kl(1))
+ allocate(Cb_kl(1))
+ allocate(Mb_kl(1))
+ allocate(mufrb_kl(1))
+ allocate(rhobb_kl(1))
+ allocate(rhofbb_kl(1))
+ allocate(phib_kl(1))
+ allocate(cpI_kl(1))
+ allocate(cpII_kl(1))
+ allocate(cs_kl(1))
+ allocate(ratio_kl(1))
+ allocate(phil_global(1))
+ allocate(mulfr_global(1))
+ allocate(etal_f_global(1))
+ allocate(rhol_s_global(1))
+ allocate(rhol_f_global(1))
+ allocate(rhol_bar_global(1))
+ allocate(tortl_global(1))
+ allocate(permlxx_global(1))
+ allocate(permlxz_global(1))
+ allocate(permlzz_global(1))
+ endif
+
+ if(any_poroelastic .and. any_elastic) then
+ allocate(displ(2,npoin))
+ allocate(veloc(2,npoin))
+ else
+ allocate(displ(2,1))
+ allocate(veloc(2,1))
+ endif
+
! potential, its first and second derivative, and inverse of the mass matrix for acoustic elements
if(any_acoustic) then
allocate(potential_acoustic(npoin))
@@ -1569,6 +2127,32 @@
allocate(potential_dot_dot_acoustic(1))
allocate(rmass_inverse_acoustic(1))
endif
+ if(isolver == 2 .and. any_acoustic) then
+ allocate(b_potential_acoustic(npoin))
+ allocate(b_potential_dot_acoustic(npoin))
+ allocate(b_potential_dot_dot_acoustic(npoin))
+ allocate(rho_ac_kl(npoin))
+ allocate(rho_ac_k(npoin))
+ allocate(rhol_ac_global(npoin))
+ allocate(kappa_ac_kl(npoin))
+ allocate(kappa_ac_k(npoin))
+ allocate(kappal_ac_global(npoin))
+ allocate(rhop_ac_kl(npoin))
+ allocate(alpha_ac_kl(npoin))
+ else
+! allocate unused arrays with fictitious size
+ allocate(b_potential_acoustic(1))
+ allocate(b_potential_dot_acoustic(1))
+ allocate(b_potential_dot_dot_acoustic(1))
+ allocate(rho_ac_kl(1))
+ allocate(rho_ac_k(1))
+ allocate(rhol_ac_global(1))
+ allocate(kappa_ac_kl(1))
+ allocate(kappa_ac_k(1))
+ allocate(kappal_ac_global(1))
+ allocate(rhop_ac_kl(1))
+ allocate(alpha_ac_kl(1))
+ endif
endif
@@ -1576,31 +2160,47 @@
!---- build the global mass matrix and invert it once and for all
!
if(any_elastic) rmass_inverse_elastic(:) = ZERO
+ if(any_poroelastic) rmass_s_inverse_poroelastic(:) = ZERO
+ if(any_poroelastic) rmass_w_inverse_poroelastic(:) = ZERO
if(any_acoustic) rmass_inverse_acoustic(:) = ZERO
do ispec = 1,nspec
do j = 1,NGLLZ
do i = 1,NGLLX
iglob = ibool(i,j,ispec)
-! if external density model
+
+! if external density model (elastic or acoustic)
if(assign_external_model) then
rhol = rhoext(i,j,ispec)
kappal = rhol * vpext(i,j,ispec)**2
else
- rhol = density(kmato(ispec))
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
+ rhol = density(1,kmato(ispec))
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
kappal = lambdal_relaxed + 2.d0*mul_relaxed
endif
- if(elastic(ispec)) then
-! for elastic medium
+
+ if(poroelastic(ispec)) then ! material is poroelastic
+ rhol_s = density(1,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+ rhol_bar = (1._CUSTOM_REAL-phil)*rhol_s + phil*rhol_f
+! for the solid mass matrix
+ rmass_s_inverse_poroelastic(iglob) = rmass_s_inverse_poroelastic(iglob) + &
+ wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*(rhol_bar - phil*rhol_f/tortl)
+! for the fluid mass matrix
+ rmass_w_inverse_poroelastic(iglob) = rmass_w_inverse_poroelastic(iglob) + &
+ wxgll(i)*wzgll(j)*jacobian(i,j,ispec)*(rhol_bar*rhol_f*tortl - &
+ phil*rhol_f*rhol_f)/(rhol_bar*phil)
+ elseif(elastic(ispec)) then ! for elastic medium
rmass_inverse_elastic(iglob) = rmass_inverse_elastic(iglob) + wxgll(i)*wzgll(j)*rhol*jacobian(i,j,ispec)
- else
-! for acoustic medium
+ else ! for acoustic medium
rmass_inverse_acoustic(iglob) = rmass_inverse_acoustic(iglob) + wxgll(i)*wzgll(j)*jacobian(i,j,ispec) / kappal
endif
+
enddo
enddo
- enddo
+ enddo ! do ispec = 1,nspec
#ifdef USE_MPI
if ( nproc > 1 ) then
@@ -1608,12 +2208,12 @@
if(ipass == 1) allocate(mask_ispec_inner_outer(nspec))
mask_ispec_inner_outer(:) = .false.
- call prepare_assemble_MPI (nspec,ibool,knods, ngnod,npoin,elastic, &
+ call prepare_assemble_MPI (nspec,ibool,knods,ngnod,npoin,elastic,poroelastic, &
ninterface, max_interface_size,my_nelmnts_neighbours, my_interfaces, &
- ibool_interfaces_acoustic, ibool_interfaces_elastic, &
- nibool_interfaces_acoustic, nibool_interfaces_elastic, &
- inum_interfaces_acoustic, inum_interfaces_elastic, &
- ninterface_acoustic, ninterface_elastic,mask_ispec_inner_outer)
+ ibool_interfaces_acoustic, ibool_interfaces_elastic, ibool_interfaces_poroelastic, &
+ nibool_interfaces_acoustic, nibool_interfaces_elastic, nibool_interfaces_poroelastic, &
+ inum_interfaces_acoustic, inum_interfaces_elastic, inum_interfaces_poroelastic, &
+ ninterface_acoustic, ninterface_elastic, ninterface_poroelastic,mask_ispec_inner_outer)
nspec_outer = count(mask_ispec_inner_outer)
nspec_inner = nspec - nspec_outer
@@ -1640,6 +2240,7 @@
max_ibool_interfaces_size_ac = maxval(nibool_interfaces_acoustic(:))
max_ibool_interfaces_size_el = NDIM*maxval(nibool_interfaces_elastic(:))
+ max_ibool_interfaces_size_po = NDIM*maxval(nibool_interfaces_poroelastic(:))
if(ipass == 1) then
allocate(tab_requests_send_recv_acoustic(ninterface_acoustic*2))
allocate(buffer_send_faces_vector_ac(max_ibool_interfaces_size_ac,ninterface_acoustic))
@@ -1647,16 +2248,25 @@
allocate(tab_requests_send_recv_elastic(ninterface_elastic*2))
allocate(buffer_send_faces_vector_el(max_ibool_interfaces_size_el,ninterface_elastic))
allocate(buffer_recv_faces_vector_el(max_ibool_interfaces_size_el,ninterface_elastic))
+ allocate(tab_requests_send_recv_poroelastic(ninterface_poroelastic*4))
+ allocate(buffer_send_faces_vector_pos(max_ibool_interfaces_size_po,ninterface_poroelastic))
+ allocate(buffer_recv_faces_vector_pos(max_ibool_interfaces_size_po,ninterface_poroelastic))
+ allocate(buffer_send_faces_vector_pow(max_ibool_interfaces_size_po,ninterface_poroelastic))
+ allocate(buffer_recv_faces_vector_pow(max_ibool_interfaces_size_po,ninterface_poroelastic))
endif
! assembling the mass matrix
- call assemble_MPI_scalar(rmass_inverse_acoustic, rmass_inverse_elastic,npoin, &
+ call assemble_MPI_scalar(rmass_inverse_acoustic,rmass_inverse_elastic,rmass_s_inverse_poroelastic, &
+ rmass_w_inverse_poroelastic,npoin, &
ninterface, max_interface_size, max_ibool_interfaces_size_ac, max_ibool_interfaces_size_el, &
- ibool_interfaces_acoustic,ibool_interfaces_elastic, nibool_interfaces_acoustic,nibool_interfaces_elastic, my_neighbours)
+ max_ibool_interfaces_size_po, &
+ ibool_interfaces_acoustic,ibool_interfaces_elastic,ibool_interfaces_poroelastic, &
+ nibool_interfaces_acoustic,nibool_interfaces_elastic,nibool_interfaces_poroelastic,my_neighbours)
else
ninterface_acoustic = 0
ninterface_elastic = 0
+ ninterface_poroelastic = 0
num_ispec_outer = 0
num_ispec_inner = 0
@@ -1804,7 +2414,6 @@
if(minval(check_perm) /= 1) stop 'minval check_perm is incorrect for whole'
if(maxval(check_perm) /= nspec) stop 'maxval check_perm is incorrect for whole'
deallocate(check_perm)
-
else
if(ACTUALLY_IMPLEMENT_PERM_OUT) then
@@ -1849,10 +2458,14 @@
! fill mass matrix with fictitious non-zero values to make sure it can be inverted globally
if(any_elastic) where(rmass_inverse_elastic <= 0._CUSTOM_REAL) rmass_inverse_elastic = 1._CUSTOM_REAL
+ if(any_poroelastic) where(rmass_s_inverse_poroelastic <= 0._CUSTOM_REAL) rmass_s_inverse_poroelastic = 1._CUSTOM_REAL
+ if(any_poroelastic) where(rmass_w_inverse_poroelastic <= 0._CUSTOM_REAL) rmass_w_inverse_poroelastic = 1._CUSTOM_REAL
if(any_acoustic) where(rmass_inverse_acoustic <= 0._CUSTOM_REAL) rmass_inverse_acoustic = 1._CUSTOM_REAL
! compute the inverse of the mass matrix
if(any_elastic) rmass_inverse_elastic(:) = 1._CUSTOM_REAL / rmass_inverse_elastic(:)
+ if(any_poroelastic) rmass_s_inverse_poroelastic(:) = 1._CUSTOM_REAL / rmass_s_inverse_poroelastic(:)
+ if(any_poroelastic) rmass_w_inverse_poroelastic(:) = 1._CUSTOM_REAL / rmass_w_inverse_poroelastic(:)
if(any_acoustic) rmass_inverse_acoustic(:) = 1._CUSTOM_REAL / rmass_inverse_acoustic(:)
! check the mesh, stability and number of points per wavelength
@@ -1867,9 +2480,11 @@
else
stop 'incorrect value of DISPLAY_SUBSET_OPTION'
endif
- call checkgrid(vpext,vsext,rhoext,density,elastcoef,ibool,kmato,coord,npoin,vpmin,vpmax, &
- assign_external_model,nspec,UPPER_LIMIT_DISPLAY,numat,deltat,f0,t0,initialfield,time_function_type, &
- coorg,xinterp,zinterp,shape2D_display,knods,simulation_title,npgeo,pointsdisp,ngnod,any_elastic,myrank,nproc)
+ call checkgrid(vpext,vsext,rhoext,density,poroelastcoef,porosity,tortuosity,ibool,kmato, &
+ coord,npoin,vpImin,vpImax,vpIImin,vpIImax, &
+ assign_external_model,nspec,UPPER_LIMIT_DISPLAY,numat,deltat,f0,t0,initialfield, &
+ time_function_type,coorg,xinterp,zinterp,shape2D_display,knods,simulation_title, &
+ npgeo,pointsdisp,ngnod,any_elastic,any_poroelastic,myrank,nproc,NSOURCE,poroelastic)
! convert receiver angle to radians
anglerec = anglerec * pi / 180.d0
@@ -2069,11 +2684,535 @@
veloc_elastic = ZERO
accel_elastic = ZERO
+ displs_poroelastic = ZERO
+ velocs_poroelastic = ZERO
+ accels_poroelastic = ZERO
+ displw_poroelastic = ZERO
+ velocw_poroelastic = ZERO
+ accelw_poroelastic = ZERO
+
potential_acoustic = ZERO
potential_dot_acoustic = ZERO
potential_dot_dot_acoustic = ZERO
!
+!----- Files where viscous damping are saved during forward wavefield calculation
+!
+ if(any_poroelastic .and. (save_forward .or. isolver .eq. 2)) then
+ allocate(b_viscodampx(npoin))
+ allocate(b_viscodampz(npoin))
+ write(outputname,'(a,i6.6,a)') 'viscodampingx',myrank,'.bin'
+ write(outputname2,'(a,i6.6,a)') 'viscodampingz',myrank,'.bin'
+ if(isolver == 2) then
+ reclen = CUSTOM_REAL * npoin
+ open(unit=23,file='OUTPUT_FILES/'//outputname,status='old',&
+ action='read',form='unformatted',access='direct',&
+ recl=reclen)
+ open(unit=24,file='OUTPUT_FILES/'//outputname2,status='old',&
+ action='read',form='unformatted',access='direct',&
+ recl=reclen)
+ else
+ reclen = CUSTOM_REAL * npoin
+ open(unit=23,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted',access='direct',&
+ recl=reclen)
+ open(unit=24,file='OUTPUT_FILES/'//outputname2,status='unknown',&
+ form='unformatted',access='direct',&
+ recl=reclen)
+ endif
+ endif
+
+!
+!----- Files where absorbing signal are saved during forward wavefield calculation
+!
+
+ if( ((save_forward .and. isolver ==1) .or. isolver == 2) .and. anyabs ) then
+
+ if(any_elastic) then
+
+!--- left absorbing boundary
+ if( nspec_xmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_elastic_left',myrank,'.bin'
+ if(isolver == 2) then
+ open(unit=35,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=35,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of left absorbing boundary
+
+!--- right absorbing boundary
+ if( nspec_xmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_elastic_right',myrank,'.bin'
+ if(isolver == 2) then
+ open(unit=36,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=36,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of right absorbing boundary
+
+!--- bottom absorbing boundary
+ if( nspec_zmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_elastic_bottom',myrank,'.bin'
+ if(isolver == 2) then
+ open(unit=37,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=37,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of bottom absorbing boundary
+
+!--- top absorbing boundary
+ if( nspec_zmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_elastic_top',myrank,'.bin'
+ if(isolver == 2) then
+ open(unit=38,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=38,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of top absorbing boundary
+
+ endif
+
+ if(any_poroelastic) then
+
+!--- left absorbing boundary
+ if( nspec_xmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_poro_s_left',myrank,'.bin'
+ write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_left',myrank,'.bin'
+ if(isolver == 2) then
+ open(unit=45,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ open(unit=25,file='OUTPUT_FILES/'//outputname2,status='old',&
+ form='unformatted')
+ else
+ open(unit=45,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ open(unit=25,file='OUTPUT_FILES/'//outputname2,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of left absorbing boundary
+
+!--- right absorbing boundary
+ if( nspec_xmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_poro_s_right',myrank,'.bin'
+ write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_right',myrank,'.bin'
+ if(isolver == 2) then
+ open(unit=46,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ open(unit=26,file='OUTPUT_FILES/'//outputname2,status='old',&
+ form='unformatted')
+ else
+ open(unit=46,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ open(unit=26,file='OUTPUT_FILES/'//outputname2,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of right absorbing boundary
+
+!--- bottom absorbing boundary
+ if( nspec_zmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_poro_s_bottom',myrank,'.bin'
+ write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_bottom',myrank,'.bin'
+ if(isolver == 2) then
+ open(unit=47,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ open(unit=29,file='OUTPUT_FILES/'//outputname2,status='old',&
+ form='unformatted')
+ else
+ open(unit=47,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ open(unit=29,file='OUTPUT_FILES/'//outputname2,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of bottom absorbing boundary
+
+!--- top absorbing boundary
+ if( nspec_zmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_poro_s_top',myrank,'.bin'
+ write(outputname2,'(a,i6.6,a)') 'absorb_poro_w_top',myrank,'.bin'
+ if(isolver == 2) then
+ open(unit=48,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ open(unit=28,file='OUTPUT_FILES/'//outputname2,status='old',&
+ form='unformatted')
+ else
+ open(unit=48,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ open(unit=28,file='OUTPUT_FILES/'//outputname2,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of top absorbing boundary
+
+ endif
+
+ if(any_acoustic) then
+
+!--- left absorbing boundary
+ if( nspec_xmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_acoustic_left',myrank,'.bin'
+ if(isolver == 2) then
+ open(unit=65,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=65,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of left absorbing boundary
+
+!--- right absorbing boundary
+ if( nspec_xmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_acoustic_right',myrank,'.bin'
+ if(isolver == 2) then
+ open(unit=66,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=66,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of right absorbing boundary
+
+!--- bottom absorbing boundary
+ if( nspec_zmin >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_acoustic_bottom',myrank,'.bin'
+ if(isolver == 2) then
+ open(unit=67,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=67,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of bottom absorbing boundary
+
+!--- top absorbing boundary
+ if( nspec_zmax >0 ) then
+ write(outputname,'(a,i6.6,a)') 'absorb_acoustic_top',myrank,'.bin'
+ if(isolver == 2) then
+ open(unit=68,file='OUTPUT_FILES/'//outputname,status='old',&
+ form='unformatted')
+ else
+ open(unit=68,file='OUTPUT_FILES/'//outputname,status='unknown',&
+ form='unformatted')
+ endif
+
+ endif ! end of top absorbing boundary
+
+ endif
+
+ endif !if( ((save_forward .and. isolver ==1) .or. isolver == 2) .and. anyabs )
+
+
+ if(anyabs .and. isolver == 2) then
+
+ if(any_elastic) then
+
+ do it =1, NSTEP
+
+!--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do id =1,2
+ do i=1,NGLLZ
+ read(35) b_absorb_elastic_left(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do id =1,2
+ do i=1,NGLLZ
+ read(36) b_absorb_elastic_right(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do id =1,2
+ do i=1,NGLLX
+ read(37) b_absorb_elastic_bottom(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do id =1,2
+ do i=1,NGLLX
+ read(38) b_absorb_elastic_top(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+
+ enddo
+
+ endif ! if(any_elastic)
+
+ if(any_poroelastic) then
+
+ do it =1, NSTEP
+
+!--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do id =1,2
+ do i=1,NGLLZ
+ read(45) b_absorb_poro_s_left(id,i,ispec,it)
+ read(25) b_absorb_poro_w_left(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do id =1,2
+ do i=1,NGLLZ
+ read(46) b_absorb_poro_s_right(id,i,ispec,it)
+ read(26) b_absorb_poro_w_right(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do id =1,2
+ do i=1,NGLLX
+ read(47) b_absorb_poro_s_bottom(id,i,ispec,it)
+ read(29) b_absorb_poro_w_bottom(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do id =1,2
+ do i=1,NGLLX
+ read(48) b_absorb_poro_s_top(id,i,ispec,it)
+ read(28) b_absorb_poro_w_top(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+
+ enddo
+
+ endif ! if(any_poroelastic)
+
+ if(any_acoustic) then
+
+ do it =1, NSTEP
+
+!--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do i=1,NGLLZ
+ read(65) b_absorb_acoustic_left(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+!--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do i=1,NGLLZ
+ read(66) b_absorb_acoustic_right(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+!--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do i=1,NGLLX
+ read(67) b_absorb_acoustic_bottom(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+!--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do i=1,NGLLX
+ read(68) b_absorb_acoustic_top(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+
+ enddo
+
+ endif ! if(any_acoustic)
+
+
+ endif ! if(anyabs .and. isolver == 2)
+
+
+
+!
+!----- Read last frame for backward wavefield calculation
+!
+
+ if(isolver == 2) then
+
+ if(any_elastic) then
+ write(outputname,'(a,i6.6,a)') 'lastframe_elastic',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
+ do j=1,npoin
+ read(55) (b_displ_elastic(i,j), i=1,NDIM), &
+ (b_veloc_elastic(i,j), i=1,NDIM), &
+ (b_accel_elastic(i,j), i=1,NDIM)
+ enddo
+ close(55)
+
+ write(outputname,'(a,i6.6,a)') 'snapshot_rho_kappa_mu_',myrank
+ open(unit = 97, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_rhop_alpha_beta_',myrank
+ open(unit = 98, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+
+ rho_kl(:) = ZERO
+ mu_kl(:) = ZERO
+ kappa_kl(:) = ZERO
+!
+ rhop_kl(:) = ZERO
+ beta_kl(:) = ZERO
+ alpha_kl(:) = ZERO
+ endif
+
+ if(any_poroelastic) then
+ write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_s',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
+ write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_s',myrank,'.bin'
+ open(unit=56,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
+ do j=1,npoin
+ read(55) (b_displs_poroelastic(i,j), i=1,NDIM), &
+ (b_velocs_poroelastic(i,j), i=1,NDIM), &
+ (b_accels_poroelastic(i,j), i=1,NDIM)
+ read(56) (b_displw_poroelastic(i,j), i=1,NDIM), &
+ (b_velocw_poroelastic(i,j), i=1,NDIM), &
+ (b_accelw_poroelastic(i,j), i=1,NDIM)
+ enddo
+ close(55)
+ close(56)
+
+! Primary kernels
+ write(outputname,'(a,i6.6,a)') 'snapshot_mu_B_C_',myrank
+ open(unit = 14, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_M_rho_rhof_',myrank
+ open(unit = 15, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_m_eta_',myrank
+ open(unit = 16, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+! Wavespeed kernels
+ write(outputname,'(a,i6.6,a)') 'snapshot_cpI_cpII_cs_',myrank
+ open(unit = 17, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_rhobb_rhofbb_ratio_',myrank
+ open(unit = 18, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_phib_eta_',myrank
+ open(unit = 19, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+! Density normalized kernels
+ write(outputname,'(a,i6.6,a)') 'snapshot_mub_Bb_Cb_',myrank
+ open(unit = 20, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_Mb_rhob_rhofb_',myrank
+ open(unit = 21, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_mb_etab_',myrank
+ open(unit = 22, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+
+ rhot_kl(:) = ZERO
+ rhof_kl(:) = ZERO
+ eta_kl(:) = ZERO
+ sm_kl(:) = ZERO
+ mufr_kl(:) = ZERO
+ B_kl(:) = ZERO
+ C_kl(:) = ZERO
+ M_kl(:) = ZERO
+!
+ rhob_kl(:) = ZERO
+ rhofb_kl(:) = ZERO
+ phi_kl(:) = ZERO
+ mufrb_kl(:) = ZERO
+ Bb_kl(:) = ZERO
+ Cb_kl(:) = ZERO
+ Mb_kl(:) = ZERO
+!
+ rhobb_kl(:) = ZERO
+ rhofbb_kl(:) = ZERO
+ phib_kl(:) = ZERO
+ cs_kl(:) = ZERO
+ cpI_kl(:) = ZERO
+ cpII_kl(:) = ZERO
+ ratio_kl(:) = ZERO
+ endif
+
+ if(any_acoustic) then
+ write(outputname,'(a,i6.6,a)') 'lastframe_acoustic',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='old',action='read',form='unformatted')
+ do j=1,npoin
+ read(55) b_potential_acoustic(j),&
+ b_potential_dot_acoustic(j),&
+ b_potential_dot_dot_acoustic(j)
+ enddo
+ close(55)
+
+ write(outputname,'(a,i6.6,a)') 'snapshot_rho_kappa_',myrank
+ open(unit = 95, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+ write(outputname,'(a,i6.6,a)') 'snapshot_rhop_c_',myrank
+ open(unit = 96, file = 'OUTPUT_FILES/'//outputname,status = 'unknown',iostat=ios)
+ if (ios /= 0) stop 'Error writing snapshot to disk'
+
+ rho_ac_kl(:) = ZERO
+ kappa_ac_kl(:) = ZERO
+!
+ rhop_ac_kl(:) = ZERO
+ alpha_ac_kl(:) = ZERO
+ endif
+
+ endif ! if(isover == 2)
+
+!
!---- read initial fields from external file if needed
!
@@ -2089,7 +3228,7 @@
write(IOUT,*) 'Implementing an analytical initial plane wave...'
write(IOUT,*)
endif
- if(any_acoustic) call exit_MPI('initial field currently implemented for purely elastic simulation only')
+ if(any_acoustic .or. any_poroelastic) call exit_MPI('initial field currently implemented for purely elastic simulation only')
!=======================================================================
!
@@ -2106,47 +3245,49 @@
write(IOUT,*) 'and use 1 for a plane P wave, 2 for a plane SV wave, 3 for a Rayleigh wave'
write(IOUT,*)
- if (source_type == 1) then
- write(IOUT,*) 'initial P wave of', angleforce*180.d0/pi, 'degrees introduced.'
- else if (source_type == 2) then
- write(IOUT,*) 'initial SV wave of', angleforce*180.d0/pi, ' degrees introduced.'
+! only implemented for one source
+ if(NSOURCE > 1) call exit_MPI('calculation of the initial wave is only implemented for one source')
+ if (source_type(1) == 1) then
+ write(IOUT,*) 'initial P wave of', angleforce(1)*180.d0/pi, 'degrees introduced.'
+ else if (source_type(1) == 2) then
+ write(IOUT,*) 'initial SV wave of', angleforce(1)*180.d0/pi, ' degrees introduced.'
- else if (source_type == 3) then
+ else if (source_type(1) == 3) then
write(IOUT,*) 'Rayleigh wave introduced.'
else
call exit_MPI('Unrecognized source_type: should be 1 for plane P waves, 2 for plane SV waves, 3 for Rayleigh wave')
endif
- if ((angleforce < 0.0d0 .or. angleforce >= pi/2.d0) .and. source_type /= 3) then
+ if ((angleforce(1) < 0.0d0 .or. angleforce(1) >= pi/2.d0) .and. source_type(1) /= 3) then
call exit_MPI("incorrect angleforce: must have 0 <= angleforce < 90")
endif
endif
! only implemented for homogeneous media therefore only 1 material supported
if (numat==1) then
- mu = elastcoef(2,numat)
- lambdaplus2mu = elastcoef(3,numat)
- denst = density(numat)
+ mu = poroelastcoef(2,1,numat)
+ lambdaplus2mu = poroelastcoef(3,1,numat)
+ denst = density(1,numat)
cploc = sqrt(lambdaplus2mu/denst)
csloc = sqrt(mu/denst)
-
+
! P wave case
- if (source_type == 1) then
+ if (source_type(1) == 1) then
- p=sin(angleforce)/cploc
+ p=sin(angleforce(1))/cploc
c_inc = cploc
c_refl = csloc
angleforce_refl = asin(p*c_refl)
! from formulas (5.26) and (5.27) p 140 in Aki & Richards (1980)
- PP = (- cos(2.d0*angleforce_refl)**2/csloc**3 + 4.d0*p**2*cos(angleforce)*cos(angleforce_refl)/cploc) / &
- ( cos(2.d0*angleforce_refl)**2/csloc**3 + 4.d0*p**2*cos(angleforce)*cos(angleforce_refl)/cploc)
+ PP = (- cos(2.d0*angleforce_refl)**2/csloc**3 + 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc) / &
+ ( cos(2.d0*angleforce_refl)**2/csloc**3 + 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc)
- PS = 4.d0*p*cos(angleforce)*cos(2.d0*angleforce_refl) / &
+ PS = 4.d0*p*cos(angleforce(1))*cos(2.d0*angleforce_refl) / &
(csloc**2*(cos(2.d0*angleforce_refl)**2/csloc**3 &
- +4.d0*p**2*cos(angleforce)*cos(angleforce_refl)/cploc))
+ +4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc))
if (myrank == 0) then
write(IOUT,*) 'reflected convert plane wave angle: ', angleforce_refl*180.d0/pi
@@ -2154,14 +3295,14 @@
! from Table 5.1 p141 in Aki & Richards (1980)
! we put the opposite sign on z coefficients because z axis is oriented from bottom to top
- A_plane(1) = sin(angleforce); A_plane(2) = cos(angleforce)
- B_plane(1) = PP * sin(angleforce); B_plane(2) = - PP * cos(angleforce)
- C_plane(1) = PS * cos(angleforce_refl); C_plane(2) = PS * sin(angleforce_refl)
+ A_plane(1) = sin(angleforce(1)); A_plane(2) = cos(angleforce(1))
+ B_plane(1) = PP * sin(angleforce(1)); B_plane(2) = - PP * cos(angleforce(1))
+ C_plane(1) = PS * cos(angleforce_refl); C_plane(2) = PS * sin(angleforce_refl)
! SV wave case
- else if (source_type == 2) then
+ else if (source_type(1) == 2) then
- p=sin(angleforce)/csloc
+ p=sin(angleforce(1))/csloc
c_inc = csloc
c_refl = cploc
@@ -2170,18 +3311,18 @@
angleforce_refl = asin(p*c_refl)
! from formulas (5.30) and (5.31) p 140 in Aki & Richards (1980)
- SS = (cos(2.d0*angleforce)**2/csloc**3 - 4.d0*p**2*cos(angleforce)*cos(angleforce_refl)/cploc) / &
- (cos(2.d0*angleforce)**2/csloc**3 + 4.d0*p**2*cos(angleforce)*cos(angleforce_refl)/cploc)
- SP = 4.d0*p*cos(angleforce)*cos(2*angleforce) / &
- (cploc*csloc*(cos(2.d0*angleforce)**2/csloc**3&
- +4.d0*p**2*cos(angleforce_refl)*cos(angleforce)/cploc))
+ SS = (cos(2.d0*angleforce(1))**2/csloc**3 - 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc) / &
+ (cos(2.d0*angleforce(1))**2/csloc**3 + 4.d0*p**2*cos(angleforce(1))*cos(angleforce_refl)/cploc)
+ SP = 4.d0*p*cos(angleforce(1))*cos(2*angleforce(1)) / &
+ (cploc*csloc*(cos(2.d0*angleforce(1))**2/csloc**3&
+ +4.d0*p**2*cos(angleforce_refl)*cos(angleforce(1))/cploc))
if (myrank == 0) then
write(IOUT,*) 'reflected convert plane wave angle: ', angleforce_refl*180.d0/pi
endif
! SV45 degree incident plane wave is a particular case
- else if (angleforce>pi/4.d0-1.0d-11 .and. angleforce<pi/4.d0+1.0d-11) then
+ else if (angleforce(1)>pi/4.d0-1.0d-11 .and. angleforce(1)<pi/4.d0+1.0d-11) then
angleforce_refl = 0.d0
SS = -1.0d0
SP = 0.d0
@@ -2194,12 +3335,12 @@
! from Table 5.1 p141 in Aki & Richards (1980)
! we put the opposite sign on z coefficients because z axis is oriented from bottom to top
- A_plane(1) = cos(angleforce); A_plane(2) = - sin(angleforce)
- B_plane(1) = SS * cos(angleforce); B_plane(2) = SS * sin(angleforce)
- C_plane(1) = SP * sin(angleforce_refl); C_plane(2) = - SP * cos(angleforce_refl)
+ A_plane(1) = cos(angleforce(1)); A_plane(2) = - sin(angleforce(1))
+ B_plane(1) = SS * cos(angleforce(1)); B_plane(2) = SS * sin(angleforce(1))
+ C_plane(1) = SP * sin(angleforce_refl); C_plane(2) = - SP * cos(angleforce_refl)
! Rayleigh case
- else if (source_type == 3) then
+ else if (source_type(1) == 3) then
over_critical_angle=.true.
A_plane(1)=0.d0; A_plane(2)=0.d0
B_plane(1)=0.d0; B_plane(2)=0.d0
@@ -2227,20 +3368,20 @@
#endif
! initialize the time offset to put the plane wave not too close to the irregularity on the free surface
- if (abs(angleforce)<1.d0*pi/180.d0 .and. source_type/=3) then
+ if (abs(angleforce(1))<1.d0*pi/180.d0 .and. source_type(1)/=3) then
time_offset=-1.d0*(zmax-zmin)/2.d0/c_inc
else
time_offset=0.d0
endif
! to correctly center the initial plane wave in the mesh
- x0_source=x_source
- z0_source=z_source
+ x0_source=x_source(1)
+ z0_source=z_source(1)
if (myrank == 0) then
write(IOUT,*)
write(IOUT,*) 'You can modify the location of the initial plane wave by changing xs and zs in DATA/Par_File.'
- write(IOUT,*) ' for instance: xs=',x_source,' zs=',z_source, ' (zs must be the height of the free surface)'
+ write(IOUT,*) ' for instance: xs=',x_source(1),' zs=',z_source(1), ' (zs must be the height of the free surface)'
write(IOUT,*)
endif
@@ -2258,35 +3399,35 @@
t = 0.d0 + time_offset
! formulas for the initial displacement for a plane wave from Aki & Richards (1980)
- displ_elastic(1,i) = A_plane(1) * ricker_Bielak_displ(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
- + B_plane(1) * ricker_Bielak_displ(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
- + C_plane(1) * ricker_Bielak_displ(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
- displ_elastic(2,i) = A_plane(2) * ricker_Bielak_displ(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
- + B_plane(2) * ricker_Bielak_displ(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
- + C_plane(2) * ricker_Bielak_displ(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
+ displ_elastic(1,i) = A_plane(1) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(1) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(1) * ricker_Bielak_displ(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
+ displ_elastic(2,i) = A_plane(2) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(2) * ricker_Bielak_displ(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(2) * ricker_Bielak_displ(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
! formulas for the initial velocity for a plane wave (first derivative in time of the displacement)
- veloc_elastic(1,i) = A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
- + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
- + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
- veloc_elastic(2,i) = A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
- + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
- + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
+ veloc_elastic(1,i) = A_plane(1) * ricker_Bielak_veloc(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(1) * ricker_Bielak_veloc(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(1) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
+ veloc_elastic(2,i) = A_plane(2) * ricker_Bielak_veloc(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(2) * ricker_Bielak_veloc(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(2) * ricker_Bielak_veloc(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
! formulas for the initial acceleration for a plane wave (second derivative in time of the displacement)
- accel_elastic(1,i) = A_plane(1) * ricker_Bielak_accel(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
- + B_plane(1) * ricker_Bielak_accel(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
- + C_plane(1) * ricker_Bielak_accel(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
- accel_elastic(2,i) = A_plane(2) * ricker_Bielak_accel(t - sin(angleforce)*x/c_inc + cos(angleforce)*z/c_inc,f0) &
- + B_plane(2) * ricker_Bielak_accel(t - sin(angleforce)*x/c_inc - cos(angleforce)*z/c_inc,f0) &
- + C_plane(2) * ricker_Bielak_accel(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0)
+ accel_elastic(1,i) = A_plane(1) * ricker_Bielak_accel(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(1) * ricker_Bielak_accel(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(1) * ricker_Bielak_accel(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
+ accel_elastic(2,i) = A_plane(2) * ricker_Bielak_accel(t - sin(angleforce(1))*x/c_inc + cos(angleforce(1))*z/c_inc,f0(1)) &
+ + B_plane(2) * ricker_Bielak_accel(t - sin(angleforce(1))*x/c_inc - cos(angleforce(1))*z/c_inc,f0(1)) &
+ + C_plane(2) * ricker_Bielak_accel(t - sin(angleforce_refl)*x/c_refl - cos(angleforce_refl)*z/c_refl,f0(1))
enddo
else ! beyond critical angle
if (myrank == 0) then
- if (source_type/=3) write(IOUT,*) 'You are beyond the critical angle ( > ',asin(c_inc/c_refl)*180d0/pi,')'
+ if (source_type(1)/=3) write(IOUT,*) 'You are beyond the critical angle ( > ',asin(c_inc/c_refl)*180d0/pi,')'
write(IOUT,*) '*************'
write(IOUT,*) 'We have to compute the initial field in the frequency domain'
@@ -2350,8 +3491,8 @@
allocate(t0z_bot(count_bot,NSTEP))
! call Paco's routine to compute in frequency and convert to time by Fourier transform
- call paco_beyond_critical(coord,npoin,deltat,NSTEP,angleforce,&
- f0,cploc,csloc,TURN_ATTENUATION_ON,Qp_attenuation,source_type,v0x_left,v0z_left,&
+ call paco_beyond_critical(coord,npoin,deltat,NSTEP,angleforce(1),&
+ f0(1),cploc,csloc,TURN_ATTENUATION_ON,Qp_attenuation,source_type(1),v0x_left,v0z_left,&
v0x_right,v0z_right,v0x_bot,v0z_bot,t0x_left,t0z_left,t0x_right,t0z_right,&
t0x_bot,t0z_bot,left_bound(1:count_left),right_bound(1:count_right),bot_bound(1:count_bot)&
,count_left,count_right,count_bot,displ_elastic,veloc_elastic,accel_elastic)
@@ -2381,7 +3522,7 @@
! compute the source time function and store it in a text file
if(.not. initialfield) then
- allocate(source_time_function(NSTEP))
+ allocate(source_time_function(NSOURCE,NSTEP))
if (myrank == 0) then
write(IOUT,*)
@@ -2390,6 +3531,9 @@
open(unit=55,file='OUTPUT_FILES/source.txt',status='unknown')
endif
+! loop on all the sources
+ do i_source=1,NSOURCE
+
! loop on all the time steps
do it = 1,NSTEP
@@ -2397,30 +3541,36 @@
time = (it-1)*deltat
! Ricker (second derivative of a Gaussian) source time function
- if(time_function_type == 1) then
- source_time_function(it) = - factor * (ONE-TWO*aval*(time-t0)**2) * exp(-aval*(time-t0)**2)
+ if(time_function_type(i_source) == 1) then
+! source_time_function(i_source,it) = - factor(i_source) * (ONE-TWO*aval(i_source)*(time-t0(i_source))**2) * &
+! exp(-aval(i_source)*(time-t0(i_source))**2)
+ source_time_function(i_source,it) = - factor(i_source) * TWO*aval(i_source)*sqrt(aval(i_source))*&
+ (time-t0(i_source))/pi * exp(-aval(i_source)*(time-t0(i_source))**2)
! first derivative of a Gaussian source time function
- else if(time_function_type == 2) then
- source_time_function(it) = - factor * TWO*aval*(time-t0) * exp(-aval*(time-t0)**2)
+ else if(time_function_type(i_source) == 2) then
+ source_time_function(i_source,it) = - factor(i_source) * TWO*aval(i_source)*(time-t0(i_source)) * &
+ exp(-aval(i_source)*(time-t0(i_source))**2)
! Gaussian or Dirac (we use a very thin Gaussian instead) source time function
- else if(time_function_type == 3 .or. time_function_type == 4) then
- source_time_function(it) = factor * exp(-aval*(time-t0)**2)
+ else if(time_function_type(i_source) == 3 .or. time_function_type(i_source) == 4) then
+ source_time_function(i_source,it) = factor(i_source) * exp(-aval(i_source)*(time-t0(i_source))**2)
! Heaviside source time function (we use a very thin error function instead)
- else if(time_function_type == 5) then
- hdur = 1.d0 / f0
- hdur_gauss = hdur * 5.d0 / 3.d0
- source_time_function(it) = factor * 0.5d0*(1.0d0 + netlib_specfun_erf(SOURCE_DECAY_MIMIC_TRIANGLE*(time-t0)/hdur_gauss))
+ else if(time_function_type(i_source) == 5) then
+ hdur(i_source) = 1.d0 / f0(i_source)
+ hdur_gauss(i_source) = hdur(i_source) * 5.d0 / 3.d0
+ source_time_function(i_source,it) = factor(i_source) * 0.5d0*(1.0d0 + &
+ netlib_specfun_erf(SOURCE_DECAY_MIMIC_TRIANGLE*(time-t0(i_source))/hdur_gauss(i_source)))
else
call exit_MPI('unknown source time function')
endif
! output absolute time in third column, in case user wants to check it as well
- if (myrank == 0) write(55,*) sngl(time),real(source_time_function(it),4),sngl(time-t0)
+ if (myrank == 0 .and. i_source==1 ) write(55,*) sngl(time),real(source_time_function(1,it),4),sngl(time-t0(1))
enddo
+ enddo ! i_source=1,NSOURCE
if (myrank == 0) close(55)
@@ -2428,18 +3578,21 @@
! than one if the nearest point is on the interface between several partitions with an explosive source.
! since source contribution is linear, the source_time_function is cut down by that number (it would have been similar
! if we just had elected one of those processes).
- source_time_function(:) = source_time_function(:) / nb_proc_source
+ do i_source=1,NSOURCE
+ source_time_function(i_source,:) = source_time_function(i_source,:) / nb_proc_source(i_source)
+ enddo
else
- allocate(source_time_function(1))
+ allocate(source_time_function(1,1))
- endif
+ endif
! determine if coupled fluid-solid simulation
coupled_acoustic_elastic = any_acoustic .and. any_elastic
+ coupled_acoustic_poroelastic = any_acoustic .and. any_poroelastic
-! fluid/solid edge detection
+! fluid/solid (elastic) edge detection
! the two elements (fluid and solid) forming an edge are already known (computed in meshfem2D),
! the common nodes forming the edge are computed here
if(coupled_acoustic_elastic) then
@@ -2502,7 +3655,8 @@
ispec_elastic = fluid_solid_elastic_ispec(inum)
! one element must be acoustic and the other must be elastic
- if(ispec_acoustic /= ispec_elastic .and. .not. elastic(ispec_acoustic) .and. elastic(ispec_elastic)) then
+ if(ispec_acoustic /= ispec_elastic .and. .not. elastic(ispec_acoustic) .and. &
+ .not. poroelastic(ispec_acoustic) .and. elastic(ispec_elastic)) then
! loop on the four edges of the two elements
do iedge_acoustic = 1,NEDGES
@@ -2526,7 +3680,7 @@
enddo
-! make sure fluid/solid matching has been perfectly detected: check that the grid points
+! make sure fluid/solid (elastic) matching has been perfectly detected: check that the grid points
! have the same physical coordinates
! loop on all the coupling edges
@@ -2570,6 +3724,138 @@
endif
+! fluid/solid (poroelastic) edge detection
+! the two elements (fluid and solid) forming an edge are already known (computed in meshfem2D),
+! the common nodes forming the edge are computed here
+ if(coupled_acoustic_poroelastic) then
+ if ( myrank == 0 ) then
+ print *
+ print *,'Mixed acoustic/poroelastic simulation'
+ print *
+ print *,'Beginning of fluid/solid (poroelastic) edge detection'
+ endif
+
+! define the edges of a given element
+ i_begin(IBOTTOM) = 1
+ j_begin(IBOTTOM) = 1
+ i_end(IBOTTOM) = NGLLX
+ j_end(IBOTTOM) = 1
+
+ i_begin(IRIGHT) = NGLLX
+ j_begin(IRIGHT) = 1
+ i_end(IRIGHT) = NGLLX
+ j_end(IRIGHT) = NGLLZ
+
+ i_begin(ITOP) = NGLLX
+ j_begin(ITOP) = NGLLZ
+ i_end(ITOP) = 1
+ j_end(ITOP) = NGLLZ
+
+ i_begin(ILEFT) = 1
+ j_begin(ILEFT) = NGLLZ
+ i_end(ILEFT) = 1
+ j_end(ILEFT) = 1
+
+! define i and j points for each edge
+ do ipoin1D = 1,NGLLX
+
+ ivalue(ipoin1D,IBOTTOM) = ipoin1D
+ ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
+ jvalue(ipoin1D,IBOTTOM) = 1
+ jvalue_inverse(ipoin1D,IBOTTOM) = 1
+
+ ivalue(ipoin1D,IRIGHT) = NGLLX
+ ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
+ jvalue(ipoin1D,IRIGHT) = ipoin1D
+ jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
+
+ ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
+ ivalue_inverse(ipoin1D,ITOP) = ipoin1D
+ jvalue(ipoin1D,ITOP) = NGLLZ
+ jvalue_inverse(ipoin1D,ITOP) = NGLLZ
+
+ ivalue(ipoin1D,ILEFT) = 1
+ ivalue_inverse(ipoin1D,ILEFT) = 1
+ jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
+ jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
+
+ enddo
+
+ do inum = 1, num_fluid_poro_edges
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
+
+! one element must be acoustic and the other must be poroelastic
+ if(ispec_acoustic /= ispec_poroelastic .and. .not. poroelastic(ispec_acoustic) .and. &
+ .not. elastic(ispec_acoustic) .and. poroelastic(ispec_poroelastic)) then
+
+! loop on the four edges of the two elements
+ do iedge_acoustic = 1,NEDGES
+ do iedge_poroelastic = 1,NEDGES
+
+! store the matching topology if the two edges match in inverse order
+ if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_end(iedge_poroelastic),j_end(iedge_poroelastic),ispec_poroelastic) .and. &
+ ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_begin(iedge_poroelastic),j_begin(iedge_poroelastic),ispec_poroelastic)) then
+ fluid_poro_acoustic_iedge(inum) = iedge_acoustic
+ fluid_poro_poroelastic_iedge(inum) = iedge_poroelastic
+ endif
+
+ enddo
+ enddo
+
+ endif
+
+ enddo
+
+
+! make sure fluid/solid (poroelastic) matching has been perfectly detected: check that the grid points
+! have the same physical coordinates
+! loop on all the coupling edges
+
+ if ( myrank == 0 ) then
+ print *,'Checking fluid/solid (poroelastic) edge topology...'
+ endif
+
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ iedge_acoustic = fluid_poro_acoustic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = fluid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_poroelastic)
+ j = jvalue_inverse(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+! get point values for the acoustic side
+ i = ivalue(ipoin1D,iedge_acoustic)
+ j = jvalue(ipoin1D,iedge_acoustic)
+ iglob2 = ibool(i,j,ispec_acoustic)
+
+! if distance between the two points is not negligible, there is an error, since it should be zero
+ if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
+ call exit_MPI( 'error in fluid/solid (poroelastic) coupling buffer')
+
+ enddo
+
+ enddo
+
+ if ( myrank == 0 ) then
+ print *,'End of fluid/solid (poroelastic) edge detection'
+ print *
+ endif
+
+ endif
+
! exclude common points between acoustic absorbing edges and acoustic/elastic matching interfaces
if(coupled_acoustic_elastic .and. anyabs) then
@@ -2619,6 +3905,263 @@
endif
+! exclude common points between acoustic absorbing edges and acoustic/poroelastic matching interfaces
+ if(coupled_acoustic_poroelastic .and. anyabs) then
+
+ if (myrank == 0) &
+ print *,'excluding common points between acoustic absorbing edges and acoustic/poroelastic matching interfaces, if any'
+
+! loop on all the absorbing elements
+ do ispecabs = 1,nelemabs
+
+ ispec = numabs(ispecabs)
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ iedge_acoustic = fluid_poro_acoustic_iedge(inum)
+
+! if acoustic absorbing element and acoustic/poroelastic coupled element is the same
+ if(ispec_acoustic == ispec) then
+
+ if(iedge_acoustic == IBOTTOM) then
+ jbegin_left(ispecabs) = 2
+ jbegin_right(ispecabs) = 2
+ endif
+
+ if(iedge_acoustic == ITOP) then
+ jend_left(ispecabs) = NGLLZ - 1
+ jend_right(ispecabs) = NGLLZ - 1
+ endif
+
+ if(iedge_acoustic == ILEFT) then
+ ibegin_bottom(ispecabs) = 2
+ ibegin_top(ispecabs) = 2
+ endif
+
+ if(iedge_acoustic == IRIGHT) then
+ iend_bottom(ispecabs) = NGLLX - 1
+ iend_top(ispecabs) = NGLLX - 1
+ endif
+
+ endif
+
+ enddo
+
+ enddo
+
+ endif
+
+
+! determine if coupled elastic-poroelastic simulation
+ coupled_elastic_poroelastic = any_elastic .and. any_poroelastic
+
+! solid/porous edge detection
+! the two elements forming an edge are already known (computed in meshfem2D),
+! the common nodes forming the edge are computed here
+ if(coupled_elastic_poroelastic) then
+
+ if(TURN_ATTENUATION_ON .or. TURN_VISCATTENUATION_ON) &
+ stop 'Attenuation not supported for mixed elastic/poroelastic simulations'
+
+ if ( myrank == 0 ) then
+ print *
+ print *,'Mixed elastic/poroelastic simulation'
+ print *
+ print *,'Beginning of solid/porous edge detection'
+ endif
+
+! define the edges of a given element
+ i_begin(IBOTTOM) = 1
+ j_begin(IBOTTOM) = 1
+ i_end(IBOTTOM) = NGLLX
+ j_end(IBOTTOM) = 1
+
+ i_begin(IRIGHT) = NGLLX
+ j_begin(IRIGHT) = 1
+ i_end(IRIGHT) = NGLLX
+ j_end(IRIGHT) = NGLLZ
+
+ i_begin(ITOP) = NGLLX
+ j_begin(ITOP) = NGLLZ
+ i_end(ITOP) = 1
+ j_end(ITOP) = NGLLZ
+
+ i_begin(ILEFT) = 1
+ j_begin(ILEFT) = NGLLZ
+ i_end(ILEFT) = 1
+ j_end(ILEFT) = 1
+
+! define i and j points for each edge
+ do ipoin1D = 1,NGLLX
+
+ ivalue(ipoin1D,IBOTTOM) = ipoin1D
+ ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
+ jvalue(ipoin1D,IBOTTOM) = 1
+ jvalue_inverse(ipoin1D,IBOTTOM) = 1
+
+ ivalue(ipoin1D,IRIGHT) = NGLLX
+ ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
+ jvalue(ipoin1D,IRIGHT) = ipoin1D
+ jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
+
+ ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
+ ivalue_inverse(ipoin1D,ITOP) = ipoin1D
+ jvalue(ipoin1D,ITOP) = NGLLZ
+ jvalue_inverse(ipoin1D,ITOP) = NGLLZ
+
+ ivalue(ipoin1D,ILEFT) = 1
+ ivalue_inverse(ipoin1D,ILEFT) = 1
+ jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
+ jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
+
+ enddo
+
+
+ do inum = 1, num_solid_poro_edges
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+
+! one element must be elastic and the other must be poroelastic
+ if(ispec_elastic /= ispec_poroelastic .and. elastic(ispec_elastic) .and. &
+ poroelastic(ispec_poroelastic)) then
+
+! loop on the four edges of the two elements
+ do iedge_poroelastic = 1,NEDGES
+ do iedge_elastic = 1,NEDGES
+
+! store the matching topology if the two edges match in inverse order
+ if(ibool(i_begin(iedge_poroelastic),j_begin(iedge_poroelastic),ispec_poroelastic) == &
+ ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic) .and. &
+ ibool(i_end(iedge_poroelastic),j_end(iedge_poroelastic),ispec_poroelastic) == &
+ ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic)) then
+ solid_poro_elastic_iedge(inum) = iedge_elastic
+ solid_poro_poroelastic_iedge(inum) = iedge_poroelastic
+ endif
+
+ enddo
+ enddo
+
+ endif
+
+ enddo
+
+! make sure solid/porous matching has been perfectly detected: check that the grid points
+! have the same physical coordinates
+! loop on all the coupling edges
+
+ if ( myrank == 0 ) then
+ print *,'Checking solid/porous edge topology...'
+ endif
+
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the elastic element
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ iedge_elastic = solid_poro_elastic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_elastic)
+ j = jvalue_inverse(ipoin1D,iedge_elastic)
+ iglob = ibool(i,j,ispec_elastic)
+
+! get point values for the elastic side
+ i = ivalue(ipoin1D,iedge_poroelastic)
+ j = jvalue(ipoin1D,iedge_poroelastic)
+ iglob2 = ibool(i,j,ispec_poroelastic)
+
+! if distance between the two points is not negligible, there is an error, since it should be zero
+ if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
+ call exit_MPI( 'error in solid/porous coupling buffer')
+
+ enddo
+
+ enddo
+
+ if ( myrank == 0 ) then
+ print *,'End of solid/porous edge detection'
+ print *
+ endif
+
+ endif
+
+! initiation
+ if(any_poroelastic .and. anyabs) then
+! loop on all the absorbing elements
+ do ispecabs = 1,nelemabs
+ jbegin_left_poro(ispecabs) = 1
+ jbegin_right_poro(ispecabs) = 1
+
+ jend_left_poro(ispecabs) = NGLLZ
+ jend_right_poro(ispecabs) = NGLLZ
+
+ ibegin_bottom_poro(ispecabs) = 1
+ ibegin_top_poro(ispecabs) = 1
+
+ iend_bottom_poro(ispecabs) = NGLLX
+ iend_top_poro(ispecabs) = NGLLX
+ enddo
+ endif
+
+! exclude common points between poroelastic absorbing edges and elastic/poroelastic matching interfaces
+ if(coupled_elastic_poroelastic .and. anyabs) then
+
+ if (myrank == 0) &
+ print *,'excluding common points between poroelastic absorbing edges and elastic/poroelastic matching interfaces, if any'
+
+! loop on all the absorbing elements
+ do ispecabs = 1,nelemabs
+
+ ispec = numabs(ispecabs)
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the acoustic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+! if poroelastic absorbing element and elastic/poroelastic coupled element is the same
+ if(ispec_poroelastic == ispec) then
+
+ if(iedge_poroelastic == IBOTTOM) then
+ jbegin_left_poro(ispecabs) = 2
+ jbegin_right_poro(ispecabs) = 2
+ endif
+
+ if(iedge_poroelastic == ITOP) then
+ jend_left_poro(ispecabs) = NGLLZ - 1
+ jend_right_poro(ispecabs) = NGLLZ - 1
+ endif
+
+ if(iedge_poroelastic == ILEFT) then
+ ibegin_bottom_poro(ispecabs) = 2
+ ibegin_top_poro(ispecabs) = 2
+ endif
+
+ if(iedge_poroelastic == IRIGHT) then
+ iend_bottom_poro(ispecabs) = NGLLX - 1
+ iend_top_poro(ispecabs) = NGLLX - 1
+ endif
+
+ endif
+
+ enddo
+
+ enddo
+
+ endif
+
+
#ifdef USE_MPI
if(OUTPUT_ENERGY) stop 'energy calculation only currently serial only, should add an MPI_REDUCE in parallel'
#endif
@@ -2645,10 +4188,55 @@
! to display the P-velocity model in background on color images
allocate(vp_display(npoin))
do ispec = 1,nspec
+
+ if(poroelastic(ispec)) then
+!get parameters of current spectral element
+ phil = porosity(kmato(ispec))
+ tortl = tortuosity(kmato(ispec))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec))
+ kappal_s = poroelastcoef(3,1,kmato(ispec)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
+ rhol_s = density(1,kmato(ispec))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec))
+ rhol_f = density(2,kmato(ispec))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+ B_biot = H_biot - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+! Approximated velocities (no viscous dissipation)
+ afactor = rhol_bar - phil/tortl*rhol_f
+ bfactor = H_biot + phil*rhol_bar/(tortl*rhol_f)*M_biot - TWO*phil/tortl*C_biot
+ cfactor = phil/(tortl*rhol_f)*(H_biot*M_biot - C_biot*C_biot)
+ cpIsquare = (bfactor + sqrt(bfactor*bfactor - 4._CUSTOM_REAL*afactor*cfactor))/(2._CUSTOM_REAL*afactor)
+ cpIIsquare = (bfactor - sqrt(bfactor*bfactor - 4._CUSTOM_REAL*afactor*cfactor))/(2._CUSTOM_REAL*afactor)
+ cssquare = mul_fr/afactor
+
+! Approximated ratio r = amplitude "w" field/amplitude "s" field (no viscous dissipation)
+! used later for kernels calculation
+ gamma1 = H_biot - phil/tortl*C_biot
+ gamma2 = C_biot - phil/tortl*M_biot
+ gamma3 = phil/tortl*( M_biot*(afactor/rhol_f + phil/tortl) - C_biot)
+ gamma4 = phil/tortl*( C_biot*(afactor/rhol_f + phil/tortl) - H_biot)
+ ratio = HALF*(gamma1 - gamma3)/gamma4 + HALF*sqrt((gamma1-gamma3)**2/gamma4**2 + 4._CUSTOM_REAL * gamma2/gamma4)
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ vp_display(ibool(i,j,ispec)) = sqrt(cpIsquare)
+ enddo
+ enddo
+
+ else
! get relaxed elastic parameters of current spectral element
- rhol = density(kmato(ispec))
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
+ rhol = density(1,kmato(ispec))
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec))
do j = 1,NGLLZ
do i = 1,NGLLX
!--- if external medium, get elastic parameters of current grid point
@@ -2659,6 +4247,7 @@
endif
enddo
enddo
+ endif !if(poroelastic(ispec)) then
enddo
! getting velocity for each local pixels
@@ -2723,6 +4312,33 @@
seismo_offset = 0
seismo_current = 0
+! Precompute Runge Kutta coefficients if viscous attenuation
+ if(TURN_VISCATTENUATION_ON) then
+ theta_e = (sqrt(Q0**2+1.d0) +1.d0)/(2.d0*pi*freq0*Q0)
+ theta_s = (sqrt(Q0**2+1.d0) -1.d0)/(2.d0*pi*freq0*Q0)
+
+ thetainv = - 1.d0 / theta_s
+ alphaval = 1.d0 + deltat*thetainv + deltat**2*thetainv**2 / 2.d0 + &
+ deltat**3*thetainv**3 / 6.d0 + deltat**4*thetainv**4 / 24.d0
+ betaval = deltat / 2.d0 + deltat**2*thetainv / 3.d0 + deltat**3*thetainv**2 / 8.d0 + deltat**4*thetainv**3 / 24.d0
+ gammaval = deltat / 2.d0 + deltat**2*thetainv / 6.d0 + deltat**3*thetainv**2 / 24.d0
+ print*,'************************************************************'
+ print*,'****** Visco attenuation coefficients (poroelastic) ********'
+ print*,'theta_e = ', theta_e
+ print*,'theta_s = ', theta_s
+ print*,'alpha = ', alphaval
+ print*,'beta = ', betaval
+ print*,'gamma = ', gammaval
+ print*,'************************************************************'
+
+! initialize memory variables for attenuation
+ viscox(:,:,:) = 0.d0
+ viscoz(:,:,:) = 0.d0
+ rx_viscous(:,:,:) = 0.d0
+ rz_viscous(:,:,:) = 0.d0
+
+ endif
+
! allocate arrays for postscript output
#ifdef USE_MPI
if(modelvect) then
@@ -2873,33 +4489,181 @@
displ_elastic = displ_elastic + deltat*veloc_elastic + deltatsquareover2*accel_elastic
veloc_elastic = veloc_elastic + deltatover2*accel_elastic
accel_elastic = ZERO
+
+ if(isolver == 2) then ! Adjoint calculation
+ b_displ_elastic = b_displ_elastic + b_deltat*b_veloc_elastic + b_deltatsquareover2*b_accel_elastic
+ b_veloc_elastic = b_veloc_elastic + b_deltatover2*b_accel_elastic
+ b_accel_elastic = ZERO
+ endif
endif
+ if(any_poroelastic) then
+!for the solid
+ displs_poroelastic = displs_poroelastic + deltat*velocs_poroelastic + deltatsquareover2*accels_poroelastic
+ velocs_poroelastic = velocs_poroelastic + deltatover2*accels_poroelastic
+ accels_poroelastic = ZERO
+!for the fluid
+ displw_poroelastic = displw_poroelastic + deltat*velocw_poroelastic + deltatsquareover2*accelw_poroelastic
+ velocw_poroelastic = velocw_poroelastic + deltatover2*accelw_poroelastic
+ accelw_poroelastic = ZERO
+
+ if(isolver == 2) then ! Adjoint calculation
+!for the solid
+ b_displs_poroelastic = b_displs_poroelastic + b_deltat*b_velocs_poroelastic + b_deltatsquareover2*b_accels_poroelastic
+ b_velocs_poroelastic = b_velocs_poroelastic + b_deltatover2*b_accels_poroelastic
+ b_accels_poroelastic = ZERO
+!for the fluid
+ b_displw_poroelastic = b_displw_poroelastic + b_deltat*b_velocw_poroelastic + b_deltatsquareover2*b_accelw_poroelastic
+ b_velocw_poroelastic = b_velocw_poroelastic + b_deltatover2*b_accelw_poroelastic
+ b_accelw_poroelastic = ZERO
+ endif
+ endif
+
+!--------------------------------------------------------------------------------------------
+! implement viscous attenuation for poroelastic media
+!
+ if(TURN_VISCATTENUATION_ON .and. any_poroelastic) then
+! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
+! loop over spectral elements
+
+ do ispec = 1,nspec
+
+ etal_f = poroelastcoef(2,2,kmato(ispec))
+ permlxx = permeability(1,kmato(ispec))
+ permlxz = permeability(2,kmato(ispec))
+ permlzz = permeability(3,kmato(ispec))
+
+ ! calcul of the inverse of k
+
+ detk = permlxx*permlzz - permlxz*permlxz
+
+ if(detk /= ZERO) then
+ invpermlxx = permlzz/detk
+ invpermlxz = -permlxz/detk
+ invpermlzz = permlxx/detk
+ else
+ stop 'Permeability matrix is not inversible'
+ endif
+
+! relaxed viscous coef
+ bl_relaxed(1) = etal_f*invpermlxx
+ bl_relaxed(2) = etal_f*invpermlxz
+ bl_relaxed(3) = etal_f*invpermlzz
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+ viscox_loc(i,j) = velocw_poroelastic(1,iglob)*bl_relaxed(1) + &
+ velocw_poroelastic(2,iglob)*bl_relaxed(2)
+ viscoz_loc(i,j) = velocw_poroelastic(1,iglob)*bl_relaxed(2) + &
+ velocw_poroelastic(2,iglob)*bl_relaxed(3)
+
+! evolution rx_viscous
+ Sn = - (1.d0 - theta_e/theta_s)/theta_s*viscox(i,j,ispec)
+ Snp1 = - (1.d0 - theta_e/theta_s)/theta_s*viscox_loc(i,j)
+ rx_viscous(i,j,ispec) = alphaval * rx_viscous(i,j,ispec) + betaval * Sn + gammaval * Snp1
+
+! evolution rz_viscous
+ Sn = - (1.d0 - theta_e/theta_s)/theta_s*viscoz(i,j,ispec)
+ Snp1 = - (1.d0 - theta_e/theta_s)/theta_s*viscoz_loc(i,j)
+ rz_viscous(i,j,ispec) = alphaval * rz_viscous(i,j,ispec) + betaval * Sn + gammaval * Snp1
+
+
+ enddo
+ enddo
+
+! save visco for Runge-Kutta scheme
+ viscox(:,:,ispec) = viscox_loc(:,:)
+ viscoz(:,:,ispec) = viscoz_loc(:,:)
+
+ enddo ! end of spectral element loop
+ endif ! end of viscous attenuation for porous media
+
+!-----------------------------------------
+
if(any_acoustic) then
potential_acoustic = potential_acoustic + deltat*potential_dot_acoustic + deltatsquareover2*potential_dot_dot_acoustic
potential_dot_acoustic = potential_dot_acoustic + deltatover2*potential_dot_dot_acoustic
potential_dot_dot_acoustic = ZERO
+ if(isolver == 2) then ! Adjoint calculation
+ b_potential_acoustic = b_potential_acoustic + b_deltat*b_potential_dot_acoustic + &
+ b_deltatsquareover2*b_potential_dot_dot_acoustic
+ b_potential_dot_acoustic = b_potential_dot_acoustic + b_deltatover2*b_potential_dot_dot_acoustic
+ b_potential_dot_dot_acoustic = ZERO
+ endif
+
! free surface for an acoustic medium
if ( nelem_acoustic_surface > 0 ) then
call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
potential_acoustic,acoustic_surface,ibool,nelem_acoustic_surface,npoin,nspec)
+
+ if(isolver == 2) then ! Adjoint calculation
+ call enforce_acoustic_free_surface(b_potential_dot_dot_acoustic,b_potential_dot_acoustic, &
+ b_potential_acoustic,acoustic_surface,ibool,nelem_acoustic_surface,npoin,nspec)
+ endif
endif
! *********************************************************
! ************* compute forces for the acoustic elements
! *********************************************************
- call compute_forces_acoustic(npoin,nspec,nelemabs,numat, &
+ call compute_forces_acoustic(npoin,nspec,nelemabs,numat,it,NSTEP, &
anyabs,assign_external_model,ibool,kmato,numabs, &
- elastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic,density,elastcoef,xix,xiz,gammax,gammaz,jacobian, &
+ elastic,poroelastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,b_potential_dot_dot_acoustic,b_potential_acoustic, &
+ density,poroelastcoef,xix,xiz,gammax,gammaz,jacobian, &
vpext,rhoext,hprime_xx,hprimewgll_xx, &
hprime_zz,hprimewgll_zz,wxgll,wzgll, &
ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
- jbegin_left,jend_left,jbegin_right,jend_right)
+ jbegin_left,jend_left,jbegin_right,jend_right,isolver,save_forward,b_absorb_acoustic_left,&
+ b_absorb_acoustic_right,b_absorb_acoustic_bottom,&
+ b_absorb_acoustic_top,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax,kappa_ac_k)
+ if(anyabs .and. save_forward .and. isolver == 1) then
+
+!--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do i=1,NGLLZ
+ write(65) b_absorb_acoustic_left(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+!--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do i=1,NGLLZ
+ write(66) b_absorb_acoustic_right(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+!--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do i=1,NGLLX
+ write(67) b_absorb_acoustic_bottom(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+!--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do i=1,NGLLX
+ write(68) b_absorb_acoustic_top(i,ispec,it)
+ enddo
+ enddo
+ endif
+
+ endif ! if(anyabs .and. save_forward .and. isolver == 1)
+
endif ! end of test if any acoustic element
! *********************************************************
@@ -2930,6 +4694,11 @@
displ_x = displ_elastic(1,iglob)
displ_z = displ_elastic(2,iglob)
+ if(isolver == 2) then
+ b_displ_x = b_displ_elastic(1,iglob)
+ b_displ_z = b_displ_elastic(2,iglob)
+ endif
+
! get point values for the acoustic side
i = ivalue(ipoin1D,iedge_acoustic)
j = jvalue(ipoin1D,iedge_acoustic)
@@ -2940,18 +4709,34 @@
! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
! Blackwell Science, page 110, equation (4.60).
- if(iedge_acoustic == IBOTTOM .or. iedge_acoustic == ITOP) then
+ if(iedge_acoustic == ITOP)then
xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic == IBOTTOM)then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
nx = + zxi / jacobian1D
nz = - xxi / jacobian1D
- else
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic ==ILEFT)then
xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_acoustic ==IRIGHT)then
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
nx = + zgamma / jacobian1D
nz = - xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
endif
! compute dot product
@@ -2962,12 +4747,115 @@
potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*displ_n
+ if(isolver == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) +&
+ weight*(b_displ_x*nx + b_displ_z*nz)
+ endif !if(isolver == 2) then
+
enddo
enddo
endif
+! *********************************************************
+! ************* add coupling with the poroelastic side
+! *********************************************************
+
+ if(coupled_acoustic_poroelastic) then
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ iedge_acoustic = fluid_poro_acoustic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = fluid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_poroelastic)
+ j = jvalue_inverse(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+ displ_x = displs_poroelastic(1,iglob)
+ displ_z = displs_poroelastic(2,iglob)
+
+ phil = porosity(kmato(ispec_poroelastic))
+ displw_x = displw_poroelastic(1,iglob)
+ displw_z = displw_poroelastic(2,iglob)
+
+ if(isolver == 2) then
+ b_displ_x = b_displs_poroelastic(1,iglob)
+ b_displ_z = b_displs_poroelastic(2,iglob)
+
+ b_displw_x = b_displw_poroelastic(1,iglob)
+ b_displw_z = b_displw_poroelastic(2,iglob)
+ endif
+
+! get point values for the acoustic side
+! get point values for the acoustic side
+ i = ivalue(ipoin1D,iedge_acoustic)
+ j = jvalue(ipoin1D,iedge_acoustic)
+ iglob = ibool(i,j,ispec_acoustic)
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+ if(iedge_acoustic == ITOP)then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic == IBOTTOM)then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic ==ILEFT)then
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_acoustic ==IRIGHT)then
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ endif
+
+! compute dot product [u_s + w]*n
+ displ_n = (displ_x + displw_x)*nx + (displ_z + displw_z)*nz
+
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*displ_n
+
+ if(isolver == 2) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) +&
+ weight*((b_displ_x + b_displw_x)*nx + (b_displ_z + b_displw_z)*nz)
+ endif !if(isolver == 2) then
+
+ enddo
+
+ enddo
+
+ endif
+
+
! assembling potential_dot_dot for acoustic elements
#ifdef USE_MPI
if ( nproc > 1 .and. any_acoustic .and. ninterface_acoustic > 0) then
@@ -2978,6 +4866,15 @@
tab_requests_send_recv_acoustic,buffer_send_faces_vector_ac, &
buffer_recv_faces_vector_ac, my_neighbours)
endif
+
+ if ( nproc > 1 .and. any_acoustic .and. ninterface_acoustic > 0 .and. isolver == 2) then
+ call assemble_MPI_vector_ac(b_potential_dot_dot_acoustic,npoin, &
+ ninterface, ninterface_acoustic,inum_interfaces_acoustic, &
+ max_interface_size, max_ibool_interfaces_size_ac,&
+ ibool_interfaces_acoustic, nibool_interfaces_acoustic, &
+ tab_requests_send_recv_acoustic,buffer_send_faces_vector_ac, &
+ buffer_recv_faces_vector_ac, my_neighbours)
+ endif
#endif
@@ -2989,20 +4886,49 @@
! --- add the source
if(.not. initialfield) then
+
+ do i_source=1,NSOURCE
! if this processor carries the source and the source element is acoustic
- if (is_proc_source == 1 .and. .not. elastic(ispec_selected_source)) then
+ if (is_proc_source(i_source) == 1 .and. .not. elastic(ispec_selected_source(i_source)) .and. &
+ .not. poroelastic(ispec_selected_source(i_source))) then
! collocated force
! beware, for acoustic medium, source is: pressure divided by Kappa of the fluid
! the sign is negative because pressure p = - Chi_dot_dot therefore we need
! to add minus the source to Chi_dot_dot to get plus the source in pressure
- if(source_type == 1) then
- potential_dot_dot_acoustic(iglob_source) = potential_dot_dot_acoustic(iglob_source) - source_time_function(it)
-
+ if(source_type(i_source) == 1) then
+ if(isolver == 1) then ! forward wavefield
+ potential_dot_dot_acoustic(iglob_source(i_source)) = potential_dot_dot_acoustic(iglob_source(i_source)) &
+ - source_time_function(i_source,it)
+ else ! backward wavefield
+ b_potential_dot_dot_acoustic(iglob_source(i_source)) = b_potential_dot_dot_acoustic(iglob_source(i_source)) &
+ - source_time_function(i_source,NSTEP-it+1)
+ endif
! moment tensor
- else if(source_type == 2) then
+ else if(source_type(i_source) == 2) then
call exit_MPI('cannot have moment tensor source in acoustic element')
endif
endif ! if this processor carries the source and the source element is acoustic
+ enddo ! do i_source=1,NSOURCE
+
+ if(isolver == 2) then ! adjoint wavefield
+ irec_local = 0
+ do irec = 1,nrec
+! add the source (only if this proc carries the source)
+ if (myrank == which_proc_receiver(irec) .and. .not. elastic(ispec_selected_rec(irec)) .and. &
+ .not. poroelastic(ispec_selected_rec(irec))) then
+ irec_local = irec_local + 1
+! add source array
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec_selected_rec(irec))
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - &
+ adj_sourcearrays(irec_local,NSTEP-it+1,1,i,j)
+ enddo
+ enddo
+ endif ! if this processor carries the adjoint source
+ enddo ! irec = 1,nrec
+ endif ! isolver == 2 adjoint wavefield
+
endif ! if not using an initial field
potential_dot_dot_acoustic = potential_dot_dot_acoustic * rmass_inverse_acoustic
@@ -3012,29 +4938,175 @@
if ( nelem_acoustic_surface > 0 ) then
call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
potential_acoustic,acoustic_surface,ibool,nelem_acoustic_surface,npoin,nspec)
+
+ if(isolver == 2) then
+ call enforce_acoustic_free_surface(b_potential_dot_dot_acoustic,b_potential_dot_acoustic, &
+ b_potential_acoustic,acoustic_surface,ibool,nelem_acoustic_surface,npoin,nspec)
+ endif
+
endif
endif
+ if(any_acoustic .and. isolver == 2) then ! kernels calculation
+ do iglob = 1,npoin
+ rho_ac_k(iglob) = potential_dot_dot_acoustic(iglob)*b_potential_acoustic(iglob)
+ enddo
+ endif
+
+
+! ****************************************************************************************
+! If coupling elastic/poroelastic domain, average some arrays at the interface first
+! ****************************************************************************************
+ if(coupled_elastic_poroelastic) then
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the elastic element
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ iedge_elastic = solid_poro_elastic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+ phil = porosity(kmato(ispec_poroelastic))
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue(ipoin1D,iedge_poroelastic)
+ j = jvalue(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+! get point values for the elastic side
+ ii2 = ivalue_inverse(ipoin1D,iedge_elastic)
+ jj2 = jvalue_inverse(ipoin1D,iedge_elastic)
+ iglob2 = ibool(ii2,jj2,ispec_elastic)
+
+ if(iglob /= iglob2) &
+ call exit_MPI( 'error in solid/porous iglob detection')
+
+ displ(1,iglob)=(displs_poroelastic(1,iglob) &
+ +displ_elastic(1,iglob2))/2.d0
+ displ(2,iglob)=(displs_poroelastic(2,iglob) &
+ +displ_elastic(2,iglob2))/2.d0
+
+ veloc(1,iglob)=(velocs_poroelastic(1,iglob) &
+ +veloc_elastic(1,iglob2))/2.d0
+ veloc(2,iglob)=(velocs_poroelastic(2,iglob) &
+ +veloc_elastic(2,iglob2))/2.d0
+
+ enddo
+ enddo
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+! imnplement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue(ipoin1D,iedge_poroelastic)
+ j = jvalue(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+ displs_poroelastic(1,iglob)=displ(1,iglob)
+ displs_poroelastic(2,iglob)=displ(2,iglob)
+
+ displ_elastic(1,iglob)=displ(1,iglob)
+ displ_elastic(2,iglob)=displ(2,iglob)
+
+ velocs_poroelastic(1,iglob)=veloc(1,iglob)
+ velocs_poroelastic(2,iglob)=veloc(2,iglob)
+
+ veloc_elastic(1,iglob)=veloc(1,iglob)
+ veloc_elastic(2,iglob)=veloc(2,iglob)
+
+ displw_poroelastic(1,iglob)=ZERO
+ displw_poroelastic(2,iglob)=ZERO
+
+ velocw_poroelastic(1,iglob)=ZERO
+ velocw_poroelastic(2,iglob)=ZERO
+ enddo
+ enddo
+
+ endif
+
! *********************************************************
! ************* main solver for the elastic elements
! *********************************************************
- if(any_elastic) &
- call compute_forces_elastic(npoin,nspec,nelemabs,numat, &
- ispec_selected_source,is_proc_source,source_type,it,NSTEP,anyabs,assign_external_model, &
+ if(any_elastic) then
+ call compute_forces_elastic(npoin,nspec,myrank,nelemabs,numat, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver, &
+ source_type,it,NSTEP,anyabs,assign_external_model, &
initialfield,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,angleforce,deltatcube, &
deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,elastic,codeabs, &
- accel_elastic,veloc_elastic,displ_elastic,density,elastcoef,xix,xiz,gammax,gammaz, &
- jacobian,vpext,vsext,rhoext,source_time_function,sourcearray, &
+ accel_elastic,veloc_elastic,displ_elastic,b_accel_elastic,b_displ_elastic, &
+ density,poroelastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,vpext,vsext,rhoext,source_time_function,sourcearray,adj_sourcearrays, &
e1,e11,e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu1,phi_nu1,inv_tau_sigma_nu2,phi_nu2,Mu_nu1,Mu_nu2,N_SLS, &
deltat,coord,add_Bielak_conditions, x0_source, z0_source, &
- A_plane, B_plane, C_plane, angleforce_refl, c_inc, c_refl, time_offset, f0,&
+ A_plane, B_plane, C_plane, angleforce_refl, c_inc, c_refl, time_offset, f0(1),&
v0x_left(1,it),v0z_left(1,it),v0x_right(1,it),v0z_right(1,it),v0x_bot(1,it),v0z_bot(1,it), &
t0x_left(1,it),t0z_left(1,it),t0x_right(1,it),t0z_right(1,it),t0x_bot(1,it),t0z_bot(1,it), &
- count_left,count_right,count_bot,over_critical_angle)
+ count_left,count_right,count_bot,over_critical_angle,NSOURCE,nrec,isolver,save_forward,b_absorb_elastic_left,&
+ b_absorb_elastic_right,b_absorb_elastic_bottom,b_absorb_elastic_top,nspec_xmin,nspec_xmax,&
+ nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax,mu_k,kappa_k)
+ if(anyabs .and. save_forward .and. isolver == 1) then
+!--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do id =1,2
+ do i=1,NGLLZ
+ write(35) b_absorb_elastic_left(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do id =1,2
+ do i=1,NGLLZ
+ write(36) b_absorb_elastic_right(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do id =1,2
+ do i=1,NGLLX
+ write(37) b_absorb_elastic_bottom(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do id =1,2
+ do i=1,NGLLX
+ write(38) b_absorb_elastic_top(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+ endif ! if(anyabs .and. save_forward .and. isolver == 1)
+
+ endif !if(any_elastic)
+
! *********************************************************
! ************* add coupling with the acoustic side
! *********************************************************
@@ -3062,43 +5134,267 @@
! compute pressure on the fluid/solid edge
pressure = - potential_dot_dot_acoustic(iglob)
-
+ if(isolver == 2) then
+ b_pressure = - b_potential_dot_dot_acoustic(iglob)
+ endif
! get point values for the elastic side
- i = ivalue(ipoin1D,iedge_elastic)
- j = jvalue(ipoin1D,iedge_elastic)
- iglob = ibool(i,j,ispec_elastic)
+ ii2 = ivalue(ipoin1D,iedge_elastic)
+ jj2 = jvalue(ipoin1D,iedge_elastic)
+ iglob = ibool(ii2,jj2,ispec_elastic)
! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
! Blackwell Science, page 110, equation (4.60).
- if(iedge_acoustic == IBOTTOM .or. iedge_acoustic == ITOP) then
+ if(iedge_acoustic == ITOP)then
xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic == IBOTTOM)then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
nx = + zxi / jacobian1D
nz = - xxi / jacobian1D
- else
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic ==ILEFT)then
xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_acoustic ==IRIGHT)then
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
nx = + zgamma / jacobian1D
nz = - xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
endif
-! formulation with generalized potential
- weight = jacobian1D * wxgll(i)
-
accel_elastic(1,iglob) = accel_elastic(1,iglob) + weight*nx*pressure
accel_elastic(2,iglob) = accel_elastic(2,iglob) + weight*nz*pressure
+ if(isolver == 2) then
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) + weight*nx*b_pressure
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) + weight*nz*b_pressure
+ endif !if(isolver == 2) then
+
enddo
enddo
endif
+! ****************************************************************************
+! ************* add coupling with the poroelastic side
+! ****************************************************************************
+ if(coupled_elastic_poroelastic) then
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the elastic element
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ iedge_elastic = solid_poro_elastic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the poroelastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_poroelastic)
+ j = jvalue_inverse(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+! get poroelastic domain paramters
+ phil = porosity(kmato(ispec_poroelastic))
+ tortl = tortuosity(kmato(ispec_poroelastic))
+!solid properties
+ mul_s = poroelastcoef(2,1,kmato(ispec_poroelastic))
+ kappal_s = poroelastcoef(3,1,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_s/3._CUSTOM_REAL
+ rhol_s = density(1,kmato(ispec_poroelastic))
+!fluid properties
+ kappal_f = poroelastcoef(1,2,kmato(ispec_poroelastic))
+ rhol_f = density(2,kmato(ispec_poroelastic))
+!frame properties
+ mul_fr = poroelastcoef(2,3,kmato(ispec_poroelastic))
+ kappal_fr = poroelastcoef(3,3,kmato(ispec_poroelastic)) - 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+!Biot coefficients for the input phi
+ D_biot = kappal_s*(1._CUSTOM_REAL + phil*(kappal_s/kappal_f - 1._CUSTOM_REAL))
+ H_biot = (kappal_s - kappal_fr)*(kappal_s - kappal_fr)/(D_biot - kappal_fr) + &
+ kappal_fr + 4._CUSTOM_REAL*mul_fr/3._CUSTOM_REAL
+ C_biot = kappal_s*(kappal_s - kappal_fr)/(D_biot - kappal_fr)
+ M_biot = kappal_s*kappal_s/(D_biot - kappal_fr)
+ mul_G = mul_fr
+ lambdal_G = H_biot - 2._CUSTOM_REAL*mul_fr
+ lambdalplus2mul_G = lambdal_G + TWO*mul_G
+
+! derivative along x and along z for u_s and w
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ dwx_dxi = ZERO
+ dwz_dxi = ZERO
+
+ dwx_dgamma = ZERO
+ dwz_dgamma = ZERO
+
+ if(isolver == 2) then
+ b_dux_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duz_dgamma = ZERO
+
+ b_dwx_dxi = ZERO
+ b_dwz_dxi = ZERO
+
+ b_dwx_dgamma = ZERO
+ b_dwz_dgamma = ZERO
+ endif
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+
+ dwx_dxi = dwx_dxi + displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dwz_dxi = dwz_dxi + displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ dwx_dgamma = dwx_dgamma + displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ dwz_dgamma = dwz_dgamma + displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ if(isolver == 2) then
+ b_dux_dxi = b_dux_dxi + b_displs_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_duz_dxi = b_duz_dxi + b_displs_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_dux_dgamma = b_dux_dgamma + b_displs_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ b_duz_dgamma = b_duz_dgamma + b_displs_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+
+ b_dwx_dxi = b_dwx_dxi + b_displw_poroelastic(1,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_dwz_dxi = b_dwz_dxi + b_displw_poroelastic(2,ibool(k,j,ispec_poroelastic))*hprime_xx(i,k)
+ b_dwx_dgamma = b_dwx_dgamma + b_displw_poroelastic(1,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ b_dwz_dgamma = b_dwz_dgamma + b_displw_poroelastic(2,ibool(i,k,ispec_poroelastic))*hprime_zz(j,k)
+ endif
+ enddo
+
+ xixl = xix(i,j,ispec_poroelastic)
+ xizl = xiz(i,j,ispec_poroelastic)
+ gammaxl = gammax(i,j,ispec_poroelastic)
+ gammazl = gammaz(i,j,ispec_poroelastic)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ dwx_dxl = dwx_dxi*xixl + dwx_dgamma*gammaxl
+ dwx_dzl = dwx_dxi*xizl + dwx_dgamma*gammazl
+
+ dwz_dxl = dwz_dxi*xixl + dwz_dgamma*gammaxl
+ dwz_dzl = dwz_dxi*xizl + dwz_dgamma*gammazl
+
+ if(isolver == 2) then
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+
+ b_dwx_dxl = b_dwx_dxi*xixl + b_dwx_dgamma*gammaxl
+ b_dwx_dzl = b_dwx_dxi*xizl + b_dwx_dgamma*gammazl
+
+ b_dwz_dxl = b_dwz_dxi*xixl + b_dwz_dgamma*gammaxl
+ b_dwz_dzl = b_dwz_dxi*xizl + b_dwz_dgamma*gammazl
+ endif
+! compute stress tensor (include attenuation or anisotropy if needed)
+
+! no attenuation
+ sigma_xx = lambdalplus2mul_G*dux_dxl + lambdal_G*duz_dzl + C_biot*(dwx_dxl + dwz_dzl)
+ sigma_xz = mul_G*(duz_dxl + dux_dzl)
+ sigma_zz = lambdalplus2mul_G*duz_dzl + lambdal_G*dux_dxl + C_biot*(dwx_dxl + dwz_dzl)
+
+ if(isolver == 2) then
+ b_sigma_xx = lambdalplus2mul_G*b_dux_dxl + lambdal_G*b_duz_dzl + C_biot*(b_dwx_dxl + b_dwz_dzl)
+ b_sigma_xz = mul_G*(b_duz_dxl + b_dux_dzl)
+ b_sigma_zz = lambdalplus2mul_G*b_duz_dzl + lambdal_G*b_dux_dxl + C_biot*(b_dwx_dxl + b_dwz_dzl)
+ endif
+! get point values for the elastic domain, which matches our side in the inverse direction
+ ii2 = ivalue(ipoin1D,iedge_elastic)
+ jj2 = jvalue(ipoin1D,iedge_elastic)
+ iglob = ibool(ii2,jj2,ispec_elastic)
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+ if(iedge_poroelastic == ITOP)then
+ xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_poroelastic == IBOTTOM)then
+ xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_poroelastic ==ILEFT)then
+ xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_poroelastic ==IRIGHT)then
+ xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ endif
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - weight* &
+ (sigma_xx*nx + sigma_xz*nz)
+
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) - weight* &
+ (sigma_xz*nx + sigma_zz*nz)
+
+ if(isolver == 2) then
+ b_accel_elastic(1,iglob) = b_accel_elastic(1,iglob) - weight*( &
+ b_sigma_xx*nx + b_sigma_xz*nz)
+
+ b_accel_elastic(2,iglob) = b_accel_elastic(2,iglob) - weight*( &
+ b_sigma_xz*nx + b_sigma_zz*nz)
+ endif !if(isolver == 2) then
+
+ enddo
+
+ enddo
+
+ endif
+
+
! assembling accel_elastic for elastic elements
#ifdef USE_MPI
if (nproc > 1 .and. any_elastic .and. ninterface_elastic > 0) then
@@ -3109,6 +5405,15 @@
tab_requests_send_recv_elastic,buffer_send_faces_vector_el, &
buffer_recv_faces_vector_el, my_neighbours)
endif
+
+ if (nproc > 1 .and. any_elastic .and. ninterface_elastic > 0 .and. isolver == 2) then
+ call assemble_MPI_vector_el(b_accel_elastic,npoin, &
+ ninterface, ninterface_elastic,inum_interfaces_elastic, &
+ max_interface_size, max_ibool_interfaces_size_el,&
+ ibool_interfaces_elastic, nibool_interfaces_elastic, &
+ tab_requests_send_recv_elastic,buffer_send_faces_vector_el, &
+ buffer_recv_faces_vector_el, my_neighbours)
+ endif
#endif
@@ -3121,16 +5426,27 @@
! --- add the source if it is a collocated force
if(.not. initialfield) then
+ do i_source=1,NSOURCE
! if this processor carries the source and the source element is elastic
- if (is_proc_source == 1 .and. elastic(ispec_selected_source)) then
+ if (is_proc_source(i_source) == 1 .and. elastic(ispec_selected_source(i_source))) then
! collocated force
- if(source_type == 1) then
- accel_elastic(1,iglob_source) = accel_elastic(1,iglob_source) - sin(angleforce)*source_time_function(it)
- accel_elastic(2,iglob_source) = accel_elastic(2,iglob_source) + cos(angleforce)*source_time_function(it)
+ if(source_type(i_source) == 1) then
+ if(isolver == 1) then ! forward wavefield
+ accel_elastic(1,iglob_source(i_source)) = accel_elastic(1,iglob_source(i_source)) &
+ - sin(angleforce(i_source))*source_time_function(i_source,it)
+ accel_elastic(2,iglob_source(i_source)) = accel_elastic(2,iglob_source(i_source)) &
+ + cos(angleforce(i_source))*source_time_function(i_source,it)
+ else ! backward wavefield
+ b_accel_elastic(1,iglob_source(i_source)) = b_accel_elastic(1,iglob_source(i_source)) &
+ - sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+ b_accel_elastic(2,iglob_source(i_source)) = b_accel_elastic(2,iglob_source(i_source)) &
+ + cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+ endif !endif isolver == 1
endif
endif ! if this processor carries the source and the source element is elastic
+ enddo ! do i_source=1,NSOURCE
endif ! if not using an initial field
@@ -3139,13 +5455,548 @@
veloc_elastic = veloc_elastic + deltatover2*accel_elastic
+ if(isolver == 2) then
+ b_accel_elastic(1,:) = b_accel_elastic(1,:) * rmass_inverse_elastic(:)
+ b_accel_elastic(2,:) = b_accel_elastic(2,:) * rmass_inverse_elastic(:)
+
+ b_veloc_elastic = b_veloc_elastic + b_deltatover2*b_accel_elastic
+ endif
+
endif
+ if(any_elastic .and. isolver == 2) then ! kernels calculation
+ do iglob = 1,npoin
+ rho_k(iglob) = accel_elastic(1,iglob)*b_displ_elastic(1,iglob) +&
+ accel_elastic(2,iglob)*b_displ_elastic(2,iglob)
+ enddo
+ endif
+
+! ******************************************************************************************************************
+! ************* main solver for the poroelastic elements: first the solid (u_s) than the fluid (w)
+! ******************************************************************************************************************
+
+ if(any_poroelastic) then
+
+ if(isolver == 2) then
+! if inviscid fluid, comment the reading and uncomment the zeroing
+! read(23,rec=NSTEP-it+1) b_viscodampx
+! read(24,rec=NSTEP-it+1) b_viscodampz
+ b_viscodampx(:) = ZERO
+ b_viscodampz(:) = ZERO
+ endif
+
+ call compute_forces_solid(npoin,nspec,myrank,nelemabs,numat,iglob_source, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs, &
+ initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,angleforce,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
+ accels_poroelastic,velocs_poroelastic,velocw_poroelastic,displs_poroelastic,displw_poroelastic,&
+ b_accels_poroelastic,b_displs_poroelastic,b_velocw_poroelastic,b_displw_poroelastic,&
+ density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,source_time_function,sourcearray,adj_sourcearrays,e11, &
+ e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
+ dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu2,&
+ phi_nu2,Mu_nu2,N_SLS, &
+ rx_viscous,rz_viscous,theta_e,theta_s,&
+ b_viscodampx,b_viscodampz,&
+ ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro, &
+ jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
+ mufr_k,B_k,NSOURCE,nrec,isolver,save_forward,&
+ b_absorb_poro_s_left,b_absorb_poro_s_right,b_absorb_poro_s_bottom,b_absorb_poro_s_top,&
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax)
+
+
+
+ call compute_forces_fluid(npoin,nspec,myrank,nelemabs,numat,iglob_source, &
+ ispec_selected_source,ispec_selected_rec,is_proc_source,which_proc_receiver,&
+ source_type,it,NSTEP,anyabs, &
+ initialfield,TURN_ATTENUATION_ON,TURN_VISCATTENUATION_ON,angleforce,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,poroelastic,codeabs, &
+ accelw_poroelastic,velocw_poroelastic,displw_poroelastic,velocs_poroelastic,displs_poroelastic,&
+ b_accelw_poroelastic,b_velocw_poroelastic,b_displw_poroelastic,b_displs_poroelastic,&
+ density,porosity,tortuosity,permeability,poroelastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,source_time_function,sourcearray,adj_sourcearrays,e11, &
+ e13,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
+ dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll,inv_tau_sigma_nu2,&
+ phi_nu2,Mu_nu2,N_SLS, &
+ rx_viscous,rz_viscous,theta_e,theta_s,&
+ b_viscodampx,b_viscodampz,&
+ ibegin_bottom_poro,iend_bottom_poro,ibegin_top_poro,iend_top_poro, &
+ jbegin_left_poro,jend_left_poro,jbegin_right_poro,jend_right_poro,&
+ C_k,M_k,NSOURCE,nrec,isolver,save_forward,&
+ b_absorb_poro_w_left,b_absorb_poro_w_right,b_absorb_poro_w_bottom,b_absorb_poro_w_top,&
+ nspec_xmin,nspec_xmax,nspec_zmin,nspec_zmax,ib_xmin,ib_xmax,ib_zmin,ib_zmax)
+
+
+ if(save_forward .and. isolver == 1) then
+! if inviscid fluid, comment
+! write(23,rec=it) b_viscodampx
+! write(24,rec=it) b_viscodampz
+ endif
+
+ if(anyabs .and. save_forward .and. isolver == 1) then
+
+!--- left absorbing boundary
+ if(nspec_xmin >0) then
+ do ispec = 1,nspec_xmin
+ do id =1,2
+ do i=1,NGLLZ
+ write(45) b_absorb_poro_s_left(id,i,ispec,it)
+ write(25) b_absorb_poro_w_left(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- right absorbing boundary
+ if(nspec_xmax >0) then
+ do ispec = 1,nspec_xmax
+ do id =1,2
+ do i=1,NGLLZ
+ write(46) b_absorb_poro_s_right(id,i,ispec,it)
+ write(26) b_absorb_poro_w_right(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- bottom absorbing boundary
+ if(nspec_zmin >0) then
+ do ispec = 1,nspec_zmin
+ do id =1,2
+ do i=1,NGLLX
+ write(47) b_absorb_poro_s_bottom(id,i,ispec,it)
+ write(29) b_absorb_poro_w_bottom(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+!--- top absorbing boundary
+ if(nspec_zmax >0) then
+ do ispec = 1,nspec_zmax
+ do id =1,2
+ do i=1,NGLLX
+ write(48) b_absorb_poro_s_top(id,i,ispec,it)
+ write(28) b_absorb_poro_w_top(id,i,ispec,it)
+ enddo
+ enddo
+ enddo
+ endif
+
+ endif ! if(anyabs .and. save_forward .and. isolver == 1)
+
+ endif !if(any_poroelastic) then
+
+! *********************************************************
+! ************* add coupling with the acoustic side
+! *********************************************************
+
+ if(coupled_acoustic_poroelastic) then
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_poro_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_poro_acoustic_ispec(inum)
+ iedge_acoustic = fluid_poro_acoustic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = fluid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = fluid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the acoustic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_acoustic)
+ j = jvalue_inverse(ipoin1D,iedge_acoustic)
+ iglob = ibool(i,j,ispec_acoustic)
+
+! get poroelastic parameters
+ phil = porosity(kmato(ispec_poroelastic))
+ tortl = tortuosity(kmato(ispec_poroelastic))
+ rhol_f = density(2,kmato(ispec_poroelastic))
+ rhol_s = density(1,kmato(ispec_poroelastic))
+ rhol_bar = (1._CUSTOM_REAL-phil)*rhol_s + phil*rhol_f
+
+! compute pressure on the fluid/porous medium edge
+ pressure = - potential_dot_dot_acoustic(iglob)
+ if(isolver == 2) then
+ b_pressure = - b_potential_dot_dot_acoustic(iglob)
+ endif
+
+! get point values for the poroelastic side
+ ii2 = ivalue(ipoin1D,iedge_poroelastic)
+ jj2 = jvalue(ipoin1D,iedge_poroelastic)
+ iglob = ibool(ii2,jj2,ispec_poroelastic)
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+ if(iedge_acoustic == ITOP)then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic == IBOTTOM)then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_acoustic ==ILEFT)then
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_acoustic ==IRIGHT)then
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ endif
+
+! contribution to the solid phase
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + weight*nx*pressure*(1._CUSTOM_REAL-phil/tortl)
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + weight*nz*pressure*(1._CUSTOM_REAL-phil/tortl)
+
+! contribution to the fluid phase
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) + weight*nx*pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) + weight*nz*pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
+
+ if(isolver == 2) then
+! contribution to the solid phase
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) + weight*nx*b_pressure*(1._CUSTOM_REAL-phil/tortl)
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + weight*nz*b_pressure*(1._CUSTOM_REAL-phil/tortl)
+
+! contribution to the fluid phase
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) + weight*nx*b_pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) + weight*nz*b_pressure*(1._CUSTOM_REAL-rhol_f/rhol_bar)
+ endif !if(isolver == 2) then
+
+ enddo ! do ipoin1D = 1,NGLLX
+
+ enddo ! do inum = 1,num_fluid_poro_edges
+
+ endif ! if(coupled_acoustic_poroelastic)
+
+! ****************************************************************************
+! ************* add coupling with the elastic side
+! ****************************************************************************
+
+ if(coupled_elastic_poroelastic) then
+
+! loop on all the coupling edges
+ do inum = 1,num_solid_poro_edges
+
+! get the edge of the elastic element
+ ispec_elastic = solid_poro_elastic_ispec(inum)
+ iedge_elastic = solid_poro_elastic_iedge(inum)
+
+! get the corresponding edge of the poroelastic element
+ ispec_poroelastic = solid_poro_poroelastic_ispec(inum)
+ iedge_poroelastic = solid_poro_poroelastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the elastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_elastic)
+ j = jvalue_inverse(ipoin1D,iedge_elastic)
+ iglob = ibool(i,j,ispec_elastic)
+
+! get poroelastic medium properties
+ phil = porosity(kmato(ispec_poroelastic))
+ tortl = tortuosity(kmato(ispec_poroelastic))
+!
+ rhol_s = density(1,kmato(ispec_poroelastic))
+ rhol_f = density(2,kmato(ispec_poroelastic))
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+
+! get elastic properties
+ lambdal_relaxed = poroelastcoef(1,1,kmato(ispec_elastic))
+ mul_relaxed = poroelastcoef(2,1,kmato(ispec_elastic))
+ lambdalplus2mul_relaxed = poroelastcoef(3,1,kmato(ispec_elastic))
+
+! derivative along x and along z for u_s and w
+ dux_dxi = ZERO
+ duz_dxi = ZERO
+
+ dux_dgamma = ZERO
+ duz_dgamma = ZERO
+
+ if(isolver == 2) then
+ b_dux_dxi = ZERO
+ b_duz_dxi = ZERO
+
+ b_dux_dgamma = ZERO
+ b_duz_dgamma = ZERO
+ endif
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
+ duz_dxi = duz_dxi + displ_elastic(2,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
+ dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
+ duz_dgamma = duz_dgamma + displ_elastic(2,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
+
+ if(isolver == 2) then
+ b_dux_dxi = b_dux_dxi + b_displ_elastic(1,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
+ b_duz_dxi = b_duz_dxi + b_displ_elastic(2,ibool(k,j,ispec_elastic))*hprime_xx(i,k)
+ b_dux_dgamma = b_dux_dgamma + b_displ_elastic(1,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
+ b_duz_dgamma = b_duz_dgamma + b_displ_elastic(2,ibool(i,k,ispec_elastic))*hprime_zz(j,k)
+ endif
+ enddo
+
+ xixl = xix(i,j,ispec_elastic)
+ xizl = xiz(i,j,ispec_elastic)
+ gammaxl = gammax(i,j,ispec_elastic)
+ gammazl = gammaz(i,j,ispec_elastic)
+
+! derivatives of displacement
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+ if(isolver == 2) then
+ b_dux_dxl = b_dux_dxi*xixl + b_dux_dgamma*gammaxl
+ b_dux_dzl = b_dux_dxi*xizl + b_dux_dgamma*gammazl
+
+ b_duz_dxl = b_duz_dxi*xixl + b_duz_dgamma*gammaxl
+ b_duz_dzl = b_duz_dxi*xizl + b_duz_dgamma*gammazl
+ endif
+! compute stress tensor
+
+! no attenuation
+ sigma_xx = lambdalplus2mul_relaxed*dux_dxl + lambdal_relaxed*duz_dzl
+ sigma_xz = mul_relaxed*(duz_dxl + dux_dzl)
+ sigma_zz = lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
+
+! full anisotropy
+ if(TURN_ANISOTROPY_ON) then
+! implement anisotropy in 2D
+ sigma_xx = c11val*dux_dxl + c15val*(duz_dxl + dux_dzl) + c13val*duz_dzl
+ sigma_zz = c13val*dux_dxl + c35val*(duz_dxl + dux_dzl) + c33val*duz_dzl
+ sigma_xz = c15val*dux_dxl + c55val*(duz_dxl + dux_dzl) + c35val*duz_dzl
+ endif
+
+ if(isolver == 2) then
+ b_sigma_xx = lambdalplus2mul_relaxed*b_dux_dxl + lambdal_relaxed*b_duz_dzl
+ b_sigma_xz = mul_relaxed*(b_duz_dxl + b_dux_dzl)
+ b_sigma_zz = lambdalplus2mul_relaxed*b_duz_dzl + lambdal_relaxed*b_dux_dxl
+ endif ! if(isolver == 2)
+
+! get point values for the poroelastic side
+ i = ivalue(ipoin1D,iedge_poroelastic)
+ j = jvalue(ipoin1D,iedge_poroelastic)
+ iglob = ibool(i,j,ispec_poroelastic)
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+ if(iedge_poroelastic == ITOP)then
+ xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = - zxi / jacobian1D
+ nz = + xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_poroelastic == IBOTTOM)then
+ xxi = + gammaz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zxi = - gammax(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ weight = jacobian1D * wxgll(i)
+ elseif(iedge_poroelastic ==ILEFT)then
+ xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = - zgamma / jacobian1D
+ nz = + xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ elseif(iedge_poroelastic ==IRIGHT)then
+ xgamma = - xiz(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ zgamma = + xix(i,j,ispec_poroelastic) * jacobian(i,j,ispec_poroelastic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ weight = jacobian1D * wzgll(j)
+ endif
+
+! contribution to the solid phase
+ accels_poroelastic(1,iglob) = accels_poroelastic(1,iglob) + &
+ weight*(sigma_xx*nx + sigma_xz*nz)*(1._CUSTOM_REAL - phil/tortl )
+
+ accels_poroelastic(2,iglob) = accels_poroelastic(2,iglob) + &
+ weight*(sigma_xz*nx + sigma_zz*nz)*(1._CUSTOM_REAL - phil/tortl )
+
+! contribution to the fluid phase
+ accelw_poroelastic(1,iglob) = accelw_poroelastic(1,iglob) - &
+ weight*(rhol_f/rhol_bar - 1._CUSTOM_REAL)*(sigma_xx*nx+sigma_xz*nz)
+
+ accelw_poroelastic(2,iglob) = accelw_poroelastic(2,iglob) - &
+ weight*(rhol_f/rhol_bar - 1._CUSTOM_REAL)*(sigma_xz*nx+sigma_zz*nz)
+
+ if(isolver == 2) then
+! contribution to the solid phase
+ b_accels_poroelastic(1,iglob) = b_accels_poroelastic(1,iglob) + &
+ weight*(b_sigma_xx*nx + b_sigma_xz*nz)*(1._CUSTOM_REAL - phil/tortl)
+
+ b_accels_poroelastic(2,iglob) = b_accels_poroelastic(2,iglob) + &
+ weight*(b_sigma_xz*nx + b_sigma_zz*nz)*(1._CUSTOM_REAL - phil/tortl)
+
+! contribution to the fluid phase
+ b_accelw_poroelastic(1,iglob) = b_accelw_poroelastic(1,iglob) - &
+ weight*(rhol_f/rhol_bar - 1._CUSTOM_REAL)*(b_sigma_xx*nx + b_sigma_xz*nz)
+
+ b_accelw_poroelastic(2,iglob) = b_accelw_poroelastic(2,iglob) - &
+ weight*(rhol_f/rhol_bar - 1._CUSTOM_REAL)*(b_sigma_xz*nx + b_sigma_zz*nz)
+ endif !if(isolver == 2) then
+
+ enddo
+
+ enddo
+
+ endif ! if(coupled_elastic_poroelastic)
+
+
+! assembling accels_proelastic & accelw_poroelastic for poroelastic elements
+#ifdef USE_MPI
+ if (nproc > 1 .and. any_poroelastic .and. ninterface_poroelastic > 0) then
+ call assemble_MPI_vector_po(accels_poroelastic,accelw_poroelastic,npoin, &
+ ninterface, ninterface_poroelastic,inum_interfaces_poroelastic, &
+ max_interface_size, max_ibool_interfaces_size_po,&
+ ibool_interfaces_poroelastic, nibool_interfaces_poroelastic, &
+ tab_requests_send_recv_poroelastic,buffer_send_faces_vector_pos,buffer_send_faces_vector_pow, &
+ buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow, &
+ my_neighbours)
+ endif
+
+ if (nproc > 1 .and. any_poroelastic .and. ninterface_poroelastic > 0 .and. isolver == 2) then
+ call assemble_MPI_vector_po(b_accels_poroelastic,b_accelw_poroelastic,npoin, &
+ ninterface, ninterface_poroelastic,inum_interfaces_poroelastic, &
+ max_interface_size, max_ibool_interfaces_size_po,&
+ ibool_interfaces_poroelastic, nibool_interfaces_poroelastic, &
+ tab_requests_send_recv_poroelastic,buffer_send_faces_vector_pos,buffer_send_faces_vector_pow, &
+ buffer_recv_faces_vector_pos,buffer_recv_faces_vector_pow, &
+ my_neighbours)
+ endif
+#endif
+
+
+! ************************************************************************************
+! ************* multiply by the inverse of the mass matrix and update velocity
+! ************************************************************************************
+
+ if(any_poroelastic) then
+
+
+! --- add the source if it is a collocated force
+ if(.not. initialfield) then
+
+ do i_source=1,NSOURCE
+! if this processor carries the source and the source element is elastic
+ if (is_proc_source(i_source) == 1 .and. poroelastic(ispec_selected_source(i_source))) then
+
+ phil = porosity(kmato(ispec_selected_source(i_source)))
+ tortl = tortuosity(kmato(ispec_selected_source(i_source)))
+ rhol_s = density(1,kmato(ispec_selected_source(i_source)))
+ rhol_f = density(2,kmato(ispec_selected_source(i_source)))
+ rhol_bar = (1._CUSTOM_REAL - phil)*rhol_s + phil*rhol_f
+
+! collocated force
+ if(source_type(i_source) == 1) then
+ if(isolver == 1) then ! forward wavefield
+! s
+ accels_poroelastic(1,iglob_source(i_source)) = accels_poroelastic(1,iglob_source(i_source)) - &
+ (1._CUSTOM_REAL - phil/tortl)*sin(angleforce(i_source))*source_time_function(i_source,it)
+ accels_poroelastic(2,iglob_source(i_source)) = accels_poroelastic(2,iglob_source(i_source)) + &
+ (1._CUSTOM_REAL - phil/tortl)*cos(angleforce(i_source))*source_time_function(i_source,it)
+! w
+ accelw_poroelastic(1,iglob_source(i_source)) = accelw_poroelastic(1,iglob_source(i_source)) - &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*sin(angleforce(i_source))*source_time_function(i_source,it)
+ accelw_poroelastic(2,iglob_source(i_source)) = accelw_poroelastic(2,iglob_source(i_source)) + &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*cos(angleforce(i_source))*source_time_function(i_source,it)
+
+ else ! backward wavefield
+! b_s
+ b_accels_poroelastic(1,iglob_source(i_source)) = b_accels_poroelastic(1,iglob_source(i_source)) - &
+ (1._CUSTOM_REAL - phil/tortl)*sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+ b_accels_poroelastic(2,iglob_source(i_source)) = b_accels_poroelastic(2,iglob_source(i_source)) + &
+ (1._CUSTOM_REAL - phil/tortl)*cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+!b_w
+ b_accelw_poroelastic(1,iglob_source(i_source)) = b_accelw_poroelastic(1,iglob_source(i_source)) - &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*sin(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+ b_accelw_poroelastic(2,iglob_source(i_source)) = b_accelw_poroelastic(2,iglob_source(i_source)) + &
+ (1._CUSTOM_REAL - rhol_f/rhol_bar)*cos(angleforce(i_source))*source_time_function(i_source,NSTEP-it+1)
+ endif !endif isolver == 1
+ endif
+
+ endif ! if this processor carries the source and the source element is elastic
+ enddo ! do i_source=1,NSOURCE
+
+ endif ! if not using an initial field
+
+ accels_poroelastic(1,:) = accels_poroelastic(1,:) * rmass_s_inverse_poroelastic(:)
+ accels_poroelastic(2,:) = accels_poroelastic(2,:) * rmass_s_inverse_poroelastic(:)
+ velocs_poroelastic = velocs_poroelastic + deltatover2*accels_poroelastic
+
+ accelw_poroelastic(1,:) = accelw_poroelastic(1,:) * rmass_w_inverse_poroelastic(:)
+ accelw_poroelastic(2,:) = accelw_poroelastic(2,:) * rmass_w_inverse_poroelastic(:)
+ velocw_poroelastic = velocw_poroelastic + deltatover2*accelw_poroelastic
+
+ if(isolver == 2) then
+ b_accels_poroelastic(1,:) = b_accels_poroelastic(1,:) * rmass_s_inverse_poroelastic(:)
+ b_accels_poroelastic(2,:) = b_accels_poroelastic(2,:) * rmass_s_inverse_poroelastic(:)
+ b_velocs_poroelastic = b_velocs_poroelastic + b_deltatover2*b_accels_poroelastic
+
+ b_accelw_poroelastic(1,:) = b_accelw_poroelastic(1,:) * rmass_w_inverse_poroelastic(:)
+ b_accelw_poroelastic(2,:) = b_accelw_poroelastic(2,:) * rmass_w_inverse_poroelastic(:)
+ b_velocw_poroelastic = b_velocw_poroelastic + b_deltatover2*b_accelw_poroelastic
+ endif
+
+ endif
+
+ if(any_poroelastic .and. isolver ==2) then
+ do iglob =1,npoin
+ rhot_k(iglob) = accels_poroelastic(1,iglob) * b_displs_poroelastic(1,iglob) + &
+ accels_poroelastic(2,iglob) * b_displs_poroelastic(2,iglob)
+ rhof_k(iglob) = accelw_poroelastic(1,iglob) * b_displs_poroelastic(1,iglob) + &
+ accelw_poroelastic(2,iglob) * b_displs_poroelastic(2,iglob) + &
+ accels_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
+ accels_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
+ sm_k(iglob) = accelw_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
+ accelw_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
+ eta_k(iglob) = velocw_poroelastic(1,iglob) * b_displw_poroelastic(1,iglob) + &
+ velocw_poroelastic(2,iglob) * b_displw_poroelastic(2,iglob)
+ enddo
+ endif
+
!---- compute kinetic and potential energy
if(OUTPUT_ENERGY) &
- call compute_energy(displ_elastic,veloc_elastic, &
- xix,xiz,gammax,gammaz,jacobian,ibool,elastic,hprime_xx,hprime_zz, &
- nspec,npoin,assign_external_model,it,deltat,t0,kmato,elastcoef,density, &
+ call compute_energy(displ_elastic,veloc_elastic,displs_poroelastic,velocs_poroelastic, &
+ displw_poroelastic,velocw_poroelastic, &
+ xix,xiz,gammax,gammaz,jacobian,ibool,elastic,poroelastic,hprime_xx,hprime_zz, &
+ nspec,npoin,assign_external_model,it,deltat,t0(1),kmato,poroelastcoef,density, &
+ porosity,tortuosity, &
vpext,vsext,rhoext,wxgll,wzgll,numat, &
pressure_element,vector_field_element,e1,e11, &
potential_dot_acoustic,potential_dot_dot_acoustic,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,Mu_nu1,Mu_nu2,N_SLS)
@@ -3173,7 +6024,7 @@
#ifdef USE_MPI
call MPI_ALLREDUCE (displnorm_all, displnorm_all_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
#endif
- if (myrank == 0) write(IOUT,*) 'Max norm of vector field in solid = ',displnorm_all_glob
+ if (myrank == 0) write(IOUT,*) 'Max norm of vector field in solid (elastic) = ',displnorm_all_glob
! check stability of the code in solid, exit if unstable
! negative values can occur with some compilers when the unstable value is greater
! than the greatest possible floating-point number of the machine
@@ -3181,6 +6032,40 @@
call exit_MPI('code became unstable and blew up in solid')
endif
+ if(any_poroelastic_glob) then
+ if(any_poroelastic) then
+ displnorm_all = maxval(sqrt(displs_poroelastic(1,:)**2 + displs_poroelastic(2,:)**2))
+ else
+ displnorm_all = 0.d0
+ endif
+ displnorm_all_glob = displnorm_all
+#ifdef USE_MPI
+ call MPI_ALLREDUCE (displnorm_all, displnorm_all_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+#endif
+ if (myrank == 0) write(IOUT,*) 'Max norm of vector field in solid (poroelastic) = ',displnorm_all_glob
+! check stability of the code in solid, exit if unstable
+! negative values can occur with some compilers when the unstable value is greater
+! than the greatest possible floating-point number of the machine
+ if(displnorm_all_glob > STABILITY_THRESHOLD .or. displnorm_all_glob < 0) &
+ call exit_MPI('code became unstable and blew up in solid (poroelastic)')
+
+ if(any_poroelastic) then
+ displnorm_all = maxval(sqrt(displw_poroelastic(1,:)**2 + displw_poroelastic(2,:)**2))
+ else
+ displnorm_all = 0.d0
+ endif
+ displnorm_all_glob = displnorm_all
+#ifdef USE_MPI
+ call MPI_ALLREDUCE (displnorm_all, displnorm_all_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
+#endif
+ if (myrank == 0) write(IOUT,*) 'Max norm of vector field in fluid (poroelastic) = ',displnorm_all_glob
+! check stability of the code in solid, exit if unstable
+! negative values can occur with some compilers when the unstable value is greater
+! than the greatest possible floating-point number of the machine
+ if(displnorm_all_glob > STABILITY_THRESHOLD .or. displnorm_all_glob < 0) &
+ call exit_MPI('code became unstable and blew up in fluid (poroelastic)')
+ endif
+
if(any_acoustic_glob) then
if(any_acoustic) then
displnorm_all = maxval(abs(potential_acoustic(:)))
@@ -3191,7 +6076,7 @@
#ifdef USE_MPI
call MPI_ALLREDUCE (displnorm_all, displnorm_all_glob, 1, MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, ier)
#endif
- if (myrank == 0) write(IOUT,*) 'Max absolute value of scalar field in fluid = ',displnorm_all_glob
+ if (myrank == 0) write(IOUT,*) 'Max absolute value of scalar field in fluid (acoustic) = ',displnorm_all_glob
! check stability of the code in fluid, exit if unstable
! negative values can occur with some compilers when the unstable value is greater
! than the greatest possible floating-point number of the machine
@@ -3211,27 +6096,31 @@
! compute pressure in this element if needed
if(seismotype == 4) then
- call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,elastic, &
+ call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,&
+ displs_poroelastic,displw_poroelastic,elastic,poroelastic,&
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
- numat,kmato,elastcoef,vpext,vsext,rhoext,ispec,e1,e11, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext,ispec,e1,e11, &
TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,Mu_nu1,Mu_nu2,N_SLS)
- else if(.not. elastic(ispec)) then
+ else if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
! for acoustic medium, compute vector field from gradient of potential for seismograms
if(seismotype == 1) then
- call compute_vector_one_element(vector_field_element,potential_acoustic,displ_elastic,elastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,density,rhoext,assign_external_model)
+ call compute_vector_one_element(vector_field_element,potential_acoustic,displ_elastic,displs_poroelastic,&
+ elastic,poroelastic,xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,&
+ density,rhoext,assign_external_model)
else if(seismotype == 2) then
- call compute_vector_one_element(vector_field_element,potential_dot_acoustic,veloc_elastic,elastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,density,rhoext,assign_external_model)
+ call compute_vector_one_element(vector_field_element,potential_dot_acoustic,veloc_elastic,velocs_poroelastic, &
+ elastic,poroelastic,xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,&
+ density,rhoext,assign_external_model)
else if(seismotype == 3) then
- call compute_vector_one_element(vector_field_element,potential_dot_dot_acoustic,accel_elastic,elastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,density,rhoext,assign_external_model)
+ call compute_vector_one_element(vector_field_element,potential_dot_dot_acoustic,accel_elastic,accels_poroelastic, &
+ elastic,poroelastic,xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec,numat,kmato,&
+ density,rhoext,assign_external_model)
endif
else if(seismotype == 5) then
- call compute_curl_one_element(curl_element,displ_elastic,elastic, &
+ call compute_curl_one_element(curl_element,displ_elastic,displs_poroelastic,elastic,poroelastic, &
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin, ispec)
endif
@@ -3254,30 +6143,55 @@
dxd = pressure_element(i,j)
dzd = ZERO
- else if(.not. elastic(ispec)) then
+ else if(.not. elastic(ispec) .and. .not. poroelastic(ispec) .and. seismotype /= 6) then
dxd = vector_field_element(1,i,j)
dzd = vector_field_element(2,i,j)
+ else if(seismotype == 6) then
+
+ dxd = potential_acoustic(iglob)
+ dzd = ZERO
+
else if(seismotype == 1) then
+ if(poroelastic(ispec)) then
+ dxd = displs_poroelastic(1,iglob)
+ dzd = displs_poroelastic(2,iglob)
+ elseif(elastic(ispec)) then
dxd = displ_elastic(1,iglob)
dzd = displ_elastic(2,iglob)
+ endif
else if(seismotype == 2) then
+ if(poroelastic(ispec)) then
+ dxd = velocs_poroelastic(1,iglob)
+ dzd = velocs_poroelastic(2,iglob)
+ elseif(elastic(ispec)) then
dxd = veloc_elastic(1,iglob)
dzd = veloc_elastic(2,iglob)
+ endif
else if(seismotype == 3) then
+ if(poroelastic(ispec)) then
+ dxd = accels_poroelastic(1,iglob)
+ dzd = accels_poroelastic(2,iglob)
+ elseif(elastic(ispec)) then
dxd = accel_elastic(1,iglob)
dzd = accel_elastic(2,iglob)
+ endif
else if(seismotype == 5) then
+ if(poroelastic(ispec)) then
+ dxd = displs_poroelastic(1,iglob)
+ dzd = displs_poroelastic(2,iglob)
+ elseif(elastic(ispec)) then
dxd = displ_elastic(1,iglob)
dzd = displ_elastic(2,iglob)
+ endif
dcurld = curl_element(i,j)
endif
@@ -3291,7 +6205,7 @@
enddo
! rotate seismogram components if needed, except if recording pressure, which is a scalar
- if(seismotype /= 4) then
+ if(seismotype /= 4 .and. seismotype /= 6) then
sisux(seismo_current,irecloc) = cosrot_irec(irecloc)*valux + sinrot_irec(irecloc)*valuz
sisuz(seismo_current,irecloc) = - sinrot_irec(irecloc)*valux + cosrot_irec(irecloc)*valuz
else
@@ -3302,12 +6216,277 @@
enddo
+
!
+!----- ecriture des kernels
+!
+! kernels output
+ if(isolver == 2) then
+
+ if(any_acoustic) then
+
+ do ispec = 1, nspec
+ if(.not. elastic(ispec) .and. .not. poroelastic(ispec)) then
+ do k = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,k,ispec)
+ kappal_ac_global(iglob) = poroelastcoef(1,2,kmato(ispec))
+ rhol_ac_global(iglob) = density(2,kmato(ispec))
+ enddo
+ enddo
+ endif
+ enddo
+
+ do iglob =1,npoin
+ rho_ac_kl(iglob) = rho_ac_kl(iglob) - rhol_ac_global(iglob) * rho_ac_k(iglob) * deltat
+ kappa_ac_kl(iglob) = kappa_ac_kl(iglob) - kappal_ac_global(iglob) * kappa_ac_k(iglob) * deltat
+!
+ rhop_ac_kl(iglob) = rho_ac_kl(iglob) + kappa_ac_kl(iglob)
+ alpha_ac_kl(iglob) = TWO * kappa_ac_kl(iglob)
+ enddo
+
+ endif !if(any_acoustic)
+
+ if(any_elastic) then
+
+ do ispec = 1, nspec
+ if(elastic(ispec)) then
+ do k = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,k,ispec)
+ mul_global(iglob) = poroelastcoef(2,1,kmato(ispec))
+ kappal_global(iglob) = poroelastcoef(3,1,kmato(ispec)) - 4._CUSTOM_REAL*mul_global(iglob)/3._CUSTOM_REAL
+ rhol_global(iglob) = density(1,kmato(ispec))
+ enddo
+ enddo
+ endif
+ enddo
+
+ do iglob =1,npoin
+ rho_kl(iglob) = rho_kl(iglob) - rhol_global(iglob) * rho_k(iglob) * deltat
+ mu_kl(iglob) = mu_kl(iglob) - TWO * mul_global(iglob) * mu_k(iglob) * deltat
+ kappa_kl(iglob) = kappa_kl(iglob) - kappal_global(iglob) * kappa_k(iglob) * deltat
+!
+ rhop_kl(iglob) = rho_kl(iglob) + kappa_kl(iglob) + mu_kl(iglob)
+ beta_kl(iglob) = TWO * (mu_kl(iglob) - 4._CUSTOM_REAL * mul_global(iglob) &
+ / (3._CUSTOM_REAL * kappal_global(iglob)) * kappa_kl(iglob))
+ alpha_kl(iglob) = TWO * (1._CUSTOM_REAL + 4._CUSTOM_REAL * mul_global(iglob)/&
+ (3._CUSTOM_REAL * kappal_global(iglob))) * kappa_kl(iglob)
+ enddo
+
+ endif !if(any_elastic)
+
+ if(any_poroelastic) then
+
+ do ispec = 1, nspec
+ if(poroelastic(ispec)) then
+ do k = 1, NGLLZ
+ do i = 1, NGLLX
+ iglob = ibool(i,k,ispec)
+ phil_global(iglob) = porosity(kmato(ispec))
+ tortl_global(iglob) = tortuosity(kmato(ispec))
+ rhol_s_global(iglob) = density(1,kmato(ispec))
+ rhol_f_global(iglob) = density(2,kmato(ispec))
+ rhol_bar_global(iglob) = (1._CUSTOM_REAL - phil_global(iglob))*rhol_s_global(iglob) &
+ + phil_global(iglob)*rhol_f_global(iglob)
+ etal_f_global(iglob) = poroelastcoef(2,2,kmato(ispec))
+ permlxx_global(iglob) = permeability(1,kmato(ispec))
+ permlxz_global(iglob) = permeability(2,kmato(ispec))
+ permlzz_global(iglob) = permeability(3,kmato(ispec))
+ mulfr_global(iglob) = poroelastcoef(2,3,kmato(ispec))
+ enddo
+ enddo
+ endif
+ enddo
+
+ do iglob =1,npoin
+ rhot_kl(iglob) = rhot_kl(iglob) - deltat * rhol_bar_global(iglob) * rhot_k(iglob)
+ rhof_kl(iglob) = rhof_kl(iglob) - deltat * rhol_f_global(iglob) * rhof_k(iglob)
+ sm_kl(iglob) = sm_kl(iglob) - deltat * rhol_f_global(iglob)*tortl_global(iglob)/phil_global(iglob) * sm_k(iglob)
+!at the moment works with constant permeability
+ eta_kl(iglob) = eta_kl(iglob) - deltat * etal_f_global(iglob)/permlxx_global(iglob) * eta_k(iglob)
+ B_kl(iglob) = B_kl(iglob) - deltat * B_k(iglob)
+ C_kl(iglob) = C_kl(iglob) - deltat * C_k(iglob)
+ M_kl(iglob) = M_kl(iglob) - deltat * M_k(iglob)
+ mufr_kl(iglob) = mufr_kl(iglob) - TWO * deltat * mufr_k(iglob)
+! density kernels
+ rholb = rhol_bar_global(iglob) - phil_global(iglob)*rhol_f_global(iglob)/tortl_global(iglob)
+ rhob_kl(iglob) = rhot_kl(iglob) + B_kl(iglob) + mufr_kl(iglob)
+ rhofb_kl(iglob) = rhof_kl(iglob) + C_kl(iglob) + M_kl(iglob) + sm_kl(iglob)
+ Bb_kl(iglob) = B_kl(iglob)
+ Cb_kl(iglob) = C_kl(iglob)
+ Mb_kl(iglob) = M_kl(iglob)
+ mufrb_kl(iglob) = mufr_kl(iglob)
+ phi_kl(iglob) = - sm_kl(iglob) - M_kl(iglob)
+! wave speed kernels
+ dd1 = (1._CUSTOM_REAL+rholb/rhol_f_global(iglob))*ratio**2 + 2._CUSTOM_REAL*ratio +&
+ tortl_global(iglob)/phil_global(iglob)
+ rhobb_kl(iglob) = rhob_kl(iglob) - &
+ phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*B_biot) * &
+ (cpIIsquare + (cpIsquare - cpIIsquare)*( (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1+&
+ (rhol_bar_global(iglob)**2*ratio**2/rhol_f_global(iglob)**2*(phil_global(iglob)/tortl_global(iglob)*&
+ ratio+1)*(phil_global(iglob)/tortl_global(iglob)*ratio+phil_global(iglob)/tortl_global(iglob)*&
+ (1+rhol_f_global(iglob)/rhol_bar_global(iglob))-1) )/dd1**2 )- FOUR_THIRDS*cssquare )*&
+ Bb_kl(iglob) - &
+ rhol_bar_global(iglob)*ratio**2/M_biot * (cpIsquare - cpIIsquare)* &
+ (phil_global(iglob)/tortl_global(iglob)*ratio + 1._CUSTOM_REAL)**2/dd1**2*Mb_kl(iglob) + &
+ rhol_bar_global(iglob)*ratio/C_biot * (cpIsquare - cpIIsquare)* (&
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
+ phil_global(iglob)*ratio/tortl_global(iglob)*(phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*&
+ (1+rhol_bar_global(iglob)*ratio/rhol_f_global(iglob))/dd1**2)*Cb_kl(iglob)+ &
+ phil_global(iglob)*rhol_f_global(iglob)*cssquare/(tortl_global(iglob)*mulfr_global(iglob))*mufrb_kl(iglob)
+ rhofbb_kl(iglob) = rhofb_kl(iglob) + &
+ phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*B_biot) * &
+ (cpIIsquare + (cpIsquare - cpIIsquare)*( (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1+&
+ (rhol_bar_global(iglob)**2*ratio**2/rhol_f_global(iglob)**2*(phil_global(iglob)/tortl_global(iglob)*&
+ ratio+1)*(phil_global(iglob)/tortl_global(iglob)*ratio+phil_global(iglob)/tortl_global(iglob)*&
+ (1+rhol_f_global(iglob)/rhol_bar_global(iglob))-1) )/dd1**2 )- FOUR_THIRDS*cssquare )*&
+ Bb_kl(iglob) + &
+ rhol_bar_global(iglob)*ratio**2/M_biot * (cpIsquare - cpIIsquare)* &
+ (phil_global(iglob)/tortl_global(iglob)*ratio + 1._CUSTOM_REAL)**2/dd1**2*Mb_kl(iglob) - &
+ rhol_bar_global(iglob)*ratio/C_biot * (cpIsquare - cpIIsquare)* (&
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
+ phil_global(iglob)*ratio/tortl_global(iglob)*(phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*&
+ (1+rhol_bar_global(iglob)*ratio/rhol_f_global(iglob))/dd1**2)*Cb_kl(iglob)- &
+ phil_global(iglob)*rhol_f_global(iglob)*cssquare/(tortl_global(iglob)*mulfr_global(iglob))*mufrb_kl(iglob)
+ phib_kl(iglob) = phi_kl(iglob) - &
+ phil_global(iglob)*rhol_bar_global(iglob)/(tortl_global(iglob)*B_biot) * ( cpIsquare - rhol_f_global(iglob)/&
+ rhol_bar_global(iglob)*cpIIsquare- &
+ (cpIsquare-cpIIsquare)*( (TWO*ratio**2*phil_global(iglob)/tortl_global(iglob) + (1._CUSTOM_REAL+&
+ rhol_f_global(iglob)/rhol_bar_global(iglob))*(TWO*ratio*phil_global(iglob)/tortl_global(iglob)+&
+ 1._CUSTOM_REAL))/dd1 + (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(phil_global(iglob)*&
+ ratio/tortl_global(iglob)+phil_global(iglob)/tortl_global(iglob)*(1._CUSTOM_REAL+rhol_f_global(iglob)/&
+ rhol_bar_global(iglob))-1._CUSTOM_REAL)*((1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)-&
+ TWO*phil_global(iglob)/tortl_global(iglob))*ratio**2+TWO*ratio)/dd1**2 ) - &
+ FOUR_THIRDS*rhol_f_global(iglob)*cssquare/rhol_bar_global(iglob) )*Bb_kl(iglob) + &
+ rhol_f_global(iglob)/M_biot * (cpIsquare-cpIIsquare)*(&
+ TWO*ratio*(phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2*((1._CUSTOM_REAL+rhol_bar_global(iglob)/&
+ rhol_f_global(iglob)-TWO*phil_global(iglob)/tortl_global(iglob))*ratio**2+TWO*ratio)/dd1**2&
+ )*Mb_kl(iglob) + &
+ phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*C_biot)*(cpIsquare-cpIIsquare)*ratio* (&
+ (1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob)*ratio)/dd1 - &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(1._CUSTOM_REAL+rhol_bar_global(iglob)/&
+ rhol_f_global(iglob)*ratio)*((1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)-TWO*&
+ phil_global(iglob)/tortl_global(iglob))*ratio+TWO)/dd1**2&
+ )*Cb_kl(iglob) -&
+ phil_global(iglob)*rhol_f_global(iglob)*cssquare/(tortl_global(iglob)*mulfr_global(iglob))*mufrb_kl(iglob)
+ cpI_kl(iglob) = 2._CUSTOM_REAL*cpIsquare/B_biot*rhol_bar_global(iglob)*( &
+ 1._CUSTOM_REAL-phil_global(iglob)/tortl_global(iglob) + &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(phil_global(iglob)/tortl_global(iglob)*&
+ ratio+phil_global(iglob)/tortl_global(iglob)*(1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob))-&
+ 1._CUSTOM_REAL)/dd1 &
+ )* Bb_kl(iglob) +&
+ 2._CUSTOM_REAL*cpIsquare*rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot) *&
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2/dd1*Mb_kl(iglob)+&
+ 2._CUSTOM_REAL*cpIsquare*rhol_f_global(iglob)/C_biot * &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(1._CUSTOM_REAL+rhol_bar_global(iglob)/&
+ rhol_f_global(iglob)*ratio)/dd1*Cb_kl(iglob)
+ cpII_kl(iglob) = 2._CUSTOM_REAL*cpIIsquare*rhol_bar_global(iglob)/B_biot * (&
+ phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*rhol_bar_global(iglob)) - &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(phil_global(iglob)/tortl_global(iglob)*&
+ ratio+phil_global(iglob)/tortl_global(iglob)*(1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob))-&
+ 1._CUSTOM_REAL)/dd1 ) * Bb_kl(iglob) +&
+ 2._CUSTOM_REAL*cpIIsquare*rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot) * (&
+ 1._CUSTOM_REAL - (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2/dd1 )*Mb_kl(iglob) + &
+ 2._CUSTOM_REAL*cpIIsquare*rhol_f_global(iglob)/C_biot * (&
+ 1._CUSTOM_REAL - (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*(1._CUSTOM_REAL+&
+ rhol_bar_global(iglob)/rhol_f_global(iglob)*ratio)/dd1 )*Cb_kl(iglob)
+ cs_kl(iglob) = - 8._CUSTOM_REAL/3._CUSTOM_REAL*cssquare*rhol_bar_global(iglob)/B_biot*(1._CUSTOM_REAL-&
+ phil_global(iglob)*rhol_f_global(iglob)/(tortl_global(iglob)*rhol_bar_global(iglob)))*Bb_kl(iglob) + &
+ 2._CUSTOM_REAL*(rhol_bar_global(iglob)-rhol_f_global(iglob)*phil_global(iglob)/tortl_global(iglob))/&
+ mulfr_global(iglob)*cssquare*mufrb_kl(iglob)
+ ratio_kl(iglob) = ratio*rhol_bar_global(iglob)*phil_global(iglob)/(tortl_global(iglob)*B_biot) * &
+ (cpIsquare-cpIIsquare) * ( &
+ phil_global(iglob)/tortl_global(iglob)*(2._CUSTOM_REAL*ratio+1._CUSTOM_REAL+rhol_f_global(iglob)/ &
+ rhol_bar_global(iglob))/dd1 - (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)*&
+ (phil_global(iglob)/tortl_global(iglob)*ratio+phil_global(iglob)/tortl_global(iglob)*(&
+ 1._CUSTOM_REAL+rhol_f_global(iglob)/rhol_bar_global(iglob))-1._CUSTOM_REAL)*(2._CUSTOM_REAL*ratio*(&
+ 1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)-phil_global(iglob)/tortl_global(iglob)) +&
+ 2._CUSTOM_REAL)/dd1**2 )*Bb_kl(iglob) + &
+ ratio*rhol_f_global(iglob)*tortl_global(iglob)/(phil_global(iglob)*M_biot)*(cpIsquare-cpIIsquare) * &
+ 2._CUSTOM_REAL*phil_global(iglob)/tortl_global(iglob) * (&
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)/dd1 - &
+ (phil_global(iglob)/tortl_global(iglob)*ratio+1._CUSTOM_REAL)**2*((1._CUSTOM_REAL+rhol_bar_global(iglob)/&
+ rhol_f_global(iglob)-phil_global(iglob)/tortl_global(iglob))*ratio+1._CUSTOM_REAL)/dd1**2 )*Mb_kl(iglob) +&
+ ratio*rhol_f_global(iglob)/C_biot*(cpIsquare-cpIIsquare) * (&
+ (2._CUSTOM_REAL*phil_global(iglob)*rhol_bar_global(iglob)*ratio/(tortl_global(iglob)*rhol_f_global(iglob))+&
+ phil_global(iglob)/tortl_global(iglob)+rhol_bar_global(iglob)/rhol_f_global(iglob))/dd1 - &
+ 2._CUSTOM_REAL*phil_global(iglob)/tortl_global(iglob)*(phil_global(iglob)/tortl_global(iglob)*ratio+&
+ 1._CUSTOM_REAL)*(1._CUSTOM_REAL+rhol_bar_global(iglob)/rhol_f_global(iglob)*ratio)*((1._CUSTOM_REAL+&
+ rhol_bar_global(iglob)/rhol_f_global(iglob)-phil_global(iglob)/tortl_global(iglob))*ratio+1._CUSTOM_REAL)/&
+ dd1**2 )*Cb_kl(iglob)
+ enddo
+
+ endif ! if(any_poroelastic)
+
+ endif ! if(isolver == 2)
+
+!
!---- display results at given time steps
!
if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
!
+! kernels output files
+!
+
+ if(isolver == 2 .and. it == NSTEP) then
+
+ if ( myrank == 0 ) then
+ write(IOUT,*) 'Writing Kernels file'
+ endif
+
+ if(any_acoustic) then
+ do iglob =1,npoin
+ xx = coord(1,iglob)
+ zz = coord(2,iglob)
+ write(95,'(5e12.3)')xx,zz,rho_ac_kl(iglob),kappa_ac_kl(iglob)
+ write(96,'(5e12.3)')xx,zz,rhop_ac_kl(iglob),alpha_ac_kl(iglob)
+ enddo
+ close(95)
+ close(96)
+ endif
+
+ if(any_elastic) then
+ do iglob =1,npoin
+ xx = coord(1,iglob)
+ zz = coord(2,iglob)
+ write(97,'(5e12.3)')xx,zz,rho_kl(iglob),kappa_kl(iglob),mu_kl(iglob)
+ write(98,'(5e12.3)')xx,zz,rhop_kl(iglob),alpha_kl(iglob),beta_kl(iglob)
+ enddo
+ close(97)
+ close(98)
+ endif
+
+ if(any_poroelastic) then
+ do iglob =1,npoin
+ xx = coord(1,iglob)
+ zz = coord(2,iglob)
+ write(14,'(5e12.3)')xx,zz,mufr_kl(iglob),B_kl(iglob),C_kl(iglob)
+ write(15,'(5e12.3)')xx,zz,M_kl(iglob),rhot_kl(iglob),rhof_kl(iglob)
+ write(16,'(5e12.3)')xx,zz,sm_kl(iglob),eta_kl(iglob)
+ write(17,'(5e12.3)')xx,zz,mufrb_kl(iglob),Bb_kl(iglob),Cb_kl(iglob)
+ write(18,'(5e12.3)')xx,zz,Mb_kl(iglob),rhob_kl(iglob),rhofb_kl(iglob)
+ write(19,'(5e12.3)')xx,zz,phi_kl(iglob),eta_kl(iglob)
+ write(20,'(5e12.3)')xx,zz,cpI_kl(iglob),cpII_kl(iglob),cs_kl(iglob)
+ write(21,'(5e12.3)')xx,zz,rhobb_kl(iglob),rhofbb_kl(iglob),ratio_kl(iglob)
+ write(22,'(5e12.3)')xx,zz,phib_kl(iglob),eta_kl(iglob)
+ enddo
+ close(14)
+ close(15)
+ close(16)
+ close(17)
+ close(18)
+ close(19)
+ close(20)
+ close(21)
+ close(22)
+ endif
+
+ endif
+
+!
!---- PostScript display
!
if(output_postscript_snapshot) then
@@ -3318,18 +6497,24 @@
if (myrank == 0) write(IOUT,*) 'drawing displacement vector as small arrows...'
- call compute_vector_whole_medium(potential_acoustic,displ_elastic,elastic,vector_field_display, &
+ call compute_vector_whole_medium(potential_acoustic,b_displ_elastic,displs_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
call plotpost(vector_field_display,coord,vpext,x_source,z_source,st_xval,st_zval, &
it,deltat,coorg,xinterp,zinterp,shape2D_display, &
- Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,&
+ poroelastcoef,knods,kmato,ibool, &
numabs,codeabs,anyabs,nelem_acoustic_surface,acoustic_edges, &
- simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
+ simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCE, &
colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
- nspec,ngnod,coupled_acoustic_elastic,any_acoustic,plot_lowerleft_corner_only, &
- fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges,myrank,nproc,ier,&
+ nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poroelastic,coupled_elastic_poroelastic, &
+ any_acoustic,any_poroelastic,plot_lowerleft_corner_only, &
+ fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges,&
+ fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge,num_fluid_poro_edges, &
+ solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge,num_solid_poro_edges, &
+ myrank,nproc,ier,&
d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model,d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model, &
@@ -3348,18 +6533,24 @@
if (myrank == 0) write(IOUT,*) 'drawing velocity vector as small arrows...'
- call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,elastic,vector_field_display, &
+ call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,velocs_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
call plotpost(vector_field_display,coord,vpext,x_source,z_source,st_xval,st_zval, &
it,deltat,coorg,xinterp,zinterp,shape2D_display, &
- Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,&
+ poroelastcoef,knods,kmato,ibool, &
numabs,codeabs,anyabs,nelem_acoustic_surface,acoustic_edges, &
- simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
+ simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCE, &
colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
- nspec,ngnod,coupled_acoustic_elastic,any_acoustic,plot_lowerleft_corner_only, &
- fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges,myrank,nproc,ier,&
+ nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poroelastic,coupled_elastic_poroelastic, &
+ any_acoustic,any_poroelastic,plot_lowerleft_corner_only, &
+ fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges,&
+ fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge,num_fluid_poro_edges, &
+ solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge,num_solid_poro_edges, &
+ myrank,nproc,ier,&
d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model,d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model, &
@@ -3378,18 +6569,24 @@
if (myrank == 0) write(IOUT,*) 'drawing acceleration vector as small arrows...'
- call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,elastic,vector_field_display, &
+ call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,accels_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
call plotpost(vector_field_display,coord,vpext,x_source,z_source,st_xval,st_zval, &
it,deltat,coorg,xinterp,zinterp,shape2D_display, &
- Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ Uxinterp,Uzinterp,flagrange,density,porosity,tortuosity,&
+ poroelastcoef,knods,kmato,ibool, &
numabs,codeabs,anyabs,nelem_acoustic_surface,acoustic_edges, &
- simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
+ simulation_title,npoin,npgeo,vpImin,vpImax,nrec,NSOURCE, &
colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
- nspec,ngnod,coupled_acoustic_elastic,any_acoustic,plot_lowerleft_corner_only, &
- fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges,myrank,nproc,ier,&
+ nspec,ngnod,coupled_acoustic_elastic,coupled_acoustic_poroelastic,coupled_elastic_poroelastic, &
+ any_acoustic,any_poroelastic,plot_lowerleft_corner_only, &
+ fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges, &
+ fluid_poro_acoustic_ispec,fluid_poro_acoustic_iedge,num_fluid_poro_edges, &
+ solid_poro_poroelastic_ispec,solid_poro_poroelastic_iedge,num_solid_poro_edges, &
+ myrank,nproc,ier,&
d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model, &
d1_coorg_recv_ps_velocity_model,d2_coorg_recv_ps_velocity_model, &
d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model,d1_RGB_recv_ps_velocity_model,d2_RGB_recv_ps_velocity_model, &
@@ -3427,30 +6624,34 @@
if (myrank == 0) write(IOUT,*) 'drawing image of vertical component of displacement vector...'
- call compute_vector_whole_medium(potential_acoustic,displ_elastic,elastic,vector_field_display, &
+ call compute_vector_whole_medium(potential_acoustic,displ_elastic,displs_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
else if(imagetype == 2) then
if (myrank == 0) write(IOUT,*) 'drawing image of vertical component of velocity vector...'
- call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,elastic,vector_field_display, &
+ call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,velocs_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
else if(imagetype == 3) then
if (myrank == 0) write(IOUT,*) 'drawing image of vertical component of acceleration vector...'
- call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,elastic,vector_field_display, &
+ call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,accels_poroelastic,&
+ elastic,poroelastic,vector_field_display, &
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,numat,kmato,density,rhoext,assign_external_model)
else if(imagetype == 4) then
if (myrank == 0) write(IOUT,*) 'drawing image of pressure field...'
- call compute_pressure_whole_medium(potential_dot_dot_acoustic,displ_elastic,elastic,vector_field_display, &
+ call compute_pressure_whole_medium(potential_dot_dot_acoustic,displ_elastic,&
+ displs_poroelastic,displw_poroelastic,elastic,poroelastic,vector_field_display, &
xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
- numat,kmato,elastcoef,vpext,vsext,rhoext,e1,e11, &
+ numat,kmato,density,porosity,tortuosity,poroelastcoef,vpext,vsext,rhoext,e1,e11, &
TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,Mu_nu1,Mu_nu2,N_SLS)
else
@@ -3544,6 +6745,89 @@
enddo ! end of the main time loop
+ if((save_forward .and. isolver==1) .or. isolver ==2) then
+ if(any_acoustic) then
+ close(65)
+ close(66)
+ close(67)
+ close(68)
+ endif
+ if(any_elastic) then
+ close(35)
+ close(36)
+ close(37)
+ close(38)
+ endif
+ if(any_poroelastic) then
+ close(25)
+ close(45)
+ close(26)
+ close(46)
+ close(29)
+ close(47)
+ close(28)
+ close(48)
+ endif
+ endif
+
+!
+!--- save last frame
+!
+ if(save_forward .and. isolver ==1 .and. any_elastic) then
+ if ( myrank == 0 ) then
+ write(IOUT,*)
+ write(IOUT,*) 'Saving elastic last frame...'
+ write(IOUT,*)
+ endif
+ write(outputname,'(a,i6.6,a)') 'lastframe_elastic',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
+ do j=1,npoin
+ write(55) (displ_elastic(i,j), i=1,NDIM), &
+ (veloc_elastic(i,j), i=1,NDIM), &
+ (accel_elastic(i,j), i=1,NDIM)
+ enddo
+ close(55)
+ endif
+
+ if(save_forward .and. isolver ==1 .and. any_poroelastic) then
+ if ( myrank == 0 ) then
+ write(IOUT,*)
+ write(IOUT,*) 'Saving poroelastic last frame...'
+ write(IOUT,*)
+ endif
+ write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_s',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
+ write(outputname,'(a,i6.6,a)') 'lastframe_poroelastic_w',myrank,'.bin'
+ open(unit=56,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
+ do j=1,npoin
+ write(55) (displs_poroelastic(i,j), i=1,NDIM), &
+ (velocs_poroelastic(i,j), i=1,NDIM), &
+ (accels_poroelastic(i,j), i=1,NDIM)
+ write(56) (displw_poroelastic(i,j), i=1,NDIM), &
+ (velocw_poroelastic(i,j), i=1,NDIM), &
+ (accelw_poroelastic(i,j), i=1,NDIM)
+ enddo
+ close(55)
+ close(56)
+ endif
+
+ if(save_forward .and. isolver ==1 .and. any_acoustic) then
+ if ( myrank == 0 ) then
+ write(IOUT,*)
+ write(IOUT,*) 'Saving acoustic last frame...'
+ write(IOUT,*)
+ endif
+ write(outputname,'(a,i6.6,a)') 'lastframe_acoustic',myrank,'.bin'
+ open(unit=55,file='OUTPUT_FILES/'//outputname,status='unknown',form='unformatted')
+ do j=1,npoin
+ write(55) potential_acoustic(j),&
+ potential_dot_acoustic(j),&
+ potential_dot_dot_acoustic(j)
+ enddo
+ close(55)
+ endif
+
+
deallocate(v0x_left)
deallocate(v0z_left)
deallocate(t0x_left)
More information about the CIG-COMMITS
mailing list