[cig-commits] r8441 - in seismo/2D/SPECFEM2D/trunk: . DATA
walter at geodynamics.org
walter at geodynamics.org
Fri Dec 7 15:46:41 PST 2007
Author: walter
Date: 2007-12-07 15:46:40 -0800 (Fri, 07 Dec 2007)
New Revision: 8441
Added:
seismo/2D/SPECFEM2D/trunk/DATA/
seismo/2D/SPECFEM2D/trunk/DATA/CMTSOLUTION
seismo/2D/SPECFEM2D/trunk/DATA/Par_file
seismo/2D/SPECFEM2D/trunk/DATA/Par_file_Paul_acoustic
seismo/2D/SPECFEM2D/trunk/DATA/Par_file_Paul_elastic
seismo/2D/SPECFEM2D/trunk/DATA/Par_file_cours_M2_UPPA
seismo/2D/SPECFEM2D/trunk/DATA/STATIONS
seismo/2D/SPECFEM2D/trunk/DATA/interf_paco.dat
seismo/2D/SPECFEM2D/trunk/DATA/interface_sinus.dat
seismo/2D/SPECFEM2D/trunk/DATA/interfaces_cours_M2_UPPA_curved.dat
seismo/2D/SPECFEM2D/trunk/DATA/interfaces_cours_M2_UPPA_flat.dat
seismo/2D/SPECFEM2D/trunk/DATA/profilx.dat
seismo/2D/SPECFEM2D/trunk/DATA/profily.dat
seismo/2D/SPECFEM2D/trunk/DATA/topo_cours_M2_UPPA_curved.dat
seismo/2D/SPECFEM2D/trunk/DATA/topo_rouen_aniso.dat
seismo/2D/SPECFEM2D/trunk/DATA/topoarticle.dat
seismo/2D/SPECFEM2D/trunk/Makefile
seismo/2D/SPECFEM2D/trunk/checkgrid.f90
seismo/2D/SPECFEM2D/trunk/circ.f90
seismo/2D/SPECFEM2D/trunk/compute_gradient_attenuation.f90
seismo/2D/SPECFEM2D/trunk/compute_gradient_fluid.f90
seismo/2D/SPECFEM2D/trunk/constants.h
seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.csh
seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.f90
seismo/2D/SPECFEM2D/trunk/createnum_fast.f90
seismo/2D/SPECFEM2D/trunk/createnum_slow.f90
seismo/2D/SPECFEM2D/trunk/cree_image_PNM.f90
seismo/2D/SPECFEM2D/trunk/datim.f90
seismo/2D/SPECFEM2D/trunk/defarrays.f90
seismo/2D/SPECFEM2D/trunk/define_derivative_matrices.f90
seismo/2D/SPECFEM2D/trunk/define_shape_functions.f90
seismo/2D/SPECFEM2D/trunk/gll_library.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/maille_non_struct_2.f90
seismo/2D/SPECFEM2D/trunk/maille_non_struct_3.f90
seismo/2D/SPECFEM2D/trunk/meshfem2D.f90
seismo/2D/SPECFEM2D/trunk/plotgll.f90
seismo/2D/SPECFEM2D/trunk/plotpost.f90
seismo/2D/SPECFEM2D/trunk/positsource.f90
seismo/2D/SPECFEM2D/trunk/recompute_jacobian.f90
seismo/2D/SPECFEM2D/trunk/specfem2D.f90
seismo/2D/SPECFEM2D/trunk/write_seismograms.f90
Removed:
seismo/2D/SPECFEM2D/trunk/MAILLE90/
seismo/2D/SPECFEM2D/trunk/SPECFEM90/
Log:
Receivers can now be located anywhere, not only at grid points, in 2D code.
Also switched to same convention as in 3D code for naming Par_file,
now located in DATA, only one directory for mesher and solver,
and station file name follows same convention S001.AA.BHZ.semd
Added: seismo/2D/SPECFEM2D/trunk/DATA/CMTSOLUTION
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/CMTSOLUTION 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/DATA/CMTSOLUTION 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,13 @@
+ PDE 2000 01 01 01 01 01.00 0.0000 000.0000 10.0 4.5 4.5 Middle of Half Space
+event name: B00002
+time shift: 0.0000
+half duration: 0.0000
+latitude: 34.5000
+longitude: -117.5000
+depth: 30.0000
+Mrr: 0.000000e+00
+Mtt: 0.000000e+00
+Mpp: 0.000000e+00
+Mrt: 0.000000e+00
+Mrp: 0.000000e+00
+Mtp: 7.498942e+22
Added: seismo/2D/SPECFEM2D/trunk/DATA/Par_file
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/Par_file 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/DATA/Par_file 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,82 @@
+# ----------------------------------------------------------------
+#
+# This is the parameter file
+# Put variable names first and actual value after 34th column
+#
+# ----------------------------------------------------------------
+#
+# title of job, and file that contains interface data
+#
+title = Test Sinusoide
+interfacesfile = interface_sinus.dat
+#
+# geometry of the model (origin lower-left corner = 0,0) and mesh description
+#
+xmin = 0.d0 ! abscissa of left side of the model
+xmax = 4000.d0 ! abscissa of right side of the model
+nx = 80 ! number of elements along X
+ngnod = 4 ! noeuds de controle pour blocs (4 ou 9)
+initialfield = .false. ! use a plane wave as source or not
+readmodel = .false. ! read external earth model or not
+ELASTIC = .true. ! elastic or acoustic simulation
+TURN_ANISOTROPY_ON = .false. ! turn anisotropy on or off
+TURN_ATTENUATION_ON = .false. ! turn attenuation on or off
+#
+# absorbing boundaries parameters
+#
+absorbhaut = .false. ! absorbing boundary active or not
+absorbbas = .true.
+absorbgauche = .true.
+absorbdroite = .true.
+#
+# time step parameters
+#
+nt = 1400 ! nb total de pas de temps
+dt = 1.d-3 ! valeur du pas de temps
+#
+# source parameters
+#
+source_surf = .false. ! source dans le volume ou a la surface
+xs = 2000. ! source location x in meters
+zs = 1200. ! source location z in meters
+source_type = 1 ! force = 1 or explosion = 2
+time_function_type = 1 ! Ricker = 1, first derivative = 2, Gaussian = 3, Dirac = 4
+f0 = 10.0 ! dominant source frequency (Hz) if not Dirac
+angle = 0. ! angle of the source (for a force only)
+factor = 1.d4 ! amplification factor
+#
+# receiver line parameters
+#
+enreg_surf = .true. ! enregistrement volume ou surface
+sismostype = 1 ! record 1=displ 2=veloc 3=accel
+nrec = 101 ! number of receivers
+xdeb = 300. ! first receiver x in meters
+zdeb = 2200. ! first receiver z in meters
+xfin = 3700. ! last receiver x in meters
+zfin = 2200. ! last receiver z in meters
+anglerec = 0.d0 ! angle to rotate components at receivers
+#
+# display parameters
+#
+itaff = 100 ! display frequency in time steps
+vecttype = 1 ! display 1=displ 2=veloc 3=accel
+cutvect = 1. ! amplitude min en % pour vector plots
+meshvect = .true. ! display mesh on vector plots or not
+modelvect = .false. ! display velocity model on vector plots
+boundvect = .true. ! display boundary conditions on plots
+interpol = .true. ! interpolation of the display or not
+pointsdisp = 6 ! points for interpolation of display
+subsamp = 1 ! subsampling of color snapshots
+gnuplot = .false. ! generate a GNUPLOT file for the grid
+outputgrid = .false. ! save the grid in a text file or not
+#
+# velocity and density model (nx,nz)
+#
+nbmodels = 2 ! nb de modeles differents (0,rho,vp,vs,0,0)
+1 0 2700.d0 3000.d0 1732.051d0 0 0
+2 0 1800.d0 2000.d0 1100.845d0 0 0
+#3 0 2200.d0 2500.d0 1443.375d0 0 0
+nbzone = 2 ! nb of zones and model number for each
+1 80 1 40 1
+1 80 31 40 2
+#1 80 41 60 3
Added: seismo/2D/SPECFEM2D/trunk/DATA/Par_file_Paul_acoustic
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/Par_file_Paul_acoustic 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/DATA/Par_file_Paul_acoustic 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,82 @@
+# ----------------------------------------------------------------
+#
+# This is the parameter file
+# Put variable names first and actual value after 34th column
+#
+# ----------------------------------------------------------------
+#
+# title of job, and file that contains interface data
+#
+title = Test Sinusoide
+interfacesfile = interface_sinus.dat
+#
+# geometry of the model (origin lower-left corner = 0,0) and mesh description
+#
+xmin = 0.d0 ! abscissa of left side of the model
+xmax = 4000.d0 ! abscissa of right side of the model
+nx = 80 ! number of elements along X
+ngnod = 4 ! noeuds de controle pour blocs (4 ou 9)
+initialfield = .false. ! use a plane wave as source or not
+readmodel = .false. ! read external earth model or not
+ELASTIC = .false. ! elastic or acoustic simulation
+TURN_ANISOTROPY_ON = .false. ! turn anisotropy on or off
+TURN_ATTENUATION_ON = .false. ! turn attenuation on or off
+#
+# absorbing boundaries parameters
+#
+absorbhaut = .false. ! absorbing boundary active or not
+absorbbas = .true.
+absorbgauche = .true.
+absorbdroite = .true.
+#
+# time step parameters
+#
+nt = 1400 ! nb total de pas de temps
+dt = 1.d-3 ! valeur du pas de temps
+#
+# source parameters
+#
+source_surf = .false. ! source dans le volume ou a la surface
+xs = 2000. ! source location x in meters
+zs = 1200. ! source location z in meters
+source_type = 1 ! force = 1 or explosion = 2
+time_function_type = 2 ! Ricker = 1, first derivative = 2, Gaussian = 3, Dirac = 4
+f0 = 10.0 ! dominant source frequency (Hz) if not Dirac
+angle = 0. ! angle of the source (for a force only)
+factor = 1.d4 ! amplification factor
+#
+# receiver line parameters
+#
+enreg_surf = .false. ! enregistrement volume ou surface
+sismostype = 2 ! record 1=displ 2=veloc 3=accel
+nrec = 11 ! number of receivers
+xdeb = 300. ! first receiver x in meters
+zdeb = 1700. ! first receiver z in meters
+xfin = 3700. ! last receiver x in meters
+zfin = 1700. ! last receiver z in meters
+anglerec = 0.d0 ! angle to rotate components at receivers
+#
+# display parameters
+#
+itaff = 100 ! display frequency in time steps
+vecttype = 2 ! display 1=displ 2=veloc 3=accel
+cutvect = 1. ! amplitude min en % pour vector plots
+meshvect = .true. ! display mesh on vector plots or not
+modelvect = .false. ! display velocity model on vector plots
+boundvect = .true. ! display boundary conditions on plots
+interpol = .true. ! interpolation of the display or not
+pointsdisp = 6 ! points for interpolation of display
+subsamp = 1 ! subsampling of color snapshots
+gnuplot = .false. ! generate a GNUPLOT file for the grid
+outputgrid = .false. ! save the grid in a text file or not
+#
+# velocity and density model (nx,nz)
+#
+nbmodels = 2 ! nb de modeles differents (0,rho,vp,vs,0,0)
+1 0 2700.d0 3000.d0 0.d0 0 0
+2 0 1800.d0 2000.d0 0.d0 0 0
+#3 0 2200.d0 2500.d0 0.d0 0 0
+nbzone = 2 ! nb of zones and model number for each
+1 80 1 40 1
+1 80 31 40 2
+#1 80 41 60 3
Added: seismo/2D/SPECFEM2D/trunk/DATA/Par_file_Paul_elastic
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/Par_file_Paul_elastic 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/DATA/Par_file_Paul_elastic 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,82 @@
+# ----------------------------------------------------------------
+#
+# This is the parameter file
+# Put variable names first and actual value after 34th column
+#
+# ----------------------------------------------------------------
+#
+# title of job, and file that contains interface data
+#
+title = Test Sinusoide
+interfacesfile = interface_sinus.dat
+#
+# geometry of the model (origin lower-left corner = 0,0) and mesh description
+#
+xmin = 0.d0 ! abscissa of left side of the model
+xmax = 4000.d0 ! abscissa of right side of the model
+nx = 80 ! number of elements along X
+ngnod = 4 ! noeuds de controle pour blocs (4 ou 9)
+initialfield = .false. ! use a plane wave as source or not
+readmodel = .false. ! read external earth model or not
+ELASTIC = .true. ! elastic or acoustic simulation
+TURN_ANISOTROPY_ON = .false. ! turn anisotropy on or off
+TURN_ATTENUATION_ON = .false. ! turn attenuation on or off
+#
+# absorbing boundaries parameters
+#
+absorbhaut = .false. ! absorbing boundary active or not
+absorbbas = .true.
+absorbgauche = .true.
+absorbdroite = .true.
+#
+# time step parameters
+#
+nt = 1400 ! nb total de pas de temps
+dt = 1.d-3 ! valeur du pas de temps
+#
+# source parameters
+#
+source_surf = .false. ! source dans le volume ou a la surface
+xs = 2000. ! source location x in meters
+zs = 1200. ! source location z in meters
+source_type = 1 ! force = 1 or explosion = 2
+time_function_type = 1 ! Ricker = 1, first derivative = 2, Gaussian = 3, Dirac = 4
+f0 = 10.0 ! dominant source frequency (Hz) if not Dirac
+angle = 0. ! angle of the source (for a force only)
+factor = 1.d4 ! amplification factor
+#
+# receiver line parameters
+#
+enreg_surf = .true. ! enregistrement volume ou surface
+sismostype = 1 ! record 1=displ 2=veloc 3=accel
+nrec = 101 ! number of receivers
+xdeb = 300. ! first receiver x in meters
+zdeb = 2200. ! first receiver z in meters
+xfin = 3700. ! last receiver x in meters
+zfin = 2200. ! last receiver z in meters
+anglerec = 0.d0 ! angle to rotate components at receivers
+#
+# display parameters
+#
+itaff = 100 ! display frequency in time steps
+vecttype = 1 ! display 1=displ 2=veloc 3=accel
+cutvect = 1. ! amplitude min en % pour vector plots
+meshvect = .true. ! display mesh on vector plots or not
+modelvect = .false. ! display velocity model on vector plots
+boundvect = .true. ! display boundary conditions on plots
+interpol = .true. ! interpolation of the display or not
+pointsdisp = 6 ! points for interpolation of display
+subsamp = 1 ! subsampling of color snapshots
+gnuplot = .false. ! generate a GNUPLOT file for the grid
+outputgrid = .false. ! save the grid in a text file or not
+#
+# velocity and density model (nx,nz)
+#
+nbmodels = 2 ! nb de modeles differents (0,rho,vp,vs,0,0)
+1 0 2700.d0 3000.d0 1732.051d0 0 0
+2 0 1800.d0 2000.d0 1100.845d0 0 0
+#3 0 2200.d0 2500.d0 1443.375d0 0 0
+nbzone = 2 ! nb of zones and model number for each
+1 80 1 40 1
+1 80 31 40 2
+#1 80 41 60 3
Added: seismo/2D/SPECFEM2D/trunk/DATA/Par_file_cours_M2_UPPA
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/Par_file_cours_M2_UPPA 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/DATA/Par_file_cours_M2_UPPA 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,82 @@
+# ----------------------------------------------------------------
+#
+# This is the parameter file
+# Put variable names first and actual value after 34th column
+#
+# ----------------------------------------------------------------
+#
+# title of job, and file that contains interface data
+#
+title = Test pour cours M2 UPPA
+interfacesfile = interfaces_cours_M2_UPPA_curved.dat
+#
+# geometry of the model (origin lower-left corner = 0,0) and mesh description
+#
+xmin = 0.d0 ! abscissa of left side of the model
+xmax = 4000.d0 ! abscissa of right side of the model
+nx = 80 ! number of elements along X
+ngnod = 4 ! noeuds de controle pour blocs (4 ou 9)
+initialfield = .false. ! use a plane wave as source or not
+readmodel = .false. ! read external earth model or not
+ELASTIC = .true. ! elastic or acoustic simulation
+TURN_ANISOTROPY_ON = .false. ! turn anisotropy on or off
+TURN_ATTENUATION_ON = .false. ! turn attenuation on or off
+#
+# absorbing boundaries parameters
+#
+absorbhaut = .false. ! absorbing boundary active or not
+absorbbas = .true.
+absorbgauche = .true.
+absorbdroite = .true.
+#
+# time step parameters
+#
+nt = 1600 ! nb total de pas de temps
+dt = 1.d-3 ! valeur du pas de temps
+#
+# source parameters
+#
+source_surf = .true. ! source dans le volume ou a la surface
+xs = 2000. ! source location x in meters
+zs = 1500. ! source location z in meters
+source_type = 1 ! force = 1 or explosion = 2
+time_function_type = 1 ! Ricker = 1, first derivative = 2, Gaussian = 3, Dirac = 4
+f0 = 10.0 ! dominant source frequency (Hz) if not Dirac
+angle = 0. ! angle of the source (for a force only)
+factor = 1.d10 ! amplification factor
+#
+# receiver line parameters
+#
+enreg_surf = .true. ! enregistrement volume ou surface
+sismostype = 1 ! record 1=displ 2=veloc 3=accel
+nrec = 11 ! number of receivers
+xdeb = 300. ! first receiver x in meters
+zdeb = 2200. ! first receiver z in meters
+xfin = 3700. ! last receiver x in meters
+zfin = 2200. ! last receiver z in meters
+anglerec = 0.d0 ! angle to rotate components at receivers
+#
+# display parameters
+#
+itaff = 100 ! display frequency in time steps
+vecttype = 1 ! display 1=displ 2=veloc 3=accel
+cutvect = 1. ! amplitude min en % pour vector plots
+meshvect = .true. ! display mesh on vector plots or not
+modelvect = .false. ! display velocity model on vector plots
+boundvect = .true. ! display boundary conditions on plots
+interpol = .true. ! interpolation of the display or not
+pointsdisp = 6 ! points for interpolation of display
+subsamp = 1 ! subsampling of color snapshots
+gnuplot = .false. ! generate a GNUPLOT file for the grid
+outputgrid = .false. ! save the grid in a text file or not
+#
+# velocity and density model (nx,nz)
+#
+nbmodels = 3 ! nb de modeles differents (0,rho,vp,vs,0,0)
+1 0 2700.d0 3000.d0 1732.051d0 0 0
+2 0 2500.d0 2700.d0 1558.845d0 0 0
+3 0 2200.d0 2500.d0 1443.375d0 0 0
+nbzone = 3 ! nb of zones and model number for each
+1 80 1 20 1
+1 80 21 40 2
+1 80 41 60 3
Added: seismo/2D/SPECFEM2D/trunk/DATA/STATIONS
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/STATIONS 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/DATA/STATIONS 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,102 @@
+ 101
+S001 AA 300.0000000 2000.0000000 0.0 0.0
+S002 AA 334.0000000 2000.0000000 0.0 0.0
+S003 AA 368.0000000 2000.0000000 0.0 0.0
+S004 AA 402.0000000 2000.0000000 0.0 0.0
+S005 AA 436.0000000 2000.0000000 0.0 0.0
+S006 AA 470.0000000 2000.0000000 0.0 0.0
+S007 AA 504.0000000 2000.0000000 0.0 0.0
+S008 AA 538.0000000 2000.0000000 0.0 0.0
+S009 AA 572.0000000 2000.0000000 0.0 0.0
+S010 AA 606.0000000 2000.0000000 0.0 0.0
+S011 AA 640.0000000 2000.0000000 0.0 0.0
+S012 AA 674.0000000 2000.0000000 0.0 0.0
+S013 AA 708.0000000 2000.0000000 0.0 0.0
+S014 AA 742.0000000 2000.0000000 0.0 0.0
+S015 AA 776.0000000 2000.0000000 0.0 0.0
+S016 AA 810.0000000 2000.0000000 0.0 0.0
+S017 AA 844.0000000 2000.0000000 0.0 0.0
+S018 AA 878.0000000 2000.0000000 0.0 0.0
+S019 AA 912.0000000 2000.0000000 0.0 0.0
+S020 AA 946.0000000 2000.0000000 0.0 0.0
+S021 AA 980.0000000 2000.0000000 0.0 0.0
+S022 AA 1014.0000000 2000.0000000 0.0 0.0
+S023 AA 1048.0000000 2000.0000000 0.0 0.0
+S024 AA 1082.0000000 2000.0000000 0.0 0.0
+S025 AA 1116.0000000 2000.0000000 0.0 0.0
+S026 AA 1150.0000000 2000.0000000 0.0 0.0
+S027 AA 1184.0000000 2000.0000000 0.0 0.0
+S028 AA 1218.0000000 2000.0000000 0.0 0.0
+S029 AA 1252.0000000 2000.0000000 0.0 0.0
+S030 AA 1286.0000000 2000.0000000 0.0 0.0
+S031 AA 1320.0000000 2000.0000000 0.0 0.0
+S032 AA 1354.0000000 2000.0000000 0.0 0.0
+S033 AA 1388.0000000 2000.0000000 0.0 0.0
+S034 AA 1422.0000000 2000.0000000 0.0 0.0
+S035 AA 1456.0000000 2000.0000000 0.0 0.0
+S036 AA 1490.0000000 2000.0000000 0.0 0.0
+S037 AA 1524.0000000 2000.0000000 0.0 0.0
+S038 AA 1558.0000000 2000.0000000 0.0 0.0
+S039 AA 1592.0000000 2000.0000000 0.0 0.0
+S040 AA 1626.0000000 2000.0000000 0.0 0.0
+S041 AA 1660.0000000 2000.0000000 0.0 0.0
+S042 AA 1694.0000000 2000.0000000 0.0 0.0
+S043 AA 1728.0000000 2000.0000000 0.0 0.0
+S044 AA 1762.0000000 2000.0000000 0.0 0.0
+S045 AA 1796.0000000 2000.0000000 0.0 0.0
+S046 AA 1830.0000000 2000.0000000 0.0 0.0
+S047 AA 1864.0000000 2000.0000000 0.0 0.0
+S048 AA 1898.0000000 2000.0000000 0.0 0.0
+S049 AA 1932.0000000 2000.0000000 0.0 0.0
+S050 AA 1966.0000000 2000.0000000 0.0 0.0
+S051 AA 2000.0000000 2000.0000000 0.0 0.0
+S052 AA 2034.0000000 2000.0000000 0.0 0.0
+S053 AA 2068.0000000 2000.0000000 0.0 0.0
+S054 AA 2102.0000000 2000.0000000 0.0 0.0
+S055 AA 2136.0000000 2000.0000000 0.0 0.0
+S056 AA 2170.0000000 2000.0000000 0.0 0.0
+S057 AA 2204.0000000 2000.0000000 0.0 0.0
+S058 AA 2238.0000000 2000.0000000 0.0 0.0
+S059 AA 2272.0000000 2000.0000000 0.0 0.0
+S060 AA 2306.0000000 2000.0000000 0.0 0.0
+S061 AA 2340.0000000 2000.0000000 0.0 0.0
+S062 AA 2374.0000000 2000.0000000 0.0 0.0
+S063 AA 2408.0000000 2000.0000000 0.0 0.0
+S064 AA 2442.0000000 2000.0000000 0.0 0.0
+S065 AA 2476.0000000 2000.0000000 0.0 0.0
+S066 AA 2510.0000000 2000.0000000 0.0 0.0
+S067 AA 2544.0000000 2000.0000000 0.0 0.0
+S068 AA 2578.0000000 2000.0000000 0.0 0.0
+S069 AA 2612.0000000 2000.0000000 0.0 0.0
+S070 AA 2646.0000000 2000.0000000 0.0 0.0
+S071 AA 2680.0000000 2000.0000000 0.0 0.0
+S072 AA 2714.0000000 2000.0000000 0.0 0.0
+S073 AA 2748.0000000 2000.0000000 0.0 0.0
+S074 AA 2782.0000000 2000.0000000 0.0 0.0
+S075 AA 2816.0000000 2000.0000000 0.0 0.0
+S076 AA 2850.0000000 2000.0000000 0.0 0.0
+S077 AA 2884.0000000 2000.0000000 0.0 0.0
+S078 AA 2918.0000000 2000.0000000 0.0 0.0
+S079 AA 2952.0000000 2000.0000000 0.0 0.0
+S080 AA 2986.0000000 2000.0000000 0.0 0.0
+S081 AA 3020.0000000 2000.0000000 0.0 0.0
+S082 AA 3054.0000000 2000.0000000 0.0 0.0
+S083 AA 3088.0000000 2000.0000000 0.0 0.0
+S084 AA 3122.0000000 2000.0000000 0.0 0.0
+S085 AA 3156.0000000 2000.0000000 0.0 0.0
+S086 AA 3190.0000000 2000.0000000 0.0 0.0
+S087 AA 3224.0000000 2000.0000000 0.0 0.0
+S088 AA 3258.0000000 2000.0000000 0.0 0.0
+S089 AA 3292.0000000 2000.0000000 0.0 0.0
+S090 AA 3326.0000000 2000.0000000 0.0 0.0
+S091 AA 3360.0000000 2000.0000000 0.0 0.0
+S092 AA 3394.0000000 2000.0000000 0.0 0.0
+S093 AA 3428.0000000 2000.0000000 0.0 0.0
+S094 AA 3462.0000000 2000.0000000 0.0 0.0
+S095 AA 3496.0000000 2000.0000000 0.0 0.0
+S096 AA 3530.0000000 2000.0000000 0.0 0.0
+S097 AA 3564.0000000 2000.0000000 0.0 0.0
+S098 AA 3598.0000000 2000.0000000 0.0 0.0
+S099 AA 3632.0000000 2000.0000000 0.0 0.0
+S100 AA 3666.0000000 2000.0000000 0.0 0.0
+S101 AA 3700.0000000 2000.0000000 0.0 0.0
Added: seismo/2D/SPECFEM2D/trunk/DATA/interf_paco.dat
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/interf_paco.dat 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/DATA/interf_paco.dat 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,212 @@
+ 211
+ 0. 4000.0000000000
+ 33.333333333333 4000.0000000000
+ 66.666666666667 4000.0000000000
+ 100.000000000000 4000.0000000000
+ 133.33333333333 4000.0000000000
+ 166.66666666667 4000.0000000000
+ 200.00000000000 4000.0000000000
+ 233.33333333333 4000.0000000000
+ 266.66666666667 4000.0000000000
+ 300.00000000000 4000.0000000000
+ 333.33333333333 4000.0000000000
+ 366.66666666667 4000.0000000000
+ 400.00000000000 4000.0000000000
+ 433.33333333333 4000.0000000000
+ 466.66666666667 4000.0000000000
+ 500.00000000000 4000.0000000000
+ 533.33333333333 4000.0000000000
+ 566.66666666667 4000.0000000000
+ 600.00000000000 4000.0000000000
+ 633.33333333333 4000.0000000000
+ 666.66666666667 4000.0000000000
+ 700.00000000000 4000.0000000000
+ 733.33333333333 4000.0000000000
+ 766.66666666667 4000.0000000000
+ 800.00000000000 4000.0000000000
+ 833.33333333333 4000.0000000000
+ 866.66666666667 4000.0000000000
+ 900.00000000000 4000.0000000000
+ 933.33333333333 4000.0000000000
+ 966.66666666667 4000.0000000000
+ 1000.00000000000 4000.0000000000
+ 1033.3333333333 4000.0000000000
+ 1066.6666666667 4000.0000000000
+ 1100.0000000000 4000.0000000000
+ 1133.3333333333 4000.0000000000
+ 1166.6666666667 4000.0000000000
+ 1200.0000000000 4000.0000000000
+ 1233.3333333333 4000.0000000000
+ 1266.6666666667 4000.0000000000
+ 1300.0000000000 4000.0000000000
+ 1333.3333333333 4000.0000000000
+ 1366.6666666667 4000.0000000000
+ 1400.0000000000 4000.0000000000
+ 1433.3333333333 4000.0000000000
+ 1466.6666666667 4000.0000000000
+ 1500.0000000000 4000.0000000000
+ 1533.3333333333 4000.0000000000
+ 1566.6666666667 4000.0000000000
+ 1600.0000000000 4000.0000000000
+ 1633.3333333333 4000.0000000000
+ 1666.6666666667 4000.0000000000
+ 1700.0000000000 4000.0000000000
+ 1733.3333333333 4000.0000000000
+ 1766.6666666667 4000.0000000000
+ 1800.0000000000 4000.0000000000
+ 1833.3333333333 4000.0000000000
+ 1866.6666666667 4000.0000000000
+ 1900.0000000000 4000.0000000000
+ 1933.3333333333 4000.0000000000
+ 1966.6666666667 4000.0000000000
+ 2000.0000000000 4000.0000000000
+ 2033.3333333333 4000.0000000000
+ 2066.6666666667 4000.0000000000
+ 2100.0000000000 4000.0000000000
+ 2133.3333333333 4000.0000000000
+ 2166.6666666667 4000.0000000000
+ 2200.0000000000 4000.0000000000
+ 2233.3333333333 4000.0000000000
+ 2266.6666666667 4000.0000000000
+ 2300.0000000000 4000.0000000000
+ 2333.3333333333 4000.0000000000
+ 2366.6666666667 4000.0000000000
+ 2400.0000000000 4000.0000000000
+ 2433.3333333333 4000.0000000000
+ 2466.6666666667 4000.0000000000
+ 2500.0000000000 4000.0000000000
+ 2533.3333333333 3998.6304738452
+ 2566.6666666667 3994.5369001959
+ 2600.0000000000 3987.7641291015
+ 2633.3333333333 3978.3863644593
+ 2666.6666666667 3966.5063510209
+ 2700.0000000000 3952.2542486992
+ 2733.3333333333 3935.7862065095
+ 2766.6666666667 3917.2826517676
+ 2800.0000000000 3896.9463132909
+ 2833.3333333333 3875.0000002591
+ 2866.6666666667 3851.6841610696
+ 2900.0000000000 3827.2542489351
+ 2933.3333333333 3801.9779230848
+ 2966.6666666667 3776.1321162334
+ 3000.0000000000 3750.0000004487
+ 3033.3333333333 3723.8678846591
+ 3066.6666666667 3698.0220777930
+ 3100.0000000000 3672.7457519184
+ 3133.3333333333 3648.3158397503
+ 3166.6666666667 3625.0000005181
+ 3200.0000000000 3603.0536874351
+ 3233.3333333333 3582.7173488994
+ 3266.6666666667 3564.2137940910
+ 3300.0000000000 3547.7457518283
+ 3333.3333333333 3533.4936494278
+ 3366.6666666667 3521.6136359057
+ 3400.0000000000 3512.2358711758
+ 3433.3333333333 3505.4630999907
+ 3466.6666666667 3501.3695262486
+ 3500.0000000000 3500.0000000000
+ 3533.3333333333 3501.3695260610
+ 3566.6666666667 3505.4630996175
+ 3600.0000000000 3512.2358706212
+ 3633.3333333333 3521.6136351757
+ 3666.6666666667 3533.4936485304
+ 3700.0000000000 3547.7457507733
+ 3733.3333333333 3564.2137928900
+ 3766.6666666667 3582.7173475655
+ 3800.0000000000 3603.0536859830
+ 3833.3333333333 3624.9999989637
+ 3866.6666666667 3648.3158381106
+ 3900.0000000000 3672.7457502113
+ 3933.3333333333 3698.0220760373
+ 3966.6666666667 3723.8678828740
+ 4000.0000000000 3749.9999986538
+ 4033.3333333333 3776.1321144484
+ 4066.6666666667 3801.9779213292
+ 4100.0000000000 3827.2542472281
+ 4133.3333333333 3851.6841594298
+ 4166.6666666667 3874.9999987046
+ 4200.0000000000 3896.9463118388
+ 4233.3333333333 3917.2826504337
+ 4266.6666666667 3935.7862053084
+ 4300.0000000000 3952.2542476442
+ 4333.3333333333 3966.5063501234
+ 4366.6666666667 3978.3863637293
+ 4400.0000000000 3987.7641285469
+ 4433.3333333333 3994.5368998227
+ 4466.6666666667 3998.6304736576
+ 4500.0000000000 4000.0000000000
+ 4533.3333333333 4000.0000000000
+ 4566.6666666667 4000.0000000000
+ 4600.0000000000 4000.0000000000
+ 4633.3333333333 4000.0000000000
+ 4666.6666666667 4000.0000000000
+ 4700.0000000000 4000.0000000000
+ 4733.3333333333 4000.0000000000
+ 4766.6666666667 4000.0000000000
+ 4800.0000000000 4000.0000000000
+ 4833.3333333333 4000.0000000000
+ 4866.6666666667 4000.0000000000
+ 4900.0000000000 4000.0000000000
+ 4933.3333333333 4000.0000000000
+ 4966.6666666667 4000.0000000000
+ 5000.0000000000 4000.0000000000
+ 5033.3333333333 4000.0000000000
+ 5066.6666666667 4000.0000000000
+ 5100.0000000000 4000.0000000000
+ 5133.3333333333 4000.0000000000
+ 5166.6666666667 4000.0000000000
+ 5200.0000000000 4000.0000000000
+ 5233.3333333333 4000.0000000000
+ 5266.6666666667 4000.0000000000
+ 5300.0000000000 4000.0000000000
+ 5333.3333333333 4000.0000000000
+ 5366.6666666667 4000.0000000000
+ 5400.0000000000 4000.0000000000
+ 5433.3333333333 4000.0000000000
+ 5466.6666666667 4000.0000000000
+ 5500.0000000000 4000.0000000000
+ 5533.3333333333 4000.0000000000
+ 5566.6666666667 4000.0000000000
+ 5600.0000000000 4000.0000000000
+ 5633.3333333333 4000.0000000000
+ 5666.6666666667 4000.0000000000
+ 5700.0000000000 4000.0000000000
+ 5733.3333333333 4000.0000000000
+ 5766.6666666667 4000.0000000000
+ 5800.0000000000 4000.0000000000
+ 5833.3333333333 4000.0000000000
+ 5866.6666666667 4000.0000000000
+ 5900.0000000000 4000.0000000000
+ 5933.3333333333 4000.0000000000
+ 5966.6666666667 4000.0000000000
+ 6000.0000000000 4000.0000000000
+ 6033.3333333333 4000.0000000000
+ 6066.6666666667 4000.0000000000
+ 6100.0000000000 4000.0000000000
+ 6133.3333333333 4000.0000000000
+ 6166.6666666667 4000.0000000000
+ 6200.0000000000 4000.0000000000
+ 6233.3333333333 4000.0000000000
+ 6266.6666666667 4000.0000000000
+ 6300.0000000000 4000.0000000000
+ 6333.3333333333 4000.0000000000
+ 6366.6666666667 4000.0000000000
+ 6400.0000000000 4000.0000000000
+ 6433.3333333333 4000.0000000000
+ 6466.6666666667 4000.0000000000
+ 6500.0000000000 4000.0000000000
+ 6533.3333333333 4000.0000000000
+ 6566.6666666667 4000.0000000000
+ 6600.0000000000 4000.0000000000
+ 6633.3333333333 4000.0000000000
+ 6666.6666666667 4000.0000000000
+ 6700.0000000000 4000.0000000000
+ 6733.3333333333 4000.0000000000
+ 6766.6666666667 4000.0000000000
+ 6800.0000000000 4000.0000000000
+ 6833.3333333333 4000.0000000000
+ 6866.6666666667 4000.0000000000
+ 6900.0000000000 4000.0000000000
+ 6933.3333333333 4000.0000000000
+ 6966.6666666667 4000.0000000000
+ 7000.0000000000 4000.0000000000
Added: seismo/2D/SPECFEM2D/trunk/DATA/interface_sinus.dat
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/interface_sinus.dat 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/DATA/interface_sinus.dat 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,75 @@
+#
+# Number of interfaces
+#
+3
+#
+#
+#
+#
+# Interface 1 (Bottom of the mesh)
+#
+2
+0 0
+4000 0
+#
+# Interface 2
+#
+41
+0 1500
+100 1507
+200 1510
+300 1507
+400 1500
+500 1492
+600 1490
+700 1492
+800 1500
+900 1507
+1000 1510
+1100 1507
+1200 1500
+1300 1492
+1400 1490
+1500 1492
+1600 1500
+1700 1507
+1800 1510
+1900 1507
+2000 1500
+2100 1492
+2200 1490
+2300 1492
+2400 1500
+2500 1507
+2600 1510
+2700 1507
+2800 1500
+2900 1492
+3000 1490
+3100 1492
+3200 1500
+3300 1507
+3400 1510
+3500 1507
+3600 1500
+3700 1492
+3800 1490
+3900 1492
+4000 1500
+#
+# Interface 3
+#
+2
+0 2000
+4000 2000
+#
+#Number of spectral elements
+#
+#
+#
+#
+30
+#
+#
+#
+10
Added: seismo/2D/SPECFEM2D/trunk/DATA/interfaces_cours_M2_UPPA_curved.dat
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/interfaces_cours_M2_UPPA_curved.dat 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/DATA/interfaces_cours_M2_UPPA_curved.dat 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,48 @@
+# number of interfaces
+ 4
+#
+# for each interface below, we give the number of points and then x,y for each point
+#
+# interface number 1 (bottom of the mesh)
+ 2
+ 0 0
+ 5000 0
+# interface number 2
+ 7
+ 0 1000
+ 1500 1100
+ 2000 1180
+ 2500 1200
+ 3000 1220
+ 3500 1170
+ 5000 1100
+# interface number 3
+ 9
+ 0 2000
+ 500 2000
+ 1000 1900
+ 1500 1847
+ 2000 1900
+ 2500 2000
+ 3000 2090
+ 3500 2020
+ 5000 2000
+# interface number 4 (topography, top of the mesh)
+ 8
+ 0 3000
+ 500 3000
+ 1000 3100
+ 1500 3350
+ 2000 3250
+ 2500 3180
+ 3000 3090
+ 5000 3000
+#
+# for each layer, we give the number of spectral elements in the vertical direction
+#
+# layer number 1 (bottom layer)
+ 20
+# layer number 2
+ 20
+# layer number 3 (top layer)
+ 20
Added: seismo/2D/SPECFEM2D/trunk/DATA/interfaces_cours_M2_UPPA_flat.dat
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/interfaces_cours_M2_UPPA_flat.dat 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/DATA/interfaces_cours_M2_UPPA_flat.dat 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,46 @@
+#
+# number of interfaces
+#
+ 4
+#
+# for each interface below, we give the number of points and then x,y for each point
+#
+#
+# interface number 1 (bottom of the mesh)
+#
+ 2
+ 0 0
+ 5000 0
+#
+# interface number 2
+#
+ 2
+ 0 1000
+ 5000 1000
+#
+# interface number 3
+#
+ 2
+ 0 2000
+ 5000 2000
+#
+# interface number 4 (topography, top of the mesh)
+#
+ 2
+ 0 3000
+ 5000 3000
+#
+# for each layer, we give the number of spectral elements in the vertical direction
+#
+#
+# layer number 1 (bottom layer)
+#
+ 20
+#
+# layer number 2
+#
+ 20
+#
+# layer number 3 (top layer)
+#
+ 20
Added: seismo/2D/SPECFEM2D/trunk/DATA/profilx.dat
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/profilx.dat 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/DATA/profilx.dat 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,215 @@
+-4.030060
+-4.031510
+-4.027550
+-4.022690
+-4.017840
+-4.011910
+-3.999230
+-3.972270
+-3.940420
+-3.909460
+-3.885800
+-3.868120
+-3.853440
+-3.840630
+-3.830040
+-3.818850
+-3.804520
+-3.790030
+-3.776320
+-3.765340
+-3.755920
+-3.746830
+-3.735490
+-3.721820
+-3.703930
+-3.679520
+-3.650700
+-3.620200
+-3.591410
+-3.568040
+-3.547570
+-3.528300
+-3.507120
+-3.485880
+-3.468120
+-3.446460
+-3.420720
+-3.390030
+-3.353750
+-3.313270
+-3.264390
+-3.214030
+-3.179940
+-3.155080
+-3.132110
+-3.106450
+-3.075090
+-3.038830
+-2.991240
+-2.916530
+-2.815720
+-2.748110
+-2.712470
+-2.670830
+-2.618150
+-2.555080
+-2.484160
+-2.405320
+-2.321900
+-2.229520
+-2.133560
+-2.070170
+-2.027820
+-1.974430
+-1.907660
+-1.851900
+-1.790190
+-1.724810
+-1.662320
+-1.613210
+-1.567500
+-1.532530
+-1.499660
+-1.420860
+-1.326870
+-1.238010
+-1.149630
+-1.055670
+-0.951941
+-0.830088
+-0.695442
+-0.535123
+-0.303787
+-0.066964
+0.137585
+0.292947
+0.427345
+0.504895
+0.548948
+0.611893
+0.669241
+0.731076
+0.784069
+0.862715
+0.908088
+0.989800
+1.074750
+1.125830
+1.155250
+1.142880
+1.068660
+0.966157
+1.106490
+1.229600
+1.452710
+1.620460
+1.795150
+1.775980
+1.694660
+1.678880
+1.661540
+1.600500
+1.536210
+1.454460
+1.203100
+0.999440
+0.972028
+0.935924
+0.995477
+1.063760
+1.098300
+1.056350
+0.986176
+0.855505
+0.689433
+0.529934
+0.397784
+0.317342
+0.222705
+0.117320
+0.028807
+-0.040407
+-0.118587
+-0.326905
+-0.574415
+-0.741248
+-0.887590
+-1.010380
+-1.087830
+-1.108840
+-1.160430
+-1.209690
+-1.264010
+-1.319100
+-1.348980
+-1.404960
+-1.485740
+-1.575370
+-1.662450
+-1.738790
+-1.798140
+-1.850290
+-1.905520
+-1.951300
+-1.995390
+-2.063230
+-2.151310
+-2.217030
+-2.278450
+-2.333810
+-2.384270
+-2.421330
+-2.443130
+-2.465170
+-2.567050
+-2.690890
+-2.770720
+-2.838250
+-2.898530
+-2.956700
+-3.026270
+-3.102020
+-3.173380
+-3.233160
+-3.285530
+-3.338610
+-3.390250
+-3.433800
+-3.482320
+-3.537380
+-3.588740
+-3.628460
+-3.662240
+-3.688980
+-3.709740
+-3.732810
+-3.750350
+-3.772050
+-3.797530
+-3.827180
+-3.859440
+-3.890500
+-3.918430
+-3.944920
+-3.968160
+-3.987850
+-4.002890
+-4.012180
+-4.014820
+-4.016240
+-4.021080
+-4.025060
+-4.027960
+-4.030390
+-4.031410
+-4.032690
+-4.034570
+-4.035590
+-4.036420
+-4.037270
+-4.037550
+-4.016490
+-4.008760
+-4.007300
+-4.006200
Added: seismo/2D/SPECFEM2D/trunk/DATA/profily.dat
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/profily.dat 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/DATA/profily.dat 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,209 @@
+-4.042630
+-4.033770
+-4.024570
+-4.031010
+-4.027090
+-4.011370
+-3.989330
+-3.963060
+-3.929730
+-3.893400
+-3.854910
+-3.807280
+-3.764700
+-3.718700
+-3.667760
+-3.619570
+-3.579390
+-3.529760
+-3.477630
+-3.427720
+-3.383820
+-3.346060
+-3.312440
+-3.281950
+-3.252910
+-3.222660
+-3.189850
+-3.153580
+-3.113840
+-3.073560
+-3.036520
+-2.994700
+-2.946600
+-2.906230
+-2.856750
+-2.801230
+-2.751650
+-2.709890
+-2.593630
+-2.501410
+-2.339970
+-2.219030
+-2.157610
+-2.126910
+-2.081700
+-2.033360
+-1.993200
+-1.959890
+-1.920950
+-1.885440
+-1.849060
+-1.795820
+-1.723950
+-1.624180
+-1.500000
+-1.379030
+-1.266730
+-1.161710
+-1.064370
+-0.991573
+-0.971158
+-0.935858
+-0.900854
+-0.874644
+-0.842509
+-0.808727
+-0.789044
+-0.797708
+-0.768248
+-0.756078
+-0.738104
+-0.756372
+-0.775592
+-0.795957
+-0.787438
+-0.705082
+-0.595518
+-0.438898
+-0.292028
+-0.145967
+-0.062730
+0.042711
+0.270900
+0.520289
+0.726283
+0.910875
+1.135880
+1.376630
+1.592740
+1.757490
+1.894770
+2.043840
+2.106480
+2.091720
+1.818020
+1.200320
+0.943632
+0.864765
+0.849034
+0.953888
+1.012090
+1.158530
+1.759700
+1.777570
+1.252260
+1.043510
+1.229600
+1.496690
+1.515210
+1.522500
+1.522040
+1.505200
+1.497920
+1.479140
+1.447090
+1.430400
+1.462890
+1.560170
+1.666450
+1.695220
+1.675090
+1.617180
+1.532760
+1.426300
+1.375350
+1.198940
+0.876019
+0.921095
+0.998579
+0.847144
+0.712094
+0.580680
+0.459470
+0.335168
+0.179500
+0.065837
+-0.008686
+-0.125625
+-0.407411
+-0.779719
+-1.215620
+-1.613050
+-1.707880
+-1.708050
+-1.734230
+-1.753980
+-1.773940
+-1.796890
+-1.822940
+-1.854070
+-1.880990
+-1.901660
+-1.965350
+-1.995410
+-1.941710
+-1.898150
+-1.983790
+-2.167880
+-2.287980
+-2.395880
+-2.460820
+-2.487850
+-2.504990
+-2.499650
+-2.511300
+-2.511300
+-2.551220
+-2.608210
+-2.644140
+-2.692670
+-2.720570
+-2.735400
+-2.747100
+-2.788430
+-2.834740
+-2.886570
+-2.951890
+-3.016690
+-3.075140
+-3.116640
+-3.156450
+-3.207550
+-3.258550
+-3.308610
+-3.356020
+-3.398640
+-3.437490
+-3.477580
+-3.513470
+-3.544880
+-3.568640
+-3.600160
+-3.632250
+-3.665310
+-3.697350
+-3.729730
+-3.763660
+-3.795090
+-3.823330
+-3.854270
+-3.883290
+-3.908390
+-3.931510
+-3.955920
+-3.977590
+-3.992900
+-4.004930
+-4.014750
+-4.025040
Added: seismo/2D/SPECFEM2D/trunk/DATA/topo_cours_M2_UPPA_curved.dat
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/topo_cours_M2_UPPA_curved.dat 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/DATA/topo_cours_M2_UPPA_curved.dat 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,10 @@
+9
+0 3000
+500 3000
+1000 3100
+1500 3400
+2000 3300
+2500 3200
+3000 3100
+3500 3000
+5000 3000
Added: seismo/2D/SPECFEM2D/trunk/DATA/topo_rouen_aniso.dat
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/topo_rouen_aniso.dat 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/DATA/topo_rouen_aniso.dat 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,3 @@
+2
+0 0.06d0
+1 0.06d0
Added: seismo/2D/SPECFEM2D/trunk/DATA/topoarticle.dat
===================================================================
--- seismo/2D/SPECFEM2D/trunk/DATA/topoarticle.dat 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/DATA/topoarticle.dat 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,210 @@
+ 209
+ 0. 1741.09
+ 12.0192 1743.55
+ 24.0385 1746.09
+ 36.0577 1748.72
+ 48.0769 1751.41
+ 60.0962 1754.16
+ 72.1154 1756.95
+ 84.1346 1759.79
+ 96.1538 1762.66
+ 108.173 1765.56
+ 120.192 1768.47
+ 132.212 1771.38
+ 144.231 1774.30
+ 156.250 1777.21
+ 168.269 1780.11
+ 180.288 1782.99
+ 192.308 1785.85
+ 204.327 1788.68
+ 216.346 1791.46
+ 228.365 1794.20
+ 240.385 1796.89
+ 252.404 1799.52
+ 264.423 1802.09
+ 276.442 1804.60
+ 288.462 1807.02
+ 300.481 1809.37
+ 312.500 1811.63
+ 324.519 1813.80
+ 336.538 1815.90
+ 348.558 1817.91
+ 360.577 1819.86
+ 372.596 1821.73
+ 384.615 1823.53
+ 396.635 1825.27
+ 408.654 1826.95
+ 420.673 1828.58
+ 432.692 1830.19
+ 444.712 1831.78
+ 456.731 1833.38
+ 468.750 1835.00
+ 480.769 1836.67
+ 492.788 1838.40
+ 504.808 1840.21
+ 516.827 1842.10
+ 528.846 1844.02
+ 540.865 1845.95
+ 552.885 1847.86
+ 564.904 1849.70
+ 576.923 1851.44
+ 588.942 1853.05
+ 600.962 1854.49
+ 612.981 1855.74
+ 625.000 1856.81
+ 637.019 1857.72
+ 649.038 1858.49
+ 661.058 1859.13
+ 673.077 1859.68
+ 685.096 1860.15
+ 697.115 1860.56
+ 709.135 1860.92
+ 721.154 1861.22
+ 733.173 1861.42
+ 745.192 1861.49
+ 757.212 1861.39
+ 769.231 1861.09
+ 781.250 1860.56
+ 793.269 1859.75
+ 805.288 1858.64
+ 817.308 1857.17
+ 829.327 1855.28
+ 841.346 1852.89
+ 853.365 1849.93
+ 865.385 1846.34
+ 877.404 1842.04
+ 889.423 1836.97
+ 901.442 1831.04
+ 913.462 1824.28
+ 925.481 1816.85
+ 937.500 1809.00
+ 949.519 1800.95
+ 961.538 1792.92
+ 973.558 1785.14
+ 985.577 1777.84
+ 997.596 1771.25
+ 1009.62 1765.55
+ 1021.63 1760.76
+ 1033.65 1756.75
+ 1045.67 1753.44
+ 1057.69 1750.72
+ 1069.71 1748.49
+ 1081.73 1746.65
+ 1093.75 1745.09
+ 1105.77 1743.72
+ 1117.79 1742.49
+ 1129.81 1741.37
+ 1141.83 1740.35
+ 1153.85 1739.42
+ 1165.87 1738.57
+ 1177.88 1737.79
+ 1189.90 1737.06
+ 1201.92 1736.37
+ 1213.94 1735.72
+ 1225.96 1735.14
+ 1237.98 1734.66
+ 1250.00 1734.30
+ 1262.02 1734.11
+ 1274.04 1734.11
+ 1286.06 1734.33
+ 1298.08 1734.80
+ 1310.10 1735.55
+ 1322.12 1736.55
+ 1334.13 1737.74
+ 1346.15 1739.08
+ 1358.17 1740.50
+ 1370.19 1741.96
+ 1382.21 1743.40
+ 1394.23 1744.77
+ 1406.25 1746.02
+ 1418.27 1747.13
+ 1430.29 1748.10
+ 1442.31 1748.94
+ 1454.33 1749.64
+ 1466.35 1750.22
+ 1478.37 1750.68
+ 1490.38 1751.02
+ 1502.40 1751.25
+ 1514.42 1751.41
+ 1526.44 1751.68
+ 1538.46 1752.23
+ 1550.48 1753.22
+ 1562.50 1754.84
+ 1574.52 1757.27
+ 1586.54 1760.67
+ 1598.56 1765.22
+ 1610.58 1771.04
+ 1622.60 1777.93
+ 1634.62 1785.56
+ 1646.63 1793.60
+ 1658.65 1801.74
+ 1670.67 1809.64
+ 1682.69 1817.00
+ 1694.71 1823.48
+ 1706.73 1828.77
+ 1718.75 1832.75
+ 1730.77 1835.44
+ 1742.79 1836.88
+ 1754.81 1837.11
+ 1766.83 1836.17
+ 1778.85 1834.08
+ 1790.87 1830.90
+ 1802.88 1826.64
+ 1814.90 1821.41
+ 1826.92 1815.42
+ 1838.94 1808.87
+ 1850.96 1802.01
+ 1862.98 1795.03
+ 1875.00 1788.17
+ 1887.02 1781.64
+ 1899.04 1775.67
+ 1911.06 1770.45
+ 1923.08 1765.99
+ 1935.10 1762.29
+ 1947.12 1759.31
+ 1959.13 1757.05
+ 1971.15 1755.47
+ 1983.17 1754.55
+ 1995.19 1754.28
+ 2007.21 1754.63
+ 2019.23 1755.57
+ 2031.25 1757.03
+ 2043.27 1758.96
+ 2055.29 1761.33
+ 2067.31 1764.06
+ 2079.33 1767.11
+ 2091.35 1770.43
+ 2103.37 1773.97
+ 2115.38 1777.65
+ 2127.40 1781.39
+ 2139.42 1785.08
+ 2151.44 1788.64
+ 2163.46 1791.97
+ 2175.48 1794.97
+ 2187.50 1797.54
+ 2199.52 1799.60
+ 2211.54 1801.07
+ 2223.56 1802.01
+ 2235.58 1802.51
+ 2247.60 1802.66
+ 2259.62 1802.56
+ 2271.63 1802.29
+ 2283.65 1801.94
+ 2295.67 1801.62
+ 2307.69 1801.39
+ 2319.71 1801.30
+ 2331.73 1801.30
+ 2343.75 1801.39
+ 2355.77 1801.54
+ 2367.79 1801.73
+ 2379.81 1801.93
+ 2391.83 1802.13
+ 2403.85 1802.30
+ 2415.87 1802.43
+ 2427.88 1802.51
+ 2439.90 1802.55
+ 2451.92 1802.56
+ 2463.94 1802.52
+ 2475.96 1802.45
+ 2487.98 1802.35
+ 2500.00 1802.20
Added: seismo/2D/SPECFEM2D/trunk/Makefile
===================================================================
--- seismo/2D/SPECFEM2D/trunk/Makefile 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/Makefile 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,121 @@
+#
+# Makefile for SPECFEM2D version 5.1
+#
+# Dimitri Komatitsch, Universite de Pau et des Pays de l'Adour, December 2004
+#
+SHELL=/bin/sh
+
+O = obj
+
+# Portland Linux
+#F90 = pgf90
+#FLAGS=-fast -Mnobounds -Minline -Mneginfo -Mdclchk
+
+# Intel Linux
+F90 = ifort
+#FLAGS=-O0 -implicitnone -warn stderrors -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check bounds
+FLAGS=-O3 -implicitnone -warn stderrors -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nobounds
+
+#
+# g95 (free f95 compiler from http://www.g95.org, still under development, but works)
+#
+#F90 = g95
+#FLAGS = -O
+
+# Dec Alpha
+#F90 = f90
+#FLAGS=-O0 -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nounderflow -check bounds -C
+##FLAGS=-fast -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nounderflow -check nobounds
+
+LINK = $(F90)
+
+OBJS_MESHFEM2D = $O/meshfem2D.o
+
+OBJS_SPECFEM2D = $O/checkgrid.o $O/datim.o $O/defarrays.o\
+ $O/lagrange_poly.o $O/gmat01.o $O/gll_library.o $O/plotgll.o $O/define_derivative_matrices.o\
+ $O/plotpost.o $O/locate_receivers.o $O/positsource.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/cree_image_PNM.o $O/compute_gradient_fluid.o $O/recompute_jacobian.o
+
+default: meshfem2D specfem2D
+
+all: default
+
+clean:
+ /bin/rm -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*
+
+meshfem2D: $(OBJS_MESHFEM2D)
+ $(LINK) $(FLAGS) -o xmeshfem2D $(OBJS_MESHFEM2D)
+
+specfem2D: $(OBJS_SPECFEM2D)
+ $(LINK) $(FLAGS) -o xspecfem2D $(OBJS_SPECFEM2D)
+
+convolve_source_timefunction: $O/convolve_source_timefunction.o
+ ${F90} $(FLAGS) -o xconvolve_source_timefunction $O/convolve_source_timefunction.o
+
+$O/checkgrid.o: checkgrid.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/checkgrid.o checkgrid.f90
+
+$O/meshfem2D.o: meshfem2D.f90
+ ${F90} $(FLAGS) -c -o $O/meshfem2D.o meshfem2D.f90
+
+$O/createnum_fast.o: createnum_fast.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/createnum_fast.o createnum_fast.f90
+
+$O/createnum_slow.o: createnum_slow.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/createnum_slow.o createnum_slow.f90
+
+$O/convolve_source_timefunction.o: convolve_source_timefunction.f90
+ ${F90} $(FLAGS) -c -o $O/convolve_source_timefunction.o convolve_source_timefunction.f90
+
+$O/datim.o: datim.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/datim.o datim.f90
+
+$O/defarrays.o: defarrays.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/defarrays.o defarrays.f90
+
+$O/lagrange_poly.o: lagrange_poly.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/lagrange_poly.o lagrange_poly.f90
+
+$O/gmat01.o: gmat01.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/gmat01.o gmat01.f90
+
+$O/gll_library.o: gll_library.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/gll_library.o gll_library.f90
+
+$O/define_derivative_matrices.o: define_derivative_matrices.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/define_derivative_matrices.o define_derivative_matrices.f90
+
+$O/plotgll.o: plotgll.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/plotgll.o plotgll.f90
+
+$O/plotpost.o: plotpost.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/plotpost.o plotpost.f90
+
+$O/locate_receivers.o: locate_receivers.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/locate_receivers.o locate_receivers.f90
+
+$O/recompute_jacobian.o: recompute_jacobian.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/recompute_jacobian.o recompute_jacobian.f90
+
+$O/positsource.o: positsource.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/positsource.o positsource.f90
+
+$O/define_shape_functions.o: define_shape_functions.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/define_shape_functions.o define_shape_functions.f90
+
+$O/specfem2D.o: specfem2D.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/specfem2D.o specfem2D.f90
+
+$O/compute_gradient_attenuation.o: compute_gradient_attenuation.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/compute_gradient_attenuation.o compute_gradient_attenuation.f90
+
+$O/compute_gradient_fluid.o: compute_gradient_fluid.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/compute_gradient_fluid.o compute_gradient_fluid.f90
+
+$O/cree_image_PNM.o: cree_image_PNM.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/cree_image_PNM.o cree_image_PNM.f90
+
+$O/write_seismograms.o: write_seismograms.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/write_seismograms.o write_seismograms.f90
+
Added: seismo/2D/SPECFEM2D/trunk/checkgrid.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/checkgrid.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/checkgrid.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,73 @@
+
+!========================================================================
+!
+! 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 checkgrid(deltat,f0,t0,initialfield,rsizemin,rsizemax, &
+ cpoverdxmin,cpoverdxmax,rlamdaSmin,rlamdaSmax,rlamdaPmin,rlamdaPmax)
+
+!
+!---- verification taille des mailles, stabilite et nb de points par lambda
+!
+
+ implicit none
+
+ include "constants.h"
+
+ double precision f0,t0
+ double precision deltat,rsizemin,rsizemax,cpoverdxmin,cpoverdxmax, &
+ rlamdaSmin,rlamdaSmax,rlamdaPmin,rlamdaPmax
+
+ logical initialfield
+
+!
+!---- verification taille de grille min et max
+!
+
+ print *
+ print *,'******************************************'
+ print *,'*** Verification parametres simulation ***'
+ print *,'******************************************'
+ print *
+ print *,'*** Taille max grille = ',rsizemax
+ print *,'*** Taille min grille = ',rsizemin
+ print *,'*** Rapport max/min = ',rsizemax/rsizemin
+ print *
+ print *,'*** Stabilite max vitesse P = ',cpoverdxmax*deltat
+ print *,'*** Stabilite min vitesse P = ',cpoverdxmin*deltat
+ print *
+
+ if(.not. initialfield) then
+
+ print *,' Onset time = ',t0
+ print *,' Fundamental period = ',1.d0/f0
+ print *,' Fundamental frequency = ',f0
+ if(t0 <= 1.d0/f0) then
+ stop 'Onset time too small'
+ else
+ print *,' --> onset time ok'
+ endif
+ print *,'----'
+ print *,' Nb pts / lambda P max f0 = ',NGLLX*rlamdaPmax/f0
+ print *,' Nb pts / lambda P min f0 = ',NGLLX*rlamdaPmin/f0
+ print *,' Nb pts / lambda P max fmax = ',NGLLX*rlamdaPmax/(2.5d0*f0)
+ print *,' Nb pts / lambda P min fmax = ',NGLLX*rlamdaPmin/(2.5d0*f0)
+ print *,'----'
+ print *,' Nb pts / lambda S max f0 = ',NGLLX*rlamdaSmax/f0
+ print *,' Nb pts / lambda S min f0 = ',NGLLX*rlamdaSmin/f0
+ print *,' Nb pts / lambda S max fmax = ',NGLLX*rlamdaSmax/(2.5d0*f0)
+ print *,' Nb pts / lambda S min fmax = ',NGLLX*rlamdaSmin/(2.5d0*f0)
+ print *,'----'
+
+ endif
+
+ end subroutine checkgrid
+
Added: seismo/2D/SPECFEM2D/trunk/circ.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/circ.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/circ.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,839 @@
+!
+!=====================================================================
+!
+! P r e m a i l l e u r - 2 D
+! ---------------------------
+!
+! Version 2.1
+! -----------
+!
+! Dimitri Komatitsch
+!
+! Departement de Sismologie
+! Institut de Physique du Globe de Paris
+!
+! (c) Institut de Physique du Globe de Paris, Octobre 1996
+!
+!=====================================================================
+!
+
+! DK DK Mexico August 1999 : mise a jour format base de donnees
+
+ program circ
+
+ implicit none
+
+! max size of the model in elements
+ integer, parameter :: mnx=7,mnz=7
+
+ double precision, parameter :: pi=3.141592653589793d0
+
+! seuil pour considerer deux points comme confondus
+ double precision, parameter :: rseuil=1.d-2
+
+! declare variables
+ integer imaxabs,n2ana,itimetype,isource_type,nump1,nump2,nump3,nump4
+ integer ndofn,ndime,ngnod,nnode,nbcnd,n1ana
+ integer nofst,npgeo,nspel,nbmodeles,nbsources,nrec,lquad,isamp,nrec1,nrec2
+ integer irec,imatnum,netyp,nxgll,nelemperio,nelemabs,nx,nz,i,j
+ integer irepr,nrecsur3,nt,niter,itaff,itfirstaff,numerocourant,iptsdisp,isubsamp
+
+ double precision R,theta_i,theta_init,delta_theta,eta_j,valseuil,freqmaxrep
+ double precision f0,t0,xs,zs,angle,factor,dist,xoffs,zoffs
+ double precision xrec,zrec,rho,cp,cs,anglerec
+ double precision anglerec2,dt,alphanewm,betanewm,gammanewm
+ double precision cutvect,cutcolor,scalex,scalez,sizemax,orig_x,orig_z
+ double precision factorana,factorxsu
+
+! stockage de la grille curvi (x et z)
+ integer, parameter :: npoinz1=(4*mnx+1)*(mnz+1), nelemz1=(4*mnx)*mnz
+ double precision x1(0:4*mnx,0:mnz)
+ double precision z1(0:4*mnx,0:mnz)
+
+ integer, parameter :: npoinz3=(2*mnx+1)*(4*mnz+1), nelemz3=(2*mnx)*(4*mnz)
+ double precision x3(0:2*mnx,0:4*mnz)
+ double precision z3(0:2*mnx,0:4*mnz)
+
+ integer, parameter :: npoinz4=(2*mnx+1)*(2*mnz+1), nelemz4=(2*mnx)*(2*mnz)
+ double precision x4(0:2*mnx,0:2*mnz)
+ double precision z4(0:2*mnx,0:2*mnz)
+
+ integer, parameter :: npoinz1b=(2*mnx+1)*(mnz+1), nelemz1b=(2*mnx)*mnz
+ double precision x1b(0:2*mnx,0:mnz)
+ double precision z1b(0:2*mnx,0:mnz)
+
+ integer, parameter :: npoinz2b=(mnx+1)*(2*mnz+1), nelemz2b=mnx*(2*mnz)
+ double precision x2b(0:mnx,0:2*mnz)
+ double precision z2b(0:mnx,0:2*mnz)
+
+ integer, parameter :: npoinz3b=(4*mnx+1)*(4*mnz+1), nelemz3b=(4*mnx)*(4*mnz)
+ double precision x3b(0:4*mnx,0:4*mnz)
+ double precision z3b(0:4*mnx,0:4*mnz)
+
+ integer, parameter :: npoinz4b=(2*mnx+1)*(2*mnz+1), nelemz4b=(2*mnx)*(2*mnz)
+ double precision x4b(0:2*mnx,0:2*mnz)
+ double precision z4b(0:2*mnx,0:2*mnz)
+
+! nombre max de points de maillage, et nombre exact d'elements
+ integer, parameter :: npoin = npoinz1+npoinz3+npoinz4+ &
+ npoinz1b+npoinz2b+npoinz3b+npoinz4b
+ integer, parameter :: nelem = nelemz1+nelemz3+nelemz4+ &
+ nelemz1b+nelemz2b+nelemz3b+nelemz4b
+
+! coordonnees geometriques des points
+ double precision xpoint(npoin)
+ double precision zpoint(npoin)
+
+! coordonnees des sommets de chaque element
+ double precision x1e(nelem)
+ double precision z1e(nelem)
+ double precision x2e(nelem)
+ double precision z2e(nelem)
+ double precision x3e(nelem)
+ double precision z3e(nelem)
+ double precision x4e(nelem)
+ double precision z4e(nelem)
+
+! numero des points des elements
+ integer numpoin1(nelem)
+ integer numpoin2(nelem)
+ integer numpoin3(nelem)
+ integer numpoin4(nelem)
+
+! nom du fichier GNUPLOT contenant la grille
+ character(len=50) file1,title
+
+ logical iexternal, aleatoire, topoplane, simulate, absstacey
+ logical absorbhaut, absorbbas, absorbgauche, sismos
+ logical absorbdroite, absorbstacey, absorbmodar, ifullabs
+
+ logical display, ignuplot, ivectplot, icolorplot, imeshvect
+ logical imeshcolor, imodelvect, iboundvect, interpol, isymbols, initialfield
+ logical usletter,compenergy
+
+ print *,'Nombre d''elements = ',nelem
+ print *,'Nombre max de points = ',npoin
+
+ nx = mnx
+ nz = mnz
+
+ R = 1.
+
+! ***************************************
+! *** ZONE DE DROITE
+! ***************************************
+
+! generer les points de base de l'interpolation lineaire (zone 1)
+ theta_init = 3 * pi / 2.
+ delta_theta = pi / 2.
+ do i=0,4*nx
+
+! --- point de depart
+ if(i < 2*nx) then
+ x1(i,0) = 2.*R * real(i) / real(2*nx)
+ z1(i,0) = - 2.*R
+ else
+ x1(i,0) = 2.*R
+ z1(i,0) = - 2.*R * (1. - real(i - 2*nx) / real(2*nx))
+ endif
+
+! --- point d'arrivee
+ theta_i = theta_init + delta_theta * real(i) / real(4*nx)
+ x1(i,nz) = dcos(theta_i)
+ z1(i,nz) = dsin(theta_i)
+
+! --- points intermediaires par interpolation lineaire
+ do j=1,nz-1
+ eta_j = real(j) / real(nz)
+ x1(i,j) = (1.-eta_j)*x1(i,0) + eta_j*x1(i,nz)
+ z1(i,j) = (1.-eta_j)*z1(i,0) + eta_j*z1(i,nz)
+ enddo
+ enddo
+
+! generer zone de gauche (zone 3)
+ do i=0,2*nx
+ do j=0,4*nz
+ x3(i,j) = 5. * real(i) / real(2*nx) + 2.
+ if(j <= 2*nz) then
+ z3(i,j) = 7. * real(j) / real(2*nz) - 9.
+ else
+ z3(i,j) = 2. * real(j-2*nz) / real(2*nz) - 2.
+ endif
+ enddo
+ enddo
+
+! generer zone du bas (zone 4)
+ do i=0,2*nx
+ do j=0,2*nz
+ x4(i,j) = 2. * real(i) / real(2*nx)
+ z4(i,j) = 7. * real(j) / real(2*nz) - 9.
+ enddo
+ enddo
+
+! ***************************************
+! *** ZONE DE GAUCHE
+! ***************************************
+
+! generer les points de base de l'interpolation lineaire (zone 1)
+ theta_init = pi / 4.
+ delta_theta = pi / 4.
+ do i=0,2*nx
+! --- point de depart
+ x1b(i,0) = 2.*R * (real(i) / real(2*nx) - 1.)
+ z1b(i,0) = - 2.*R
+
+! --- point d'arrivee
+ theta_i = theta_init + delta_theta * real(i) / real(2*nx)
+ x1b(i,nz) = - dcos(theta_i)
+ z1b(i,nz) = - dsin(theta_i)
+
+! --- points intermediaires par interpolation lineaire
+ do j=1,nz-1
+ eta_j = real(j) / real(nz)
+ x1b(i,j) = (1.-eta_j)*x1b(i,0) + eta_j*x1b(i,nz)
+ z1b(i,j) = (1.-eta_j)*z1b(i,0) + eta_j*z1b(i,nz)
+ enddo
+ enddo
+
+! generer les points de base de l'interpolation lineaire (zone 2)
+ theta_init = pi / 4.
+ do j=0,2*nz
+! --- point de depart
+ x2b(0,j) = - 2.*R
+ z2b(0,j) = 2.*R * (real(j) / real(2*nz) - 1.)
+
+! --- point d'arrivee
+ theta_i = theta_init - &
+ delta_theta * real(j) / real(2*nz)
+ x2b(nx,j) = - dcos(theta_i)
+ z2b(nx,j) = - dsin(theta_i)
+
+! --- points intermediaires par interpolation lineaire
+ do i=1,nx-1
+ eta_j = real(i) / real(nx)
+ x2b(i,j) = (1.-eta_j)*x2b(0,j) + eta_j*x2b(nx,j)
+ z2b(i,j) = (1.-eta_j)*z2b(0,j) + eta_j*z2b(nx,j)
+ enddo
+
+ enddo
+
+! generer zone de gauche (zone 3)
+ do i=0,4*nx
+ do j=0,4*nz
+ x3b(i,j) = 10. * real(i) / real(4*nx) - 12.
+ if(j <= 2*nz) then
+ z3b(i,j) = 7. * real(j) / real(2*nz) - 9.
+ else
+ z3b(i,j) = 2. * real(j-2*nz) / real(2*nz) - 2.
+ endif
+ enddo
+ enddo
+
+! generer zone du bas (zone 4)
+ do i=0,2*nx
+ do j=0,2*nz
+ x4b(i,j) = 2. * real(i) / real(2*nx) - 2.
+ z4b(i,j) = 7. * real(j) / real(2*nz) - 9.
+ enddo
+ enddo
+
+! ***
+! *** generer un fichier 'GNUPLOT' pour le controle de la grille ***
+! ***
+
+ write(*,*)' '
+ write(*,*)' Ecriture de la grille format GNUPLOT...'
+
+ file1='grid.GNU'
+
+ open(unit=20,file=file1,status='unknown')
+
+! *** dessiner la zone 1
+ do j=0,nz
+ do i=0,4*nx-1
+ write(20,*) real(x1(i,j)),real(z1(i,j))
+ write(20,*) real(x1(i+1,j)),real(z1(i+1,j))
+ write(20,100)
+ enddo
+ enddo
+
+ do i=0,4*nx
+ do j=0,nz-1
+ write(20,*) real(x1(i,j)),real(z1(i,j))
+ write(20,*) real(x1(i,j+1)),real(z1(i,j+1))
+ write(20,100)
+ enddo
+ enddo
+
+! *** dessiner la zone 3
+ do j=0,4*nz
+ do i=0,2*nx-1
+ write(20,*) real(x3(i,j)),real(z3(i,j))
+ write(20,*) real(x3(i+1,j)),real(z3(i+1,j))
+ write(20,100)
+ enddo
+ enddo
+
+ do i=0,2*nx
+ do j=0,4*nz-1
+ write(20,*) real(x3(i,j)),real(z3(i,j))
+ write(20,*) real(x3(i,j+1)),real(z3(i,j+1))
+ write(20,100)
+ enddo
+ enddo
+
+! *** dessiner la zone 4
+ do j=0,2*nz
+ do i=0,2*nx-1
+ write(20,*) real(x4(i,j)),real(z4(i,j))
+ write(20,*) real(x4(i+1,j)),real(z4(i+1,j))
+ write(20,100)
+ enddo
+ enddo
+
+ do i=0,2*nx
+ do j=0,2*nz-1
+ write(20,*) real(x4(i,j)),real(z4(i,j))
+ write(20,*) real(x4(i,j+1)),real(z4(i,j+1))
+ write(20,100)
+ enddo
+ enddo
+
+! *** dessiner la zone 1
+ do j=0,nz
+ do i=0,2*nx-1
+ write(20,*) real(x1b(i,j)),real(z1b(i,j))
+ write(20,*) real(x1b(i+1,j)),real(z1b(i+1,j))
+ write(20,100)
+ enddo
+ enddo
+
+ do i=0,2*nx
+ do j=0,nz-1
+ write(20,*) real(x1b(i,j)),real(z1b(i,j))
+ write(20,*) real(x1b(i,j+1)),real(z1b(i,j+1))
+ write(20,100)
+ enddo
+ enddo
+
+! *** dessiner la zone 2
+ do j=0,2*nz
+ do i=0,nx-1
+ write(20,*) real(x2b(i,j)),real(z2b(i,j))
+ write(20,*) real(x2b(i+1,j)),real(z2b(i+1,j))
+ write(20,100)
+ enddo
+ enddo
+
+ do i=0,nx
+ do j=0,2*nz-1
+ write(20,*) real(x2b(i,j)),real(z2b(i,j))
+ write(20,*) real(x2b(i,j+1)),real(z2b(i,j+1))
+ write(20,100)
+ enddo
+ enddo
+
+! *** dessiner la zone 3
+ do j=0,4*nz
+ do i=0,4*nx-1
+ write(20,*) real(x3b(i,j)),real(z3b(i,j))
+ write(20,*) real(x3b(i+1,j)),real(z3b(i+1,j))
+ write(20,100)
+ enddo
+ enddo
+
+ do i=0,4*nx
+ do j=0,4*nz-1
+ write(20,*) real(x3b(i,j)),real(z3b(i,j))
+ write(20,*) real(x3b(i,j+1)),real(z3b(i,j+1))
+ write(20,100)
+ enddo
+ enddo
+
+! *** dessiner la zone 4
+ do j=0,2*nz
+ do i=0,2*nx-1
+ write(20,*) real(x4b(i,j)),real(z4b(i,j))
+ write(20,*) real(x4b(i+1,j)),real(z4b(i+1,j))
+ write(20,100)
+ enddo
+ enddo
+
+ do i=0,2*nx
+ do j=0,2*nz-1
+ write(20,*) real(x4b(i,j)),real(z4b(i,j))
+ write(20,*) real(x4b(i,j+1)),real(z4b(i,j+1))
+ write(20,100)
+ enddo
+ enddo
+
+ close(20)
+
+ write(*,*)' Fin ecriture de la grille format GNUPLOT'
+ write(*,*)' '
+
+ 100 format('')
+
+! ***
+! *** generer la liste des points geometriques
+! ***
+
+ numerocourant = 1
+
+! *** zone 1
+ do j=0,nz
+ do i=0,4*nx
+ xpoint(numerocourant) = x1(i,j)
+ zpoint(numerocourant) = z1(i,j)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 3
+ do j=0,4*nz
+ do i=0,2*nx
+ xpoint(numerocourant) = x3(i,j)
+ zpoint(numerocourant) = z3(i,j)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 4
+ do j=0,2*nz
+ do i=0,2*nx
+ xpoint(numerocourant) = x4(i,j)
+ zpoint(numerocourant) = z4(i,j)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 1
+ do j=0,nz
+ do i=0,2*nx
+ xpoint(numerocourant) = x1b(i,j)
+ zpoint(numerocourant) = z1b(i,j)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 2
+ do j=0,2*nz
+ do i=0,nx
+ xpoint(numerocourant) = x2b(i,j)
+ zpoint(numerocourant) = z2b(i,j)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 3
+ do j=0,4*nz
+ do i=0,4*nx
+ xpoint(numerocourant) = x3b(i,j)
+ zpoint(numerocourant) = z3b(i,j)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 4
+ do j=0,2*nz
+ do i=0,2*nx
+ xpoint(numerocourant) = x4b(i,j)
+ zpoint(numerocourant) = z4b(i,j)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+ print *,'nb de points stockes = ',numerocourant - 1
+
+! ***
+! *** generer la liste des elements
+! ***
+
+ numerocourant = 1
+ imaxabs = 0
+
+! *** zone 1
+ do j=0,nz-1
+ do i=0,4*nx-1
+ x1e(numerocourant) = x1(i,j)
+ z1e(numerocourant) = z1(i,j)
+ x2e(numerocourant) = x1(i+1,j)
+ z2e(numerocourant) = z1(i+1,j)
+ x3e(numerocourant) = x1(i+1,j+1)
+ z3e(numerocourant) = z1(i+1,j+1)
+ x4e(numerocourant) = x1(i,j+1)
+ z4e(numerocourant) = z1(i,j+1)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 3
+ do j=0,4*nz-1
+ do i=0,2*nx-1
+ x1e(numerocourant) = x3(i,j)
+ z1e(numerocourant) = z3(i,j)
+ x2e(numerocourant) = x3(i+1,j)
+ z2e(numerocourant) = z3(i+1,j)
+ x3e(numerocourant) = x3(i+1,j+1)
+ z3e(numerocourant) = z3(i+1,j+1)
+ x4e(numerocourant) = x3(i,j+1)
+ z4e(numerocourant) = z3(i,j+1)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 4
+ do j=0,2*nz-1
+ do i=0,2*nx-1
+ x1e(numerocourant) = x4(i,j)
+ z1e(numerocourant) = z4(i,j)
+ x2e(numerocourant) = x4(i+1,j)
+ z2e(numerocourant) = z4(i+1,j)
+ x3e(numerocourant) = x4(i+1,j+1)
+ z3e(numerocourant) = z4(i+1,j+1)
+ x4e(numerocourant) = x4(i,j+1)
+ z4e(numerocourant) = z4(i,j+1)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 1
+ do j=0,nz-1
+ do i=0,2*nx-1
+ x1e(numerocourant) = x1b(i,j)
+ z1e(numerocourant) = z1b(i,j)
+ x2e(numerocourant) = x1b(i+1,j)
+ z2e(numerocourant) = z1b(i+1,j)
+ x3e(numerocourant) = x1b(i+1,j+1)
+ z3e(numerocourant) = z1b(i+1,j+1)
+ x4e(numerocourant) = x1b(i,j+1)
+ z4e(numerocourant) = z1b(i,j+1)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 2
+ do j=0,2*nz-1
+ do i=0,nx-1
+ x1e(numerocourant) = x2b(i,j)
+ z1e(numerocourant) = z2b(i,j)
+ x2e(numerocourant) = x2b(i+1,j)
+ z2e(numerocourant) = z2b(i+1,j)
+ x3e(numerocourant) = x2b(i+1,j+1)
+ z3e(numerocourant) = z2b(i+1,j+1)
+ x4e(numerocourant) = x2b(i,j+1)
+ z4e(numerocourant) = z2b(i,j+1)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 3
+ do j=0,4*nz-1
+ do i=0,4*nx-1
+ x1e(numerocourant) = x3b(i,j)
+ z1e(numerocourant) = z3b(i,j)
+ x2e(numerocourant) = x3b(i+1,j)
+ z2e(numerocourant) = z3b(i+1,j)
+ x3e(numerocourant) = x3b(i+1,j+1)
+ z3e(numerocourant) = z3b(i+1,j+1)
+ x4e(numerocourant) = x3b(i,j+1)
+ z4e(numerocourant) = z3b(i,j+1)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 4
+ do j=0,2*nz-1
+ do i=0,2*nx-1
+ x1e(numerocourant) = x4b(i,j)
+ z1e(numerocourant) = z4b(i,j)
+ x2e(numerocourant) = x4b(i+1,j)
+ z2e(numerocourant) = z4b(i+1,j)
+ x3e(numerocourant) = x4b(i+1,j+1)
+ z3e(numerocourant) = z4b(i+1,j+1)
+ x4e(numerocourant) = x4b(i,j+1)
+ z4e(numerocourant) = z4b(i,j+1)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+ print *,'nb d''elements stockes = ',numerocourant - 1
+
+! ***
+! *** creation des elements sous forme topologique
+! ***
+
+ write(*,*)' '
+ write(*,*)' Creation de la topologie des elements...'
+
+ file1='topoelements.txt'
+
+ do i=1,nelem
+
+! recherche point 1
+ do j=1,npoin
+ dist = dsqrt((x1e(i)-xpoint(j))**2 + &
+ (z1e(i)-zpoint(j))**2)
+ if(dist <= rseuil) then
+ nump1 = j
+ goto 401
+ endif
+ enddo
+ stop 'point not found !'
+ 401 continue
+
+! recherche point 2
+ do j=1,npoin
+ dist = dsqrt((x2e(i)-xpoint(j))**2 + &
+ (z2e(i)-zpoint(j))**2)
+ if(dist <= rseuil) then
+ nump2 = j
+ goto 402
+ endif
+ enddo
+ stop 'point not found !'
+ 402 continue
+
+! recherche point 3
+ do j=1,npoin
+ dist = dsqrt((x3e(i)-xpoint(j))**2 + &
+ (z3e(i)-zpoint(j))**2)
+ if(dist <= rseuil) then
+ nump3 = j
+ goto 403
+ endif
+ enddo
+ stop 'point not found !'
+ 403 continue
+
+! recherche point 4
+ do j=1,npoin
+ dist = dsqrt((x4e(i)-xpoint(j))**2 + &
+ (z4e(i)-zpoint(j))**2)
+ if(dist <= rseuil) then
+ nump4 = j
+ goto 404
+ endif
+ enddo
+ stop 'point not found !'
+ 404 continue
+
+ numpoin1(i) = nump1
+ numpoin2(i) = nump2
+ numpoin3(i) = nump3
+ numpoin4(i) = nump4
+
+ enddo
+
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+! *** generation de la base de donnees
+
+ write(*,*)
+ write(*,*) 'Generation de la base de donnees...'
+
+ open(unit=15,file='../SPECFEM90/DataBase',status='unknown')
+
+ title = 'Modele Canyon Paco'
+ write(15,*) '#'
+ write(15,*) '# Base de Donnees pour Specfem - Premailleur Fortran 90'
+ write(15,*) '# ',title
+ write(15,*) '# Dimitri Komatitsch, (c) EPS - Harvard February 1998'
+ write(15,*) '#'
+
+ write(15,*) 'Titre simulation'
+ write(15,40) title
+
+ ndofn = 2
+ ndime = 2
+ ngnod = 4
+ nnode = 4
+ nbcnd = 0
+ nofst = 0
+ npgeo = npoin
+ nspel = nelem
+ nbmodeles = 1
+ nbsources = 1
+ nrec = 150
+ lquad = 1
+ iexternal = .false.
+ aleatoire = .false.
+ topoplane = .false.
+ simulate = .false.
+
+ absorbhaut = .false.
+ absorbbas = .false.
+ absorbgauche = .false.
+ absorbdroite = .false.
+ absorbstacey = .true.
+ absorbmodar = .false.
+ ifullabs = .false.
+
+ sismos = .true.
+ isamp = 20
+ nrec1 = nrec
+ nrec2 = 0
+ anglerec = 0.
+ anglerec2 = 0.
+ irepr = 1
+ nrecsur3 = nrec / 3
+
+ nt = 20000
+ dt = 0.625e-3
+ niter = 1
+ alphanewm = 0.
+ betanewm = 0.
+ gammanewm = 0.5
+ display = .true.
+ ignuplot = .false.
+ ivectplot = .true.
+ icolorplot = .false.
+ imeshvect = .true.
+ imeshcolor = .false.
+ imodelvect = .false.
+ iboundvect = .false.
+ interpol = .true.
+ isymbols = .true.
+
+!! DK DK Mexico August 1999, temporarily suppress external field
+ initialfield = .true.
+ initialfield = .false.
+
+ itaff = 2000
+ itfirstaff = 5
+ cutvect = 1.
+ cutcolor = 2.2
+ scalex = 1.
+ scalez = 1.
+ sizemax = 1.
+ iptsdisp = 7
+ isubsamp = 2
+ orig_x = 2.3
+ orig_z = 3.4
+ factorana = 50000.
+ factorxsu = 3.5
+ n1ana = 1
+ n2ana = nrec1
+
+ write(15,*) 'ndofn ndime npgeo'
+ write(15,*) ndofn,ndime,npgeo
+
+ write(15,*) 'display ignuplot interpol'
+ write(15,*) display,ignuplot,interpol
+
+ write(15,*) 'itaff itfirstaff icolor inumber'
+ write(15,*) itaff,itfirstaff,0,0
+
+ write(15,*) 'ivectplot imeshvect imodelvect iboundvect cutvect isubsamp'
+ write(15,*) ivectplot,imeshvect,imodelvect,iboundvect,cutvect,isubsamp
+
+ usletter = .true.
+ write(15,*) 'scalex scalez sizemax angle rapport USletter'
+ write(15,*) scalex,scalez,sizemax,20.,0.40,usletter
+
+ write(15,*) 'orig_x orig_z isymbols'
+ write(15,*) orig_x,orig_z,isymbols
+
+ valseuil = 5.00
+ freqmaxrep = 100.
+ write(15,*) 'valseuil freqmaxrep'
+ write(15,*) valseuil,freqmaxrep
+
+ write(15,*) 'sismos nrec nrec1 nrec2 isamp'
+ write(15,*) sismos,nrec,nrec1,nrec2,isamp
+
+ write(15,*) 'irepr anglerec anglerec2'
+ write(15,*) irepr,anglerec,anglerec2
+
+ compenergy = .false.
+ absstacey = .true.
+ write(15,*) 'topoplane absstacey compenergy'
+ write(15,*) topoplane,absstacey,compenergy
+
+ write(15,*) 'initialfield factorana factorxsu n1ana n2ana'
+ write(15,*) initialfield,factorana,factorxsu,n1ana,n2ana
+
+ write(15,*) 'isismostype ivecttype iaffinfo'
+ write(15,*) '1, 1, 40'
+ write(15,*) 'ireadmodel ioutputgrid iavs ivisual3'
+ write(15,*) 'F, F, F, F'
+
+ write(15,*) 'iexec iecho'
+ write(15,*) '1 1'
+
+ write(15,*) 'ncycl dtinc niter'
+ write(15,*) nt,dt,niter
+
+ write(15,*) 'alpha beta gamma'
+ write(15,*) alphanewm,betanewm,gammanewm
+
+ nbsources = 1
+ write(15,*) 'nltfl (number of force or pressure sources)'
+ write(15,*) nbsources
+
+ itimetype = 6
+ isource_type = 2
+ f0 = 2.
+ t0 = 0.55
+ xs = +1.
+ zs = -2.
+ angle = 0.
+ factor = 1.
+ xoffs = 12.
+ zoffs = 9.
+ write(15,*) 'Collocated forces and/or pressure sources:'
+ write(15,*) itimetype,isource_type, &
+ xs+xoffs,zs+zoffs,f0,t0,factor,angle,0
+
+ write(15,*) 'Receivers (number, angle, position in meters)'
+ do irec=1,nrec
+ if(irec <= nrecsur3) then
+ xrec = 2.*dble(irec-1)/dble(nrecsur3-1) + 9.
+ zrec = 9.
+ else if(irec >= 2*nrecsur3) then
+ xrec = 2.*dble(irec-2*nrecsur3)/dble(nrecsur3) + 13.
+ zrec = 9.
+ else
+ angle = pi + pi*dble(irec-nrecsur3)/dble(nrecsur3)
+ xrec = 12. + dcos(angle)
+ zrec = 9. + dsin(angle)
+ endif
+ write(15,*) irec,xrec,zrec
+ enddo
+
+ write(15,*) 'Coordinates of spectral control points'
+ do i=1,npoin
+ write(15,*) i,xpoint(i)+xoffs,zpoint(i)+zoffs
+ enddo
+
+ netyp = 2
+ nxgll = 6
+ nelemperio = 0
+ nelemabs = 0
+
+ write(15,*) 'params spectraux'
+ write(15,*) netyp,nbmodeles,ngnod,nxgll,nxgll,nspel,iptsdisp, &
+ nelemabs,nelemperio
+
+ write(15,*) 'Material sets (num 0 rho vp vs 0 0)'
+ rho = 1.
+ cp = 2.
+ cs = 1.
+ write(15,*) nbmodeles,0,rho,cp,cs,0,0
+
+ write(15,*) 'Spectral elements topology'
+
+ imatnum = 1
+
+ do i=1,nspel
+ write(15,*) i,imatnum,numpoin1(i),numpoin2(i),numpoin3(i), &
+ numpoin4(i)
+ enddo
+
+ close(15)
+
+ 40 format(a50)
+
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+ end program circ
Added: seismo/2D/SPECFEM2D/trunk/compute_gradient_attenuation.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_gradient_attenuation.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/compute_gradient_attenuation.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,89 @@
+
+!========================================================================
+!
+! 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_attenuation(displ,duxdxl,duzdxl,duxdzl,duzdzl, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,NSPEC,npoin)
+
+! compute Grad(displ) for attenuation
+
+ implicit none
+
+ include "constants.h"
+
+ integer NSPEC,npoin
+
+ integer, dimension(NGLLX,NGLLZ,NSPEC) :: ibool
+
+ double precision, dimension(NGLLX,NGLLZ,NSPEC) :: duxdxl,duzdxl,duxdzl,duzdzl,xix,xiz,gammax,gammaz
+
+ double precision, dimension(NDIM,npoin) :: displ
+
+! 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,tempz1l,tempz2l
+ 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
+ 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
+
+! 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
+
+ duzdxl(i,j,ispec) = tempz1l*xixl + tempz2l*gammaxl
+ duzdzl(i,j,ispec) = tempz1l*xizl + tempz2l*gammazl
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine compute_gradient_attenuation
+
Added: seismo/2D/SPECFEM2D/trunk/compute_gradient_fluid.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/compute_gradient_fluid.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/compute_gradient_fluid.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,83 @@
+
+!========================================================================
+!
+! 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
+
+ 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/constants.h
===================================================================
--- seismo/2D/SPECFEM2D/trunk/constants.h 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/constants.h 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,127 @@
+
+! polynomial degree
+ integer, parameter :: NGLLX = 5
+ integer, parameter :: NGLLZ = NGLLX
+
+! select fast (Paul Fischer) or slow (topology only) global numbering algorithm
+ logical, parameter :: FAST_NUMBERING = .true.
+
+! mesh tolerance for fast global numbering
+ double precision, parameter :: SMALLVALTOL = 0.000001d0
+
+! displacement threshold above which we consider the code became unstable
+ double precision, parameter :: STABILITY_THRESHOLD = 1.d+25
+
+! input and output files
+ integer, parameter :: IIN = 40
+
+! uncomment this to write to standard output
+ integer, parameter :: IOUT = 6
+! uncomment this to write to file instead
+! integer, parameter :: IOUT = 41
+
+! flags for absorbing boundaries
+ integer, parameter :: ITOP = 1
+ integer, parameter :: IBOTTOM = 2
+ integer, parameter :: ILEFT = 3
+ integer, parameter :: IRIGHT = 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
+
+! pi
+ double precision, parameter :: PI = 3.141592653589793d0
+
+! 4/3
+ double precision, parameter :: FOUR_THIRDS = 4.d0/3.d0
+
+! 1/24
+ double precision, parameter :: ONE_OVER_24 = 1.d0 / 24.d0
+
+! parameters to define the Gauss-Lobatto-Legendre points
+ double precision, parameter :: GAUSSALPHA = ZERO,GAUSSBETA = ZERO
+
+! very large and very small values
+ double precision, parameter :: HUGEVAL = 1.d+30,TINYVAL = 1.d-9
+
+! number of spatial dimensions
+ integer, parameter :: NDIM = 2
+
+! maximum length of station and network name for receivers
+ integer, parameter :: MAX_LENGTH_STATION_NAME = 32
+ integer, parameter :: MAX_LENGTH_NETWORK_NAME = 8
+
+! number of iterations to solve the system for xi and eta
+ integer, parameter :: NUM_ITER = 4
+
+! display non lineaire pour rehausser les faibles amplitudes sur les images PNM
+ double precision, parameter :: POWER_DISPLAY_PNM = 0.30d0
+
+! X and Z scaling du display pour PostScript
+ double precision, parameter :: SCALEX = 1.d0
+ double precision, parameter :: SCALEZ = 1.d0
+
+! taille de la plus grande fleche en centimetres
+ double precision, parameter :: SIZEMAX = 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
+
+! dot to centimeter conversion for PostScript
+ double precision, parameter :: CENTIM = 28.5d0
+
+! parameters for arrows for PostScript snapshot
+ double precision, parameter :: ANGLE = 20.d0
+ double precision, parameter :: RAPPORT = 0.40d0
+
+! ecrire legendes ou non in PostScript display
+ logical, parameter :: LEGENDES = .true.
+
+! 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
+
+!-----------------------------------------------------------------------
+
+!
+! anisotropic copper crystal (cubic symmetry)
+!
+
+! regular c_ijkl with no rotation
+ double precision, parameter :: c11val = 169.d9
+ double precision, parameter :: c12val = 122.d9
+ double precision, parameter :: c13val = c12val
+ double precision, parameter :: c14val = 0.d0
+ double precision, parameter :: c15val = 0.d0
+ double precision, parameter :: c16val = 0.d0
+
+ double precision, parameter :: c22val = c11val
+ double precision, parameter :: c23val = c12val
+ double precision, parameter :: c24val = 0.d0
+ double precision, parameter :: c25val = 0.d0
+ double precision, parameter :: c26val = 0.d0
+
+ double precision, parameter :: c33val = c11val
+ double precision, parameter :: c34val = 0.d0
+ double precision, parameter :: c35val = 0.d0
+ double precision, parameter :: c36val = 0.d0
+
+ double precision, parameter :: c44val = 75.3d9
+ double precision, parameter :: c45val = 0.d0
+ double precision, parameter :: c46val = 0.d0
+
+ double precision, parameter :: c55val = c44val
+ double precision, parameter :: c56val = 0.d0
+
+ double precision, parameter :: c66val = c44val
+
Added: seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.csh
===================================================================
--- seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.csh 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.csh 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,20 @@
+#!/bin/csh
+
+set hdur = 11.2
+
+foreach file ( $* )
+
+set nlines = `wc -l $file `
+echo $nlines > input_convolve_code.txt
+echo $hdur >> input_convolve_code.txt
+# use .true. for a triangle and .false. for a Gaussian
+#echo ".true." >> input_convolve_code.txt
+echo ".false." >> input_convolve_code.txt
+
+echo convolving $file with hdur = $hdur using lines $nlines
+
+./xconvolve_source_timefunction < $file > ${file}.convolved
+rm input_convolve_code.txt
+
+end
+
Property changes on: seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.csh
___________________________________________________________________
Name: svn:executable
+ *
Added: seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/convolve_source_timefunction.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,111 @@
+!=====================================================================
+!
+! S p e c f e m 3 D B a s i n V e r s i o n 1 . 2
+! --------------------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology July 2004
+!
+! A signed non-commercial agreement is required to use this program.
+! Please check http://www.gps.caltech.edu/research/jtromp for details.
+! Free for non-commercial academic research ONLY.
+! This program is distributed WITHOUT ANY WARRANTY whatsoever.
+! Do not redistribute this program without written permission.
+!
+!=====================================================================
+
+ program convolve_source_time_function
+
+!
+! convolve seismograms computed for a Heaviside with given source time function
+!
+
+ implicit none
+
+ include "constants.h"
+
+! source decay rate
+ double precision, parameter :: SOURCE_DECAY_RATE = 2.628d0
+
+ integer i,j,N_j
+ integer number_remove
+ double precision, dimension(:), allocatable :: time,sem,sem_fil
+ double precision alpha,dt,tau_j,source,exponent
+ double precision t1,t2,displ1,displ2,gamma,height
+
+ integer nlines
+ double precision hdur
+ logical triangle
+
+! read file with number of lines in input
+ open(unit=33,file='input_convolve_code.txt',status='old')
+ read(33,*) nlines
+ read(33,*) hdur
+ read(33,*) triangle
+ close(33)
+
+! for Gaussian use 1.66667*hdur to get roughly a triangle with half-duration hdur
+ if(.not.triangle) hdur = hdur * 5. / 3.
+
+! allocate arrays
+ allocate(time(nlines),sem(nlines),sem_fil(nlines))
+
+ do i=1,nlines
+ read(5,*) time(i),sem(i)
+ enddo
+
+ alpha=SOURCE_DECAY_RATE/hdur
+ dt=time(2)-time(1)
+ N_j=int(hdur/dt)
+ do i=1,nlines
+ sem_fil(i)=0.
+ do j=-N_j,N_j
+ tau_j=dble(j)*dt
+
+! convolve with a triangle
+ if(triangle) then
+ height = 1. / hdur
+ if(abs(tau_j) > hdur) then
+ source = 0.
+ else if (tau_j < 0) then
+ t1 = - N_j * dt
+ displ1 = 0.
+ t2 = 0
+ displ2 = height
+ gamma = (tau_j - t1) / (t2 - t1)
+ source= (1. - gamma) * displ1 + gamma * displ2
+ else
+ t1 = 0
+ displ1 = height
+ t2 = + N_j * dt
+ displ2 = 0.
+ gamma = (tau_j - t1) / (t2 - t1)
+ source= (1. - gamma) * displ1 + gamma * displ2
+ endif
+
+ else
+
+! convolve with a Gaussian
+ exponent = alpha*alpha*tau_j*tau_j
+ if(exponent < 100.) then
+ source = alpha*exp(-exponent)/sqrt(PI)
+ else
+ source = 0.
+ endif
+
+ endif
+
+ if(i > j .and. i-j <= nlines) sem_fil(i) = sem_fil(i)+sem(i-j)*source*dt
+
+ enddo
+ enddo
+
+! compute number of samples to remove from end of seismograms
+ number_remove = int(hdur / dt) + 1
+ do i=1,nlines - number_remove
+ write(*,*) sngl(time(i)),' ',sngl(sem_fil(i))
+ enddo
+
+ end program convolve_source_time_function
+
Added: seismo/2D/SPECFEM2D/trunk/createnum_fast.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/createnum_fast.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/createnum_fast.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,307 @@
+
+!========================================================================
+!
+! 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 createnum_fast(knods,ibool,shape,coorg,npoin,npgeo,nspec,ngnod)
+
+! equivalent de la routine "createnum_slow" mais algorithme plus rapide
+
+ implicit none
+
+ include "constants.h"
+
+ integer npoin,npgeo,nspec,ngnod
+ integer knods(ngnod,nspec),ibool(NGLLX,NGLLZ,nspec)
+ double precision shape(ngnod,NGLLX,NGLLX)
+ double precision coorg(NDIM,npgeo)
+
+ integer i,j
+
+! tableaux supplementaires pour cette version rapide
+ integer, dimension(:), allocatable :: loc,ind,ninseg,iglob,iwork
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: xp,yp,work
+
+ integer ie,nseg,ioff,iseg,ig
+ integer nxyz,ntot,ispec,ieoff,ilocnum,iy,ix,in,nnum
+
+ double precision xmaxval,xminval,ymaxval,yminval,xtol,xtypdist
+ double precision xcor,ycor
+
+!---- create global mesh numbering
+ print *
+ print *
+ print *,'Generating global mesh numbering (fast version)...'
+ print *
+
+ nxyz = NGLLX*NGLLZ
+ ntot = nxyz*nspec
+
+ allocate(loc(ntot))
+ allocate(ind(ntot))
+ allocate(ninseg(ntot))
+ allocate(iglob(ntot))
+ allocate(ifseg(ntot))
+ allocate(xp(ntot))
+ allocate(yp(ntot))
+ allocate(work(ntot))
+ allocate(iwork(ntot))
+
+! compute coordinates of the grid points
+ do ispec=1,nspec
+ ieoff = nxyz*(ispec - 1)
+ ilocnum = 0
+
+ do iy = 1,NGLLX
+ do ix = 1,NGLLX
+
+ ilocnum = ilocnum + 1
+
+ xcor = zero
+ ycor = zero
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xcor = xcor + shape(in,ix,iy)*coorg(1,nnum)
+ ycor = ycor + shape(in,ix,iy)*coorg(2,nnum)
+ enddo
+
+ xp(ilocnum + ieoff) = xcor
+ yp(ilocnum + ieoff) = ycor
+
+ enddo
+ enddo
+
+ enddo
+
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+! Establish initial pointers
+ do ie=1,nspec
+ ieoff = nxyz*(ie -1)
+ do ix=1,nxyz
+ loc (ix+ieoff) = ix+ieoff
+ enddo
+ enddo
+
+! set up local geometric tolerances
+
+ xtypdist=+HUGEVAL
+
+ do ie=1,nspec
+
+ xminval=+HUGEVAL
+ yminval=+HUGEVAL
+ xmaxval=-HUGEVAL
+ ymaxval=-HUGEVAL
+ ieoff=nxyz*(ie-1)
+ do ilocnum=1,nxyz
+ xmaxval=max(xp(ieoff+ilocnum),xmaxval)
+ xminval=min(xp(ieoff+ilocnum),xminval)
+ ymaxval=max(yp(ieoff+ilocnum),ymaxval)
+ yminval=min(yp(ieoff+ilocnum),yminval)
+ enddo
+
+! compute the minimum typical "size" of an element in the mesh
+ xtypdist = min(xtypdist,xmaxval-xminval)
+ xtypdist = min(xtypdist,ymaxval-yminval)
+
+ enddo
+
+! define a tolerance, small with respect to the minimum size
+ xtol=smallvaltol*xtypdist
+
+ ifseg(:) = .false.
+ nseg = 1
+ ifseg(1) = .true.
+ ninseg(1) = ntot
+
+ do j=1,NDIM
+! Sort within each segment
+ ioff=1
+ do iseg=1,nseg
+ if(j == 1) then
+ call rank (xp(ioff),ind,ninseg(iseg))
+ else
+ call rank (yp(ioff),ind,ninseg(iseg))
+ endif
+ call swap(xp(ioff),work,ind,ninseg(iseg))
+ call swap(yp(ioff),work,ind,ninseg(iseg))
+ call iswap(loc(ioff),iwork,ind,ninseg(iseg))
+ ioff=ioff+ninseg(iseg)
+ enddo
+! Check for jumps in current coordinate
+ if (j == 1) then
+ do i=2,ntot
+ if (abs(xp(i)-xp(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ else
+ do i=2,ntot
+ if (abs(yp(i)-yp(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ endif
+! Count up number of different segments
+ nseg = 0
+ do i=1,ntot
+ if (ifseg(i)) then
+ nseg = nseg+1
+ ninseg(nseg) = 1
+ else
+ ninseg(nseg) = ninseg(nseg) + 1
+ endif
+ enddo
+ enddo
+!
+! Assign global node numbers (now sorted lexicographically!)
+!
+ ig = 0
+ do i=1,ntot
+ if (ifseg(i)) ig=ig+1
+ iglob(loc(i)) = ig
+ enddo
+
+ npoin = ig
+
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+! recuperer resultat a mon format
+ do ispec=1,nspec
+ ieoff = nxyz*(ispec - 1)
+ ilocnum = 0
+ do iy = 1,NGLLX
+ do ix = 1,NGLLX
+ ilocnum = ilocnum + 1
+ ibool(ix,iy,ispec) = iglob(ilocnum + ieoff)
+ enddo
+ enddo
+ enddo
+
+ deallocate(loc)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iglob)
+ deallocate(ifseg)
+ deallocate(xp)
+ deallocate(yp)
+ deallocate(work)
+ deallocate(iwork)
+
+! verification de la coherence de la numerotation generee
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) stop 'Error while generating global numbering'
+
+ print *
+ print *,'Total number of points of the global mesh: ',npoin
+ print *
+
+ end subroutine createnum_fast
+
+
+!-----------------------------------------------------------------------
+
+ subroutine rank(A,IND,N)
+!
+! Use Heap Sort (p 233 Numerical Recipes)
+!
+ implicit none
+
+ integer N
+ double precision A(N)
+ integer IND(N)
+
+ integer i,j,l,ir,indx
+ double precision q
+
+ do J=1,N
+ IND(j)=j
+ enddo
+
+ if(n == 1) return
+ L=n/2+1
+ ir=n
+ 100 continue
+ IF(l > 1) THEN
+ l=l-1
+ indx=ind(l)
+ q=a(indx)
+ ELSE
+ indx=ind(ir)
+ q=a(indx)
+ ind(ir)=ind(1)
+ ir=ir-1
+ if(ir == 1) then
+ ind(1)=indx
+ return
+ endif
+ ENDIF
+ i=l
+ j=l+l
+ 200 continue
+ IF(J <= IR) THEN
+ IF(J < IR) THEN
+ IF(A(IND(j)) < A(IND(j+1))) j=j+1
+ ENDIF
+ IF(q < A(IND(j))) THEN
+ IND(I)=IND(J)
+ I=J
+ J=J+J
+ ELSE
+ J=IR+1
+ ENDIF
+ GOTO 200
+ ENDIF
+ IND(I)=INDX
+ GOTO 100
+
+ end subroutine rank
+
+!-----------------------------------------------------------------------
+
+ subroutine swap(a,w,ind,n)
+!
+! Use IND to sort array A (p 233 Numerical Recipes)
+!
+ implicit none
+
+ integer n
+ double precision A(N),W(N)
+ integer IND(N)
+
+ integer j
+
+ W(:) = A(:)
+
+ do J=1,N
+ A(j) = W(ind(j))
+ enddo
+
+ end subroutine swap
+
+!-----------------------------------------------------------------------
+
+ subroutine iswap(a,w,ind,n)
+!
+! Use IND to sort array A
+!
+ implicit none
+
+ integer n
+ integer A(N),W(N),IND(N)
+
+ integer j
+
+ W(:) = A(:)
+
+ do J=1,N
+ A(j) = W(ind(j))
+ enddo
+
+ end subroutine iswap
+
Added: seismo/2D/SPECFEM2D/trunk/createnum_slow.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/createnum_slow.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/createnum_slow.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,289 @@
+
+!========================================================================
+!
+! 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 createnum_slow(knods,ibool,npoin,nspec,ngnod)
+
+! generate the global numbering
+
+ implicit none
+
+ include "constants.h"
+
+ integer npoin,nspec,ngnod
+
+ integer knods(ngnod,nspec),ibool(NGLLX,NGLLZ,nspec)
+
+ integer i,j,num2,i2,j2,ipos,ipos2,iloc,jloc,kloc
+ integer ngnodloc,ngnodother,nedgeloc,nedgeother,npedge,numelem,npcorn
+
+ logical alreadyexist
+
+ integer ngnoddeb(4),ngnodfin(4)
+
+!---- create global mesh numbering
+ print *
+ print *,'Generating global mesh numbering (slow version)...'
+ print *
+
+ npoin = 0
+ npedge = 0
+ npcorn = 0
+
+! definition des aretes par rapport aux quatre points de controle
+
+! --- arete 1 relie point 1 a point 2
+ ngnoddeb(1)= 1
+ ngnodfin(1)= 2
+
+! --- arete 2 relie point 2 a point 3
+ ngnoddeb(2)= 2
+ ngnodfin(2)= 3
+
+! --- arete 3 relie point 3 a point 4
+ ngnoddeb(3)= 3
+ ngnodfin(3)= 4
+
+! --- arete 4 relie point 4 a point 1
+ ngnoddeb(4)= 4
+ ngnodfin(4)= 1
+
+! initialisation du tableau de numerotation globale
+ ibool(:,:,:) = 0
+
+ do numelem = 1,nspec
+ do i=1,NGLLX
+ do j=1,NGLLZ
+
+! verifier que le point n'a pas deja ete genere
+
+ if(ibool(i,j,numelem) == 0) then
+
+!
+!---- point interieur a un element, donc forcement unique
+!
+ if(i /= 1 .and. i /= NGLLX .and. j /= 1 .and. j /= NGLLZ) then
+
+ npoin = npoin + 1
+ ibool(i,j,numelem) = npoin
+
+!
+!---- point au coin d'un element, rechercher les coins des autres elements
+!
+ else if((i == 1 .and. j == 1) .or. (i == 1 .and. j == NGLLZ) .or. &
+ (i == NGLLX .and. j == 1) .or. (i == NGLLX .and. j == NGLLZ)) then
+
+! trouver numero local du coin
+ if(i == 1 .and. j == 1) then
+ ngnodloc = 1
+ else if(i == NGLLX .and. j == 1) then
+ ngnodloc = 2
+ else if(i == NGLLX .and. j == NGLLZ) then
+ ngnodloc = 3
+ else if(i == 1 .and. j == NGLLZ) then
+ ngnodloc = 4
+ endif
+
+! rechercher si existe deja, forcement dans un element precedent
+
+ alreadyexist = .false.
+
+ if(numelem > 1) then
+
+ do num2=1,numelem-1
+
+! ne rechercher que sur les 4 premiers points de controle et non sur ngnod
+ do ngnodother=1,4
+
+! voir si ce coin a deja ete genere
+ if(knods(ngnodother,num2) == knods(ngnodloc,numelem)) then
+ alreadyexist = .true.
+
+! obtenir la numerotation dans l'autre element
+ if(ngnodother == 1) then
+ i2 = 1
+ j2 = 1
+ else if(ngnodother == 2) then
+ i2 = NGLLX
+ j2 = 1
+ else if(ngnodother == 3) then
+ i2 = NGLLX
+ j2 = NGLLZ
+ else if(ngnodother == 4) then
+ i2 = 1
+ j2 = NGLLZ
+ else
+ stop 'bad corner'
+ endif
+
+! affecter le meme numero
+ ibool(i,j,numelem) = ibool(i2,j2,num2)
+
+! sortir de la recherche
+ goto 134
+
+ endif
+ enddo
+ enddo
+
+ 134 continue
+
+ endif
+
+! si un ancien point n'a pas ete trouve, en generer un nouveau
+ if(.not. alreadyexist) then
+ npcorn = npcorn + 1
+ npoin = npoin + 1
+ ibool(i,j,numelem) = npoin
+ endif
+
+!
+!---- point a l'interieur d'une arete, rechercher si autre arete correspondante
+!
+ else
+
+! trouver numero local de l'arete
+ if(j == 1) then
+ nedgeloc = 1
+ else if(i == NGLLX) then
+ nedgeloc = 2
+ else if(j == NGLLZ) then
+ nedgeloc = 3
+ else if(i == 1) then
+ nedgeloc = 4
+ endif
+
+! rechercher si existe deja, forcement dans un element precedent
+
+ alreadyexist = .false.
+
+ if(numelem > 1) then
+
+ do num2=1,numelem-1
+
+! rechercher sur les 4 aretes
+ do nedgeother=1,4
+
+!--- detecter un eventuel defaut dans la structure topologique du maillage
+
+ if((knods(ngnoddeb(nedgeother),num2) == knods(ngnoddeb(nedgeloc),numelem)) &
+ .and. &
+ (knods(ngnodfin(nedgeother),num2) == knods(ngnodfin(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)) &
+ .and. &
+ (knods(ngnodfin(nedgeother),num2) == knods(ngnoddeb(nedgeloc),numelem))) then
+
+ alreadyexist = .true.
+
+! obtenir la numerotation dans l'autre element
+! maillage conforme donc on doit supposer que NGLLX == NGLLZ
+
+! generer toute l'arete pour eviter des recherches superflues
+ do kloc = 2,NGLLX-1
+
+! calculer l'abscisse le long de l'arete de depart
+ if(nedgeloc == 1) then
+ iloc = kloc
+ jloc = 1
+ ipos = iloc
+ else if(nedgeloc == 2) then
+ iloc = NGLLX
+ jloc = kloc
+ ipos = jloc
+ else if(nedgeloc == 3) then
+ iloc = kloc
+ jloc = NGLLZ
+ ipos = NGLLX - iloc + 1
+ else if(nedgeloc == 4) then
+ iloc = 1
+ jloc = kloc
+ ipos = NGLLZ - jloc + 1
+ else
+ stop 'bad nedgeloc'
+ endif
+
+! calculer l'abscisse le long de l'arete d'arrivee
+! topologie du maillage coherente, donc sens de parcours des aretes opposes
+
+ ipos2 = NGLLX - ipos + 1
+
+! calculer les coordonnees reelles dans l'element d'arrivee
+ if(nedgeother == 1) then
+ i2 = ipos2
+ j2 = 1
+ else if(nedgeother == 2) then
+ i2 = NGLLX
+ j2 = ipos2
+ else if(nedgeother == 3) then
+ i2 = NGLLX - ipos2 + 1
+ j2 = NGLLZ
+ else if(nedgeother == 4) then
+ i2 = 1
+ j2 = NGLLZ - ipos2 + 1
+ else
+ stop 'bad nedgeother'
+ endif
+
+! verifier que le point de depart n'existe pas deja
+ if(ibool(iloc,jloc,numelem) /= 0) stop 'point genere deux fois'
+
+! verifier que le point d'arrivee existe bien deja
+ if(ibool(i2,j2,num2) == 0) stop 'point inconnu dans le maillage'
+
+! affecter le meme numero
+ ibool(iloc,jloc,numelem) = ibool(i2,j2,num2)
+
+ enddo
+
+! sortir de la recherche
+ goto 135
+
+ endif
+ enddo
+ enddo
+
+ 135 continue
+
+ endif
+
+! si un ancien point n'a pas ete trouve, en generer un nouveau
+ if(.not. alreadyexist) then
+ npedge = npedge + 1
+ npoin = npoin + 1
+ ibool(i,j,numelem) = npoin
+ endif
+
+ endif
+
+ endif
+
+ enddo
+ enddo
+ enddo
+
+! verification de la coherence de la numerotation generee
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) stop 'Error while generating global numbering'
+
+ print *,'Total number of points of the global mesh: ',npoin
+ print *,'distributed as follows:'
+ print *
+ print *,'Number of interior points: ',npoin-npedge-npcorn
+ print *,'Number of edge points (without corners): ',npedge
+ print *,'Number of corner points: ',npcorn
+ print *
+
+ end subroutine createnum_slow
+
Added: seismo/2D/SPECFEM2D/trunk/cree_image_PNM.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/cree_image_PNM.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/cree_image_PNM.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,109 @@
+
+!========================================================================
+!
+! 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 cree_image_PNM(donnees_image_PNM_2D,iglob_image_PNM_2D,NX,NY,it,cutvect)
+
+! routine d'affichage du deplacement sous forme d'image en couleurs
+
+! pour voir les snapshots : display image*.pnm
+! pour les convertir en autre format : convert image0001.pnm image0001.jpg
+
+ implicit none
+
+ include "constants.h"
+
+ integer NX,NY,it
+
+ double precision cutvect
+
+ integer, dimension(NX,NY) :: iglob_image_PNM_2D
+
+ double precision, dimension(NX,NY) :: donnees_image_PNM_2D
+
+ integer ix,iy
+
+ double precision amplitude_max
+
+ character(len=100) nom_fichier
+
+ double precision valeur_normalisee
+ integer :: R, G, B
+
+! ouverture du fichier image
+ write(nom_fichier,222) it
+ 222 format('image',i5.5,'.pnm')
+
+! ouvrir le fichier
+ open(unit=27, file=nom_fichier, status='unknown')
+
+ write(27,100) ! ecrire P3 = format d'image PNM
+
+ write(27,*) NX,NY ! ecrire la taille
+ write(27,*) '255' ! nombre de nuances
+
+! calculer l'amplitude maximum
+ amplitude_max = maxval(abs(donnees_image_PNM_2D))
+
+! supprimer les petites amplitudes considerees comme du bruit
+ where(abs(donnees_image_PNM_2D) < amplitude_max * cutvect) donnees_image_PNM_2D = 0.d0
+
+! dans le format PNM, l'image commence par le coin en haut a gauche
+ do iy=NY,1,-1
+ do ix=1,NX
+
+! regarder si le pixel est defini ou non (au dessus de la topographie par exemple)
+ if(iglob_image_PNM_2D(ix,iy) == -1) then
+
+! utiliser couleur verte pour afficher les zones non definies
+ R = 0
+ G = 255
+ B = 0
+
+ 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_PNM_2D(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
+
+! 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_PNM)
+ G = 0
+ B = 0
+ else
+ R = 0
+ G = 0
+ B = nint(255.d0*abs(valeur_normalisee)**POWER_DISPLAY_PNM)
+ endif
+
+ endif
+
+! ecrire l'image en couleur
+ write(27,110) R,G,B
+
+ enddo
+ enddo
+
+! fermer le fichier
+ close(27)
+
+ 100 format('P3')
+ 110 format(i3,' ',i3,' ',i3)
+
+ end subroutine cree_image_PNM
+
Added: seismo/2D/SPECFEM2D/trunk/datim.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/datim.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/datim.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,49 @@
+
+!========================================================================
+!
+! 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 datim(string_input)
+
+! get date and time using f90 portable routines
+
+ implicit none
+
+ include "constants.h"
+
+ character(len=50) string_input
+ character(len=8) datein
+ character(len=10) timein
+ character(len=16) dateprint
+ character(len=8) timeprint
+
+ datein = ''
+ timein = ''
+
+ call date_and_time(datein,timein)
+
+ dateprint = datein(7:8)//' - '//datein(5:6)//' - '//datein(1:4)
+ timeprint = timein(1:2)//':'//timein(3:4)//':'//timein(5:6)
+
+ write(iout,100)
+ write(iout,101) string_input
+ write(iout,102) dateprint,timeprint
+
+!
+!---- formats
+!
+
+ 100 format(//1x,79('-')/1x,79('-')/1x,'Program SPECFEM2D: ')
+ 101 format(1x,79('-')/1x,79('-')/1x,a50)
+ 102 format(1x,79('-')/,1x,79('-')/' D a t e : ',a16,30x,' T i m e : ',a8/1x,79('-'),/1x,79('-'))
+
+ end subroutine datim
+
Added: seismo/2D/SPECFEM2D/trunk/defarrays.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/defarrays.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/defarrays.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,209 @@
+
+!========================================================================
+!
+! 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 defarrays(vpext,vsext,rhoext,density,elastcoef, &
+ xigll,zigll,xix,xiz,gammax,gammaz,a11,a12, &
+ ibool,kmato,coord,npoin,rsizemin,rsizemax, &
+ cpoverdxmin,cpoverdxmax,lambdaSmin,lambdaSmax,lambdaPmin,lambdaPmax, &
+ vpmin,vpmax,readmodel,nspec,numat,source_type,ix_source,iz_source,ispec_source)
+
+! define all the arrays for the variational formulation
+
+ implicit none
+
+ include "constants.h"
+
+ integer i,j,ispec,material,ipointnum,npoin,nspec,numat
+ integer ix_source,iz_source,ispec_source,ir,is,source_type
+
+ integer kmato(nspec),ibool(NGLLX,NGLLX,nspec)
+
+ double precision xix(NGLLX,NGLLZ,nspec)
+ double precision xiz(NGLLX,NGLLZ,nspec)
+ double precision gammax(NGLLX,NGLLZ,nspec)
+ double precision gammaz(NGLLX,NGLLZ,nspec)
+
+ double precision density(numat),elastcoef(4,numat)
+
+ double precision coord(NDIM,npoin)
+
+ double precision a11(NGLLX,NGLLX),a12(NGLLX,NGLLX)
+
+ double precision xigll(NGLLX),zigll(NGLLZ)
+
+ double precision vpext(npoin)
+ double precision vsext(npoin)
+ double precision rhoext(npoin)
+
+ double precision vsmin,vsmax,densmin,densmax
+ double precision lambdaplus2mu,lambda,mu,denst
+ double precision kappa,cploc,csloc,x0,z0
+ double precision x1,z1,x2,z2,rdist1,rdist2,rapportmin,rapportmax
+ double precision lambdamin,lambdamax
+ double precision flagxprime,flagzprime,sig0
+
+ double precision rsizemin,rsizemax,cpoverdxmin,cpoverdxmax, &
+ lambdaSmin,lambdaSmax,lambdaPmin,lambdaPmax,vpmin,vpmax
+
+ logical readmodel
+
+ double precision, external :: lagrange_deriv_GLL
+
+!
+!-----------------------------------------------------------------------
+!
+
+!---- compute parameters for the spectral elements
+
+ a11 = zero
+ a12 = zero
+
+ vpmin = HUGEVAL
+ vsmin = HUGEVAL
+ vpmax = -HUGEVAL
+ vsmax = -HUGEVAL
+ densmin = HUGEVAL
+ densmax = -HUGEVAL
+
+ rsizemin = HUGEVAL
+ rsizemax = -HUGEVAL
+
+ cpoverdxmin = HUGEVAL
+ cpoverdxmax = -HUGEVAL
+
+ lambdaPmin = HUGEVAL
+ lambdaSmin = HUGEVAL
+ lambdaPmax = -HUGEVAL
+ lambdaSmax = -HUGEVAL
+
+ do ispec=1,nspec
+
+ material = kmato(ispec)
+
+ lambda = elastcoef(1,material)
+ mu = elastcoef(2,material)
+ lambdaplus2mu = elastcoef(3,material)
+ denst = density(material)
+
+ kappa = lambda + 2.d0*mu/3.d0
+
+ cploc = sqrt((kappa + 4.d0*mu/3.d0)/denst)
+ csloc = sqrt(mu/denst)
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+!--- si formulation heterogene pour un modele de vitesse externe
+ if(readmodel) then
+ ipointnum = ibool(i,j,ispec)
+ cploc = vpext(ipointnum)
+ csloc = vsext(ipointnum)
+ denst = rhoext(ipointnum)
+ mu = denst*csloc*csloc
+ lambda = denst*cploc*cploc - 2.d0*mu
+ lambdaplus2mu = lambda + 2.d0*mu
+ endif
+
+!--- calculer min et max du modele de vitesse et densite
+ vpmin = min(vpmin,cploc)
+ vpmax = max(vpmax,cploc)
+
+ vsmin = min(vsmin,csloc)
+ vsmax = max(vsmax,csloc)
+
+ densmin = min(densmin,denst)
+ densmax = max(densmax,denst)
+
+!--- stocker parametres pour verifs diverses
+ if(i < NGLLX .and. j < NGLLZ) then
+
+ x0 = coord(1,ibool(i,j,ispec))
+ z0 = coord(2,ibool(i,j,ispec))
+ x1 = coord(1,ibool(i+1,j,ispec))
+ z1 = coord(2,ibool(i+1,j,ispec))
+ x2 = coord(1,ibool(i,j+1,ispec))
+ z2 = coord(2,ibool(i,j+1,ispec))
+
+ rdist1 = sqrt((x1-x0)**2 + (z1-z0)**2)
+ rdist2 = sqrt((x2-x0)**2 + (z2-z0)**2)
+
+ rsizemin = min(rsizemin,rdist1)
+ rsizemin = min(rsizemin,rdist2)
+ rsizemax = max(rsizemax,rdist1)
+ rsizemax = max(rsizemax,rdist2)
+
+ rapportmin = cploc / max(rdist1,rdist2)
+ rapportmax = cploc / min(rdist1,rdist2)
+ cpoverdxmin = min(cpoverdxmin,rapportmin)
+ cpoverdxmax = max(cpoverdxmax,rapportmax)
+
+ x0 = coord(1,ibool(1,1,ispec))
+ z0 = coord(2,ibool(1,1,ispec))
+ x1 = coord(1,ibool(NGLLX,1,ispec))
+ z1 = coord(2,ibool(NGLLX,1,ispec))
+ x2 = coord(1,ibool(1,NGLLZ,ispec))
+ z2 = coord(2,ibool(1,NGLLZ,ispec))
+
+ rdist1 = sqrt((x1-x0)**2 + (z1-z0)**2)
+ rdist2 = sqrt((x2-x0)**2 + (z2-z0)**2)
+
+ lambdamin = cploc/max(rdist1,rdist2)
+ lambdamax = cploc/min(rdist1,rdist2)
+ lambdaPmin = min(lambdaPmin,lambdamin)
+ lambdaPmax = max(lambdaPmax,lambdamax)
+
+ lambdamin = csloc/max(rdist1,rdist2)
+ lambdamax = csloc/min(rdist1,rdist2)
+ lambdaSmin = min(lambdaSmin,lambdamin)
+ lambdaSmax = max(lambdaSmax,lambdamax)
+
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ print *
+ print *,'********'
+ print *,'Modele : vitesse P min,max = ',vpmin,vpmax
+ print *,'Modele : vitesse S min,max = ',vsmin,vsmax
+ print *,'Modele : densite min,max = ',densmin,densmax
+ print *,'********'
+ print *
+
+! seulement si source explosive
+ if(source_type == 2) then
+
+ if(ix_source == 1 .or. ix_source == NGLLX .or. iz_source == 1 .or. iz_source == NGLLX) &
+ stop 'Explosive source on element edge'
+
+!---- definir a11 et a12 - dirac (schema en croix)
+
+ sig0 = one
+
+ do ir=1,NGLLX
+ flagxprime = lagrange_deriv_GLL(ir-1,ix_source-1,xigll,NGLLX)
+ a11(ir,iz_source) = a11(ir,iz_source) + sig0*xix(ix_source,iz_source,ispec_source)*flagxprime
+ a12(ir,iz_source) = a12(ir,iz_source) + sig0*xiz(ix_source,iz_source,ispec_source)*flagxprime
+ enddo
+
+ do is=1,NGLLZ
+ flagzprime = lagrange_deriv_GLL(is-1,iz_source-1,zigll,NGLLZ)
+ a11(ix_source,is) = a11(ix_source,is) + sig0*gammax(ix_source,iz_source,ispec_source)*flagzprime
+ a12(ix_source,is) = a12(ix_source,is) + sig0*gammaz(ix_source,iz_source,ispec_source)*flagzprime
+ enddo
+
+ endif
+
+ end subroutine defarrays
+
Added: seismo/2D/SPECFEM2D/trunk/define_derivative_matrices.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/define_derivative_matrices.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/define_derivative_matrices.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,61 @@
+
+!========================================================================
+!
+! 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 define_derivative_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz)
+
+ implicit none
+
+ include "constants.h"
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLZ) :: zigll
+
+! weights
+ double precision, dimension(NGLLX) :: wxgll
+ 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
+
+! function for calculating derivatives of Lagrange polynomials
+ double precision, external :: lagrange_deriv_GLL
+
+ integer i1,i2,k1,k2
+
+! set up coordinates of the Gauss-Lobatto-Legendre points
+ call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
+
+! if number of points is odd, the middle abscissa is exactly zero
+ if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO
+ if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO
+
+! calculate derivatives of the Lagrange polynomials
+! and precalculate some products in double precision
+! hprime(i,j) = h'_i(xigll_j) by definition of the derivative matrix
+ do i1=1,NGLLX
+ do i2=1,NGLLX
+ hprime_xx(i1,i2) = lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)
+ enddo
+ enddo
+
+ do k1=1,NGLLZ
+ do k2=1,NGLLZ
+ hprime_zz(k1,k2) = lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)
+ enddo
+ enddo
+
+ end subroutine define_derivative_matrices
+
Added: seismo/2D/SPECFEM2D/trunk/define_shape_functions.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/define_shape_functions.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/define_shape_functions.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,139 @@
+
+!========================================================================
+!
+! 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 define_shape_functions(shape2D,dershape2D,xi,gamma,ngnod)
+
+!=======================================================================
+!
+! Set up the shape functions for the subparametric transformation.
+! The routine can handle 4 or 9 control nodes defined as follows:
+!
+! 4 . . . . 7 . . . . 3
+! . .
+! . t .
+! . .
+! 8 9 s 6
+! . .
+! . .
+! . .
+! 1 . . . . 5 . . . . 2
+!
+! Local coordinate system : s,t
+!
+!=======================================================================
+
+ implicit none
+
+ include "constants.h"
+
+ integer ngnod
+
+ double precision shape2D(ngnod)
+ double precision dershape2D(NDIM,ngnod)
+ double precision xi,gamma
+
+ double precision s,t,sp,sm,tp,tm,s2,t2,ss,tt,st
+
+!
+!---- set up the shape functions and their local derivatives
+!
+ s = xi
+ t = gamma
+
+!---- 4-node element
+ if(ngnod == 4) then
+ sp = s + ONE
+ sm = s - ONE
+ tp = t + ONE
+ tm = t - ONE
+
+!---- corner nodes
+ shape2D(1) = QUART * sm * tm
+ shape2D(2) = - QUART * sp * tm
+ shape2D(3) = QUART * sp * tp
+ shape2D(4) = - QUART * sm * tp
+
+ dershape2D(1,1) = QUART * tm
+ dershape2D(1,2) = - QUART * tm
+ dershape2D(1,3) = QUART * tp
+ dershape2D(1,4) = - QUART * tp
+
+ dershape2D(2,1) = QUART * sm
+ dershape2D(2,2) = - QUART * sp
+ dershape2D(2,3) = QUART * sp
+ dershape2D(2,4) = - QUART * sm
+
+!---- 9-node element
+ else if(ngnod == 9) then
+
+ sp = s + ONE
+ sm = s - ONE
+ tp = t + ONE
+ tm = t - ONE
+ s2 = s * TWO
+ t2 = t * TWO
+ ss = s * s
+ tt = t * t
+ st = s * t
+
+!---- corner nodes
+ shape2D(1) = QUART * sm * st * tm
+ shape2D(2) = QUART * sp * st * tm
+ shape2D(3) = QUART * sp * st * tp
+ shape2D(4) = QUART * sm * st * tp
+
+ dershape2D(1,1) = QUART * tm * t * (s2 - ONE)
+ dershape2D(1,2) = QUART * tm * t * (s2 + ONE)
+ dershape2D(1,3) = QUART * tp * t * (s2 + ONE)
+ dershape2D(1,4) = QUART * tp * t * (s2 - ONE)
+
+ dershape2D(2,1) = QUART * sm * s * (t2 - ONE)
+ dershape2D(2,2) = QUART * sp * s * (t2 - ONE)
+ dershape2D(2,3) = QUART * sp * s * (t2 + ONE)
+ dershape2D(2,4) = QUART * sm * s * (t2 + ONE)
+
+!---- midside nodes
+ shape2D(5) = HALF * tm * t * (ONE - ss)
+ shape2D(6) = HALF * sp * s * (ONE - tt)
+ shape2D(7) = HALF * tp * t * (ONE - ss)
+ shape2D(8) = HALF * sm * s * (ONE - tt)
+
+ dershape2D(1,5) = -ONE * st * tm
+ dershape2D(1,6) = HALF * (ONE - tt) * (s2 + ONE)
+ dershape2D(1,7) = -ONE * st * tp
+ dershape2D(1,8) = HALF * (ONE - tt) * (s2 - ONE)
+
+ dershape2D(2,5) = HALF * (ONE - ss) * (t2 - ONE)
+ dershape2D(2,6) = -ONE * st * sp
+ dershape2D(2,7) = HALF * (ONE - ss) * (t2 + ONE)
+ dershape2D(2,8) = -ONE * st * sm
+
+!---- center node
+ shape2D(9) = (ONE - ss) * (ONE - tt)
+
+ dershape2D(1,9) = -ONE * s2 * (ONE - tt)
+ dershape2D(2,9) = -ONE * t2 * (ONE - ss)
+
+ else
+ stop 'Error: wrong number of control nodes'
+ endif
+
+!--- check the shape functions and their derivatives
+! sum of shape functions should be one
+! sum of derivaticves of shape functions should be zero
+ if(abs(sum(shape2D)-ONE) > TINYVAL) stop 'error shape functions'
+ if(abs(sum(dershape2D(1,:))) > TINYVAL) stop 'error deriv xi shape functions'
+ if(abs(sum(dershape2D(2,:))) > TINYVAL) stop 'error deriv gamma shape functions'
+
+ end subroutine define_shape_functions
+
Added: seismo/2D/SPECFEM2D/trunk/gll_library.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/gll_library.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/gll_library.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,529 @@
+
+!=======================================================================
+!
+! Library to compute the Gauss-Lobatto-Legendre points and weights
+! Based on Gauss-Lobatto routines from M.I.T.
+! Department of Mechanical Engineering
+!
+!=======================================================================
+
+ double precision function endw1(n,alpha,beta)
+
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+ double precision, external :: gammaf
+ integer i
+
+ f3 = zero
+ apb = alpha+beta
+ if(n == 0) then
+ endw1 = zero
+ return
+ endif
+ f1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if(n == 1) then
+ endw1 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (-two*(beta+two)*fint1 + (apb+four)*fint2) * (apb+three)/four
+ if(n == 2) then
+ endw1 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw1 = f3
+
+ end function endw1
+
+!
+!=======================================================================
+!
+
+ double precision function endw2(n,alpha,beta)
+
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+ double precision, external :: gammaf
+ integer i
+
+ apb = alpha+beta
+ f3 = zero
+ if (n == 0) then
+ endw2 = zero
+ return
+ endif
+ f1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if (n == 1) then
+ endw2 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (two*(alpha+two)*fint1 - (apb+four)*fint2) * (apb+three)/four
+ if (n == 2) then
+ endw2 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw2 = f3
+
+ end function endw2
+
+!
+!=======================================================================
+!
+
+ double precision function gammaf (x)
+
+ implicit none
+
+ double precision, parameter :: pi = 3.141592653589793d0
+
+ double precision x
+
+ double precision, parameter :: half=0.5d0,one=1.d0,two=2.d0
+
+ gammaf = one
+
+ if (x == -half) gammaf = -two*sqrt(pi)
+ if (x == half) gammaf = sqrt(pi)
+ if (x == one ) gammaf = one
+ if (x == two ) gammaf = one
+ if (x == 1.5d0) gammaf = sqrt(pi)/2.d0
+ if (x == 2.5d0) gammaf = 1.5d0*sqrt(pi)/2.d0
+ if (x == 3.5d0) gammaf = 2.5d0*1.5d0*sqrt(pi)/2.d0
+ if (x == 3.d0 ) gammaf = 2.d0
+ if (x == 4.d0 ) gammaf = 6.d0
+ if (x == 5.d0 ) gammaf = 24.d0
+ if (x == 6.d0 ) gammaf = 120.d0
+
+ end function gammaf
+
+!
+!=====================================================================
+!
+
+ subroutine jacg (xjac,np,alpha,beta)
+
+!=======================================================================
+!
+! computes np Gauss points, which are the zeros of the
+! Jacobi polynomial with parameters alpha and beta
+!
+! .alpha = beta = 0.0 -> Legendre points
+! .alpha = beta = -0.5 -> Chebyshev points
+!
+!=======================================================================
+
+ implicit none
+
+ integer np
+ double precision alpha,beta
+ double precision xjac(np)
+
+ integer k,j,i,jmin,jm,n
+ double precision xlast,dth,x,x1,x2,recsum,delx,xmin,swap
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+
+ integer, parameter :: K_MAX_ITER = 10
+ double precision, parameter :: zero = 0.d0, eps = 1.0d-12
+
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ xlast = 0.d0
+ n = np-1
+ dth = 4.d0*atan(1.d0)/(2.d0*dble(n)+2.d0)
+ p = 0.d0
+ pd = 0.d0
+ jmin = 0
+ do j=1,np
+ if(j == 1) then
+ x = cos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
+ else
+ x1 = cos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
+ x2 = xlast
+ x = (x1+x2)/2.d0
+ endif
+ do k=1,K_MAX_ITER
+ call jacobf (p,pd,pm1,pdm1,pm2,pdm2,np,alpha,beta,x)
+ recsum = 0.d0
+ jm = j-1
+ do i=1,jm
+ recsum = recsum+1.d0/(x-xjac(np-i+1))
+ enddo
+ delx = -p/(pd-recsum*p)
+ x = x+delx
+ if(abs(delx) < eps) goto 31
+ enddo
+ 31 continue
+ xjac(np-j+1) = x
+ xlast = x
+ enddo
+ do i=1,np
+ xmin = 2.d0
+ do j=i,np
+ if(xjac(j) < xmin) then
+ xmin = xjac(j)
+ jmin = j
+ endif
+ enddo
+ if(jmin /= i) then
+ swap = xjac(i)
+ xjac(i) = xjac(jmin)
+ xjac(jmin) = swap
+ endif
+ enddo
+
+ end subroutine jacg
+
+!
+!=====================================================================
+!
+
+ subroutine jacobf (poly,pder,polym1,pderm1,polym2,pderm2,n,alp,bet,x)
+
+!=======================================================================
+!
+! Computes the Jacobi polynomial of degree n and its derivative at x
+!
+!=======================================================================
+
+ implicit none
+
+ double precision poly,pder,polym1,pderm1,polym2,pderm2,alp,bet,x
+ integer n
+
+ double precision apb,polyl,pderl,dk,a1,a2,b3,a3,a4,polyn,pdern,psave,pdsave
+ integer k
+
+ apb = alp+bet
+ poly = 1.d0
+ pder = 0.d0
+ psave = 0.d0
+ pdsave = 0.d0
+
+ if (n == 0) return
+
+ polyl = poly
+ pderl = pder
+ poly = (alp-bet+(apb+2.d0)*x)/2.d0
+ pder = (apb+2.d0)/2.d0
+ if (n == 1) return
+
+ do k=2,n
+ dk = dble(k)
+ a1 = 2.d0*dk*(dk+apb)*(2.d0*dk+apb-2.d0)
+ a2 = (2.d0*dk+apb-1.d0)*(alp**2-bet**2)
+ b3 = (2.d0*dk+apb-2.d0)
+ a3 = b3*(b3+1.d0)*(b3+2.d0)
+ a4 = 2.d0*(dk+alp-1.d0)*(dk+bet-1.d0)*(2.d0*dk+apb)
+ polyn = ((a2+a3*x)*poly-a4*polyl)/a1
+ pdern = ((a2+a3*x)*pder-a4*pderl+a3*poly)/a1
+ psave = polyl
+ pdsave = pderl
+ polyl = poly
+ poly = polyn
+ pderl = pder
+ pder = pdern
+ enddo
+
+ polym1 = polyl
+ pderm1 = pderl
+ polym2 = psave
+ pderm2 = pdsave
+
+ end subroutine jacobf
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision FUNCTION PNDLEG (Z,N)
+
+!------------------------------------------------------------------------
+!
+! Compute the derivative of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!------------------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P1D,P2D,P3D,FK,P3
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P1D = 0.d0
+ P2D = 1.d0
+ P3D = 1.d0
+
+ do K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P3D = ((2.d0*FK+1.d0)*P2 + (2.d0*FK+1.d0)*Z*P2D - FK*P1D) / (FK+1.d0)
+ P1 = P2
+ P2 = P3
+ P1D = P2D
+ P2D = P3D
+ enddo
+
+ PNDLEG = P3D
+
+ end function pndleg
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision FUNCTION PNLEG (Z,N)
+
+!------------------------------------------------------------------------
+!
+! Compute the value of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!------------------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P3,FK
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P3 = P2
+
+ do K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P1 = P2
+ P2 = P3
+ enddo
+
+ PNLEG = P3
+
+ end function pnleg
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision function pnormj (n,alpha,beta)
+
+ implicit none
+
+ double precision alpha,beta
+ integer n
+
+ double precision one,two,dn,const,prod,dindx,frac
+ double precision, external :: gammaf
+ integer i
+
+ one = 1.d0
+ two = 2.d0
+ dn = dble(n)
+ const = alpha+beta+one
+
+ if (n <= 1) then
+ prod = gammaf(dn+alpha)*gammaf(dn+beta)
+ prod = prod/(gammaf(dn)*gammaf(dn+alpha+beta))
+ pnormj = prod * two**const/(two*dn+const)
+ return
+ endif
+
+ prod = gammaf(alpha+one)*gammaf(beta+one)
+ prod = prod/(two*(one+const)*gammaf(const+one))
+ prod = prod*(one+alpha)*(two+alpha)
+ prod = prod*(one+beta)*(two+beta)
+
+ do i=3,n
+ dindx = dble(i)
+ frac = (dindx+alpha)*(dindx+beta)/(dindx*(dindx+alpha+beta))
+ prod = prod*frac
+ enddo
+
+ pnormj = prod * two**const/(two*dn+const)
+
+ end function pnormj
+
+!
+!------------------------------------------------------------------------
+!
+
+ subroutine zwgjd(z,w,np,alpha,beta)
+
+!=======================================================================
+!
+! Z w g j d : Generate np Gauss-Jacobi points and weights
+! associated with Jacobi polynomial of degree n = np-1
+!
+! Note : Coefficients alpha and beta must be greater than -1.
+! ----
+!=======================================================================
+
+ implicit none
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision z(np),w(np)
+ double precision alpha,beta
+
+ integer n,np1,np2,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision apb,dnp1,dnp2,fac1,fac2,fac3,fnorm,rcoef
+ double precision, external :: gammaf,pnormj
+
+ pd = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ apb = alpha+beta
+ p = zero
+ pdm1 = zero
+
+ if (np <= 0) stop 'minimum number of Gauss points is 1'
+
+ if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
+
+ if (np == 1) then
+ z(1) = (beta-alpha)/(apb+two)
+ w(1) = gammaf(alpha+one)*gammaf(beta+one)/gammaf(apb+two) * two**(apb+one)
+ return
+ endif
+
+ call jacg(z,np,alpha,beta)
+
+ np1 = n+1
+ np2 = n+2
+ dnp1 = dble(np1)
+ dnp2 = dble(np2)
+ fac1 = dnp1+alpha+beta+one
+ fac2 = fac1+dnp1
+ fac3 = fac2+one
+ fnorm = pnormj(np1,alpha,beta)
+ rcoef = (fnorm*fac2*fac3)/(two*fac1*dnp2)
+ do i=1,np
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,np2,alpha,beta,z(i))
+ w(i) = -rcoef/(p*pdm1)
+ enddo
+
+ end subroutine zwgjd
+
+!
+!------------------------------------------------------------------------
+!
+
+ subroutine zwgljd(z,w,np,alpha,beta)
+
+!=======================================================================
+!
+! Z w g l j d : Generate np Gauss-Lobatto-Jacobi points and the
+! ----------- weights associated with Jacobi polynomials of degree
+! n = np-1.
+!
+! Note : alpha and beta coefficients must be greater than -1.
+! Legendre polynomials are special case of Jacobi polynomials
+! just by setting alpha and beta to 0.
+!
+!=======================================================================
+
+ implicit none
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision alpha,beta
+ double precision z(np), w(np)
+
+ integer n,nm1,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision alpg,betg
+ double precision, external :: endw1,endw2
+
+ p = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ nm1 = n-1
+ pd = zero
+
+ if (np <= 1) stop 'minimum number of Gauss-Lobatto points is 2'
+
+! with spectral elements, use at least 3 points
+ if (np <= 2) stop 'minimum number of Gauss-Lobatto points for the SEM is 3'
+
+ if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
+
+ if (nm1 > 0) then
+ alpg = alpha+one
+ betg = beta+one
+ call zwgjd(z(2),w(2),nm1,alpg,betg)
+ endif
+
+ z(1) = - one
+ z(np) = one
+
+ do i=2,np-1
+ w(i) = w(i)/(one-z(i)**2)
+ enddo
+
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(1))
+ w(1) = endw1(n,alpha,beta)/(two*pd)
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(np))
+ w(np) = endw2(n,alpha,beta)/(two*pd)
+
+ end subroutine zwgljd
+
Added: seismo/2D/SPECFEM2D/trunk/gmat01.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/gmat01.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/gmat01.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,148 @@
+
+!========================================================================
+!
+! 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 gmat01(density_array,elastcoef,numat)
+
+! read properties of a 2D isotropic or anisotropic linear elastic element
+
+ implicit none
+
+ include "constants.h"
+
+ character(len=80) datlin
+ double precision lambdaplus2mu,kappa
+
+ integer numat
+ double precision density_array(numat),elastcoef(4,numat)
+
+ integer in,n,indic
+ double precision young,poisson,density,cp,cs,mu,two_mu,lambda
+ double precision val1,val2,val3,val4
+ double precision c11,c13,c33,c44
+
+!
+!---- loop over the different material sets
+!
+ density_array(:) = zero
+ elastcoef(:,:) = zero
+
+ write(iout,100) numat
+
+ read(iin ,40) datlin
+ do in = 1,numat
+
+ read(iin ,*) n,indic,density,val1,val2,val3,val4
+
+ if(n<1 .or. n>numat) stop 'Wrong material set number'
+
+!---- materiau isotrope, vitesse P et vitesse S donnees
+ if(indic == 0) then
+
+! P and S velocity
+ cp = val1
+ cs = val2
+
+! Lam'e parameters
+ lambdaplus2mu = density*cp*cp
+ mu = density*cs*cs
+ two_mu = 2.d0*mu
+ lambda = lambdaplus2mu - two_mu
+
+! bulk modulus K
+ kappa = lambda + two_mu/3.d0
+
+! Young modulus
+ young = 9.d0*kappa*mu/(3.d0*kappa + mu)
+
+! Poisson's ratio
+ poisson = half*(3.d0*kappa-two_mu)/(3.d0*kappa+mu)
+
+! 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
+ c11 = val1
+ c13 = val2
+ c33 = val3
+ c44 = val4
+
+ endif
+
+!
+!---- set elastic coefficients and density
+!
+! Isotropic : lambda, mu, K (= lambda + 2*mu), zero
+! Transverse anisotropic : c11, c13, c33, c44
+!
+ if(indic == 0 .or. indic == 1) then
+ elastcoef(1,n) = lambda
+ elastcoef(2,n) = mu
+ elastcoef(3,n) = lambdaplus2mu
+ elastcoef(4,n) = zero
+ else
+ elastcoef(1,n) = c11
+ elastcoef(2,n) = c13
+ elastcoef(3,n) = c33
+ elastcoef(4,n) = c44
+ endif
+
+ density_array(n) = density
+
+!
+!---- check the input
+!
+ if(indic == 0 .or. indic == 1) then
+ write(iout,200) n,cp,cs,density,poisson,lambda,mu,kappa,young
+ else
+ write(iout,300) n,c11,c13,c33,c44,density, &
+ sqrt(c33/density),sqrt(c11/density),sqrt(c44/density),sqrt(c44/density)
+ endif
+
+ enddo
+
+!
+!---- formats
+!
+ 40 format(a80)
+ 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) =',i5)
+ 200 format(//5x,'------------------------',/5x, &
+ '-- Isotropic material --',/5x, &
+ '------------------------',/5x, &
+ 'Material set number. . . . . . . . (jmat) =',i5,/5x, &
+ 'P-wave velocity. . . . . . . . . . . (cp) =',1pe15.8,/5x, &
+ 'S-wave velocity. . . . . . . . . . . (cs) =',1pe15.8,/5x, &
+ 'Mass density. . . . . . . . . . (density) =',1pe15.8,/5x, &
+ '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, &
+ 'Young''s modulus E. . . . . . . . .(young) =',1pe15.8)
+ 300 format(//5x,'-------------------------------------',/5x, &
+ '-- Transverse anisotropic material --',/5x, &
+ '-------------------------------------',/5x, &
+ 'Material set number. . . . . . . . (jmat) =',i5,/5x, &
+ 'c11 coefficient (Pascal). . . . . . (c11) =',1pe15.8,/5x, &
+ 'c13 coefficient (Pascal). . . . . . (c13) =',1pe15.8,/5x, &
+ 'c33 coefficient (Pascal). . . . . . (c33) =',1pe15.8,/5x, &
+ 'c44 coefficient (Pascal). . . . . . (c44) =',1pe15.8,/5x, &
+ 'Mass density. . . . . . . . . . (density) =',1pe15.8,/5x, &
+ 'Velocity of qP along vertical axis. . . . =',1pe15.8,/5x, &
+ 'Velocity of qP along horizontal axis. . . =',1pe15.8,/5x, &
+ 'Velocity of qSV along vertical axis . . . =',1pe15.8,/5x, &
+ 'Velocity of qSV along horizontal axis . . =',1pe15.8)
+
+ end subroutine gmat01
+
Added: seismo/2D/SPECFEM2D/trunk/lagrange_poly.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/lagrange_poly.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/lagrange_poly.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,131 @@
+
+!========================================================================
+!
+! 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
+!
+!========================================================================
+
+ double precision function hgll(I,Z,ZGLL,NZ)
+
+!-------------------------------------------------------------
+!
+! Compute the value of the Lagrangian interpolant L through
+! the NZ Gauss-Lobatto Legendre points ZGLL at point Z
+!
+!-------------------------------------------------------------
+
+ implicit none
+
+ integer i,nz
+ double precision z
+ double precision ZGLL(0:nz-1)
+
+ integer n
+ double precision EPS,DZ,ALFAN
+ double precision, external :: PNLEG,PNDLEG
+
+ EPS = 1.d-5
+ DZ = Z - ZGLL(I)
+ if(abs(DZ) < EPS) then
+ HGLL = 1.d0
+ return
+ endif
+ N = NZ - 1
+ ALFAN = dble(N)*(dble(N)+1.d0)
+ HGLL = - (1.d0-Z*Z)*PNDLEG(Z,N)/ (ALFAN*PNLEG(ZGLL(I),N)*(Z-ZGLL(I)))
+
+ end function hgll
+
+!
+!=====================================================================
+!
+
+ subroutine lagrange_any(xi,NGLL,xigll,h,hprime)
+
+! subroutine to compute the Lagrange interpolants based upon the GLL points
+! and their first derivatives at any point xi in [-1,1]
+
+ implicit none
+
+ integer NGLL
+ double precision xi,xigll(NGLL),h(NGLL),hprime(NGLL)
+
+ integer dgr,i,j
+ double precision prod1,prod2
+
+ do dgr=1,NGLL
+
+ prod1 = 1.0d0
+ prod2 = 1.0d0
+ do i=1,NGLL
+ if(i /= dgr) then
+ prod1 = prod1*(xi-xigll(i))
+ prod2 = prod2*(xigll(dgr)-xigll(i))
+ endif
+ enddo
+ h(dgr)=prod1/prod2
+
+ hprime(dgr)=0.0d0
+ do i=1,NGLL
+ if(i /= dgr) then
+ prod1=1.0d0
+ do j=1,NGLL
+ if(j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j))
+ enddo
+ hprime(dgr) = hprime(dgr)+prod1
+ endif
+ enddo
+ hprime(dgr) = hprime(dgr)/prod2
+
+ enddo
+
+ end subroutine lagrange_any
+
+!
+!=====================================================================
+!
+
+! subroutine to compute the derivative of the Lagrange interpolants
+! at the GLL points at any given GLL point
+
+ double precision function lagrange_deriv_GLL(I,j,ZGLL,NZ)
+
+!------------------------------------------------------------------------
+!
+! Compute the value of the derivative of the I-th
+! Lagrange interpolant through the
+! NZ Gauss-Lobatto Legendre points ZGLL at point ZGLL(j)
+!
+!------------------------------------------------------------------------
+
+ implicit none
+
+ integer i,j,nz
+ double precision zgll(0:nz-1)
+
+ integer degpoly
+
+ double precision, external :: pnleg,pndleg
+
+ degpoly = nz - 1
+ if (i == 0 .and. j == 0) then
+ lagrange_deriv_GLL = - dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
+ else if (i == degpoly .and. j == degpoly) then
+ lagrange_deriv_GLL = dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
+ else if (i == j) then
+ lagrange_deriv_GLL = 0.d0
+ else
+ lagrange_deriv_GLL = pnleg(zgll(j),degpoly) / &
+ (pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))) &
+ + (1.d0-zgll(j)*zgll(j))*pndleg(zgll(j),degpoly) / (dble(degpoly)* &
+ (dble(degpoly)+1.d0)*pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))*(zgll(j)-zgll(i)))
+ endif
+
+ end function lagrange_deriv_GLL
+
Added: seismo/2D/SPECFEM2D/trunk/locate_receivers.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/locate_receivers.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/locate_receivers.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,196 @@
+
+!========================================================================
+!
+! 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
+!
+!========================================================================
+
+!----
+!---- locate_receivers finds the correct position of the receivers
+!----
+
+ subroutine 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)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nrec,nspec,npoin,ngnod,npgeo
+
+ integer knods(ngnod,nspec)
+ double precision coorg(NDIM,npgeo)
+
+ integer, dimension(NGLLX,NGLLZ,nspec) :: ibool
+
+! array containing coordinates of the points
+ double precision coord(NDIM,npoin)
+
+ integer nrec_dummy,irec,i,j,ispec,iglob,iter_loop,ix_initial_guess,iz_initial_guess
+
+ double precision x_source,z_source,dist,stele,stbur,distance_receiver
+ double precision xi,gamma,dx,dz,dxi,dgamma
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision xigll(NGLLX)
+ double precision zigll(NGLLZ)
+
+ double precision x,z,xix,xiz,gammax,gammaz,jacobian
+
+! use dynamic allocation
+ double precision distmin
+ double precision, dimension(:), allocatable :: final_distance
+
+! receiver information
+ integer, dimension(nrec) :: ispec_selected_rec
+ double precision, dimension(nrec) :: xi_receiver,gamma_receiver
+
+! station information for writing the seismograms
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+
+ double precision, dimension(nrec) :: st_xval,st_zval
+
+! **************
+
+ write(IOUT,*)
+ write(IOUT,*) '********************'
+ write(IOUT,*) ' locating receivers'
+ write(IOUT,*) '********************'
+ write(IOUT,*)
+ write(IOUT,*) 'reading receiver information from the DATA/STATIONS file'
+ write(IOUT,*)
+
+! get number of stations from receiver file
+ open(unit=1,file='DATA/STATIONS',status='old')
+ read(1,*) nrec_dummy
+
+ if(nrec_dummy /= nrec) stop 'problem with number of receivers'
+
+! allocate memory for arrays using number of stations
+ allocate(final_distance(nrec))
+
+! loop on all the stations
+ do irec=1,nrec
+
+! set distance to huge initial value
+ distmin=HUGEVAL
+
+ 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'
+
+! compute distance between source and receiver
+ distance_receiver = sqrt((st_zval(irec)-z_source)**2 + (st_xval(irec)-x_source)**2)
+
+ do ispec=1,nspec
+
+! loop only on points inside the element
+! exclude edges to ensure this point is not shared with other elements
+ do j=2,NGLLZ-1
+ do i=2,NGLLX-1
+
+ iglob = ibool(i,j,ispec)
+ dist = sqrt((st_xval(irec)-dble(coord(1,iglob)))**2 + (st_zval(irec)-dble(coord(2,iglob)))**2)
+
+! keep this point if it is closer to the receiver
+ if(dist < distmin) then
+ distmin = dist
+ ispec_selected_rec(irec) = ispec
+ ix_initial_guess = i
+ iz_initial_guess = j
+ endif
+
+ enddo
+ enddo
+
+! end of loop on all the spectral elements
+ enddo
+
+! ****************************************
+! find the best (xi,gamma) for each receiver
+! ****************************************
+
+! use initial guess in xi and gamma
+ xi = xigll(ix_initial_guess)
+ gamma = zigll(iz_initial_guess)
+
+! iterate to solve the non linear system
+ do iter_loop = 1,NUM_ITER
+
+! recompute jacobian for the new point
+ call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian,coorg,knods,ispec_selected_rec(irec),ngnod,nspec,npgeo)
+
+! compute distance to target location
+ dx = - (x - st_xval(irec))
+ dz = - (z - st_zval(irec))
+
+! compute increments
+ dxi = xix*dx + xiz*dz
+ dgamma = gammax*dx + gammaz*dz
+
+! update values
+ xi = xi + dxi
+ gamma = gamma + dgamma
+
+! impose that we stay in that element
+! (useful if user gives a receiver outside the mesh for instance)
+! we can go slightly outside the [1,1] segment since with finite elements
+! the polynomial solution is defined everywhere
+! this can be useful for convergence of itertive scheme with distorted elements
+ if (xi > 1.10d0) xi = 1.10d0
+ if (xi < -1.10d0) xi = -1.10d0
+ if (gamma > 1.10d0) gamma = 1.10d0
+ if (gamma < -1.10d0) gamma = -1.10d0
+
+! end of non linear iterations
+ enddo
+
+! compute final coordinates of point found
+ call recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian,coorg,knods,ispec_selected_rec(irec),ngnod,nspec,npgeo)
+
+! store xi,gamma of point found
+ xi_receiver(irec) = xi
+ gamma_receiver(irec) = gamma
+
+! compute final distance between asked and found
+ final_distance(irec) = sqrt((st_xval(irec)-x)**2 + (st_zval(irec)-z)**2)
+
+ write(IOUT,*)
+ write(IOUT,*) 'Station # ',irec,' ',station_name(irec),network_name(irec)
+
+ if(final_distance(irec) == HUGEVAL) stop 'error locating receiver'
+
+ write(IOUT,*) ' original x: ',sngl(st_xval(irec))
+ write(IOUT,*) ' original z: ',sngl(st_zval(irec))
+ write(IOUT,*) ' distance from source: ',sngl(distance_receiver)
+
+ write(IOUT,*) 'closest estimate found: ',sngl(final_distance(irec)),' m away'
+ write(IOUT,*) ' in element ',ispec_selected_rec(irec)
+ write(IOUT,*) ' at xi,gamma coordinates = ',xi_receiver(irec),gamma_receiver(irec)
+ write(IOUT,*)
+
+ enddo
+
+! close receiver file
+ close(1)
+
+! display maximum error for all the receivers
+ write(IOUT,*) 'maximum error in location of all the receivers: ',sngl(maxval(final_distance(:))),' m'
+
+ write(IOUT,*)
+ write(IOUT,*) 'end of receiver detection'
+ write(IOUT,*)
+
+! deallocate arrays
+ deallocate(final_distance)
+
+ end subroutine locate_receivers
+
Added: seismo/2D/SPECFEM2D/trunk/maille_non_struct_2.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/maille_non_struct_2.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/maille_non_struct_2.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,962 @@
+!=====================================================================
+!
+! P r e m a i l l e u r F o r t r a n 9 0
+! -------------------------------------------
+!
+! Version 3.0
+! -----------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+!
+! (c) August 1998
+!
+!=====================================================================
+
+!
+! *** Version optimisee avec maillage non structure Jacques Muller - Elf ***
+! *** Raffinement d'un facteur 2 en surface ***
+!
+
+ program maille_non_struct_2
+
+ implicit none
+
+! definir les tableaux pour allocation dynamique
+
+! coordinates of the grid points
+ double precision, allocatable :: x(:,:),z(:,:)
+
+! variables needed to compute the transformation
+ double precision, allocatable :: psi(:),eta(:),absx(:), &
+ a00(:),a01(:),valeta(:),bot0(:),top0(:)
+
+! stockage du modele de vitesse et densite
+ double precision, allocatable :: rho(:),cp(:),cs(:)
+
+! the topography data
+ double precision, allocatable :: xtopo(:),ztopo(:),coefs_topo(:)
+
+! arrays for the source
+ double precision, allocatable :: xs(:),zs(:),f0(:),t0(:),angle(:),factor(:)
+ integer, allocatable :: isource_type(:),itimetype(:)
+
+! arrays for the receivers
+ double precision, allocatable :: xrec(:),zrec(:)
+
+ character(len=50) interffile,topofile,title
+ character(len=15) junk
+
+ integer imatnum,inumabs,inumelem,nelemperio,nxgll,netyp
+ integer icodehaut,icodebas,icodegauche,icodedroite
+ integer nelemabs,npgeo,nspec,ntopo,nspecvolume,nspecWz
+ integer k,ix,iz,irec,i,j,iadd
+ integer imodele,nbmodeles,iaffinfo
+ integer itaff,itfirstaff,iptsdisp,isubsamp,nrec,n1ana,n2ana
+ integer irepr,nrec1,nrec2,isamp,nbsources,isismostype,ivecttype
+ integer ngnod,nt,niter,idegpoly,nx,nz
+ integer icodematread
+
+ double precision valseuil,freqmaxrep,ratio
+ double precision tang1,tangN
+ double precision orig_x,orig_z,sizemax,cutvect,scalex,scalez
+ double precision factorxsu,factorana,xspacerec,zspacerec
+ double precision anglerec,anglerec2,xmin,xmax
+ double precision xfin,zfin,xfin2,zfin2,xdeb,zdeb,xdeb2,zdeb2
+ double precision alphanewm,betanewm,gammanewm,dt
+ double precision rhoread,cpread,csread,aniso3read,aniso4read
+
+ logical interpol,ignuplot,ireadmodel,iavs,ivisual3,ioutputgrid
+ logical abshaut,absbas,absgauche,absdroite,absstacey
+ logical periohaut,periogauche
+ logical sismos,isources_surf,ienreg_surf,ienreg_surf2,display
+ logical ivectplot,imeshvect
+ logical topoplane,iexec,initialfield
+ logical imodelvect,iboundvect,usletter,compenergy
+
+ integer, external :: num
+ double precision, external :: bottom,spl,dens
+
+ double precision, parameter :: zero = 0.d0, one = 1.d0
+
+! simulation a 2D
+ integer, parameter :: ndime = 2
+ integer, parameter :: ndofn = 2
+
+! --- code des numeros d'aretes pour les bords absorbants
+ integer, parameter :: iaretebas = 1
+ integer, parameter :: iaretedroite = 2
+ integer, parameter :: iaretehaut = 3
+ integer, parameter :: iaretegauche = 4
+
+! DK DK DK ajout Elf : extraction de la topo du fichier SEP
+!! call system('rm -f topo_from_SEP.dat topo_SEP_maille90.dat ; xextract_topo')
+
+ print *
+ print *,' *** Version optimisee avec maillage non structure ***'
+ print *,' *** Raffinement d''un facteur 2 en surface ***'
+ print *
+
+! ***
+! *** read the parameter file
+! ***
+
+ print *,' Reading the parameter file ... '
+ print *
+
+ open(unit=10,file='DATA/Par_file',status='old')
+
+! formats
+ 1 format(a,f12.5)
+ 2 format(a,i8)
+ 3 format(a,a)
+ 4 format(a,l8)
+
+! read the header
+ do i=1,10
+ read(10,*)
+ enddo
+
+! read file names and path for output
+ read(10,3)junk,title
+ read(10,3)junk,topofile
+ read(10,3)junk,interffile
+
+ write(*,*) 'Titre de la simulation'
+ write(*,*) title
+ print *
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read grid parameters
+ read(10,1)junk,xmin
+ read(10,1)junk,xmax
+ read(10,2)junk,nx
+ read(10,2)junk,nz
+ read(10,2)junk,idegpoly
+ read(10,2)junk,ngnod
+ read(10,1)junk,ratio
+ read(10,4)junk,topoplane
+ read(10,4)junk,initialfield
+ read(10,4)junk,ireadmodel
+ read(10,4)junk,iexec
+
+! DK DK forcer pour Elf
+ ngnod = 9
+ topoplane = .false.
+ initialfield = .false.
+
+! pour le non structure, verifier la coherence du maillage
+ if(nx < 2) stop 'nx must be greater or equal to 2'
+ if(nz < 2) stop 'nz must be greater or equal to 2'
+ if(mod(nx,2) /= 0) stop 'nx must be even'
+
+! multiplier par 2 pour implementer le deraffinement non conforme
+ nx = nx * 2
+ nz = nz * 2
+
+! multiplier par 2 pour elements 9 noeuds
+ nx = nx * 2
+ nz = nz * 2
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read absorbing boundaries parameters
+ read(10,4)junk,abshaut
+ read(10,4)junk,absbas
+ read(10,4)junk,absgauche
+ read(10,4)junk,absdroite
+ read(10,4)junk,absstacey
+ read(10,4)junk,periohaut
+ read(10,4)junk,periogauche
+
+! DK DK forcer pour Elf
+ abshaut = .false.
+ periohaut = .false.
+ periogauche = .false.
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read time step parameters
+ read(10,2)junk,nt
+ read(10,1)junk,dt
+ read(10,2)junk,niter
+ read(10,1)junk,alphanewm
+ read(10,1)junk,betanewm
+ read(10,1)junk,gammanewm
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read source parameters
+ read(10,2)junk,nbsources
+ read(10,4)junk,isources_surf
+ read(10,1)junk,valseuil
+ read(10,1)junk,freqmaxrep
+ print *,'Nb de sources a lire : ',nbsources
+
+ allocate(xs(nbsources))
+ allocate(zs(nbsources))
+ allocate(f0(nbsources))
+ allocate(t0(nbsources))
+ allocate(isource_type(nbsources))
+ allocate(itimetype(nbsources))
+ allocate(angle(nbsources))
+ allocate(factor(nbsources))
+
+ do i=1,nbsources
+ read(10,*)
+ read(10,1)junk,xs(i)
+ read(10,1)junk,zs(i)
+ read(10,1)junk,f0(i)
+ read(10,1)junk,t0(i)
+ read(10,2)junk,isource_type(i)
+ read(10,2)junk,itimetype(i)
+ read(10,1)junk,angle(i)
+ read(10,1)junk,factor(i)
+
+ print *
+ print *,' Source #',i
+ print *,'Position xs, zs = ',xs(i),zs(i)
+ print *,'Frequency, delay = ',f0(i),t0(i)
+ print *,'Source type (1=force 2=explo) : ', &
+ isource_type(i)
+ print *,'Angle of the source if force = ',angle(i)
+ print *,'Multiplying factor = ',factor(i)
+ enddo
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read receivers line parameters
+ read(10,4)junk,sismos
+ read(10,2)junk,isamp
+ read(10,2)junk,isismostype
+ read(10,2)junk,irepr
+ read(10,*)
+ read(10,2)junk,nrec1
+ read(10,1)junk,xdeb
+ read(10,1)junk,zdeb
+ read(10,1)junk,xfin
+ read(10,1)junk,zfin
+ read(10,4)junk,ienreg_surf
+ read(10,1)junk,anglerec
+ read(10,*)
+ read(10,2)junk,nrec2
+ read(10,1)junk,xdeb2
+ read(10,1)junk,zdeb2
+ read(10,1)junk,xfin2
+ read(10,1)junk,zfin2
+ read(10,4)junk,ienreg_surf2
+ read(10,1)junk,anglerec2
+ read(10,*)
+ read(10,1)junk,factorxsu
+ read(10,2)junk,n1ana
+ read(10,2)junk,n2ana
+ read(10,1)junk,factorana
+
+! determination et affichage position ligne de receivers
+ if(nrec2 < 0) stop 'negative value of nrec2 !'
+
+ if(nrec2 == 0) then
+ nrec = nrec1
+ else
+ nrec = nrec1 + nrec2
+ endif
+
+! DK DK forcer pour Elf
+ n1ana = 1
+ n2ana = nrec
+
+ allocate(xrec(nrec))
+ allocate(zrec(nrec))
+
+ if(nrec2 == 0) then
+ print *
+ print *,'There are ',nrec,' receivers on a single line'
+ xspacerec=(xfin-xdeb)/dble(nrec-1)
+ zspacerec=(zfin-zdeb)/dble(nrec-1)
+ do i=1,nrec
+ xrec(i) = xdeb + dble(i-1)*xspacerec
+ zrec(i) = zdeb + dble(i-1)*zspacerec
+ enddo
+ else
+ print *
+ print *,'There are ',nrec,' receivers on two lines'
+ print *,'First line contains ',nrec1,' receivers'
+ print *,'Second line contains ',nrec2,' receivers'
+ xspacerec=(xfin-xdeb)/dble(nrec1-1)
+ zspacerec=(zfin-zdeb)/dble(nrec1-1)
+ do i=1,nrec1
+ xrec(i) = xdeb + dble(i-1)*xspacerec
+ zrec(i) = zdeb + dble(i-1)*zspacerec
+ enddo
+ xspacerec=(xfin2-xdeb2)/dble(nrec2-1)
+ zspacerec=(zfin2-zdeb2)/dble(nrec2-1)
+ do i=1,nrec2
+ xrec(i+nrec1) = xdeb2 + dble(i-1)*xspacerec
+ zrec(i+nrec1) = zdeb2 + dble(i-1)*zspacerec
+ enddo
+ endif
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read display parameters
+ read(10,4)junk,display
+ read(10,2)junk,itaff
+ read(10,2)junk,itfirstaff
+ read(10,2)junk,iaffinfo
+ read(10,4)junk,ivectplot
+ read(10,2)junk,ivecttype
+ read(10,1)junk,cutvect
+ read(10,4)junk,imeshvect
+ read(10,4)junk,imodelvect
+ read(10,4)junk,iboundvect
+ read(10,4)junk,interpol
+ read(10,2)junk,iptsdisp
+ read(10,2)junk,isubsamp
+ read(10,1)junk,scalex
+ read(10,1)junk,scalez
+ read(10,1)junk,sizemax
+ read(10,4)junk,usletter
+ read(10,1)junk,orig_x
+ read(10,1)junk,orig_z
+ read(10,4)junk,ignuplot
+ read(10,4)junk,iavs
+ read(10,4)junk,ivisual3
+ read(10,4)junk,ioutputgrid
+ read(10,4)junk,compenergy
+
+! DK DK forcer pour Elf
+ ignuplot = .false.
+ iavs = .false.
+ ivisual3 = .false.
+ compenergy = .false.
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! lecture des differents modeles de materiaux
+
+ read(10,2)junk,nbmodeles
+ if(nbmodeles <= 0) stop 'Negative number of models not allowed !!'
+
+ allocate(rho(nbmodeles))
+ allocate(cp(nbmodeles))
+ allocate(cs(nbmodeles))
+
+ rho(:) = 0.d0
+ cp(:) = 0.d0
+ cs(:) = 0.d0
+
+ do imodele=1,nbmodeles
+ read(10,*) i,icodematread,rhoread,cpread,csread,aniso3read,aniso4read
+ if(i<1 .or. i>nbmodeles) stop 'Wrong material set number'
+ rho(i) = rhoread
+ cp(i) = cpread
+ cs(i) = csread
+ if (rho(i) < 0.d0 .or. cp(i) < 0.d0 .or. cs(i) < 0.d0) &
+ stop 'Negative value of velocity or density'
+ enddo
+
+ print *
+ print *, 'Nb de modeles de roche = ',nbmodeles
+ print *
+ do i=1,nbmodeles
+ print *,'Modele #',i,' isotrope'
+ print *,'rho,cp,cs = ',rho(i),cp(i),cs(i)
+ enddo
+ print *
+
+ close(10)
+
+ print *
+ print *,' Parameter file successfully read... '
+
+! --------- fin lecture fichier parametres --------------
+
+ allocate(psi(0:nx))
+ allocate(eta(0:nz))
+ allocate(absx(0:nx))
+ allocate(a00(0:nz))
+ allocate(a01(0:nz))
+ allocate(valeta(0:nz))
+ allocate(bot0(0:nx))
+ allocate(top0(0:nx))
+
+! calcul des points regulierement espaces
+ do i=0,nx
+ psi(i) = i/dble(nx)
+ enddo
+ do j=0,nz
+ eta(j) = j/dble(nz)
+ enddo
+
+! quelques verifications de base a faire
+
+ if(ngnod /= 9) stop 'erreur ngnod different de 9 !!'
+
+! calcul du nombre total d'elements spectraux, absorbants et periodiques
+ nspecvolume = (nx/2/2)*((nz-4)/2/2)
+ nspecWz = 3*(nx/2/2)
+ nspec = nspecvolume + nspecWz
+ nelemperio = 0
+
+ if(absgauche .or. absdroite .or. absbas) then
+ nelemabs = 2 * (nz/4 - 2) + nx/4 + 2 + 2
+ else
+ nelemabs = 0
+ endif
+
+ print *
+ print *,'Le maillage comporte ',nspec,' elements spectraux (nx = ',nx/4, &
+ ' nz = ',nz/4,')'
+ print *,'soit ',nspecvolume,' elements spectraux dans le volume'
+ print *,'et ',nspecWz,' elements spectraux dans la couche Wz'
+ print *,'Chaque element comporte ',idegpoly+1,' points dans chaque direction'
+ print *,'Le nombre maximum de points theorique est ',nspec*(idegpoly+1)**ndime
+ print *,'Les elements de controle sont des elements ',ngnod,' noeuds'
+ print *
+
+!------------------------------------------------------
+
+ allocate(x(0:nx,0:nz))
+ allocate(z(0:nx,0:nz))
+
+ x(:,:)=0.d0
+ z(:,:)=0.d0
+
+! get topography data from external file
+ print *,'Reading topography from file ',topofile
+ open(unit=15,file=topofile,status='old')
+ read(15,*) ntopo
+ if (ntopo < 2) stop 'Not enough topography points (min 2)'
+ print *,'Reading ',ntopo,' points from topography file'
+ print *
+
+ allocate(xtopo(ntopo))
+ allocate(ztopo(ntopo))
+ allocate(coefs_topo(ntopo))
+
+ do i=1,ntopo
+ read(15,*) xtopo(i),ztopo(i)
+ enddo
+ close(15)
+
+! check the values read
+ print *
+ print *, 'Topography data points (x,z)'
+ print *, '----------------------------'
+ print *
+ print *, 'Topo 1 = (',xtopo(1),',',ztopo(1),')'
+ print *, 'Topo ntopo = (',xtopo(ntopo),',',ztopo(ntopo),')'
+
+!--- calculate the spline function for the topography
+!--- imposer les tangentes aux deux bords
+ tang1 = (ztopo(2)-ztopo(1))/(xtopo(2)-xtopo(1))
+ tangN = (ztopo(ntopo)-ztopo(ntopo-1))/(xtopo(ntopo)-xtopo(ntopo-1))
+ call spline(xtopo,ztopo,ntopo,tang1,tangN,coefs_topo)
+
+! *** afficher limites du modele lu
+ print *
+ print *, 'Limites absolues modele fichier topo :'
+ print *
+ print *, 'Xmin = ',minval(xtopo),' Xmax = ',maxval(xtopo)
+ print *, 'Zmin = ',minval(ztopo),' Zmax = ',maxval(ztopo)
+ print *
+
+! *** modifier sources pour position par rapport a la surface
+ print *
+ print *, 'Position (x,z) des ',nbsources,' sources'
+ print *
+ do i=1,nbsources
+
+! DK DK DK Elf : position source donnee en profondeur par rapport a la topo
+ zs(i) = spl(xs(i),xtopo,ztopo,coefs_topo,ntopo) - zs(i)
+
+ if(isources_surf) zs(i) = spl(xs(i),xtopo,ztopo,coefs_topo,ntopo)
+ print *, 'Source ',i,' = ',xs(i),zs(i)
+ enddo
+
+! *** modifier recepteurs pour enregistrement en surface
+ print *
+ print *, 'Position (x,z) des ',nrec,' receivers'
+ print *
+ do irec=1,nrec
+
+! DK DK DK Elf : distinguer les deux lignes de recepteurs
+ if(irec <= nrec1) then
+ if(ienreg_surf) zrec(irec) = spl(xrec(irec),xtopo,ztopo,coefs_topo,ntopo)
+ else
+ if(ienreg_surf2) zrec(irec) = spl(xrec(irec),xtopo,ztopo,coefs_topo,ntopo)
+ endif
+ print *, 'Receiver ',irec,' = ',xrec(irec),zrec(irec)
+
+ enddo
+
+!--- definition du maillage suivant X
+ do ix=0,nx
+ absx(ix) = dens(ix,psi,xmin,xmax,nx)
+ enddo
+
+! *** une seule zone
+
+ do iz=0,nz
+
+! DK DK DK densification sinusoidale ici en vertical
+ valeta(iz) = eta(iz) + ratio * sin(3.14159265 * eta(iz))
+ if(valeta(iz) < zero) valeta(iz) = zero
+ if(valeta(iz) > one ) valeta(iz) = one
+! DK DK DK densification sinusoidale ici en vertical
+
+ a00(iz) = 1-valeta(iz)
+ a01(iz) = valeta(iz)
+ enddo
+
+ do ix=0,nx
+ bot0(ix) = bottom(absx(ix))
+ top0(ix) = spl(absx(ix),xtopo,ztopo,coefs_topo,ntopo)
+ enddo
+
+! valeurs de x et y pour display domaine physique
+ do ix=0,nx
+ do iz=0,nz
+ x(ix,iz) = absx(ix)
+ z(ix,iz) = a00(iz)*bot0(ix) + a01(iz)*top0(ix)
+ enddo
+ enddo
+
+! calculer min et max de X et Z sur la grille
+ 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 *
+
+! *** generation de la base de donnees
+
+ print *
+ print *,' Creation de la base de donnees pour SPECFEM...'
+ print *
+
+ open(unit=15,file='../SPECFEM90/DataBase',status='unknown')
+
+ write(15,*) '#'
+ write(15,*) '# Base de Donnees pour Specfem - Premailleur Fortran 90'
+ write(15,*) '# ',title
+ write(15,*) '# Dimitri Komatitsch, (c) EPS - Harvard August 1998'
+ write(15,*) '#'
+
+ write(15,*) 'Titre simulation'
+ write(15,40) title
+
+ npgeo = (nx+1)*(nz+1)
+ write(15,*) 'ndofn ndime npgeo'
+ write(15,*) ndofn,ndime,npgeo
+
+ write(15,*) 'display ignuplot interpol'
+ write(15,*) display,ignuplot,interpol
+
+ write(15,*) 'itaff itfirstaff icolor inumber'
+ write(15,*) itaff,itfirstaff,0,0
+
+ write(15,*) 'ivectplot imeshvect imodelvect iboundvect cutvect isubsamp'
+ write(15,*) ivectplot,imeshvect,imodelvect,iboundvect,cutvect,isubsamp
+
+ write(15,*) 'scalex scalez sizemax angle rapport USletter'
+ write(15,*) scalex,scalez,sizemax,20.,0.40,usletter
+
+ write(15,*) 'orig_x orig_z isymbols'
+ write(15,*) orig_x,orig_z,' T'
+
+ write(15,*) 'valseuil freqmaxrep'
+ write(15,*) valseuil,freqmaxrep
+
+ write(15,*) 'sismos nrec nrec1 nrec2 isamp'
+ write(15,*) sismos,nrec,nrec1,nrec2,isamp
+
+ write(15,*) 'irepr anglerec anglerec2'
+ write(15,*) irepr,anglerec,anglerec2
+
+ write(15,*) 'topoplane absstacey compenergy'
+ write(15,*) topoplane,absstacey,compenergy
+
+ write(15,*) 'initialfield factorana factorxsu n1ana n2ana'
+ write(15,*) initialfield,factorana,factorxsu,n1ana,n2ana
+
+ write(15,*) 'isismostype ivecttype iaffinfo'
+ write(15,*) isismostype,ivecttype,iaffinfo
+
+ write(15,*) 'ireadmodel ioutputgrid iavs ivisual3'
+ write(15,*) ireadmodel,ioutputgrid,iavs,ivisual3
+
+ write(15,*) 'iexec iecho'
+ if(iexec) then
+ write(15,*) '1 1'
+ else
+ write(15,*) '0 1'
+ endif
+
+ write(15,*) 'ncycl dtinc niter'
+ write(15,*) nt,dt,niter
+
+ write(15,*) 'alpha beta gamma (alpha not used for the moment)'
+ write(15,*) alphanewm,betanewm,gammanewm
+
+ write(15,*) 'nltfl (number of force or pressure sources)'
+ write(15,*) nbsources
+
+ write(15,*) 'Collocated forces and/or pressure sources:'
+ do i=1,nbsources
+ write(15,*) itimetype(i),isource_type(i), &
+ xs(i)-xmin ,zs(i), &
+ f0(i),t0(i),factor(i),angle(i),0
+ enddo
+
+ write(15,*) 'Receivers positions:'
+ do irec=1,nrec
+ write(15,*) irec,xrec(irec)-xmin ,zrec(irec)
+ enddo
+
+ write(15,*) 'Coordinates of macroblocs mesh (coorg):'
+ do j=0,nz
+ do i=0,nx
+ write(15,*) num(i,j,nx),x(i,j)-xmin,z(i,j)
+ enddo
+ enddo
+
+ netyp = 2
+ nxgll = idegpoly + 1
+
+ write(15,*) 'netyp numat ngnod nxgll nygll nspec iptsdisp ielemabs ielemperio'
+ write(15,*) netyp,nbmodeles,ngnod,nxgll,nxgll,nspec,iptsdisp, &
+ nelemabs,nelemperio
+
+ write(15,*) 'Material sets (num 0 rho vp vs 0 0)'
+ do i=1,nbmodeles
+ write(15,*) i,0,rho(i),cp(i),cs(i),0,0
+ enddo
+
+
+ write(15,*) 'Arrays kmato and knods for each bloc:'
+
+ imatnum = 1
+ k=0
+
+! zone structuree dans le volume
+ do j=0,nz-8,4
+ do i=0,nx-4,4
+ k = k + 1
+ write(15,*) k,imatnum,num(i,j,nx),num(i+4,j,nx),num(i+4,j+4,nx), &
+ num(i,j+4,nx),num(i+2,j,nx),num(i+4,j+2,nx), &
+ num(i+2,j+4,nx),num(i,j+2,nx),num(i+2,j+2,nx)
+ enddo
+ enddo
+
+ if(k /= nspecvolume) stop 'nombre d''elements incoherent dans le volume'
+
+! zone non structuree dans la couche Wz
+ j=nz-4
+ do i=0,nx-8,8
+
+! element 1 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i,j,nx),num(i+4,j,nx),num(i+2,j+2,nx), &
+ num(i,j+2,nx),num(i+2,j,nx),num(i+3,j+1,nx), &
+ num(i+1,j+2,nx),num(i,j+1,nx),num(i+1,j+1,nx)
+
+! element 2 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i,j+2,nx),num(i+2,j+2,nx),num(i+2,j+4,nx), &
+ num(i,j+4,nx),num(i+1,j+2,nx),num(i+2,j+3,nx), &
+ num(i+1,j+4,nx),num(i,j+3,nx),num(i+1,j+3,nx)
+
+! element 3 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+2,j+2,nx),num(i+4,j,nx),num(i+4,j+4,nx), &
+ num(i+2,j+4,nx),num(i+3,j+1,nx),num(i+4,j+2,nx), &
+ num(i+3,j+4,nx),num(i+2,j+3,nx),num(i+3,j+3,nx)
+
+! element 4 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+4,j,nx),num(i+6,j+2,nx),num(i+6,j+4,nx), &
+ num(i+4,j+4,nx),num(i+5,j+1,nx),num(i+6,j+3,nx), &
+ num(i+5,j+4,nx),num(i+4,j+2,nx),num(i+5,j+3,nx)
+
+! element 5 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+4,j,nx),num(i+8,j,nx),num(i+8,j+2,nx), &
+ num(i+6,j+2,nx),num(i+6,j,nx),num(i+8,j+1,nx), &
+ num(i+7,j+2,nx),num(i+5,j+1,nx),num(i+7,j+1,nx)
+
+! element 6 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+6,j+2,nx),num(i+8,j+2,nx),num(i+8,j+4,nx), &
+ num(i+6,j+4,nx),num(i+7,j+2,nx),num(i+8,j+3,nx), &
+ num(i+7,j+4,nx),num(i+6,j+3,nx),num(i+7,j+3,nx)
+
+ enddo
+
+ if(k /= nspec) stop 'nombre d''elements incoherent dans la couche Wz'
+
+!
+!--- sauvegarde des bords absorbants
+!
+
+ print *
+ print *,'Au total il y a ',nelemabs,' elements absorbants'
+ print *
+ print *,'Bords absorbants actifs :'
+ print *
+ print *,'Haut = ',abshaut
+ print *,'Bas = ',absbas
+ print *,'Gauche = ',absgauche
+ print *,'Droite = ',absdroite
+ print *
+ print *,'Stacey = ',absstacey
+ print *
+
+! generer la liste des elements absorbants
+ if(nelemabs > 0) then
+ write(15,*) 'Liste des elements absorbants (haut bas gauche droite) :'
+
+! repasser aux vrais valeurs de nx et nz
+ nx = nx / 4
+ nz = nz / 4
+
+ inumabs = 0
+
+! bord absorbant du bas sans les coins
+ iz = 1
+ do ix = 2,nx-1
+ inumabs = inumabs + 1
+ inumelem = (iz-1)*nx + ix
+ icodehaut = 0
+ icodebas = iaretebas
+ icodegauche = 0
+ icodedroite = 0
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+! coin en bas a gauche
+ inumabs = inumabs + 1
+ inumelem = 1
+ icodehaut = 0
+ icodebas = iaretebas
+ icodegauche = iaretegauche
+ icodedroite = 0
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+
+! coin en bas a droite
+ inumabs = inumabs + 1
+ inumelem = nx
+ icodehaut = 0
+ icodebas = iaretebas
+ icodegauche = 0
+ icodedroite = iaretedroite
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+
+! partie structuree du bord de gauche
+ ix = 1
+ do iz = 2,nz-1
+ inumabs = inumabs + 1
+ inumelem = (iz-1)*nx + ix
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = iaretegauche
+ icodedroite = 0
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+! partie structuree du bord de droite
+ ix = nx
+ do iz = 2,nz-1
+ inumabs = inumabs + 1
+ inumelem = (iz-1)*nx + ix
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = 0
+ icodedroite = iaretedroite
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+! partie non structuree du bord de gauche (deux elements)
+ do iadd = 1,2
+ inumabs = inumabs + 1
+ inumelem = nx*(nz-1) + iadd
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = iaretegauche
+ icodedroite = 0
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+! partie non structuree du bord de droite (deux elements)
+ do iadd = 1,2
+ inumabs = inumabs + 1
+ inumelem = nspec - iadd + 1
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = 0
+ icodedroite = iaretedroite
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+ if(inumabs /= nelemabs) stop 'nombre d''elements absorbants incoherent'
+
+ endif
+
+! fermer la base de donnees
+
+ close(15)
+
+ 40 format(a50)
+
+ end program maille_non_struct_2
+
+! *****************
+! routines maillage
+! *****************
+
+! --- numero global du noeud
+
+ integer function num(i,j,nx)
+ implicit none
+ integer i,j,nx
+
+ num = j*(nx+1) + i + 1
+
+ end function num
+
+! ------- definition des fonctions representant les interfaces -------
+
+!
+! --- bas du modele
+!
+
+ double precision function bottom(x)
+ implicit none
+ double precision x
+
+ bottom = 0.d0
+
+ end function bottom
+
+!
+! --- representation interfaces par un spline
+!
+
+!--- spline
+ double precision function spl(x,xtopo,ztopo,coefs,ntopo)
+ implicit none
+ integer ntopo
+ double precision x,xp
+ double precision xtopo(ntopo),ztopo(ntopo)
+ double precision coefs(ntopo)
+
+ spl = 0.
+ xp = x
+ if (xp < xtopo(1)) xp = xtopo(1)
+ if (xp > xtopo(ntopo)) xp = xtopo(ntopo)
+ call splint(xtopo,ztopo,coefs,ntopo,xp,spl)
+
+ end function spl
+
+! --- fonction de densification du maillage horizontal
+
+ double precision function dens(ix,psi,xmin,xmax,nx)
+ implicit none
+ integer ix,nx
+ double precision psi(0:nx)
+ double precision xmin,xmax
+
+ dens = xmin + dble(xmax-xmin)*psi(ix)
+
+ end function dens
+
+! --------------------------------------
+
+! routine de calcul des coefs du spline (Numerical Recipes)
+ subroutine spline(x,y,n,yp1,ypn,y2)
+ implicit none
+
+ integer n
+ double precision x(n),y(n),y2(n)
+ double precision, dimension(:), allocatable :: u
+ double precision yp1,ypn
+
+ integer i,k
+ double precision sig,p,qn,un
+
+ allocate(u(n))
+
+ y2(1)=-0.5
+ u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
+ do i=2,n-1
+ sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
+ p=sig*y2(i-1)+2.
+ y2(i)=(sig-1.)/p
+ u(i)=(6.*((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.5
+ un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
+ y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
+ do k=n-1,1,-1
+ y2(k)=y2(k)*y2(k+1)+u(k)
+ enddo
+
+ deallocate(u)
+
+ end subroutine spline
+
+! --------------
+
+! routine d'evaluation du spline (Numerical Recipes)
+ SUBROUTINE SPLINT(XA,YA,Y2A,N,X,Y)
+ implicit none
+
+ integer n
+ double precision XA(N),YA(N),Y2A(N)
+ double precision x,y
+
+ integer k,klo,khi
+ double precision h,a,b
+
+ KLO=1
+ KHI=N
+ do while (KHI-KLO > 1)
+ K=(KHI+KLO)/2
+ IF(XA(K) > X)THEN
+ KHI=K
+ ELSE
+ KLO=K
+ ENDIF
+ enddo
+ H=XA(KHI)-XA(KLO)
+ IF (H == 0.d0) stop 'Bad input in spline evaluation'
+ A=(XA(KHI)-X)/H
+ B=(X-XA(KLO))/H
+
+ Y=A*YA(KLO)+B*YA(KHI)+((A**3-A)*Y2A(KLO)+ &
+ (B**3-B)*Y2A(KHI))*(H**2)/6.d0
+
+ end subroutine SPLINT
+
Added: seismo/2D/SPECFEM2D/trunk/maille_non_struct_3.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/maille_non_struct_3.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/maille_non_struct_3.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,985 @@
+!=====================================================================
+!
+! P r e m a i l l e u r F o r t r a n 9 0
+! -------------------------------------------
+!
+! Version 3.0
+! -----------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+!
+! (c) August 1998
+!
+!=====================================================================
+
+!
+! *** Version optimisee avec maillage non structure Jacques Muller - Elf ***
+! *** Raffinement d'un facteur 3 en surface ***
+!
+
+ program maille_non_struct_3
+
+ implicit none
+
+! definir les tableaux pour allocation dynamique
+
+! coordinates of the grid points
+ double precision, allocatable :: x(:,:),z(:,:)
+
+! variables needed to compute the transformation
+ double precision, allocatable :: psi(:),eta(:),absx(:), &
+ a00(:),a01(:),valeta(:),bot0(:),top0(:)
+
+! stockage du modele de vitesse et densite
+ double precision, allocatable :: rho(:),cp(:),cs(:)
+
+! the topography data
+ double precision, allocatable :: xtopo(:),ztopo(:),coefs_topo(:)
+
+! arrays for the source
+ double precision, allocatable :: xs(:),zs(:),f0(:),t0(:),angle(:),factor(:)
+ integer, allocatable :: isource_type(:),itimetype(:)
+
+! arrays for the receivers
+ double precision, allocatable :: xrec(:),zrec(:)
+
+ character(len=50) interffile,topofile,title
+ character(len=15) junk
+
+ integer imatnum,inumabs,inumelem,nelemperio,nxgll,netyp
+ integer icodehaut,icodebas,icodegauche,icodedroite
+ integer nelemabs,npgeo,nspec,ntopo,nspecvolume,nspecWz
+ integer k,ix,iz,irec,i,j,iadd
+ integer imodele,nbmodeles,iaffinfo
+ integer itaff,itfirstaff,iptsdisp,isubsamp,nrec,n1ana,n2ana
+ integer irepr,nrec1,nrec2,isamp,nbsources,isismostype,ivecttype
+ integer ngnod,nt,niter,idegpoly,nx,nz
+ integer icodematread
+
+ double precision valseuil,freqmaxrep,ratio
+ double precision tang1,tangN
+ double precision orig_x,orig_z,sizemax,cutvect,scalex,scalez
+ double precision factorxsu,factorana,xspacerec,zspacerec
+ double precision anglerec,anglerec2,xmin,xmax
+ double precision xfin,zfin,xfin2,zfin2,xdeb,zdeb,xdeb2,zdeb2
+ double precision alphanewm,betanewm,gammanewm,dt
+ double precision rhoread,cpread,csread,aniso3read,aniso4read
+
+ logical interpol,ignuplot,ireadmodel,iavs,ivisual3,ioutputgrid
+ logical abshaut,absbas,absgauche,absdroite,absstacey
+ logical periohaut,periogauche
+ logical sismos,isources_surf,ienreg_surf,ienreg_surf2,display
+ logical ivectplot,imeshvect
+ logical topoplane,iexec,initialfield
+ logical imodelvect,iboundvect,usletter,compenergy
+
+ integer, external :: num
+ double precision, external :: bottom,spl,dens
+
+ double precision, parameter :: zero = 0.d0, one = 1.d0
+
+! simulation a 2D
+ integer, parameter :: ndime = 2
+ integer, parameter :: ndofn = 2
+
+! --- code des numeros d'aretes pour les bords absorbants
+ integer, parameter :: iaretebas = 1
+ integer, parameter :: iaretedroite = 2
+ integer, parameter :: iaretehaut = 3
+ integer, parameter :: iaretegauche = 4
+
+! DK DK DK ajout Elf : extraction de la topo du fichier SEP
+!! call system('rm -f topo_from_SEP.dat topo_SEP_maille90.dat ; xextract_topo')
+
+ print *
+ print *,' *** Version optimisee avec maillage non structure ***'
+ print *,' *** Raffinement d''un facteur 3 en surface ***'
+ print *
+
+! ***
+! *** read the parameter file
+! ***
+
+ print *,' Reading the parameter file ... '
+ print *
+
+ open(unit=10,file='DATA/Par_file',status='old')
+
+! formats
+ 1 format(a,f12.5)
+ 2 format(a,i8)
+ 3 format(a,a)
+ 4 format(a,l8)
+
+! read the header
+ do i=1,10
+ read(10,*)
+ enddo
+
+! read file names and path for output
+ read(10,3)junk,title
+ read(10,3)junk,topofile
+ read(10,3)junk,interffile
+
+ write(*,*) 'Titre de la simulation'
+ write(*,*) title
+ print *
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read grid parameters
+ read(10,1)junk,xmin
+ read(10,1)junk,xmax
+ read(10,2)junk,nx
+ read(10,2)junk,nz
+ read(10,2)junk,idegpoly
+ read(10,2)junk,ngnod
+ read(10,1)junk,ratio
+ read(10,4)junk,topoplane
+ read(10,4)junk,initialfield
+ read(10,4)junk,ireadmodel
+ read(10,4)junk,iexec
+
+! DK DK forcer pour Elf
+ ngnod = 9
+ topoplane = .false.
+ initialfield = .false.
+
+! pour le non structure, verifier la coherence du maillage
+ if(nx < 2) stop 'nx must be greater or equal to 2'
+ if(nz < 2) stop 'nz must be greater or equal to 2'
+ if(mod(nx,2) /= 0) stop 'nx must be even'
+
+! multiplier par 3 pour implementer le deraffinement non conforme
+ nx = nx * 3
+ nz = nz * 3
+
+! multiplier par 2 pour elements 9 noeuds
+ nx = nx * 2
+ nz = nz * 2
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read absorbing boundaries parameters
+ read(10,4)junk,abshaut
+ read(10,4)junk,absbas
+ read(10,4)junk,absgauche
+ read(10,4)junk,absdroite
+ read(10,4)junk,absstacey
+ read(10,4)junk,periohaut
+ read(10,4)junk,periogauche
+
+! DK DK forcer pour Elf
+ abshaut = .false.
+ periohaut = .false.
+ periogauche = .false.
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read time step parameters
+ read(10,2)junk,nt
+ read(10,1)junk,dt
+ read(10,2)junk,niter
+ read(10,1)junk,alphanewm
+ read(10,1)junk,betanewm
+ read(10,1)junk,gammanewm
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read source parameters
+ read(10,2)junk,nbsources
+ read(10,4)junk,isources_surf
+ read(10,1)junk,valseuil
+ read(10,1)junk,freqmaxrep
+ print *,'Nb de sources a lire : ',nbsources
+
+ allocate(xs(nbsources))
+ allocate(zs(nbsources))
+ allocate(f0(nbsources))
+ allocate(t0(nbsources))
+ allocate(isource_type(nbsources))
+ allocate(itimetype(nbsources))
+ allocate(angle(nbsources))
+ allocate(factor(nbsources))
+
+ do i=1,nbsources
+ read(10,*)
+ read(10,1)junk,xs(i)
+ read(10,1)junk,zs(i)
+ read(10,1)junk,f0(i)
+ read(10,1)junk,t0(i)
+ read(10,2)junk,isource_type(i)
+ read(10,2)junk,itimetype(i)
+ read(10,1)junk,angle(i)
+ read(10,1)junk,factor(i)
+
+ print *
+ print *,' Source #',i
+ print *,'Position xs, zs = ',xs(i),zs(i)
+ print *,'Frequency, delay = ',f0(i),t0(i)
+ print *,'Source type (1=force 2=explo) : ', &
+ isource_type(i)
+ print *,'Angle of the source if force = ',angle(i)
+ print *,'Multiplying factor = ',factor(i)
+ enddo
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read receivers line parameters
+ read(10,4)junk,sismos
+ read(10,2)junk,isamp
+ read(10,2)junk,isismostype
+ read(10,2)junk,irepr
+ read(10,*)
+ read(10,2)junk,nrec1
+ read(10,1)junk,xdeb
+ read(10,1)junk,zdeb
+ read(10,1)junk,xfin
+ read(10,1)junk,zfin
+ read(10,4)junk,ienreg_surf
+ read(10,1)junk,anglerec
+ read(10,*)
+ read(10,2)junk,nrec2
+ read(10,1)junk,xdeb2
+ read(10,1)junk,zdeb2
+ read(10,1)junk,xfin2
+ read(10,1)junk,zfin2
+ read(10,4)junk,ienreg_surf2
+ read(10,1)junk,anglerec2
+ read(10,*)
+ read(10,1)junk,factorxsu
+ read(10,2)junk,n1ana
+ read(10,2)junk,n2ana
+ read(10,1)junk,factorana
+
+! determination et affichage position ligne de receivers
+ if(nrec2 < 0) stop 'negative value of nrec2 !'
+
+ if(nrec2 == 0) then
+ nrec = nrec1
+ else
+ nrec = nrec1 + nrec2
+ endif
+
+! DK DK forcer pour Elf
+ n1ana = 1
+ n2ana = nrec
+
+ allocate(xrec(nrec))
+ allocate(zrec(nrec))
+
+ if(nrec2 == 0) then
+ print *
+ print *,'There are ',nrec,' receivers on a single line'
+ xspacerec=(xfin-xdeb)/dble(nrec-1)
+ zspacerec=(zfin-zdeb)/dble(nrec-1)
+ do i=1,nrec
+ xrec(i) = xdeb + dble(i-1)*xspacerec
+ zrec(i) = zdeb + dble(i-1)*zspacerec
+ enddo
+ else
+ print *
+ print *,'There are ',nrec,' receivers on two lines'
+ print *,'First line contains ',nrec1,' receivers'
+ print *,'Second line contains ',nrec2,' receivers'
+ xspacerec=(xfin-xdeb)/dble(nrec1-1)
+ zspacerec=(zfin-zdeb)/dble(nrec1-1)
+ do i=1,nrec1
+ xrec(i) = xdeb + dble(i-1)*xspacerec
+ zrec(i) = zdeb + dble(i-1)*zspacerec
+ enddo
+ xspacerec=(xfin2-xdeb2)/dble(nrec2-1)
+ zspacerec=(zfin2-zdeb2)/dble(nrec2-1)
+ do i=1,nrec2
+ xrec(i+nrec1) = xdeb2 + dble(i-1)*xspacerec
+ zrec(i+nrec1) = zdeb2 + dble(i-1)*zspacerec
+ enddo
+ endif
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read display parameters
+ read(10,4)junk,display
+ read(10,2)junk,itaff
+ read(10,2)junk,itfirstaff
+ read(10,2)junk,iaffinfo
+ read(10,4)junk,ivectplot
+ read(10,2)junk,ivecttype
+ read(10,1)junk,cutvect
+ read(10,4)junk,imeshvect
+ read(10,4)junk,imodelvect
+ read(10,4)junk,iboundvect
+ read(10,4)junk,interpol
+ read(10,2)junk,iptsdisp
+ read(10,2)junk,isubsamp
+ read(10,1)junk,scalex
+ read(10,1)junk,scalez
+ read(10,1)junk,sizemax
+ read(10,4)junk,usletter
+ read(10,1)junk,orig_x
+ read(10,1)junk,orig_z
+ read(10,4)junk,ignuplot
+ read(10,4)junk,iavs
+ read(10,4)junk,ivisual3
+ read(10,4)junk,ioutputgrid
+ read(10,4)junk,compenergy
+
+! DK DK forcer pour Elf
+ ignuplot = .false.
+ iavs = .false.
+ ivisual3 = .false.
+ compenergy = .false.
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! lecture des differents modeles de materiaux
+
+ read(10,2)junk,nbmodeles
+ if(nbmodeles <= 0) stop 'Negative number of models not allowed !!'
+
+ allocate(rho(nbmodeles))
+ allocate(cp(nbmodeles))
+ allocate(cs(nbmodeles))
+
+ rho(:) = 0.d0
+ cp(:) = 0.d0
+ cs(:) = 0.d0
+
+ do imodele=1,nbmodeles
+ read(10,*) i,icodematread,rhoread,cpread,csread,aniso3read,aniso4read
+ if(i<1 .or. i>nbmodeles) stop 'Wrong material set number'
+ rho(i) = rhoread
+ cp(i) = cpread
+ cs(i) = csread
+ if (rho(i) < 0.d0 .or. cp(i) < 0.d0 .or. cs(i) < 0.d0) &
+ stop 'Negative value of velocity or density'
+ enddo
+
+ print *
+ print *, 'Nb de modeles de roche = ',nbmodeles
+ print *
+ do i=1,nbmodeles
+ print *,'Modele #',i,' isotrope'
+ print *,'rho,cp,cs = ',rho(i),cp(i),cs(i)
+ enddo
+ print *
+
+ close(10)
+
+ print *
+ print *,' Parameter file successfully read... '
+
+! --------- fin lecture fichier parametres --------------
+
+ allocate(psi(0:nx))
+ allocate(eta(0:nz))
+ allocate(absx(0:nx))
+ allocate(a00(0:nz))
+ allocate(a01(0:nz))
+ allocate(valeta(0:nz))
+ allocate(bot0(0:nx))
+ allocate(top0(0:nx))
+
+! calcul des points regulierement espaces
+ do i=0,nx
+ psi(i) = i/dble(nx)
+ enddo
+ do j=0,nz
+ eta(j) = j/dble(nz)
+ enddo
+
+! quelques verifications de base a faire
+
+ if(ngnod /= 9) stop 'erreur ngnod different de 9 !!'
+
+! calcul du nombre total d'elements spectraux, absorbants et periodiques
+ nspecvolume = (nx/2/3)*((nz-6)/2/3)
+ nspecWz = 5*(nx/2/3)
+ nspec = nspecvolume + nspecWz
+ nelemperio = 0
+
+ if(absgauche .or. absdroite .or. absbas) then
+ nelemabs = 2 * (nz/6 - 2) + nx/6 + 3 + 3
+ else
+ nelemabs = 0
+ endif
+
+ print *
+ print *,'Le maillage comporte ',nspec,' elements spectraux (nx = ',nx/6, &
+ ' nz = ',nz/6,')'
+ print *,'soit ',nspecvolume,' elements spectraux dans le volume'
+ print *,'et ',nspecWz,' elements spectraux dans la couche Wz'
+ print *,'Chaque element comporte ',idegpoly+1,' points dans chaque direction'
+ print *,'Le nombre maximum de points theorique est ',nspec*(idegpoly+1)**ndime
+ print *,'Les elements de controle sont des elements ',ngnod,' noeuds'
+ print *
+
+!------------------------------------------------------
+
+ allocate(x(0:nx,0:nz))
+ allocate(z(0:nx,0:nz))
+
+ x(:,:)=0.d0
+ z(:,:)=0.d0
+
+! get topography data from external file
+ print *,'Reading topography from file ',topofile
+ open(unit=15,file=topofile,status='old')
+ read(15,*) ntopo
+ if (ntopo < 2) stop 'Not enough topography points (min 2)'
+ print *,'Reading ',ntopo,' points from topography file'
+ print *
+
+ allocate(xtopo(ntopo))
+ allocate(ztopo(ntopo))
+ allocate(coefs_topo(ntopo))
+
+ do i=1,ntopo
+ read(15,*) xtopo(i),ztopo(i)
+ enddo
+ close(15)
+
+! check the values read
+ print *
+ print *, 'Topography data points (x,z)'
+ print *, '----------------------------'
+ print *
+ print *, 'Topo 1 = (',xtopo(1),',',ztopo(1),')'
+ print *, 'Topo ntopo = (',xtopo(ntopo),',',ztopo(ntopo),')'
+
+!--- calculate the spline function for the topography
+!--- imposer les tangentes aux deux bords
+ tang1 = (ztopo(2)-ztopo(1))/(xtopo(2)-xtopo(1))
+ tangN = (ztopo(ntopo)-ztopo(ntopo-1))/(xtopo(ntopo)-xtopo(ntopo-1))
+ call spline(xtopo,ztopo,ntopo,tang1,tangN,coefs_topo)
+
+! *** afficher limites du modele lu
+ print *
+ print *, 'Limites absolues modele fichier topo :'
+ print *
+ print *, 'Xmin = ',minval(xtopo),' Xmax = ',maxval(xtopo)
+ print *, 'Zmin = ',minval(ztopo),' Zmax = ',maxval(ztopo)
+ print *
+
+! *** modifier sources pour position par rapport a la surface
+ print *
+ print *, 'Position (x,z) des ',nbsources,' sources'
+ print *
+ do i=1,nbsources
+
+! DK DK DK Elf : position source donnee en profondeur par rapport a la topo
+ zs(i) = spl(xs(i),xtopo,ztopo,coefs_topo,ntopo) - zs(i)
+
+ if(isources_surf) zs(i) = spl(xs(i),xtopo,ztopo,coefs_topo,ntopo)
+ print *, 'Source ',i,' = ',xs(i),zs(i)
+ enddo
+
+! *** modifier recepteurs pour enregistrement en surface
+ print *
+ print *, 'Position (x,z) des ',nrec,' receivers'
+ print *
+ do irec=1,nrec
+
+! DK DK DK Elf : distinguer les deux lignes de recepteurs
+ if(irec <= nrec1) then
+ if(ienreg_surf) zrec(irec) = spl(xrec(irec),xtopo,ztopo,coefs_topo,ntopo)
+ else
+ if(ienreg_surf2) zrec(irec) = spl(xrec(irec),xtopo,ztopo,coefs_topo,ntopo)
+ endif
+ print *, 'Receiver ',irec,' = ',xrec(irec),zrec(irec)
+
+ enddo
+
+!--- definition du maillage suivant X
+ do ix=0,nx
+ absx(ix) = dens(ix,psi,xmin,xmax,nx)
+ enddo
+
+! *** une seule zone
+
+ do iz=0,nz
+
+! DK DK DK densification sinusoidale ici en vertical
+ valeta(iz) = eta(iz) + ratio * sin(3.14159265 * eta(iz))
+ if(valeta(iz) < zero) valeta(iz) = zero
+ if(valeta(iz) > one ) valeta(iz) = one
+! DK DK DK densification sinusoidale ici en vertical
+
+ a00(iz) = 1-valeta(iz)
+ a01(iz) = valeta(iz)
+ enddo
+
+ do ix=0,nx
+ bot0(ix) = bottom(absx(ix))
+ top0(ix) = spl(absx(ix),xtopo,ztopo,coefs_topo,ntopo)
+ enddo
+
+! valeurs de x et y pour display domaine physique
+ do ix=0,nx
+ do iz=0,nz
+ x(ix,iz) = absx(ix)
+ z(ix,iz) = a00(iz)*bot0(ix) + a01(iz)*top0(ix)
+ enddo
+ enddo
+
+! calculer min et max de X et Z sur la grille
+ 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 *
+
+! *** generation de la base de donnees
+
+ print *
+ print *,' Creation de la base de donnees pour SPECFEM...'
+ print *
+
+ open(unit=15,file='../SPECFEM90/DataBase',status='unknown')
+
+ write(15,*) '#'
+ write(15,*) '# Base de Donnees pour Specfem - Premailleur Fortran 90'
+ write(15,*) '# ',title
+ write(15,*) '# Dimitri Komatitsch, (c) EPS - Harvard August 1998'
+ write(15,*) '#'
+
+ write(15,*) 'Titre simulation'
+ write(15,40) title
+
+ npgeo = (nx+1)*(nz+1)
+ write(15,*) 'ndofn ndime npgeo'
+ write(15,*) ndofn,ndime,npgeo
+
+ write(15,*) 'display ignuplot interpol'
+ write(15,*) display,ignuplot,interpol
+
+ write(15,*) 'itaff itfirstaff icolor inumber'
+ write(15,*) itaff,itfirstaff,0,0
+
+ write(15,*) 'ivectplot imeshvect imodelvect iboundvect cutvect isubsamp'
+ write(15,*) ivectplot,imeshvect,imodelvect,iboundvect,cutvect,isubsamp
+
+ write(15,*) 'scalex scalez sizemax angle rapport USletter'
+ write(15,*) scalex,scalez,sizemax,20.,0.40,usletter
+
+ write(15,*) 'orig_x orig_z isymbols'
+ write(15,*) orig_x,orig_z,' T'
+
+ write(15,*) 'valseuil freqmaxrep'
+ write(15,*) valseuil,freqmaxrep
+
+ write(15,*) 'sismos nrec nrec1 nrec2 isamp'
+ write(15,*) sismos,nrec,nrec1,nrec2,isamp
+
+ write(15,*) 'irepr anglerec anglerec2'
+ write(15,*) irepr,anglerec,anglerec2
+
+ write(15,*) 'topoplane absstacey compenergy'
+ write(15,*) topoplane,absstacey,compenergy
+
+ write(15,*) 'initialfield factorana factorxsu n1ana n2ana'
+ write(15,*) initialfield,factorana,factorxsu,n1ana,n2ana
+
+ write(15,*) 'isismostype ivecttype iaffinfo'
+ write(15,*) isismostype,ivecttype,iaffinfo
+
+ write(15,*) 'ireadmodel ioutputgrid iavs ivisual3'
+ write(15,*) ireadmodel,ioutputgrid,iavs,ivisual3
+
+ write(15,*) 'iexec iecho'
+ if(iexec) then
+ write(15,*) '1 1'
+ else
+ write(15,*) '0 1'
+ endif
+
+ write(15,*) 'ncycl dtinc niter'
+ write(15,*) nt,dt,niter
+
+ write(15,*) 'alpha beta gamma (alpha not used for the moment)'
+ write(15,*) alphanewm,betanewm,gammanewm
+
+ write(15,*) 'nltfl (number of force or pressure sources)'
+ write(15,*) nbsources
+
+ write(15,*) 'Collocated forces and/or pressure sources:'
+ do i=1,nbsources
+ write(15,*) itimetype(i),isource_type(i), &
+ xs(i)-xmin ,zs(i), &
+ f0(i),t0(i),factor(i),angle(i),0
+ enddo
+
+ write(15,*) 'Receivers positions:'
+ do irec=1,nrec
+ write(15,*) irec,xrec(irec)-xmin ,zrec(irec)
+ enddo
+
+ write(15,*) 'Coordinates of macroblocs mesh (coorg):'
+ do j=0,nz
+ do i=0,nx
+ write(15,*) num(i,j,nx),x(i,j)-xmin,z(i,j)
+ enddo
+ enddo
+
+ netyp = 2
+ nxgll = idegpoly + 1
+
+ write(15,*) 'netyp numat ngnod nxgll nygll nspec iptsdisp ielemabs ielemperio'
+ write(15,*) netyp,nbmodeles,ngnod,nxgll,nxgll,nspec,iptsdisp, &
+ nelemabs,nelemperio
+
+ write(15,*) 'Material sets (num 0 rho vp vs 0 0)'
+ do i=1,nbmodeles
+ write(15,*) i,0,rho(i),cp(i),cs(i),0,0
+ enddo
+
+
+ write(15,*) 'Arrays kmato and knods for each bloc:'
+
+ imatnum = 1
+ k=0
+
+! zone structuree dans le volume
+ do j=0,nz-12,6
+ do i=0,nx-6,6
+ k = k + 1
+ write(15,*) k,imatnum,num(i,j,nx),num(i+6,j,nx),num(i+6,j+6,nx), &
+ num(i,j+6,nx),num(i+3,j,nx),num(i+6,j+3,nx), &
+ num(i+3,j+6,nx),num(i,j+3,nx),num(i+3,j+3,nx)
+ enddo
+ enddo
+
+ if(k /= nspecvolume) stop 'nombre d''elements incoherent dans le volume'
+
+! zone non structuree dans la couche Wz
+ j=nz-6
+ do i=0,nx-12,12
+
+! element 1 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i,j,nx),num(i+6,j,nx),num(i+4,j+2,nx), &
+ num(i,j+2,nx),num(i+3,j,nx),num(i+5,j+1,nx), &
+ num(i+2,j+2,nx),num(i,j+1,nx),num(i+3,j+1,nx)
+
+! element 2 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i,j+2,nx),num(i+4,j+2,nx),num(i+2,j+4,nx), &
+ num(i,j+4,nx),num(i+2,j+2,nx),num(i+3,j+3,nx), &
+ num(i+1,j+4,nx),num(i,j+3,nx),num(i+1,j+3,nx)
+
+! element 3 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i,j+4,nx),num(i+2,j+4,nx),num(i+2,j+6,nx), &
+ num(i,j+6,nx),num(i+1,j+4,nx),num(i+2,j+5,nx), &
+ num(i+1,j+6,nx),num(i,j+5,nx),num(i+1,j+5,nx)
+
+! element 4 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+2,j+4,nx),num(i+4,j+2,nx),num(i+4,j+6,nx), &
+ num(i+2,j+6,nx),num(i+3,j+3,nx),num(i+4,j+4,nx), &
+ num(i+3,j+6,nx),num(i+2,j+5,nx),num(i+3,j+5,nx)
+
+! element 5 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+4,j+2,nx),num(i+6,j,nx),num(i+6,j+6,nx), &
+ num(i+4,j+6,nx),num(i+5,j+1,nx),num(i+6,j+3,nx), &
+ num(i+5,j+6,nx),num(i+4,j+4,nx),num(i+5,j+3,nx)
+
+! element 6 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+6,j,nx),num(i+8,j+2,nx),num(i+8,j+6,nx), &
+ num(i+6,j+6,nx),num(i+7,j+1,nx),num(i+8,j+4,nx), &
+ num(i+7,j+6,nx),num(i+6,j+3,nx),num(i+7,j+3,nx)
+
+! element 7 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+8,j+2,nx),num(i+10,j+4,nx),num(i+10,j+6,nx), &
+ num(i+8,j+6,nx),num(i+9,j+3,nx),num(i+10,j+5,nx), &
+ num(i+9,j+6,nx),num(i+8,j+4,nx),num(i+9,j+4,nx)
+
+! element 8 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+6,j,nx),num(i+12,j,nx),num(i+12,j+2,nx), &
+ num(i+8,j+2,nx),num(i+9,j,nx),num(i+12,j+1,nx), &
+ num(i+10,j+2,nx),num(i+7,j+1,nx),num(i+10,j+1,nx)
+
+! element 9 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+8,j+2,nx),num(i+12,j+2,nx),num(i+12,j+4,nx), &
+ num(i+10,j+4,nx),num(i+10,j+2,nx),num(i+12,j+3,nx), &
+ num(i+11,j+4,nx),num(i+9,j+3,nx),num(i+11,j+3,nx)
+
+! element 10 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+10,j+4,nx),num(i+12,j+4,nx),num(i+12,j+6,nx),&
+ num(i+10,j+6,nx),num(i+11,j+4,nx),num(i+12,j+5,nx), &
+ num(i+11,j+6,nx),num(i+10,j+5,nx),num(i+11,j+5,nx)
+
+ enddo
+
+ if(k /= nspec) stop 'nombre d''elements incoherent dans la couche Wz'
+
+!
+!--- sauvegarde des bords absorbants
+!
+
+ print *
+ print *,'Au total il y a ',nelemabs,' elements absorbants'
+ print *
+ print *,'Bords absorbants actifs :'
+ print *
+ print *,'Haut = ',abshaut
+ print *,'Bas = ',absbas
+ print *,'Gauche = ',absgauche
+ print *,'Droite = ',absdroite
+ print *
+ print *,'Stacey = ',absstacey
+ print *
+
+! generer la liste des elements absorbants
+ if(nelemabs > 0) then
+ write(15,*) 'Liste des elements absorbants (haut bas gauche droite) :'
+
+! repasser aux vrais valeurs de nx et nz
+ nx = nx / 6
+ nz = nz / 6
+
+ inumabs = 0
+
+! bord absorbant du bas sans les coins
+ iz = 1
+ do ix = 2,nx-1
+ inumabs = inumabs + 1
+ inumelem = (iz-1)*nx + ix
+ icodehaut = 0
+ icodebas = iaretebas
+ icodegauche = 0
+ icodedroite = 0
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+! coin en bas a gauche
+ inumabs = inumabs + 1
+ inumelem = 1
+ icodehaut = 0
+ icodebas = iaretebas
+ icodegauche = iaretegauche
+ icodedroite = 0
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+
+! coin en bas a droite
+ inumabs = inumabs + 1
+ inumelem = nx
+ icodehaut = 0
+ icodebas = iaretebas
+ icodegauche = 0
+ icodedroite = iaretedroite
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+
+! partie structuree du bord de gauche
+ ix = 1
+ do iz = 2,nz-1
+ inumabs = inumabs + 1
+ inumelem = (iz-1)*nx + ix
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = iaretegauche
+ icodedroite = 0
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+! partie structuree du bord de droite
+ ix = nx
+ do iz = 2,nz-1
+ inumabs = inumabs + 1
+ inumelem = (iz-1)*nx + ix
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = 0
+ icodedroite = iaretedroite
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+! partie non structuree du bord de gauche (trois elements)
+ do iadd = 1,3
+ inumabs = inumabs + 1
+ inumelem = nx*(nz-1) + iadd
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = iaretegauche
+ icodedroite = 0
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+! partie non structuree du bord de droite (trois elements)
+ do iadd = 1,3
+ inumabs = inumabs + 1
+ inumelem = nspec - iadd + 1
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = 0
+ icodedroite = iaretedroite
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+ if(inumabs /= nelemabs) stop 'nombre d''elements absorbants incoherent'
+
+ endif
+
+! fermer la base de donnees
+
+ close(15)
+
+ 40 format(a50)
+
+ end program maille_non_struct_3
+
+! *****************
+! routines maillage
+! *****************
+
+! --- numero global du noeud
+
+ integer function num(i,j,nx)
+ implicit none
+ integer i,j,nx
+
+ num = j*(nx+1) + i + 1
+
+ end function num
+
+! ------- definition des fonctions representant les interfaces -------
+
+!
+! --- bas du modele
+!
+
+ double precision function bottom(x)
+ implicit none
+ double precision x
+
+ bottom = 0.d0
+
+ end function bottom
+
+!
+! --- representation interfaces par un spline
+!
+
+!--- spline
+ double precision function spl(x,xtopo,ztopo,coefs,ntopo)
+ implicit none
+ integer ntopo
+ double precision x,xp
+ double precision xtopo(ntopo),ztopo(ntopo)
+ double precision coefs(ntopo)
+
+ spl = 0.
+ xp = x
+ if (xp < xtopo(1)) xp = xtopo(1)
+ if (xp > xtopo(ntopo)) xp = xtopo(ntopo)
+ call splint(xtopo,ztopo,coefs,ntopo,xp,spl)
+
+ end function spl
+
+! --- fonction de densification du maillage horizontal
+
+ double precision function dens(ix,psi,xmin,xmax,nx)
+ implicit none
+ integer ix,nx
+ double precision psi(0:nx)
+ double precision xmin,xmax
+
+ dens = xmin + dble(xmax-xmin)*psi(ix)
+
+ end function dens
+
+! --------------------------------------
+
+! routine de calcul des coefs du spline (Numerical Recipes)
+ subroutine spline(x,y,n,yp1,ypn,y2)
+ implicit none
+
+ integer n
+ double precision x(n),y(n),y2(n)
+ double precision, dimension(:), allocatable :: u
+ double precision yp1,ypn
+
+ integer i,k
+ double precision sig,p,qn,un
+
+ allocate(u(n))
+
+ y2(1)=-0.5
+ u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
+ do i=2,n-1
+ sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
+ p=sig*y2(i-1)+2.
+ y2(i)=(sig-1.)/p
+ u(i)=(6.*((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.5
+ un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
+ y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
+ do k=n-1,1,-1
+ y2(k)=y2(k)*y2(k+1)+u(k)
+ enddo
+
+ deallocate(u)
+
+ end subroutine spline
+
+! --------------
+
+! routine d'evaluation du spline (Numerical Recipes)
+ SUBROUTINE SPLINT(XA,YA,Y2A,N,X,Y)
+ implicit none
+
+ integer n
+ double precision XA(N),YA(N),Y2A(N)
+ double precision x,y
+
+ integer k,klo,khi
+ double precision h,a,b
+
+ KLO=1
+ KHI=N
+ do while (KHI-KLO > 1)
+ K=(KHI+KLO)/2
+ IF(XA(K) > X)THEN
+ KHI=K
+ ELSE
+ KLO=K
+ ENDIF
+ enddo
+ H=XA(KHI)-XA(KLO)
+ IF (H == 0.d0) stop 'Bad input in spline evaluation'
+ A=(XA(KHI)-X)/H
+ B=(X-XA(KLO))/H
+
+ Y=A*YA(KLO)+B*YA(KHI)+((A**3-A)*Y2A(KLO)+ (B**3-B)*Y2A(KHI))*(H**2)/6.d0
+
+ end subroutine SPLINT
+
Added: seismo/2D/SPECFEM2D/trunk/meshfem2D.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/meshfem2D.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/meshfem2D.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,1053 @@
+
+!========================================================================
+!
+! M E S H F E M 2 D Version 5.1
+! ------------------------------
+!
+! Dimitri Komatitsch
+! Universite de Pau et des Pays de l'Adour, France
+!
+! (c) January 2005
+!
+!========================================================================
+
+!========================================================================
+!
+! Basic mesh generator for SPECFEM2D
+!
+!========================================================================
+
+ program meshfem2D
+
+ implicit none
+
+! coordinates of the grid points of the mesh
+ double precision, dimension(:,:), allocatable :: x,z
+
+! to compute the coordinate transformation
+ integer :: ioffset
+ double precision :: gamma,absx,a00,a01,bot0,top0
+
+! stockage du modele de vitesse et densite
+ double precision, dimension(:), allocatable :: rho,cp,cs,aniso3,aniso4
+ integer, dimension(:), allocatable :: icodemat
+ integer, dimension(:,:), allocatable :: num_modele
+
+! interface data
+ integer interface_current,ipoint_current,number_of_interfaces,npoints_interface_bottom,npoints_interface_top
+ integer ilayer,number_of_layers,max_npoints_interface
+ double precision xinterface_dummy,zinterface_dummy,xinterface_dummy_previous
+ integer, dimension(:), allocatable :: nz_layer
+ double precision, dimension(:), allocatable :: &
+ xinterface_bottom,zinterface_bottom,coefs_interface_bottom, &
+ xinterface_top,zinterface_top,coefs_interface_top
+
+! for the source
+ integer source_type,time_function_type
+ double precision xs,zs,f0,t0,angle,factor
+
+! arrays for the receivers
+ double precision, dimension(:), allocatable :: xrec,zrec
+
+ character(len=50) interfacesfile,title
+
+ integer imatnum,inumabs,inumsurface,inumelem
+ integer nelemabs,nelemsurface,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,nrec
+ integer sismostype,vecttype
+ integer ngnod,nt,nx,nz,nxread,nzread
+ integer icodematread
+
+ logical codehaut,codebas,codegauche,codedroite
+
+ double precision tang1,tangN,vpzone,vszone,poisson_ratio
+ double precision cutvect,xspacerec,zspacerec
+ double precision anglerec,xfin,zfin,xdeb,zdeb,xmin,xmax,dt
+ double precision rhoread,cpread,csread,aniso3read,aniso4read
+
+ logical interpol,gnuplot,readmodel,outputgrid
+ logical abshaut,absbas,absgauche,absdroite
+ logical source_surf,enreg_surf,meshvect,initialfield,modelvect,boundvect
+ logical ELASTIC,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
+
+ integer, external :: num
+ double precision, external :: value_spline
+
+! flag to indicate an anisotropic material
+ integer, parameter :: ANISOTROPIC_MATERIAL = 1
+
+! file number for input DATA/Par_file and interface file
+ integer, parameter :: IIN_PAR = 10
+ integer, parameter :: IIN_INTERFACES = 15
+
+! ignore variable name field (junk) at the beginning of each input line
+ logical, parameter :: IGNORE_JUNK = .true.,DONT_IGNORE_JUNK = .false.
+
+! ***
+! *** read the parameter file
+! ***
+
+ print *,'Reading the parameter file ... '
+ print *
+
+ open(unit=10,file='DATA/Par_file',status='old')
+
+! read file names and path for output
+ call read_value_string(IIN_PAR,IGNORE_JUNK,title)
+ call read_value_string(IIN_PAR,IGNORE_JUNK,interfacesfile)
+
+ write(*,*) 'Titre de la simulation'
+ write(*,*) title
+ print *
+
+! read grid parameters
+ call read_value_double_precision(IIN_PAR,IGNORE_JUNK,xmin)
+ call read_value_double_precision(IIN_PAR,IGNORE_JUNK,xmax)
+ call read_value_integer(IIN_PAR,IGNORE_JUNK,nx)
+ call read_value_integer(IIN_PAR,IGNORE_JUNK,ngnod)
+ call read_value_logical(IIN_PAR,IGNORE_JUNK,initialfield)
+ call read_value_logical(IIN_PAR,IGNORE_JUNK,readmodel)
+ call read_value_logical(IIN_PAR,IGNORE_JUNK,ELASTIC)
+ call read_value_logical(IIN_PAR,IGNORE_JUNK,TURN_ANISOTROPY_ON)
+ call read_value_logical(IIN_PAR,IGNORE_JUNK,TURN_ATTENUATION_ON)
+
+! get interface data from external file to count the spectral elements along Z
+ print *,'Reading interface data from file DATA/',interfacesfile(1:len_trim(interfacesfile)),' to count the spectral elements'
+ open(unit=15,file='DATA/'//interfacesfile,status='old')
+
+ max_npoints_interface = -1
+
+! read number of interfaces
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,number_of_interfaces)
+ if(number_of_interfaces < 2) stop 'not enough interfaces (minimum is 2)'
+
+! loop on all the interfaces
+ do interface_current = 1,number_of_interfaces
+
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,npoints_interface_bottom)
+ if(npoints_interface_bottom < 2) stop 'not enough interface points (minimum is 2)'
+ max_npoints_interface = max(npoints_interface_bottom,max_npoints_interface)
+ print *,'Reading ',npoints_interface_bottom,' points for interface ',interface_current
+
+! loop on all the points describing this interface
+ do ipoint_current = 1,npoints_interface_bottom
+ read(IIN_INTERFACES,*) xinterface_dummy,zinterface_dummy
+ if(ipoint_current > 1 .and. xinterface_dummy <= xinterface_dummy_previous) &
+ stop 'interface points must be sorted in increasing X'
+ xinterface_dummy_previous = xinterface_dummy
+ enddo
+
+ enddo
+
+! define number of layers
+ number_of_layers = number_of_interfaces - 1
+
+ allocate(nz_layer(number_of_layers))
+
+! loop on all the layers
+ do ilayer = 1,number_of_layers
+
+! read number of spectral elements in vertical direction in this layer
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,nz_layer(ilayer))
+ if(nz_layer(ilayer) < 1) stop 'not enough spectral elements along Z in layer (minimum is 1)'
+ print *,'There are ',nz_layer(ilayer),' spectral elements along Z in layer ',ilayer
+
+ enddo
+
+ close(15)
+
+! compute total number of spectral elements in vertical direction
+ nz = sum(nz_layer)
+
+ print *
+ print *,'Total number of spectral elements along Z = ',nz
+ print *
+
+ nxread = nx
+ nzread = nz
+
+! multiplier par 2 si elements 9 noeuds
+ if(ngnod == 9) then
+ nx = nx * 2
+ nz = nz * 2
+ endif
+
+! read absorbing boundaries parameters
+ call read_value_logical(IIN_PAR,IGNORE_JUNK,abshaut)
+ call read_value_logical(IIN_PAR,IGNORE_JUNK,absbas)
+ call read_value_logical(IIN_PAR,IGNORE_JUNK,absgauche)
+ call read_value_logical(IIN_PAR,IGNORE_JUNK,absdroite)
+
+! read time step parameters
+ call read_value_integer(IIN_PAR,IGNORE_JUNK,nt)
+ call read_value_double_precision(IIN_PAR,IGNORE_JUNK,dt)
+
+! read source parameters
+ call read_value_logical(IIN_PAR,IGNORE_JUNK,source_surf)
+ call read_value_double_precision(IIN_PAR,IGNORE_JUNK,xs)
+ call read_value_double_precision(IIN_PAR,IGNORE_JUNK,zs)
+ call read_value_integer(IIN_PAR,IGNORE_JUNK,source_type)
+ call read_value_integer(IIN_PAR,IGNORE_JUNK,time_function_type)
+ call read_value_double_precision(IIN_PAR,IGNORE_JUNK,f0)
+ call read_value_double_precision(IIN_PAR,IGNORE_JUNK,angle)
+ call read_value_double_precision(IIN_PAR,IGNORE_JUNK,factor)
+
+! if Dirac source time function, use a very thin Gaussian instead
+ if(time_function_type == 4) f0 = 1.d0 / (5.d0 * dt)
+
+! time delay of the source in seconds, use a 20 % security margin
+ t0 = 1.20d0 / f0
+
+ print *
+ print *,'Source:'
+ print *,'Position xs, zs = ',xs,zs
+ print *,'Frequency, delay = ',f0,t0
+ print *,'Source type (1=force, 2=explosion): ',source_type
+ print *,'Time function type (1=Ricker, 2=First derivative, 3=Gaussian, 4=Dirac): ',time_function_type
+ print *,'Angle of the source if force = ',angle
+ print *,'Multiplying factor = ',factor
+
+! read receivers line parameters
+ call read_value_logical(IIN_PAR,IGNORE_JUNK,enreg_surf)
+ call read_value_integer(IIN_PAR,IGNORE_JUNK,sismostype)
+ call read_value_integer(IIN_PAR,IGNORE_JUNK,nrec)
+ call read_value_double_precision(IIN_PAR,IGNORE_JUNK,xdeb)
+ call read_value_double_precision(IIN_PAR,IGNORE_JUNK,zdeb)
+ call read_value_double_precision(IIN_PAR,IGNORE_JUNK,xfin)
+ call read_value_double_precision(IIN_PAR,IGNORE_JUNK,zfin)
+ call read_value_double_precision(IIN_PAR,IGNORE_JUNK,anglerec)
+
+ allocate(xrec(nrec))
+ allocate(zrec(nrec))
+
+ print *
+ print *,'There are ',nrec,' receivers'
+ xspacerec = (xfin-xdeb) / dble(nrec-1)
+ zspacerec = (zfin-zdeb) / dble(nrec-1)
+ do i=1,nrec
+ xrec(i) = xdeb + dble(i-1)*xspacerec
+ zrec(i) = zdeb + dble(i-1)*zspacerec
+ enddo
+
+! read display parameters
+ call read_value_integer(IIN_PAR,IGNORE_JUNK,itaff)
+ call read_value_integer(IIN_PAR,IGNORE_JUNK,vecttype)
+ call read_value_double_precision(IIN_PAR,IGNORE_JUNK,cutvect)
+ call read_value_logical(IIN_PAR,IGNORE_JUNK,meshvect)
+ call read_value_logical(IIN_PAR,IGNORE_JUNK,modelvect)
+ call read_value_logical(IIN_PAR,IGNORE_JUNK,boundvect)
+ call read_value_logical(IIN_PAR,IGNORE_JUNK,interpol)
+ call read_value_integer(IIN_PAR,IGNORE_JUNK,pointsdisp)
+ call read_value_integer(IIN_PAR,IGNORE_JUNK,subsamp)
+ call read_value_logical(IIN_PAR,IGNORE_JUNK,gnuplot)
+ call read_value_logical(IIN_PAR,IGNORE_JUNK,outputgrid)
+
+! lecture des differents modeles de materiaux
+ call read_value_integer(IIN_PAR,IGNORE_JUNK,nbmodeles)
+ if(nbmodeles <= 0) stop 'Negative number of models 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))
+
+ icodemat(:) = 0
+ rho(:) = 0.d0
+ cp(:) = 0.d0
+ cs(:) = 0.d0
+ aniso3(:) = 0.d0
+ aniso4(:) = 0.d0
+ num_modele(:,:) = 0
+
+ do imodele=1,nbmodeles
+ read(IIN_PAR,*) i,icodematread,rhoread,cpread,csread,aniso3read,aniso4read
+ if(i < 1 .or. i > nbmodeles) stop 'Wrong model number!!'
+ icodemat(i) = icodematread
+ rho(i) = rhoread
+ cp(i) = cpread
+ cs(i) = csread
+
+ 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 *
+ do i=1,nbmodeles
+ if(icodemat(i) /= ANISOTROPIC_MATERIAL) then
+ print *,'Modele #',i,' isotrope'
+ print *,'rho,cp,cs = ',rho(i),cp(i),cs(i)
+ else
+ print *,'Modele #',i,' anisotrope'
+ print *,'rho,c11,c13,c33,c44 = ',rho(i),cp(i),cs(i),aniso3(i),aniso4(i)
+ endif
+ enddo
+ print *
+
+! lecture des numeros de modele des differentes zones
+ call read_value_integer(IIN_PAR,IGNORE_JUNK,nbzone)
+
+ if(nbzone <= 0) stop 'Negative number of zones not allowed !!'
+
+ print *
+ print *, 'Nb de zones du modele = ',nbzone
+ print *
+
+ do izone = 1,nbzone
+
+ read(IIN_PAR,*) ixdebzone,ixfinzone,izdebzone,izfinzone,imodnum
+
+ 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 !!'
+
+ print *,'Zone ',izone
+ print *,'IX from ',ixdebzone,' to ',ixfinzone
+ print *,'IZ from ',izdebzone,' to ',izfinzone
+
+ 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)
+ 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)
+ endif
+ print *,' -----'
+
+! stocker le modele de vitesse et densite
+ do i = ixdebzone,ixfinzone
+ do j = izdebzone,izfinzone
+ if(ngnod == 4) then
+ num_modele(i,j) = imodnum
+ 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
+ endif
+ enddo
+ enddo
+
+ enddo
+
+ if(minval(num_modele) <= 0) stop 'Velocity model not entirely set...'
+
+ close(10)
+
+ print *
+ print *,' Parameter file successfully read... '
+
+! --------- fin lecture fichier parametres --------------
+
+ if(ngnod /= 4 .and. ngnod /= 9) stop 'erreur ngnod different de 4 ou 9 !!'
+
+ print *
+ if(ngnod == 4) then
+ print *,'Le maillage comporte ',nx,' x ',nz,' elements'
+ else
+ print *,'Le maillage comporte ',nx/2,' x ',nz/2,' elements'
+ endif
+ print *
+ print *,'Les elements de controle sont des elements ',ngnod,' noeuds'
+ 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))
+
+ x(:,:) = 0.d0
+ z(:,:) = 0.d0
+
+! get interface data from external file
+ print *,'Reading interface data from file DATA/',interfacesfile(1:len_trim(interfacesfile))
+ open(unit=15,file='DATA/'//interfacesfile,status='old')
+
+ allocate(xinterface_bottom(max_npoints_interface))
+ allocate(zinterface_bottom(max_npoints_interface))
+ allocate(coefs_interface_bottom(max_npoints_interface))
+
+ allocate(xinterface_top(max_npoints_interface))
+ allocate(zinterface_top(max_npoints_interface))
+ allocate(coefs_interface_top(max_npoints_interface))
+
+! read number of interfaces
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,number_of_interfaces)
+
+! read bottom interface
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,npoints_interface_bottom)
+
+! loop on all the points describing this interface
+ do ipoint_current = 1,npoints_interface_bottom
+ read(IIN_INTERFACES,*) xinterface_bottom(ipoint_current),zinterface_bottom(ipoint_current)
+ enddo
+
+! boucle sur toutes les couches
+ do ilayer = 1,number_of_layers
+
+! read top interface
+ call read_value_integer(IIN_INTERFACES,DONT_IGNORE_JUNK,npoints_interface_top)
+
+! loop on all the points describing this interface
+ do ipoint_current = 1,npoints_interface_top
+ read(IIN_INTERFACES,*) xinterface_top(ipoint_current),zinterface_top(ipoint_current)
+ enddo
+
+! calculer le spline pour l'interface du bas, imposer la tangente aux deux bords
+ 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
+ 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
+ if(ilayer == number_of_layers) then
+
+! modifier position de la source si source exactement en surface
+ if(source_surf) zs = value_spline(xs,xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
+
+! modifier position des recepteurs si enregistrement exactement en surface
+ if(enreg_surf) then
+ do irec=1,nrec
+ zrec(irec) = value_spline(xrec(irec),xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
+ enddo
+ endif
+
+ endif
+
+! calcul de l'offset de cette couche en nombre d'elements spectraux suivant Z
+ if(ilayer > 1) then
+ ioffset = sum(nz_layer(1:ilayer-1))
+ else
+ ioffset = 0
+ endif
+
+!--- definition du maillage
+
+ do ix = 0,nx
+
+! points regulierement espaces suivant X
+ absx = xmin + (xmax - xmin) * dble(ix) / dble(nx)
+
+! value of the bottom and top splines
+ bot0 = value_spline(absx,xinterface_bottom,zinterface_bottom,coefs_interface_bottom,npoints_interface_bottom)
+ top0 = value_spline(absx,xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
+
+ do iz = 0,nz_layer(ilayer)
+
+! linear interpolation between bottom and top
+ gamma = dble(iz) / dble(nz_layer(ilayer))
+ a00 = 1.d0 - gamma
+ a01 = gamma
+
+! coordinates of the grid points
+ x(ix,iz + ioffset) = absx
+ z(ix,iz + ioffset) = a00*bot0 + a01*top0
+
+ enddo
+
+ enddo
+
+! l'interface du haut devient celle du bas pour passer a la couche suivante
+ npoints_interface_bottom = npoints_interface_top
+ xinterface_bottom(:) = xinterface_top(:)
+ zinterface_bottom(:) = zinterface_top(:)
+
+ enddo
+
+ close(15)
+
+! calculer min et max de X et Z sur la grille
+ 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 *
+
+! afficher position de la source et des recepteurs
+ print *
+ print *,'Position (x,z) de la source'
+ print *
+ print *,'Source = ',xs,zs
+ print *
+ print *,'Position (x,z) des ',nrec,' recepteurs'
+ print *
+ do irec=1,nrec
+ print *,'Receiver ',irec,' = ',xrec(irec),zrec(irec)
+ enddo
+
+! ***
+! *** generer un fichier Gnuplot pour le controle de la grille ***
+! ***
+
+ print *
+ print *,'Ecriture de la grille format Gnuplot...'
+
+ open(unit=20,file='gridfile.gnu',status='unknown')
+
+! dessin des lignes horizontales de la grille
+ print *,'Ecriture lignes horizontales'
+ istepx = 1
+ if(ngnod == 4) then
+ istepz = 1
+ else
+ istepz = 2
+ endif
+ do ili=0,nz,istepz
+ do icol=0,nx-istepx,istepx
+ write(20,15) sngl(x(icol,ili)),sngl(z(icol,ili))
+ write(20,15) sngl(x(icol+istepx,ili)),sngl(z(icol+istepx,ili))
+ write(20,10)
+ enddo
+ enddo
+
+! dessin des lignes verticales de la grille
+ print *,'Ecriture lignes verticales'
+ if(ngnod == 4) then
+ istepx = 1
+ else
+ istepx = 2
+ endif
+ istepz = 1
+ do icol=0,nx,istepx
+ do ili=0,nz-istepz,istepz
+ write(20,15) sngl(x(icol,ili)),sngl(z(icol,ili))
+ write(20,15) sngl(x(icol,ili+istepz)),sngl(z(icol,ili+istepz))
+ write(20,10)
+ enddo
+ enddo
+
+ close(20)
+
+! cree le script de dessin pour gnuplot
+ open(unit=20,file='plotgnu',status='unknown')
+ write(20,*) '#set term postscript landscape monochrome solid "Helvetica" 22'
+ write(20,*) '#set output "grille.ps"'
+ write(20,*) 'plot "gridfile.gnu" title "Macrobloc mesh" w l'
+ write(20,*) 'pause -1 "appuyez sur une touche"'
+ close(20)
+
+ print *,'Fin ecriture de la grille format Gnuplot'
+ print *
+
+! *** generation de la base de donnees
+
+ open(unit=15,file='Database',status='unknown')
+
+ write(15,*) '#'
+ write(15,*) '# Database for SPECFEM2D'
+ write(15,*) '# Dimitri Komatitsch, (c) University of Pau, France'
+ write(15,*) '#'
+
+ write(15,*) 'Titre simulation'
+ write(15,40) title
+
+ npgeo = (nx+1)*(nz+1)
+ if(ngnod == 4) then
+ nspec = nx*nz
+ else
+ nspec = nx*nz/4
+ endif
+ write(15,*) 'npgeo'
+ write(15,*) npgeo
+
+ write(15,*) 'gnuplot interpol'
+ write(15,*) gnuplot,interpol
+
+ write(15,*) 'itaff colors numbers'
+ write(15,*) itaff,' 1 0'
+
+ write(15,*) 'meshvect modelvect boundvect cutvect subsamp nx_sem_PNM'
+ write(15,*) meshvect,modelvect,boundvect,cutvect,subsamp,nxread
+
+ write(15,*) 'anglerec'
+ write(15,*) anglerec
+
+ write(15,*) 'initialfield'
+ write(15,*) initialfield
+
+ write(15,*) 'sismostype vecttype'
+ write(15,*) sismostype,vecttype
+
+ write(15,*) 'readmodel outputgrid ELASTIC TURN_ANISOTROPY_ON TURN_ATTENUATION_ON'
+ write(15,*) readmodel,outputgrid,ELASTIC,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
+
+ write(15,*) 'ncycl dtinc'
+ write(15,*) nt,dt
+
+ write(15,*) 'source'
+ write(15,*) source_type,time_function_type,xs-xmin,zs,f0,t0,factor,angle
+
+ write(15,*) 'Coordinates of macrobloc mesh (coorg):'
+ do j=0,nz
+ do i=0,nx
+ write(15,*) num(i,j,nx),x(i,j)-xmin,z(i,j)
+ enddo
+ enddo
+
+!
+!--- introduction des bords absorbants
+!
+ nelemabs = 0
+ if(absbas) nelemabs = nelemabs + nx
+ if(abshaut) nelemabs = nelemabs + nx
+ if(absgauche) nelemabs = nelemabs + nz
+ if(absdroite) nelemabs = nelemabs + nz
+
+! on a deux fois trop d'elements si elements 9 noeuds
+ 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
+
+!
+!--- introduction de la surface libre si milieu acoustique
+!
+ nelemsurface = nx
+
+! on a deux fois trop d'elements si elements 9 noeuds
+ if(ngnod == 9) nelemsurface = nelemsurface / 2
+
+ write(15,*) 'numat ngnod nspec pointsdisp nelemabs nelemsurface'
+ write(15,*) nbmodeles,ngnod,nspec,pointsdisp,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,*) 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
+ 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)
+ 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)
+
+ enddo
+ enddo
+ endif
+
+!
+!--- sauvegarde des bords absorbants
+!
+ print *
+ print *,'Au total il y a ',nelemabs,' elements absorbants'
+ print *
+ print *,'Bords absorbants actifs :'
+ print *
+ print *,'Haut = ',abshaut
+ print *,'Bas = ',absbas
+ print *,'Gauche = ',absgauche
+ print *,'Droite = ',absdroite
+ print *
+
+! generer la liste des elements absorbants
+ if(nelemabs > 0) then
+ write(15,*) 'Liste des elements absorbants (haut bas gauche droite) :'
+ inumabs = 0
+ do iz = 1,nzread
+ do ix = 1,nxread
+ codehaut = .false.
+ codebas = .false.
+ codegauche = .false.
+ codedroite = .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
+ enddo
+ enddo
+ endif
+
+!
+!--- sauvegarde de la surface libre
+!
+ print *
+ print *,'Au total il y a ',nelemsurface,' elements a la surface libre'
+ print *
+
+! generer la liste des elements a la surface libre
+ if(nelemsurface > 0) then
+ write(15,*) 'Liste des elements a la surface libre'
+ 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
+ endif
+
+ close(15)
+
+
+!
+!--- write the STATIONS file
+!
+ print *
+ print *,'writing the DATA/STATIONS file'
+ print *
+
+ open(unit=15,file='DATA/STATIONS',status='unknown')
+ write(15,*) nrec
+ do irec=1,nrec
+ write(15,100) irec,xrec(irec)-xmin,zrec(irec)
+ enddo
+ close(15)
+
+ 10 format('')
+ 15 format(e10.5,1x,e10.5)
+ 40 format(a50)
+
+ 100 format('S',i3.3,' AA ',f20.7,1x,f20.7,' 0.0 0.0')
+
+ end program meshfem2D
+
+! ********************
+! routines de maillage
+! ********************
+
+!--- numero global du noeud
+
+ integer function num(i,j,nx)
+
+ implicit none
+
+ integer i,j,nx
+
+ num = j*(nx+1) + i + 1
+
+ end function num
+
+!--- representation des interfaces par un spline
+
+ double precision function value_spline(x,xinterface,zinterface,coefs_interface,npoints_interface)
+
+ implicit none
+
+ integer npoints_interface
+ double precision x,xp
+ double precision, dimension(npoints_interface) :: xinterface,zinterface,coefs_interface
+
+ value_spline = 0.d0
+
+ xp = x
+
+! si on sort du modele, prolonger par continuite
+ if(xp < xinterface(1)) xp = xinterface(1)
+ if(xp > xinterface(npoints_interface)) xp = xinterface(npoints_interface)
+
+ call splint(xinterface,zinterface,coefs_interface,npoints_interface,xp,value_spline)
+
+ end function value_spline
+
+! --------------------------------------
+
+! routine de calcul des coefs du spline (adapted from Numerical Recipes)
+
+ subroutine spline(x,y,n,yp1,ypn,y2)
+
+ implicit none
+
+ integer n
+ double precision, dimension(n) :: x,y,y2
+ double precision, dimension(:), allocatable :: u
+ double precision yp1,ypn
+
+ integer i,k
+ double precision sig,p,qn,un
+
+ allocate(u(n))
+
+ y2(1)=-0.5d0
+ u(1)=(3.d0/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
+
+ do i=2,n-1
+ 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
+ enddo
+
+ qn=0.5d0
+ un=(3.d0/(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
+ y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.d0)
+
+ do k=n-1,1,-1
+ y2(k)=y2(k)*y2(k+1)+u(k)
+ enddo
+
+ deallocate(u)
+
+ end subroutine spline
+
+! --------------
+
+! routine d'evaluation du spline (adapted from Numerical Recipes)
+
+ subroutine splint(XA,YA,Y2A,N,X,Y)
+
+ implicit none
+
+ integer n
+ double precision, dimension(n) :: XA,YA,Y2A
+ double precision x,y
+
+ integer k,klo,khi
+ double precision h,a,b
+
+ KLO = 1
+ KHI = N
+
+ do while (KHI-KLO > 1)
+ K=(KHI+KLO)/2
+ if(XA(K) > X) then
+ KHI=K
+ else
+ KLO=K
+ endif
+ enddo
+
+ H = XA(KHI)-XA(KLO)
+ IF (H == 0.d0) stop 'bad input in spline evaluation'
+
+ A = (XA(KHI)-X) / H
+ B = (X-XA(KLO)) / H
+
+ Y = A*YA(KLO) + B*YA(KHI) + ((A**3-A)*Y2A(KLO) + (B**3-B)*Y2A(KHI))*(H**2)/6.d0
+
+ end subroutine splint
+
+!--------------------
+
+ subroutine read_value_integer(iin,ignore_junk,value_to_read)
+
+ implicit none
+
+ integer iin
+ logical ignore_junk
+
+ integer value_to_read
+
+ integer ios
+
+ character(len=100) string_read
+ character(len=34) junk
+
+ do
+ read(unit=iin,fmt=200,iostat=ios) string_read
+ if(ios /= 0) stop 'error while reading input file'
+
+! suppress leading white spaces, if any
+ string_read = adjustl(string_read)
+
+! exit loop when we find the first line that is not a comment
+ if(string_read(1:1) /= '#') exit
+
+ enddo
+
+ if(ignore_junk) then
+ read(string_read,100) junk,value_to_read
+ else
+ read(string_read,*) value_to_read
+ endif
+
+! format
+ 100 format(a,i8)
+ 200 format(a100)
+
+ end subroutine read_value_integer
+
+!--------------------
+
+ subroutine read_value_double_precision(iin,ignore_junk,value_to_read)
+
+ implicit none
+
+ integer iin
+ logical ignore_junk
+
+ double precision value_to_read
+
+ integer ios
+
+ character(len=100) string_read
+ character(len=34) junk
+
+ do
+ read(unit=iin,fmt=200,iostat=ios) string_read
+ if(ios /= 0) stop 'error while reading input file'
+
+! suppress leading white spaces, if any
+ string_read = adjustl(string_read)
+
+! exit loop when we find the first line that is not a comment
+ if(string_read(1:1) /= '#') exit
+
+ enddo
+
+ if(ignore_junk) then
+ read(string_read,100) junk,value_to_read
+ else
+ read(string_read,*) value_to_read
+ endif
+
+! format
+ 100 format(a,f12.5)
+ 200 format(a100)
+
+ end subroutine read_value_double_precision
+
+!--------------------
+
+ subroutine read_value_logical(iin,ignore_junk,value_to_read)
+
+ implicit none
+
+ integer iin
+ logical ignore_junk
+
+ logical value_to_read
+
+ integer ios
+
+ character(len=100) string_read
+ character(len=34) junk
+
+ do
+ read(unit=iin,fmt=200,iostat=ios) string_read
+ if(ios /= 0) stop 'error while reading input file'
+
+! suppress leading white spaces, if any
+ string_read = adjustl(string_read)
+
+! exit loop when we find the first line that is not a comment
+ if(string_read(1:1) /= '#') exit
+
+ enddo
+
+ if(ignore_junk) then
+ read(string_read,100) junk,value_to_read
+ else
+ read(string_read,*) value_to_read
+ endif
+
+! format
+ 100 format(a,l8)
+ 200 format(a100)
+
+ end subroutine read_value_logical
+
+!--------------------
+
+ subroutine read_value_string(iin,ignore_junk,value_to_read)
+
+ implicit none
+
+ integer iin
+ logical ignore_junk
+
+ character(len=*) value_to_read
+
+ integer ios
+
+ character(len=100) string_read
+ character(len=34) junk
+
+ do
+ read(unit=iin,fmt=200,iostat=ios) string_read
+ if(ios /= 0) stop 'error while reading input file'
+
+! suppress leading white spaces, if any
+ string_read = adjustl(string_read)
+
+! exit loop when we find the first line that is not a comment
+ if(string_read(1:1) /= '#') exit
+
+ enddo
+
+ if(ignore_junk) then
+ read(string_read,100) junk,value_to_read
+ else
+ read(string_read,*) value_to_read
+ endif
+
+! format
+ 100 format(a34,a)
+ 200 format(a100)
+
+ end subroutine read_value_string
+
Added: seismo/2D/SPECFEM2D/trunk/plotgll.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/plotgll.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/plotgll.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,230 @@
+
+!========================================================================
+!
+! 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 plotgll(knods,ibool,coorg,coord,npoin,npgeo,ngnod,nspec)
+
+! output the Gauss-Lobatto-Legendre mesh in a gnuplot file
+
+ implicit none
+
+ include "constants.h"
+
+ integer ispec,iy,ix,iglobnum,iglobnum2,ibloc,inode,npoin,npgeo,ngnod,nspec
+
+ integer knods(ngnod,nspec),ibool(NGLLX,NGLLX,nspec)
+
+ double precision coorg(NDIM,npgeo),coord(NDIM,npoin)
+
+! coordinates of the nodes for Gnuplot file
+ integer, parameter :: MAXNGNOD = 9
+ double precision xval(MAXNGNOD),zval(MAXNGNOD)
+
+ character(len=70) name
+
+!
+!---- output the GLL mesh in a Gnuplot file
+!
+
+ write(iout,*)
+ write(iout,*) 'Generating gnuplot meshes...'
+ write(iout,*)
+
+! create non empty files for the case of 4-node elements
+
+ name='macros1.gnu'
+ open(unit=30,file=name,status='unknown')
+
+ name='macros2.gnu'
+ open(unit=31,file=name,status='unknown')
+ write(31,10)
+
+ name='gllmesh1.gnu'
+ open(unit=20,file=name,status='unknown')
+
+ name='gllmesh2.gnu'
+ open(unit=21,file=name,status='unknown')
+ write(21,10)
+
+ do ispec = 1,nspec
+
+!
+!---- plot the lines in xi-direction
+!
+ do iy = 1,NGLLZ
+ do ix = 1,NGLLX-1
+!
+!---- get the global point number
+!
+ iglobnum = ibool(ix,iy,ispec)
+!
+!---- do the same for next point on horizontal line
+!
+ iglobnum2 = ibool(ix+1,iy,ispec)
+
+ write(20,15) coord(1,iglobnum),coord(2,iglobnum)
+ write(20,15) coord(1,iglobnum2),coord(2,iglobnum2)
+ write(20,10)
+
+ if(iy == 1 .or. iy == NGLLZ) then
+ write(21,15) coord(1,iglobnum),coord(2,iglobnum)
+ write(21,15) coord(1,iglobnum2),coord(2,iglobnum2)
+ write(21,10)
+ endif
+
+ enddo
+ enddo
+
+!
+!---- plot the lines in eta-direction
+!
+ do ix = 1,NGLLX
+ do iy = 1,NGLLZ-1
+!
+!---- get the global point number
+!
+ iglobnum = ibool(ix,iy,ispec)
+!
+!---- do the same for next point on vertical line
+!
+ iglobnum2 = ibool(ix,iy+1,ispec)
+
+ write(20,15) coord(1,iglobnum),coord(2,iglobnum)
+ write(20,15) coord(1,iglobnum2),coord(2,iglobnum2)
+ write(20,10)
+
+ if(ix == 1 .or. ix == NGLLX) then
+ write(21,15) coord(1,iglobnum),coord(2,iglobnum)
+ write(21,15) coord(1,iglobnum2),coord(2,iglobnum2)
+ write(21,10)
+ endif
+
+ enddo
+ enddo
+ enddo
+
+!
+!---- plot the macrobloc mesh using Gnuplot
+!
+ do ibloc = 1,nspec
+ do inode = 1,ngnod
+
+ xval(inode) = coorg(1,knods(inode,ibloc))
+ zval(inode) = coorg(2,knods(inode,ibloc))
+
+ enddo
+
+ if(ngnod == 4) then
+!
+!---- 4-node rectangular element
+!
+
+! draw the edges of the element using one color
+ write(30,15) xval(1),zval(1)
+ write(30,15) xval(2),zval(2)
+ write(30,10)
+ write(30,15) xval(2),zval(2)
+ write(30,15) xval(3),zval(3)
+ write(30,10)
+ write(30,15) xval(3),zval(3)
+ write(30,15) xval(4),zval(4)
+ write(30,10)
+ write(30,15) xval(4),zval(4)
+ write(30,15) xval(1),zval(1)
+ write(30,10)
+
+ else
+
+!
+!---- 9-node rectangular element
+!
+
+! draw the edges of the element using one color
+ write(30,15) xval(1),zval(1)
+ write(30,15) xval(5),zval(5)
+ write(30,10)
+ write(30,15) xval(5),zval(5)
+ write(30,15) xval(2),zval(2)
+ write(30,10)
+ write(30,15) xval(2),zval(2)
+ write(30,15) xval(6),zval(6)
+ write(30,10)
+ write(30,15) xval(6),zval(6)
+ write(30,15) xval(3),zval(3)
+ write(30,10)
+ write(30,15) xval(3),zval(3)
+ write(30,15) xval(7),zval(7)
+ write(30,10)
+ write(30,15) xval(7),zval(7)
+ write(30,15) xval(4),zval(4)
+ write(30,10)
+ write(30,15) xval(4),zval(4)
+ write(30,15) xval(8),zval(8)
+ write(30,10)
+ write(30,15) xval(8),zval(8)
+ write(30,15) xval(1),zval(1)
+ write(30,10)
+
+! draw middle lines using another color
+ write(31,15) xval(5),zval(5)
+ write(31,15) xval(9),zval(9)
+ write(31,10)
+ write(31,15) xval(9),zval(9)
+ write(31,15) xval(7),zval(7)
+ write(31,10)
+ write(31,15) xval(8),zval(8)
+ write(31,15) xval(9),zval(9)
+ write(31,10)
+ write(31,15) xval(9),zval(9)
+ write(31,15) xval(6),zval(6)
+ write(31,10)
+
+ endif
+
+ enddo
+
+ close(20)
+ close(21)
+
+ close(30)
+ close(31)
+
+!
+!---- generate the command file for Gnuplot
+!
+ open(unit=20,file='plotall_gll_mesh.gnu',status='unknown')
+ write(20,*) 'set term x11'
+ write(20,*) '# set term postscript landscape color solid "Helvetica" 22'
+ write(20,*) '# set output "gll_mesh.ps"'
+ write(20,*) 'set xlabel "X"'
+ write(20,*) 'set ylabel "Y"'
+ write(20,*) 'set title "Gauss-Lobatto-Legendre Mesh"'
+ write(20,*) 'plot "gllmesh1.gnu" title '''' w l 2, "gllmesh2.gnu" title '''' w linesp 1 3'
+ write(20,*) 'pause -1 "Hit any key to exit..."'
+ close(20)
+
+ open(unit=20,file='plotall_macro_mesh.gnu',status='unknown')
+ write(20,*) 'set term x11'
+ write(20,*) '# set term postscript landscape color solid "Helvetica" 22'
+ write(20,*) '# set output "macro_mesh.ps"'
+ write(20,*) 'set xlabel "X"'
+ write(20,*) 'set ylabel "Y"'
+ write(20,*) 'set title "Spectral Element (Macrobloc) Mesh"'
+ write(20,*) 'plot "macros2.gnu" title '''' w l 2, "macros1.gnu" title '''' w linesp 1 3'
+ write(20,*) 'pause -1 "Hit any key to exit..."'
+ close(20)
+
+ 10 format('')
+ 15 format(e10.5,1x,e10.5)
+
+ end subroutine plotgll
+
Added: seismo/2D/SPECFEM2D/trunk/plotpost.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/plotpost.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/plotpost.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,918 @@
+
+!========================================================================
+!
+! 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 plotpost(displ,coord,vpext,iglob_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,readmodel,cutvect,nelemabs,numat,iptsdisp,nspec,ngnod,ELASTIC)
+
+!
+! routine affichage postscript
+!
+
+ implicit none
+
+ include "constants.h"
+
+! color palette
+ integer, parameter :: MAXCOLORS = 100
+ double precision, dimension(MAXCOLORS) :: red,green,blue
+
+ integer it,nrec,nelemabs,numat,iptsdisp,nspec
+ integer i,iglob_source,npoin,npgeo,ngnod
+
+ integer kmato(nspec),knods(ngnod,nspec)
+ integer ibool(NGLLX,NGLLZ,nspec)
+
+ double precision xinterp(iptsdisp,iptsdisp),zinterp(iptsdisp,iptsdisp)
+ double precision shapeint(ngnod,iptsdisp,iptsdisp)
+ double precision Uxinterp(iptsdisp,iptsdisp)
+ double precision Uzinterp(iptsdisp,iptsdisp)
+ double precision flagrange(NGLLX,iptsdisp)
+ double precision density(numat),elastcoef(4,numat)
+
+ double precision dt,timeval
+ double precision displ(NDIM,npoin),coord(NDIM,npoin)
+ double precision vpext(npoin)
+
+ double precision coorg(NDIM,npgeo)
+ double precision, dimension(nrec) :: st_xval,st_zval
+
+ integer numabs(nelemabs),codeabs(4,nelemabs)
+ logical anyabs,ELASTIC
+
+ 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
+
+ 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,nbcols,imat,icol,l,longueur
+ integer indice,ii,ipoin,in,nnum,ispecabs,ideb,ifin,ibord
+
+ integer colors,numbers,subsamp,vecttype
+ logical interpol,meshvect,modelvect,boundvect,readmodel
+ double precision cutvect
+
+ double precision rapp_page,dispmax,xmin,zmin
+
+! title of the plot
+ character(len=60) stitle
+
+! papier A4 ou US letter
+ if(US_LETTER) then
+ usoffset = 1.75d0
+ sizex = 27.94d0
+ sizez = 21.59d0
+ else
+ usoffset = 0.d0
+ sizex = 29.7d0
+ sizez = 21.d0
+ endif
+
+! definition de la palette de couleur
+
+! red
+ red(1) = 1.d0
+ green(1) = 0.d0
+ blue(1) = 0.d0
+! blue
+ red(2) = 0.d0
+ green(2) = 0.d0
+ blue(2) = 1.d0
+! violet
+ red(3) = .93d0
+ green(3) = .51d0
+ blue(3) = .93d0
+! medium orchid
+ red(4) = .73d0
+ green(4) = .33d0
+ blue(4) = .83d0
+! dark orchid
+ red(5) = .6d0
+ green(5) = .2d0
+ blue(5) = .8d0
+! blue violet
+ red(6) = .54d0
+ green(6) = .17d0
+ blue(6) = .89d0
+! slate blue
+ red(7) = .42d0
+ green(7) = .35d0
+ blue(7) = .80d0
+! deep pink
+ red(8) = 1.d0
+ green(8) = .08d0
+ blue(8) = .58d0
+! dodger blue
+ red(9) = .12d0
+ green(9) = .56d0
+ blue(9) = 1.d0
+! dark turquoise
+ red(10) = 0.d0
+ green(10) = .81d0
+ blue(10) = .82d0
+! turquoise
+ red(11) = .25d0
+ green(11) = .88d0
+ blue(11) = .82d0
+! lime green
+ red(12) = .2d0
+ green(12) = .8d0
+ blue(12) = .2d0
+! spring green
+ red(13) = 0.d0
+ green(13) = 1.d0
+ blue(13) = .5d0
+! chartreuse
+ red(14) = .5d0
+ green(14) = 1.d0
+ blue(14) = 0.d0
+! green yellow
+ red(15) = .68d0
+ green(15) = 1.d0
+ blue(15) = .18d0
+! yellow
+ red(16) = 1.d0
+ green(16) = 1.d0
+ blue(16) = 0.d0
+! lemon chiffon
+ red(17) = 1.d0
+ green(17) = .98d0
+ blue(17) = .8d0
+! gold
+ red(18) = 1.d0
+ green(18) = .84d0
+ blue(18) = 0.d0
+! mocassin
+ red(19) = 1.d0
+ green(19) = .89d0
+ blue(19) = .71d0
+! peach puff
+ red(20) = 1.d0
+ green(20) = .85d0
+ blue(20) = .73d0
+
+! recherche des positions maximales des points de la grille
+ xmax=maxval(coord(1,:))
+ zmax=maxval(coord(2,:))
+ write(*,*) 'Max X = ',xmax
+ write(*,*) 'Max Z = ',zmax
+
+! limite du repere physique
+ xmin=0.d0
+ zmin=0.d0
+
+! rapport taille page/taille domaine physique
+ rapp_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) / 100.d0
+
+! recherche de la valeur maximum de la norme du deplacement
+ dispmax = maxval(sqrt(displ(1,:)**2 + displ(2,:)**2))
+ write(*,*) 'Max norme = ',dispmax
+
+! hauteur des numeros de domaine en CM
+ height = 0.25d0
+
+!
+!---- ouverture du fichier PostScript
+!
+ write(name,222) it
+ open(unit=24,file=name,status='unknown')
+ 222 format('vect',i5.5,'.ps')
+
+!
+!---- ecriture de l'entete du fichier PostScript
+!
+ write(24,10) stitle
+ 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,*) '% differents symboles utiles'
+ 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,*) '/Losange {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,*) '/BK {setgray fill} def'
+ write(24,*) '% version noir et blanc'
+ write(24,*) '%/BK {pop 1 setgray fill} def'
+ write(24,*) '%'
+ write(24,*) '% magenta pour les vecteurs deplacement'
+ write(24,*) '/Colvects {0.01 CM SLW 1. 0. 1. RG} def'
+ write(24,*) '% version noir et blanc'
+ write(24,*) '%/Colvects {0.01 CM SLW 0. setgray} def'
+ write(24,*) '%'
+ write(24,*) '% chartreuse pour le maillage des macroblocs'
+ write(24,*) '/Colmesh {0.02 CM SLW 0.5 1. 0. RG} def'
+ write(24,*) '% version noir et blanc'
+ write(24,*) '%/Colmesh {0.02 CM SLW 0. setgray} def'
+ write(24,*) '%'
+ write(24,*) '% cyan pour les sources et recepteurs'
+ write(24,*) '/Colreceiv {0. 1. 1. RG} def'
+ write(24,*) '% version noir et blanc'
+ write(24,*) '%/Colreceiv {0. setgray} def'
+ write(24,*) '%'
+ write(24,*) '% macro dessin fleche'
+ write(24,*) '/F {MV LR gsave LR ST grestore LR ST} def'
+ write(24,*) '% macro dessin contour 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,*) '%'
+
+!
+!--- ecriture des legendes du fichier PostScript
+!
+ 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,*) '%'
+
+ write(24,*) '24. CM 1.95 CM MV'
+ timeval = it*dt
+ if(timeval >= 1.d-3) then
+ write(24,600) usoffset,timeval
+ else
+ write(24,601) usoffset,timeval
+ endif
+ write(24,*) '%'
+ write(24,*) '24. CM 2.7 CM MV'
+ write(24,640) usoffset,dispmax
+ write(24,*) '%'
+ write(24,*) '24. CM 3.45 CM MV'
+ write(24,620) usoffset,cutvect*100.d0
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM SCSF'
+ if(colors == 1) 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'
+ if(colors == 1) 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(vecttype == 1) then
+ write(24,*) '(Displacement vector field) show'
+ else if(vecttype == 2) then
+ write(24,*) '(Velocity vector field) show'
+ else if(vecttype == 3) then
+ write(24,*) '(Acceleration vector field) show'
+ else
+ stop 'Bad field code in PostScript display'
+ 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,*) '(',stitle,') 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
+ 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,*) '%'
+
+!
+!---- print the spectral elements mesh in PostScript
+!
+
+ print *,'Shape functions based on ',ngnod,' control nodes'
+
+ convert = pi/180.d0
+
+!
+!---- draw the velocity model in background
+!
+ if(modelvect) then
+
+ do ispec=1,nspec
+ do i=1,NGLLX-subsamp,subsamp
+ do j=1,NGLLX-subsamp,subsamp
+
+ if((vpmax-vpmin)/vpmin > 0.02d0) then
+ if(readmodel) then
+ x1 = (vpext(ibool(i,j,ispec))-vpmin)/ (vpmax-vpmin)
+ else
+ material = kmato(ispec)
+ rlamda = elastcoef(1,material)
+ rmu = elastcoef(2,material)
+ denst = density(material)
+ rKvol = rlamda + 2.d0*rmu/3.d0
+ cploc = sqrt((rKvol + 4.d0*rmu/3.d0)/denst)
+ x1 = (cploc-vpmin)/(vpmax-vpmin)
+ endif
+ else
+ x1 = 0.5d0
+ endif
+
+! rescaler pour eviter gris trop sombre
+ x1 = x1*0.7 + 0.2
+ if(x1 > 1.d0) x1=1.d0
+
+! inverser echelle : blanc = vpmin, gris = 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 * 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 * 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 * 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 * centim
+ zw = zw * centim
+ write(24,499) xw,zw
+ write(24,604) x1
+
+ enddo
+ enddo
+ enddo
+
+ endif
+
+!
+!---- draw spectral element mesh
+!
+
+ if(meshvect) then
+
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+
+ do ispec=1,nspec
+
+ write(24,*) '% elem ',ispec
+
+ do i=1,iptsdisp
+ do j=1,iptsdisp
+ 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)*rapp_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ write(24,*) 'MK'
+ write(24,681) x1,z1
+
+ if(ngnod == 4) then
+
+! tracer des droites si elements 4 noeuds
+
+ ir=iptsdisp
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ ir=iptsdisp
+ is=iptsdisp
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ is=iptsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_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 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ else
+
+! tracer des courbes si elements 9 noeuds
+ do ir=2,iptsdisp
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+ enddo
+
+ ir=iptsdisp
+ do is=2,iptsdisp
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+ enddo
+
+ is=iptsdisp
+ do ir=iptsdisp-1,1,-1
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+ enddo
+
+ ir=1
+ do is=iptsdisp-1,2,-1
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+ enddo
+
+ endif
+
+ write(24,*) 'CO'
+
+ if(colors == 1) then
+
+! For the moment 20 different colors max
+ nbcols = 20
+
+! Use a different color for each material set
+ imat = kmato(ispec)
+ icol = mod(imat - 1,nbcols) + 1
+
+ write(24,680) red(icol),green(icol),blue(icol)
+
+ endif
+
+ if(modelvect) then
+ write(24,*) 'GC'
+ else
+ write(24,*) 'GG'
+ endif
+
+! 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 = xw * centim
+ zw = zw * centim
+ if(colors == 1) write(24,*) '1 setgray'
+
+ write(24,500) xw,zw
+
+!--- ecriture numero de l'element
+ write(24,502) ispec
+
+ endif
+
+ enddo
+
+ endif
+
+!
+!---- draw the boundary conditions
+!
+
+ if(anyabs .and. boundvect) then
+
+ write(24,*) '%'
+ write(24,*) '% boundary conditions on the mesh'
+ write(24,*) '%'
+
+ write(24,*) '0.05 CM SLW'
+
+!--- bords absorbants
+
+ if(anyabs) then
+
+ do ispecabs = 1,nelemabs
+ ispec = numabs(ispecabs)
+
+!--- 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
+
+ do ibord = 1,4
+
+ if(codeabs(ibord,ispecabs) /= 0) then
+
+ if(ibord == ITOP) then
+ write(24,*) '1. .85 0. RG'
+ ideb = 3
+ ifin = 4
+ else if(ibord == IBOTTOM) then
+ write(24,*) '.4 1. .4 RG'
+ ideb = 1
+ ifin = 2
+ else if(ibord == ILEFT) then
+ write(24,*) '1. .43 1. RG'
+ ideb = 4
+ ifin = 1
+ else if(ibord == IRIGHT) then
+ write(24,*) '.25 1. 1. RG'
+ 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 = x1 * centim
+ z1 = z1 * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,602) x1,z1,x2,z2
+
+ endif
+ enddo
+
+ enddo
+
+ endif
+
+ write(24,*) '0 setgray'
+ write(24,*) '0.01 CM SLW'
+
+ endif
+
+!
+!---- draw the normalized displacement field
+!
+
+! return if the maximum displacement equals zero (no source)
+ if(dispmax == 0.d0) then
+ print *,' null displacement : returning !'
+ return
+ endif
+
+ write(24,*) '%'
+ write(24,*) '% vector field'
+ write(24,*) '%'
+
+! fleches en couleur si modele de vitesse en background
+ if(modelvect) then
+ write(24,*) 'Colvects'
+ else
+ write(24,*) '0 setgray'
+ endif
+
+ if(interpol) then
+
+ print *,'Interpolating the vector field...'
+
+ do ispec=1,nspec
+
+! interpolation sur grille reguliere
+ if(mod(ispec,1000) == 0) write(*,*) 'Interpolation uniform grid element ',ispec
+
+ do i=1,iptsdisp
+ do j=1,iptsdisp
+
+ 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
+
+ Uxinterp(i,j) = 0.d0
+ Uzinterp(i,j) = 0.d0
+
+ 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)
+
+ enddo
+ enddo
+
+ x1 =(xinterp(i,j)-xmin)*rapp_page
+ z1 =(zinterp(i,j)-zmin)*rapp_page
+
+ x2 = Uxinterp(i,j)*sizemax/dispmax
+ z2 = Uzinterp(i,j)*sizemax/dispmax
+
+ d = sqrt(x2**2 + z2**2)
+
+! ignorer si vecteur trop petit
+ if(d > cutvect*sizemax) then
+
+ d1 = d * rapport
+ d2 = d1 * cos(angle*convert)
+
+ dummy = x2/d
+ if(dummy > 0.9999d0) dummy = 0.9999d0
+ if(dummy < -0.9999d0) dummy = -0.9999d0
+ theta = acos(dummy)
+
+ if(z2 < 0.d0) theta = 360.d0*convert - theta
+ thetaup = theta - angle*convert
+ thetadown = theta + angle*convert
+
+! tracer le vecteur proprement dit
+ x1 = (orig_x+x1) * centim
+ z1 = (orig_z+z1) * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ xa = -d2*cos(thetaup)
+ za = -d2*sin(thetaup)
+ xa = xa * centim
+ za = za * centim
+ xb = -d2*cos(thetadown)
+ zb = -d2*sin(thetadown)
+ xb = xb * centim
+ zb = zb * centim
+ write(name,700) xb,zb,xa,za,x2,z2,x1,z1
+
+! filtrer les blancs inutiles pour diminuer taille fichier PostScript
+ longueur = 49
+ indice = 1
+ first = .false.
+ do ii=1,longueur-1
+ if(ch1(ii) /= ' ' .or. first) then
+ if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
+ ch2(indice) = ch1(ii)
+ indice = indice + 1
+ first = .true.
+ endif
+ endif
+ enddo
+ ch2(indice) = ch1(longueur)
+ write(24,200) (ch2(ii),ii=1,indice)
+
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ 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
+
+ x2 = displ(1,ipoin)*sizemax/dispmax
+ z2 = displ(2,ipoin)*sizemax/dispmax
+
+ d = sqrt(x2**2 + z2**2)
+
+! ignorer si vecteur trop petit
+ if(d > cutvect*sizemax) then
+
+ d1 = d * rapport
+ d2 = d1 * cos(angle*convert)
+
+ dummy = x2/d
+ if(dummy > 0.9999d0) dummy = 0.9999d0
+ if(dummy < -0.9999d0) dummy = -0.9999d0
+ theta = acos(dummy)
+
+ if(z2 < 0.d0) theta = 360.d0*convert - theta
+ thetaup = theta - angle*convert
+ thetadown = theta + angle*convert
+
+! tracer le vecteur proprement dit
+ x1 = (orig_x+x1) * centim
+ z1 = (orig_z+z1) * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ xa = -d2*cos(thetaup)
+ za = -d2*sin(thetaup)
+ xa = xa * centim
+ za = za * centim
+ xb = -d2*cos(thetadown)
+ zb = -d2*sin(thetadown)
+ xb = xb * centim
+ zb = zb * centim
+ write(name,700) xb,zb,xa,za,x2,z2,x1,z1
+
+! filtrer les blancs inutiles pour diminuer taille fichier PostScript
+ longueur = 49
+ indice = 1
+ first = .false.
+ do ii=1,longueur-1
+ if(ch1(ii) /= ' ' .or. first) then
+ if(ch1(ii) /= ' ' .or. ch1(ii+1) /= ' ') then
+ ch2(indice) = ch1(ii)
+ indice = indice + 1
+ first = .true.
+ endif
+ endif
+ enddo
+ ch2(indice) = ch1(longueur)
+ write(24,200) (ch2(ii),ii=1,indice)
+
+ endif
+
+ enddo
+
+ endif
+
+ write(24,*) '0 setgray'
+
+! sources et recepteurs en couleur si modele de vitesse
+ if(modelvect) then
+ write(24,*) 'Colreceiv'
+ else
+ write(24,*) '0 setgray'
+ endif
+
+!
+!---- write position of the source
+!
+ xw = coord(1,iglob_source)
+ zw = coord(2,iglob_source)
+ 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
+ write(24,*) 'Cross'
+ else
+ write(24,*) '(S) show'
+ endif
+
+!
+!---- 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'
+
+ 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
+ enddo
+
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+
+ 10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a50,/, &
+ '%% Created by: Specfem Version 5.0',/, &
+ '%% Author: Dimitri Komatitsch',/,'%%')
+ 510 format(f5.1,1x,f5.1,' M')
+ 600 format(f6.3,' neg CM 0 MR (Time =',f6.3,' s) show')
+ 601 format(f6.3,' neg CM 0 MR (Time =',1pe10.3,' s) show')
+ 610 format(f6.3,' neg CM 0 MR (Time step = ',i5,') show')
+ 620 format(f6.3,' neg CM 0 MR (Cut =',f5.2,' \%) show')
+ 640 format(f6.3,' neg CM 0 MR (Max norm =',1pe10.3,') show')
+
+ 200 format(80(a1))
+ 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')
+
+ end subroutine plotpost
+
Added: seismo/2D/SPECFEM2D/trunk/positsource.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/positsource.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/positsource.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,92 @@
+
+!========================================================================
+!
+! 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 positsource(coord,ibool,npoin,nspec,x_source,z_source,source_type,ix_source,iz_source,ispec_source,iglob_source)
+
+!
+!----- calculer la position reelle de la source
+!
+
+ implicit none
+
+ include "constants.h"
+
+ integer npoin,nspec,source_type
+ integer ibool(NGLLX,NGLLZ,nspec)
+
+ double precision x_source,z_source
+ double precision coord(NDIM,npoin)
+
+ integer ip,ix,iz,numelem,ilowx,ilowz,ihighx,ihighz,ix_source,iz_source,ispec_source,iglob_source
+
+ double precision distminmax,distmin,xp,zp,dist
+
+ write(iout,200)
+
+ distminmax = -HUGEVAL
+
+ distmin = +HUGEVAL
+
+ ilowx = 1
+ ilowz = 1
+ ihighx = NGLLX
+ ihighz = NGLLZ
+
+! on ne fait la recherche que sur l'interieur de l'element si source explosive
+ if(source_type == 2) then
+ ilowx = 2
+ ilowz = 2
+ ihighx = NGLLX-1
+ ihighz = NGLLZ-1
+ endif
+
+! recherche du point de grille le plus proche
+ do numelem=1,nspec
+ do ix=ilowx,ihighx
+ do iz=ilowz,ihighz
+
+! numero global du point
+ ip=ibool(ix,iz,numelem)
+
+! coordonnees du point de grille
+ xp = coord(1,ip)
+ zp = coord(2,ip)
+
+ dist = sqrt((xp-x_source)**2 + (zp-z_source)**2)
+
+! retenir le point pour lequel l'ecart est minimal
+ if(dist < distmin) then
+ distmin = dist
+ iglob_source = ip
+ ix_source = ix
+ iz_source = iz
+ ispec_source = numelem
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ distminmax = max(distmin,distminmax)
+
+ write(iout,150) x_source,z_source,coord(1,iglob_source),coord(2,iglob_source),distmin
+ write(iout,160) distminmax
+
+ 150 format(1x,f12.3,1x,f12.3,1x,f12.3,1x,f12.3,f12.3)
+ 160 format(/2x,'Maximum distance between asked and real =',f12.3)
+ 200 format(//1x,48('=')/,' = S o u r c e s ', &
+ 'r e a l p o s i t i o n s ='/1x,48('=')// &
+ ' Source x-asked z-asked x-obtain z-obtain dist'/)
+
+ end subroutine positsource
+
Added: seismo/2D/SPECFEM2D/trunk/recompute_jacobian.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/recompute_jacobian.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/recompute_jacobian.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,79 @@
+
+!========================================================================
+!
+! 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
+!
+!========================================================================
+
+! recompute 2D jacobian at a given point in a 4-node or 9-node element
+
+ subroutine recompute_jacobian(xi,gamma,x,z,xix,xiz,gammax,gammaz,jacobian,coorg,knods,ispec,ngnod,nspec,npgeo)
+
+ implicit none
+
+ include "constants.h"
+
+ integer ispec,ngnod,nspec,npgeo
+ double precision x,z,xix,xiz,gammax,gammaz
+ double precision xi,gamma,jacobian
+
+ integer knods(ngnod,nspec)
+ double precision coorg(NDIM,npgeo)
+
+! 2D shape functions and their derivatives at receiver
+ double precision shape2D(ngnod)
+ double precision dershape2D(NDIM,ngnod)
+
+ double precision xxi,zxi,xgamma,zgamma,xelm,zelm
+
+ integer ia,nnum
+
+! recompute jacobian for any (xi,gamma) point, not necessarily a GLL point
+
+! create the 2D shape functions and the Jacobian
+ call define_shape_functions(shape2D,dershape2D,xi,gamma,ngnod)
+
+! compute coordinates and jacobian matrix
+ x = ZERO
+ z = ZERO
+
+ xxi = ZERO
+ zxi = ZERO
+ xgamma = ZERO
+ zgamma = ZERO
+
+ do ia=1,ngnod
+
+ nnum = knods(ia,ispec)
+
+ xelm = coorg(1,nnum)
+ zelm = coorg(2,nnum)
+
+ x = x + shape2D(ia)*xelm
+ z = z + shape2D(ia)*zelm
+
+ xxi = xxi + dershape2D(1,ia)*xelm
+ zxi = zxi + dershape2D(1,ia)*zelm
+ xgamma = xgamma + dershape2D(2,ia)*xelm
+ zgamma = zgamma + dershape2D(2,ia)*zelm
+
+ enddo
+
+ jacobian = xxi*zgamma - xgamma*zxi
+
+ if(jacobian <= ZERO) stop '2D Jacobian undefined'
+
+! invert the relation
+ xix = zgamma / jacobian
+ gammax = - zxi / jacobian
+ xiz = - xgamma / jacobian
+ gammaz = xxi / jacobian
+
+ end subroutine recompute_jacobian
+
Added: seismo/2D/SPECFEM2D/trunk/specfem2D.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/specfem2D.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/specfem2D.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,1805 @@
+
+!========================================================================
+!
+! 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
+!
+!========================================================================
+
+!====================================================================================
+!
+! An explicit 2D spectral element solver for the anelastic anisotropic wave equation
+!
+!====================================================================================
+
+!
+! version 5.1, 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
+! - receivers at any location, not only grid points
+! - color PNM snapshots
+! - more flexible DATA/Par_file with any number of comment lines
+! - Xsu scripts for seismograms
+! - subtract t0 from seismograms
+!
+! version 5.0, May 2004 :
+! - got rid of useless routines, suppressed commons etc.
+! - weak formulation based explicitly on stress tensor
+! - implementation of full anisotropy
+! - implementation of attenuation based on memory variables
+!
+! based on SPECFEM2D version 4.2, June 1998
+! (c) by Dimitri Komatitsch, Harvard University, USA
+! and Jean-Pierre Vilotte, Institut de Physique du Globe de Paris, France
+!
+! itself based on SPECFEM2D version 1.0, 1995
+! (c) by Dimitri Komatitsch and Jean-Pierre Vilotte,
+! Institut de Physique du Globe de Paris, France
+!
+
+ program specfem2D
+
+ implicit none
+
+ include "constants.h"
+
+ character(len=80) datlin
+
+ integer source_type,time_function_type
+ double precision x_source,z_source,f0,t0,factor,angleforce
+
+ double precision, dimension(:,:), allocatable :: coorg
+ double precision, dimension(:), allocatable :: coorgread
+
+! receiver information
+ integer, dimension(:), allocatable :: ispec_selected_rec
+ double precision, dimension(:), allocatable :: xi_receiver,gamma_receiver,st_xval,st_zval
+
+ double precision, dimension(:,:), allocatable :: sisux,sisuz
+
+ logical anyabs
+
+ integer i,j,it,irec,ipoin,ip,id
+ integer nbpoin,inump,n,npoinext,ispec,npoin,npgeo,iglob
+
+ double precision dxd,dzd,valux,valuz,hlagrange,rhoextread,vpextread,vsextread
+ 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
+
+! Gauss-Lobatto-Legendre points and weights
+ 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
+
+! 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
+
+ double precision, dimension(NGLLX,NGLLZ) :: tempx1,tempx2,tempz1,tempz2
+
+! 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
+
+! 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,cpsquare
+ double precision mul_unrelaxed,lambdal_unrelaxed,lambdalplus2mul_unrelaxed
+
+ double precision, dimension(:,:), allocatable :: coord,accel,veloc,displ, &
+ flagrange,xinterp,zinterp,Uxinterp,Uzinterp,elastcoef,vector_field_postscript
+
+ 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 :: a11,a12
+
+ double precision, dimension(:,:,:,:), allocatable :: dershape2D,dershape2D_display
+
+ integer, dimension(:,:,:), allocatable :: ibool
+ integer, dimension(:,:), allocatable :: knods
+ integer, dimension(:), allocatable :: kmato,numabs,numsurface
+
+ integer ie,k
+
+ integer ispec_source,iglob_source,ix_source,iz_source
+ double precision a,displnorm_all
+ double precision, dimension(:), allocatable :: source_time_function
+
+ double precision rsizemin,rsizemax,cpoverdxmin,cpoverdxmax, &
+ lambdal_Smin,lambdal_Smax,lambdal_Pmin,lambdal_Pmax,vpmin,vpmax
+
+ integer colors,numbers,subsamp,vecttype,itaff,nrec,sismostype
+ integer numat,ngnod,nspec,iptsdisp,nelemabs,nelemsurface
+
+ logical interpol,meshvect,modelvect,boundvect,readmodel,initialfield,abshaut, &
+ outputgrid,gnuplot,ELASTIC,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
+
+ double precision cutvect,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
+
+ logical, dimension(:,:), allocatable :: codeabs
+
+! for attenuation
+ integer nspec_allocate
+
+ 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
+
+! for color PNM images
+ integer :: NX_IMAGE_PNM,NZ_IMAGE_PNM,iplus1,jplus1,iminus1,jminus1,nx_sem_PNM
+ double precision :: xmin_PNM_image,xmax_PNM_image,zmin_PNM_image,zmax_PNM_image,taille_pixel_horizontal,taille_pixel_vertical
+ integer, dimension(:,:), allocatable :: iglob_image_PNM_2D,copy_iglob_image_PNM_2D
+ double precision, dimension(:,:), allocatable :: donnees_image_PNM_2D
+
+! 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
+
+! Lagrange interpolators at receivers
+ double precision, dimension(:), allocatable :: hxir,hgammar,hpxir,hpgammar
+ double precision, dimension(:,:), allocatable :: hxir_store,hgammar_store
+
+! for Lagrange interpolants
+ double precision, external :: hgll
+
+!***********************************************************************
+!
+! i n i t i a l i z a t i o n p h a s e
+!
+!***********************************************************************
+
+ open (IIN,file='Database')
+
+! uncomment this to write to file instead of standard output
+! open (IOUT,file='results_simulation.txt')
+
+!
+!--- read job title and skip remaining titles of the input file
+!
+ read(IIN,40) datlin
+ read(IIN,40) datlin
+ read(IIN,40) datlin
+ read(IIN,40) datlin
+ read(IIN,40) datlin
+ read(IIN,45) stitle
+
+!
+!---- print the date, time and start-up banner
+!
+ call datim(stitle)
+
+ write(*,*)
+ write(*,*)
+ write(*,*) '*********************'
+ write(*,*) '**** ****'
+ write(*,*) '**** SPECFEM2D ****'
+ write(*,*) '**** ****'
+ write(*,*) '*********************'
+
+!
+!---- read parameters from input file
+!
+
+ read(IIN,40) datlin
+ read(IIN,*) npgeo
+
+ read(IIN,40) datlin
+ read(IIN,*) gnuplot,interpol
+
+ read(IIN,40) datlin
+ read(IIN,*) itaff,colors,numbers
+
+ read(IIN,40) datlin
+ read(IIN,*) meshvect,modelvect,boundvect,cutvect,subsamp,nx_sem_PNM
+ cutvect = cutvect / 100.d0
+
+ read(IIN,40) datlin
+ read(IIN,*) anglerec
+
+ read(IIN,40) datlin
+ read(IIN,*) initialfield
+
+ read(IIN,40) datlin
+ read(IIN,*) sismostype,vecttype
+
+ read(IIN,40) datlin
+ read(IIN,*) readmodel,outputgrid,ELASTIC,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
+
+!---- check parameters read
+ write(IOUT,200) npgeo,NDIM
+ write(IOUT,600) itaff,colors,numbers
+ write(IOUT,700) sismostype,anglerec
+ write(IOUT,750) initialfield,readmodel,ELASTIC,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON,outputgrid
+ write(IOUT,800) vecttype,100.d0*cutvect,subsamp
+
+!---- read time step
+ read(IIN,40) datlin
+ read(IIN,*) NSTEP,deltat
+ write(IOUT,703) NSTEP,deltat,NSTEP*deltat
+
+!
+!---- read source information
+!
+ read(IIN,40) datlin
+ read(IIN,*) source_type,time_function_type,x_source,z_source,f0,t0,factor,angleforce
+
+!
+!----- check the input
+!
+ if(.not. initialfield) then
+ if (source_type == 1) then
+ write(IOUT,212) x_source,z_source,f0,t0,factor,angleforce
+ else if(source_type == 2) then
+ write(IOUT,222) x_source,z_source,f0,t0,factor
+ else
+ stop 'Unknown source type number !'
+ endif
+ endif
+
+! for the source time function
+ a = pi*pi*f0*f0
+
+!----- convert angle from degrees to radians
+ angleforce = angleforce * pi / 180.d0
+
+!
+!---- read the spectral macrobloc nodal coordinates
+!
+ allocate(coorg(NDIM,npgeo))
+
+ ipoin = 0
+ read(IIN,40) datlin
+ allocate(coorgread(NDIM))
+ do ip = 1,npgeo
+ read(IIN,*) ipoin,(coorgread(id),id =1,NDIM)
+ if(ipoin<1 .or. ipoin>npgeo) stop 'Wrong control point number'
+ coorg(:,ipoin) = coorgread
+ enddo
+ deallocate(coorgread)
+
+!
+!---- read the basic properties of the spectral elements
+!
+ read(IIN,40) datlin
+ read(IIN,*) numat,ngnod,nspec,iptsdisp,nelemabs,nelemsurface
+
+!
+!---- allocate arrays
+!
+ allocate(shape2D(ngnod,NGLLX,NGLLZ))
+ allocate(dershape2D(NDIM,ngnod,NGLLX,NGLLZ))
+ allocate(shape2D_display(ngnod,iptsdisp,iptsdisp))
+ allocate(dershape2D_display(NDIM,ngnod,iptsdisp,iptsdisp))
+ allocate(xix(NGLLX,NGLLZ,nspec))
+ allocate(xiz(NGLLX,NGLLZ,nspec))
+ allocate(gammax(NGLLX,NGLLZ,nspec))
+ allocate(gammaz(NGLLX,NGLLZ,nspec))
+ allocate(jacobian(NGLLX,NGLLZ,nspec))
+ allocate(a11(NGLLX,NGLLZ))
+ allocate(a12(NGLLX,NGLLZ))
+ allocate(flagrange(NGLLX,iptsdisp))
+ allocate(xinterp(iptsdisp,iptsdisp))
+ allocate(zinterp(iptsdisp,iptsdisp))
+ allocate(Uxinterp(iptsdisp,iptsdisp))
+ allocate(Uzinterp(iptsdisp,iptsdisp))
+ allocate(density(numat))
+ allocate(elastcoef(4,numat))
+ allocate(kmato(nspec))
+ allocate(knods(ngnod,nspec))
+ allocate(ibool(NGLLX,NGLLZ,nspec))
+
+! 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'
+
+ 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
+ anyabs = .false.
+ else
+ anyabs = .true.
+ endif
+ allocate(numabs(nelemabs))
+ allocate(codeabs(4,nelemabs))
+
+! --- allocate array for free surface condition in acoustic medium
+ if(nelemsurface <= 0) nelemsurface = 1
+ allocate(numsurface(nelemsurface))
+
+!
+!---- print element group main parameters
+!
+ write(IOUT,107)
+ write(IOUT,207) nspec,ngnod,NGLLX,NGLLZ,NGLLX*NGLLZ,iptsdisp,numat,nelemabs
+
+! set up Gauss-Lobatto-Legendre derivation matrices
+ call define_derivative_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz)
+
+!
+!---- read the material properties
+!
+ call gmat01(density,elastcoef,numat)
+
+!
+!---- read spectral macrobloc data
+!
+ n = 0
+ read(IIN,40) datlin
+ do ie = 1,nspec
+ read(IIN,*) n,kmato(n),(knods(k,n), k=1,ngnod)
+ enddo
+
+!
+!---- read absorbing boundary data
+!
+ if(anyabs) then
+ read(IIN,40) 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'
+ numabs(inum) = numabsread
+ codeabs(ITOP,inum) = codeabsread(1)
+ codeabs(IBOTTOM,inum) = codeabsread(2)
+ codeabs(ILEFT,inum) = codeabsread(3)
+ codeabs(IRIGHT,inum) = codeabsread(4)
+ enddo
+ write(*,*)
+ write(*,*) 'Number of absorbing elements: ',nelemabs
+ endif
+
+!
+!---- read free surface data
+!
+ read(IIN,40) datlin
+ 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
+ enddo
+ write(*,*)
+ write(*,*) 'Number of free surface elements: ',nelemsurface
+
+!
+!---- close input file
+!
+ close(IIN)
+
+!
+!---- compute shape functions and their derivatives for SEM grid
+!
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ call define_shape_functions(shape2D(:,i,j),dershape2D(:,:,i,j),xigll(i),zigll(j),ngnod)
+ enddo
+ enddo
+
+!
+!---- generate the global numbering
+!
+
+! version "propre mais lente" ou version "sale mais rapide"
+ if(fast_numbering) then
+ call createnum_fast(knods,ibool,shape2D,coorg,npoin,npgeo,nspec,ngnod)
+ else
+ call createnum_slow(knods,ibool,npoin,nspec,ngnod)
+ endif
+
+!---- compute shape functions and their derivatives for regular !interpolated display grid
+ do j = 1,iptsdisp
+ do i = 1,iptsdisp
+ xirec = 2.d0*dble(i-1)/dble(iptsdisp-1) - 1.d0
+ gammarec = 2.d0*dble(j-1)/dble(iptsdisp-1) - 1.d0
+ call define_shape_functions(shape2D_display(:,i,j),dershape2D_display(:,:,i,j),xirec,gammarec,ngnod)
+ enddo
+ enddo
+
+!---- compute Lagrange interpolants on a regular interpolated grid in (xi,gamma)
+!---- for display (assumes NGLLX = NGLLZ)
+ do j=1,NGLLX
+ do i=1,iptsdisp
+ xirec = 2.d0*dble(i-1)/dble(iptsdisp-1) - 1.d0
+ flagrange(j,i) = hgll(j-1,xirec,xigll,NGLLX)
+ enddo
+ enddo
+
+
+! read total number of receivers
+ open(unit=IIN,file='DATA/STATIONS',status='old')
+ read(IIN,*) nrec
+ close(IIN)
+
+ write(IOUT,*)
+ write(IOUT,*) 'Total number of receivers = ',nrec
+ write(IOUT,*)
+
+ if(nrec < 1) stop 'need at least one receiver'
+
+! allocate seismogram arrays
+ allocate(sisux(NSTEP,nrec))
+ allocate(sisuz(NSTEP,nrec))
+
+! receiver information
+ allocate(ispec_selected_rec(nrec))
+ allocate(st_xval(nrec))
+ allocate(st_zval(nrec))
+ allocate(xi_receiver(nrec))
+ allocate(gamma_receiver(nrec))
+ allocate(station_name(nrec))
+ allocate(network_name(nrec))
+
+! allocate 1-D Lagrange interpolators and derivatives
+ allocate(hxir(NGLLX))
+ allocate(hpxir(NGLLX))
+ allocate(hgammar(NGLLZ))
+ allocate(hpgammar(NGLLZ))
+
+! allocate Lagrange interpolators for receivers
+ allocate(hxir_store(nrec,NGLLX))
+ allocate(hgammar_store(nrec,NGLLZ))
+
+!
+!---- allocation des autres tableaux pour la grille globale et les bords
+!
+
+ allocate(coord(NDIM,npoin))
+
+ allocate(accel(NDIM,npoin))
+ allocate(displ(NDIM,npoin))
+ allocate(veloc(NDIM,npoin))
+
+! for acoustic medium
+ if(ELASTIC) then
+ allocate(vector_field_postscript(NDIM,1))
+ else
+ allocate(vector_field_postscript(NDIM,npoin))
+ endif
+
+ allocate(rmass(npoin))
+
+ if(readmodel) 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
+!
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ xi = xigll(i)
+ gamma = zigll(j)
+
+ call recompute_jacobian(xi,gamma,x,z,xixl,xizl,gammaxl,gammazl,jacobianl,coorg,knods,ispec,ngnod,nspec,npgeo)
+
+ coord(1,ibool(i,j,ispec)) = x
+ coord(2,ibool(i,j,ispec)) = z
+
+ xix(i,j,ispec) = xixl
+ xiz(i,j,ispec) = xizl
+ gammax(i,j,ispec) = gammaxl
+ gammaz(i,j,ispec) = gammazl
+ jacobian(i,j,ispec) = jacobianl
+
+ enddo
+ enddo
+ enddo
+
+!
+!--- save the grid of points in a file
+!
+ if(outputgrid) then
+ print *
+ print *,'Saving the grid in a text file...'
+ print *
+ open(unit=55,file='gridpoints.txt',status='unknown')
+ write(55,*) npoin
+ do n = 1,npoin
+ write(55,*) n,(coord(i,n), i=1,NDIM)
+ enddo
+ close(55)
+ endif
+
+!
+!----- plot the GLL mesh in a Gnuplot file
+!
+ if(gnuplot) call plotgll(knods,ibool,coorg,coord,npoin,npgeo,ngnod,nspec)
+
+!
+!---- define coefficients of the Newmark time scheme
+!
+ deltatover2 = HALF*deltat
+ deltatsquareover2 = HALF*deltat*deltat
+
+!
+!---- definir la position reelle des points source et recepteurs
+!
+ call positsource(coord,ibool,npoin,nspec,x_source,z_source,source_type,ix_source,iz_source,ispec_source,iglob_source)
+
+! locate receivers in the mesh
+ 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)
+
+! define and store Lagrange interpolators at all the receivers
+ do irec = 1,nrec
+ call lagrange_any(xi_receiver(irec),NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(gamma_receiver(irec),NGLLZ,zigll,hgammar,hpgammar)
+ hxir_store(irec,:) = hxir(:)
+ hgammar_store(irec,:) = hgammar(:)
+ enddo
+
+!
+!---- eventuellement lecture d'un modele externe de vitesse et de densite
+!
+ if(readmodel) then
+ print *
+ print *,'Reading velocity and density model from external file...'
+ print *
+ open(unit=55,file='extmodel.txt',status='unknown')
+ read(55,*) nbpoin
+ if(nbpoin /= npoin) stop 'Wrong number of points in input file'
+ do n = 1,npoin
+ read(55,*) inump,rhoextread,vpextread,vsextread
+ if(inump<1 .or. inump>npoin) stop 'Wrong point number'
+ rhoext(inump) = rhoextread
+ vpext(inump) = vpextread
+ vsext(inump) = vsextread
+ enddo
+ close(55)
+ endif
+
+!
+!---- define all arrays
+!
+ call defarrays(vpext,vsext,rhoext,density,elastcoef, &
+ xigll,zigll,xix,xiz,gammax,gammaz,a11,a12, &
+ ibool,kmato,coord,npoin,rsizemin,rsizemax, &
+ cpoverdxmin,cpoverdxmax,lambdal_Smin,lambdal_Smax,lambdal_Pmin,lambdal_Pmax, &
+ vpmin,vpmax,readmodel,nspec,numat,source_type,ix_source,iz_source,ispec_source)
+
+! build the global mass matrix once and for all
+ rmass(:) = ZERO
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+! if external density model
+ if(readmodel) then
+ rhol = rhoext(iglob)
+ cpsquare = vpext(iglob)**2
+ else
+ rhol = density(kmato(ispec))
+ lambdal_relaxed = elastcoef(1,kmato(ispec))
+ mul_relaxed = elastcoef(2,kmato(ispec))
+ 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)
+ else
+ rmass(iglob) = rmass(iglob) + wxgll(i)*wzgll(j)*jacobian(i,j,ispec) / cpsquare
+ endif
+ enddo
+ enddo
+ enddo
+
+! convertir angle recepteurs en 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,cpoverdxmin,cpoverdxmax,lambdal_Smin,lambdal_Smax,lambdal_Pmin,lambdal_Pmax)
+
+!
+!---- for color PNM images
+!
+
+! taille horizontale de l'image
+ xmin_PNM_image = minval(coord(1,:))
+ xmax_PNM_image = maxval(coord(1,:))
+
+! taille verticale de l'image, augmenter un peu pour depasser de la topographie
+ zmin_PNM_image = minval(coord(2,:))
+ zmax_PNM_image = maxval(coord(2,:))
+ zmax_PNM_image = zmin_PNM_image + 1.05d0 * (zmax_PNM_image - zmin_PNM_image)
+
+! calculer le nombre de pixels en horizontal en fonction du nombre d'elements spectraux
+ NX_IMAGE_PNM = nx_sem_PNM * (NGLLX-1) + 1
+
+! calculer le nombre de pixels en vertical en fonction du rapport des tailles
+ NZ_IMAGE_PNM = nint(NX_IMAGE_PNM * (zmax_PNM_image - zmin_PNM_image) / (xmax_PNM_image - xmin_PNM_image))
+
+! allouer un tableau pour les donnees de l'image
+ allocate(donnees_image_PNM_2D(NX_IMAGE_PNM,NZ_IMAGE_PNM))
+
+! allouer un tableau pour le point de grille contenant cette donnee
+ allocate(iglob_image_PNM_2D(NX_IMAGE_PNM,NZ_IMAGE_PNM))
+ allocate(copy_iglob_image_PNM_2D(NX_IMAGE_PNM,NZ_IMAGE_PNM))
+
+! creer tous les pixels
+ print *
+ print *,'localisation de tous les pixels des images PNM'
+
+ taille_pixel_horizontal = (xmax_PNM_image - xmin_PNM_image) / dble(NX_IMAGE_PNM-1)
+ taille_pixel_vertical = (zmax_PNM_image - zmin_PNM_image) / dble(NZ_IMAGE_PNM-1)
+
+ iglob_image_PNM_2D(:,:) = -1
+
+! boucle sur tous les points de grille pour leur affecter un pixel de l'image
+ do n=1,npoin
+
+! calculer les coordonnees du pixel
+ i = nint((coord(1,n) - xmin_PNM_image) / taille_pixel_horizontal + 1)
+ j = nint((coord(2,n) - zmin_PNM_image) / taille_pixel_vertical + 1)
+
+! eviter les effets de bord
+ if(i < 1) i = 1
+ if(i > NX_IMAGE_PNM) i = NX_IMAGE_PNM
+
+ if(j < 1) j = 1
+ if(j > NZ_IMAGE_PNM) j = NZ_IMAGE_PNM
+
+! affecter ce point a ce pixel
+ iglob_image_PNM_2D(i,j) = n
+
+ enddo
+
+! completer les pixels manquants en les localisant par la distance minimum
+ copy_iglob_image_PNM_2D(:,:) = iglob_image_PNM_2D(:,:)
+
+ do j = 1,NZ_IMAGE_PNM
+ do i = 1,NX_IMAGE_PNM
+
+ if(copy_iglob_image_PNM_2D(i,j) == -1) then
+
+ iplus1 = i + 1
+ iminus1 = i - 1
+
+ jplus1 = j + 1
+ jminus1 = j - 1
+
+! eviter les effets de bord
+ if(iminus1 < 1) iminus1 = 1
+ if(iplus1 > NX_IMAGE_PNM) iplus1 = NX_IMAGE_PNM
+
+ if(jminus1 < 1) jminus1 = 1
+ if(jplus1 > NZ_IMAGE_PNM) jplus1 = NZ_IMAGE_PNM
+
+! utiliser les pixels voisins pour remplir les trous
+
+! horizontales
+ if(copy_iglob_image_PNM_2D(iplus1,j) /= -1) then
+ iglob_image_PNM_2D(i,j) = copy_iglob_image_PNM_2D(iplus1,j)
+
+ else if(copy_iglob_image_PNM_2D(iminus1,j) /= -1) then
+ iglob_image_PNM_2D(i,j) = copy_iglob_image_PNM_2D(iminus1,j)
+
+! verticales
+ else if(copy_iglob_image_PNM_2D(i,jplus1) /= -1) then
+ iglob_image_PNM_2D(i,j) = copy_iglob_image_PNM_2D(i,jplus1)
+
+ else if(copy_iglob_image_PNM_2D(i,jminus1) /= -1) then
+ iglob_image_PNM_2D(i,j) = copy_iglob_image_PNM_2D(i,jminus1)
+
+! diagonales
+ else if(copy_iglob_image_PNM_2D(iminus1,jminus1) /= -1) then
+ iglob_image_PNM_2D(i,j) = copy_iglob_image_PNM_2D(iminus1,jminus1)
+
+ else if(copy_iglob_image_PNM_2D(iplus1,jminus1) /= -1) then
+ iglob_image_PNM_2D(i,j) = copy_iglob_image_PNM_2D(iplus1,jminus1)
+
+ else if(copy_iglob_image_PNM_2D(iminus1,jplus1) /= -1) then
+ iglob_image_PNM_2D(i,j) = copy_iglob_image_PNM_2D(iminus1,jplus1)
+
+ else if(copy_iglob_image_PNM_2D(iplus1,jplus1) /= -1) then
+ iglob_image_PNM_2D(i,j) = copy_iglob_image_PNM_2D(iplus1,jplus1)
+
+ endif
+
+ endif
+
+ enddo
+ enddo
+
+ deallocate(copy_iglob_image_PNM_2D)
+
+ print *,'fin localisation de tous les pixels des images PNM'
+
+!
+!---- initialiser sismogrammes
+!
+ sisux = ZERO
+ sisuz = ZERO
+
+ cosrot = cos(anglerec)
+ sinrot = sin(anglerec)
+
+! initialiser les tableaux a zero
+ accel = ZERO
+ veloc = ZERO
+ displ = ZERO
+
+!
+!---- eventuellement lecture des champs initiaux dans un fichier
+!
+ if(initialfield) then
+ print *
+ print *,'Reading initial fields from external file...'
+ print *
+ open(unit=55,file='wavefields.txt',status='unknown')
+ read(55,*) nbpoin
+ if(nbpoin /= npoin) stop 'Wrong number of points in input file'
+ allocate(displread(NDIM))
+ allocate(velocread(NDIM))
+ allocate(accelread(NDIM))
+ do n = 1,npoin
+ 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
+ enddo
+ deallocate(displread)
+ deallocate(velocread)
+ deallocate(accelread)
+ close(55)
+ print *,'Max norm of initial displacement = ',maxval(sqrt(displ(1,:)**2 + displ(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
+
+ twelvedeltat = 12.d0 * deltat
+ fourdeltatsquare = 4.d0 * deltatsquare
+
+! --- compute the source time function and store it in a text file
+ if(.not. initialfield) then
+
+ allocate(source_time_function(NSTEP))
+
+ print *
+ print *,'Saving the source time function in a text file...'
+ print *
+ open(unit=55,file='source.txt',status='unknown')
+
+! boucle principale d'evolution en temps
+ do it = 1,NSTEP
+
+! compute current time
+ time = (it-1)*deltat
+
+! Ricker (second derivative of a Gaussian) source time function
+ if(time_function_type == 1) then
+ source_time_function(it) = - factor * (ONE-TWO*a*(time-t0)**2) * exp(-a*(time-t0)**2)
+
+! first derivative of a Gaussian source time function
+ else if(time_function_type == 2) then
+ source_time_function(it) = - factor * TWO*a*(time-t0) * exp(-a*(time-t0)**2)
+
+! Gaussian or Dirac (we use a very thin Gaussian instead) source time function
+ else if(time_function_type == 3 .or. time_function_type == 4) then
+ source_time_function(it) = factor * exp(-a*(time-t0)**2)
+
+ else
+ stop 'unknown source time function'
+ endif
+
+ write(55,*) sngl(time-t0),sngl(source_time_function(it))
+
+ enddo
+
+ close(55)
+
+ else
+
+ allocate(source_time_function(1))
+
+ endif
+
+!
+!---- s t a r t t i m e i t e r a t i o n s
+!
+
+ write(IOUT,400)
+
+! boucle principale d'evolution en temps
+ do it = 1,NSTEP
+
+! compute current time
+ time = (it-1)*deltat
+
+ if(mod(it,itaff) == 0) then
+ write(IOUT,*)
+ if(time >= 1.d-3) then
+ write(IOUT,100) it,time
+ else
+ write(IOUT,101) it,time
+ endif
+ endif
+
+! 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)
+
+! update displacement using finite-difference time scheme (Newmark)
+ displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsquareover2*accel(:,:)
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+ accel(:,:) = ZERO
+
+
+!--- 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. Also check that
+! top absorbing boundary is not set because cannot be both absorbing and free surface
+ if(.not. ELASTIC .and. .not. abshaut) then
+
+ do ispecsurface=1,nelemsurface
+
+ ispec = numsurface(ispecsurface)
+
+ j = NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec)
+ displ(:,iglob) = ZERO
+ veloc(:,iglob) = ZERO
+ accel(:,iglob) = ZERO
+ enddo
+
+ enddo
+
+ endif ! end of free surface condition for acoustic medium
+
+
+! integration over spectral elements
+ do ispec = 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
+
+! first double loop over GLL to compute and store gradients
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+!--- if external medium, get elastic parameters of current grid point
+ if(readmodel) 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
+
+! 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
+
+! 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
+
+! 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 = tempx1l*xixl + tempx2l*gammaxl
+ duxdzl = tempx1l*xizl + tempx2l*gammazl
+
+ duzdxl = tempz1l*xixl + tempz2l*gammaxl
+ duzdzl = tempz1l*xizl + tempz2l*gammazl
+
+! compute stress tensor (include attenuation or anisotropy if needed)
+
+ if(TURN_ATTENUATION_ON) then
+
+! 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
+
+! 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))
+
+ else
+
+! no attenuation
+ sigma_xx = lambdalplus2mul_relaxed*duxdxl + lambdal_relaxed*duzdzl
+ sigma_xz = mul_relaxed*(duzdxl + duxdzl)
+ sigma_zz = lambdalplus2mul_relaxed*duzdzl + lambdal_relaxed*duxdxl
+
+ endif
+
+! full anisotropy
+ if(TURN_ANISOTROPY_ON) then
+
+! implement anisotropy in 2D
+ duydyl = ZERO
+ duydzl = ZERO
+ duzdyl = ZERO
+ duxdyl = ZERO
+ duydxl = ZERO
+
+! 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
+
+ sigma_xx = c11val*duxdxl + c16val*duxdyl_plus_duydxl + c12val*duydyl + &
+ c15val*duzdxl_plus_duxdzl + c14val*duzdyl_plus_duydzl + c13val*duzdzl
+
+! sigma_yy = c12val*duxdxl + c26val*duxdyl_plus_duydxl + c22val*duydyl + &
+! c25val*duzdxl_plus_duxdzl + c24val*duzdyl_plus_duydzl + c23val*duzdzl
+
+ sigma_zz = c13val*duxdxl + c36val*duxdyl_plus_duydxl + c23val*duydyl + &
+ c35val*duzdxl_plus_duxdzl + c34val*duzdyl_plus_duydzl + c33val*duzdzl
+
+! sigma_xy = c16val*duxdxl + c66val*duxdyl_plus_duydxl + c26val*duydyl + &
+! c56val*duzdxl_plus_duxdzl + c46val*duzdyl_plus_duydzl + c36val*duzdzl
+
+ sigma_xz = c15val*duxdxl + c56val*duxdyl_plus_duydxl + c25val*duydyl + &
+ c55val*duzdxl_plus_duxdzl + c45val*duzdyl_plus_duydzl + c35val*duzdzl
+
+! sigma_yz = c14val*duxdxl + c46val*duxdyl_plus_duydxl + c24val*duydyl + &
+! c45val*duzdxl_plus_duxdzl + c44val*duzdyl_plus_duydzl + c34val*duzdzl
+
+ endif
+
+! stress tensor is symmetric
+ sigma_zx = sigma_xz
+
+ jacobianl = jacobian(i,j,ispec)
+
+! weak formulation term based on stress tensor (non-symmetric form)
+ tempx1(i,j) = jacobianl*(sigma_xx*xixl+sigma_zx*xizl)
+ tempz1(i,j) = jacobianl*(sigma_xz*xixl+sigma_zz*xizl)
+
+ tempx2(i,j) = jacobianl*(sigma_xx*gammaxl+sigma_zx*gammazl)
+ tempz2(i,j) = jacobianl*(sigma_xz*gammaxl+sigma_zz*gammazl)
+
+! for acoustic medium
+ if(.not. ELASTIC) then
+ tempx1(i,j) = jacobianl*(xixl*dUxdxl + xizl*dUxdzl)
+ tempx2(i,j) = jacobianl*(gammaxl*dUxdxl + gammazl*dUxdzl)
+ endif
+
+ enddo
+ enddo
+
+!
+! second double-loop over GLL to compute all terms
+!
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+! 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
+
+! 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
+
+! GLL integration weights
+ fac1 = wzgll(j)
+ fac2 = wxgll(i)
+
+! 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
+
+ enddo ! second loop over the GLL points
+ enddo
+
+ 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)
+
+ zgamma = xix(i,j,ispec) * jacobian(i,j,ispec)
+
+! external velocity model
+ if(readmodel) then
+ cpl = vpext(iglob)
+ csl = vsext(iglob)
+ rhol = rhoext(iglob)
+ 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
+ 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(readmodel) then
+ cpl = vpext(iglob)
+ csl = vsext(iglob)
+ rhol = rhoext(iglob)
+ 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
+ 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
+ i1abs = 1
+ i2abs = NGLLX
+ if(codeabs(ILEFT,ispecabs)) i1abs = 2
+ if(codeabs(IRIGHT,ispecabs)) i2abs = NGLLX-1
+
+ do i=i1abs,i2abs
+
+ iglob = ibool(i,j,ispec)
+
+ xxi = gammaz(i,j,ispec) * jacobian(i,j,ispec)
+
+! external velocity model
+ if(readmodel) then
+ cpl = vpext(iglob)
+ csl = vsext(iglob)
+ rhol = rhoext(iglob)
+ endif
+
+ rho_vp = rhol*cpl
+ rho_vs = rhol*csl
+
+ nx = ZERO
+ nz = -ONE
+
+ 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
+ else
+ accel(1,iglob) = accel(1,iglob) - veloc(1,iglob)*weight/cpl
+ 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
+ i1abs = 1
+ i2abs = NGLLX
+ if(codeabs(ILEFT,ispecabs)) i1abs = 2
+ if(codeabs(IRIGHT,ispecabs)) i2abs = NGLLX-1
+
+ do i=i1abs,i2abs
+
+ iglob = ibool(i,j,ispec)
+
+ xxi = gammaz(i,j,ispec) * jacobian(i,j,ispec)
+
+! external velocity model
+ if(readmodel) then
+ cpl = vpext(iglob)
+ csl = vsext(iglob)
+ rhol = rhoext(iglob)
+ endif
+
+ rho_vp = rhol*cpl
+ rho_vs = rhol*csl
+
+ nx = ZERO
+ nz = ONE
+
+ 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
+ else
+ accel(1,iglob) = accel(1,iglob) - veloc(1,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 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
+
+! explosion
+ else if(source_type == 2) then
+ do i=1,NGLLX
+ do j=1,NGLLX
+ iglob = ibool(i,j,ispec_source)
+ accel(1,iglob) = accel(1,iglob) + a11(i,j)*source_time_function(it)
+ accel(2,iglob) = accel(2,iglob) + a12(i,j)*source_time_function(it)
+ enddo
+ enddo
+ endif
+
+ else
+ stop 'wrong source type'
+ endif
+
+! divide by the mass matrix
+ accel(1,:) = accel(1,:) / rmass(:)
+ accel(2,:) = accel(2,:) / rmass(:)
+
+! update velocity
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+
+
+!--- 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. Also check that
+! top absorbing boundary is not set because cannot be both absorbing and free surface
+ if(.not. ELASTIC .and. .not. abshaut) then
+
+ do ispecsurface=1,nelemsurface
+
+ ispec = numsurface(ispecsurface)
+
+ j = NGLLZ
+ do i=1,NGLLX
+ iglob = ibool(i,j,ispec)
+ displ(:,iglob) = ZERO
+ veloc(:,iglob) = ZERO
+ accel(:,iglob) = ZERO
+ enddo
+
+ enddo
+
+ endif ! end of free surface condition for acoustic medium
+
+
+! implement attenuation
+ if(TURN_ATTENUATION_ON) then
+
+! 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)
+
+! update memory variables with fourth-order Runge-Kutta time scheme for attenuation
+ do k=1,nspec
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+ theta_n = duxdxl_n(i,j,k) + duzdzl_n(i,j,k)
+ theta_np1 = duxdxl_np1(i,j,k) + duzdzl_np1(i,j,k)
+
+! 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
+
+! 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
+
+! 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
+
+! 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
+
+! 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
+
+! 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 max of norm of displacement
+ if(mod(it,itaff) == 0) then
+ displnorm_all = maxval(sqrt(displ(1,:)**2 + displ(2,:)**2))
+ print *,'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'
+ endif
+
+! store the seismograms
+ if(sismostype < 1 .or. sismostype > 3) stop 'Wrong field code for seismogram output'
+
+ if(.not. ELASTIC) 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
+! 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)
+ endif
+ endif
+
+ do irec=1,nrec
+
+! perform the general interpolation using Lagrange polynomials
+ valux = ZERO
+ valuz = ZERO
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec_selected_rec(irec))
+
+ hlagrange = hxir_store(irec,i)*hgammar_store(irec,j)
+
+ if(ELASTIC) 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
+
+ else
+
+! for acoustic medium
+ dxd = vector_field_postscript(1,iglob)
+ dzd = vector_field_postscript(2,iglob)
+
+ endif
+
+! compute interpolated field
+ valux = valux + dxd*hlagrange
+ valuz = valuz + dzd*hlagrange
+
+ enddo
+ enddo
+
+! rotate seismogram components if needed
+ sisux(it,irec) = cosrot*valux + sinrot*valuz
+ sisuz(it,irec) = - sinrot*valux + cosrot*valuz
+
+ enddo
+
+!
+!---- affichage des resultats a certains pas de temps
+!
+ if(mod(it,itaff) == 0 .or. it == 5 .or. it == NSTEP) then
+
+ write(IOUT,*)
+ if(time >= 1.d-3) then
+ write(IOUT,110) time
+ else
+ write(IOUT,111) time
+ endif
+ write(IOUT,*)
+
+!
+!---- affichage postscript
+!
+ write(IOUT,*) 'Dump PostScript'
+
+! for elastic medium
+ if(ELASTIC .and. vecttype == 1) then
+ write(IOUT,*) 'drawing displacement field...'
+ call plotpost(displ,coord,vpext,iglob_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,readmodel,cutvect,nelemabs,numat,iptsdisp,nspec,ngnod,ELASTIC)
+
+ else if(ELASTIC .and. vecttype == 2) then
+ write(IOUT,*) 'drawing velocity field...'
+ call plotpost(veloc,coord,vpext,iglob_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,readmodel,cutvect,nelemabs,numat,iptsdisp,nspec,ngnod,ELASTIC)
+
+ else if(ELASTIC .and. vecttype == 3) then
+ write(IOUT,*) 'drawing acceleration field...'
+ call plotpost(accel,coord,vpext,iglob_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,readmodel,cutvect,nelemabs,numat,iptsdisp,nspec,ngnod,ELASTIC)
+
+! for acoustic medium
+ else if(.not. ELASTIC .and. vecttype == 1) then
+ stop 'cannot display displacement field in acoustic medium because of potential formulation'
+
+ else if(.not. ELASTIC .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,iglob_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,readmodel,cutvect,nelemabs,numat,iptsdisp,nspec,ngnod,ELASTIC)
+
+ else if(.not. ELASTIC .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,iglob_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,readmodel,cutvect,nelemabs,numat,iptsdisp,nspec,ngnod,ELASTIC)
+
+ else
+ stop 'wrong field code for PostScript display'
+ endif
+ write(IOUT,*) 'Fin dump PostScript'
+
+!
+!---- affichage image PNM
+!
+ write(IOUT,*) 'Creation image PNM de taille ',NX_IMAGE_PNM,' x ',NZ_IMAGE_PNM
+
+ donnees_image_PNM_2D(:,:) = 0.d0
+
+ do j = 1,NZ_IMAGE_PNM
+ do i = 1,NX_IMAGE_PNM
+ if(iglob_image_PNM_2D(i,j) /= -1) then
+! display vertical component of vector
+ if(ELASTIC) then
+ if(vecttype == 1) then
+ donnees_image_PNM_2D(i,j) = displ(2,iglob_image_PNM_2D(i,j))
+ else if(vecttype == 2) then
+ donnees_image_PNM_2D(i,j) = veloc(2,iglob_image_PNM_2D(i,j))
+ else
+ donnees_image_PNM_2D(i,j) = accel(2,iglob_image_PNM_2D(i,j))
+ endif
+ else
+! for acoustic medium
+ donnees_image_PNM_2D(i,j) = vector_field_postscript(2,iglob_image_PNM_2D(i,j))
+ endif
+ endif
+ enddo
+ enddo
+
+ call cree_image_PNM(donnees_image_PNM_2D,iglob_image_PNM_2D,NX_IMAGE_PNM,NZ_IMAGE_PNM,it,cutvect)
+
+ write(IOUT,*) 'Fin creation image PNM'
+
+!---- save temporary seismograms
+ call write_seismograms(sisux,sisuz,station_name,network_name,NSTEP,nrec,deltat,sismostype,st_xval,it,t0)
+
+
+ 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)
+
+! print exit banner
+ call datim(stitle)
+
+!
+!---- close output file
+!
+ close(IOUT)
+
+!
+!---- formats
+!
+ 40 format(a80)
+ 45 format(a50)
+ 100 format('Pas de temps numero ',i5,' t = ',f7.4,' s')
+ 101 format('Pas de temps numero ',i5,' t = ',1pe10.4,' s')
+ 110 format('Sauvegarde deplacement temps t = ',f7.4,' s')
+ 111 format('Sauvegarde deplacement temps t = ',1pe10.4,' s')
+ 400 format(/1x,41('=')/,' = T i m e e v o l u t i o n l o o p ='/1x,41('=')/)
+
+ 200 format(//1x,'C o n t r o l',/1x,34('='),//5x,&
+ 'Number of spectral element control nodes. . .(npgeo) =',i8/5x, &
+ 'Number of space dimensions . . . . . . . . . (NDIM) =',i8)
+ 600 format(//1x,'C o n t r o l',/1x,34('='),//5x, &
+ 'Display frequency . . . . . . . . . . . . . (itaff) = ',i5/ 5x, &
+ 'Color display . . . . . . . . . . . . . . . (colors) = ',i5/ 5x, &
+ ' == 0 black and white display ', / 5x, &
+ ' == 1 color display ', /5x, &
+ 'Numbered mesh . . . . . . . . . . . . . . .(numbers) = ',i5/ 5x, &
+ ' == 0 do not number the mesh ', /5x, &
+ ' == 1 number the mesh ')
+ 700 format(//1x,'C o n t r o l',/1x,34('='),//5x, &
+ 'Seismograms recording type. . . . . . .(sismostype) = ',i6/5x, &
+ 'Angle for first line of receivers. . . . .(anglerec) = ',f6.2)
+ 750 format(//1x,'C o n t r o l',/1x,34('='),//5x, &
+ 'Read external initial field or not . .(initialfield) = ',l6/5x, &
+ 'Read external velocity model or not . . .(readmodel) = ',l6/5x, &
+ 'Elastic simulation or acoustic. . . . . . .(ELASTIC) = ',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,34('='),//5x, &
+ 'Vector display type . . . . . . . . . . .(vecttype) = ',i6/5x, &
+ 'Percentage of cut for vector plots. . . . .(cutvect) = ',f6.2/5x, &
+ 'Subsampling for velocity model display . .(subsamp) = ',i6)
+
+ 703 format(//' I t e r a t i o n s '/1x,29('='),//5x, &
+ 'Number of time iterations . . . . .(NSTEP) =',i8,/5x, &
+ 'Time step increment . . . . . . . .(deltat) =',1pe15.6,/5x, &
+ 'Total simulation duration . . . . . (ttot) =',1pe15.6)
+
+ 107 format(/5x,'--> Isoparametric Spectral Elements <--',//)
+ 207 format(5x, &
+ 'Number of spectral elements . . . . . (nspec) =',i7,/5x, &
+ 'Number of control nodes per element . (ngnod) =',i7,/5x, &
+ 'Number of points in X-direction . . . (NGLLX) =',i7,/5x, &
+ 'Number of points in Y-direction . . . (NGLLZ) =',i7,/5x, &
+ 'Number of points per element. . .(NGLLX*NGLLZ) =',i7,/5x, &
+ 'Number of points for display . . . .(iptsdisp) =',i7,/5x, &
+ 'Number of element material sets . . . (numat) =',i7,/5x, &
+ 'Number of absorbing elements . . . .(nelemabs) =',i7)
+
+ 212 format(//,5x, &
+ 'Source Type. . . . . . . . . . . . . . = Collocated Force',/5x, &
+ 'X-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Y-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Fundamental frequency (Hz) . . . . . . =',1pe20.10,/5x, &
+ 'Time delay (s) . . . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Multiplying factor . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Angle from vertical direction (deg). . =',1pe20.10,/5x)
+ 222 format(//,5x, &
+ 'Source Type. . . . . . . . . . . . . . = Explosion',/5x, &
+ 'X-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Y-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Fundamental frequency (Hz) . . . . . . =',1pe20.10,/5x, &
+ 'Time delay (s) . . . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Multiplying factor . . . . . . . . . . =',1pe20.10,/5x)
+
+ end program specfem2D
+
Added: seismo/2D/SPECFEM2D/trunk/write_seismograms.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/write_seismograms.f90 2005-01-19 15:52:46 UTC (rev 8440)
+++ seismo/2D/SPECFEM2D/trunk/write_seismograms.f90 2007-12-07 23:46:40 UTC (rev 8441)
@@ -0,0 +1,185 @@
+!=====================================================================
+!
+! S p e c f e m 3 D B a s i n V e r s i o n 1 . 2
+! --------------------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology July 2004
+!
+! A signed non-commercial agreement is required to use this program.
+! Please check http://www.gps.caltech.edu/research/jtromp for details.
+! Free for non-commercial academic research ONLY.
+! This program is distributed WITHOUT ANY WARRANTY whatsoever.
+! Do not redistribute this program without written permission.
+!
+!=====================================================================
+
+! write seismograms to text files
+
+ subroutine write_seismograms(sisux,sisuz,station_name,network_name,NSTEP,nrec,deltat,sismostype,st_xval,it,t0)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nrec,NSTEP,it,sismostype
+ double precision t0,deltat
+
+ double precision,dimension(NSTEP,nrec) :: sisux,sisuz
+
+ double precision st_xval(nrec)
+
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+
+ integer irec,length_station_name,length_network_name,iorientation,isample
+
+ character(len=4) chn
+ character(len=1) component
+ character(len=150) sisname
+
+! scaling factor for Seismic Unix xsu dislay
+ double precision, parameter :: FACTORXSU = 1.d0
+
+! write seismograms in ASCII format
+
+! save displacement, velocity or acceleration
+ if(sismostype == 1) then
+ component = 'd'
+ else if(sismostype == 2) then
+ component = 'v'
+ else if(sismostype == 3) then
+ component = 'a'
+ else
+ stop 'wrong component to save for seismograms'
+ endif
+
+ do irec = 1,nrec
+
+ do iorientation = 1,NDIM
+
+ if(iorientation == 1) then
+ chn = 'BHX'
+ else if(iorientation == 2) then
+ chn = 'BHZ'
+ else
+ stop 'incorrect channel value'
+ endif
+
+! create the name of the seismogram file for each slice
+! file name includes the name of the station, the network and the component
+ length_station_name = len_trim(station_name(irec))
+ length_network_name = len_trim(network_name(irec))
+
+! check that length conforms to standard
+ if(length_station_name < 1 .or. length_station_name > MAX_LENGTH_STATION_NAME) stop 'wrong length of station name'
+
+ if(length_network_name < 1 .or. length_network_name > MAX_LENGTH_NETWORK_NAME) stop 'wrong length of network name'
+
+ write(sisname,"(a,'.',a,'.',a3,'.sem',a1)") station_name(irec)(1:length_station_name),&
+ network_name(irec)(1:length_network_name),chn,component
+
+! save seismograms in text format with no subsampling.
+! Because we do not subsample the output, this can result in large files
+! if the simulation uses many time steps. However, subsampling the output
+! here would result in a loss of accuracy when one later convolves
+! the results with the source time function
+ open(unit=IOUT,file=sisname(1:len_trim(sisname)),status='unknown')
+
+! make sure we never write more than the maximum number of time steps
+! subtract offset of the source to make sure travel time is correct
+ do isample = 1,min(it,NSTEP)
+ if(iorientation == 1) then
+ write(IOUT,*) sngl(dble(isample-1)*deltat - t0),' ',sngl(sisux(isample,irec))
+ else
+ write(IOUT,*) sngl(dble(isample-1)*deltat - t0),' ',sngl(sisuz(isample,irec))
+ endif
+ enddo
+
+ close(IOUT)
+
+ enddo
+
+ enddo
+
+!----
+
+! write seismograms in single precision binary format
+
+! X component
+ open(unit=11,file='Ux_file.bin',status='unknown',access='direct',recl=NSTEP*4)
+ do irec=1,nrec
+ write(11,rec=irec) (sngl(sisux(isample,irec)),isample=1,NSTEP)
+ enddo
+ close(11)
+
+! Z component
+ open(unit=11,file='Uz_file.bin',status='unknown',access='direct',recl=NSTEP*4)
+ do irec=1,nrec
+ write(11,rec=irec) (sngl(sisuz(isample,irec)),isample=1,NSTEP)
+ enddo
+ close(11)
+
+!----
+
+! ligne de recepteurs pour Xsu
+ open(unit=11,file='receiver_line_Xsu_XWindow',status='unknown')
+
+! subtract t0 from seismograms to get correct zero time
+ write(11,110) FACTORXSU,NSTEP,deltat,-t0,nrec
+
+ do irec=1,nrec
+ write(11,140) st_xval(irec)
+ if(irec < nrec) write(11,*) ','
+ enddo
+
+ if(sismostype == 1) then
+ write(11,*) '@title="Ux at displacement@component"@<@Ux_file.bin'
+ else if(sismostype == 2) then
+ write(11,*) '@title="Ux at velocity@component"@<@Ux_file.bin'
+ else
+ write(11,*) '@title="Ux at acceleration@component"@<@Ux_file.bin'
+ endif
+
+ close(11)
+
+! script de visualisation
+ open(unit=11,file='show_receiver_line_Xsu',status='unknown')
+ write(11,100)
+ write(11,*)
+ write(11,*) '/bin/rm -f tempfile receiver_line_Xsu_postscript'
+ write(11,*) '# concatener toutes les lignes'
+ write(11,*) 'tr -d ''\012'' <receiver_line_Xsu_XWindow >tempfile'
+ write(11,*) '# remettre fin de ligne'
+ write(11,*) 'echo " " >> tempfile'
+ write(11,*) '# supprimer espaces, changer arobas, dupliquer'
+ write(11,120)
+ write(11,*) '/bin/rm -f tempfile'
+ write(11,*) '# copier fichier pour sortie postscript'
+ write(11,130)
+ write(11,*) '/bin/rm -f tempfile'
+ write(11,*) 'echo ''rm -f uxpoly.ps uzpoly.ps'' > tempfile'
+ write(11,*) 'cat tempfile receiver_line_Xsu_postscript > tempfile2'
+ write(11,*) '/bin/mv -f tempfile2 receiver_line_Xsu_postscript'
+ write(11,*) '/bin/rm -f tempfile'
+ write(11,*) '# executer commande xsu'
+ write(11,*) 'sh receiver_line_Xsu_XWindow'
+ write(11,*) '/bin/rm -f tempfile tempfile2'
+ close(11)
+
+! formats
+ 100 format('#!/bin/csh -f')
+
+ 110 format('xwigb at xcur=',f8.2,'@n1=',i5,'@d1=',f15.8,'@f1=',f15.8,'@label1="Time@(s)"@label2="x@(m)"@n2=',i5,'@x2=')
+
+ 120 format('sed -e ''1,$s/ //g'' -e ''1,$s/@/ /g'' -e ''1,1p'' -e ''$,$s/Ux/Uz/g'' <tempfile > receiver_line_Xsu_XWindow')
+
+ 130 format('sed -e ''1,$s/xwigb/pswigp/g'' ', &
+ '-e ''1,$s/Ux_file.bin/Ux_file.bin > uxpoly.ps/g'' ', &
+ '-e ''1,$s/Uz_file.bin/Uz_file.bin > uzpoly.ps/g'' receiver_line_Xsu_XWindow > receiver_line_Xsu_postscript')
+
+ 140 format(f12.5)
+
+ end subroutine write_seismograms
+
More information about the cig-commits
mailing list