[cig-commits] r8508 - seismo/2D/SPECFEM2D/trunk
walter at geodynamics.org
walter at geodynamics.org
Fri Dec 7 15:52:05 PST 2007
Author: walter
Date: 2007-12-07 15:52:05 -0800 (Fri, 07 Dec 2007)
New Revision: 8508
Added:
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/define_external_model.f90
seismo/2D/SPECFEM2D/trunk/enforce_acoustic_free_surface.f90
Removed:
seismo/2D/SPECFEM2D/trunk/compute_gradient_fluid.f90
Modified:
seismo/2D/SPECFEM2D/trunk/Makefile
seismo/2D/SPECFEM2D/trunk/checkgrid.f90
seismo/2D/SPECFEM2D/trunk/compute_arrays_source.f90
seismo/2D/SPECFEM2D/trunk/compute_gradient_attenuation.f90
seismo/2D/SPECFEM2D/trunk/constants.h
seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.f90
seismo/2D/SPECFEM2D/trunk/create_color_image.f90
seismo/2D/SPECFEM2D/trunk/createnum_fast.f90
seismo/2D/SPECFEM2D/trunk/createnum_slow.f90
seismo/2D/SPECFEM2D/trunk/datim.f90
seismo/2D/SPECFEM2D/trunk/define_derivation_matrices.f90
seismo/2D/SPECFEM2D/trunk/define_shape_functions.f90
seismo/2D/SPECFEM2D/trunk/gmat01.f90
seismo/2D/SPECFEM2D/trunk/lagrange_poly.f90
seismo/2D/SPECFEM2D/trunk/locate_receivers.f90
seismo/2D/SPECFEM2D/trunk/locate_source_force.f90
seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.f90
seismo/2D/SPECFEM2D/trunk/meshfem2D.f90
seismo/2D/SPECFEM2D/trunk/plotgll.f90
seismo/2D/SPECFEM2D/trunk/plotpost.f90
seismo/2D/SPECFEM2D/trunk/read_value_parameters.f90
seismo/2D/SPECFEM2D/trunk/recompute_jacobian.f90
seismo/2D/SPECFEM2D/trunk/specfem2D.f90
seismo/2D/SPECFEM2D/trunk/write_seismograms.f90
Log:
Major update: release of version 5.2.
Version 5.2, Dimitri Komatitsch, April 2007:
- general fluid/solid implementation with any number, shape and orientation of matching edges
- absorbing edges with any normal vector
- general numbering of absorbing and acoustic free surface edges
- cleaned implementation of attenuation as in Carcione (1993)
- merged loops in the solver for efficiency
- simplified input of external model
- added CPU time information
- translated many comments from French to English
Modified: seismo/2D/SPECFEM2D/trunk/Makefile
===================================================================
--- seismo/2D/SPECFEM2D/trunk/Makefile 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/Makefile 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,37 +1,37 @@
#
-# Makefile for SPECFEM2D version 5.1
+# Makefile for SPECFEM2D version 5.2
#
-# Dimitri Komatitsch, Universite de Pau et des Pays de l'Adour, December 2004
+# Dimitri Komatitsch, University of Pau, April 2007
#
SHELL=/bin/sh
O = obj
-# Portland Linux
+# Portland
#F90 = pgf90
-#FLAGS_NOCHECK=-fast -Mnobounds -Minline -Mneginfo -Mdclchk
-#FLAGS_CHECK=-O0 -Mbounds -Mneginfo -Mdclchk
+#FLAGS_NOCHECK=-fast -Mnobounds -Minline -Mneginfo -Mdclchk -Knoieee -Minform=warn -fastsse -tp amd64e -Msmart
+#FLAGS_CHECK=-fast -Mbounds -Mneginfo -Mdclchk -Minform=warn
-# Intel Linux
-F90 = ifort
-#FLAGS_NOCHECK=-O0 -implicitnone -warn stderrors -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -assume byterecl -check bounds
-FLAGS_NOCHECK=-O3 -implicitnone -warn stderrors -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -assume byterecl -check nobounds
-FLAGS_CHECK = $(FLAGS_NOCHECK) -check bounds
+# Intel
+#F90 = ifort
+#FLAGS_NOCHECK=-O3 -implicitnone -warn stderrors -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -assume byterecl -check nobounds
+#FLAGS_CHECK = $(FLAGS_NOCHECK) -check bounds
# GNU gfortran
-#F90 = gfortran
-#FLAGS_NOCHECK = -std=gnu -fimplicit-none -frange-check -O2 -Wunused-labels -Waliasing -Wampersand -Wsurprising -Wline-truncation -Wunderflow
-#FLAGS_CHECK = $(FLAGS_NOCHECK) -fbounds-check
+F90 = gfortran
+FLAGS_NOCHECK = -std=gnu -fimplicit-none -frange-check -O2 -Wunused-labels -Waliasing -Wampersand -Wsurprising -Wline-truncation -Wunderflow
+FLAGS_CHECK = $(FLAGS_NOCHECK) -fbounds-check
LINK = $(F90)
OBJS_MESHFEM2D = $O/meshfem2D.o $O/read_value_parameters.o
-OBJS_SPECFEM2D = $O/checkgrid.o $O/datim.o $O/defarrays.o\
+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/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/createnum_fast.o $O/createnum_slow.o\
- $O/define_shape_functions.o $O/create_color_image.o $O/compute_gradient_fluid.o\
+ $O/specfem2D.o $O/write_seismograms.o $O/define_external_model.o $O/createnum_fast.o $O/createnum_slow.o\
+ $O/define_shape_functions.o $O/create_color_image.o $O/compute_vector_field.o $O/compute_pressure.o\
$O/recompute_jacobian.o $O/compute_arrays_source.o $O/locate_source_moment_tensor.o $O/numerical_recipes.o
default: clean meshfem2D specfem2D convolve_source_timefunction
@@ -39,7 +39,7 @@
all: default
clean:
- /bin/rm -r -f xmeshfem2D xmeshfem2D.trace xspecfem2D xspecfem2D.trace $O/*.o *.o $O/*.il *.mod core *.gnu *.ps Ux*.bin Uz*.bin image*.pnm xconvolve_source_timefunction *receiver_line_* plotgnu source.txt *.sem* xcreate_earth_model
+ /bin/rm -r -f xmeshfem2D xmeshfem2D.trace xspecfem2D xspecfem2D.trace $O/*.o *.o $O/*.il *.mod core xconvolve_source_timefunction
meshfem2D: $(OBJS_MESHFEM2D)
$(LINK) $(FLAGS_CHECK) -o xmeshfem2D $(OBJS_MESHFEM2D)
@@ -51,9 +51,6 @@
convolve_source_timefunction: $O/convolve_source_timefunction.o
${F90} $(FLAGS_CHECK) -o xconvolve_source_timefunction $O/convolve_source_timefunction.o
-create_earth_model: $O/create_earth_model.o
- ${F90} $(FLAGS_CHECK) -o xcreate_earth_model $O/create_earth_model.o
-
$O/checkgrid.o: checkgrid.f90 constants.h
${F90} $(FLAGS_CHECK) -c -o $O/checkgrid.o checkgrid.f90
@@ -69,18 +66,12 @@
$O/convolve_source_timefunction.o: convolve_source_timefunction.f90
${F90} $(FLAGS_CHECK) -c -o $O/convolve_source_timefunction.o convolve_source_timefunction.f90
-$O/create_earth_model.o: create_earth_model.f90
- ${F90} $(FLAGS_CHECK) -c -o $O/create_earth_model.o create_earth_model.f90
-
$O/read_value_parameters.o: read_value_parameters.f90
${F90} $(FLAGS_CHECK) -c -o $O/read_value_parameters.o read_value_parameters.f90
$O/datim.o: datim.f90 constants.h
${F90} $(FLAGS_CHECK) -c -o $O/datim.o datim.f90
-$O/defarrays.o: defarrays.f90 constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/defarrays.o defarrays.f90
-
$O/lagrange_poly.o: lagrange_poly.f90 constants.h
${F90} $(FLAGS_CHECK) -c -o $O/lagrange_poly.o lagrange_poly.f90
@@ -118,12 +109,28 @@
$O/specfem2D.o: specfem2D.f90 constants.h
${F90} $(FLAGS_NOCHECK) -c -o $O/specfem2D.o specfem2D.f90
+### use optimized compilation option for solver only
+$O/enforce_acoustic_free_surface.o: enforce_acoustic_free_surface.f90 constants.h
+ ${F90} $(FLAGS_NOCHECK) -c -o $O/enforce_acoustic_free_surface.o enforce_acoustic_free_surface.f90
+
+### use optimized compilation option for solver only
+$O/compute_forces_acoustic.o: compute_forces_acoustic.f90 constants.h
+ ${F90} $(FLAGS_NOCHECK) -c -o $O/compute_forces_acoustic.o compute_forces_acoustic.f90
+
+### use optimized compilation option for solver only
+$O/compute_forces_elastic.o: compute_forces_elastic.f90 constants.h
+ ${F90} $(FLAGS_NOCHECK) -c -o $O/compute_forces_elastic.o compute_forces_elastic.f90
+
+### use optimized compilation option for solver only
$O/compute_gradient_attenuation.o: compute_gradient_attenuation.f90 constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/compute_gradient_attenuation.o compute_gradient_attenuation.f90
+ ${F90} $(FLAGS_NOCHECK) -c -o $O/compute_gradient_attenuation.o compute_gradient_attenuation.f90
-$O/compute_gradient_fluid.o: compute_gradient_fluid.f90 constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/compute_gradient_fluid.o compute_gradient_fluid.f90
+$O/compute_vector_field.o: compute_vector_field.f90 constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/compute_vector_field.o compute_vector_field.f90
+$O/compute_pressure.o: compute_pressure.f90 constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/compute_pressure.o compute_pressure.f90
+
$O/compute_arrays_source.o: compute_arrays_source.f90 constants.h
${F90} $(FLAGS_CHECK) -c -o $O/compute_arrays_source.o compute_arrays_source.f90
@@ -133,6 +140,9 @@
$O/numerical_recipes.o: numerical_recipes.f90 constants.h
${F90} $(FLAGS_CHECK) -c -o $O/numerical_recipes.o numerical_recipes.f90
+$O/define_external_model.o: define_external_model.f90 constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/define_external_model.o define_external_model.f90
+
$O/write_seismograms.o: write_seismograms.f90 constants.h
${F90} $(FLAGS_CHECK) -c -o $O/write_seismograms.o write_seismograms.f90
Modified: seismo/2D/SPECFEM2D/trunk/checkgrid.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/checkgrid.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/checkgrid.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,50 +1,207 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
- subroutine checkgrid(deltat,f0,t0,initialfield,rsizemin,rsizemax, &
- cpoverdxmax,rlamdaSmin,rlamdaSmax,rlamdaPmin,rlamdaPmax)
+ subroutine checkgrid(vpext,vsext,rhoext,density,elastcoef,ibool,kmato,coord,npoin,vpmin,vpmax, &
+ assign_external_model,nspec,numat,deltat,f0,t0,initialfield,time_function_type, &
+ coorg,xinterp,zinterp,shapeint,knods,simulation_title,npgeo,pointsdisp,ngnod,any_elastic)
-!
-!---- verification taille des mailles, stabilite et nb de points par lambda
-!
+! check the mesh, stability and number of points per wavelength
implicit none
include "constants.h"
- double precision f0,t0
- double precision deltat,rsizemin,rsizemax,cpoverdxmax, &
- rlamdaSmin,rlamdaSmax,rlamdaPmin,rlamdaPmax
+ integer i,j,ispec,material,npoin,nspec,numat,time_function_type
- logical initialfield
+ integer, dimension(nspec) :: kmato
+ integer, dimension(NGLLX,NGLLX,nspec) :: ibool
-!
-!---- verification taille de grille min et max
-!
+ double precision, dimension(numat) :: density
+ double precision, dimension(4,numat) :: elastcoef
+ 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 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
+
+ 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
+ double precision :: percent_GLL(NGLLX_MAX_STABILITY)
+
+ 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
+
+ integer knods(ngnod,nspec)
+
+ double precision xinterp(pointsdisp,pointsdisp),zinterp(pointsdisp,pointsdisp)
+ double precision shapeint(ngnod,pointsdisp,pointsdisp)
+
+ double precision coorg(NDIM,npgeo)
+
+! title of the plot
+ character(len=60) simulation_title
+
+! define percentage of smallest distance between GLL points for NGLLX points
+! percentages were computed by calling the GLL points routine for each degree
+ percent_GLL(2) = 100.d0
+ percent_GLL(3) = 50.d0
+ percent_GLL(4) = 27.639320225002102d0
+ percent_GLL(5) = 17.267316464601141d0
+ percent_GLL(6) = 11.747233803526763d0
+ percent_GLL(7) = 8.4888051860716516d0
+ percent_GLL(8) = 6.4129925745196719d0
+ percent_GLL(9) = 5.0121002294269914d0
+ percent_GLL(10) = 4.0233045916770571d0
+ percent_GLL(11) = 3.2999284795970416d0
+ percent_GLL(12) = 2.7550363888558858d0
+ percent_GLL(13) = 2.3345076678918053d0
+ percent_GLL(14) = 2.0032477366369594d0
+ percent_GLL(15) = 1.7377036748080721d0
+
+! convert to real percentage
+ percent_GLL(:) = percent_GLL(:) / 100.d0
+
+ if(NGLLX > NGLLX_MAX_STABILITY) stop 'cannot estimate the stability condition for that degree'
+
+!---- compute parameters for the spectral elements
+
+ vpmin = HUGEVAL
+ vsmin = HUGEVAL
+ vpmax = -HUGEVAL
+ vsmax = -HUGEVAL
+ densmin = HUGEVAL
+ densmax = -HUGEVAL
+
+ distance_min = HUGEVAL
+ distance_max = -HUGEVAL
+
+ courant_stability_number_max = -HUGEVAL
+
+ lambdaPmin = HUGEVAL
+ lambdaSmin = HUGEVAL
+ lambdaPmax = -HUGEVAL
+ lambdaSmax = -HUGEVAL
+
+ do ispec=1,nspec
+
+ material = kmato(ispec)
+
+ mu = elastcoef(2,material)
+ lambdaplus2mu = elastcoef(3,material)
+ denst = density(material)
+
+ cploc = sqrt(lambdaplus2mu/denst)
+ csloc = sqrt(mu/denst)
+
+ vpmax_local = -HUGEVAL
+ vpmin_local = HUGEVAL
+ vsmin_local = HUGEVAL
+
+ distance_min_local = HUGEVAL
+ distance_max_local = -HUGEVAL
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+!--- if heterogeneous formulation with external velocity model
+ if(assign_external_model) then
+ cploc = 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)
+
+! ignore fluid regions with Vs = 0
+ if(csloc > 0.0001d0) vsmin = min(vsmin,csloc)
+ vsmax = max(vsmax,csloc)
+
+ 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)
+
+ enddo
+ enddo
+
+! compute minimum and maximum size of edges of this grid cell
+ distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
+ (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
+
+ distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
+
+ distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
+
+ distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
+ (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
+
+ distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
+ distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
+
+ 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)))
+
+! ignore fluid regions with Vs = 0
+ if(csloc > 0.0001d0) then
+ lambdaSmin = min(lambdaSmin,vsmin_local / (distance_max_local / (NGLLX - 1)))
+ 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)))
+
+ enddo
+
write(IOUT,*)
- write(IOUT,*) '******************************************'
- write(IOUT,*) '*** Verification parametres simulation ***'
- write(IOUT,*) '******************************************'
+ write(IOUT,*) '********'
+ write(IOUT,*) 'Model: P velocity min,max = ',vpmin,vpmax
+ write(IOUT,*) 'Model: S velocity min,max = ',vsmin,vsmax
+ write(IOUT,*) 'Model: density min,max = ',densmin,densmax
+ write(IOUT,*) '********'
write(IOUT,*)
- write(IOUT,*) '*** Taille max grille = ',rsizemax
- write(IOUT,*) '*** Taille min grille = ',rsizemin
- write(IOUT,*) '*** Rapport max/min = ',rsizemax/rsizemin
+
write(IOUT,*)
- write(IOUT,*) '*** Stabilite max vitesse P = ',cpoverdxmax*deltat
+ write(IOUT,*) '*********************************************'
+ write(IOUT,*) '*** Verification of simulation parameters ***'
+ write(IOUT,*) '*********************************************'
write(IOUT,*)
+ write(IOUT,*) '*** Max grid size = ',distance_max
+ write(IOUT,*) '*** Min grid size = ',distance_min
+ write(IOUT,*) '*** Max/min ratio = ',distance_max/distance_min
+ write(IOUT,*)
+ write(IOUT,*) '*** Max stability for P wave velocity = ',courant_stability_number_max
+ write(IOUT,*)
- if(.not. initialfield) then
+! 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
write(IOUT,*) ' Onset time = ',t0
write(IOUT,*) ' Fundamental period = ',1.d0/f0
@@ -55,18 +212,802 @@
write(IOUT,*) ' --> onset time ok'
endif
write(IOUT,*) '----'
- write(IOUT,*) ' Nb pts / lambda P max f0 = ',NGLLX*rlamdaPmax/f0
- write(IOUT,*) ' Nb pts / lambda P min f0 = ',NGLLX*rlamdaPmin/f0
- write(IOUT,*) ' Nb pts / lambda P max fmax = ',NGLLX*rlamdaPmax/(2.5d0*f0)
- write(IOUT,*) ' Nb pts / lambda P min fmax = ',NGLLX*rlamdaPmin/(2.5d0*f0)
+ write(IOUT,*) ' Nb pts / lambdaPmin_fmax max = ',lambdaPmax/(2.5d0*f0)
+ write(IOUT,*) ' Nb pts / lambdaPmin_fmax min = ',lambdaPmin/(2.5d0*f0)
write(IOUT,*) '----'
- write(IOUT,*) ' Nb pts / lambda S max f0 = ',NGLLX*rlamdaSmax/f0
- write(IOUT,*) ' Nb pts / lambda S min f0 = ',NGLLX*rlamdaSmin/f0
- write(IOUT,*) ' Nb pts / lambda S max fmax = ',NGLLX*rlamdaSmax/(2.5d0*f0)
- write(IOUT,*) ' Nb pts / lambda S min fmax = ',NGLLX*rlamdaSmin/(2.5d0*f0)
+ write(IOUT,*) ' Nb pts / lambdaSmin_fmax max = ',lambdaSmax/(2.5d0*f0)
+ write(IOUT,*) ' Nb pts / lambdaSmin_fmax min = ',lambdaSmin/(2.5d0*f0)
write(IOUT,*) '----'
endif
+!
+!--------------------------------------------------------------------------------
+!
+
+! A4 or US letter paper
+ if(US_LETTER) then
+ usoffset = 1.75d0
+ sizex = 27.94d0
+ sizez = 21.59d0
+ else
+ usoffset = 0.d0
+ sizex = 29.7d0
+ sizez = 21.d0
+ endif
+
+! height of domain numbers in centimeters
+ height = 0.25d0
+
+! get minimum and maximum values of mesh coordinates
+ xmin = minval(coord(1,:))
+ zmin = minval(coord(2,:))
+ xmax = maxval(coord(1,:))
+ zmax = maxval(coord(2,:))
+
+! ratio of physical page size/size of the domain meshed
+ ratio_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) / 100.d0
+
+ print *
+ print *,'Creating PostScript file with stability condition'
+
+!
+!---- open PostScript file
+!
+ open(unit=24,file='OUTPUT_FILES/mesh_stability.ps',status='unknown')
+
+!
+!---- write PostScript header
+!
+ write(24,10) simulation_title
+ write(24,*) '/CM {28.5 mul} def'
+ write(24,*) '/LR {rlineto} def'
+ write(24,*) '/LT {lineto} def'
+ write(24,*) '/L {lineto} def'
+ write(24,*) '/MR {rmoveto} def'
+ write(24,*) '/MV {moveto} def'
+ write(24,*) '/M {moveto} def'
+ write(24,*) '/MK {mark} def'
+ write(24,*) '/ST {stroke} def'
+ write(24,*) '/CP {closepath} def'
+ write(24,*) '/RG {setrgbcolor} def'
+ write(24,*) '/GF {gsave fill grestore} def'
+ write(24,*) '/GG {0 setgray ST} def'
+ write(24,*) '/GC {Colmesh ST} def'
+ write(24,*) '/RF {setrgbcolor fill} def'
+ write(24,*) '/SF {setgray fill} def'
+ write(24,*) '/GS {gsave} def'
+ write(24,*) '/GR {grestore} def'
+ write(24,*) '/SLW {setlinewidth} def'
+ write(24,*) '/SCSF {scalefont setfont} def'
+ write(24,*) '% different useful symbols'
+ write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
+ write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/Cross {GS 0.05 CM SLW'
+ write(24,*) 'GS 3 3 MR -6. -6. LR ST GR'
+ write(24,*) 'GS 3 -3 MR -6. 6. LR ST GR'
+ write(24,*) '0.01 CM SLW} def'
+ write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
+ write(24,*) '/Diamond {GS 0.05 CM SLW 0 4.2 MR'
+ write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
+ write(24,*) 'GR 0.01 CM SLW} def'
+ write(24,*) '%'
+ write(24,*) '% macro to draw the contour of the elements'
+ write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
+ write(24,*) '%'
+ write(24,*) '.01 CM SLW'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.35 CM SCSF'
+ write(24,*) '%'
+ write(24,*) '/vshift ',-height/2,' CM def'
+ write(24,*) '/Rshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop neg vshift MR show } def'
+ write(24,*) '/Cshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
+ write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM SCSF} def'
+ write(24,*) '%'
+ write(24,*) 'gsave newpath 90 rotate'
+ write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '%'
+
+!
+!--- write captions of PostScript figure
+!
+ write(24,*) '0 setgray'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.5 CM SCSF'
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM SCSF'
+ write(24,*) '.4 .9 .9 setrgbcolor'
+ write(24,*) '11 CM 1.1 CM MV'
+ write(24,*) '(X axis) show'
+ write(24,*) '%'
+ write(24,*) '1.4 CM 9.5 CM MV'
+ write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
+ write(24,*) '(Y axis) show'
+ write(24,*) 'grestore'
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.7 CM SCSF'
+ write(24,*) '.8 0 .8 setrgbcolor'
+ write(24,*) '24.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(Mesh stability condition \(red = bad\)) show'
+ write(24,*) 'grestore'
+ write(24,*) '25.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(',simulation_title,') show'
+ write(24,*) 'grestore'
+ write(24,*) '26.45 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(2D Spectral Element Method) show'
+ write(24,*) 'grestore'
+
+ write(24,*) '%'
+ write(24,*) '1 1 scale'
+ write(24,*) '%'
+
+!
+!---- draw the spectral element mesh
+!
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+ write(24,*) '0 setgray'
+
+ do ispec = 1, nspec
+
+ write(24,*) '% elem ',ispec
+
+ do i=1,pointsdisp
+ do j=1,pointsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ write(24,*) 'MK'
+ write(24,681) x1,z1
+
+! draw straight lines if elements have 4 nodes
+
+ ir=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ ir=pointsdisp
+ is=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ is=pointsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ write(24,*) 'CO'
+
+ material = kmato(ispec)
+
+ mu = elastcoef(2,material)
+ lambdaplus2mu = elastcoef(3,material)
+ denst = density(material)
+
+ cploc = sqrt(lambdaplus2mu/denst)
+ csloc = sqrt(mu/denst)
+
+ vpmax_local = -HUGEVAL
+ vpmin_local = HUGEVAL
+ vsmin_local = HUGEVAL
+
+ distance_min_local = HUGEVAL
+ distance_max_local = -HUGEVAL
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+!--- if heterogeneous formulation with external velocity model
+ if(assign_external_model) then
+ cploc = 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)
+ vsmin_local = min(vsmin_local,csloc)
+
+ enddo
+ enddo
+
+! compute minimum and maximum size of edges of this grid cell
+ distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
+ (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
+
+ distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
+
+ distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
+
+ distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
+ (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
+
+ distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
+ distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
+
+ 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))
+
+! display bad elements that are above 80% of the threshold
+ if(courant_stability_number >= 0.80 * courant_stability_number_max) then
+ write(24,*) '1 0 0 RG GF GG'
+ else
+! do not color the elements if below the threshold
+ write(24,*) 'ST'
+ endif
+
+ enddo ! end of loop on all the spectral elements
+
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+
+ print *,'End of creation of PostScript file with stability condition'
+
+!
+!--------------------------------------------------------------------------------
+!
+
+ print *
+ print *,'Creating PostScript file with mesh dispersion'
+
+!
+!---- open PostScript file
+!
+ if(any_elastic) 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')
+ endif
+
+!
+!---- write PostScript header
+!
+ write(24,10) simulation_title
+ write(24,*) '/CM {28.5 mul} def'
+ write(24,*) '/LR {rlineto} def'
+ write(24,*) '/LT {lineto} def'
+ write(24,*) '/L {lineto} def'
+ write(24,*) '/MR {rmoveto} def'
+ write(24,*) '/MV {moveto} def'
+ write(24,*) '/M {moveto} def'
+ write(24,*) '/MK {mark} def'
+ write(24,*) '/ST {stroke} def'
+ write(24,*) '/CP {closepath} def'
+ write(24,*) '/RG {setrgbcolor} def'
+ write(24,*) '/GF {gsave fill grestore} def'
+ write(24,*) '/GG {0 setgray ST} def'
+ write(24,*) '/GC {Colmesh ST} def'
+ write(24,*) '/RF {setrgbcolor fill} def'
+ write(24,*) '/SF {setgray fill} def'
+ write(24,*) '/GS {gsave} def'
+ write(24,*) '/GR {grestore} def'
+ write(24,*) '/SLW {setlinewidth} def'
+ write(24,*) '/SCSF {scalefont setfont} def'
+ write(24,*) '% different useful symbols'
+ write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
+ write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/Cross {GS 0.05 CM SLW'
+ write(24,*) 'GS 3 3 MR -6. -6. LR ST GR'
+ write(24,*) 'GS 3 -3 MR -6. 6. LR ST GR'
+ write(24,*) '0.01 CM SLW} def'
+ write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
+ write(24,*) '/Diamond {GS 0.05 CM SLW 0 4.2 MR'
+ write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
+ write(24,*) 'GR 0.01 CM SLW} def'
+ write(24,*) '%'
+ write(24,*) '% macro to draw the contour of the elements'
+ write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
+ write(24,*) '%'
+ write(24,*) '.01 CM SLW'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.35 CM SCSF'
+ write(24,*) '%'
+ write(24,*) '/vshift ',-height/2,' CM def'
+ write(24,*) '/Rshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop neg vshift MR show } def'
+ write(24,*) '/Cshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
+ write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM SCSF} def'
+ write(24,*) '%'
+ write(24,*) 'gsave newpath 90 rotate'
+ write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '%'
+
+!
+!--- write captions of PostScript figure
+!
+ write(24,*) '0 setgray'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.5 CM SCSF'
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM SCSF'
+ write(24,*) '.4 .9 .9 setrgbcolor'
+ write(24,*) '11 CM 1.1 CM MV'
+ write(24,*) '(X axis) show'
+ write(24,*) '%'
+ write(24,*) '1.4 CM 9.5 CM MV'
+ write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
+ write(24,*) '(Y axis) show'
+ write(24,*) 'grestore'
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.7 CM SCSF'
+ write(24,*) '.8 0 .8 setrgbcolor'
+ write(24,*) '24.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ if(any_elastic) then
+ write(24,*) '(Mesh elastic S-wave dispersion \(red = good, blue = bad\)) show'
+ else
+ write(24,*) '(Mesh acoustic P-wave dispersion \(red = good, blue = bad\)) show'
+ endif
+ write(24,*) 'grestore'
+ write(24,*) '25.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(',simulation_title,') show'
+ write(24,*) 'grestore'
+ write(24,*) '26.45 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(2D Spectral Element Method) show'
+ write(24,*) 'grestore'
+
+ write(24,*) '%'
+ write(24,*) '1 1 scale'
+ write(24,*) '%'
+
+!
+!---- draw the spectral element mesh
+!
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+ write(24,*) '0 setgray'
+
+ do ispec = 1, nspec
+
+ write(24,*) '% elem ',ispec
+
+ do i=1,pointsdisp
+ do j=1,pointsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ write(24,*) 'MK'
+ write(24,681) x1,z1
+
+! draw straight lines if elements have 4 nodes
+
+ ir=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ ir=pointsdisp
+ is=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ is=pointsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ write(24,*) 'CO'
+
+ material = kmato(ispec)
+
+ mu = elastcoef(2,material)
+ lambdaplus2mu = elastcoef(3,material)
+ denst = density(material)
+
+ cploc = sqrt(lambdaplus2mu/denst)
+ csloc = sqrt(mu/denst)
+
+ vpmax_local = -HUGEVAL
+ vpmin_local = HUGEVAL
+ vsmin_local = HUGEVAL
+
+ distance_min_local = HUGEVAL
+ distance_max_local = -HUGEVAL
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+!--- if heterogeneous formulation with external velocity model
+ if(assign_external_model) then
+ cploc = 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)
+ vsmin_local = min(vsmin_local,csloc)
+
+ enddo
+ enddo
+
+! compute minimum and maximum size of edges of this grid cell
+ distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
+ (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
+
+ distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
+
+ distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
+
+ distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
+ (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
+
+ distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
+ distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
+
+ distance_min = min(distance_min,distance_min_local)
+ 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) then
+
+! ignore fluid regions with Vs = 0
+ if(csloc > 0.0001d0) then
+
+ lambdaS_local = vsmin_local / (distance_max_local / (NGLLX - 1))
+
+! display very good elements that are above 80% of the threshold in red
+ if(lambdaS_local >= 0.80 * lambdaSmax) then
+ write(24,*) '1 0 0 RG GF GG'
+
+! display bad elements that are below 120% of the threshold in blue
+ else if(lambdaS_local <= 1.20 * lambdaSmin) then
+ write(24,*) '0 0 1 RG GF GG'
+
+ else
+! do not color the elements if not close to the threshold
+ write(24,*) 'ST'
+ endif
+
+ else
+! do not color the elements if S-wave velocity undefined
+ write(24,*) 'ST'
+ endif
+
+! 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))
+
+! display very good elements that are above 80% of the threshold in red
+ if(lambdaP_local >= 0.80 * lambdaPmax) then
+ write(24,*) '1 0 0 RG GF GG'
+
+! display bad elements that are below 120% of the threshold in blue
+ else if(lambdaP_local <= 1.20 * lambdaPmin) then
+ write(24,*) '0 0 1 RG GF GG'
+
+ else
+! do not color the elements if not close to the threshold
+ write(24,*) 'ST'
+ endif
+
+ endif
+
+ enddo ! end of loop on all the spectral elements
+
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+
+ print *,'End of creation of PostScript file with mesh dispersion'
+
+!
+!--------------------------------------------------------------------------------
+!
+
+ print *
+ print *,'Creating PostScript file with velocity model'
+
+!
+!---- open PostScript file
+!
+ open(unit=24,file='OUTPUT_FILES/P_velocity_model.ps',status='unknown')
+
+!
+!---- write PostScript header
+!
+ write(24,10) simulation_title
+ write(24,*) '/CM {28.5 mul} def'
+ write(24,*) '/LR {rlineto} def'
+ write(24,*) '/LT {lineto} def'
+ write(24,*) '/L {lineto} def'
+ write(24,*) '/MR {rmoveto} def'
+ write(24,*) '/MV {moveto} def'
+ write(24,*) '/M {moveto} def'
+ write(24,*) '/MK {mark} def'
+ write(24,*) '/ST {stroke} def'
+ write(24,*) '/CP {closepath} def'
+ write(24,*) '/RG {setrgbcolor} def'
+ write(24,*) '/GF {gsave fill grestore} def'
+ write(24,*) '/GG {0 setgray ST} def'
+ write(24,*) '/GC {Colmesh ST} def'
+ write(24,*) '/RF {setrgbcolor fill} def'
+ write(24,*) '/SF {setgray fill} def'
+ write(24,*) '/GS {gsave} def'
+ write(24,*) '/GR {grestore} def'
+ write(24,*) '/SLW {setlinewidth} def'
+ write(24,*) '/SCSF {scalefont setfont} def'
+ write(24,*) '% different useful symbols'
+ write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
+ write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/Cross {GS 0.05 CM SLW'
+ write(24,*) 'GS 3 3 MR -6. -6. LR ST GR'
+ write(24,*) 'GS 3 -3 MR -6. 6. LR ST GR'
+ write(24,*) '0.01 CM SLW} def'
+ write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
+ write(24,*) '/Diamond {GS 0.05 CM SLW 0 4.2 MR'
+ write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
+ write(24,*) 'GR 0.01 CM SLW} def'
+ write(24,*) '%'
+ write(24,*) '% macro to draw the contour of the elements'
+ write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
+ write(24,*) '%'
+ write(24,*) '.01 CM SLW'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.35 CM SCSF'
+ write(24,*) '%'
+ write(24,*) '/vshift ',-height/2,' CM def'
+ write(24,*) '/Rshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop neg vshift MR show } def'
+ write(24,*) '/Cshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
+ write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM SCSF} def'
+ write(24,*) '%'
+ write(24,*) 'gsave newpath 90 rotate'
+ write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '%'
+
+!
+!--- write captions of PostScript figure
+!
+ write(24,*) '0 setgray'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.5 CM SCSF'
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM SCSF'
+ write(24,*) '.4 .9 .9 setrgbcolor'
+ write(24,*) '11 CM 1.1 CM MV'
+ write(24,*) '(X axis) show'
+ write(24,*) '%'
+ write(24,*) '1.4 CM 9.5 CM MV'
+ write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
+ write(24,*) '(Y axis) show'
+ write(24,*) 'grestore'
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.7 CM SCSF'
+ write(24,*) '.8 0 .8 setrgbcolor'
+ write(24,*) '24.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(P-velocity model \(dark = fast, light = slow\)) show'
+ write(24,*) 'grestore'
+ write(24,*) '25.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(',simulation_title,') show'
+ write(24,*) 'grestore'
+ write(24,*) '26.45 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(2D Spectral Element Method) show'
+ write(24,*) 'grestore'
+
+ write(24,*) '%'
+ write(24,*) '1 1 scale'
+ write(24,*) '%'
+
+!
+!---- draw the spectral element mesh
+!
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+ write(24,*) '0 setgray'
+
+ do ispec = 1, nspec
+
+ write(24,*) '% elem ',ispec
+
+ do i=1,pointsdisp
+ do j=1,pointsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ write(24,*) 'MK'
+ write(24,681) x1,z1
+
+! draw straight lines if elements have 4 nodes
+
+ ir=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ ir=pointsdisp
+ is=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ is=pointsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ write(24,*) 'CO'
+
+ if((vpmax-vpmin)/vpmin > 0.02d0) then
+ if(assign_external_model) then
+! use lower-left corner
+ x1 = (vpext(1,1,ispec)-vpmin) / (vpmax-vpmin)
+ else
+ material = kmato(ispec)
+ mu = elastcoef(2,material)
+ lambdaplus2mu = elastcoef(3,material)
+ denst = density(material)
+ cploc = sqrt(lambdaplus2mu/denst)
+ x1 = (cploc-vpmin)/(vpmax-vpmin)
+ endif
+ else
+ x1 = 0.5d0
+ endif
+
+! rescale to avoid very dark gray levels
+ x1 = x1*0.7 + 0.2
+ if(x1 > 1.d0) x1=1.d0
+
+! invert scale: white = vpmin, dark gray = vpmax
+ x1 = 1.d0 - x1
+
+! display P-velocity model using gray levels
+ write(24,*) sngl(x1),' setgray GF GG'
+
+ enddo ! end of loop on all the spectral elements
+
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+
+ print *,'End of creation of PostScript file with velocity model'
+
+ 10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a50,/,'%% Created by: Specfem2D',/,'%% Author: Dimitri Komatitsch',/,'%%')
+
+ 681 format(f6.2,1x,f6.2)
+
end subroutine checkgrid
Modified: seismo/2D/SPECFEM2D/trunk/compute_arrays_source.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_arrays_source.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/compute_arrays_source.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,13 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
Added: seismo/2D/SPECFEM2D/trunk/compute_forces_acoustic.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_forces_acoustic.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/compute_forces_acoustic.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -0,0 +1,356 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 5.2
+! ------------------------------
+!
+! Dimitri Komatitsch
+! University of Pau, France
+!
+! (c) April 2007
+!
+!========================================================================
+
+ subroutine compute_forces_acoustic(npoin,nspec,nelemabs,numat, &
+ iglob_source,ispec_selected_source,source_type,it,NSTEP,anyabs, &
+ assign_external_model,initialfield,ibool,kmato,numabs, &
+ elastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,density,elastcoef,xix,xiz,gammax,gammaz,jacobian, &
+ vpext,vsext,rhoext,source_time_function,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)
+
+! compute forces for the acoustic elements
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: npoin,nspec,nelemabs,numat,iglob_source,ispec_selected_source,source_type,it,NSTEP
+
+ logical :: anyabs,assign_external_model,initialfield
+
+ 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(4,nelemabs) :: codeabs
+
+ double precision, dimension(npoin) :: potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
+ double precision, dimension(numat) :: density
+ double precision, dimension(4,numat) :: elastcoef
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,vsext,rhoext
+ double precision, dimension(NSTEP) :: source_time_function
+
+! derivatives of Lagrange polynomials
+ double precision, dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ double precision, dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+
+! Gauss-Lobatto-Legendre weights
+ double precision, dimension(NGLLX) :: wxgll
+ double precision, dimension(NGLLZ) :: wzgll
+
+!---
+!--- local variables
+!---
+
+ integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend,jbegin,jend
+
+! spatial derivatives
+ double precision :: dux_dxi,dux_dgamma,dux_dxl,dux_dzl
+ double precision :: nx,nz,rho_vp,rho_vs,weight,xxi,zxi,xgamma,zgamma,jacobian1D
+
+ double precision, dimension(NGLLX,NGLLZ) :: tempx1,tempx2
+
+! Jacobian matrix and determinant
+ double precision :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+! material properties of the elastic medium
+ double precision :: mul_relaxed,lambdal_relaxed,kappal,cpl,csl,rhol
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+!---
+!--- acoustic spectral element
+!---
+ if(.not. elastic(ispec)) then
+
+! 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
+ dux_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 + potential_acoustic(ibool(k,j,ispec))*hprime_xx(k,i)
+ dux_dgamma = dux_dgamma + potential_acoustic(ibool(i,k,ispec))*hprime_zz(k,j)
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+! derivatives of potential
+ dux_dxl = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ jacobianl = jacobian(i,j,ispec)
+
+! for acoustic medium
+! also add GLL integration weights
+ tempx1(i,j) = wzgll(j)*jacobianl*(xixl*dux_dxl + xizl*dux_dzl)
+ tempx2(i,j) = wxgll(i)*jacobianl*(gammaxl*dux_dxl + gammazl*dux_dzl)
+
+ enddo
+ enddo
+
+!
+! second double-loop over GLL to compute all the terms
+!
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+! along x direction and z direction
+! and assemble the contributions
+ do k = 1,NGLLX
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - &
+ (tempx1(k,j)*hprimewgll_xx(i,k) + tempx2(i,k)*hprimewgll_zz(j,k))
+ enddo
+
+ enddo ! second loop over the GLL points
+ enddo
+
+ endif ! end of test if acoustic element
+
+ enddo ! end of loop over all spectral elements
+
+!
+!--- absorbing boundaries
+!
+ if(anyabs) then
+
+ do ispecabs=1,nelemabs
+
+ 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))
+ kappal = lambdal_relaxed + TWO*mul_relaxed/3.d0
+ cpl = sqrt((kappal + 4.d0*mul_relaxed/3.d0)/rhol)
+ csl = sqrt(mul_relaxed/rhol)
+
+
+!--- left absorbing boundary
+ if(codeabs(ILEFT,ispecabs)) then
+
+ i = 1
+
+ jbegin = jbegin_left(ispecabs)
+ jend = jend_left(ispecabs)
+
+ do j = jbegin,jend
+
+ iglob = ibool(i,j,ispec)
+
+ zgamma = xix(i,j,ispec) * jacobian(i,j,ispec)
+
+! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ rho_vp = rhol*cpl
+ rho_vs = rhol*csl
+
+ xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
+ zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+
+ weight = jacobian1D * wzgll(j)
+
+! Sommerfeld condition if acoustic
+ if(.not. elastic(ispec)) then
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl
+ endif
+
+ enddo
+
+ endif ! end of left absorbing boundary
+
+!--- right absorbing boundary
+ if(codeabs(IRIGHT,ispecabs)) then
+
+ i = NGLLX
+
+ jbegin = jbegin_right(ispecabs)
+ jend = jend_right(ispecabs)
+
+ do j = jbegin,jend
+
+ iglob = ibool(i,j,ispec)
+
+ zgamma = xix(i,j,ispec) * jacobian(i,j,ispec)
+
+! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ rho_vp = rhol*cpl
+ rho_vs = rhol*csl
+
+ xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
+ zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+
+ weight = jacobian1D * wzgll(j)
+
+! Sommerfeld condition if acoustic
+ if(.not. elastic(ispec)) then
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl
+ endif
+
+ enddo
+
+ endif ! end of right absorbing boundary
+
+!--- bottom absorbing boundary
+ if(codeabs(IBOTTOM,ispecabs)) then
+
+ j = 1
+
+ ibegin = ibegin_bottom(ispecabs)
+ iend = iend_bottom(ispecabs)
+
+! exclude corners to make sure there is no contradiction on the normal
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+
+ do i = ibegin,iend
+
+ iglob = ibool(i,j,ispec)
+
+ xxi = gammaz(i,j,ispec) * jacobian(i,j,ispec)
+
+! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ rho_vp = rhol*cpl
+ rho_vs = rhol*csl
+
+ xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
+ zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+
+ weight = jacobian1D * wxgll(i)
+
+! Sommerfeld condition if acoustic
+ if(.not. elastic(ispec)) then
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl
+ endif
+
+ enddo
+
+ endif ! end of bottom absorbing boundary
+
+!--- top absorbing boundary
+ if(codeabs(ITOP,ispecabs)) then
+
+ j = NGLLZ
+
+ ibegin = ibegin_top(ispecabs)
+ iend = iend_top(ispecabs)
+
+! exclude corners to make sure there is no contradiction on the normal
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+
+ do i = ibegin,iend
+
+ iglob = ibool(i,j,ispec)
+
+ xxi = gammaz(i,j,ispec) * jacobian(i,j,ispec)
+
+! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ rho_vp = rhol*cpl
+ rho_vs = rhol*csl
+
+ xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
+ zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+
+ weight = jacobian1D * wxgll(i)
+
+! Sommerfeld condition if acoustic
+ if(.not. elastic(ispec)) then
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) - potential_dot_acoustic(iglob)*weight/cpl
+ endif
+
+ enddo
+
+ endif ! end of top absorbing boundary
+
+ enddo
+
+ endif ! end of absorbing boundaries
+
+
+! --- add the source
+ if(.not. initialfield) then
+
+! collocated force
+! beware, for acoustic medium, source is a pressure source
+ if(source_type == 1) then
+ if(.not. elastic(ispec_selected_source)) then
+ potential_dot_dot_acoustic(iglob_source) = potential_dot_dot_acoustic(iglob_source) + source_time_function(it)
+ endif
+
+! moment tensor
+ else if(source_type == 2) then
+
+ if(.not. elastic(ispec_selected_source)) stop 'cannot have moment tensor source in acoustic element'
+
+ endif
+
+ else
+ stop 'wrong source type'
+ endif
+
+ end subroutine compute_forces_acoustic
+
Added: seismo/2D/SPECFEM2D/trunk/compute_forces_elastic.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_forces_elastic.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/compute_forces_elastic.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -0,0 +1,582 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 5.2
+! ------------------------------
+!
+! Dimitri Komatitsch
+! University of Pau, France
+!
+! (c) April 2007
+!
+!========================================================================
+
+ subroutine compute_forces_elastic(npoin,nspec,nelemabs,numat,iglob_source, &
+ ispec_selected_source,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_mech1,e11_mech1, &
+ e13_mech1,e1_mech2,e11_mech2,e13_mech2,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)
+
+! compute forces for the elastic elements
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: npoin,nspec,nelemabs,numat,iglob_source,ispec_selected_source,source_type,it,NSTEP
+
+ logical :: anyabs,assign_external_model,initialfield,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON
+
+ double precision :: angleforce,deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+ integer, dimension(nspec) :: kmato
+ integer, dimension(nelemabs) :: numabs
+
+ logical, dimension(nspec) :: elastic
+ logical, dimension(4,nelemabs) :: codeabs
+
+ double precision, dimension(NDIM,npoin) :: accel_elastic,veloc_elastic,displ_elastic
+ double precision, dimension(numat) :: density
+ double precision, dimension(4,numat) :: elastcoef
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz,jacobian
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: vpext,vsext,rhoext
+ double precision, dimension(NSTEP) :: source_time_function
+ double precision, dimension(NDIM,NGLLX,NGLLZ) :: sourcearray
+
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: &
+ e1_mech1,e11_mech1,e13_mech1,e1_mech2,e11_mech2,e13_mech2, &
+ dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
+
+! derivatives of Lagrange polynomials
+ double precision, dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ double precision, dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+
+! Gauss-Lobatto-Legendre weights
+ double precision, dimension(NGLLX) :: wxgll
+ double precision, dimension(NGLLZ) :: wzgll
+
+!---
+!--- local variables
+!---
+
+ integer :: ispec,i,j,k,iglob,ispecabs,ibegin,iend
+
+! spatial derivatives
+ double precision :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
+ double precision :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ double precision :: sigma_xx,sigma_xz,sigma_zz
+ double precision :: nx,nz,vx,vz,vn,rho_vp,rho_vs,tx,tz,weight,xxi,zxi,xgamma,zgamma,jacobian1D
+
+ double precision, dimension(NGLLX,NGLLZ) :: tempx1,tempx2,tempz1,tempz2
+
+! Jacobian matrix and determinant
+ double precision :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+! material properties of the elastic medium
+ double precision :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,kappal,cpl,csl,rhol, &
+ lambdal_unrelaxed,mul_unrelaxed,lambdalplus2mul_unrelaxed
+
+! for attenuation
+ double precision :: Un,Unp1,tauinv,Sn,Snp1,theta_n,theta_np1,tauinvsquare,tauinvcube,tauinvUn
+
+! compute Grad(displ_elastic) at time step n for attenuation
+ if(TURN_ATTENUATION_ON) call compute_gradient_attenuation(displ_elastic,dux_dxl_n,duz_dxl_n, &
+ dux_dzl_n,duz_dzl_n,xix,xiz,gammax,gammaz,ibool,elastic,hprime_xx,hprime_zz,nspec,npoin)
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+!---
+!--- elastic spectral element
+!---
+ 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))
+
+! first double loop over GLL points to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+!--- if external medium, get elastic parameters of current grid point
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ mul_relaxed = rhol*csl*csl
+ lambdal_relaxed = rhol*cpl*cpl - TWO*mul_relaxed
+ lambdalplus2mul_relaxed = lambdal_relaxed + TWO*mul_relaxed
+ endif
+
+! 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 + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(k,i)
+ duz_dxi = duz_dxi + displ_elastic(2,ibool(k,j,ispec))*hprime_xx(k,i)
+ dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec))*hprime_zz(k,j)
+ duz_dgamma = duz_dgamma + displ_elastic(2,ibool(i,k,ispec))*hprime_zz(k,j)
+ 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
+ dux_dzl = dux_dxi*xizl + dux_dgamma*gammazl
+
+ duz_dxl = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl = duz_dxi*xizl + duz_dgamma*gammazl
+
+! compute stress tensor (include attenuation or anisotropy if needed)
+
+ if(TURN_ATTENUATION_ON) then
+
+! 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 - mul_relaxed * Mu_nu2
+ mul_unrelaxed = mul_relaxed * Mu_nu2
+ 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_xz = mul_unrelaxed*(duz_dxl + dux_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
+ sigma_xx = sigma_xx + (lambdal_relaxed + mul_relaxed)* &
+ (e1_mech1(i,j,ispec) + e1_mech2(i,j,ispec)) + TWO * mul_relaxed * (e11_mech1(i,j,ispec) + e11_mech2(i,j,ispec))
+ sigma_xz = sigma_xz + mul_relaxed * (e13_mech1(i,j,ispec) + e13_mech2(i,j,ispec))
+ sigma_zz = sigma_zz + (lambdal_relaxed + mul_relaxed)* &
+ (e1_mech1(i,j,ispec) + e1_mech2(i,j,ispec)) - TWO * mul_relaxed * (e11_mech1(i,j,ispec) + e11_mech2(i,j,ispec))
+
+ else
+
+! 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
+
+ endif
+
+! 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
+
+ jacobianl = jacobian(i,j,ispec)
+
+! weak formulation term based on stress tensor (non-symmetric form)
+! also add GLL integration weights
+ tempx1(i,j) = wzgll(j)*jacobianl*(sigma_xx*xixl+sigma_xz*xizl)
+ tempz1(i,j) = wzgll(j)*jacobianl*(sigma_xz*xixl+sigma_zz*xizl)
+
+ tempx2(i,j) = wxgll(i)*jacobianl*(sigma_xx*gammaxl+sigma_xz*gammazl)
+ tempz2(i,j) = wxgll(i)*jacobianl*(sigma_xz*gammaxl+sigma_zz*gammazl)
+
+ enddo
+ enddo
+
+!
+! second double-loop over GLL to compute all the terms
+!
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+! along x direction and z direction
+! and assemble the contributions
+! we can merge the two loops because NGLLX == NGLLZ
+ do k = 1,NGLLX
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - (tempx1(k,j)*hprimewgll_xx(i,k) + tempx2(i,k)*hprimewgll_zz(j,k))
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) - (tempz1(k,j)*hprimewgll_xx(i,k) + tempz2(i,k)*hprimewgll_zz(j,k))
+ enddo
+
+ enddo ! second loop over the GLL points
+ enddo
+
+ endif ! end of test if elastic element
+
+ enddo ! end of loop over all spectral elements
+
+!
+!--- absorbing boundaries
+!
+ if(anyabs) then
+
+ do ispecabs = 1,nelemabs
+
+ 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))
+ kappal = lambdal_relaxed + TWO*mul_relaxed/3.d0
+ cpl = sqrt((kappal + 4.d0*mul_relaxed/3.d0)/rhol)
+ csl = sqrt(mul_relaxed/rhol)
+
+!--- left absorbing boundary
+ if(codeabs(ILEFT,ispecabs)) then
+
+ i = 1
+
+ do j = 1,NGLLZ
+
+ iglob = ibool(i,j,ispec)
+
+! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ rho_vp = rhol*cpl
+ rho_vs = rhol*csl
+
+ xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
+ zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+
+ weight = jacobian1D * wzgll(j)
+
+! Clayton-Engquist condition if elastic
+ if(elastic(ispec)) then
+ vx = veloc_elastic(1,iglob)
+ vz = veloc_elastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+
+ tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
+ tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - tx*weight
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) - tz*weight
+ endif
+
+ enddo
+
+ endif ! end of left absorbing boundary
+
+!--- right absorbing boundary
+ if(codeabs(IRIGHT,ispecabs)) then
+
+ i = NGLLX
+
+ do j = 1,NGLLZ
+
+ iglob = ibool(i,j,ispec)
+
+! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ rho_vp = rhol*cpl
+ rho_vs = rhol*csl
+
+ xgamma = - xiz(i,j,ispec) * jacobian(i,j,ispec)
+ zgamma = + xix(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+
+ weight = jacobian1D * wzgll(j)
+
+! Clayton-Engquist condition if elastic
+ if(elastic(ispec)) then
+ vx = veloc_elastic(1,iglob)
+ vz = veloc_elastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+
+ tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
+ tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - tx*weight
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) - tz*weight
+ endif
+
+ enddo
+
+ endif ! end of right absorbing boundary
+
+!--- bottom absorbing boundary
+ if(codeabs(IBOTTOM,ispecabs)) then
+
+ j = 1
+
+! exclude corners to make sure there is no contradiction on the normal
+ ibegin = 1
+ iend = NGLLX
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+
+ do i = ibegin,iend
+
+ iglob = ibool(i,j,ispec)
+
+! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ rho_vp = rhol*cpl
+ rho_vs = rhol*csl
+
+ xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
+ zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+
+ weight = jacobian1D * wxgll(i)
+
+! Clayton-Engquist condition if elastic
+ if(elastic(ispec)) then
+ vx = veloc_elastic(1,iglob)
+ vz = veloc_elastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+
+ tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
+ tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - tx*weight
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) - tz*weight
+ endif
+
+ enddo
+
+ endif ! end of bottom absorbing boundary
+
+!--- top absorbing boundary
+ if(codeabs(ITOP,ispecabs)) then
+
+ j = NGLLZ
+
+! exclude corners to make sure there is no contradiction on the normal
+ ibegin = 1
+ iend = NGLLX
+ if(codeabs(ILEFT,ispecabs)) ibegin = 2
+ if(codeabs(IRIGHT,ispecabs)) iend = NGLLX-1
+
+ do i = ibegin,iend
+
+ iglob = ibool(i,j,ispec)
+
+! external velocity model
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ rhol = rhoext(i,j,ispec)
+ endif
+
+ rho_vp = rhol*cpl
+ rho_vs = rhol*csl
+
+ xxi = + gammaz(i,j,ispec) * jacobian(i,j,ispec)
+ zxi = - gammax(i,j,ispec) * jacobian(i,j,ispec)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+
+ weight = jacobian1D * wxgll(i)
+
+! Clayton-Engquist condition if elastic
+ if(elastic(ispec)) then
+ vx = veloc_elastic(1,iglob)
+ vz = veloc_elastic(2,iglob)
+
+ vn = nx*vx+nz*vz
+
+ tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
+ tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) - tx*weight
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) - tz*weight
+ endif
+
+ enddo
+
+ endif ! end of top absorbing boundary
+
+ enddo
+
+ endif ! end of absorbing boundaries
+
+
+! --- add the source
+ if(.not. initialfield) then
+
+! collocated force
+! beware, for acoustic medium, source is a potential, therefore source time function
+! gives shape of velocity, not displacement
+ if(source_type == 1) then
+ if(elastic(ispec_selected_source)) 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)
+ endif
+
+! moment tensor
+ else if(source_type == 2) then
+
+ if(elastic(ispec_selected_source)) then
+! 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)
+ enddo
+ enddo
+ endif
+
+ endif
+
+ else
+ stop 'wrong source type'
+ endif
+
+! implement attenuation
+ if(TURN_ATTENUATION_ON) then
+
+! compute Grad(displ_elastic) at time step n+1 for attenuation
+ call compute_gradient_attenuation(displ_elastic,dux_dxl_np1,duz_dxl_np1, &
+ dux_dzl_np1,duz_dzl_np1,xix,xiz,gammax,gammaz,ibool,elastic,hprime_xx,hprime_zz,nspec,npoin)
+
+! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
+! loop over spectral elements
+ do ispec = 1,nspec
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+ theta_n = dux_dxl_n(i,j,ispec) + duz_dzl_n(i,j,ispec)
+ theta_np1 = dux_dxl_np1(i,j,ispec) + duz_dzl_np1(i,j,ispec)
+
+! evolution e1_mech1
+ Un = e1_mech1(i,j,ispec)
+ tauinv = - inv_tau_sigma_nu1_mech1
+ tauinvsquare = tauinv * tauinv
+ tauinvcube = tauinvsquare * tauinv
+ tauinvUn = tauinv * Un
+ Sn = theta_n * phi_nu1_mech1
+ Snp1 = theta_np1 * phi_nu1_mech1
+ Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
+ twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
+ fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e1_mech1(i,j,ispec) = Unp1
+
+! evolution e1_mech2
+ Un = e1_mech2(i,j,ispec)
+ tauinv = - inv_tau_sigma_nu1_mech2
+ tauinvsquare = tauinv * tauinv
+ tauinvcube = tauinvsquare * tauinv
+ tauinvUn = tauinv * Un
+ Sn = theta_n * phi_nu1_mech2
+ Snp1 = theta_np1 * phi_nu1_mech2
+ Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
+ twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
+ fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e1_mech2(i,j,ispec) = Unp1
+
+! evolution e11_mech1
+ Un = e11_mech1(i,j,ispec)
+ tauinv = - inv_tau_sigma_nu2_mech1
+ tauinvsquare = tauinv * tauinv
+ tauinvcube = tauinvsquare * tauinv
+ tauinvUn = tauinv * Un
+ Sn = (dux_dxl_n(i,j,ispec) - theta_n/TWO) * phi_nu2_mech1
+ Snp1 = (dux_dxl_np1(i,j,ispec) - theta_np1/TWO) * phi_nu2_mech1
+ Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
+ twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
+ fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e11_mech1(i,j,ispec) = Unp1
+
+! evolution e11_mech2
+ Un = e11_mech2(i,j,ispec)
+ tauinv = - inv_tau_sigma_nu2_mech2
+ tauinvsquare = tauinv * tauinv
+ tauinvcube = tauinvsquare * tauinv
+ tauinvUn = tauinv * Un
+ Sn = (dux_dxl_n(i,j,ispec) - theta_n/TWO) * phi_nu2_mech2
+ Snp1 = (dux_dxl_np1(i,j,ispec) - theta_np1/TWO) * phi_nu2_mech2
+ Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
+ twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
+ fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e11_mech2(i,j,ispec) = Unp1
+
+! evolution e13_mech1
+ Un = e13_mech1(i,j,ispec)
+ tauinv = - inv_tau_sigma_nu2_mech1
+ tauinvsquare = tauinv * tauinv
+ tauinvcube = tauinvsquare * tauinv
+ tauinvUn = tauinv * Un
+ Sn = (dux_dzl_n(i,j,ispec) + duz_dxl_n(i,j,ispec)) * phi_nu2_mech1
+ Snp1 = (dux_dzl_np1(i,j,ispec) + duz_dxl_np1(i,j,ispec)) * phi_nu2_mech1
+ Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
+ twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
+ fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e13_mech1(i,j,ispec) = Unp1
+
+! evolution e13_mech2
+ Un = e13_mech2(i,j,ispec)
+ tauinv = - inv_tau_sigma_nu2_mech2
+ tauinvsquare = tauinv * tauinv
+ tauinvcube = tauinvsquare * tauinv
+ tauinvUn = tauinv * Un
+ Sn = (dux_dzl_n(i,j,ispec) + duz_dxl_n(i,j,ispec)) * phi_nu2_mech2
+ Snp1 = (dux_dzl_np1(i,j,ispec) + duz_dxl_np1(i,j,ispec)) * phi_nu2_mech2
+ Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
+ twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
+ fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
+ deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
+ e13_mech2(i,j,ispec) = Unp1
+
+ enddo
+ enddo
+ enddo
+
+ endif ! end of test on attenuation
+
+ end subroutine compute_forces_elastic
+
Modified: seismo/2D/SPECFEM2D/trunk/compute_gradient_attenuation.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_gradient_attenuation.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/compute_gradient_attenuation.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,88 +1,93 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
- subroutine compute_gradient_attenuation(displ,duxdxl,duzdxl,duxdzl,duzdzl, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,NSPEC,npoin)
+ subroutine compute_gradient_attenuation(displ_elastic,dux_dxl,duz_dxl,dux_dzl,duz_dzl, &
+ xix,xiz,gammax,gammaz,ibool,elastic,hprime_xx,hprime_zz,nspec,npoin)
-! compute Grad(displ) for attenuation
+! compute Grad(displ_elastic) for attenuation
implicit none
include "constants.h"
- integer NSPEC,npoin
+ integer :: nspec,npoin
- integer, dimension(NGLLX,NGLLZ,NSPEC) :: ibool
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
- double precision, dimension(NGLLX,NGLLZ,NSPEC) :: duxdxl,duzdxl,duxdzl,duzdzl,xix,xiz,gammax,gammaz
+ logical, dimension(nspec) :: elastic
- double precision, dimension(NDIM,npoin) :: displ
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: dux_dxl,duz_dxl,dux_dzl,duz_dzl,xix,xiz,gammax,gammaz
+ double precision, dimension(NDIM,npoin) :: displ_elastic
+
! array with derivatives of Lagrange polynomials
double precision, dimension(NGLLX,NGLLX) :: hprime_xx
double precision, dimension(NGLLZ,NGLLZ) :: hprime_zz
! local variables
- integer i,j,k,ispec,iglob
+ integer :: i,j,k,ispec
-! space derivatives
- double precision tempx1l,tempx2l,tempz1l,tempz2l
- double precision hp1,hp2
+! spatial derivatives
+ double precision :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
! jacobian
- double precision xixl,xizl,gammaxl,gammazl
+ double precision :: xixl,xizl,gammaxl,gammazl
! loop over spectral elements
- do ispec = 1,NSPEC
+ do ispec = 1,nspec
-! double loop over GLL to compute and store gradients
- do j = 1,NGLLZ
- do i = 1,NGLLX
+!---
+!--- elastic spectral element
+!---
+ if(elastic(ispec)) then
-! derivative along x
- tempx1l = ZERO
- tempz1l = ZERO
+! 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
+
+! first double loop over GLL points to compute and store gradients
+! we can merge the two loops because NGLLX == NGLLZ
do k = 1,NGLLX
- hp1 = hprime_xx(k,i)
- iglob = ibool(k,j,ispec)
- tempx1l = tempx1l + displ(1,iglob)*hp1
- tempz1l = tempz1l + displ(2,iglob)*hp1
+ dux_dxi = dux_dxi + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(k,i)
+ duz_dxi = duz_dxi + displ_elastic(2,ibool(k,j,ispec))*hprime_xx(k,i)
+ dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec))*hprime_zz(k,j)
+ duz_dgamma = duz_dgamma + displ_elastic(2,ibool(i,k,ispec))*hprime_zz(k,j)
enddo
-! derivative along z
- tempx2l = ZERO
- tempz2l = ZERO
- do k = 1,NGLLZ
- hp2 = hprime_zz(k,j)
- iglob = ibool(i,k,ispec)
- tempx2l = tempx2l + displ(1,iglob)*hp2
- tempz2l = tempz2l + displ(2,iglob)*hp2
- enddo
-
xixl = xix(i,j,ispec)
xizl = xiz(i,j,ispec)
gammaxl = gammax(i,j,ispec)
gammazl = gammaz(i,j,ispec)
! derivatives of displacement
- duxdxl(i,j,ispec) = tempx1l*xixl + tempx2l*gammaxl
- duxdzl(i,j,ispec) = tempx1l*xizl + tempx2l*gammazl
+ dux_dxl(i,j,ispec) = dux_dxi*xixl + dux_dgamma*gammaxl
+ dux_dzl(i,j,ispec) = dux_dxi*xizl + dux_dgamma*gammazl
- duzdxl(i,j,ispec) = tempz1l*xixl + tempz2l*gammaxl
- duzdzl(i,j,ispec) = tempz1l*xizl + tempz2l*gammazl
+ duz_dxl(i,j,ispec) = duz_dxi*xixl + duz_dgamma*gammaxl
+ duz_dzl(i,j,ispec) = duz_dxi*xizl + duz_dgamma*gammazl
+ enddo
enddo
- enddo
+
+ endif
+
enddo
end subroutine compute_gradient_attenuation
Deleted: seismo/2D/SPECFEM2D/trunk/compute_gradient_fluid.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_gradient_fluid.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/compute_gradient_fluid.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,84 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 5.1
-! ------------------------------
-!
-! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
-!
-! (c) January 2005
-!
-!========================================================================
-
- subroutine compute_gradient_fluid(potential,veloc_field_postscript, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,NSPEC,npoin)
-
-! compute Grad(potential) in fluid medium
-
- implicit none
-
- include "constants.h"
-
- integer NSPEC,npoin
-
- integer, dimension(NGLLX,NGLLZ,NSPEC) :: ibool
-
- double precision, dimension(NGLLX,NGLLZ,NSPEC) :: xix,xiz,gammax,gammaz
-
-! for compatibility with elastic arrays, potential is declared as a vector but correctly used below as a scalar
- double precision, dimension(NDIM,npoin) :: potential,veloc_field_postscript
-
-! array with derivatives of Lagrange polynomials
- double precision, dimension(NGLLX,NGLLX) :: hprime_xx
- double precision, dimension(NGLLZ,NGLLZ) :: hprime_zz
-
-! local variables
- integer i,j,k,ispec,iglob
-
-! space derivatives
- double precision tempx1l,tempx2l
- double precision hp1,hp2
-
-! jacobian
- double precision xixl,xizl,gammaxl,gammazl
-
-! loop over spectral elements
- do ispec = 1,NSPEC
-
-! double loop over GLL to compute and store gradients
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
-! derivative along x
- tempx1l = ZERO
- do k = 1,NGLLX
- hp1 = hprime_xx(k,i)
- iglob = ibool(k,j,ispec)
- tempx1l = tempx1l + potential(1,iglob)*hp1
- enddo
-
-! derivative along z
- tempx2l = ZERO
- do k = 1,NGLLZ
- hp2 = hprime_zz(k,j)
- iglob = ibool(i,k,ispec)
- tempx2l = tempx2l + potential(1,iglob)*hp2
- enddo
-
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
-
-! derivatives of velocity potential
- iglob = ibool(i,j,ispec)
- veloc_field_postscript(1,iglob) = tempx1l*xixl + tempx2l*gammaxl
- veloc_field_postscript(2,iglob) = tempx1l*xizl + tempx2l*gammazl
-
- enddo
- enddo
- enddo
-
- end subroutine compute_gradient_fluid
-
Added: seismo/2D/SPECFEM2D/trunk/compute_pressure.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_pressure.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/compute_pressure.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -0,0 +1,268 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 5.2
+! ------------------------------
+!
+! Dimitri Komatitsch
+! University of Pau, France
+!
+! (c) April 2007
+!
+!========================================================================
+
+ subroutine compute_pressure_whole_medium(potential_dot_dot_acoustic,displ_elastic,elastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
+ numat,kmato,density,elastcoef,vpext,vsext,rhoext,e1_mech1,e11_mech1, &
+ e1_mech2,e11_mech2,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON)
+
+! compute pressure in acoustic elements and in elastic elements
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nspec,npoin,numat
+
+ integer, dimension(nspec) :: kmato
+ integer, dimension(NGLLX,NGLLX,nspec) :: ibool
+
+ double precision, dimension(numat) :: density
+ double precision, dimension(4,numat) :: elastcoef
+ double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
+
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+
+ logical, dimension(nspec) :: elastic
+ double precision, dimension(npoin) :: potential_dot_dot_acoustic
+ double precision, dimension(NDIM,npoin) :: displ_elastic,vector_field_display
+
+! array with derivatives of Lagrange polynomials
+ double precision, dimension(NGLLX,NGLLX) :: hprime_xx
+ double precision, dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+ logical :: assign_external_model,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON
+
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: e1_mech1,e11_mech1,e1_mech2,e11_mech2
+
+! local variables
+ integer :: i,j,ispec,iglob
+
+! pressure in this element
+ double precision, dimension(NGLLX,NGLLX) :: pressure_element
+
+! loop over spectral elements
+ do ispec = 1,nspec
+
+! compute pressure in this element
+ call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,elastic, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
+ numat,kmato,density,elastcoef,vpext,vsext,rhoext,ispec,e1_mech1,e11_mech1, &
+ e1_mech2,e11_mech2,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON)
+
+! use vector_field_display as temporary storage, store pressure in its second component
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ vector_field_display(2,iglob) = pressure_element(i,j)
+ enddo
+ enddo
+
+ enddo
+
+ end subroutine compute_pressure_whole_medium
+
+!
+!=====================================================================
+!
+
+ subroutine compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,elastic, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
+ numat,kmato,density,elastcoef,vpext,vsext,rhoext,ispec,e1_mech1,e11_mech1, &
+ e1_mech2,e11_mech2,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON)
+
+! compute pressure in acoustic elements and in elastic elements
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,npoin,numat,ispec
+
+ integer, dimension(nspec) :: kmato
+ integer, dimension(NGLLX,NGLLX,nspec) :: ibool
+
+ double precision, dimension(numat) :: density
+ double precision, dimension(4,numat) :: elastcoef
+ double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
+
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+
+! pressure in this element
+ double precision, dimension(NGLLX,NGLLX) :: pressure_element
+
+ logical, dimension(nspec) :: elastic
+ double precision, dimension(npoin) :: potential_dot_dot_acoustic
+ double precision, dimension(NDIM,npoin) :: displ_elastic
+
+! array with derivatives of Lagrange polynomials
+ double precision, dimension(NGLLX,NGLLX) :: hprime_xx
+ double precision, dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+ logical :: assign_external_model,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON
+
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: e1_mech1,e11_mech1,e1_mech2,e11_mech2
+
+! local variables
+ integer :: i,j,k,iglob
+
+! jacobian
+ double precision :: xixl,xizl,gammaxl,gammazl
+
+! spatial derivatives
+ double precision :: dux_dxi,dux_dgamma,duz_dxi,duz_dgamma
+ double precision :: dux_dxl,duz_dxl,dux_dzl,duz_dzl
+ double precision :: sigma_xx,sigma_zz
+
+! material properties of the elastic medium
+ integer :: material
+ double precision :: mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,denst
+ double precision :: mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed,cpl,csl
+
+! if elastic element
+!
+! from L. S. Bennethum, Compressibility Moduli for Porous Materials Incorporating Volume Fraction,
+! J. Engrg. Mech., vol. 132(11), p. 1205-1214 (2006), below equation (5):
+! for a 3D isotropic solid, pressure is defined in terms of the trace of the stress tensor as
+! p = -1/3 (t11 + t22 + t33) where t is the Cauchy stress tensor.
+
+! to compute pressure in 3D in an elastic solid, one uses pressure = - trace(sigma) / 3
+! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij
+! = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_ij
+! sigma_xx = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_xx
+! sigma_yy = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_yy
+! sigma_zz = lambda (epsilon_xx + epsilon_yy + epsilon_zz) + 2 mu epsilon_zz
+! pressure = - trace(sigma) / 3 = - (lambda + 2/3 mu) trace(epsilon) = - kappa * trace(epsilon)
+!
+! to compute pressure in 2D in an elastic solid, one uses pressure = - trace(sigma) / 2
+! sigma_ij = lambda delta_ij trace(epsilon) + 2 mu epsilon_ij
+! = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_ij
+! sigma_xx = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_xx
+! sigma_yy = lambda (epsilon_xx + epsilon_yy) + 2 mu epsilon_yy
+! pressure = - trace(sigma) / 2 = - (lambda + mu) trace(epsilon)
+!
+ 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))
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+!--- if external medium, get elastic parameters of current grid point
+ if(assign_external_model) then
+ cpl = vpext(i,j,ispec)
+ csl = vsext(i,j,ispec)
+ denst = rhoext(i,j,ispec)
+ mul_relaxed = denst*csl*csl
+ lambdal_relaxed = denst*cpl*cpl - TWO*mul_relaxed
+ endif
+
+! 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 + displ_elastic(1,ibool(k,j,ispec))*hprime_xx(k,i)
+ duz_dxi = duz_dxi + displ_elastic(2,ibool(k,j,ispec))*hprime_xx(k,i)
+ dux_dgamma = dux_dgamma + displ_elastic(1,ibool(i,k,ispec))*hprime_zz(k,j)
+ duz_dgamma = duz_dgamma + displ_elastic(2,ibool(i,k,ispec))*hprime_zz(k,j)
+ 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
+
+! compute diagonal components of the stress tensor (include attenuation or anisotropy if needed)
+
+ if(TURN_ATTENUATION_ON) then
+
+! 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 - mul_relaxed * Mu_nu2
+ mul_unrelaxed = mul_relaxed * Mu_nu2
+ 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
+ sigma_xx = sigma_xx + (lambdal_relaxed + mul_relaxed)* &
+ (e1_mech1(i,j,ispec) + e1_mech2(i,j,ispec)) + TWO * mul_relaxed * (e11_mech1(i,j,ispec) + e11_mech2(i,j,ispec))
+ sigma_zz = sigma_zz + (lambdal_relaxed + mul_relaxed)* &
+ (e1_mech1(i,j,ispec) + e1_mech2(i,j,ispec)) - TWO * mul_relaxed * (e11_mech1(i,j,ispec) + e11_mech2(i,j,ispec))
+
+ else
+
+! no attenuation
+ sigma_xx = lambdalplus2mul_relaxed*dux_dxl + lambdal_relaxed*duz_dzl
+ sigma_zz = lambdalplus2mul_relaxed*duz_dzl + lambdal_relaxed*dux_dxl
+
+ endif
+
+! 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
+
+ endif
+
+! store pressure
+ pressure_element(i,j) = - (sigma_xx + sigma_zz) / 2.d0
+
+ enddo
+ enddo
+
+! pressure = - rho * Chi_dot_dot if acoustic element
+ else
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+ material = kmato(ispec)
+ denst = density(material)
+ if(assign_external_model) denst = rhoext(i,j,ispec)
+
+! store pressure
+ pressure_element(i,j) = - denst * potential_dot_dot_acoustic(iglob)
+
+ enddo
+ enddo
+
+ endif ! end of test if acoustic or elastic element
+
+ end subroutine compute_pressure_one_element
+
Added: seismo/2D/SPECFEM2D/trunk/compute_vector_field.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_vector_field.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/compute_vector_field.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -0,0 +1,152 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 5.2
+! ------------------------------
+!
+! Dimitri Komatitsch
+! University of Pau, France
+!
+! (c) April 2007
+!
+!========================================================================
+
+ subroutine compute_vector_whole_medium(potential_acoustic,veloc_elastic,elastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
+
+! compute Grad(potential) in acoustic elements
+! and combine with existing velocity vector field in elastic elements
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,npoin
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+
+ logical, dimension(nspec) :: elastic
+ double precision, dimension(npoin) :: potential_acoustic
+ double precision, dimension(NDIM,npoin) :: veloc_elastic,vector_field_display
+
+! array with derivatives of Lagrange polynomials
+ double precision, dimension(NGLLX,NGLLX) :: hprime_xx
+ double precision, dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+! local variables
+ integer i,j,ispec,iglob
+
+! vector field in this element
+ double precision, dimension(NDIM,NGLLX,NGLLX) :: vector_field_element
+
+! loop over spectral elements
+ 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)
+
+! store the result
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ vector_field_display(:,iglob) = vector_field_element(:,i,j)
+ enddo
+ enddo
+
+ enddo
+
+ end subroutine compute_vector_whole_medium
+
+!
+!=====================================================================
+!
+
+ 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)
+
+! compute Grad(potential) if acoustic element or copy existing vector if elastic element
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,npoin,ispec
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+ double precision, dimension(NGLLX,NGLLZ,nspec) :: xix,xiz,gammax,gammaz
+
+! vector field in this element
+ double precision, dimension(NDIM,NGLLX,NGLLX) :: vector_field_element
+
+ logical, dimension(nspec) :: elastic
+ double precision, dimension(npoin) :: potential_acoustic
+ double precision, dimension(NDIM,npoin) :: veloc_elastic
+
+! array with derivatives of Lagrange polynomials
+ double precision, dimension(NGLLX,NGLLX) :: hprime_xx
+ double precision, dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+! local variables
+ integer i,j,k,iglob
+
+! space derivatives
+ double precision tempx1l,tempx2l
+ double precision hp1,hp2
+
+! jacobian
+ double precision xixl,xizl,gammaxl,gammazl
+
+! simple copy of existing vector if elastic element
+ if(elastic(ispec)) then
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ vector_field_element(1,i,j) = veloc_elastic(1,iglob)
+ vector_field_element(2,i,j) = veloc_elastic(2,iglob)
+ enddo
+ enddo
+
+! compute gradient of potential to calculate vector if acoustic element
+ else
+
+! double loop over GLL points to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+! derivative along x
+ tempx1l = ZERO
+ do k = 1,NGLLX
+ hp1 = hprime_xx(k,i)
+ iglob = ibool(k,j,ispec)
+ tempx1l = tempx1l + potential_acoustic(iglob)*hp1
+ enddo
+
+! derivative along z
+ tempx2l = ZERO
+ do k = 1,NGLLZ
+ hp2 = hprime_zz(k,j)
+ iglob = ibool(i,k,ispec)
+ tempx2l = tempx2l + potential_acoustic(iglob)*hp2
+ enddo
+
+ xixl = xix(i,j,ispec)
+ xizl = xiz(i,j,ispec)
+ gammaxl = gammax(i,j,ispec)
+ gammazl = gammaz(i,j,ispec)
+
+! derivatives of potential
+ vector_field_element(1,i,j) = tempx1l*xixl + tempx2l*gammaxl
+ vector_field_element(2,i,j) = tempx1l*xizl + tempx2l*gammazl
+
+ enddo
+ enddo
+
+ endif ! end of test if acoustic or elastic element
+
+ end subroutine compute_vector_one_element
+
Modified: seismo/2D/SPECFEM2D/trunk/constants.h
===================================================================
--- seismo/2D/SPECFEM2D/trunk/constants.h 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/constants.h 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,6 +1,7 @@
! polynomial degree
integer, parameter :: NGLLX = 5
+! the code does NOT work if NGLLZ /= NGLLX because it then cannot handle a non-structured mesh
integer, parameter :: NGLLZ = NGLLX
! select fast (Paul Fischer) or slow (topology only) global numbering algorithm
@@ -21,11 +22,14 @@
! integer, parameter :: IOUT = 41
! flags for absorbing boundaries
- integer, parameter :: ITOP = 1
- integer, parameter :: IBOTTOM = 2
- integer, parameter :: ILEFT = 3
- integer, parameter :: IRIGHT = 4
+ integer, parameter :: IBOTTOM = 1
+ integer, parameter :: IRIGHT = 2
+ integer, parameter :: ITOP = 3
+ integer, parameter :: ILEFT = 4
+! number of edges of each element
+ integer, parameter :: NEDGES = 4
+
! a few useful constants
double precision, parameter :: ZERO = 0.d0,ONE = 1.d0
double precision, parameter :: HALF = 0.5d0,TWO = 2.0d0,QUART = 0.25d0
@@ -58,19 +62,12 @@
! error function source decay rate for Heaviside
double precision, parameter :: SOURCE_DECAY_RATE = 1.628d0
-! display non lineaire pour rehausser les faibles amplitudes sur les images couleur
+! non linear display to enhance small amplitudes in color images
double precision, parameter :: POWER_DISPLAY_COLOR = 0.30d0
-! X and Z scaling du display pour PostScript
- double precision, parameter :: SCALEX = 1.d0
- double precision, parameter :: SCALEZ = 1.d0
-
! US letter paper or European A4
logical, parameter :: US_LETTER = .false.
-! write symbols on PostScript display
- logical, parameter :: ISYMBOLS = .true.
-
! X and Z axis origin of PostScript plot in centimeters
double precision, parameter :: ORIG_X = 2.4d0
double precision, parameter :: ORIG_Z = 2.9d0
@@ -79,18 +76,60 @@
double precision, parameter :: CENTIM = 28.5d0
! parameters for arrows for PostScript snapshot
- double precision, parameter :: ANGLE = 20.d0
- double precision, parameter :: RAPPORT = 0.40d0
+ double precision, parameter :: ARROW_ANGLE = 20.d0
+ double precision, parameter :: ARROW_RATIO = 0.40d0
-! ecrire legendes ou non in PostScript display
- logical, parameter :: LEGENDES = .true.
+! size of frame used for Postscript display in percentage of the size of the page
+ double precision, parameter :: RPERCENTX = 70.0d0,RPERCENTZ = 77.0d0
-! limite pour afficher des points a la place des recepteurs
- integer, parameter :: NDOTS = 30
+!-----------------------------------------------------------------------
-! taille de la fenetre de display Postscript en pourcentage de la feuille
- double precision, parameter :: RPERCENTX = 70.0d0,RPERCENTZ = 77.0d0
+! attenuation constants from J. M. Carcione, Seismic modeling in viscoelastic media, Geophysics,
+! vol. 58(1), p. 110-120 (1993) for two memory-variable mechanisms (page 112).
+! Beware: these values implement specific values of the quality factors:
+! Qp approximately equal to 13 and Qs approximately equal to 10,
+! which means very high attenuation, see that paper for details.
+! double precision, parameter :: tau_epsilon_nu1_mech1 = 0.0334d0
+! double precision, parameter :: tau_sigma_nu1_mech1 = 0.0303d0
+! double precision, parameter :: tau_epsilon_nu2_mech1 = 0.0352d0
+! double precision, parameter :: tau_sigma_nu2_mech1 = 0.0287d0
+! double precision, parameter :: tau_epsilon_nu1_mech2 = 0.0028d0
+! double precision, parameter :: tau_sigma_nu1_mech2 = 0.0025d0
+! double precision, parameter :: tau_epsilon_nu2_mech2 = 0.0029d0
+! double precision, parameter :: tau_sigma_nu2_mech2 = 0.0024d0
+
+! attenuation constants from 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) for two memory-variable mechanisms (page 604).
+! Beware: these values implement specific values of the quality factors:
+! Qp approximately equal to 27 and Qs approximately equal to 20,
+! which means very high attenuation, see that paper for details.
+ double precision, parameter :: tau_epsilon_nu1_mech1 = 0.0325305d0
+ double precision, parameter :: tau_sigma_nu1_mech1 = 0.0311465d0
+ double precision, parameter :: tau_epsilon_nu2_mech1 = 0.0332577d0
+ double precision, parameter :: tau_sigma_nu2_mech1 = 0.0304655d0
+
+ double precision, parameter :: tau_epsilon_nu1_mech2 = 0.0032530d0
+ double precision, parameter :: tau_sigma_nu1_mech2 = 0.0031146d0
+ double precision, parameter :: tau_epsilon_nu2_mech2 = 0.0033257d0
+ double precision, parameter :: tau_sigma_nu2_mech2 = 0.0030465d0
+
+ double precision, parameter :: inv_tau_sigma_nu1_mech1 = ONE / tau_sigma_nu1_mech1
+ double precision, parameter :: inv_tau_sigma_nu2_mech1 = ONE / tau_sigma_nu2_mech1
+ double precision, parameter :: inv_tau_sigma_nu1_mech2 = ONE / tau_sigma_nu1_mech2
+ double precision, parameter :: inv_tau_sigma_nu2_mech2 = ONE / tau_sigma_nu2_mech2
+
+ double precision, parameter :: phi_nu1_mech1 = (ONE - tau_epsilon_nu1_mech1/tau_sigma_nu1_mech1) / tau_sigma_nu1_mech1
+ double precision, parameter :: phi_nu2_mech1 = (ONE - tau_epsilon_nu2_mech1/tau_sigma_nu2_mech1) / tau_sigma_nu2_mech1
+ double precision, parameter :: phi_nu1_mech2 = (ONE - tau_epsilon_nu1_mech2/tau_sigma_nu1_mech2) / tau_sigma_nu1_mech2
+ double precision, parameter :: phi_nu2_mech2 = (ONE - tau_epsilon_nu2_mech2/tau_sigma_nu2_mech2) / tau_sigma_nu2_mech2
+
+ double precision, parameter :: Mu_nu1 = ONE - (ONE - tau_epsilon_nu1_mech1/tau_sigma_nu1_mech1) &
+ - (ONE - tau_epsilon_nu1_mech2/tau_sigma_nu1_mech2)
+ double precision, parameter :: Mu_nu2 = ONE - (ONE - tau_epsilon_nu2_mech1/tau_sigma_nu2_mech1) &
+ - (ONE - tau_epsilon_nu2_mech2/tau_sigma_nu2_mech2)
+
!-----------------------------------------------------------------------
!
Modified: seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,13 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
Modified: seismo/2D/SPECFEM2D/trunk/create_color_image.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/create_color_image.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/create_color_image.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,19 +1,19 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
- subroutine create_color_image(donnees_image_color_2D,iglob_image_color_2D,NX,NY,it,cutvect)
+ subroutine create_color_image(color_image_2D_data,iglob_image_color_2D,NX,NY,it,cutsnaps)
-! routine d'affichage du deplacement sous forme d'image en couleurs
+! display a given field as a red and blue color image
! to display the snapshots : display image*.gif
@@ -25,17 +25,17 @@
integer NX,NY,it
- double precision cutvect
+ double precision cutsnaps
integer, dimension(NX,NY) :: iglob_image_color_2D
- double precision, dimension(NX,NY) :: donnees_image_color_2D
+ double precision, dimension(NX,NY) :: color_image_2D_data
- integer ix,iy,R,G,B,dixmilliers,milliers,centaines,dizaines,unites,reste,current_rec
+ integer ix,iy,R,G,B,tenthousands,thousands,hundreds,tens,units,remainder,current_rec
- double precision amplitude_max,valeur_normalisee
+ double precision amplitude_max,normalized_value
- character(len=100) nom_fichier,system_command
+ character(len=100) file_name,system_command
! create temporary image files in binary PNM P6 format (smaller) or ASCII PNM P3 format (easier to edit)
logical, parameter :: BINARY_FILE = .true.
@@ -43,96 +43,96 @@
! ASCII code of character '0' and of carriage return character
integer, parameter :: ascii_code_of_zero = 48, ascii_code_of_carriage_return = 10
-! ouverture du fichier image
- write(nom_fichier,"('OUTPUT_FILES/image',i6.6,'.pnm')") it
+! open the image file
+ write(file_name,"('OUTPUT_FILES/image',i6.6,'.pnm')") it
-! ouvrir le fichier
if(BINARY_FILE) then
- open(unit=27,file=nom_fichier,status='unknown',access='direct',recl=1)
+ open(unit=27,file=file_name,status='unknown',access='direct',recl=1)
write(27,rec=1) 'P'
- write(27,rec=2) '6' ! ecrire P6 = format d'image PNM binaire
+ write(27,rec=2) '6' ! write P6 = binary PNM image format
write(27,rec=3) char(ascii_code_of_carriage_return)
! compute and write horizontal size
- reste = NX
+ remainder = NX
- dixmilliers = reste / 10000
- reste = reste - 10000 * dixmilliers
+ tenthousands = remainder / 10000
+ remainder = remainder - 10000 * tenthousands
- milliers = reste / 1000
- reste = reste - 1000 * milliers
+ thousands = remainder / 1000
+ remainder = remainder - 1000 * thousands
- centaines = reste / 100
- reste = reste - 100 * centaines
+ hundreds = remainder / 100
+ remainder = remainder - 100 * hundreds
- dizaines = reste / 10
- reste = reste - 10 * dizaines
+ tens = remainder / 10
+ remainder = remainder - 10 * tens
- unites = reste
+ units = remainder
- if(dixmilliers > 0) then
- write(27,rec=4) char(dixmilliers + ascii_code_of_zero)
+ if(tenthousands > 0) then
+ write(27,rec=4) char(tenthousands + ascii_code_of_zero)
else
write(27,rec=4) ' '
endif
- if(milliers > 0) then
- write(27,rec=5) char(milliers + ascii_code_of_zero)
+ if(thousands > 0) then
+ write(27,rec=5) char(thousands + ascii_code_of_zero)
else
write(27,rec=5) ' '
endif
- if(centaines > 0) then
- write(27,rec=6) char(centaines + ascii_code_of_zero)
+ if(hundreds > 0) then
+ write(27,rec=6) char(hundreds + ascii_code_of_zero)
else
write(27,rec=6) ' '
endif
- write(27,rec=7) char(dizaines + ascii_code_of_zero)
- write(27,rec=8) char(unites + ascii_code_of_zero)
+ write(27,rec=7) char(tens + ascii_code_of_zero)
+ write(27,rec=8) char(units + ascii_code_of_zero)
write(27,rec=9) ' '
! compute and write vertical size
- reste = NY
+ remainder = NY
- dixmilliers = reste / 10000
- reste = reste - 10000 * dixmilliers
+ tenthousands = remainder / 10000
+ remainder = remainder - 10000 * tenthousands
- milliers = reste / 1000
- reste = reste - 1000 * milliers
+ thousands = remainder / 1000
+ remainder = remainder - 1000 * thousands
- centaines = reste / 100
- reste = reste - 100 * centaines
+ hundreds = remainder / 100
+ remainder = remainder - 100 * hundreds
- dizaines = reste / 10
- reste = reste - 10 * dizaines
+ tens = remainder / 10
+ remainder = remainder - 10 * tens
- unites = reste
+ units = remainder
- if(dixmilliers > 0) then
- write(27,rec=10) char(dixmilliers + ascii_code_of_zero)
+! write image size
+ if(tenthousands > 0) then
+ write(27,rec=10) char(tenthousands + ascii_code_of_zero)
else
write(27,rec=10) ' '
endif
- if(milliers > 0) then
- write(27,rec=11) char(milliers + ascii_code_of_zero)
+ if(thousands > 0) then
+ write(27,rec=11) char(thousands + ascii_code_of_zero)
else
write(27,rec=11) ' '
endif
- if(centaines > 0) then
- write(27,rec=12) char(centaines + ascii_code_of_zero)
+ if(hundreds > 0) then
+ write(27,rec=12) char(hundreds + ascii_code_of_zero)
else
write(27,rec=12) ' '
endif
- write(27,rec=13) char(dizaines + ascii_code_of_zero)
- write(27,rec=14) char(unites + ascii_code_of_zero)
+ write(27,rec=13) char(tens + ascii_code_of_zero)
+ write(27,rec=14) char(units + ascii_code_of_zero)
write(27,rec=15) char(ascii_code_of_carriage_return)
-! nombre de nuances
+! number of shades
write(27,rec=16) '2'
write(27,rec=17) '5'
write(27,rec=18) '5'
@@ -143,30 +143,30 @@
else
- open(unit=27,file=nom_fichier,status='unknown')
- write(27,"('P3')") ! ecrire P3 = format d'image PNM ASCII
- write(27,*) NX,NY ! ecrire la taille
- write(27,*) '255' ! nombre de nuances
+ open(unit=27,file=file_name,status='unknown')
+ write(27,"('P3')") ! write P3 = ASCII PNM image format
+ write(27,*) NX,NY ! write image size
+ write(27,*) '255' ! number of shades
endif
-! calculer l'amplitude maximum
- amplitude_max = maxval(abs(donnees_image_color_2D))
+! compute maximum amplitude
+ amplitude_max = maxval(abs(color_image_2D_data))
-! dans le format PNM, l'image commence par le coin en haut a gauche
+! in the PNM format, the image starts in the upper-left corner
do iy=NY,1,-1
do ix=1,NX
-! regarder si le pixel est defini ou non (au dessus de la topographie par exemple)
+! check if pixel is defined or not (can be above topography for instance)
if(iglob_image_color_2D(ix,iy) == -1) then
-! utiliser couleur bleu ciel pour afficher les zones non definies situees au dessus de la topo
+! use light blue to display undefined region above topography
R = 204
G = 255
B = 255
-! supprimer les petites amplitudes considerees comme du bruit
- else if (abs(donnees_image_color_2D(ix,iy)) < amplitude_max * CUTVECT) then
+! suppress small amplitudes considered as noise
+ else if (abs(color_image_2D_data(ix,iy)) < amplitude_max * cutsnaps) then
! use black background where amplitude is negligible
R = 0
@@ -175,29 +175,28 @@
else
-! definir les donnees comme etant le deplacement normalise entre [-1:1]
-! et converti a l'entier le plus proche
-! en se rappelant que l'amplitude peut etre negative
- valeur_normalisee = donnees_image_color_2D(ix,iy) / amplitude_max
+! define normalized image data in [-1:1] and convert to nearest integer
+! keeping in mind that data values can be negative
+ normalized_value = color_image_2D_data(ix,iy) / amplitude_max
-! supprimer valeurs en dehors de [-1:+1]
- if(valeur_normalisee < -1.d0) valeur_normalisee = -1.d0
- if(valeur_normalisee > 1.d0) valeur_normalisee = 1.d0
+! suppress values outside of [-1:+1]
+ if(normalized_value < -1.d0) normalized_value = -1.d0
+ if(normalized_value > 1.d0) normalized_value = 1.d0
-! utiliser rouge si deplacement positif, bleu si negatif, pas de vert
- if(valeur_normalisee >= 0.d0) then
- R = nint(255.d0*valeur_normalisee**POWER_DISPLAY_COLOR)
+! use red if positive value, blue if negative, no green
+ if(normalized_value >= 0.d0) then
+ R = nint(255.d0*normalized_value**POWER_DISPLAY_COLOR)
G = 0
B = 0
else
R = 0
G = 0
- B = nint(255.d0*abs(valeur_normalisee)**POWER_DISPLAY_COLOR)
+ B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY_COLOR)
endif
endif
-! ecrire l'image en couleur
+! write color image
if(BINARY_FILE) then
! first write red
@@ -221,7 +220,7 @@
enddo
enddo
-! fermer le fichier
+! close the file
close(27)
! open image file and create system command to convert image to more convenient format
Modified: seismo/2D/SPECFEM2D/trunk/createnum_fast.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/createnum_fast.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/createnum_fast.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,13 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
Modified: seismo/2D/SPECFEM2D/trunk/createnum_slow.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/createnum_slow.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/createnum_slow.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,13 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
@@ -28,7 +28,7 @@
logical alreadyexist
- integer ngnoddeb(4),ngnodfin(4)
+ integer, dimension(NEDGES) :: ngnod_begin,ngnod_end
!---- create global mesh numbering
write(IOUT,*)
@@ -39,23 +39,23 @@
npedge = 0
npcorn = 0
-! definition des aretes par rapport aux quatre points de controle
+! define edges from the four control points
-! --- arete 1 relie point 1 a point 2
- ngnoddeb(1)= 1
- ngnodfin(1)= 2
+! --- edge 1 linking point 1 to point 2
+ ngnod_begin(1)= 1
+ ngnod_end(1)= 2
-! --- arete 2 relie point 2 a point 3
- ngnoddeb(2)= 2
- ngnodfin(2)= 3
+! --- edge 2 linking point 2 to point 3
+ ngnod_begin(2)= 2
+ ngnod_end(2)= 3
-! --- arete 3 relie point 3 a point 4
- ngnoddeb(3)= 3
- ngnodfin(3)= 4
+! --- edge 3 linking point 3 to point 4
+ ngnod_begin(3)= 3
+ ngnod_end(3)= 4
-! --- arete 4 relie point 4 a point 1
- ngnoddeb(4)= 4
- ngnodfin(4)= 1
+! --- edge 4 linking point 4 to point 1
+ ngnod_begin(4)= 4
+ ngnod_end(4)= 1
! initialisation du tableau de numerotation globale
ibool(:,:,:) = 0
@@ -175,16 +175,16 @@
!--- detecter un eventuel defaut dans la structure topologique du maillage
- if((knods(ngnoddeb(nedgeother),num2) == knods(ngnoddeb(nedgeloc),numelem)) &
+ if((knods(ngnod_begin(nedgeother),num2) == knods(ngnod_begin(nedgeloc),numelem)) &
.and. &
- (knods(ngnodfin(nedgeother),num2) == knods(ngnodfin(nedgeloc),numelem))) then
+ (knods(ngnod_end(nedgeother),num2) == knods(ngnod_end(nedgeloc),numelem))) then
stop 'Improper topology of the input mesh detected'
!--- sinon voir si cette arete a deja ete generee
- else if((knods(ngnoddeb(nedgeother),num2) == knods(ngnodfin(nedgeloc),numelem)) &
+ else if((knods(ngnod_begin(nedgeother),num2) == knods(ngnod_end(nedgeloc),numelem)) &
.and. &
- (knods(ngnodfin(nedgeother),num2) == knods(ngnoddeb(nedgeloc),numelem))) then
+ (knods(ngnod_end(nedgeother),num2) == knods(ngnod_begin(nedgeloc),numelem))) then
alreadyexist = .true.
Modified: seismo/2D/SPECFEM2D/trunk/datim.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/datim.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/datim.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,19 +1,19 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
subroutine datim(string_input)
-! get date and time using f90 portable routines
+! get date and time
implicit none
Modified: seismo/2D/SPECFEM2D/trunk/define_derivation_matrices.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/define_derivation_matrices.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/define_derivation_matrices.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,17 +1,17 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
- subroutine define_derivation_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz)
+ subroutine define_derivation_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz,hprimewgll_xx,hprimewgll_zz)
implicit none
@@ -26,8 +26,8 @@
double precision, dimension(NGLLZ) :: wzgll
! array with derivatives of Lagrange polynomials
- double precision, dimension(NGLLX,NGLLX) :: hprime_xx
- double precision, dimension(NGLLZ,NGLLZ) :: hprime_zz
+ double precision, dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ double precision, dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
! function for calculating derivatives of Lagrange polynomials
double precision, external :: lagrange_deriv_GLL
@@ -48,12 +48,14 @@
do i1=1,NGLLX
do i2=1,NGLLX
hprime_xx(i1,i2) = lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)
+ hprimewgll_xx(i1,i2) = wxgll(i2) * hprime_xx(i1,i2)
enddo
enddo
do k1=1,NGLLZ
do k2=1,NGLLZ
hprime_zz(k1,k2) = lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)
+ hprimewgll_zz(k1,k2) = wzgll(k2) * hprime_zz(k1,k2)
enddo
enddo
Added: seismo/2D/SPECFEM2D/trunk/define_external_model.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/define_external_model.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/define_external_model.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -0,0 +1,41 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 5.2
+! ------------------------------
+!
+! Dimitri Komatitsch
+! University of Pau, France
+!
+! (c) April 2007
+!
+!========================================================================
+
+ subroutine define_external_model(x,y,iflag_element,rho,vp,vs)
+
+ implicit none
+
+ include "constants.h"
+
+! user can modify this routine to assign any different external Earth model (rho, vp, vs)
+! based on the x and y coordinates of that grid point and the flag of the region it belongs to
+
+ integer, intent(in) :: iflag_element
+
+ double precision, intent(in) :: x,y
+
+ double precision, intent(out) :: rho,vp,vs
+
+! dummy routine here, just to demonstrate how the model can be assigned
+ if(iflag_element == 1 .or. x < 1700.d0 .or. y >= 2300.d0) then
+ rho = 2000.d0
+ vp = 3000.d0
+ vs = vp / sqrt(3.d0)
+ else
+ rho = 2500.d0
+ vp = 3600.d0
+ vs = vp / 2.d0
+ endif
+
+ end subroutine define_external_model
+
Modified: seismo/2D/SPECFEM2D/trunk/define_shape_functions.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/define_shape_functions.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/define_shape_functions.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,13 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
Added: seismo/2D/SPECFEM2D/trunk/enforce_acoustic_free_surface.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/enforce_acoustic_free_surface.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/enforce_acoustic_free_surface.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -0,0 +1,74 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 5.2
+! ------------------------------
+!
+! Dimitri Komatitsch
+! University of Pau, France
+!
+! (c) April 2007
+!
+!========================================================================
+
+ subroutine enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,ispecnum_acoustic_surface,iedgenum_acoustic_surface, &
+ ibool,nelem_acoustic_surface,npoin,nspec)
+
+! free surface for an acoustic medium
+! if acoustic, the free surface condition is a Dirichlet condition for the potential,
+! not Neumann, in order to impose zero pressure at the surface
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nelem_acoustic_surface,npoin,nspec
+
+ integer, dimension(nelem_acoustic_surface) :: ispecnum_acoustic_surface,iedgenum_acoustic_surface
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+ double precision, dimension(npoin) :: potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
+
+!---
+!--- local variables
+!---
+
+ integer :: ispec_acoustic_surface,ispec,iedge,i,j,iglob
+
+ do ispec_acoustic_surface = 1,nelem_acoustic_surface
+
+ ispec = ispecnum_acoustic_surface(ispec_acoustic_surface)
+ iedge = iedgenum_acoustic_surface(ispec_acoustic_surface)
+
+ if(iedge == IBOTTOM .or. iedge == ITOP) then
+ if(iedge == IBOTTOM) then
+ j = 1
+ else
+ j = NGLLZ
+ endif
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ potential_acoustic(iglob) = ZERO
+ potential_dot_acoustic(iglob) = ZERO
+ potential_dot_dot_acoustic(iglob) = ZERO
+ enddo
+ else
+ if(iedge == ILEFT) then
+ i = 1
+ else
+ i = NGLLX
+ endif
+ do j = 1,NGLLZ
+ iglob = ibool(i,j,ispec)
+ potential_acoustic(iglob) = ZERO
+ potential_dot_acoustic(iglob) = ZERO
+ potential_dot_dot_acoustic(iglob) = ZERO
+ enddo
+ endif
+
+ enddo
+
+ end subroutine enforce_acoustic_free_surface
+
Modified: seismo/2D/SPECFEM2D/trunk/gmat01.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/gmat01.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/gmat01.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,13 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
@@ -45,8 +45,8 @@
if(n<1 .or. n>numat) stop 'Wrong material set number'
-!---- materiau isotrope, vitesse P et vitesse S donnees
- if(indic == 0) then
+!---- isotropic material, P and S velocities given
+ if(indic == 1) then
! P and S velocity
cp = val1
@@ -58,7 +58,7 @@
two_mu = 2.d0*mu
lambda = lambdaplus2mu - two_mu
-! bulk modulus K
+! bulk modulus Kappa
kappa = lambda + two_mu/3.d0
! Young modulus
@@ -70,13 +70,16 @@
! Poisson's ratio must be between -1 and +1/2
if (poisson < -1.d0 .or. poisson > 0.5d0) stop 'Poisson''s ratio out of range'
-!---- materiau anisotrope, c11, c13, c33 et c44 donnes en Pascal
- else
+!---- anisotropic material, c11, c13, c33 and c44 given in Pascal
+ else if (indic == 2) then
c11 = val1
c13 = val2
c33 = val3
c44 = val4
+ else
+ stop 'wrong model flag read'
+
endif
!
@@ -85,7 +88,7 @@
! Isotropic : lambda, mu, K (= lambda + 2*mu), zero
! Transverse anisotropic : c11, c13, c33, c44
!
- if(indic == 0 .or. indic == 1) then
+ if(indic == 1) then
elastcoef(1,n) = lambda
elastcoef(2,n) = mu
elastcoef(3,n) = lambdaplus2mu
@@ -102,11 +105,15 @@
!
!---- check the input
!
- if(indic == 0 .or. indic == 1) then
- write(iout,200) n,cp,cs,density,poisson,lambda,mu,kappa,young
+ 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
+ else
+ write(iout,300) n,cp,density,kappa
+ endif
else
- write(iout,300) n,c11,c13,c33,c44,density, &
- sqrt(c33/density),sqrt(c11/density),sqrt(c44/density),sqrt(c44/density)
+ write(iout,400) n,c11,c13,c33,c44,density,sqrt(c33/density),sqrt(c11/density),sqrt(c44/density),sqrt(c44/density)
endif
enddo
@@ -117,9 +124,10 @@
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', &
/1x,54('='),//5x,'Number of material sets . . . . . . (numat) =',i6)
- 200 format(//5x,'------------------------',/5x, &
- '-- Isotropic material --',/5x, &
- '------------------------',/5x, &
+
+ 200 format(//5x,'----------------------------------------',/5x, &
+ '-- Elastic (solid) isotropic material --',/5x, &
+ '----------------------------------------',/5x, &
'Material set number. . . . . . . . (jmat) =',i6,/5x, &
'P-wave velocity. . . . . . . . . . . (cp) =',1pe15.8,/5x, &
'S-wave velocity. . . . . . . . . . . (cs) =',1pe15.8,/5x, &
@@ -127,9 +135,18 @@
'Poisson''s ratio. . . . . . . . .(poisson) =',1pe15.8,/5x, &
'First Lame parameter Lambda. . . (lambda) =',1pe15.8,/5x, &
'Second Lame parameter Mu. . . . . . .(mu) =',1pe15.8,/5x, &
- 'Bulk modulus K . . . . . . . . . .(kappa) =',1pe15.8,/5x, &
+ 'Bulk modulus Kappa . . . . . . . .(kappa) =',1pe15.8,/5x, &
'Young''s modulus E. . . . . . . . .(young) =',1pe15.8)
- 300 format(//5x,'-------------------------------------',/5x, &
+
+ 300 format(//5x,'-------------------------------',/5x, &
+ '-- Acoustic (fluid) material --',/5x, &
+ '-------------------------------',/5x, &
+ 'Material set number. . . . . . . . (jmat) =',i6,/5x, &
+ 'P-wave velocity. . . . . . . . . . . (cp) =',1pe15.8,/5x, &
+ 'Mass density. . . . . . . . . . (density) =',1pe15.8,/5x, &
+ 'Bulk modulus Kappa . . . . . . . .(kappa) =',1pe15.8)
+
+ 400 format(//5x,'-------------------------------------',/5x, &
'-- Transverse anisotropic material --',/5x, &
'-------------------------------------',/5x, &
'Material set number. . . . . . . . (jmat) =',i6,/5x, &
Modified: seismo/2D/SPECFEM2D/trunk/lagrange_poly.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/lagrange_poly.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/lagrange_poly.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,13 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
Modified: seismo/2D/SPECFEM2D/trunk/locate_receivers.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/locate_receivers.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/locate_receivers.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,13 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
@@ -85,7 +85,7 @@
read(1,*) station_name(irec),network_name(irec),st_xval(irec),st_zval(irec),stele,stbur
! check that station is not buried, burial is not implemented in current code
- if(abs(stbur) > 0.001d0) stop 'stations with non-zero burial not implemented yet'
+ if(abs(stbur) > TINYVAL) stop 'stations with non-zero burial not implemented yet'
! compute distance between source and receiver
distance_receiver = sqrt((st_zval(irec)-z_source)**2 + (st_xval(irec)-x_source)**2)
Modified: seismo/2D/SPECFEM2D/trunk/locate_source_force.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/locate_source_force.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/locate_source_force.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,13 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
Modified: seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,13 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
Modified: seismo/2D/SPECFEM2D/trunk/meshfem2D.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/meshfem2D.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/meshfem2D.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,13 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
@@ -21,9 +21,9 @@
!
! @ARTICLE{KoTr99,
! author={D. Komatitsch and J. Tromp},
-! year=1999,
! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
! journal={Geophys. J. Int.},
+! year=1999,
! volume=139,
! number=3,
! pages={806-822},
@@ -51,10 +51,10 @@
integer :: ioffset
double precision :: gamma,absx,a00,a01,bot0,top0
-! stockage du modele de vitesse et densite
+! to store density and velocity model
double precision, dimension(:), allocatable :: rho,cp,cs,aniso3,aniso4
integer, dimension(:), allocatable :: icodemat
- integer, dimension(:,:), allocatable :: num_modele
+ integer, dimension(:,:), allocatable :: num_material
! interface data
integer interface_current,ipoint_current,number_of_interfaces,npoints_interface_bottom,npoints_interface_top
@@ -71,28 +71,28 @@
character(len=50) interfacesfile,title
- integer imatnum,inumabs,inumsurface,inumelem
- integer nelemabs,nelemsurface,npgeo,nspec
+ integer imaterial_number,inumelem
+ integer nelemabs,nelem_acoustic_surface,npgeo,nspec
integer k,icol,ili,istepx,istepz,ix,iz,irec,i,j
- integer ixdebzone,ixfinzone,izdebzone,izfinzone,imodnum
- integer izone,imodele,nbzone,nbmodeles
- integer itaff,pointsdisp,subsamp,sismostype,vecttype
+ integer ixdebregion,ixfinregion,izdebregion,izfinregion
+ integer iregion,imaterial,nbregion,nb_materials
+ integer NTSTEP_BETWEEN_OUTPUT_INFO,pointsdisp,subsamp,seismotype,imagetype
integer ngnod,nt,nx,nz,nxread,nzread,icodematread,ireceiverlines,nreceiverlines
integer, dimension(:), allocatable :: nrec
- logical codehaut,codebas,codegauche,codedroite,output_postscript_snapshot,output_color_image,plot_lowerleft_corner_only
+ logical codetop,codebottom,codeleft,coderight,output_postscript_snapshot,output_color_image,plot_lowerleft_corner_only
- double precision tang1,tangN,vpzone,vszone,poisson_ratio
- double precision cutvect,sizemax_arrows,anglerec,xmin,xmax,deltat
+ double precision tang1,tangN,vpregion,vsregion,poisson_ratio
+ double precision cutsnaps,sizemax_arrows,anglerec,xmin,xmax,deltat
double precision rhoread,cpread,csread,aniso3read,aniso4read
double precision, dimension(:), allocatable :: xdeb,zdeb,xfin,zfin
- logical interpol,gnuplot,read_external_model,outputgrid
- logical abshaut,absbas,absgauche,absdroite
+ logical interpol,gnuplot,assign_external_model,outputgrid
+ logical abstop,absbottom,absleft,absright
logical source_surf,meshvect,initialfield,modelvect,boundvect
- logical ELASTIC,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
+ logical TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
logical, dimension(:), allocatable :: enreg_surf
@@ -100,7 +100,7 @@
double precision, external :: value_spline
! flag to indicate an anisotropic material
- integer, parameter :: ANISOTROPIC_MATERIAL = 1
+ integer, parameter :: ANISOTROPIC_MATERIAL = 2
! file number for interface file
integer, parameter :: IIN_INTERFACES = 15
@@ -121,7 +121,7 @@
call read_value_string(IIN,IGNORE_JUNK,title)
call read_value_string(IIN,IGNORE_JUNK,interfacesfile)
- write(*,*) 'Titre de la simulation'
+ write(*,*) 'Title of the simulation'
write(*,*) title
print *
@@ -131,8 +131,7 @@
call read_value_integer(IIN,IGNORE_JUNK,nx)
call read_value_integer(IIN,IGNORE_JUNK,ngnod)
call read_value_logical(IIN,IGNORE_JUNK,initialfield)
- call read_value_logical(IIN,IGNORE_JUNK,read_external_model)
- call read_value_logical(IIN,IGNORE_JUNK,ELASTIC)
+ call read_value_logical(IIN,IGNORE_JUNK,assign_external_model)
call read_value_logical(IIN,IGNORE_JUNK,TURN_ANISOTROPY_ON)
call read_value_logical(IIN,IGNORE_JUNK,TURN_ATTENUATION_ON)
@@ -191,7 +190,7 @@
nxread = nx
nzread = nz
-! multiplier par 2 si elements 9 noeuds
+! multiply by 2 if elements have 9 nodes
if(ngnod == 9) then
nx = nx * 2
nz = nz * 2
@@ -199,10 +198,10 @@
endif
! read absorbing boundaries parameters
- call read_value_logical(IIN,IGNORE_JUNK,abshaut)
- call read_value_logical(IIN,IGNORE_JUNK,absbas)
- call read_value_logical(IIN,IGNORE_JUNK,absgauche)
- call read_value_logical(IIN,IGNORE_JUNK,absdroite)
+ call read_value_logical(IIN,IGNORE_JUNK,absbottom)
+ call read_value_logical(IIN,IGNORE_JUNK,absright)
+ call read_value_logical(IIN,IGNORE_JUNK,abstop)
+ call read_value_logical(IIN,IGNORE_JUNK,absleft)
! read time step parameters
call read_value_integer(IIN,IGNORE_JUNK,nt)
@@ -245,7 +244,7 @@
print *,'Multiplying factor = ',factor
! read receiver line parameters
- call read_value_integer(IIN,IGNORE_JUNK,sismostype)
+ call read_value_integer(IIN,IGNORE_JUNK,seismotype)
call read_value_integer(IIN,IGNORE_JUNK,nreceiverlines)
call read_value_double_precision(IIN,IGNORE_JUNK,anglerec)
@@ -270,11 +269,11 @@
enddo
! read display parameters
- call read_value_integer(IIN,IGNORE_JUNK,itaff)
+ call read_value_integer(IIN,IGNORE_JUNK,NTSTEP_BETWEEN_OUTPUT_INFO)
call read_value_logical(IIN,IGNORE_JUNK,output_postscript_snapshot)
call read_value_logical(IIN,IGNORE_JUNK,output_color_image)
- call read_value_integer(IIN,IGNORE_JUNK,vecttype)
- call read_value_double_precision(IIN,IGNORE_JUNK,cutvect)
+ call read_value_integer(IIN,IGNORE_JUNK,imagetype)
+ call read_value_double_precision(IIN,IGNORE_JUNK,cutsnaps)
call read_value_logical(IIN,IGNORE_JUNK,meshvect)
call read_value_logical(IIN,IGNORE_JUNK,modelvect)
call read_value_logical(IIN,IGNORE_JUNK,boundvect)
@@ -293,17 +292,17 @@
plot_lowerleft_corner_only = .false.
endif
-! lecture des differents modeles de materiaux
- call read_value_integer(IIN,IGNORE_JUNK,nbmodeles)
- if(nbmodeles <= 0) stop 'Negative number of models not allowed !!'
+! read the different material materials
+ call read_value_integer(IIN,IGNORE_JUNK,nb_materials)
+ if(nb_materials <= 0) stop 'Negative number of materials not allowed!'
- allocate(icodemat(nbmodeles))
- allocate(rho(nbmodeles))
- allocate(cp(nbmodeles))
- allocate(cs(nbmodeles))
- allocate(aniso3(nbmodeles))
- allocate(aniso4(nbmodeles))
- allocate(num_modele(nx,nz))
+ 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(num_material(nx,nz))
icodemat(:) = 0
rho(:) = 0.d0
@@ -311,11 +310,11 @@
cs(:) = 0.d0
aniso3(:) = 0.d0
aniso4(:) = 0.d0
- num_modele(:,:) = 0
+ num_material(:,:) = 0
- do imodele=1,nbmodeles
+ do imaterial=1,nb_materials
call read_material_parameters(IIN,DONT_IGNORE_JUNK,i,icodematread,rhoread,cpread,csread,aniso3read,aniso4read)
- if(i < 1 .or. i > nbmodeles) stop 'Wrong model number!!'
+ if(i < 1 .or. i > nb_materials) stop 'Wrong material number!'
icodemat(i) = icodematread
rho(i) = rhoread
cp(i) = cpread
@@ -323,123 +322,116 @@
if(rho(i) <= 0.d0 .or. cp(i) <= 0.d0 .or. cs(i) < 0.d0) stop 'negative value of velocity or density'
-! check that Cs = 0 if acoustic simulation
- if(.not. ELASTIC .and. cs(i) > 0.0001) stop 'must have Cs = 0 for acoustic model'
-
aniso3(i) = aniso3read
aniso4(i) = aniso4read
enddo
print *
- print *, 'Nb de modeles de roche = ',nbmodeles
+ print *, 'Nb of solid or fluid materials = ',nb_materials
print *
- do i=1,nbmodeles
+ do i=1,nb_materials
if(icodemat(i) /= ANISOTROPIC_MATERIAL) then
- print *,'Modele #',i,' isotrope'
+ print *,'Material #',i,' isotropic'
print *,'rho,cp,cs = ',rho(i),cp(i),cs(i)
+ if(cs(i) < TINYVAL) then
+ print *,'Material is fluid'
+ else
+ print *,'Material is solid'
+ endif
else
- print *,'Modele #',i,' anisotrope'
+ print *,'Material #',i,' anisotropic'
print *,'rho,c11,c13,c33,c44 = ',rho(i),cp(i),cs(i),aniso3(i),aniso4(i)
endif
- enddo
print *
+ enddo
-! lecture des numeros de modele des differentes zones
- call read_value_integer(IIN,IGNORE_JUNK,nbzone)
+! read the material numbers for each region
+ call read_value_integer(IIN,IGNORE_JUNK,nbregion)
- if(nbzone <= 0) stop 'Negative number of zones not allowed !!'
+ if(nbregion <= 0) stop 'Negative number of regions not allowed!'
print *
- print *, 'Nb de zones du modele = ',nbzone
+ print *, 'Nb of regions in the mesh = ',nbregion
print *
- do izone = 1,nbzone
+ do iregion = 1,nbregion
- call read_zone_coordinates(IIN,DONT_IGNORE_JUNK,ixdebzone,ixfinzone,izdebzone,izfinzone,imodnum)
+ call read_region_coordinates(IIN,DONT_IGNORE_JUNK,ixdebregion,ixfinregion,izdebregion,izfinregion,imaterial_number)
- if(imodnum < 1) stop 'Negative model number not allowed !!'
- if(ixdebzone < 1) stop 'Left coordinate of zone negative !!'
- if(ixfinzone > nxread) stop 'Right coordinate of zone too high !!'
- if(izdebzone < 1) stop 'Bottom coordinate of zone negative !!'
- if(izfinzone > nzread) stop 'Top coordinate of zone too high !!'
+ if(imaterial_number < 1) stop 'Negative material number not allowed!'
+ if(ixdebregion < 1) stop 'Left coordinate of region negative!'
+ if(ixfinregion > nxread) stop 'Right coordinate of region too high!'
+ if(izdebregion < 1) stop 'Bottom coordinate of region negative!'
+ if(izfinregion > nzread) stop 'Top coordinate of region too high!'
- print *,'Zone ',izone
- print *,'IX from ',ixdebzone,' to ',ixfinzone
- print *,'IZ from ',izdebzone,' to ',izfinzone
+ print *,'Region ',iregion
+ print *,'IX from ',ixdebregion,' to ',ixfinregion
+ print *,'IZ from ',izdebregion,' to ',izfinregion
- if(icodemat(imodnum) /= ANISOTROPIC_MATERIAL) then
- vpzone = cp(imodnum)
- vszone = cs(imodnum)
- print *,'Model # ',imodnum,' isotrope'
- print *,'vp = ',vpzone
- print *,'vs = ',vszone
- print *,'rho = ',rho(imodnum)
- poisson_ratio = 0.5d0*(vpzone*vpzone-2.d0*vszone*vszone) / (vpzone*vpzone-vszone*vszone)
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL) then
+ vpregion = cp(imaterial_number)
+ vsregion = cs(imaterial_number)
+ print *,'Material # ',imaterial_number,' isotropic'
+ if(vsregion < TINYVAL) then
+ print *,'Material is fluid'
+ else
+ print *,'Material is solid'
+ endif
+ print *,'vp = ',vpregion
+ print *,'vs = ',vsregion
+ print *,'rho = ',rho(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'
else
- print *,'Model # ',imodnum,' anisotrope'
- print *,'c11 = ',cp(imodnum)
- print *,'c13 = ',cs(imodnum)
- print *,'c33 = ',aniso3(imodnum)
- print *,'c44 = ',aniso4(imodnum)
- print *,'rho = ',rho(imodnum)
+ 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)
endif
print *,' -----'
-! stocker le modele de vitesse et densite
- do i = ixdebzone,ixfinzone
- do j = izdebzone,izfinzone
+! store density and velocity model
+ do i = ixdebregion,ixfinregion
+ do j = izdebregion,izfinregion
if(ngnod == 4) then
- num_modele(i,j) = imodnum
+ num_material(i,j) = imaterial_number
else
- num_modele(2*(i-1)+1,2*(j-1)+1) = imodnum
- num_modele(2*(i-1)+1,2*(j-1)+2) = imodnum
- num_modele(2*(i-1)+2,2*(j-1)+1) = imodnum
- num_modele(2*(i-1)+2,2*(j-1)+2) = imodnum
+ num_material(2*(i-1)+1,2*(j-1)+1) = imaterial_number
+ num_material(2*(i-1)+1,2*(j-1)+2) = imaterial_number
+ num_material(2*(i-1)+2,2*(j-1)+1) = imaterial_number
+ num_material(2*(i-1)+2,2*(j-1)+2) = imaterial_number
endif
enddo
enddo
enddo
- if(minval(num_modele) <= 0) stop 'Velocity model not entirely set...'
+ if(minval(num_material) <= 0) stop 'Velocity model not entirely set...'
close(IIN)
print *
- print *,' Parameter file successfully read... '
+ print *,'Parameter file successfully read... '
-! --------- fin lecture fichier parametres --------------
+!---
- if(ngnod /= 4 .and. ngnod /= 9) stop 'erreur ngnod different de 4 ou 9 !!'
+ if(ngnod /= 4 .and. ngnod /= 9) stop 'ngnod different from 4 or 9!'
print *
if(ngnod == 4) then
- print *,'Le maillage comporte ',nx,' x ',nz,' elements'
+ print *,'The mesh contains ',nx,' x ',nz,' elements'
else
- print *,'Le maillage comporte ',nx/2,' x ',nz/2,' elements'
+ print *,'The mesh contains ',nx/2,' x ',nz/2,' elements'
endif
print *
- print *,'Les elements de controle sont des elements ',ngnod,' noeuds'
+ print *,'Control elements have ',ngnod,' nodes'
print *
!---
-! perform basic checks on parameters read
-
-! for acoustic
- if(TURN_ANISOTROPY_ON .and. .not. ELASTIC) stop 'currently cannot have anisotropy in acoustic simulation'
-
- if(TURN_ATTENUATION_ON .and. .not. ELASTIC) stop 'currently cannot have attenuation in acoustic simulation'
-
- if(source_type == 2 .and. .not. ELASTIC) stop 'currently cannot have moment tensor source in acoustic simulation'
-
-! for attenuation
- if(TURN_ANISOTROPY_ON .and. TURN_ATTENUATION_ON) stop 'cannot have anisotropy and attenuation both turned on in current version'
-
-!---
-
! allocate arrays for the grid
allocate(x(0:nx,0:nz))
allocate(z(0:nx,0:nz))
@@ -471,7 +463,7 @@
xinterface_bottom(ipoint_current),zinterface_bottom(ipoint_current))
enddo
-! boucle sur toutes les couches
+! loop on all the layers
do ilayer = 1,number_of_layers
! read top interface
@@ -483,35 +475,35 @@
xinterface_top(ipoint_current),zinterface_top(ipoint_current))
enddo
-! calculer le spline pour l'interface du bas, imposer la tangente aux deux bords
+! compute the spline for the bottom interface, impose the tangent on both edges
tang1 = (zinterface_bottom(2)-zinterface_bottom(1)) / (xinterface_bottom(2)-xinterface_bottom(1))
tangN = (zinterface_bottom(npoints_interface_bottom)-zinterface_bottom(npoints_interface_bottom-1)) / &
(xinterface_bottom(npoints_interface_bottom)-xinterface_bottom(npoints_interface_bottom-1))
call spline(xinterface_bottom,zinterface_bottom,npoints_interface_bottom,tang1,tangN,coefs_interface_bottom)
-! calculer le spline pour l'interface du haut, imposer la tangente aux deux bords
+! compute the spline for the top interface, impose the tangent on both edges
tang1 = (zinterface_top(2)-zinterface_top(1)) / (xinterface_top(2)-xinterface_top(1))
tangN = (zinterface_top(npoints_interface_top)-zinterface_top(npoints_interface_top-1)) / &
(xinterface_top(npoints_interface_top)-xinterface_top(npoints_interface_top-1))
call spline(xinterface_top,zinterface_top,npoints_interface_top,tang1,tangN,coefs_interface_top)
-! tester si on est sur la derniere couche, qui contient la topographie
-! et modifier position de la source si source exactement en surface
+! 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)
-! calcul de l'offset de cette couche en nombre d'elements spectraux suivant Z
+! compute the offset of this layer in terms of number of spectral elements below along Z
if(ilayer > 1) then
ioffset = sum(nz_layer(1:ilayer-1))
else
ioffset = 0
endif
-!--- definition du maillage
+!--- definition of the mesh
do ix = 0,nx
-! points regulierement espaces suivant X
+! evenly spaced points along X
absx = xmin + (xmax - xmin) * dble(ix) / dble(nx)
! value of the bottom and top splines
@@ -533,7 +525,7 @@
enddo
-! l'interface du haut devient celle du bas pour passer a la couche suivante
+! the top interface becomes the bottom interface before switching to the next layer
npoints_interface_bottom = npoints_interface_top
xinterface_bottom(:) = xinterface_top(:)
zinterface_bottom(:) = zinterface_top(:)
@@ -542,23 +534,23 @@
close(IIN_INTERFACES)
-! calculer min et max de X et Z sur la grille
+! compute min and max of X and Z in the grid
print *
- print *,'Valeurs min et max de X sur le maillage = ',minval(x),maxval(x)
- print *,'Valeurs min et max de Z sur le maillage = ',minval(z),maxval(z)
+ print *,'Min and max value of X in the grid = ',minval(x),maxval(x)
+ print *,'Min and max value of Z in the grid = ',minval(z),maxval(z)
print *
! ***
-! *** generer un fichier Gnuplot pour le controle de la grille ***
+! *** create a Gnuplot file that displays the grid
! ***
print *
- print *,'Ecriture de la grille format Gnuplot...'
+ print *,'Saving the grid in Gnuplot format...'
open(unit=20,file='OUTPUT_FILES/gridfile.gnu',status='unknown')
-! dessin des lignes horizontales de la grille
- print *,'Ecriture lignes horizontales'
+! draw horizontal lines of the grid
+ print *,'drawing horizontal lines of the grid'
istepx = 1
if(ngnod == 4) then
istepz = 1
@@ -573,8 +565,8 @@
enddo
enddo
-! dessin des lignes verticales de la grille
- print *,'Ecriture lignes verticales'
+! draw vertical lines of the grid
+ print *,'drawing vertical lines of the grid'
if(ngnod == 4) then
istepx = 1
else
@@ -593,7 +585,7 @@
close(20)
-! cree le script de dessin pour gnuplot
+! create a Gnuplot script to display the grid
open(unit=20,file='OUTPUT_FILES/plotgnu',status='unknown')
write(20,*) '#set term X11'
write(20,*) 'set term postscript landscape monochrome solid "Helvetica" 22'
@@ -603,13 +595,13 @@
! use same unit length on both X and Y axes
write(20,*) 'set size ratio -1'
write(20,*) 'plot "gridfile.gnu" title "Macrobloc mesh" w l'
- write(20,*) 'pause -1 "appuyez sur une touche"'
+ write(20,*) 'pause -1 "Hit any key..."'
close(20)
- print *,'Fin ecriture de la grille format Gnuplot'
+ print *,'Grid saved in Gnuplot format...'
print *
-! *** generation de la base de donnees
+! *** generate the database for the solver
open(unit=15,file='OUTPUT_FILES/Database',status='unknown')
@@ -618,7 +610,7 @@
write(15,*) '# Dimitri Komatitsch, (c) University of Pau, France'
write(15,*) '#'
- write(15,*) 'Titre simulation'
+ write(15,*) 'Title of the simulation'
write(15,"(a50)") title
npgeo = (nx+1)*(nz+1)
@@ -633,23 +625,26 @@
write(15,*) 'gnuplot interpol'
write(15,*) gnuplot,interpol
- write(15,*) 'itaff output_postscript_snapshot output_color_image colors numbers'
- write(15,*) itaff,output_postscript_snapshot,output_color_image,' 1 0'
+ write(15,*) 'NTSTEP_BETWEEN_OUTPUT_INFO'
+ write(15,*) NTSTEP_BETWEEN_OUTPUT_INFO
- write(15,*) 'meshvect modelvect boundvect cutvect subsamp sizemax_arrows nx_sem_color'
- write(15,*) meshvect,modelvect,boundvect,cutvect,subsamp,sizemax_arrows,nxread
+ write(15,*) 'output_postscript_snapshot output_color_image colors numbers'
+ write(15,*) output_postscript_snapshot,output_color_image,' 1 0'
+ write(15,*) 'meshvect modelvect boundvect cutsnaps subsamp sizemax_arrows'
+ write(15,*) meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows
+
write(15,*) 'anglerec'
write(15,*) anglerec
write(15,*) 'initialfield'
write(15,*) initialfield
- write(15,*) 'sismostype vecttype'
- write(15,*) sismostype,vecttype
+ write(15,*) 'seismotype imagetype'
+ write(15,*) seismotype,imagetype
- write(15,*) 'read_external_model outputgrid ELASTIC TURN_ANISOTROPY_ON TURN_ATTENUATION_ON'
- write(15,*) read_external_model,outputgrid,ELASTIC,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
+ 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
@@ -665,125 +660,126 @@
enddo
!
-!--- introduction des bords absorbants
+!--- definition of absorbing boundaries
!
nelemabs = 0
- if(absbas) nelemabs = nelemabs + nx
- if(abshaut) nelemabs = nelemabs + nx
- if(absgauche) nelemabs = nelemabs + nz
- if(absdroite) nelemabs = nelemabs + nz
+ if(absbottom) nelemabs = nelemabs + nx
+ if(abstop) nelemabs = nelemabs + nx
+ if(absleft) nelemabs = nelemabs + nz
+ if(absright) nelemabs = nelemabs + nz
-! on a deux fois trop d'elements si elements 9 noeuds
+! we have counted the elements twice if they have nine nodes
if(ngnod == 9) nelemabs = nelemabs / 2
-! enlever aussi les coins qui ont ete comptes deux fois
- if(absbas .and. absgauche) nelemabs = nelemabs - 1
- if(absbas .and. absdroite) nelemabs = nelemabs - 1
- if(abshaut .and. absgauche) nelemabs = nelemabs - 1
- if(abshaut .and. absdroite) nelemabs = nelemabs - 1
+! also remove the corner elements, which have been counted twice
+ if(absbottom .and. absleft) nelemabs = nelemabs - 1
+ if(absbottom .and. absright) nelemabs = nelemabs - 1
+ if(abstop .and. absleft) nelemabs = nelemabs - 1
+ if(abstop .and. absright) nelemabs = nelemabs - 1
-!
-!--- introduction de la surface libre si milieu acoustique
-!
- nelemsurface = nx
+! count the number of acoustic free-surface elements
+ nelem_acoustic_surface = 0
+ do j = 1,nzread
+ do i = 1,nxread
+ if(ngnod == 4) then
+ imaterial_number = num_material(i,j)
+ else
+ imaterial_number = num_material(2*(i-1)+1,2*(j-1)+1)
+ endif
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. cs(imaterial_number) < TINYVAL &
+ .and. j == nzread) nelem_acoustic_surface = nelem_acoustic_surface + 1
+ enddo
+ enddo
-! on a deux fois trop d'elements si elements 9 noeuds
- if(ngnod == 9) nelemsurface = nelemsurface / 2
+ write(15,*) 'numat ngnod nspec pointsdisp plot_lowerleft_corner_only'
+ write(15,*) nb_materials,ngnod,nspec,pointsdisp,plot_lowerleft_corner_only
+ write(15,*) 'nelemabs nelem_acoustic_surface'
+ write(15,*) nelemabs,nelem_acoustic_surface
- write(15,*) 'numat ngnod nspec pointsdisp plot_lowerleft_corner_only nelemabs nelemsurface'
- write(15,*) nbmodeles,ngnod,nspec,pointsdisp,plot_lowerleft_corner_only,nelemabs,nelemsurface
-
- write(15,*) 'Material sets (num 0 rho vp vs 0 0) or (num 1 rho c11 c13 c33 c44)'
- do i=1,nbmodeles
+ write(15,*) 'Material sets (num 1 rho vp vs 0 0) or (num 2 rho c11 c13 c33 c44)'
+ do i=1,nb_materials
write(15,*) i,icodemat(i),rho(i),cp(i),cs(i),aniso3(i),aniso4(i)
enddo
write(15,*) 'Arrays kmato and knods for each bloc:'
- k=0
+ k = 0
if(ngnod == 4) then
do j=0,nz-1
- do i=0,nx-1
-
- k = k + 1
- imatnum = num_modele(i+1,j+1)
- write(15,*) k,imatnum,num(i,j,nx),num(i+1,j,nx),num(i+1,j+1,nx),num(i,j+1,nx)
+ do i=0,nx-1
+ k = k + 1
+ imaterial_number = num_material(i+1,j+1)
+ write(15,*) k,imaterial_number,num(i,j,nx),num(i+1,j,nx),num(i+1,j+1,nx),num(i,j+1,nx)
+ enddo
enddo
- enddo
else
do j=0,nz-2,2
- do i=0,nx-2,2
-
- k = k + 1
- imatnum = num_modele(i+1,j+1)
- write(15,*) k,imatnum,num(i,j,nx),num(i+2,j,nx),num(i+2,j+2,nx), &
- num(i,j+2,nx),num(i+1,j,nx),num(i+2,j+1,nx), &
- num(i+1,j+2,nx),num(i,j+1,nx),num(i+1,j+1,nx)
-
+ do i=0,nx-2,2
+ k = k + 1
+ imaterial_number = num_material(i+1,j+1)
+ write(15,*) k,imaterial_number,num(i,j,nx),num(i+2,j,nx),num(i+2,j+2,nx),num(i,j+2,nx), &
+ num(i+1,j,nx),num(i+2,j+1,nx),num(i+1,j+2,nx),num(i,j+1,nx),num(i+1,j+1,nx)
+ enddo
enddo
- enddo
endif
!
-!--- sauvegarde des bords absorbants
+!--- save absorbing boundaries
!
print *
- print *,'Au total il y a ',nelemabs,' elements absorbants'
+ print *,'There is a total of ',nelemabs,' absorbing elements'
print *
- print *,'Bords absorbants actifs :'
+ print *,'Active absorbing boundaries:'
print *
- print *,'Haut = ',abshaut
- print *,'Bas = ',absbas
- print *,'Gauche = ',absgauche
- print *,'Droite = ',absdroite
+ print *,'Bottom = ',absbottom
+ print *,'Right = ',absright
+ print *,'Top = ',abstop
+ print *,'Left = ',absleft
print *
-! generer la liste des elements absorbants
+! generate the list of absorbing elements
if(nelemabs > 0) then
- write(15,*) 'Liste des elements absorbants (haut bas gauche droite) :'
- inumabs = 0
+ write(15,*) 'List of absorbing elements (bottom right top left):'
do iz = 1,nzread
do ix = 1,nxread
- codehaut = .false.
- codebas = .false.
- codegauche = .false.
- codedroite = .false.
+ codebottom = .false.
+ coderight = .false.
+ codetop = .false.
+ codeleft = .false.
inumelem = (iz-1)*nxread + ix
- if(abshaut .and. iz == nzread) codehaut = .true.
- if(absbas .and. iz == 1) codebas = .true.
- if(absgauche .and. ix == 1) codegauche = .true.
- if(absdroite .and. ix == nxread) codedroite = .true.
- if(codehaut .or. codebas .or. codegauche .or. codedroite) then
- inumabs = inumabs + 1
- write(15,*) inumabs,inumelem,codehaut,codebas,codegauche,codedroite
- endif
+ if(absbottom .and. iz == 1) codebottom = .true.
+ if(absright .and. ix == nxread) coderight = .true.
+ if(abstop .and. iz == nzread) codetop = .true.
+ if(absleft .and. ix == 1) codeleft = .true.
+ if(codebottom .or. coderight .or. codetop .or. codeleft) write(15,*) inumelem,codebottom,coderight,codetop,codeleft
enddo
enddo
endif
!
-!--- sauvegarde de la surface libre
+!--- save acoustic free-surface elements
!
print *
- print *,'Au total il y a ',nelemsurface,' elements a la surface libre'
+ print *,'There is a total of ',nelem_acoustic_surface,' acoustic free-surface elements'
print *
-! generer la liste des elements a la surface libre
- if(nelemsurface > 0) then
- write(15,*) 'Liste des elements a la surface libre'
-! we need to know if it is also an absorbing edge, in which case we turn off the acoustic free surface
- write(15,*) abshaut
- inumsurface = 0
- do iz = 1,nzread
- do ix = 1,nxread
- inumelem = (iz-1)*nxread + ix
- if(iz == nzread) then
- inumsurface = inumsurface + 1
- write(15,*) inumsurface,inumelem
- endif
- enddo
- enddo
+! generate the list of acoustic free-surface elements
+ if(nelem_acoustic_surface > 0) then
+ write(15,*) 'List of acoustic free-surface elements:'
+ do j = 1,nzread
+ do i = 1,nxread
+ inumelem = (j-1)*nxread + i
+ if(ngnod == 4) then
+ imaterial_number = num_material(i,j)
+ else
+ imaterial_number = num_material(2*(i-1)+1,2*(j-1)+1)
+ endif
+! in this simple mesher, it is always the top edge that is at the free surface
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. cs(imaterial_number) < TINYVAL .and. j == nzread) &
+ write(15,*) inumelem,ITOP
+ enddo
+ enddo
endif
close(15)
@@ -832,7 +828,7 @@
zrec = zdeb(ireceiverlines)
endif
-! modifier position du recepteur si enregistrement exactement en surface
+! modify position of receiver if we must record exactly at the surface
if(enreg_surf(ireceiverlines)) &
zrec = value_spline(xrec,xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
@@ -850,11 +846,11 @@
end program meshfem2D
-! ********************
-! routines de maillage
-! ********************
+! *******************
+! meshing subroutines
+! *******************
-!--- numero global du noeud
+!--- global node number
integer function num(i,j,nx)
@@ -866,7 +862,7 @@
end function num
-!--- representation des interfaces par un spline
+!--- spline to describe the interfaces
double precision function value_spline(x,xinterface,zinterface,coefs_interface,npoints_interface)
@@ -880,7 +876,7 @@
xp = x
-! si on sort du modele, prolonger par continuite
+! assign the value on the edge if point is outside the model
if(xp < xinterface(1)) xp = xinterface(1)
if(xp > xinterface(npoints_interface)) xp = xinterface(npoints_interface)
@@ -890,7 +886,8 @@
! --------------------------------------
-! routine de calcul des coefs du spline (adapted from Numerical Recipes)
+! compute spline coefficients (Numerical Recipes)
+! modified to use dynamic allocation
subroutine spline(x,y,n,yp1,ypn,y2)
@@ -913,8 +910,7 @@
sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
p=sig*y2(i-1)+2.d0
y2(i)=(sig-1.d0)/p
- u(i)=(6.d0*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) &
- /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
+ u(i)=(6.d0*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
enddo
qn=0.5d0
@@ -931,9 +927,9 @@
! --------------
-! routine d'evaluation du spline (adapted from Numerical Recipes)
+! evaluate spline (adapted from Numerical Recipes)
- subroutine splint(XA,YA,Y2A,N,X,Y)
+ subroutine splint(xa,ya,y2a,n,x,y)
implicit none
@@ -956,7 +952,7 @@
endif
enddo
- H = XA(KHI)-XA(KLO)
+ H = XA(KHI) - XA(KLO)
IF (H == 0.d0) stop 'bad input in spline evaluation'
A = (XA(KHI)-X) / H
Modified: seismo/2D/SPECFEM2D/trunk/plotgll.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/plotgll.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/plotgll.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,13 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
Modified: seismo/2D/SPECFEM2D/trunk/plotpost.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/plotpost.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/plotpost.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,25 +1,26 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
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, &
- numabs,codeabs,anyabs,stitle,npoin,npgeo,vpmin,vpmax,nrec, &
- colors,numbers,subsamp,vecttype,interpol,meshvect,modelvect, &
- boundvect,read_external_model,cutvect,sizemax_arrows,nelemabs,numat,pointsdisp,nspec,ngnod,ELASTIC, &
- plot_lowerleft_corner_only)
+ numabs,codeabs,anyabs,simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
+ 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)
!
-! routine affichage postscript
+! PostScript display routine
!
implicit none
@@ -45,37 +46,45 @@
double precision dt,timeval,x_source,z_source
double precision displ(NDIM,npoin),coord(NDIM,npoin)
- double precision vpext(npoin)
+ double precision vpext(NGLLX,NGLLZ,nspec)
double precision coorg(NDIM,npgeo)
double precision, dimension(nrec) :: st_xval,st_zval
integer numabs(nelemabs),codeabs(4,nelemabs)
- logical anyabs,ELASTIC,plot_lowerleft_corner_only
+ logical anyabs,coupled_acoustic_elastic,any_acoustic,plot_lowerleft_corner_only
+! for fluid/solid edge detection
+ integer :: num_fluid_solid_edges
+ integer, dimension(num_fluid_solid_edges) :: fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge
+
double precision xmax,zmax,height,xw,zw,usoffset,sizex,sizez,vpmin,vpmax
- character(len=100) name
- character ch1(100),ch2(100)
- equivalence (name,ch1)
- logical first
+! for the file name
+ character(len=100) :: file_name
+! to suppress useless white spaces in postscript lines
+ character(len=100) :: postscript_line
+ character(len=1), dimension(100) :: ch1,ch2
+ equivalence (postscript_line,ch1)
+ logical :: first
+
double precision convert,x1,rlamda,rmu,denst,rKvol,cploc,xa,za,xb,zb
double precision z1,x2,z2,d,d1,d2,dummy,theta,thetaup,thetadown
- integer k,j,ispec,material,is,ir,imat,icol,l,longueur
- integer indice,ii,ipoin,in,nnum,ispecabs,ideb,ifin,ibord
+ integer k,j,ispec,material,is,ir,imat,icol,l,line_length
+ integer index_char,ii,ipoin,in,nnum,inum,ideb,ifin,iedge
- integer colors,numbers,subsamp,vecttype
- logical interpol,meshvect,modelvect,boundvect,read_external_model
- double precision cutvect,sizemax_arrows
+ integer colors,numbers,subsamp,imagetype
+ logical interpol,meshvect,modelvect,boundvect,assign_external_model
+ double precision cutsnaps,sizemax_arrows
- double precision rapp_page,dispmax,xmin,zmin
+ double precision ratio_page,dispmax,xmin,zmin
! title of the plot
- character(len=60) stitle
+ character(len=60) simulation_title
-! papier A4 ou US letter
+! A4 or US letter paper
if(US_LETTER) then
usoffset = 1.75d0
sizex = 27.94d0
@@ -86,6 +95,9 @@
sizez = 21.d0
endif
+! height of domain numbers in centimeters
+ height = 0.25d0
+
! define color palette in random order
! red
@@ -98,10 +110,10 @@
green(2) = 0.525490196078431
blue(2) = 0.933333333333333
-! Bisque3
- red(3) = 0.803921568627451
- green(3) = 0.717647058823529
- blue(3) = 0.619607843137255
+! gold
+ red(3) = 1.00000000000000
+ green(3) = 0.840000000000000
+ blue(3) = 0.000000000000000E+000
! springgreen
red(4) = 0.000000000000000E+000
@@ -138,10 +150,10 @@
green(10) = 0.509803921568627
blue(10) = 0.705882352941177
-! gold
- red(11) = 1.00000000000000
- green(11) = 0.840000000000000
- blue(11) = 0.000000000000000E+000
+! Bisque3
+ red(11) = 0.803921568627451
+ green(11) = 0.717647058823529
+ blue(11) = 0.619607843137255
! Salmon
red(12) = 0.980392156862745
@@ -1276,26 +1288,23 @@
write(IOUT,*) 'X min, max = ',xmin,xmax
write(IOUT,*) 'Z min, max = ',zmin,zmax
-! rapport taille page/taille domaine physique
- rapp_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) / 100.d0
+! ratio of physical page size/size of the domain meshed
+ ratio_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) / 100.d0
-! recherche de la valeur maximum de la norme du deplacement
+! compute the maximum of the norm of the vector
dispmax = maxval(sqrt(displ(1,:)**2 + displ(2,:)**2))
write(IOUT,*) 'Max norm = ',dispmax
-! hauteur des numeros de domaine en CM
- height = 0.25d0
-
!
-!---- ouverture du fichier PostScript
+!---- open PostScript file
!
- write(name,"('OUTPUT_FILES/vect',i6.6,'.ps')") it
- open(unit=24,file=name,status='unknown')
+ write(file_name,"('OUTPUT_FILES/vect',i6.6,'.ps')") it
+ open(unit=24,file=file_name,status='unknown')
!
-!---- ecriture de l'entete du fichier PostScript
+!---- write PostScript header
!
- write(24,10) stitle
+ write(24,10) simulation_title
write(24,*) '/CM {28.5 mul} def'
write(24,*) '/LR {rlineto} def'
write(24,*) '/LT {lineto} def'
@@ -1316,7 +1325,7 @@
write(24,*) '/GR {grestore} def'
write(24,*) '/SLW {setlinewidth} def'
write(24,*) '/SCSF {scalefont setfont} def'
- write(24,*) '% differents symboles utiles'
+ write(24,*) '% different useful symbols'
write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
write(24,*) 'CP fill} def'
@@ -1327,33 +1336,33 @@
write(24,*) 'GS 3 -3 MR -6. 6. LR ST GR'
write(24,*) '0.01 CM SLW} def'
write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
- write(24,*) '/Losange {GS 0.05 CM SLW 0 4.2 MR'
+ write(24,*) '/Diamond {GS 0.05 CM SLW 0 4.2 MR'
write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
write(24,*) 'GR 0.01 CM SLW} def'
write(24,*) '%'
- write(24,*) '% niveaux de gris pour le modele de vitesse'
+ write(24,*) '% gray levels for the velocity model'
write(24,*) '/BK {setgray fill} def'
- write(24,*) '% version noir et blanc'
+ write(24,*) '% black and white version'
write(24,*) '%/BK {pop 1 setgray fill} def'
write(24,*) '%'
- write(24,*) '% magenta pour les vecteurs deplacement'
+ write(24,*) '% magenta for vectors'
write(24,*) '/Colvects {0.01 CM SLW 1. 0. 1. RG} def'
- write(24,*) '% version noir et blanc'
+ write(24,*) '% black and white version'
write(24,*) '%/Colvects {0.01 CM SLW 0. setgray} def'
write(24,*) '%'
- write(24,*) '% chartreuse pour le maillage des macroblocs'
+ write(24,*) '% chartreuse for macrobloc mesh'
write(24,*) '/Colmesh {0.02 CM SLW 0.5 1. 0. RG} def'
- write(24,*) '% version noir et blanc'
+ write(24,*) '% black and white version'
write(24,*) '%/Colmesh {0.02 CM SLW 0. setgray} def'
write(24,*) '%'
- write(24,*) '% cyan pour les sources et recepteurs'
+ write(24,*) '% cyan for sources and receivers'
write(24,*) '/Colreceiv {0. 1. 1. RG} def'
- write(24,*) '% version noir et blanc'
+ write(24,*) '% black and white version'
write(24,*) '%/Colreceiv {0. setgray} def'
write(24,*) '%'
- write(24,*) '% macro dessin fleche'
+ write(24,*) '% macro to draw an arrow'
write(24,*) '/F {MV LR gsave LR ST grestore LR ST} def'
- write(24,*) '% macro dessin contour elements'
+ write(24,*) '% macro to draw the contour of the elements'
write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
write(24,*) '%'
write(24,*) '.01 CM SLW'
@@ -1369,16 +1378,18 @@
write(24,*) '%'
write(24,*) 'gsave newpath 90 rotate'
write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '% uncomment this to zoom on parts of the mesh'
+ write(24,*) '% -32 CM -21 CM translate 3. 3. scale'
+ write(24,*) '% -52 CM -24 CM translate 4. 4. scale'
write(24,*) '%'
!
-!--- ecriture des legendes du fichier PostScript
+!--- write captions of PostScript figure
!
write(24,*) '0 setgray'
write(24,*) '/Times-Roman findfont'
write(24,*) '.5 CM SCSF'
- if(legendes) then
write(24,*) '24. CM 1.2 CM MV'
write(24,610) usoffset,it
write(24,*) '%'
@@ -1395,7 +1406,7 @@
write(24,640) usoffset,dispmax
write(24,*) '%'
write(24,*) '24. CM 3.45 CM MV'
- write(24,620) usoffset,cutvect*100.d0
+ write(24,620) usoffset,cutsnaps*100.d0
write(24,*) '%'
write(24,*) '/Times-Roman findfont'
@@ -1415,11 +1426,11 @@
write(24,*) '24.35 CM 18.9 CM MV'
write(24,*) usoffset,' CM 2 div neg 0 MR'
write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- if(vecttype == 1) then
+ if(imagetype == 1) then
write(24,*) '(Displacement vector field) show'
- else if(vecttype == 2) then
+ else if(imagetype == 2) then
write(24,*) '(Velocity vector field) show'
- else if(vecttype == 3) then
+ else if(imagetype == 3) then
write(24,*) '(Acceleration vector field) show'
else
stop 'Bad field code in PostScript display'
@@ -1428,24 +1439,24 @@
write(24,*) '25.35 CM 18.9 CM MV'
write(24,*) usoffset,' CM 2 div neg 0 MR'
write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(',stitle,') show'
+ write(24,*) '(',simulation_title,') show'
write(24,*) 'grestore'
write(24,*) '26.45 CM 18.9 CM MV'
write(24,*) usoffset,' CM 2 div neg 0 MR'
write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- if(ELASTIC) then
+ if(coupled_acoustic_elastic) then
+ write(24,*) '(Coupled Acoustic/Elastic Wave 2D - SEM) show'
+ else if(any_acoustic) then
+ write(24,*) '(Acoustic Wave 2D - Spectral Element Method) show'
+ else
write(24,*) '(Elastic Wave 2D - Spectral Element Method) show'
- else
- write(24,*) '(Acoustic Wave 2D - Spectral Element Method) show'
endif
write(24,*) 'grestore'
- endif
-
write(24,*) '%'
- write(24,*) scalex,' ',scalez,' scale'
+ write(24,*) '1 1 scale'
write(24,*) '%'
!
@@ -1454,7 +1465,7 @@
write(IOUT,*) 'Shape functions based on ',ngnod,' control nodes'
- convert = pi/180.d0
+ convert = PI / 180.d0
!
!---- draw the velocity model in background
@@ -1466,8 +1477,8 @@
do j=1,NGLLX-subsamp,subsamp
if((vpmax-vpmin)/vpmin > 0.02d0) then
- if(read_external_model) then
- x1 = (vpext(ibool(i,j,ispec))-vpmin)/ (vpmax-vpmin)
+ if(assign_external_model) then
+ x1 = (vpext(i,j,ispec)-vpmin) / (vpmax-vpmin)
else
material = kmato(ispec)
rlamda = elastcoef(1,material)
@@ -1481,44 +1492,46 @@
x1 = 0.5d0
endif
-! rescaler pour eviter gris trop sombre
+! rescale to avoid very dark gray levels
x1 = x1*0.7 + 0.2
if(x1 > 1.d0) x1=1.d0
-! inverser echelle : blanc = vpmin, gris = vpmax
+! invert scale: white = vpmin, dark gray = vpmax
x1 = 1.d0 - x1
xw = coord(1,ibool(i,j,ispec))
zw = coord(2,ibool(i,j,ispec))
- xw = (xw-xmin)*rapp_page + orig_x
- zw = (zw-zmin)*rapp_page + orig_z
+ 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
xw = coord(1,ibool(i+subsamp,j,ispec))
zw = coord(2,ibool(i+subsamp,j,ispec))
- xw = (xw-xmin)*rapp_page + orig_x
- zw = (zw-zmin)*rapp_page + orig_z
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
xw = xw * centim
zw = zw * centim
write(24,499) xw,zw
xw = coord(1,ibool(i+subsamp,j+subsamp,ispec))
zw = coord(2,ibool(i+subsamp,j+subsamp,ispec))
- xw = (xw-xmin)*rapp_page + orig_x
- zw = (zw-zmin)*rapp_page + orig_z
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
xw = xw * centim
zw = zw * centim
write(24,499) xw,zw
xw = coord(1,ibool(i,j+subsamp,ispec))
zw = coord(2,ibool(i,j+subsamp,ispec))
- xw = (xw-xmin)*rapp_page + orig_x
- zw = (zw-zmin)*rapp_page + orig_z
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
xw = xw * centim
zw = zw * centim
write(24,499) xw,zw
+
+! display P-velocity model using gray levels
write(24,604) x1
enddo
@@ -1528,9 +1541,8 @@
endif
!
-!---- draw spectral element mesh
+!---- draw the spectral element mesh
!
-
if(meshvect) then
write(24,*) '%'
@@ -1555,8 +1567,8 @@
is = 1
ir = 1
- x1 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
- z1 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
x1 = x1 * centim
z1 = z1 * centim
write(24,*) 'MK'
@@ -1564,45 +1576,45 @@
if(ngnod == 4) then
-! tracer des droites si elements 4 noeuds
+! draw straight lines if elements have 4 nodes
ir=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
x2 = x2 * centim
z2 = z2 * centim
write(24,681) x2,z2
ir=pointsdisp
is=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
x2 = x2 * centim
z2 = z2 * centim
write(24,681) x2,z2
is=pointsdisp
ir=1
- x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
x2 = x2 * centim
z2 = z2 * centim
write(24,681) x2,z2
ir=1
is=2
- x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
x2 = x2 * centim
z2 = z2 * centim
write(24,681) x2,z2
else
-! tracer des courbes si elements 9 noeuds
+! draw curved lines if elements have 9 nodes
do ir=2,pointsdisp
- x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
x2 = x2 * centim
z2 = z2 * centim
write(24,681) x2,z2
@@ -1610,8 +1622,8 @@
ir=pointsdisp
do is=2,pointsdisp
- x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
x2 = x2 * centim
z2 = z2 * centim
write(24,681) x2,z2
@@ -1619,8 +1631,8 @@
is=pointsdisp
do ir=pointsdisp-1,1,-1
- x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
x2 = x2 * centim
z2 = z2 * centim
write(24,681) x2,z2
@@ -1628,8 +1640,8 @@
ir=1
do is=pointsdisp-1,2,-1
- x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
x2 = x2 * centim
z2 = z2 * centim
write(24,681) x2,z2
@@ -1658,19 +1670,17 @@
! write the element number, the group number and the material number inside the element
if(numbers == 1) then
- xw = (coorg(1,knods(1,ispec)) + coorg(1,knods(2,ispec)) + &
- coorg(1,knods(3,ispec)) + coorg(1,knods(4,ispec))) / 4.d0
- zw = (coorg(2,knods(1,ispec)) + coorg(2,knods(2,ispec)) + &
- coorg(2,knods(3,ispec)) + coorg(2,knods(4,ispec))) / 4.d0
- xw = (xw-xmin)*rapp_page + orig_x
- zw = (zw-zmin)*rapp_page + orig_z
+ xw = (coorg(1,knods(1,ispec)) + coorg(1,knods(2,ispec)) + coorg(1,knods(3,ispec)) + coorg(1,knods(4,ispec))) / 4.d0
+ zw = (coorg(2,knods(1,ispec)) + coorg(2,knods(2,ispec)) + coorg(2,knods(3,ispec)) + coorg(2,knods(4,ispec))) / 4.d0
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
xw = xw * centim
zw = zw * centim
if(colors == 1) write(24,*) '1 setgray'
write(24,500) xw,zw
-!--- ecriture numero de l'element
+! write spectral element number
write(24,502) ispec
endif
@@ -1680,7 +1690,7 @@
endif
!
-!---- draw the boundary conditions
+!--- draw absorbing boundaries with a thick color line
!
if(anyabs .and. boundvect) then
@@ -1689,49 +1699,40 @@
write(24,*) '% boundary conditions on the mesh'
write(24,*) '%'
- write(24,*) '0.05 CM SLW'
+! use green color
+ write(24,*) '0 1 0 RG'
-!--- bords absorbants
+ write(24,*) '0.10 CM SLW'
+ write(24,*) '% uncomment this when zooming on parts of the mesh'
+ write(24,*) '% 0.02 CM SLW'
- if(anyabs) then
+ do inum = 1,nelemabs
+ ispec = numabs(inum)
- do ispecabs = 1,nelemabs
- ispec = numabs(ispecabs)
+ do iedge = 1,4
-!--- une couleur pour chaque condition absorbante
-!--- bord absorbant de type "haut" : orange
-!--- bord absorbant de type "bas" : vert clair
-!--- bord absorbant de type "gauche" : rose clair
-!--- bord absorbant de type "droite" : turquoise
+ if(codeabs(iedge,inum) /= 0) then
- do ibord = 1,4
-
- if(codeabs(ibord,ispecabs) /= 0) then
-
- if(ibord == ITOP) then
- write(24,*) '1. .85 0. RG'
+ if(iedge == ITOP) then
ideb = 3
ifin = 4
- else if(ibord == IBOTTOM) then
- write(24,*) '.4 1. .4 RG'
+ else if(iedge == IBOTTOM) then
ideb = 1
ifin = 2
- else if(ibord == ILEFT) then
- write(24,*) '1. .43 1. RG'
+ else if(iedge == ILEFT) then
ideb = 4
ifin = 1
- else if(ibord == IRIGHT) then
- write(24,*) '.25 1. 1. RG'
+ else if(iedge == IRIGHT) then
ideb = 2
ifin = 3
else
stop 'Wrong absorbing boundary code'
endif
- x1 = (coorg(1,knods(ideb,ispec))-xmin)*rapp_page + orig_x
- z1 = (coorg(2,knods(ideb,ispec))-zmin)*rapp_page + orig_z
- x2 = (coorg(1,knods(ifin,ispec))-xmin)*rapp_page + orig_x
- z2 = (coorg(2,knods(ifin,ispec))-zmin)*rapp_page + orig_z
+ 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
@@ -1743,20 +1744,75 @@
enddo
+ write(24,*) '0 setgray'
+ write(24,*) '0.01 CM SLW'
+
endif
+!
+!---- draw the fluid-solid coupling edges with a thick color line
+!
+
+ if(coupled_acoustic_elastic .and. boundvect) then
+
+ write(24,*) '%'
+ write(24,*) '% fluid-solid coupling edges in the mesh'
+ write(24,*) '%'
+
+ write(24,*) '0.10 CM SLW'
+ write(24,*) '% uncomment this when zooming on parts of the mesh'
+ write(24,*) '% 0.02 CM SLW'
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_solid_edges
+
+! get the edge of the acoustic element
+ ispec = fluid_solid_acoustic_ispec(inum)
+ iedge = fluid_solid_acoustic_iedge(inum)
+
+! use pink color
+ 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
+ stop '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
+ write(24,602) x1,z1,x2,z2
+
+ enddo
+
write(24,*) '0 setgray'
write(24,*) '0.01 CM SLW'
endif
!
-!---- draw the normalized displacement field
+!---- draw the normalized vector field
!
-! return if the maximum displacement equals zero (no source)
+! return if the maximum vector equals zero (no source)
if(dispmax == 0.d0) then
- write(IOUT,*) ' null displacement : returning !'
+ write(IOUT,*) 'null vector: returning!'
return
endif
@@ -1764,7 +1820,7 @@
write(24,*) '% vector field'
write(24,*) '%'
-! fleches en couleur si modele de vitesse en background
+! color arrows if we draw the velocity model in the background
if(modelvect) then
write(24,*) 'Colvects'
else
@@ -1777,7 +1833,7 @@
do ispec=1,nspec
-! interpolation sur grille reguliere
+! interpolation on a uniform grid
if(mod(ispec,1000) == 0) write(IOUT,*) 'Interpolation uniform grid element ',ispec
! option to plot only lowerleft corner value to avoid very large files if dense meshes
@@ -1804,27 +1860,25 @@
do k=1,NGLLX
do l=1,NGLLX
- Uxinterp(i,j) = Uxinterp(i,j) + &
- displ(1,ibool(k,l,ispec))*flagrange(k,i)*flagrange(l,j)
- Uzinterp(i,j) = Uzinterp(i,j) + &
- displ(2,ibool(k,l,ispec))*flagrange(k,i)*flagrange(l,j)
+ Uxinterp(i,j) = Uxinterp(i,j) + displ(1,ibool(k,l,ispec))*flagrange(k,i)*flagrange(l,j)
+ Uzinterp(i,j) = Uzinterp(i,j) + displ(2,ibool(k,l,ispec))*flagrange(k,i)*flagrange(l,j)
enddo
enddo
- x1 =(xinterp(i,j)-xmin)*rapp_page
- z1 =(zinterp(i,j)-zmin)*rapp_page
+ x1 =(xinterp(i,j)-xmin)*ratio_page
+ z1 =(zinterp(i,j)-zmin)*ratio_page
x2 = Uxinterp(i,j)*sizemax_arrows/dispmax
z2 = Uzinterp(i,j)*sizemax_arrows/dispmax
d = sqrt(x2**2 + z2**2)
-! ignorer si vecteur trop petit
- if(d > cutvect*sizemax_arrows) then
+! ignore if vector is too small
+ if(d > cutsnaps*sizemax_arrows) then
- d1 = d * rapport
- d2 = d1 * cos(angle*convert)
+ d1 = d * ARROW_RATIO
+ d2 = d1 * cos(ARROW_ANGLE*convert)
dummy = x2/d
if(dummy > 0.9999d0) dummy = 0.9999d0
@@ -1832,10 +1886,10 @@
theta = acos(dummy)
if(z2 < 0.d0) theta = 360.d0*convert - theta
- thetaup = theta - angle*convert
- thetadown = theta + angle*convert
+ thetaup = theta - ARROW_ANGLE*convert
+ thetadown = theta + ARROW_ANGLE*convert
-! tracer le vecteur proprement dit
+! draw the vector
x1 = (orig_x+x1) * centim
z1 = (orig_z+z1) * centim
x2 = x2 * centim
@@ -1848,23 +1902,27 @@
zb = -d2*sin(thetadown)
xb = xb * centim
zb = zb * centim
- write(name,700) xb,zb,xa,za,x2,z2,x1,z1
+ write(postscript_line,700) xb,zb,xa,za,x2,z2,x1,z1
-! filtrer les blancs inutiles pour diminuer taille fichier PostScript
- longueur = 49
- indice = 1
+! suppress useless white spaces to make PostScript file smaller
+
+! suppress leading white spaces again, if any
+ postscript_line = adjustl(postscript_line)
+
+ line_length = len_trim(postscript_line)
+ index_char = 1
first = .false.
- do ii=1,longueur-1
+ do ii = 1,line_length-1
if(ch1(ii) /= ' ' .or. first) then
if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
- ch2(indice) = ch1(ii)
- indice = indice + 1
+ ch2(index_char) = ch1(ii)
+ index_char = index_char + 1
first = .true.
endif
endif
enddo
- ch2(indice) = ch1(longueur)
- write(24,"(80(a1))") (ch2(ii),ii=1,indice)
+ ch2(index_char) = ch1(line_length)
+ write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
endif
@@ -1872,24 +1930,24 @@
enddo
enddo
+! draw the vectors at the nodes of the mesh if we do not interpolate the display on a regular grid
else
-! tracer les vecteurs deplacement aux noeuds du maillage
do ipoin=1,npoin
- x1 =(coord(1,ipoin)-xmin)*rapp_page
- z1 =(coord(2,ipoin)-zmin)*rapp_page
+ x1 =(coord(1,ipoin)-xmin)*ratio_page
+ z1 =(coord(2,ipoin)-zmin)*ratio_page
x2 = displ(1,ipoin)*sizemax_arrows/dispmax
z2 = displ(2,ipoin)*sizemax_arrows/dispmax
d = sqrt(x2**2 + z2**2)
-! ignorer si vecteur trop petit
- if(d > cutvect*sizemax_arrows) then
+! ignore if vector is too small
+ if(d > cutsnaps*sizemax_arrows) then
- d1 = d * rapport
- d2 = d1 * cos(angle*convert)
+ d1 = d * ARROW_RATIO
+ d2 = d1 * cos(ARROW_ANGLE*convert)
dummy = x2/d
if(dummy > 0.9999d0) dummy = 0.9999d0
@@ -1897,10 +1955,10 @@
theta = acos(dummy)
if(z2 < 0.d0) theta = 360.d0*convert - theta
- thetaup = theta - angle*convert
- thetadown = theta + angle*convert
+ thetaup = theta - ARROW_ANGLE*convert
+ thetadown = theta + ARROW_ANGLE*convert
-! tracer le vecteur proprement dit
+! draw the vector
x1 = (orig_x+x1) * centim
z1 = (orig_z+z1) * centim
x2 = x2 * centim
@@ -1913,23 +1971,27 @@
zb = -d2*sin(thetadown)
xb = xb * centim
zb = zb * centim
- write(name,700) xb,zb,xa,za,x2,z2,x1,z1
+ write(postscript_line,700) xb,zb,xa,za,x2,z2,x1,z1
-! filtrer les blancs inutiles pour diminuer taille fichier PostScript
- longueur = 49
- indice = 1
+! suppress useless white spaces to make PostScript file smaller
+
+! suppress leading white spaces again, if any
+ postscript_line = adjustl(postscript_line)
+
+ line_length = len_trim(postscript_line)
+ index_char = 1
first = .false.
- do ii=1,longueur-1
+ do ii = 1,line_length-1
if(ch1(ii) /= ' ' .or. first) then
if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
- ch2(indice) = ch1(ii)
- indice = indice + 1
+ ch2(index_char) = ch1(ii)
+ index_char = index_char + 1
first = .true.
endif
endif
enddo
- ch2(indice) = ch1(longueur)
- write(24,"(80(a1))") (ch2(ii),ii=1,indice)
+ ch2(index_char) = ch1(line_length)
+ write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
endif
@@ -1939,7 +2001,7 @@
write(24,*) '0 setgray'
-! sources et recepteurs en couleur si modele de vitesse
+! sources and receivers in color if velocity model
if(modelvect) then
write(24,*) 'Colreceiv'
else
@@ -1951,41 +2013,29 @@
!
xw = x_source
zw = z_source
- xw = (xw-xmin)*rapp_page + orig_x
- zw = (zw-zmin)*rapp_page + orig_z
+ xw = (xw-xmin)*ratio_page + orig_x
+ zw = (zw-zmin)*ratio_page + orig_z
xw = xw * centim
zw = zw * centim
- write(24,510) xw,zw
- if(isymbols) then
- write(24,*) 'Cross'
- else
- write(24,*) '(S) show'
- endif
+ write(24,500) xw,zw
+ write(24,*) 'Cross'
!
!---- write position of the receivers
!
do i=1,nrec
- if(i == 1) write(24,*) '% debut ligne recepteurs'
- if(i == nrec) write(24,*) '% fin ligne recepteurs'
+ if(i == 1) write(24,*) '% beginning of receiver line'
+ if(i == nrec) write(24,*) '% end of receiver line'
- xw = st_xval(i)
- zw = st_zval(i)
+ xw = st_xval(i)
+ zw = st_zval(i)
- xw = (xw-xmin)*rapp_page + orig_x
- zw = (zw-zmin)*rapp_page + orig_z
- xw = xw * centim
- zw = zw * centim
- write(24,510) xw,zw
- if(isymbols) then
- if(nrec > ndots .and. i /= 1 .and. i /= nrec) then
- write(24,*) 'VDot'
- else
- write(24,*) 'Losange'
- endif
- else
- write(24,*) '(R',i,') show'
- endif
+ 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,*) 'Diamond'
enddo
write(24,*) '%'
@@ -1994,23 +2044,21 @@
close(24)
- 10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a50,/, &
- '%% Created by: Specfem2D',/,'%% Author: Dimitri Komatitsch',/,'%%')
- 510 format(f5.1,1x,f5.1,' M')
- 600 format(f6.3,' neg CM 0 MR (Time =',f8.3,' s) show')
- 601 format(f6.3,' neg CM 0 MR (Time =',1pe12.3,' s) show')
- 610 format(f6.3,' neg CM 0 MR (Time step = ',i7,') show')
- 620 format(f6.3,' neg CM 0 MR (Cut =',f5.2,' \%) show')
- 640 format(f6.3,' neg CM 0 MR (Max norm =',1pe12.3,') show')
+ 10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a50,/,'%% Created by: Specfem2D',/,'%% Author: Dimitri Komatitsch',/,'%%')
+ 600 format(f6.3,' neg CM 0 MR (Time =',f8.3,' s) show')
+ 601 format(f6.3,' neg CM 0 MR (Time =',1pe12.3,' s) show')
+ 610 format(f6.3,' neg CM 0 MR (Time step = ',i7,') show')
+ 620 format(f6.3,' neg CM 0 MR (Cut =',f5.2,' \%) show')
+ 640 format(f6.3,' neg CM 0 MR (Max norm =',1pe12.3,') show')
- 499 format(f5.1,1x,f5.1,' L')
- 500 format(f5.1,1x,f5.1,' M')
- 502 format('fN (',i4,') Cshow')
- 680 format(f12.6,1x,f12.6,1x,f12.6,' RG GF')
- 681 format(f6.2,1x,f6.2)
- 602 format(f6.2,1x,f6.2,' M ',f6.2,1x,f6.2,' L ST')
- 604 format('CP ',f12.6,' BK')
- 700 format(8(f5.1,1x),'F')
+ 499 format(f6.2,1x,f6.2,' L')
+ 500 format(f6.2,1x,f6.2,' M')
+ 502 format('fN (',i4,') Cshow')
+ 680 format(f12.6,1x,f12.6,1x,f12.6,' RG GF')
+ 681 format(f6.2,1x,f6.2)
+ 602 format(f6.2,1x,f6.2,' M ',f6.2,1x,f6.2,' L ST')
+ 604 format('CP ',f12.6,' BK')
+ 700 format(8(f6.2,1x),'F')
end subroutine plotpost
Modified: seismo/2D/SPECFEM2D/trunk/read_value_parameters.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/read_value_parameters.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/read_value_parameters.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,13 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
@@ -93,7 +93,8 @@
!--------------------
- subroutine read_zone_coordinates(iin,ignore_junk,value_to_read_1,value_to_read_2,value_to_read_3,value_to_read_4,value_to_read_5)
+ subroutine read_region_coordinates(iin,ignore_junk,value_to_read_1,value_to_read_2, &
+ value_to_read_3,value_to_read_4,value_to_read_5)
implicit none
@@ -105,7 +106,7 @@
call read_next_line(iin,ignore_junk,string_read)
read(string_read,*) value_to_read_1,value_to_read_2,value_to_read_3,value_to_read_4,value_to_read_5
- end subroutine read_zone_coordinates
+ end subroutine read_region_coordinates
!--------------------
Modified: seismo/2D/SPECFEM2D/trunk/recompute_jacobian.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/recompute_jacobian.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/recompute_jacobian.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,13 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
Modified: seismo/2D/SPECFEM2D/trunk/specfem2D.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/specfem2D.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/specfem2D.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,13 +1,13 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
@@ -17,8 +17,40 @@
!
!====================================================================================
+! If you use this code for your own research, please cite:
!
-! version 5.1, January 2005 :
+! @ARTICLE{KoTr99,
+! author={D. Komatitsch and J. Tromp},
+! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
+! journal={Geophys. J. Int.},
+! year=1999,
+! volume=139,
+! number=3,
+! pages={806-822},
+! doi={10.1046/j.1365-246x.1999.00967.x}}
+!
+! @ARTICLE{KoVi98,
+! author={D. Komatitsch and J. P. Vilotte},
+! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
+! journal={Bull. Seismol. Soc. Am.},
+! year=1998,
+! volume=88,
+! number=2,
+! pages={368-392}}
+
+!
+! version 5.2, Dimitri Komatitsch, April 2007 :
+! - general fluid/solid implementation with any number, shape and orientation of
+! matching edges
+! - absorbing edges with any normal vector
+! - general numbering of absorbing and acoustic free surface edges
+! - cleaned implementation of attenuation as in Carcione (1993)
+! - merged loops in the solver for efficiency
+! - simplified input of external model
+! - added CPU time information
+! - translated many comments from French to English
+!
+! version 5.1, Dimitri Komatitsch, January 2005 :
! - more general mesher with any number of curved layers
! - Dirac and Gaussian time sources and corresponding convolution routine
! - option for acoustic medium instead of elastic
@@ -28,9 +60,9 @@
! - more flexible DATA/Par_file with any number of comment lines
! - Xsu scripts for seismograms
! - subtract t0 from seismograms
-! - seismograms and snapshots in pressure in addition to velocity if acoustic medium
+! - seismograms and snapshots in pressure in addition to vector field
!
-! version 5.0, May 2004 :
+! version 5.0, Dimitri Komatitsch, May 2004 :
! - got rid of useless routines, suppressed commons etc.
! - weak formulation based explicitly on stress tensor
! - implementation of full anisotropy
@@ -45,34 +77,15 @@
! Institut de Physique du Globe de Paris, France
!
-! in case of an acoustic medium, a velocity potential Chi is used, as in Komatitsch
-! and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002b).
-! Velocity is then: v = grad(Chi)
-! and pressure is: p = - rho * Chi_dot (Chi_dot being the time derivative of Chi).
-! Therefore, in order to have a Ricker source in pressure, use the first-derivative
-! of a Gaussian for the time source for Chi in the parameter file.
+! in case of an acoustic medium, a displacement potential Chi is used as in Chaljub and Valette,
+! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
+! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
+! This permits acoustic-elastic coupling based on a non-iterative time scheme.
+! Displacement is then: u = grad(Chi)
+! Velocity is then: v = grad(Chi_dot) (Chi_dot being the time derivative of Chi)
+! and pressure is: p = - rho * Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
+! The source in an acoustic element is a pressure source.
-! If you use this code for your own research, please cite:
-!
-! @ARTICLE{KoTr99,
-! author={D. Komatitsch and J. Tromp},
-! year=1999,
-! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
-! journal={Geophys. J. Int.},
-! volume=139,
-! number=3,
-! pages={806-822},
-! doi={10.1046/j.1365-246x.1999.00967.x}}
-!
-! @ARTICLE{KoVi98,
-! author={D. Komatitsch and J. P. Vilotte},
-! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
-! journal={Bull. Seismol. Soc. Am.},
-! year=1998,
-! volume=88,
-! number=2,
-! pages={368-392}}
-
program specfem2D
implicit none
@@ -81,8 +94,8 @@
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
+ 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
double precision, dimension(NDIM,NGLLX,NGLLZ) :: sourcearray
double precision, dimension(:,:), allocatable :: coorg
@@ -94,21 +107,19 @@
! for seismograms
double precision, dimension(:,:), allocatable :: sisux,sisuz
+! vector field in an element
+ double precision, dimension(NDIM,NGLLX,NGLLX) :: vector_field_element
+! pressure in an element
+ double precision, dimension(NGLLX,NGLLX) :: pressure_element
! to write seismograms in single precision SEP and double precision binary format
real(kind=4), dimension(:), allocatable :: buffer_binary_single
double precision, dimension(:), allocatable :: buffer_binary_double
- logical anyabs
+ integer :: i,j,k,it,irec,ipoin,ip,id,nbpoin,inump,n,ispec,iedge,npoin,npgeo,iglob
+ logical :: anyabs
+ double precision :: dxd,dzd,valux,valuz,hlagrange,rhol,cosrot,sinrot,xi,gamma,x,z
- integer i,j,it,irec,ipoin,ip,id
- integer nbpoin,inump,n,npoinext,ispec,npoin,npgeo,iglob
-
- double precision dxd,dzd,valux,valuz,hlagrange,xdummy,zdummy
- double precision cpl,csl,rhol
- double precision cosrot,sinrot
- double precision xi,gamma,x,z
-
! coefficients of the explicit Newmark time scheme
integer NSTEP
double precision deltatover2,deltatsquareover2,time,deltat
@@ -117,104 +128,91 @@
double precision, dimension(NGLLX) :: xigll,wxgll
double precision, dimension(NGLLZ) :: zigll,wzgll
-! array with derivatives of Lagrange polynomials
- double precision, dimension(NGLLX,NGLLX) :: hprime_xx
- double precision, dimension(NGLLZ,NGLLZ) :: hprime_zz
+! derivatives of Lagrange polynomials
+ double precision, dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ double precision, dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
-! space derivatives
- double precision tempx1l,tempx2l,tempz1l,tempz2l
- double precision fac1,fac2,hp1,hp2
- double precision duxdxl,duzdxl,duxdzl,duzdzl
- double precision sigma_xx,sigma_xz,sigma_zx,sigma_zz
+! Jacobian matrix and determinant
+ double precision :: xixl,xizl,gammaxl,gammazl,jacobianl
- double precision, dimension(NGLLX,NGLLZ) :: tempx1,tempx2,tempz1,tempz2
+! material properties of the elastic medium
+ double precision :: mul_relaxed,lambdal_relaxed,cpsquare
-! for anisotropy
- double precision duydyl,duydzl,duzdyl,duxdyl,duydxl
- double precision duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
- double precision duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+ double precision, dimension(:,:), allocatable :: coord,accel_elastic,veloc_elastic,displ_elastic, &
+ flagrange,xinterp,zinterp,Uxinterp,Uzinterp,elastcoef,vector_field_display
-! Jacobian matrix and determinant
- double precision xixl,xizl,gammaxl,gammazl,jacobianl
+! for acoustic medium
+ double precision, dimension(:), allocatable :: potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
-! material properties of the elastic medium
- double precision mul_relaxed,lambdal_relaxed,lambdalplus2mul_relaxed,cpsquare,denst
- double precision mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed
+ double precision, dimension(:), allocatable :: rmass_inverse_elastic,rmass_inverse_acoustic,density,displread,velocread,accelread
- double precision, dimension(:,:), allocatable :: coord,accel,veloc,displ, &
- flagrange,xinterp,zinterp,Uxinterp,Uzinterp,elastcoef,vector_field_postscript
+ double precision, dimension(:,:,:), allocatable :: vpext,vsext,rhoext
+ double precision :: previous_vsext
- double precision, dimension(:), allocatable :: rmass,density,vpext,vsext,rhoext,displread,velocread,accelread
-
double precision, dimension(:,:,:), allocatable :: shape2D,shape2D_display,xix,xiz,gammax,gammaz,jacobian
double precision, dimension(:,:,:,:), allocatable :: dershape2D,dershape2D_display
integer, dimension(:,:,:), allocatable :: ibool
integer, dimension(:,:), allocatable :: knods
- integer, dimension(:), allocatable :: kmato,numabs,numsurface
+ integer, dimension(:), allocatable :: kmato,numabs,ispecnum_acoustic_surface,iedgenum_acoustic_surface, &
+ ibegin_bottom,iend_bottom,ibegin_top,iend_top,jbegin_left,jend_left,jbegin_right,jend_right
- integer ie,k,material
-
integer ispec_selected_source,iglob_source,ix_source,iz_source
double precision a,displnorm_all
double precision, dimension(:), allocatable :: source_time_function
double precision, external :: erf
- double precision rsizemin,rsizemax,cpoverdxmax, &
- lambdaSmin,lambdaSmax,lambdaPmin,lambdaPmax,vpmin,vpmax
+ double precision :: vpmin,vpmax
- integer colors,numbers,subsamp,vecttype,IT_AFFICHE,nrec,sismostype
- integer numat,ngnod,nspec,pointsdisp,nelemabs,nelemsurface
+ integer :: colors,numbers,subsamp,imagetype,NTSTEP_BETWEEN_OUTPUT_INFO,nrec,seismotype
+ integer :: numat,ngnod,nspec,pointsdisp,nelemabs,nelem_acoustic_surface,ispecabs
- logical interpol,meshvect,modelvect,boundvect,read_external_model,initialfield,abshaut, &
- outputgrid,gnuplot,ELASTIC,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON,output_postscript_snapshot,output_color_image, &
- plot_lowerleft_corner_only,ACOUSTIC
+ logical interpol,meshvect,modelvect,boundvect,assign_external_model,initialfield, &
+ outputgrid,gnuplot,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON,output_postscript_snapshot,output_color_image, &
+ plot_lowerleft_corner_only
- double precision cutvect,sizemax_arrows,anglerec,xirec,gammarec
+ double precision :: cutsnaps,sizemax_arrows,anglerec,xirec,gammarec
-! for absorbing and free surface conditions
- integer ispecabs,ispecsurface,inum,numabsread,numsurfaceread,i1abs,i2abs
- logical codeabsread(4)
- double precision nx,nz,vx,vz,vn,rho_vp,rho_vs,tx,tz,weight,xxi,zgamma,kappal
+! for absorbing and acoustic free surface conditions
+ integer :: ispec_acoustic_surface,inum,numabsread,numacoustread,iedgeacoustread
+ logical :: codeabsread(4)
+ double precision :: nx,nz,weight,xxi,zgamma
logical, dimension(:,:), allocatable :: codeabs
! for attenuation
integer nspec_allocate
+ double precision :: deltatsquare,deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
- double precision tau_epsilon_nu1_mech1,tau_sigma_nu1_mech1, &
- tau_epsilon_nu2_mech1,tau_sigma_nu2_mech1,tau_epsilon_nu1_mech2, &
- tau_sigma_nu1_mech2,tau_epsilon_nu2_mech2,tau_sigma_nu2_mech2
-
- double precision Un,Unp1,tauinv,Sn,Snp1,theta_n,theta_np1
- double precision phi_nu1_mech1,phi_nu2_mech1,phi_nu1_mech2,phi_nu2_mech2
- double precision deltatsquare,deltatcube,deltatfourth
- double precision twelvedeltat,fourdeltatsquare
- double precision tauinvsquare,tauinvcube,tauinvUn
- double precision inv_tau_sigma_nu1_mech1,inv_tau_sigma_nu2_mech1
- double precision inv_tau_sigma_nu1_mech2,inv_tau_sigma_nu2_mech2
-
- double precision Mu_nu1,Mu_nu2
-
double precision, dimension(:,:,:), allocatable :: &
e1_mech1,e11_mech1,e13_mech1,e1_mech2,e11_mech2,e13_mech2, &
- duxdxl_n,duzdzl_n,duzdxl_n,duxdzl_n,duxdxl_np1,duzdzl_np1,duzdxl_np1,duxdzl_np1
+ 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 fluid/solid coupling and edge detection
+ logical, dimension(:), allocatable :: elastic
+ integer, dimension(NEDGES) :: i_begin,j_begin,i_end,j_end
+ integer, dimension(NGLLX,NEDGES) :: ivalue,jvalue,ivalue_inverse,jvalue_inverse
+ integer, dimension(:), allocatable :: fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge, &
+ fluid_solid_elastic_ispec,fluid_solid_elastic_iedge
+ integer :: num_fluid_solid_edges,num_fluid_solid_edges_alloc,ispec_acoustic,ispec_elastic, &
+ iedge_acoustic,iedge_elastic,ipoin1D,iglob2
+ logical :: any_acoustic,any_elastic,coupled_acoustic_elastic
+ double precision :: displ_x,displ_z,displ_n,zxi,xgamma,jacobian1D,pressure
+
! for color images
- integer :: NX_IMAGE_color,NZ_IMAGE_color,iplus1,jplus1,iminus1,jminus1,nx_sem_color
+ integer :: NX_IMAGE_color,NZ_IMAGE_color,iplus1,jplus1,iminus1,jminus1,count_passes
double precision :: xmin_color_image,xmax_color_image, &
- zmin_color_image,zmax_color_image,taille_pixel_horizontal,taille_pixel_vertical
- integer, dimension(:), allocatable :: ispec_for_color_image
- integer, dimension(:,:), allocatable :: iglob_image_color_2D,copy_iglob_image_color_2D
- double precision, dimension(:,:), allocatable :: donnees_image_color_2D
+ zmin_color_image,zmax_color_image,size_pixel_horizontal,size_pixel_vertical
+ integer, dimension(:,:), allocatable :: iglob_image_color,copy_iglob_image_color
+ double precision, dimension(:,:), allocatable :: image_color_data
! timing information for the stations
character(len=MAX_LENGTH_STATION_NAME), allocatable, dimension(:) :: station_name
character(len=MAX_LENGTH_NETWORK_NAME), allocatable, dimension(:) :: network_name
! title of the plot
- character(len=60) stitle
+ character(len=60) simulation_title
! Lagrange interpolators at receivers
double precision, dimension(:), allocatable :: hxir,hgammar,hpxir,hpgammar
@@ -223,6 +221,14 @@
! for Lagrange interpolants
double precision, external :: hgll
+! timer to count elapsed time
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+ integer ihours,iminutes,iseconds,int_tCPU
+ double precision :: time_start,time_end,tCPU
+
!***********************************************************************
!
! i n i t i a l i z a t i o n p h a s e
@@ -242,12 +248,12 @@
read(IIN,"(a80)") datlin
read(IIN,"(a80)") datlin
read(IIN,"(a80)") datlin
- read(IIN,"(a50)") stitle
+ read(IIN,"(a50)") simulation_title
!
!---- print the date, time and start-up banner
!
- call datim(stitle)
+ call datim(simulation_title)
write(IOUT,*)
write(IOUT,*)
@@ -268,33 +274,35 @@
read(IIN,*) gnuplot,interpol
read(IIN,"(a80)") datlin
- read(IIN,*) IT_AFFICHE,output_postscript_snapshot,output_color_image,colors,numbers
+ read(IIN,*) NTSTEP_BETWEEN_OUTPUT_INFO
read(IIN,"(a80)") datlin
- read(IIN,*) meshvect,modelvect,boundvect,cutvect,subsamp,sizemax_arrows,nx_sem_color
- cutvect = cutvect / 100.d0
+ read(IIN,*) output_postscript_snapshot,output_color_image,colors,numbers
read(IIN,"(a80)") datlin
+ read(IIN,*) meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows
+ cutsnaps = cutsnaps / 100.d0
+
+ read(IIN,"(a80)") datlin
read(IIN,*) anglerec
read(IIN,"(a80)") datlin
read(IIN,*) initialfield
read(IIN,"(a80)") datlin
- read(IIN,*) sismostype,vecttype
+ read(IIN,*) seismotype,imagetype
+ if(seismotype < 1 .or. seismotype > 4) stop 'Wrong type for seismogram output'
+ if(imagetype < 1 .or. imagetype > 4) stop 'Wrong type for snapshots'
read(IIN,"(a80)") datlin
- read(IIN,*) read_external_model,outputgrid,ELASTIC,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
+ read(IIN,*) assign_external_model,outputgrid,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
-! simulation is either acoustic or elastic
- ACOUSTIC = .not. ELASTIC
-
!---- check parameters read
write(IOUT,200) npgeo,NDIM
- write(IOUT,600) IT_AFFICHE,colors,numbers
- write(IOUT,700) sismostype,anglerec
- write(IOUT,750) initialfield,read_external_model,ELASTIC,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON,outputgrid
- write(IOUT,800) vecttype,100.d0*cutvect,subsamp
+ write(IOUT,600) NTSTEP_BETWEEN_OUTPUT_INFO,colors,numbers
+ write(IOUT,700) seismotype,anglerec
+ write(IOUT,750) initialfield,assign_external_model,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON,outputgrid
+ write(IOUT,800) imagetype,100.d0*cutsnaps,subsamp
!---- read time step
read(IIN,"(a80)") datlin
@@ -345,7 +353,9 @@
!---- read the basic properties of the spectral elements
!
read(IIN,"(a80)") datlin
- read(IIN,*) numat,ngnod,nspec,pointsdisp,plot_lowerleft_corner_only,nelemabs,nelemsurface
+ read(IIN,*) numat,ngnod,nspec,pointsdisp,plot_lowerleft_corner_only
+ read(IIN,"(a80)") datlin
+ read(IIN,*) nelemabs,nelem_acoustic_surface
!
!---- allocate arrays
@@ -369,40 +379,8 @@
allocate(kmato(nspec))
allocate(knods(ngnod,nspec))
allocate(ibool(NGLLX,NGLLZ,nspec))
+ allocate(elastic(nspec))
- if(read_external_model .and. outputgrid) stop 'cannot output the grid and read external model at the same time'
-
-! for acoustic
- if(TURN_ANISOTROPY_ON .and. ACOUSTIC) stop 'currently cannot have anisotropy in acoustic simulation'
-
- if(TURN_ATTENUATION_ON .and. ACOUSTIC) stop 'currently cannot have attenuation in acoustic simulation'
-
- if(source_type == 2 .and. ACOUSTIC) stop 'currently cannot have moment tensor source in acoustic simulation'
-
-! for attenuation
- if(TURN_ANISOTROPY_ON .and. TURN_ATTENUATION_ON) stop 'cannot have anisotropy and attenuation both turned on in current version'
-
- if(TURN_ATTENUATION_ON) then
- nspec_allocate = nspec
- else
- nspec_allocate = 1
- endif
-
- allocate(e1_mech1(NGLLX,NGLLZ,nspec_allocate))
- allocate(e11_mech1(NGLLX,NGLLZ,nspec_allocate))
- allocate(e13_mech1(NGLLX,NGLLZ,nspec_allocate))
- allocate(e1_mech2(NGLLX,NGLLZ,nspec_allocate))
- allocate(e11_mech2(NGLLX,NGLLZ,nspec_allocate))
- allocate(e13_mech2(NGLLX,NGLLZ,nspec_allocate))
- allocate(duxdxl_n(NGLLX,NGLLZ,nspec_allocate))
- allocate(duzdzl_n(NGLLX,NGLLZ,nspec_allocate))
- allocate(duzdxl_n(NGLLX,NGLLZ,nspec_allocate))
- allocate(duxdzl_n(NGLLX,NGLLZ,nspec_allocate))
- allocate(duxdxl_np1(NGLLX,NGLLZ,nspec_allocate))
- allocate(duzdzl_np1(NGLLX,NGLLZ,nspec_allocate))
- allocate(duzdxl_np1(NGLLX,NGLLZ,nspec_allocate))
- allocate(duxdzl_np1(NGLLX,NGLLZ,nspec_allocate))
-
! --- allocate arrays for absorbing boundary conditions
if(nelemabs <= 0) then
nelemabs = 1
@@ -413,12 +391,24 @@
allocate(numabs(nelemabs))
allocate(codeabs(4,nelemabs))
+ allocate(ibegin_bottom(nelemabs))
+ allocate(iend_bottom(nelemabs))
+ allocate(ibegin_top(nelemabs))
+ allocate(iend_top(nelemabs))
+
+ allocate(jbegin_left(nelemabs))
+ allocate(jend_left(nelemabs))
+ allocate(jbegin_right(nelemabs))
+ allocate(jend_right(nelemabs))
+
! --- allocate array for free surface condition in acoustic medium
- if(nelemsurface <= 0) then
- nelemsurface = 0
- allocate(numsurface(1))
+ if(nelem_acoustic_surface <= 0) then
+ nelem_acoustic_surface = 0
+ allocate(ispecnum_acoustic_surface(1))
+ allocate(iedgenum_acoustic_surface(1))
else
- allocate(numsurface(nelemsurface))
+ allocate(ispecnum_acoustic_surface(nelem_acoustic_surface))
+ allocate(iedgenum_acoustic_surface(nelem_acoustic_surface))
endif
!
@@ -428,7 +418,7 @@
write(IOUT,207) nspec,ngnod,NGLLX,NGLLZ,NGLLX*NGLLZ,pointsdisp,numat,nelemabs
! set up Gauss-Lobatto-Legendre derivation matrices
- call define_derivation_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz)
+ call define_derivation_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz,hprimewgll_xx,hprimewgll_zz)
!
!---- read the material properties
@@ -440,46 +430,80 @@
!
n = 0
read(IIN,"(a80)") datlin
- do ie = 1,nspec
+ do ispec = 1,nspec
read(IIN,*) n,kmato(n),(knods(k,n), k=1,ngnod)
enddo
!
+!---- determine if each spectral element is elastic or acoustic
+!
+ any_acoustic = .false.
+ any_elastic = .false.
+ do ispec = 1,nspec
+ mul_relaxed = elastcoef(2,kmato(ispec))
+ if(mul_relaxed < TINYVAL) then
+ elastic(ispec) = .false.
+ any_acoustic = .true.
+ else
+ elastic(ispec) = .true.
+ any_elastic = .true.
+ endif
+ enddo
+
+ if(TURN_ATTENUATION_ON) then
+ nspec_allocate = nspec
+ else
+ nspec_allocate = 1
+ endif
+
+! allocate memory variables for attenuation
+ allocate(e1_mech1(NGLLX,NGLLZ,nspec_allocate))
+ allocate(e11_mech1(NGLLX,NGLLZ,nspec_allocate))
+ allocate(e13_mech1(NGLLX,NGLLZ,nspec_allocate))
+ allocate(e1_mech2(NGLLX,NGLLZ,nspec_allocate))
+ allocate(e11_mech2(NGLLX,NGLLZ,nspec_allocate))
+ allocate(e13_mech2(NGLLX,NGLLZ,nspec_allocate))
+ allocate(dux_dxl_n(NGLLX,NGLLZ,nspec_allocate))
+ allocate(duz_dzl_n(NGLLX,NGLLZ,nspec_allocate))
+ allocate(duz_dxl_n(NGLLX,NGLLZ,nspec_allocate))
+ allocate(dux_dzl_n(NGLLX,NGLLZ,nspec_allocate))
+ allocate(dux_dxl_np1(NGLLX,NGLLZ,nspec_allocate))
+ allocate(duz_dzl_np1(NGLLX,NGLLZ,nspec_allocate))
+ allocate(duz_dxl_np1(NGLLX,NGLLZ,nspec_allocate))
+ allocate(dux_dzl_np1(NGLLX,NGLLZ,nspec_allocate))
+
+!
!---- read absorbing boundary data
!
if(anyabs) then
read(IIN,"(a80)") datlin
- do n=1,nelemabs
- read(IIN,*) inum,numabsread,codeabsread(1),codeabsread(2),codeabsread(3),codeabsread(4)
- if(inum < 1 .or. inum > nelemabs) stop 'Wrong absorbing element number'
+ do inum = 1,nelemabs
+ read(IIN,*) numabsread,codeabsread(1),codeabsread(2),codeabsread(3),codeabsread(4)
+ if(numabsread < 1 .or. numabsread > nspec) stop 'Wrong absorbing element number'
numabs(inum) = numabsread
- codeabs(ITOP,inum) = codeabsread(1)
- codeabs(IBOTTOM,inum) = codeabsread(2)
- codeabs(ILEFT,inum) = codeabsread(3)
- codeabs(IRIGHT,inum) = codeabsread(4)
+ codeabs(IBOTTOM,inum) = codeabsread(1)
+ codeabs(IRIGHT,inum) = codeabsread(2)
+ codeabs(ITOP,inum) = codeabsread(3)
+ codeabs(ILEFT,inum) = codeabsread(4)
enddo
write(IOUT,*)
write(IOUT,*) 'Number of absorbing elements: ',nelemabs
endif
!
-!---- read free surface data
+!---- read acoustic free surface data
!
- if(nelemsurface > 0) then
+ if(nelem_acoustic_surface > 0) then
read(IIN,"(a80)") datlin
-! we need to know if it is also an absorbing edge, in which case we turn off the acoustic free surface
- read(IIN,*) abshaut
- do n=1,nelemsurface
- read(IIN,*) inum,numsurfaceread
- if(inum < 1 .or. inum > nelemsurface) stop 'Wrong free surface element number'
- numsurface(inum) = numsurfaceread
+ do inum = 1,nelem_acoustic_surface
+ read(IIN,*) numacoustread,iedgeacoustread
+ if(numacoustread < 1 .or. numacoustread > nspec) stop 'Wrong acoustic free surface element number'
+ if(iedgeacoustread < 1 .or. iedgeacoustread > NEDGES) stop 'Wrong acoustic free surface edge number'
+ ispecnum_acoustic_surface(inum) = numacoustread
+ iedgenum_acoustic_surface(inum) = iedgeacoustread
enddo
write(IOUT,*)
- write(IOUT,*) 'Number of free surface elements: ',nelemsurface
- if(ACOUSTIC .and. abshaut) then
- write(IOUT,*)
- write(IOUT,*) 'top acoustic surface cannot be both absorbing and free, turning off the free surface'
- endif
+ write(IOUT,*) 'Number of free surface elements: ',nelem_acoustic_surface
endif
!
@@ -500,7 +524,7 @@
!---- generate the global numbering
!
-! version "propre mais lente" ou version "sale mais rapide"
+! "slow and clean" or "quick and dirty" version
if(FAST_NUMBERING) then
call createnum_fast(knods,ibool,shape2D,coorg,npoin,npgeo,nspec,ngnod)
else
@@ -563,34 +587,22 @@
allocate(hxir_store(nrec,NGLLX))
allocate(hgammar_store(nrec,NGLLZ))
-!
-!---- allocation des autres tableaux pour la grille globale et les bords
-!
-
+! allocate other global arrays
allocate(coord(NDIM,npoin))
- allocate(accel(NDIM,npoin))
- allocate(displ(NDIM,npoin))
- allocate(veloc(NDIM,npoin))
+! to display acoustic elements
+ allocate(vector_field_display(NDIM,npoin))
-! for acoustic medium
- if(ELASTIC) then
- allocate(vector_field_postscript(NDIM,1))
+ if(assign_external_model) then
+ allocate(vpext(NGLLX,NGLLZ,nspec))
+ allocate(vsext(NGLLX,NGLLZ,nspec))
+ allocate(rhoext(NGLLX,NGLLZ,nspec))
else
- allocate(vector_field_postscript(NDIM,npoin))
+ allocate(vpext(1,1,1))
+ allocate(vsext(1,1,1))
+ allocate(rhoext(1,1,1))
endif
- allocate(rmass(npoin))
-
- if(read_external_model) then
- npoinext = npoin
- else
- npoinext = 1
- endif
- allocate(vpext(npoinext))
- allocate(vsext(npoinext))
- allocate(rhoext(npoinext))
-
!
!---- set the coordinates of the points of the global grid
!
@@ -637,17 +649,78 @@
if(gnuplot) call plotgll(knods,ibool,coorg,coord,npoin,npgeo,ngnod,nspec)
!
+!---- assign external velocity and density model if needed
+!
+ if(assign_external_model) then
+ write(IOUT,*)
+ write(IOUT,*) 'Assigning external velocity and density model...'
+ write(IOUT,*)
+ if(TURN_ANISOTROPY_ON .or. TURN_ATTENUATION_ON) &
+ stop 'cannot have anisotropy nor attenuation if external model in current version'
+ any_acoustic = .false.
+ any_elastic = .false.
+ do ispec = 1,nspec
+ previous_vsext = -1.d0
+ 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), &
+ rhoext(i,j,ispec),vpext(i,j,ispec),vsext(i,j,ispec))
+! 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. &
+ (vsext(i,j,ispec) < TINYVAL .and. previous_vsext >= TINYVAL))) &
+ stop 'external velocity model cannot be both fluid and solid inside the same spectral element'
+ if(vsext(i,j,ispec) < TINYVAL) then
+ elastic(ispec) = .false.
+ any_acoustic = .true.
+ else
+ elastic(ispec) = .true.
+ any_elastic = .true.
+ endif
+ previous_vsext = vsext(i,j,ispec)
+ enddo
+ enddo
+ enddo
+ endif
+
+!
+!---- perform basic checks on parameters read
+!
+
+! for acoustic
+ if(TURN_ANISOTROPY_ON .and. .not. any_elastic) stop 'cannot have anisotropy if acoustic simulation only'
+
+ if(TURN_ATTENUATION_ON .and. .not. any_elastic) stop 'currently cannot have attenuation if acoustic simulation only'
+
+! for attenuation
+ if(TURN_ANISOTROPY_ON .and. TURN_ATTENUATION_ON) stop 'cannot have anisotropy and attenuation both turned on in current version'
+
+!
!---- define coefficients of the Newmark time scheme
!
deltatover2 = HALF*deltat
deltatsquareover2 = HALF*deltat*deltat
-!---- definir la position reelle des points source et recepteurs
+!---- define actual location of source and receivers
if(source_type == 1) then
! collocated force source
call locate_source_force(coord,ibool,npoin,nspec,x_source,z_source,source_type, &
ix_source,iz_source,ispec_selected_source,iglob_source)
+! check that acoustic source is not exactly on the free surface because pressure is zero there
+ do ispec_acoustic_surface = 1,nelem_acoustic_surface
+ ispec = ispecnum_acoustic_surface(ispec_acoustic_surface)
+ iedge = iedgenum_acoustic_surface(ispec_acoustic_surface)
+ if(.not. elastic(ispec) .and. ispec == ispec_selected_source) then
+ if((iedge == IBOTTOM .and. iz_source == 1) .or. &
+ (iedge == ITOP .and. iz_source == NGLLZ) .or. &
+ (iedge == ILEFT .and. ix_source == 1) .or. &
+ (iedge == IRIGHT .and. ix_source == NGLLX)) &
+ stop 'an acoustic source cannot be located exactly on the free surface because pressure is zero there'
+ endif
+ enddo
+
else if(source_type == 2) then
! moment-tensor source
call locate_source_moment_tensor(ibool,coord,nspec,npoin,xigll,zigll,x_source,z_source, &
@@ -666,6 +739,30 @@
call locate_receivers(ibool,coord,nspec,npoin,xigll,zigll,nrec,st_xval,st_zval,ispec_selected_rec, &
xi_receiver,gamma_receiver,station_name,network_name,x_source,z_source,coorg,knods,ngnod,npgeo)
+! check if acoustic receiver is exactly on the free surface because pressure is zero there
+ do ispec_acoustic_surface = 1,nelem_acoustic_surface
+ ispec = ispecnum_acoustic_surface(ispec_acoustic_surface)
+ iedge = iedgenum_acoustic_surface(ispec_acoustic_surface)
+ do irec = 1,nrec
+ if(.not. elastic(ispec) .and. ispec == ispec_selected_rec(irec)) then
+ if((iedge == IBOTTOM .and. gamma_receiver(irec) < -0.99d0) .or. &
+ (iedge == ITOP .and. gamma_receiver(irec) > 0.99d0) .or. &
+ (iedge == ILEFT .and. xi_receiver(irec) < -0.99d0) .or. &
+ (iedge == IRIGHT .and. xi_receiver(irec) > 0.99d0)) then
+ if(seismotype == 4) then
+ stop 'an acoustic pressure receiver cannot be located exactly on the free surface because pressure is zero there'
+ else
+ print *, '**********************************************************************'
+ print *, '*** Warning: acoustic receiver located exactly on the free surface ***'
+ print *, '*** Warning: tangential component will be zero there ***'
+ print *, '**********************************************************************'
+ print *
+ endif
+ endif
+ endif
+ enddo
+ enddo
+
! define and store Lagrange interpolators at all the receivers
do irec = 1,nrec
call lagrange_any(xi_receiver(irec),NGLLX,xigll,hxir,hpxir)
@@ -674,40 +771,47 @@
hgammar_store(irec,:) = hgammar(:)
enddo
-!
-!---- eventuellement lecture d'un modele externe de vitesse et de densite
-!
- if(read_external_model) then
- write(IOUT,*)
- write(IOUT,*) 'Reading velocity and density model from external file...'
- write(IOUT,*)
- open(unit=55,file='OUTPUT_FILES/grid_points_and_model.txt',status='old')
- read(55,*) nbpoin
- if(nbpoin /= npoin) stop 'Wrong number of points in input file'
- do n = 1,npoin
- read(55,*) xdummy,zdummy,rhoext(n),vpext(n),vsext(n)
- enddo
- close(55)
+! displacement, velocity, acceleration and inverse of the mass matrix for elastic elements
+ if(any_elastic) then
+ allocate(displ_elastic(NDIM,npoin))
+ allocate(veloc_elastic(NDIM,npoin))
+ allocate(accel_elastic(NDIM,npoin))
+ allocate(rmass_inverse_elastic(npoin))
+ else
+! allocate unused arrays with fictitious size
+ allocate(displ_elastic(1,1))
+ allocate(veloc_elastic(1,1))
+ allocate(accel_elastic(1,1))
+ allocate(rmass_inverse_elastic(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))
+ allocate(potential_dot_acoustic(npoin))
+ allocate(potential_dot_dot_acoustic(npoin))
+ allocate(rmass_inverse_acoustic(npoin))
+ else
+! allocate unused arrays with fictitious size
+ allocate(potential_acoustic(1))
+ allocate(potential_dot_acoustic(1))
+ allocate(potential_dot_dot_acoustic(1))
+ allocate(rmass_inverse_acoustic(1))
+ endif
+
!
-!---- define all arrays
+!---- build the global mass matrix and invert it once and for all
!
- call defarrays(vpext,vsext,rhoext,density,elastcoef, &
- ibool,kmato,coord,npoin,rsizemin,rsizemax, &
- cpoverdxmax,lambdaSmin,lambdaSmax,lambdaPmin,lambdaPmax, &
- vpmin,vpmax,read_external_model,nspec,numat)
-
-! build the global mass matrix once and for all
- rmass(:) = ZERO
+ if(any_elastic) rmass_inverse_elastic(:) = 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(read_external_model) then
- rhol = rhoext(iglob)
- cpsquare = vpext(iglob)**2
+ if(assign_external_model) then
+ rhol = rhoext(i,j,ispec)
+ cpsquare = vpext(i,j,ispec)**2
else
rhol = density(kmato(ispec))
lambdal_relaxed = elastcoef(1,kmato(ispec))
@@ -715,88 +819,105 @@
cpsquare = (lambdal_relaxed + 2.d0*mul_relaxed) / rhol
endif
! for acoustic medium
- if(ELASTIC) then
- rmass(iglob) = rmass(iglob) + wxgll(i)*wzgll(j)*rhol*jacobian(i,j,ispec)
+ if(elastic(ispec)) then
+ rmass_inverse_elastic(iglob) = rmass_inverse_elastic(iglob) + wxgll(i)*wzgll(j)*rhol*jacobian(i,j,ispec)
else
- rmass(iglob) = rmass(iglob) + wxgll(i)*wzgll(j)*jacobian(i,j,ispec) / cpsquare
+ rmass_inverse_acoustic(iglob) = rmass_inverse_acoustic(iglob) + wxgll(i)*wzgll(j)*jacobian(i,j,ispec) / cpsquare
endif
enddo
enddo
enddo
-! convertir angle recepteurs en radians
+! fill mass matrix with fictitious non-zero values to make sure it can be inverted globally
+ if(any_elastic) where(rmass_inverse_elastic <= 0.d0) rmass_inverse_elastic = 1.d0
+ if(any_acoustic) where(rmass_inverse_acoustic <= 0.d0) rmass_inverse_acoustic = 1.d0
+
+! compute the inverse of the mass matrix
+ if(any_elastic) rmass_inverse_elastic(:) = 1 / rmass_inverse_elastic(:)
+ if(any_acoustic) rmass_inverse_acoustic(:) = 1 / rmass_inverse_acoustic(:)
+
+! check the mesh, stability and number of points per wavelength
+ call checkgrid(vpext,vsext,rhoext,density,elastcoef,ibool,kmato,coord,npoin,vpmin,vpmax, &
+ assign_external_model,nspec,numat,deltat,f0,t0,initialfield,time_function_type, &
+ coorg,xinterp,zinterp,shape2D_display,knods,simulation_title,npgeo,pointsdisp,ngnod,any_elastic)
+
+! convert receiver angle to radians
anglerec = anglerec * pi / 180.d0
-!---- verifier le maillage, la stabilite et le nb de points par lambda
-!---- seulement si la source en temps n'est pas un Dirac (sinon spectre non defini)
- if(time_function_type /= 4) call checkgrid(deltat,f0,t0,initialfield, &
- rsizemin,rsizemax,cpoverdxmax,lambdaSmin,lambdaSmax,lambdaPmin,lambdaPmax)
-
!
!---- for color images
!
-! taille horizontale de l'image
+ if(output_color_image) then
+
+! horizontal size of the image
xmin_color_image = minval(coord(1,:))
xmax_color_image = maxval(coord(1,:))
-! taille verticale de l'image, augmenter un peu pour depasser de la topographie
+! vertical size of the image, slightly increase it to go beyond maximum topography
zmin_color_image = minval(coord(2,:))
zmax_color_image = maxval(coord(2,:))
zmax_color_image = zmin_color_image + 1.05d0 * (zmax_color_image - zmin_color_image)
-! calculer le nombre de pixels en horizontal en fonction du nombre d'elements spectraux
- NX_IMAGE_color = nx_sem_color * (NGLLX-1) + 1
+! compute number of pixels in the horizontal direction based on typical number
+! of spectral elements in a given direction (may give bad results for very elongated models)
+ NX_IMAGE_color = nint(sqrt(dble(npgeo))) * (NGLLX-1) + 1
-! calculer le nombre de pixels en vertical en fonction du rapport des tailles
+! compute number of pixels in the vertical direction based on ratio of sizes
NZ_IMAGE_color = nint(NX_IMAGE_color * (zmax_color_image - zmin_color_image) / (xmax_color_image - xmin_color_image))
-! convertir la taille de l'image en nombre pair car plus facile pour ensuite faire des movies en MPEG
+! convert pixel sizes to even numbers because easier to reduce size, create MPEG movies in postprocessing
NX_IMAGE_color = 2 * (NX_IMAGE_color / 2)
NZ_IMAGE_color = 2 * (NZ_IMAGE_color / 2)
-! allouer un tableau pour les donnees de l'image
- allocate(donnees_image_color_2D(NX_IMAGE_color,NZ_IMAGE_color))
+! allocate an array for image data
+ allocate(image_color_data(NX_IMAGE_color,NZ_IMAGE_color))
-! allouer un tableau pour le point de grille contenant cette donnee
- allocate(iglob_image_color_2D(NX_IMAGE_color,NZ_IMAGE_color))
- allocate(copy_iglob_image_color_2D(NX_IMAGE_color,NZ_IMAGE_color))
+! allocate an array for the grid point that corresponds to a given image data point
+ allocate(iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color))
+ allocate(copy_iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color))
-! creer tous les pixels
+! create all the pixels
write(IOUT,*)
- write(IOUT,*) 'localisation de tous les pixels des images couleur'
+ write(IOUT,*) 'locating all the pixels of color images'
- taille_pixel_horizontal = (xmax_color_image - xmin_color_image) / dble(NX_IMAGE_color-1)
- taille_pixel_vertical = (zmax_color_image - zmin_color_image) / dble(NZ_IMAGE_color-1)
+ size_pixel_horizontal = (xmax_color_image - xmin_color_image) / dble(NX_IMAGE_color-1)
+ size_pixel_vertical = (zmax_color_image - zmin_color_image) / dble(NZ_IMAGE_color-1)
- iglob_image_color_2D(:,:) = -1
+ iglob_image_color(:,:) = -1
-! boucle sur tous les points de grille pour leur affecter un pixel de l'image
+! loop on all the grid points to map them to a pixel in the image
do n=1,npoin
-! calculer les coordonnees du pixel
- i = nint((coord(1,n) - xmin_color_image) / taille_pixel_horizontal + 1)
- j = nint((coord(2,n) - zmin_color_image) / taille_pixel_vertical + 1)
+! compute the coordinates of this pixel
+ i = nint((coord(1,n) - xmin_color_image) / size_pixel_horizontal + 1)
+ j = nint((coord(2,n) - zmin_color_image) / size_pixel_vertical + 1)
-! eviter les effets de bord
+! avoid edge effects
if(i < 1) i = 1
if(i > NX_IMAGE_color) i = NX_IMAGE_color
if(j < 1) j = 1
if(j > NZ_IMAGE_color) j = NZ_IMAGE_color
-! affecter ce point a ce pixel
- iglob_image_color_2D(i,j) = n
+! assign this point to this pixel
+ iglob_image_color(i,j) = n
enddo
-! completer les pixels manquants en les localisant par la distance minimum
- copy_iglob_image_color_2D(:,:) = iglob_image_color_2D(:,:)
+! locate missing pixels based on a minimum distance criterion
+! cannot do more than two iterations typically because some pixels must never be found
+! because they do not exist (for instance if they are located above topography)
+ do count_passes = 1,2
+ print *,'pass ',count_passes,' to locate the missing pixels of color images'
+
+ copy_iglob_image_color(:,:) = iglob_image_color(:,:)
+
do j = 1,NZ_IMAGE_color
do i = 1,NX_IMAGE_color
- if(copy_iglob_image_color_2D(i,j) == -1) then
+ if(copy_iglob_image_color(i,j) == -1) then
iplus1 = i + 1
iminus1 = i - 1
@@ -804,41 +925,41 @@
jplus1 = j + 1
jminus1 = j - 1
-! eviter les effets de bord
+! avoid edge effects
if(iminus1 < 1) iminus1 = 1
if(iplus1 > NX_IMAGE_color) iplus1 = NX_IMAGE_color
if(jminus1 < 1) jminus1 = 1
if(jplus1 > NZ_IMAGE_color) jplus1 = NZ_IMAGE_color
-! utiliser les pixels voisins pour remplir les trous
+! use neighbors of this pixel to fill the holes
-! horizontales
- if(copy_iglob_image_color_2D(iplus1,j) /= -1) then
- iglob_image_color_2D(i,j) = copy_iglob_image_color_2D(iplus1,j)
+! horizontal
+ if(copy_iglob_image_color(iplus1,j) /= -1) then
+ iglob_image_color(i,j) = copy_iglob_image_color(iplus1,j)
- else if(copy_iglob_image_color_2D(iminus1,j) /= -1) then
- iglob_image_color_2D(i,j) = copy_iglob_image_color_2D(iminus1,j)
+ else if(copy_iglob_image_color(iminus1,j) /= -1) then
+ iglob_image_color(i,j) = copy_iglob_image_color(iminus1,j)
-! verticales
- else if(copy_iglob_image_color_2D(i,jplus1) /= -1) then
- iglob_image_color_2D(i,j) = copy_iglob_image_color_2D(i,jplus1)
+! vertical
+ else if(copy_iglob_image_color(i,jplus1) /= -1) then
+ iglob_image_color(i,j) = copy_iglob_image_color(i,jplus1)
- else if(copy_iglob_image_color_2D(i,jminus1) /= -1) then
- iglob_image_color_2D(i,j) = copy_iglob_image_color_2D(i,jminus1)
+ else if(copy_iglob_image_color(i,jminus1) /= -1) then
+ iglob_image_color(i,j) = copy_iglob_image_color(i,jminus1)
-! diagonales
- else if(copy_iglob_image_color_2D(iminus1,jminus1) /= -1) then
- iglob_image_color_2D(i,j) = copy_iglob_image_color_2D(iminus1,jminus1)
+! diagonal
+ else if(copy_iglob_image_color(iminus1,jminus1) /= -1) then
+ iglob_image_color(i,j) = copy_iglob_image_color(iminus1,jminus1)
- else if(copy_iglob_image_color_2D(iplus1,jminus1) /= -1) then
- iglob_image_color_2D(i,j) = copy_iglob_image_color_2D(iplus1,jminus1)
+ else if(copy_iglob_image_color(iplus1,jminus1) /= -1) then
+ iglob_image_color(i,j) = copy_iglob_image_color(iplus1,jminus1)
- else if(copy_iglob_image_color_2D(iminus1,jplus1) /= -1) then
- iglob_image_color_2D(i,j) = copy_iglob_image_color_2D(iminus1,jplus1)
+ else if(copy_iglob_image_color(iminus1,jplus1) /= -1) then
+ iglob_image_color(i,j) = copy_iglob_image_color(iminus1,jplus1)
- else if(copy_iglob_image_color_2D(iplus1,jplus1) /= -1) then
- iglob_image_color_2D(i,j) = copy_iglob_image_color_2D(iplus1,jplus1)
+ else if(copy_iglob_image_color(iplus1,jplus1) /= -1) then
+ iglob_image_color(i,j) = copy_iglob_image_color(iplus1,jplus1)
endif
@@ -847,23 +968,16 @@
enddo
enddo
- deallocate(copy_iglob_image_color_2D)
+ enddo
- write(IOUT,*) 'fin localisation de tous les pixels des images couleur'
+ deallocate(copy_iglob_image_color)
-! assign ispec number to be able to determine density for acoustic color snapshots
- allocate(ispec_for_color_image(npoin))
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- ispec_for_color_image(iglob) = ispec
- enddo
- enddo
- enddo
+ write(IOUT,*) 'done locating all the pixels of color images'
+ endif
+
!
-!---- initialiser sismogrammes
+!---- initialize seismograms
!
sisux = ZERO
sisuz = ZERO
@@ -871,18 +985,23 @@
cosrot = cos(anglerec)
sinrot = sin(anglerec)
-! initialiser les tableaux a zero
- accel = ZERO
- veloc = ZERO
- displ = ZERO
+! initialize arrays to zero
+ displ_elastic = ZERO
+ veloc_elastic = ZERO
+ accel_elastic = ZERO
+ potential_acoustic = ZERO
+ potential_dot_acoustic = ZERO
+ potential_dot_dot_acoustic = ZERO
+
!
-!---- eventuellement lecture des champs initiaux dans un fichier
+!---- read initial fields from external file if needed
!
if(initialfield) then
write(IOUT,*)
write(IOUT,*) 'Reading initial fields from external file...'
write(IOUT,*)
+ if(any_acoustic) stop 'initial field currently implemented for purely elastic simulation only'
open(unit=55,file='OUTPUT_FILES/wavefields.txt',status='unknown')
read(55,*) nbpoin
if(nbpoin /= npoin) stop 'Wrong number of points in input file'
@@ -893,43 +1012,17 @@
read(55,*) inump, (displread(i), i=1,NDIM), &
(velocread(i), i=1,NDIM), (accelread(i), i=1,NDIM)
if(inump<1 .or. inump>npoin) stop 'Wrong point number'
- displ(:,inump) = displread
- veloc(:,inump) = velocread
- accel(:,inump) = accelread
+ displ_elastic(:,inump) = displread
+ veloc_elastic(:,inump) = velocread
+ accel_elastic(:,inump) = accelread
enddo
deallocate(displread)
deallocate(velocread)
deallocate(accelread)
close(55)
- write(IOUT,*) 'Max norm of initial displacement = ',maxval(sqrt(displ(1,:)**2 + displ(2,:)**2))
+ write(IOUT,*) 'Max norm of initial elastic displacement = ',maxval(sqrt(displ_elastic(1,:)**2 + displ_elastic(2,:)**2))
endif
-! attenuation constants from Carcione 1993 Geophysics volume 58 pages 111 and 112
-! for two memory-variables mechanisms.
-! beware: these values implement specific values of the quality factor Q,
-! see Carcione 1993 for details
- tau_epsilon_nu1_mech1 = 0.0334d0
- tau_sigma_nu1_mech1 = 0.0303d0
- tau_epsilon_nu2_mech1 = 0.0352d0
- tau_sigma_nu2_mech1 = 0.0287d0
- tau_epsilon_nu1_mech2 = 0.0028d0
- tau_sigma_nu1_mech2 = 0.0025d0
- tau_epsilon_nu2_mech2 = 0.0029d0
- tau_sigma_nu2_mech2 = 0.0024d0
-
- inv_tau_sigma_nu1_mech1 = ONE / tau_sigma_nu1_mech1
- inv_tau_sigma_nu2_mech1 = ONE / tau_sigma_nu2_mech1
- inv_tau_sigma_nu1_mech2 = ONE / tau_sigma_nu1_mech2
- inv_tau_sigma_nu2_mech2 = ONE / tau_sigma_nu2_mech2
-
- phi_nu1_mech1 = (ONE - tau_epsilon_nu1_mech1/tau_sigma_nu1_mech1) / tau_sigma_nu1_mech1
- phi_nu2_mech1 = (ONE - tau_epsilon_nu2_mech1/tau_sigma_nu2_mech1) / tau_sigma_nu2_mech1
- phi_nu1_mech2 = (ONE - tau_epsilon_nu1_mech2/tau_sigma_nu1_mech2) / tau_sigma_nu1_mech2
- phi_nu2_mech2 = (ONE - tau_epsilon_nu2_mech2/tau_sigma_nu2_mech2) / tau_sigma_nu2_mech2
-
- Mu_nu1 = ONE - (ONE - tau_epsilon_nu1_mech1/tau_sigma_nu1_mech1) - (ONE - tau_epsilon_nu1_mech2/tau_sigma_nu1_mech2)
- Mu_nu2 = ONE - (ONE - tau_epsilon_nu2_mech1/tau_sigma_nu2_mech1) - (ONE - tau_epsilon_nu2_mech2/tau_sigma_nu2_mech2)
-
deltatsquare = deltat * deltat
deltatcube = deltatsquare * deltat
deltatfourth = deltatsquare * deltatsquare
@@ -937,7 +1030,7 @@
twelvedeltat = 12.d0 * deltat
fourdeltatsquare = 4.d0 * deltatsquare
-! --- compute the source time function and store it in a text file
+! compute the source time function and store it in a text file
if(.not. initialfield) then
allocate(source_time_function(NSTEP))
@@ -947,7 +1040,7 @@
write(IOUT,*)
open(unit=55,file='OUTPUT_FILES/source.txt',status='unknown')
-! boucle principale d'evolution en temps
+! loop on all the time steps
do it = 1,NSTEP
! compute current time
@@ -989,628 +1082,517 @@
endif
!
-!---- s t a r t t i m e i t e r a t i o n s
+!---- check that no element has both acoustic free surface and top absorbing surface
!
+ do ispec_acoustic_surface = 1,nelem_acoustic_surface
+ ispec = ispecnum_acoustic_surface(ispec_acoustic_surface)
+ iedge = iedgenum_acoustic_surface(ispec_acoustic_surface)
+ if(elastic(ispec)) then
+ stop 'elastic element detected in acoustic free surface'
+ else
+ do inum = 1,nelemabs
+ if(numabs(inum) == ispec .and. codeabs(iedge,inum)) &
+ stop 'acoustic free surface cannot be both absorbing and free'
+ enddo
+ endif
+ enddo
- write(IOUT,400)
+! determine if coupled fluid-solid simulation
+ coupled_acoustic_elastic = any_acoustic .and. any_elastic
-! boucle principale d'evolution en temps
- do it = 1,NSTEP
+! fluid/solid edge detection
+! very basic algorithm in O(nspec^2), simple double loop on the elements
+! and then loop on the four corners of each of the two elements, could be signficantly improved
-! compute current time
- time = (it-1)*deltat
+ num_fluid_solid_edges_alloc = 0
-! compute Grad(displ) at time step n for attenuation
- if(TURN_ATTENUATION_ON) call compute_gradient_attenuation(displ,duxdxl_n,duzdxl_n, &
- duxdzl_n,duzdzl_n,xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,NSPEC,npoin)
+ if(coupled_acoustic_elastic) then
+ print *
+ print *,'Mixed acoustic/elastic simulation'
+ print *
+ print *,'Beginning of fluid/solid edge detection'
-! update displacement using finite-difference time scheme (Newmark)
- displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsquareover2*accel(:,:)
- veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
- accel(:,:) = ZERO
+! 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
-!--- free surface for an acoustic medium
+ i_begin(ITOP) = NGLLX
+ j_begin(ITOP) = NGLLZ
+ i_end(ITOP) = 1
+ j_end(ITOP) = NGLLZ
-! if acoustic, the free surface condition is a Dirichlet condition for the potential,
-! not Neumann, in order to impose zero pressure at the surface. Also check that
-! top absorbing boundary is not set because cannot be both absorbing and free surface
- if(ACOUSTIC .and. .not. abshaut) then
+ i_begin(ILEFT) = 1
+ j_begin(ILEFT) = NGLLZ
+ i_end(ILEFT) = 1
+ j_end(ILEFT) = 1
- do ispecsurface=1,nelemsurface
+! define i and j points for each edge
+ do ipoin1D = 1,NGLLX
- ispec = numsurface(ispecsurface)
+ ivalue(ipoin1D,IBOTTOM) = ipoin1D
+ ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
+ jvalue(ipoin1D,IBOTTOM) = 1
+ jvalue_inverse(ipoin1D,IBOTTOM) = 1
- j = NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec)
- displ(:,iglob) = ZERO
- veloc(:,iglob) = ZERO
- accel(:,iglob) = ZERO
- enddo
+ ivalue(ipoin1D,IRIGHT) = NGLLX
+ ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
+ jvalue(ipoin1D,IRIGHT) = ipoin1D
+ jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
- enddo
+ ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
+ ivalue_inverse(ipoin1D,ITOP) = ipoin1D
+ jvalue(ipoin1D,ITOP) = NGLLZ
+ jvalue_inverse(ipoin1D,ITOP) = NGLLZ
- endif ! end of free surface condition for acoustic medium
+ ivalue(ipoin1D,ILEFT) = 1
+ ivalue_inverse(ipoin1D,ILEFT) = 1
+ jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
+ jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
+ enddo
-! integration over spectral elements
- do ispec = 1,NSPEC
+! double loop on all the elements
+ do ispec_acoustic = 1, nspec
+ do ispec_elastic = 1, nspec
-! get relaxed elastic parameters of current spectral element
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
- lambdalplus2mul_relaxed = lambdal_relaxed + TWO*mul_relaxed
+! one element must be acoustic and the other must be elastic
+! use acoustic element as master to avoid double detection of the same pair (one on each side)
+ if(ispec_acoustic /= ispec_elastic .and. .not. elastic(ispec_acoustic) .and. elastic(ispec_elastic)) then
-! first double loop over GLL to compute and store gradients
- do j = 1,NGLLZ
- do i = 1,NGLLX
+! loop on the four edges of the two elements
+ do iedge_acoustic = 1,NEDGES
+ do iedge_elastic = 1,NEDGES
-!--- if external medium, get elastic parameters of current grid point
- if(read_external_model) then
- iglob = ibool(i,j,ispec)
- cpl = vpext(iglob)
- csl = vsext(iglob)
- rhol = rhoext(iglob)
- mul_relaxed = rhol*csl*csl
- lambdal_relaxed = rhol*cpl*cpl - TWO*mul_relaxed
- lambdalplus2mul_relaxed = lambdal_relaxed + TWO*mul_relaxed
- endif
+! error if the two edges match in direct order
+ if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic) .and. &
+ ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic)) &
+ stop 'topology error (non-inverted coupled elements) found in fluid/solid edge detection'
-! compute unrelaxed elastic coefficients from formulas in Carcione 1993 page 111
- lambdal_unrelaxed = (lambdal_relaxed + mul_relaxed) * Mu_nu1 - mul_relaxed * Mu_nu2
- mul_unrelaxed = mul_relaxed * Mu_nu2
- lambdalplus2mul_unrelaxed = lambdal_unrelaxed + TWO*mul_unrelaxed
+! the two edges can match in inverse order
+ if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic) .and. &
+ ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic)) &
+ num_fluid_solid_edges_alloc = num_fluid_solid_edges_alloc + 1
-! derivative along x
- tempx1l = ZERO
- tempz1l = ZERO
- do k = 1,NGLLX
- hp1 = hprime_xx(k,i)
- iglob = ibool(k,j,ispec)
- tempx1l = tempx1l + displ(1,iglob)*hp1
- tempz1l = tempz1l + displ(2,iglob)*hp1
+ enddo
enddo
-! derivative along z
- tempx2l = ZERO
- tempz2l = ZERO
- do k = 1,NGLLZ
- hp2 = hprime_zz(k,j)
- iglob = ibool(i,k,ispec)
- tempx2l = tempx2l + displ(1,iglob)*hp2
- tempz2l = tempz2l + displ(2,iglob)*hp2
- enddo
+ endif
- xixl = xix(i,j,ispec)
- xizl = xiz(i,j,ispec)
- gammaxl = gammax(i,j,ispec)
- gammazl = gammaz(i,j,ispec)
+ enddo
+ enddo
-! derivatives of displacement
- duxdxl = tempx1l*xixl + tempx2l*gammaxl
- duxdzl = tempx1l*xizl + tempx2l*gammazl
+ print *,'Number of fluid/solid edges detected in mesh = ',num_fluid_solid_edges_alloc
- duzdxl = tempz1l*xixl + tempz2l*gammaxl
- duzdzl = tempz1l*xizl + tempz2l*gammazl
+! allocate arrays for fluid/solid matching
+ allocate(fluid_solid_acoustic_ispec(num_fluid_solid_edges_alloc))
+ allocate(fluid_solid_acoustic_iedge(num_fluid_solid_edges_alloc))
+ allocate(fluid_solid_elastic_ispec(num_fluid_solid_edges_alloc))
+ allocate(fluid_solid_elastic_iedge(num_fluid_solid_edges_alloc))
-! compute stress tensor (include attenuation or anisotropy if needed)
+! double loop on all the elements
+ print *,'Creating fluid/solid edge topology...'
- if(TURN_ATTENUATION_ON) then
+ num_fluid_solid_edges = 0
-! compute the stress using the unrelaxed Lame parameters (Carcione page 111)
- sigma_xx = lambdalplus2mul_unrelaxed*duxdxl + lambdal_unrelaxed*duzdzl
- sigma_xz = mul_unrelaxed*(duzdxl + duxdzl)
- sigma_zz = lambdalplus2mul_unrelaxed*duzdzl + lambdal_unrelaxed*duxdxl
+ do ispec_acoustic = 1, nspec
+ do ispec_elastic = 1, nspec
-! add the memory variables using the relaxed parameters (Carcione page 111)
-! beware: there is a bug in Carcione's equation for sigma_zz
- sigma_xx = sigma_xx + (lambdal_relaxed + mul_relaxed)* &
- (e1_mech1(i,j,k) + e1_mech2(i,j,k)) + TWO * mul_relaxed * (e11_mech1(i,j,k) + e11_mech2(i,j,k))
- sigma_xz = sigma_xz + mul_relaxed * (e13_mech1(i,j,k) + e13_mech2(i,j,k))
- sigma_zz = sigma_zz + (lambdal_relaxed + mul_relaxed)* &
- (e1_mech1(i,j,k) + e1_mech2(i,j,k)) - TWO * mul_relaxed * (e11_mech1(i,j,k) + e11_mech2(i,j,k))
+! one element must be acoustic and the other must be elastic
+! use acoustic element as master to avoid double detection of the same pair (one on each side)
+ if(ispec_acoustic /= ispec_elastic .and. .not. elastic(ispec_acoustic) .and. elastic(ispec_elastic)) then
- else
+! loop on the four edges of the two elements
+ do iedge_acoustic = 1,NEDGES
+ do iedge_elastic = 1,NEDGES
-! no attenuation
- sigma_xx = lambdalplus2mul_relaxed*duxdxl + lambdal_relaxed*duzdzl
- sigma_xz = mul_relaxed*(duzdxl + duxdzl)
- sigma_zz = lambdalplus2mul_relaxed*duzdzl + lambdal_relaxed*duxdxl
+! 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_elastic),j_end(iedge_elastic),ispec_elastic) .and. &
+ ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic)) then
+ num_fluid_solid_edges = num_fluid_solid_edges + 1
+ fluid_solid_acoustic_ispec(num_fluid_solid_edges) = ispec_acoustic
+ fluid_solid_acoustic_iedge(num_fluid_solid_edges) = iedge_acoustic
+ fluid_solid_elastic_ispec(num_fluid_solid_edges) = ispec_elastic
+ fluid_solid_elastic_iedge(num_fluid_solid_edges) = iedge_elastic
+! print *,'edge ',iedge_acoustic,' of acoustic element ',ispec_acoustic, &
+! ' is in contact with edge ',iedge_elastic,' of elastic element ',ispec_elastic
+ endif
- endif
+ enddo
+ enddo
-! full anisotropy
- if(TURN_ANISOTROPY_ON) then
+ endif
-! implement anisotropy in 2D
- duydyl = ZERO
- duydzl = ZERO
- duzdyl = ZERO
- duxdyl = ZERO
- duydxl = ZERO
+ enddo
+ enddo
-! precompute some sums
- duxdxl_plus_duydyl = duxdxl + duydyl
- duxdxl_plus_duzdzl = duxdxl + duzdzl
- duydyl_plus_duzdzl = duydyl + duzdzl
- duxdyl_plus_duydxl = duxdyl + duydxl
- duzdxl_plus_duxdzl = duzdxl + duxdzl
- duzdyl_plus_duydzl = duzdyl + duydzl
+ if(num_fluid_solid_edges /= num_fluid_solid_edges_alloc) stop 'error in creation of arrays for fluid/solid matching'
- sigma_xx = c11val*duxdxl + c16val*duxdyl_plus_duydxl + c12val*duydyl + &
- c15val*duzdxl_plus_duxdzl + c14val*duzdyl_plus_duydzl + c13val*duzdzl
+! make sure fluid/solid matching has been perfectly detected: check that the grid points
+! have the same physical coordinates
+! loop on all the coupling edges
-! sigma_yy = c12val*duxdxl + c26val*duxdyl_plus_duydxl + c22val*duydyl + &
-! c25val*duzdxl_plus_duxdzl + c24val*duzdyl_plus_duydzl + c23val*duzdzl
+ print *,'Checking fluid/solid edge topology...'
- sigma_zz = c13val*duxdxl + c36val*duxdyl_plus_duydxl + c23val*duydyl + &
- c35val*duzdxl_plus_duxdzl + c34val*duzdyl_plus_duydzl + c33val*duzdzl
+ do inum = 1,num_fluid_solid_edges
-! sigma_xy = c16val*duxdxl + c66val*duxdyl_plus_duydxl + c26val*duydyl + &
-! c56val*duzdxl_plus_duxdzl + c46val*duzdyl_plus_duydzl + c36val*duzdzl
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_solid_acoustic_ispec(inum)
+ iedge_acoustic = fluid_solid_acoustic_iedge(inum)
- sigma_xz = c15val*duxdxl + c56val*duxdyl_plus_duydxl + c25val*duydyl + &
- c55val*duzdxl_plus_duxdzl + c45val*duzdyl_plus_duydzl + c35val*duzdzl
+! get the corresponding edge of the elastic element
+ ispec_elastic = fluid_solid_elastic_ispec(inum)
+ iedge_elastic = fluid_solid_elastic_iedge(inum)
-! sigma_yz = c14val*duxdxl + c46val*duxdyl_plus_duydxl + c24val*duydyl + &
-! c45val*duzdxl_plus_duxdzl + c44val*duzdyl_plus_duydzl + c34val*duzdzl
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
- endif
+! 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)
-! stress tensor is symmetric
- sigma_zx = sigma_xz
+! get point values for the acoustic side
+ i = ivalue(ipoin1D,iedge_acoustic)
+ j = jvalue(ipoin1D,iedge_acoustic)
+ iglob2 = ibool(i,j,ispec_acoustic)
- jacobianl = jacobian(i,j,ispec)
+! 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) &
+ stop 'error in fluid/solid coupling buffer'
-! for acoustic medium
- if(ACOUSTIC) then
- tempx1(i,j) = jacobianl*(xixl*dUxdxl + xizl*dUxdzl)
- tempx2(i,j) = jacobianl*(gammaxl*dUxdxl + gammazl*dUxdzl)
+ enddo
-! weak formulation term based on stress tensor (non-symmetric form)
- else
- tempx1(i,j) = jacobianl*(sigma_xx*xixl+sigma_zx*xizl)
- tempz1(i,j) = jacobianl*(sigma_xz*xixl+sigma_zz*xizl)
+ enddo
- tempx2(i,j) = jacobianl*(sigma_xx*gammaxl+sigma_zx*gammazl)
- tempz2(i,j) = jacobianl*(sigma_xz*gammaxl+sigma_zz*gammazl)
- endif
+ print *,'End of fluid/solid edge detection'
+ print *
- enddo
- enddo
+ else
-!
-! second double-loop over GLL to compute all terms
-!
- do j = 1,NGLLZ
- do i = 1,NGLLX
+! allocate dummy arrays for fluid/solid matching if purely acoustic or purely elastic
+ allocate(fluid_solid_acoustic_ispec(1))
+ allocate(fluid_solid_acoustic_iedge(1))
+ allocate(fluid_solid_elastic_ispec(1))
+ allocate(fluid_solid_elastic_iedge(1))
-! along x direction
- tempx1l = ZERO
- tempz1l = ZERO
- do k = 1,NGLLX
- fac1 = wxgll(k)*hprime_xx(i,k)
- tempx1l = tempx1l + tempx1(k,j)*fac1
- if(ELASTIC) tempz1l = tempz1l + tempz1(k,j)*fac1
- enddo
+ endif
-! along z direction
- tempx2l = ZERO
- tempz2l = ZERO
- do k = 1,NGLLZ
- fac2 = wzgll(k)*hprime_zz(j,k)
- tempx2l = tempx2l + tempx2(i,k)*fac2
- if(ELASTIC) tempz2l = tempz2l + tempz2(i,k)*fac2
- enddo
+! default values for acoustic absorbing edges
+ ibegin_bottom(:) = 1
+ ibegin_top(:) = 1
-! GLL integration weights
- fac1 = wzgll(j)
- fac2 = wxgll(i)
+ iend_bottom(:) = NGLLX
+ iend_top(:) = NGLLX
-! for acoustic medium
- iglob = ibool(i,j,ispec)
- accel(1,iglob) = accel(1,iglob) - (fac1*tempx1l + fac2*tempx2l)
- if(ELASTIC) then
- accel(2,iglob) = accel(2,iglob) - (fac1*tempz1l + fac2*tempz2l)
- else
- accel(2,iglob) = zero
- endif
+ jbegin_left(:) = 1
+ jbegin_right(:) = 1
- enddo ! second loop over the GLL points
- enddo
+ jend_left(:) = NGLLZ
+ jend_right(:) = NGLLZ
- enddo ! end of loop over all spectral elements
+! exclude common points between acoustic absorbing edges and acoustic/elastic matching interface
+ if(coupled_acoustic_elastic .and. anyabs) then
-!
-!--- absorbing boundaries
-!
- if(anyabs) then
+ print *,'excluding common points between acoustic absorbing edges and acoustic/elastic matching interface, if any'
- do ispecabs=1,nelemabs
+ do ispecabs = 1,nelemabs
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))
- kappal = lambdal_relaxed + TWO*mul_relaxed/3.d0
- cpl = sqrt((kappal + 4.d0*mul_relaxed/3.d0)/rhol)
- csl = sqrt(mul_relaxed/rhol)
+! loop on all the coupling edges
+ do inum = 1,num_fluid_solid_edges
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_solid_acoustic_ispec(inum)
+ iedge_acoustic = fluid_solid_acoustic_iedge(inum)
-!--- left absorbing boundary
- if(codeabs(ILEFT,ispecabs)) then
+! if acoustic absorbing element and acoustic/elastic coupled element is the same
+ if(ispec_acoustic == ispec) then
- i = 1
-
- do j=1,NGLLZ
-
- iglob = ibool(i,j,ispec)
-
- zgamma = xix(i,j,ispec) * jacobian(i,j,ispec)
-
-! external velocity model
- if(read_external_model) then
- cpl = vpext(iglob)
- csl = vsext(iglob)
- rhol = rhoext(iglob)
+ if(iedge_acoustic == IBOTTOM) then
+ jbegin_left(ispecabs) = 2
+ jbegin_right(ispecabs) = 2
endif
- rho_vp = rhol*cpl
- rho_vs = rhol*csl
-
- nx = -ONE
- nz = ZERO
-
- vx = veloc(1,iglob)
- vz = veloc(2,iglob)
-
- vn = nx*vx+nz*vz
-
- tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
- tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
-
- weight = zgamma*wzgll(j)
-
-! Clayton-Engquist condition if elastic, Sommerfeld condition if acoustic
- if(ELASTIC) then
- accel(1,iglob) = accel(1,iglob) - tx*weight
- accel(2,iglob) = accel(2,iglob) - tz*weight
- else
- accel(1,iglob) = accel(1,iglob) - veloc(1,iglob)*weight/cpl
+ if(iedge_acoustic == ITOP) then
+ jend_left(ispecabs) = NGLLZ - 1
+ jend_right(ispecabs) = NGLLZ - 1
endif
- enddo
-
- endif ! end of left absorbing boundary
-
-!--- right absorbing boundary
- if(codeabs(IRIGHT,ispecabs)) then
-
- i = NGLLX
-
- do j=1,NGLLZ
-
- iglob = ibool(i,j,ispec)
-
- zgamma = xix(i,j,ispec) * jacobian(i,j,ispec)
-
-! external velocity model
- if(read_external_model) then
- cpl = vpext(iglob)
- csl = vsext(iglob)
- rhol = rhoext(iglob)
+ if(iedge_acoustic == ILEFT) then
+ ibegin_bottom(ispecabs) = 2
+ ibegin_top(ispecabs) = 2
endif
- rho_vp = rhol*cpl
- rho_vs = rhol*csl
-
- nx = ONE
- nz = ZERO
-
- vx = veloc(1,iglob)
- vz = veloc(2,iglob)
-
- vn = nx*vx+nz*vz
-
- tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
- tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
-
- weight = zgamma*wzgll(j)
-
-! Clayton-Engquist condition if elastic, Sommerfeld condition if acoustic
- if(ELASTIC) then
- accel(1,iglob) = accel(1,iglob) - tx*weight
- accel(2,iglob) = accel(2,iglob) - tz*weight
- else
- accel(1,iglob) = accel(1,iglob) - veloc(1,iglob)*weight/cpl
+ if(iedge_acoustic == IRIGHT) then
+ iend_bottom(ispecabs) = NGLLX - 1
+ iend_top(ispecabs) = NGLLX - 1
endif
- enddo
+ endif
- endif ! end of right absorbing boundary
+ enddo
-!--- bottom absorbing boundary
- if(codeabs(IBOTTOM,ispecabs)) then
+ enddo
- j = 1
+ endif
-! exclude corners to make sure there is no contradiction on the normal
- i1abs = 1
- i2abs = NGLLX
- if(codeabs(ILEFT,ispecabs)) i1abs = 2
- if(codeabs(IRIGHT,ispecabs)) i2abs = NGLLX-1
+!
+!---- s t a r t t i m e i t e r a t i o n s
+!
- do i=i1abs,i2abs
+ write(IOUT,400)
- iglob = ibool(i,j,ispec)
+! count elapsed wall-clock time
+ datein = ''
+ timein = ''
+ zone = ''
- xxi = gammaz(i,j,ispec) * jacobian(i,j,ispec)
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
-! external velocity model
- if(read_external_model) then
- cpl = vpext(iglob)
- csl = vsext(iglob)
- rhol = rhoext(iglob)
- endif
+! *********************************************************
+! ************* MAIN LOOP OVER THE TIME STEPS *************
+! *********************************************************
- rho_vp = rhol*cpl
- rho_vs = rhol*csl
+ do it = 1,NSTEP
- nx = ZERO
- nz = -ONE
+! compute current time
+ time = (it-1)*deltat
- vx = veloc(1,iglob)
- vz = veloc(2,iglob)
+! update displacement using finite-difference time scheme (Newmark)
+ if(any_elastic) then
+ displ_elastic = displ_elastic + deltat*veloc_elastic + deltatsquareover2*accel_elastic
+ veloc_elastic = veloc_elastic + deltatover2*accel_elastic
+ accel_elastic = ZERO
+ endif
- vn = nx*vx+nz*vz
+ if(any_acoustic) then
- tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
- tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
+ 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
- weight = xxi*wxgll(i)
+! free surface for an acoustic medium
+ call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,ispecnum_acoustic_surface,iedgenum_acoustic_surface, &
+ ibool,nelem_acoustic_surface,npoin,nspec)
-! Clayton-Engquist condition if elastic, Sommerfeld condition if acoustic
- if(ELASTIC) then
- accel(1,iglob) = accel(1,iglob) - tx*weight
- accel(2,iglob) = accel(2,iglob) - tz*weight
- else
- accel(1,iglob) = accel(1,iglob) - veloc(1,iglob)*weight/cpl
- endif
+! *********************************************************
+! ************* compute forces for the acoustic elements
+! *********************************************************
- enddo
+ call compute_forces_acoustic(npoin,nspec,nelemabs,numat, &
+ iglob_source,ispec_selected_source,source_type,it,NSTEP,anyabs, &
+ assign_external_model,initialfield,ibool,kmato,numabs, &
+ elastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,density,elastcoef,xix,xiz,gammax,gammaz,jacobian, &
+ vpext,vsext,rhoext,source_time_function,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)
- endif ! end of bottom absorbing boundary
+ endif ! end of test if any acoustic element
-!--- top absorbing boundary
- if(codeabs(ITOP,ispecabs)) then
+! *********************************************************
+! ************* add coupling with the elastic side
+! *********************************************************
- j = NGLLZ
+ if(coupled_acoustic_elastic) then
-! exclude corners to make sure there is no contradiction on the normal
- i1abs = 1
- i2abs = NGLLX
- if(codeabs(ILEFT,ispecabs)) i1abs = 2
- if(codeabs(IRIGHT,ispecabs)) i2abs = NGLLX-1
+! loop on all the coupling edges
+ do inum = 1,num_fluid_solid_edges
- do i=i1abs,i2abs
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_solid_acoustic_ispec(inum)
+ iedge_acoustic = fluid_solid_acoustic_iedge(inum)
- iglob = ibool(i,j,ispec)
+! get the corresponding edge of the elastic element
+ ispec_elastic = fluid_solid_elastic_ispec(inum)
+ iedge_elastic = fluid_solid_elastic_iedge(inum)
- xxi = gammaz(i,j,ispec) * jacobian(i,j,ispec)
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
-! external velocity model
- if(read_external_model) then
- cpl = vpext(iglob)
- csl = vsext(iglob)
- rhol = rhoext(iglob)
- endif
+! 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)
- rho_vp = rhol*cpl
- rho_vs = rhol*csl
+ displ_x = displ_elastic(1,iglob)
+ displ_z = displ_elastic(2,iglob)
- nx = ZERO
- nz = ONE
+! get point values for the acoustic side
+ i = ivalue(ipoin1D,iedge_acoustic)
+ j = jvalue(ipoin1D,iedge_acoustic)
+ iglob = ibool(i,j,ispec_acoustic)
- vx = veloc(1,iglob)
- vz = veloc(2,iglob)
-
- vn = nx*vx+nz*vz
-
- tx = rho_vp*vn*nx+rho_vs*(vx-vn*nx)
- tz = rho_vp*vn*nz+rho_vs*(vz-vn*nz)
-
- weight = xxi*wxgll(i)
-
-! Clayton-Engquist condition if elastic, Sommerfeld condition if acoustic
- if(ELASTIC) then
- accel(1,iglob) = accel(1,iglob) - tx*weight
- accel(2,iglob) = accel(2,iglob) - tz*weight
+! 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
+ 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
- accel(1,iglob) = accel(1,iglob) - veloc(1,iglob)*weight/cpl
+ 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
endif
- enddo
+! compute dot product
+ displ_n = displ_x*nx + displ_z*nz
- endif ! end of top absorbing boundary
+! formulation with generalized potential
+ weight = jacobian1D * wxgll(i)
- enddo
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*displ_n
- endif ! end of absorbing boundaries
+ enddo
+ enddo
-! --- add the source
- if(.not. initialfield) then
-
-! collocated force
-! beware, for acoustic medium, source is a potential, therefore source time function
-! gives shape of velocity, not displacement
- if(source_type == 1) then
- if(ELASTIC) then
- accel(1,iglob_source) = accel(1,iglob_source) - sin(angleforce)*source_time_function(it)
- accel(2,iglob_source) = accel(2,iglob_source) + cos(angleforce)*source_time_function(it)
- else
- accel(1,iglob_source) = accel(1,iglob_source) + source_time_function(it)
endif
-! moment tensor
- else if(source_type == 2) then
+! ************************************************************************************
+! ************* multiply by the inverse of the mass matrix and update velocity
+! ************************************************************************************
-! add source array
- do j=1,NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec_selected_source)
- accel(:,iglob) = accel(:,iglob) + sourcearray(:,i,j)*source_time_function(it)
- enddo
- enddo
+ if(any_acoustic) then
- endif
+ potential_dot_dot_acoustic = potential_dot_dot_acoustic * rmass_inverse_acoustic
+ potential_dot_acoustic = potential_dot_acoustic + deltatover2*potential_dot_dot_acoustic
- else
- stop 'wrong source type'
+! free surface for an acoustic medium
+ call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,ispecnum_acoustic_surface,iedgenum_acoustic_surface, &
+ ibool,nelem_acoustic_surface,npoin,nspec)
endif
-! divide by the mass matrix
- accel(1,:) = accel(1,:) / rmass(:)
- accel(2,:) = accel(2,:) / rmass(:)
+! *********************************************************
+! ************* main solver for the elastic elements
+! *********************************************************
-! update velocity
- veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+ if(any_elastic) &
+ call compute_forces_elastic(npoin,nspec,nelemabs,numat,iglob_source, &
+ ispec_selected_source,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_mech1,e11_mech1, &
+ e13_mech1,e1_mech2,e11_mech2,e13_mech2,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)
+! *********************************************************
+! ************* add coupling with the acoustic side
+! *********************************************************
-!--- free surface for an acoustic medium
+ if(coupled_acoustic_elastic) then
-! if acoustic, the free surface condition is a Dirichlet condition for the potential,
-! not Neumann, in order to impose zero pressure at the surface. Also check that
-! top absorbing boundary is not set because cannot be both absorbing and free surface
- if(ACOUSTIC .and. .not. abshaut) then
+! loop on all the coupling edges
+ do inum = 1,num_fluid_solid_edges
- do ispecsurface=1,nelemsurface
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_solid_acoustic_ispec(inum)
+ iedge_acoustic = fluid_solid_acoustic_iedge(inum)
- ispec = numsurface(ispecsurface)
+! get the corresponding edge of the elastic element
+ ispec_elastic = fluid_solid_elastic_ispec(inum)
+ iedge_elastic = fluid_solid_elastic_iedge(inum)
- j = NGLLZ
- do i=1,NGLLX
- iglob = ibool(i,j,ispec)
- displ(:,iglob) = ZERO
- veloc(:,iglob) = ZERO
- accel(:,iglob) = ZERO
- enddo
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
- enddo
+! 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)
- endif ! end of free surface condition for acoustic medium
+! get density of the fluid, depending if external density model
+ if(assign_external_model) then
+ rhol = rhoext(i,j,ispec_acoustic)
+ else
+ rhol = density(kmato(ispec_acoustic))
+ endif
+! compute pressure on the fluid/solid edge
+ pressure = - rhol * potential_dot_dot_acoustic(iglob)
-! implement attenuation
- if(TURN_ATTENUATION_ON) then
+! get point values for the elastic side
+ i = ivalue(ipoin1D,iedge_elastic)
+ j = jvalue(ipoin1D,iedge_elastic)
+ iglob = ibool(i,j,ispec_elastic)
-! compute Grad(displ) at time step n+1 for attenuation
- call compute_gradient_attenuation(displ,duxdxl_np1,duzdxl_np1, &
- duxdzl_np1,duzdzl_np1,xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,NSPEC,npoin)
+! 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
+ 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
+ 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
+ endif
-! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
- do k=1,nspec
- do j=1,NGLLZ
- do i=1,NGLLX
+! formulation with generalized potential
+ weight = jacobian1D * wxgll(i)
- theta_n = duxdxl_n(i,j,k) + duzdzl_n(i,j,k)
- theta_np1 = duxdxl_np1(i,j,k) + duzdzl_np1(i,j,k)
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) + weight*nx*pressure
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) + weight*nz*pressure
-! evolution e1_mech1
- Un = e1_mech1(i,j,k)
- tauinv = - inv_tau_sigma_nu1_mech1
- tauinvsquare = tauinv * tauinv
- tauinvcube = tauinvsquare * tauinv
- tauinvUn = tauinv * Un
- Sn = theta_n * phi_nu1_mech1
- Snp1 = theta_np1 * phi_nu1_mech1
- Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
- twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
- fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e1_mech1(i,j,k) = Unp1
+ enddo
-! evolution e1_mech2
- Un = e1_mech2(i,j,k)
- tauinv = - inv_tau_sigma_nu1_mech2
- tauinvsquare = tauinv * tauinv
- tauinvcube = tauinvsquare * tauinv
- tauinvUn = tauinv * Un
- Sn = theta_n * phi_nu1_mech2
- Snp1 = theta_np1 * phi_nu1_mech2
- Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
- twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
- fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e1_mech2(i,j,k) = Unp1
+ enddo
-! evolution e11_mech1
- Un = e11_mech1(i,j,k)
- tauinv = - inv_tau_sigma_nu2_mech1
- tauinvsquare = tauinv * tauinv
- tauinvcube = tauinvsquare * tauinv
- tauinvUn = tauinv * Un
- Sn = (duxdxl_n(i,j,k) - theta_n/TWO) * phi_nu2_mech1
- Snp1 = (duxdxl_np1(i,j,k) - theta_np1/TWO) * phi_nu2_mech1
- Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
- twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
- fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e11_mech1(i,j,k) = Unp1
+ endif
-! evolution e11_mech2
- Un = e11_mech2(i,j,k)
- tauinv = - inv_tau_sigma_nu2_mech2
- tauinvsquare = tauinv * tauinv
- tauinvcube = tauinvsquare * tauinv
- tauinvUn = tauinv * Un
- Sn = (duxdxl_n(i,j,k) - theta_n/TWO) * phi_nu2_mech2
- Snp1 = (duxdxl_np1(i,j,k) - theta_np1/TWO) * phi_nu2_mech2
- Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
- twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
- fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e11_mech2(i,j,k) = Unp1
+! ************************************************************************************
+! ************* multiply by the inverse of the mass matrix and update velocity
+! ************************************************************************************
-! evolution e13_mech1
- Un = e13_mech1(i,j,k)
- tauinv = - inv_tau_sigma_nu2_mech1
- tauinvsquare = tauinv * tauinv
- tauinvcube = tauinvsquare * tauinv
- tauinvUn = tauinv * Un
- Sn = (duxdzl_n(i,j,k) + duzdxl_n(i,j,k)) * phi_nu2_mech1
- Snp1 = (duxdzl_np1(i,j,k) + duzdxl_np1(i,j,k)) * phi_nu2_mech1
- Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
- twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
- fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e13_mech1(i,j,k) = Unp1
+ if(any_elastic) then
+ accel_elastic(1,:) = accel_elastic(1,:) * rmass_inverse_elastic
+ accel_elastic(2,:) = accel_elastic(2,:) * rmass_inverse_elastic
+ veloc_elastic = veloc_elastic + deltatover2*accel_elastic
+ endif
-! evolution e13_mech2
- Un = e13_mech2(i,j,k)
- tauinv = - inv_tau_sigma_nu2_mech2
- tauinvsquare = tauinv * tauinv
- tauinvcube = tauinvsquare * tauinv
- tauinvUn = tauinv * Un
- Sn = (duxdzl_n(i,j,k) + duzdxl_n(i,j,k)) * phi_nu2_mech2
- Snp1 = (duxdzl_np1(i,j,k) + duzdxl_np1(i,j,k)) * phi_nu2_mech2
- Unp1 = Un + (deltatfourth*tauinvcube*(Sn + tauinvUn) + &
- twelvedeltat*(Sn + Snp1 + 2*tauinvUn) + &
- fourdeltatsquare*tauinv*(2*Sn + Snp1 + 3*tauinvUn) + &
- deltatcube*tauinvsquare*(3*Sn + Snp1 + 4*tauinvUn))* ONE_OVER_24
- e13_mech2(i,j,k) = Unp1
-
- enddo
- enddo
- enddo
-
- endif ! end of test on attenuation
-
!---- display time step and max of norm of displacement
- if(mod(it,IT_AFFICHE) == 0 .or. it == 5) then
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then
write(IOUT,*)
if(time >= 1.d-3 .and. time < 1000.d0) then
@@ -1619,35 +1601,52 @@
write(IOUT,"('Time step number ',i6,' t = ',1pe12.6,' s')") it,time
endif
- displnorm_all = maxval(sqrt(displ(1,:)**2 + displ(2,:)**2))
- write(IOUT,*) 'Max norm of field = ',displnorm_all
-! check stability of the code, exit if unstable
- if(displnorm_all > STABILITY_THRESHOLD) stop 'code became unstable and blew up'
+ if(any_elastic) then
+ displnorm_all = maxval(sqrt(displ_elastic(1,:)**2 + displ_elastic(2,:)**2))
+ write(IOUT,*) 'Max norm of vector field in solid = ',displnorm_all
+! check stability of the code in solid, exit if unstable
+ if(displnorm_all > STABILITY_THRESHOLD) stop 'code became unstable and blew up in solid'
+ endif
+ if(any_acoustic) then
+ displnorm_all = maxval(abs(potential_acoustic(:)))
+ write(IOUT,*) 'Max absolute value of scalar field in fluid = ',displnorm_all
+! check stability of the code in fluid, exit if unstable
+ if(displnorm_all > STABILITY_THRESHOLD) stop 'code became unstable and blew up in fluid'
+ endif
+
write(IOUT,*)
endif
-! store the seismograms
- if(sismostype < 1 .or. sismostype > 4) stop 'Wrong field code for seismogram output'
+! loop on all the receivers to compute and store the seismograms
+ do irec = 1,nrec
- if(ELASTIC .and. sismostype == 4) stop 'pressure seismograms implemented for an acoustic medium only'
+ ispec = ispec_selected_rec(irec)
- if(ACOUSTIC) then
- if(sismostype == 1) then
- stop 'cannot store displacement field in acoustic medium because of potential formulation'
- else if(sismostype == 2) then
-! for acoustic medium, compute gradient for display, displ represents the potential
- call compute_gradient_fluid(displ,vector_field_postscript, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,NSPEC,npoin)
- else if(sismostype == 3) then
-! for acoustic medium, compute gradient for display, veloc represents the first derivative of the potential
- call compute_gradient_fluid(veloc,vector_field_postscript, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,NSPEC,npoin)
+! 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, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
+ numat,kmato,density,elastcoef,vpext,vsext,rhoext,ispec,e1_mech1,e11_mech1, &
+ e1_mech2,e11_mech2,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON)
+
+ else if(.not. elastic(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)
+ 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)
+ 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)
+ endif
+
endif
- endif
- do irec=1,nrec
-
! perform the general interpolation using Lagrange polynomials
valux = ZERO
valuz = ZERO
@@ -1655,44 +1654,35 @@
do j = 1,NGLLZ
do i = 1,NGLLX
- iglob = ibool(i,j,ispec_selected_rec(irec))
+ iglob = ibool(i,j,ispec)
hlagrange = hxir_store(irec,i)*hgammar_store(irec,j)
- if(ELASTIC) then
+ if(seismotype == 4) then
- if(sismostype == 1) then
- dxd = displ(1,iglob)
- dzd = displ(2,iglob)
- else if(sismostype == 2) then
- dxd = veloc(1,iglob)
- dzd = veloc(2,iglob)
- else
- dxd = accel(1,iglob)
- dzd = accel(2,iglob)
- endif
+ dxd = pressure_element(i,j)
+ dzd = ZERO
- else
+ else if(.not. elastic(ispec)) then
-! for acoustic medium
+ dxd = vector_field_element(1,i,j)
+ dzd = vector_field_element(2,i,j)
-! pressure = - rho * Chi_dot
- if(sismostype == 4) then
+ else if(seismotype == 1) then
- material = kmato(ispec_selected_rec(irec))
- denst = density(material)
- if(read_external_model) denst = rhoext(ibool(i,j,ispec_selected_rec(irec)))
+ dxd = displ_elastic(1,iglob)
+ dzd = displ_elastic(2,iglob)
- dxd = - denst * veloc(1,iglob)
- dzd = ZERO
+ else if(seismotype == 2) then
-! velocity
- else
- dxd = vector_field_postscript(1,iglob)
- dzd = vector_field_postscript(2,iglob)
+ dxd = veloc_elastic(1,iglob)
+ dzd = veloc_elastic(2,iglob)
- endif
+ else if(seismotype == 3) then
+ dxd = accel_elastic(1,iglob)
+ dzd = accel_elastic(2,iglob)
+
endif
! compute interpolated field
@@ -1702,156 +1692,178 @@
enddo
enddo
-! rotate seismogram components if needed
- sisux(it,irec) = cosrot*valux + sinrot*valuz
- sisuz(it,irec) = - sinrot*valux + cosrot*valuz
+! rotate seismogram components if needed, except if recording pressure, which is a scalar
+ if(seismotype /= 4) then
+ sisux(it,irec) = cosrot*valux + sinrot*valuz
+ sisuz(it,irec) = - sinrot*valux + cosrot*valuz
+ else
+ sisux(it,irec) = valux
+ sisuz(it,irec) = ZERO
+ endif
enddo
!
-!---- affichage des resultats a certains pas de temps
+!---- display results at given time steps
!
- if(mod(it,IT_AFFICHE) == 0 .or. it == 5 .or. it == NSTEP) then
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
!
-!---- affichage postscript
+!---- PostScript display
!
if(output_postscript_snapshot) then
- write(IOUT,*) 'Dump PostScript'
+ write(IOUT,*) 'Writing PostScript file'
-! for elastic medium
- if(ELASTIC .and. vecttype == 1) then
- write(IOUT,*) 'drawing displacement field...'
- call plotpost(displ,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, &
- numabs,codeabs,anyabs,stitle,npoin,npgeo,vpmin,vpmax,nrec, &
- colors,numbers,subsamp,vecttype,interpol,meshvect,modelvect, &
- boundvect,read_external_model,cutvect,sizemax_arrows,nelemabs,numat,pointsdisp,nspec,ngnod,ELASTIC, &
- plot_lowerleft_corner_only)
+ if(imagetype == 1) then
- else if(ELASTIC .and. vecttype == 2) then
- write(IOUT,*) 'drawing velocity field...'
- call plotpost(veloc,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, &
- numabs,codeabs,anyabs,stitle,npoin,npgeo,vpmin,vpmax,nrec, &
- colors,numbers,subsamp,vecttype,interpol,meshvect,modelvect, &
- boundvect,read_external_model,cutvect,sizemax_arrows,nelemabs,numat,pointsdisp,nspec,ngnod,ELASTIC, &
- plot_lowerleft_corner_only)
+ write(IOUT,*) 'drawing displacement vector as small arrows...'
- else if(ELASTIC .and. vecttype == 3) then
- write(IOUT,*) 'drawing acceleration field...'
- call plotpost(accel,coord,vpext,x_source,z_source,st_xval,st_zval, &
+ call compute_vector_whole_medium(potential_acoustic,displ_elastic,elastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
+
+ 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, &
- numabs,codeabs,anyabs,stitle,npoin,npgeo,vpmin,vpmax,nrec, &
- colors,numbers,subsamp,vecttype,interpol,meshvect,modelvect, &
- boundvect,read_external_model,cutvect,sizemax_arrows,nelemabs,numat,pointsdisp,nspec,ngnod,ELASTIC, &
- plot_lowerleft_corner_only)
+ numabs,codeabs,anyabs,simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
+ 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)
-! for acoustic medium
- else if(ACOUSTIC .and. vecttype == 1) then
- stop 'cannot display displacement field in acoustic medium because of potential formulation'
+ else if(imagetype == 2) then
- else if(ACOUSTIC .and. vecttype == 2) then
- write(IOUT,*) 'drawing acoustic velocity field from velocity potential...'
-! for acoustic medium, compute gradient for display, displ represents the potential
- call compute_gradient_fluid(displ,vector_field_postscript, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,NSPEC,npoin)
- call plotpost(vector_field_postscript,coord,vpext,x_source,z_source,st_xval,st_zval, &
+ write(IOUT,*) 'drawing velocity vector as small arrows...'
+
+ call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,elastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
+
+ 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, &
- numabs,codeabs,anyabs,stitle,npoin,npgeo,vpmin,vpmax,nrec, &
- colors,numbers,subsamp,vecttype,interpol,meshvect,modelvect, &
- boundvect,read_external_model,cutvect,sizemax_arrows,nelemabs,numat,pointsdisp,nspec,ngnod,ELASTIC, &
- plot_lowerleft_corner_only)
+ numabs,codeabs,anyabs,simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
+ 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)
- else if(ACOUSTIC .and. vecttype == 3) then
- write(IOUT,*) 'drawing acoustic acceleration field from velocity potential...'
-! for acoustic medium, compute gradient for display, veloc represents the first derivative of the potential
- call compute_gradient_fluid(veloc,vector_field_postscript, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,NSPEC,npoin)
- call plotpost(vector_field_postscript,coord,vpext,x_source,z_source,st_xval,st_zval, &
+ else if(imagetype == 3) then
+
+ write(IOUT,*) 'drawing acceleration vector as small arrows...'
+
+ call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,elastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
+
+ 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, &
- numabs,codeabs,anyabs,stitle,npoin,npgeo,vpmin,vpmax,nrec, &
- colors,numbers,subsamp,vecttype,interpol,meshvect,modelvect, &
- boundvect,read_external_model,cutvect,sizemax_arrows,nelemabs,numat,pointsdisp,nspec,ngnod,ELASTIC, &
- plot_lowerleft_corner_only)
+ numabs,codeabs,anyabs,simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
+ 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)
+ else if(imagetype == 4) then
+
+ write(IOUT,*) 'cannot draw scalar pressure field as a vector plot, skipping...'
+
else
- stop 'wrong field code for PostScript display'
+ stop 'wrong type for snapshots'
endif
- write(IOUT,*) 'Fin dump PostScript'
+ if(imagetype /= 4) write(IOUT,*) 'PostScript file written'
+
endif
!
-!---- affichage image color
+!---- display color image
!
if(output_color_image) then
write(IOUT,*) 'Creating color image of size ',NX_IMAGE_color,' x ',NZ_IMAGE_color
- donnees_image_color_2D(:,:) = 0.d0
+ if(imagetype == 1) then
- do j = 1,NZ_IMAGE_color
- do i = 1,NX_IMAGE_color
+ write(IOUT,*) 'drawing image of vertical component of displacement vector...'
- iglob = iglob_image_color_2D(i,j)
+ call compute_vector_whole_medium(potential_acoustic,displ_elastic,elastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
- if(iglob /= -1) then
-! display vertical component of vector if elastic medium
- if(ELASTIC) then
+ else if(imagetype == 2) then
- if(vecttype == 1) then
- donnees_image_color_2D(i,j) = displ(2,iglob)
- else if(vecttype == 2) then
- donnees_image_color_2D(i,j) = veloc(2,iglob)
- else
- donnees_image_color_2D(i,j) = accel(2,iglob)
- endif
+ write(IOUT,*) 'drawing image of vertical component of velocity vector...'
- else
-! display pressure if acoustic medium
+ call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,elastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
-! pressure = - rho * Chi_dot
- material = kmato(ispec_for_color_image(iglob))
- denst = density(material)
- if(read_external_model) denst = rhoext(iglob)
+ else if(imagetype == 3) then
- donnees_image_color_2D(i,j) = - denst * veloc(1,iglob)
+ write(IOUT,*) 'drawing image of vertical component of acceleration vector...'
-! uncomment this for vertical component of velocity vector instead in acoustic medium
-! donnees_image_color_2D(i,j) = vector_field_postscript(2,iglob)
+ call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,elastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
- endif
- endif
+ else if(imagetype == 4) then
+
+ write(IOUT,*) 'drawing image of pressure field...'
+
+ call compute_pressure_whole_medium(potential_dot_dot_acoustic,displ_elastic,elastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
+ numat,kmato,density,elastcoef,vpext,vsext,rhoext,e1_mech1,e11_mech1, &
+ e1_mech2,e11_mech2,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON)
+
+ else
+ stop 'wrong type for snapshots'
+ endif
+
+ image_color_data(:,:) = 0.d0
+ do j = 1,NZ_IMAGE_color
+ do i = 1,NX_IMAGE_color
+ iglob = iglob_image_color(i,j)
+! draw vertical component of field
+! or pressure which is stored in the same array used as temporary storage
+ if(iglob /= -1) image_color_data(i,j) = vector_field_display(2,iglob)
enddo
enddo
- call create_color_image(donnees_image_color_2D,iglob_image_color_2D,NX_IMAGE_color,NZ_IMAGE_color,it,cutvect)
+ call create_color_image(image_color_data,iglob_image_color,NX_IMAGE_color,NZ_IMAGE_color,it,cutsnaps)
- write(IOUT,*) 'End creating color image'
+ write(IOUT,*) 'Color image created'
endif
-!---- save temporary seismograms
+!---- save temporary or final seismograms
call write_seismograms(sisux,sisuz,station_name,network_name,NSTEP, &
- nrec,deltat,sismostype,st_xval,it,t0,buffer_binary_single,buffer_binary_double)
+ nrec,deltat,seismotype,st_xval,it,t0,buffer_binary_single,buffer_binary_double)
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! elapsed time since beginning of the simulation
+ tCPU = time_end - time_start
+ int_tCPU = int(tCPU)
+ ihours = int_tCPU / 3600
+ iminutes = (int_tCPU - 3600*ihours) / 60
+ iseconds = int_tCPU - 3600*ihours - 60*iminutes
+ write(*,*) 'Elapsed time in seconds = ',tCPU
+ write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ write(*,*)
+
endif
enddo ! end of the main time loop
-!---- save final seismograms
- call write_seismograms(sisux,sisuz,station_name,network_name,NSTEP, &
- nrec,deltat,sismostype,st_xval,it,t0,buffer_binary_single,buffer_binary_double)
-
! print exit banner
- call datim(stitle)
+ call datim(simulation_title)
!
!---- close output file
@@ -1869,7 +1881,7 @@
'Number of space dimensions. . . . . . . . . . (NDIM) =',i8)
600 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
- 'Display frequency . . . . . . . . . . . (IT_AFFICHE) = ',i6/ 5x, &
+ 'Display frequency . . . (NTSTEP_BETWEEN_OUTPUT_INFO) = ',i6/ 5x, &
'Color display . . . . . . . . . . . . . . . (colors) = ',i6/ 5x, &
' == 0 black and white display ', / 5x, &
' == 1 color display ', /5x, &
@@ -1878,20 +1890,19 @@
' == 1 number the mesh ')
700 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
- 'Seismograms recording type . . . . . . .(sismostype) = ',i6/5x, &
+ 'Seismograms recording type . . . . . . .(seismotype) = ',i6/5x, &
'Angle for first line of receivers. . . . .(anglerec) = ',f6.2)
750 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
'Read external initial field. . . . . .(initialfield) = ',l6/5x, &
- 'Read external velocity model. .(read_external_model) = ',l6/5x, &
- 'Elastic simulation or acoustic. . . . . . .(ELASTIC) = ',l6/5x, &
+ 'Assign external model . . . .(assign_external_model) = ',l6/5x, &
'Turn anisotropy on or off. . . .(TURN_ANISOTROPY_ON) = ',l6/5x, &
'Turn attenuation on or off. . .(TURN_ATTENUATION_ON) = ',l6/5x, &
'Save grid in external file or not. . . .(outputgrid) = ',l6)
800 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
- 'Vector display type. . . . . . . . . . . .(vecttype) = ',i6/5x, &
- 'Percentage of cut for vector plots. . . . .(cutvect) = ',f6.2/5x, &
+ 'Vector display type . . . . . . . . . . .(imagetype) = ',i6/5x, &
+ 'Percentage of cut for vector plots . . . .(cutsnaps) = ',f6.2/5x, &
'Subsampling for velocity model display. . .(subsamp) = ',i6)
703 format(//' I t e r a t i o n s '/1x,19('='),//5x, &
Modified: seismo/2D/SPECFEM2D/trunk/write_seismograms.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/write_seismograms.f90 2007-04-17 00:40:47 UTC (rev 8507)
+++ seismo/2D/SPECFEM2D/trunk/write_seismograms.f90 2007-12-07 23:52:05 UTC (rev 8508)
@@ -1,26 +1,26 @@
!========================================================================
!
-! S P E C F E M 2 D Version 5.1
+! S P E C F E M 2 D Version 5.2
! ------------------------------
!
! Dimitri Komatitsch
-! Universite de Pau et des Pays de l'Adour, France
+! University of Pau, France
!
-! (c) January 2005
+! (c) April 2007
!
!========================================================================
! write seismograms to text files
subroutine write_seismograms(sisux,sisuz,station_name,network_name, &
- NSTEP,nrec,deltat,sismostype,st_xval,it,t0,buffer_binary_single,buffer_binary_double)
+ NSTEP,nrec,deltat,seismotype,st_xval,it,t0,buffer_binary_single,buffer_binary_double)
implicit none
include "constants.h"
- integer nrec,NSTEP,it,sismostype
+ integer nrec,NSTEP,it,seismotype
double precision t0,deltat
double precision, dimension(NSTEP,nrec) :: sisux,sisuz
@@ -48,13 +48,13 @@
! write seismograms in ASCII format
! save displacement, velocity, acceleration or pressure
- if(sismostype == 1) then
+ if(seismotype == 1) then
component = 'd'
- else if(sismostype == 2) then
+ else if(seismotype == 2) then
component = 'v'
- else if(sismostype == 3) then
+ else if(seismotype == 3) then
component = 'a'
- else if(sismostype == 4) then
+ else if(seismotype == 4) then
component = 'p'
else
stop 'wrong component to save for seismograms'
@@ -63,7 +63,7 @@
do irec = 1,nrec
! only one seismogram if pressurs
- if(sismostype == 4) then
+ if(seismotype == 4) then
number_of_components = 1
else
number_of_components = NDIM
@@ -80,7 +80,7 @@
endif
! in case of pressure, use different abbreviation
- if(sismostype == 4) chn = 'PRE'
+ if(seismotype == 4) chn = 'PRE'
! create the name of the seismogram file for each slice
! file name includes the name of the station, the network and the component
@@ -147,7 +147,7 @@
enddo
! write the new files
- if(sismostype == 4) then
+ if(seismotype == 4) then
open(unit=11,file='OUTPUT_FILES/pressure_file_single.bin',status='unknown',access='direct',recl=4*NSTEP*nrec)
else
open(unit=11,file='OUTPUT_FILES/Ux_file_single.bin',status='unknown',access='direct',recl=4*NSTEP*nrec)
@@ -155,7 +155,7 @@
write(11,rec=1) buffer_binary_single
close(11)
- if(sismostype == 4) then
+ if(seismotype == 4) then
open(unit=11,file='OUTPUT_FILES/pressure_file_double.bin',status='unknown',access='direct',recl=8*NSTEP*nrec)
else
open(unit=11,file='OUTPUT_FILES/Ux_file_double.bin',status='unknown',access='direct',recl=8*NSTEP*nrec)
@@ -173,7 +173,7 @@
close(11,status='delete')
! no Z component seismogram if pressurs
- if(sismostype /= 4) then
+ if(seismotype /= 4) then
irecord = 0
do irec=1,nrec
@@ -208,9 +208,9 @@
if(irec < nrec) write(11,*) ','
enddo
- if(sismostype == 1) then
+ if(seismotype == 1) then
write(11,*) '@title="Ux at displacement@component"@<@Ux_file_single.bin'
- else if(sismostype == 2) then
+ else if(seismotype == 2) then
write(11,*) '@title="Ux at velocity@component"@<@Ux_file_single.bin'
else
write(11,*) '@title="Ux at acceleration@component"@<@Ux_file_single.bin'
More information about the cig-commits
mailing list