[cig-commits] r8522 - seismo/2D/SPECFEM2D/trunk
walter at geodynamics.org
walter at geodynamics.org
Fri Dec 7 15:53:17 PST 2007
Author: walter
Date: 2007-12-07 15:53:16 -0800 (Fri, 07 Dec 2007)
New Revision: 8522
Added:
seismo/2D/SPECFEM2D/trunk/checkgrid.F90
seismo/2D/SPECFEM2D/trunk/locate_receivers.F90
seismo/2D/SPECFEM2D/trunk/locate_source_force.F90
seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.F90
seismo/2D/SPECFEM2D/trunk/meshfem2D.F90
seismo/2D/SPECFEM2D/trunk/specfem2D.F90
seismo/2D/SPECFEM2D/trunk/write_seismograms.F90
Removed:
seismo/2D/SPECFEM2D/trunk/checkgrid.f90
seismo/2D/SPECFEM2D/trunk/locate_receivers.f90
seismo/2D/SPECFEM2D/trunk/locate_source_force.f90
seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.f90
seismo/2D/SPECFEM2D/trunk/meshfem2D.f90
seismo/2D/SPECFEM2D/trunk/specfem2D.f90
seismo/2D/SPECFEM2D/trunk/write_seismograms.f90
Modified:
seismo/2D/SPECFEM2D/trunk/Makefile
Log:
renamed some files from .f90 to .F90 in order to enable conditional compilation with a preprocessor, and changing the Makefile accordingly.
Modified: seismo/2D/SPECFEM2D/trunk/Makefile
===================================================================
--- seismo/2D/SPECFEM2D/trunk/Makefile 2007-06-26 00:32:15 UTC (rev 8521)
+++ seismo/2D/SPECFEM2D/trunk/Makefile 2007-12-07 23:53:16 UTC (rev 8522)
@@ -19,6 +19,7 @@
# GNU gfortran
F90 = gfortran
+#FLAGS_NOCHECK = -O3 -march=opteron -m64 -mfpmath=sse,387
FLAGS_NOCHECK = -std=gnu -fimplicit-none -frange-check -O2 -Wunused-labels -Waliasing -Wampersand -Wsurprising -Wline-truncation -Wunderflow
FLAGS_CHECK = $(FLAGS_NOCHECK) -fbounds-check
@@ -51,11 +52,11 @@
convolve_source_timefunction: $O/convolve_source_timefunction.o
${F90} $(FLAGS_CHECK) -o xconvolve_source_timefunction $O/convolve_source_timefunction.o
-$O/checkgrid.o: checkgrid.f90 constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/checkgrid.o checkgrid.f90
+$O/checkgrid.o: checkgrid.F90 constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/checkgrid.o checkgrid.F90
-$O/meshfem2D.o: meshfem2D.f90
- ${F90} $(FLAGS_CHECK) -c -o $O/meshfem2D.o meshfem2D.f90
+$O/meshfem2D.o: meshfem2D.F90
+ ${F90} $(FLAGS_CHECK) -c -o $O/meshfem2D.o meshfem2D.F90
$O/createnum_fast.o: createnum_fast.f90 constants.h
${F90} $(FLAGS_CHECK) -c -o $O/createnum_fast.o createnum_fast.f90
@@ -90,24 +91,24 @@
$O/plotpost.o: plotpost.f90 constants.h
${F90} $(FLAGS_CHECK) -c -o $O/plotpost.o plotpost.f90
-$O/locate_receivers.o: locate_receivers.f90 constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/locate_receivers.o locate_receivers.f90
+$O/locate_receivers.o: locate_receivers.F90 constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/locate_receivers.o locate_receivers.F90
$O/recompute_jacobian.o: recompute_jacobian.f90 constants.h
${F90} $(FLAGS_CHECK) -c -o $O/recompute_jacobian.o recompute_jacobian.f90
-$O/locate_source_force.o: locate_source_force.f90 constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/locate_source_force.o locate_source_force.f90
+$O/locate_source_force.o: locate_source_force.F90 constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/locate_source_force.o locate_source_force.F90
-$O/locate_source_moment_tensor.o: locate_source_moment_tensor.f90 constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/locate_source_moment_tensor.o locate_source_moment_tensor.f90
+$O/locate_source_moment_tensor.o: locate_source_moment_tensor.F90 constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/locate_source_moment_tensor.o locate_source_moment_tensor.F90
$O/define_shape_functions.o: define_shape_functions.f90 constants.h
${F90} $(FLAGS_CHECK) -c -o $O/define_shape_functions.o define_shape_functions.f90
### use optimized compilation option for solver only
-$O/specfem2D.o: specfem2D.f90 constants.h
- ${F90} $(FLAGS_NOCHECK) -c -o $O/specfem2D.o specfem2D.f90
+$O/specfem2D.o: specfem2D.F90 constants.h
+ ${F90} $(FLAGS_NOCHECK) -c -o $O/specfem2D.o specfem2D.F90
### use optimized compilation option for solver only
$O/enforce_acoustic_free_surface.o: enforce_acoustic_free_surface.f90 constants.h
@@ -143,6 +144,6 @@
$O/define_external_model.o: define_external_model.f90 constants.h
${F90} $(FLAGS_CHECK) -c -o $O/define_external_model.o define_external_model.f90
-$O/write_seismograms.o: write_seismograms.f90 constants.h
- ${F90} $(FLAGS_CHECK) -c -o $O/write_seismograms.o write_seismograms.f90
+$O/write_seismograms.o: write_seismograms.F90 constants.h
+ ${F90} $(FLAGS_CHECK) -c -o $O/write_seismograms.o write_seismograms.F90
Added: seismo/2D/SPECFEM2D/trunk/checkgrid.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/checkgrid.F90 2007-06-26 00:32:15 UTC (rev 8521)
+++ seismo/2D/SPECFEM2D/trunk/checkgrid.F90 2007-12-07 23:53:16 UTC (rev 8522)
@@ -0,0 +1,986 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 5.2
+! ------------------------------
+!
+! Dimitri Komatitsch
+! University of Pau, France
+!
+! (c) April 2007
+!
+!========================================================================
+
+ subroutine checkgrid(vpext,vsext,rhoext,density,elastcoef,ibool,kmato,coord,npoin,vpmin,vpmax, &
+ assign_external_model,nspec,numat,deltat,f0,t0,initialfield,time_function_type, &
+ coorg,xinterp,zinterp,shapeint,knods,simulation_title,npgeo,pointsdisp,ngnod,any_elastic)
+
+! check the mesh, stability and number of points per wavelength
+
+ implicit none
+
+ include "constants.h"
+
+ integer i,j,ispec,material,npoin,nspec,numat,time_function_type
+
+ integer, dimension(nspec) :: kmato
+ integer, dimension(NGLLX,NGLLX,nspec) :: ibool
+
+ double precision, dimension(numat) :: density
+ double precision, dimension(4,numat) :: elastcoef
+ double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
+
+ double precision coord(NDIM,npoin)
+
+ double precision vpmin,vpmax,vsmin,vsmax,densmin,densmax,vpmax_local,vpmin_local,vsmin_local
+ double precision lambdaplus2mu,mu,denst,cploc,csloc
+ double precision distance_min,distance_max,distance_min_local,distance_max_local
+ double precision courant_stability_number_max,lambdaPmin,lambdaPmax,lambdaSmin,lambdaSmax
+ double precision f0,t0,deltat,distance_1,distance_2,distance_3,distance_4
+
+ logical assign_external_model,initialfield,any_elastic
+
+! for the stability condition
+! maximum polynomial degree for which we can compute the stability condition
+ integer, parameter :: NGLLX_MAX_STABILITY = 15
+ double precision :: percent_GLL(NGLLX_MAX_STABILITY)
+
+ integer pointsdisp,npgeo,ngnod,is,ir,in,nnum
+
+ double precision :: xmax,zmax,height,usoffset,sizex,sizez,courant_stability_number
+ double precision :: x1,z1,x2,z2,ratio_page,xmin,zmin,lambdaS_local,lambdaP_local
+
+ integer knods(ngnod,nspec)
+
+ double precision xinterp(pointsdisp,pointsdisp),zinterp(pointsdisp,pointsdisp)
+ double precision shapeint(ngnod,pointsdisp,pointsdisp)
+
+ double precision coorg(NDIM,npgeo)
+
+! title of the plot
+ character(len=60) simulation_title
+
+! define percentage of smallest distance between GLL points for NGLLX points
+! percentages were computed by calling the GLL points routine for each degree
+ percent_GLL(2) = 100.d0
+ percent_GLL(3) = 50.d0
+ percent_GLL(4) = 27.639320225002102d0
+ percent_GLL(5) = 17.267316464601141d0
+ percent_GLL(6) = 11.747233803526763d0
+ percent_GLL(7) = 8.4888051860716516d0
+ percent_GLL(8) = 6.4129925745196719d0
+ percent_GLL(9) = 5.0121002294269914d0
+ percent_GLL(10) = 4.0233045916770571d0
+ percent_GLL(11) = 3.2999284795970416d0
+ percent_GLL(12) = 2.7550363888558858d0
+ percent_GLL(13) = 2.3345076678918053d0
+ percent_GLL(14) = 2.0032477366369594d0
+ percent_GLL(15) = 1.7377036748080721d0
+
+! convert to real percentage
+ percent_GLL(:) = percent_GLL(:) / 100.d0
+
+ if(NGLLX > NGLLX_MAX_STABILITY) stop 'cannot estimate the stability condition for that degree'
+
+!---- compute parameters for the spectral elements
+
+ vpmin = HUGEVAL
+ vsmin = HUGEVAL
+ vpmax = -HUGEVAL
+ vsmax = -HUGEVAL
+ densmin = HUGEVAL
+ densmax = -HUGEVAL
+
+ distance_min = HUGEVAL
+ distance_max = -HUGEVAL
+
+ courant_stability_number_max = -HUGEVAL
+
+ lambdaPmin = HUGEVAL
+ lambdaSmin = HUGEVAL
+ lambdaPmax = -HUGEVAL
+ lambdaSmax = -HUGEVAL
+
+ do ispec=1,nspec
+
+ material = kmato(ispec)
+
+ mu = elastcoef(2,material)
+ lambdaplus2mu = elastcoef(3,material)
+ denst = density(material)
+
+ cploc = sqrt(lambdaplus2mu/denst)
+ csloc = sqrt(mu/denst)
+
+ vpmax_local = -HUGEVAL
+ vpmin_local = HUGEVAL
+ vsmin_local = HUGEVAL
+
+ distance_min_local = HUGEVAL
+ distance_max_local = -HUGEVAL
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+!--- if heterogeneous formulation with external velocity model
+ if(assign_external_model) then
+ cploc = vpext(i,j,ispec)
+ csloc = vsext(i,j,ispec)
+ denst = rhoext(i,j,ispec)
+ endif
+
+!--- compute min and max of velocity and density models
+ vpmin = min(vpmin,cploc)
+ vpmax = max(vpmax,cploc)
+
+! ignore fluid regions with Vs = 0
+ if(csloc > 0.0001d0) vsmin = min(vsmin,csloc)
+ vsmax = max(vsmax,csloc)
+
+ densmin = min(densmin,denst)
+ densmax = max(densmax,denst)
+
+ vpmax_local = max(vpmax_local,cploc)
+ vpmin_local = min(vpmin_local,cploc)
+ vsmin_local = min(vsmin_local,csloc)
+
+ enddo
+ enddo
+
+! compute minimum and maximum size of edges of this grid cell
+ distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
+ (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
+
+ distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
+
+ distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
+
+ distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
+ (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
+
+ distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
+ distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
+
+ distance_min = min(distance_min,distance_min_local)
+ distance_max = max(distance_max,distance_max_local)
+
+ courant_stability_number_max = max(courant_stability_number_max,vpmax_local * deltat / (distance_min_local * percent_GLL(NGLLX)))
+
+! ignore fluid regions with Vs = 0
+ if(csloc > 0.0001d0) then
+ lambdaSmin = min(lambdaSmin,vsmin_local / (distance_max_local / (NGLLX - 1)))
+ lambdaSmax = max(lambdaSmax,vsmin_local / (distance_max_local / (NGLLX - 1)))
+ endif
+
+ lambdaPmin = min(lambdaPmin,vpmin_local / (distance_max_local / (NGLLX - 1)))
+ lambdaPmax = max(lambdaPmax,vpmin_local / (distance_max_local / (NGLLX - 1)))
+
+ enddo
+
+ write(IOUT,*)
+ write(IOUT,*) '********'
+ write(IOUT,*) 'Model: P velocity min,max = ',vpmin,vpmax
+ write(IOUT,*) 'Model: S velocity min,max = ',vsmin,vsmax
+ write(IOUT,*) 'Model: density min,max = ',densmin,densmax
+ write(IOUT,*) '********'
+ write(IOUT,*)
+
+ write(IOUT,*)
+ write(IOUT,*) '*********************************************'
+ write(IOUT,*) '*** Verification of simulation parameters ***'
+ write(IOUT,*) '*********************************************'
+ write(IOUT,*)
+ write(IOUT,*) '*** Max grid size = ',distance_max
+ write(IOUT,*) '*** Min grid size = ',distance_min
+ write(IOUT,*) '*** Max/min ratio = ',distance_max/distance_min
+ write(IOUT,*)
+ write(IOUT,*) '*** Max stability for P wave velocity = ',courant_stability_number_max
+ write(IOUT,*)
+
+! only if time source is not a Dirac or Heaviside (otherwise maximum frequency of spectrum undefined)
+! and if source is not an initial field, for the same reason
+ if(.not. initialfield .and. time_function_type /= 4 .and. time_function_type /= 5) then
+
+ write(IOUT,*) ' Onset time = ',t0
+ write(IOUT,*) ' Fundamental period = ',1.d0/f0
+ write(IOUT,*) ' Fundamental frequency = ',f0
+ if(t0 <= 1.d0/f0) then
+ stop 'Onset time too small'
+ else
+ write(IOUT,*) ' --> onset time ok'
+ endif
+ write(IOUT,*) '----'
+ write(IOUT,*) ' Nb pts / lambdaPmin_fmax max = ',lambdaPmax/(2.5d0*f0)
+ write(IOUT,*) ' Nb pts / lambdaPmin_fmax min = ',lambdaPmin/(2.5d0*f0)
+ write(IOUT,*) '----'
+ write(IOUT,*) ' Nb pts / lambdaSmin_fmax max = ',lambdaSmax/(2.5d0*f0)
+ write(IOUT,*) ' Nb pts / lambdaSmin_fmax min = ',lambdaSmin/(2.5d0*f0)
+ write(IOUT,*) '----'
+
+ endif
+
+!
+!--------------------------------------------------------------------------------
+!
+
+! A4 or US letter paper
+ if(US_LETTER) then
+ usoffset = 1.75d0
+ sizex = 27.94d0
+ sizez = 21.59d0
+ else
+ usoffset = 0.d0
+ sizex = 29.7d0
+ sizez = 21.d0
+ endif
+
+! height of domain numbers in centimeters
+ height = 0.25d0
+
+! get minimum and maximum values of mesh coordinates
+ xmin = minval(coord(1,:))
+ zmin = minval(coord(2,:))
+ xmax = maxval(coord(1,:))
+ zmax = maxval(coord(2,:))
+
+! ratio of physical page size/size of the domain meshed
+ ratio_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) / 100.d0
+
+ print *
+ print *,'Creating PostScript file with stability condition'
+
+!
+!---- open PostScript file
+!
+ open(unit=24,file='OUTPUT_FILES/mesh_stability.ps',status='unknown')
+
+!
+!---- write PostScript header
+!
+ write(24,10) simulation_title
+ write(24,*) '/CM {28.5 mul} def'
+ write(24,*) '/LR {rlineto} def'
+ write(24,*) '/LT {lineto} def'
+ write(24,*) '/L {lineto} def'
+ write(24,*) '/MR {rmoveto} def'
+ write(24,*) '/MV {moveto} def'
+ write(24,*) '/M {moveto} def'
+ write(24,*) '/ST {stroke} def'
+ write(24,*) '/CP {closepath} def'
+ write(24,*) '/RG {setrgbcolor} def'
+ write(24,*) '/GF {gsave fill grestore} def'
+ write(24,*) '% different useful symbols'
+ write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
+ write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
+ write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
+ write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
+ write(24,*) '0.01 CM setlinewidth} def'
+ write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
+ write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
+ write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
+ write(24,*) 'grestore 0.01 CM setlinewidth} def'
+ write(24,*) '%'
+ write(24,*) '% macro to draw the contour of the elements'
+ write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
+ write(24,*) '%'
+ write(24,*) '.01 CM setlinewidth'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.35 CM scalefont setfont'
+ 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 scalefont setfont} def'
+ write(24,*) '%'
+ write(24,*) 'gsave newpath 90 rotate'
+ write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '%'
+
+!
+!--- write captions of PostScript figure
+!
+ write(24,*) '0 setgray'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.5 CM scalefont setfont'
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM scalefont setfont'
+ 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 scalefont setfont'
+ write(24,*) '.8 0 .8 setrgbcolor'
+ write(24,*) '24.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(Mesh stability condition \(red = bad\)) show'
+ write(24,*) 'grestore'
+ write(24,*) '25.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(',simulation_title,') show'
+ write(24,*) 'grestore'
+ write(24,*) '26.45 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(2D Spectral Element Method) show'
+ write(24,*) 'grestore'
+
+ write(24,*) '%'
+ write(24,*) '1 1 scale'
+ write(24,*) '%'
+
+!
+!---- draw the spectral element mesh
+!
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+ write(24,*) '0 setgray'
+
+ do ispec = 1, nspec
+
+ write(24,*) '% elem ',ispec
+
+ do i=1,pointsdisp
+ do j=1,pointsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ write(24,*) 'mark'
+ write(24,681) x1,z1
+
+! draw straight lines if elements have 4 nodes
+
+ ir=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ ir=pointsdisp
+ is=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ is=pointsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ write(24,*) 'CO'
+
+ material = kmato(ispec)
+
+ mu = elastcoef(2,material)
+ lambdaplus2mu = elastcoef(3,material)
+ denst = density(material)
+
+ cploc = sqrt(lambdaplus2mu/denst)
+ csloc = sqrt(mu/denst)
+
+ vpmax_local = -HUGEVAL
+ vpmin_local = HUGEVAL
+ vsmin_local = HUGEVAL
+
+ distance_min_local = HUGEVAL
+ distance_max_local = -HUGEVAL
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+!--- if heterogeneous formulation with external velocity model
+ if(assign_external_model) then
+ cploc = vpext(i,j,ispec)
+ csloc = vsext(i,j,ispec)
+ denst = rhoext(i,j,ispec)
+ endif
+
+ vpmax_local = max(vpmax_local,cploc)
+ vpmin_local = min(vpmin_local,cploc)
+ vsmin_local = min(vsmin_local,csloc)
+
+ enddo
+ enddo
+
+! compute minimum and maximum size of edges of this grid cell
+ distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
+ (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
+
+ distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
+
+ distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
+
+ distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
+ (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
+
+ distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
+ distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
+
+ distance_min = min(distance_min,distance_min_local)
+ distance_max = max(distance_max,distance_max_local)
+
+ courant_stability_number = vpmax_local * deltat / (distance_min_local * percent_GLL(NGLLX))
+
+! display bad elements that are above 80% of the threshold
+ if(courant_stability_number >= 0.80 * courant_stability_number_max) then
+ write(24,*) '1 0 0 RG GF 0 setgray ST'
+ else
+! do not color the elements if below the threshold
+ write(24,*) 'ST'
+ endif
+
+ enddo ! end of loop on all the spectral elements
+
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+
+ print *,'End of creation of PostScript file with stability condition'
+
+!
+!--------------------------------------------------------------------------------
+!
+
+ print *
+ print *,'Creating PostScript file with mesh dispersion'
+
+!
+!---- open PostScript file
+!
+ if(any_elastic) then
+ open(unit=24,file='OUTPUT_FILES/mesh_S_wave_dispersion.ps',status='unknown')
+ else
+ open(unit=24,file='OUTPUT_FILES/mesh_P_wave_dispersion.ps',status='unknown')
+ endif
+
+!
+!---- write PostScript header
+!
+ write(24,10) simulation_title
+ write(24,*) '/CM {28.5 mul} def'
+ write(24,*) '/LR {rlineto} def'
+ write(24,*) '/LT {lineto} def'
+ write(24,*) '/L {lineto} def'
+ write(24,*) '/MR {rmoveto} def'
+ write(24,*) '/MV {moveto} def'
+ write(24,*) '/M {moveto} def'
+ write(24,*) '/ST {stroke} def'
+ write(24,*) '/CP {closepath} def'
+ write(24,*) '/RG {setrgbcolor} def'
+ write(24,*) '/GF {gsave fill grestore} def'
+ write(24,*) '% different useful symbols'
+ write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
+ write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
+ write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
+ write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
+ write(24,*) '0.01 CM setlinewidth} def'
+ write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
+ write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
+ write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
+ write(24,*) 'grestore 0.01 CM setlinewidth} def'
+ write(24,*) '%'
+ write(24,*) '% macro to draw the contour of the elements'
+ write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
+ write(24,*) '%'
+ write(24,*) '.01 CM setlinewidth'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.35 CM scalefont setfont'
+ 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 scalefont setfont} def'
+ write(24,*) '%'
+ write(24,*) 'gsave newpath 90 rotate'
+ write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '%'
+
+!
+!--- write captions of PostScript figure
+!
+ write(24,*) '0 setgray'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.5 CM scalefont setfont'
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM scalefont setfont'
+ 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 scalefont setfont'
+ write(24,*) '.8 0 .8 setrgbcolor'
+ write(24,*) '24.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ if(any_elastic) then
+ write(24,*) '(Mesh elastic S-wave dispersion \(red = good, blue = bad\)) show'
+ else
+ write(24,*) '(Mesh acoustic P-wave dispersion \(red = good, blue = bad\)) show'
+ endif
+ write(24,*) 'grestore'
+ write(24,*) '25.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(',simulation_title,') show'
+ write(24,*) 'grestore'
+ write(24,*) '26.45 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(2D Spectral Element Method) show'
+ write(24,*) 'grestore'
+
+ write(24,*) '%'
+ write(24,*) '1 1 scale'
+ write(24,*) '%'
+
+!
+!---- draw the spectral element mesh
+!
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+ write(24,*) '0 setgray'
+
+ do ispec = 1, nspec
+
+ write(24,*) '% elem ',ispec
+
+ do i=1,pointsdisp
+ do j=1,pointsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ write(24,*) 'mark'
+ write(24,681) x1,z1
+
+! draw straight lines if elements have 4 nodes
+
+ ir=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ ir=pointsdisp
+ is=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ is=pointsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ write(24,*) 'CO'
+
+ material = kmato(ispec)
+
+ mu = elastcoef(2,material)
+ lambdaplus2mu = elastcoef(3,material)
+ denst = density(material)
+
+ cploc = sqrt(lambdaplus2mu/denst)
+ csloc = sqrt(mu/denst)
+
+ vpmax_local = -HUGEVAL
+ vpmin_local = HUGEVAL
+ vsmin_local = HUGEVAL
+
+ distance_min_local = HUGEVAL
+ distance_max_local = -HUGEVAL
+
+ do j=1,NGLLZ
+ do i=1,NGLLX
+
+!--- if heterogeneous formulation with external velocity model
+ if(assign_external_model) then
+ cploc = vpext(i,j,ispec)
+ csloc = vsext(i,j,ispec)
+ denst = rhoext(i,j,ispec)
+ endif
+
+ vpmax_local = max(vpmax_local,cploc)
+ vpmin_local = min(vpmin_local,cploc)
+ vsmin_local = min(vsmin_local,csloc)
+
+ enddo
+ enddo
+
+! compute minimum and maximum size of edges of this grid cell
+ distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
+ (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
+
+ distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
+
+ distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
+ (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
+
+ distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
+ (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
+
+ distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
+ distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
+
+ distance_min = min(distance_min,distance_min_local)
+ distance_max = max(distance_max,distance_max_local)
+
+! display mesh dispersion for S waves if there is at least one elastic element in the mesh
+ if(any_elastic) then
+
+! ignore fluid regions with Vs = 0
+ if(csloc > 0.0001d0) then
+
+ lambdaS_local = vsmin_local / (distance_max_local / (NGLLX - 1))
+
+! display very good elements that are above 80% of the threshold in red
+ if(lambdaS_local >= 0.80 * lambdaSmax) then
+ write(24,*) '1 0 0 RG GF 0 setgray ST'
+
+! display bad elements that are below 120% of the threshold in blue
+ else if(lambdaS_local <= 1.20 * lambdaSmin) then
+ write(24,*) '0 0 1 RG GF 0 setgray ST'
+
+ else
+! do not color the elements if not close to the threshold
+ write(24,*) 'ST'
+ endif
+
+ else
+! do not color the elements if S-wave velocity undefined
+ write(24,*) 'ST'
+ endif
+
+! display mesh dispersion for P waves if there is no elastic element in the mesh
+ else
+
+ lambdaP_local = vpmin_local / (distance_max_local / (NGLLX - 1))
+
+! display very good elements that are above 80% of the threshold in red
+ if(lambdaP_local >= 0.80 * lambdaPmax) then
+ write(24,*) '1 0 0 RG GF 0 setgray ST'
+
+! display bad elements that are below 120% of the threshold in blue
+ else if(lambdaP_local <= 1.20 * lambdaPmin) then
+ write(24,*) '0 0 1 RG GF 0 setgray ST'
+
+ else
+! do not color the elements if not close to the threshold
+ write(24,*) 'ST'
+ endif
+
+ endif
+
+ enddo ! end of loop on all the spectral elements
+
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+
+ print *,'End of creation of PostScript file with mesh dispersion'
+
+!
+!--------------------------------------------------------------------------------
+!
+
+ print *
+ print *,'Creating PostScript file with velocity model'
+
+!
+!---- open PostScript file
+!
+ open(unit=24,file='OUTPUT_FILES/P_velocity_model.ps',status='unknown')
+
+!
+!---- write PostScript header
+!
+ write(24,10) simulation_title
+ write(24,*) '/CM {28.5 mul} def'
+ write(24,*) '/LR {rlineto} def'
+ write(24,*) '/LT {lineto} def'
+ write(24,*) '/L {lineto} def'
+ write(24,*) '/MR {rmoveto} def'
+ write(24,*) '/MV {moveto} def'
+ write(24,*) '/M {moveto} def'
+ write(24,*) '/ST {stroke} def'
+ write(24,*) '/CP {closepath} def'
+ write(24,*) '/RG {setrgbcolor} def'
+ write(24,*) '/GF {gsave fill grestore} def'
+ write(24,*) '% different useful symbols'
+ write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
+ write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
+ write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
+ write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
+ write(24,*) '0.01 CM setlinewidth} def'
+ write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
+ write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
+ write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
+ write(24,*) 'grestore 0.01 CM setlinewidth} def'
+ write(24,*) '%'
+ write(24,*) '% macro to draw the contour of the elements'
+ write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
+ write(24,*) '%'
+ write(24,*) '.01 CM setlinewidth'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.35 CM scalefont setfont'
+ 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 scalefont setfont} def'
+ write(24,*) '%'
+ write(24,*) 'gsave newpath 90 rotate'
+ write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '%'
+
+!
+!--- write captions of PostScript figure
+!
+ write(24,*) '0 setgray'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.5 CM scalefont setfont'
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM scalefont setfont'
+ 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 scalefont setfont'
+ write(24,*) '.8 0 .8 setrgbcolor'
+ write(24,*) '24.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(P-velocity model \(dark = fast, light = slow\)) show'
+ write(24,*) 'grestore'
+ write(24,*) '25.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(',simulation_title,') show'
+ write(24,*) 'grestore'
+ write(24,*) '26.45 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(2D Spectral Element Method) show'
+ write(24,*) 'grestore'
+
+ write(24,*) '%'
+ write(24,*) '1 1 scale'
+ write(24,*) '%'
+
+!
+!---- draw the spectral element mesh
+!
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+ write(24,*) '0 setgray'
+
+ do ispec = 1, nspec
+
+ write(24,*) '% elem ',ispec
+
+ do i=1,pointsdisp
+ do j=1,pointsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ write(24,*) 'mark'
+ write(24,681) x1,z1
+
+! draw straight lines if elements have 4 nodes
+
+ ir=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ ir=pointsdisp
+ is=pointsdisp
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ is=pointsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ write(24,*) 'CO'
+
+ if((vpmax-vpmin)/vpmin > 0.02d0) then
+ if(assign_external_model) then
+! use lower-left corner
+ x1 = (vpext(1,1,ispec)-vpmin) / (vpmax-vpmin)
+ else
+ material = kmato(ispec)
+ mu = elastcoef(2,material)
+ lambdaplus2mu = elastcoef(3,material)
+ denst = density(material)
+ cploc = sqrt(lambdaplus2mu/denst)
+ x1 = (cploc-vpmin)/(vpmax-vpmin)
+ endif
+ else
+ x1 = 0.5d0
+ endif
+
+! rescale to avoid very dark gray levels
+ x1 = x1*0.7 + 0.2
+ if(x1 > 1.d0) x1=1.d0
+
+! invert scale: white = vpmin, dark gray = vpmax
+ x1 = 1.d0 - x1
+
+! display P-velocity model using gray levels
+ write(24,*) sngl(x1),' setgray GF 0 setgray ST'
+
+ enddo ! end of loop on all the spectral elements
+
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+
+ print *,'End of creation of PostScript file with velocity model'
+
+ 10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a50,/,'%% Created by: Specfem2D',/,'%% Author: Dimitri Komatitsch',/,'%%')
+
+ 681 format(f6.2,1x,f6.2)
+
+ end subroutine checkgrid
+
Deleted: seismo/2D/SPECFEM2D/trunk/checkgrid.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/checkgrid.f90 2007-06-26 00:32:15 UTC (rev 8521)
+++ seismo/2D/SPECFEM2D/trunk/checkgrid.f90 2007-12-07 23:53:16 UTC (rev 8522)
@@ -1,986 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 5.2
-! ------------------------------
-!
-! Dimitri Komatitsch
-! University of Pau, France
-!
-! (c) April 2007
-!
-!========================================================================
-
- subroutine checkgrid(vpext,vsext,rhoext,density,elastcoef,ibool,kmato,coord,npoin,vpmin,vpmax, &
- assign_external_model,nspec,numat,deltat,f0,t0,initialfield,time_function_type, &
- coorg,xinterp,zinterp,shapeint,knods,simulation_title,npgeo,pointsdisp,ngnod,any_elastic)
-
-! check the mesh, stability and number of points per wavelength
-
- implicit none
-
- include "constants.h"
-
- integer i,j,ispec,material,npoin,nspec,numat,time_function_type
-
- integer, dimension(nspec) :: kmato
- integer, dimension(NGLLX,NGLLX,nspec) :: ibool
-
- double precision, dimension(numat) :: density
- double precision, dimension(4,numat) :: elastcoef
- double precision, dimension(NGLLX,NGLLX,nspec) :: vpext,vsext,rhoext
-
- double precision coord(NDIM,npoin)
-
- double precision vpmin,vpmax,vsmin,vsmax,densmin,densmax,vpmax_local,vpmin_local,vsmin_local
- double precision lambdaplus2mu,mu,denst,cploc,csloc
- double precision distance_min,distance_max,distance_min_local,distance_max_local
- double precision courant_stability_number_max,lambdaPmin,lambdaPmax,lambdaSmin,lambdaSmax
- double precision f0,t0,deltat,distance_1,distance_2,distance_3,distance_4
-
- logical assign_external_model,initialfield,any_elastic
-
-! for the stability condition
-! maximum polynomial degree for which we can compute the stability condition
- integer, parameter :: NGLLX_MAX_STABILITY = 15
- double precision :: percent_GLL(NGLLX_MAX_STABILITY)
-
- integer pointsdisp,npgeo,ngnod,is,ir,in,nnum
-
- double precision :: xmax,zmax,height,usoffset,sizex,sizez,courant_stability_number
- double precision :: x1,z1,x2,z2,ratio_page,xmin,zmin,lambdaS_local,lambdaP_local
-
- integer knods(ngnod,nspec)
-
- double precision xinterp(pointsdisp,pointsdisp),zinterp(pointsdisp,pointsdisp)
- double precision shapeint(ngnod,pointsdisp,pointsdisp)
-
- double precision coorg(NDIM,npgeo)
-
-! title of the plot
- character(len=60) simulation_title
-
-! define percentage of smallest distance between GLL points for NGLLX points
-! percentages were computed by calling the GLL points routine for each degree
- percent_GLL(2) = 100.d0
- percent_GLL(3) = 50.d0
- percent_GLL(4) = 27.639320225002102d0
- percent_GLL(5) = 17.267316464601141d0
- percent_GLL(6) = 11.747233803526763d0
- percent_GLL(7) = 8.4888051860716516d0
- percent_GLL(8) = 6.4129925745196719d0
- percent_GLL(9) = 5.0121002294269914d0
- percent_GLL(10) = 4.0233045916770571d0
- percent_GLL(11) = 3.2999284795970416d0
- percent_GLL(12) = 2.7550363888558858d0
- percent_GLL(13) = 2.3345076678918053d0
- percent_GLL(14) = 2.0032477366369594d0
- percent_GLL(15) = 1.7377036748080721d0
-
-! convert to real percentage
- percent_GLL(:) = percent_GLL(:) / 100.d0
-
- if(NGLLX > NGLLX_MAX_STABILITY) stop 'cannot estimate the stability condition for that degree'
-
-!---- compute parameters for the spectral elements
-
- vpmin = HUGEVAL
- vsmin = HUGEVAL
- vpmax = -HUGEVAL
- vsmax = -HUGEVAL
- densmin = HUGEVAL
- densmax = -HUGEVAL
-
- distance_min = HUGEVAL
- distance_max = -HUGEVAL
-
- courant_stability_number_max = -HUGEVAL
-
- lambdaPmin = HUGEVAL
- lambdaSmin = HUGEVAL
- lambdaPmax = -HUGEVAL
- lambdaSmax = -HUGEVAL
-
- do ispec=1,nspec
-
- material = kmato(ispec)
-
- mu = elastcoef(2,material)
- lambdaplus2mu = elastcoef(3,material)
- denst = density(material)
-
- cploc = sqrt(lambdaplus2mu/denst)
- csloc = sqrt(mu/denst)
-
- vpmax_local = -HUGEVAL
- vpmin_local = HUGEVAL
- vsmin_local = HUGEVAL
-
- distance_min_local = HUGEVAL
- distance_max_local = -HUGEVAL
-
- do j=1,NGLLZ
- do i=1,NGLLX
-
-!--- if heterogeneous formulation with external velocity model
- if(assign_external_model) then
- cploc = vpext(i,j,ispec)
- csloc = vsext(i,j,ispec)
- denst = rhoext(i,j,ispec)
- endif
-
-!--- compute min and max of velocity and density models
- vpmin = min(vpmin,cploc)
- vpmax = max(vpmax,cploc)
-
-! ignore fluid regions with Vs = 0
- if(csloc > 0.0001d0) vsmin = min(vsmin,csloc)
- vsmax = max(vsmax,csloc)
-
- densmin = min(densmin,denst)
- densmax = max(densmax,denst)
-
- vpmax_local = max(vpmax_local,cploc)
- vpmin_local = min(vpmin_local,cploc)
- vsmin_local = min(vsmin_local,csloc)
-
- enddo
- enddo
-
-! compute minimum and maximum size of edges of this grid cell
- distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
- (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
-
- distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
-
- distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
-
- distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
- (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
-
- distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
- distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
-
- distance_min = min(distance_min,distance_min_local)
- distance_max = max(distance_max,distance_max_local)
-
- courant_stability_number_max = max(courant_stability_number_max,vpmax_local * deltat / (distance_min_local * percent_GLL(NGLLX)))
-
-! ignore fluid regions with Vs = 0
- if(csloc > 0.0001d0) then
- lambdaSmin = min(lambdaSmin,vsmin_local / (distance_max_local / (NGLLX - 1)))
- lambdaSmax = max(lambdaSmax,vsmin_local / (distance_max_local / (NGLLX - 1)))
- endif
-
- lambdaPmin = min(lambdaPmin,vpmin_local / (distance_max_local / (NGLLX - 1)))
- lambdaPmax = max(lambdaPmax,vpmin_local / (distance_max_local / (NGLLX - 1)))
-
- enddo
-
- write(IOUT,*)
- write(IOUT,*) '********'
- write(IOUT,*) 'Model: P velocity min,max = ',vpmin,vpmax
- write(IOUT,*) 'Model: S velocity min,max = ',vsmin,vsmax
- write(IOUT,*) 'Model: density min,max = ',densmin,densmax
- write(IOUT,*) '********'
- write(IOUT,*)
-
- write(IOUT,*)
- write(IOUT,*) '*********************************************'
- write(IOUT,*) '*** Verification of simulation parameters ***'
- write(IOUT,*) '*********************************************'
- write(IOUT,*)
- write(IOUT,*) '*** Max grid size = ',distance_max
- write(IOUT,*) '*** Min grid size = ',distance_min
- write(IOUT,*) '*** Max/min ratio = ',distance_max/distance_min
- write(IOUT,*)
- write(IOUT,*) '*** Max stability for P wave velocity = ',courant_stability_number_max
- write(IOUT,*)
-
-! only if time source is not a Dirac or Heaviside (otherwise maximum frequency of spectrum undefined)
-! and if source is not an initial field, for the same reason
- if(.not. initialfield .and. time_function_type /= 4 .and. time_function_type /= 5) then
-
- write(IOUT,*) ' Onset time = ',t0
- write(IOUT,*) ' Fundamental period = ',1.d0/f0
- write(IOUT,*) ' Fundamental frequency = ',f0
- if(t0 <= 1.d0/f0) then
- stop 'Onset time too small'
- else
- write(IOUT,*) ' --> onset time ok'
- endif
- write(IOUT,*) '----'
- write(IOUT,*) ' Nb pts / lambdaPmin_fmax max = ',lambdaPmax/(2.5d0*f0)
- write(IOUT,*) ' Nb pts / lambdaPmin_fmax min = ',lambdaPmin/(2.5d0*f0)
- write(IOUT,*) '----'
- write(IOUT,*) ' Nb pts / lambdaSmin_fmax max = ',lambdaSmax/(2.5d0*f0)
- write(IOUT,*) ' Nb pts / lambdaSmin_fmax min = ',lambdaSmin/(2.5d0*f0)
- write(IOUT,*) '----'
-
- endif
-
-!
-!--------------------------------------------------------------------------------
-!
-
-! A4 or US letter paper
- if(US_LETTER) then
- usoffset = 1.75d0
- sizex = 27.94d0
- sizez = 21.59d0
- else
- usoffset = 0.d0
- sizex = 29.7d0
- sizez = 21.d0
- endif
-
-! height of domain numbers in centimeters
- height = 0.25d0
-
-! get minimum and maximum values of mesh coordinates
- xmin = minval(coord(1,:))
- zmin = minval(coord(2,:))
- xmax = maxval(coord(1,:))
- zmax = maxval(coord(2,:))
-
-! ratio of physical page size/size of the domain meshed
- ratio_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) / 100.d0
-
- print *
- print *,'Creating PostScript file with stability condition'
-
-!
-!---- open PostScript file
-!
- open(unit=24,file='OUTPUT_FILES/mesh_stability.ps',status='unknown')
-
-!
-!---- write PostScript header
-!
- write(24,10) simulation_title
- write(24,*) '/CM {28.5 mul} def'
- write(24,*) '/LR {rlineto} def'
- write(24,*) '/LT {lineto} def'
- write(24,*) '/L {lineto} def'
- write(24,*) '/MR {rmoveto} def'
- write(24,*) '/MV {moveto} def'
- write(24,*) '/M {moveto} def'
- write(24,*) '/ST {stroke} def'
- write(24,*) '/CP {closepath} def'
- write(24,*) '/RG {setrgbcolor} def'
- write(24,*) '/GF {gsave fill grestore} def'
- write(24,*) '% different useful symbols'
- write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
- write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
- write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
- write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
- write(24,*) '0.01 CM setlinewidth} def'
- write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
- write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
- write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
- write(24,*) 'grestore 0.01 CM setlinewidth} def'
- write(24,*) '%'
- write(24,*) '% macro to draw the contour of the elements'
- write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
- write(24,*) '%'
- write(24,*) '.01 CM setlinewidth'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.35 CM scalefont setfont'
- 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 scalefont setfont} def'
- write(24,*) '%'
- write(24,*) 'gsave newpath 90 rotate'
- write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
- write(24,*) '%'
-
-!
-!--- write captions of PostScript figure
-!
- write(24,*) '0 setgray'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.5 CM scalefont setfont'
-
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.6 CM scalefont setfont'
- 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 scalefont setfont'
- write(24,*) '.8 0 .8 setrgbcolor'
- write(24,*) '24.35 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(Mesh stability condition \(red = bad\)) show'
- write(24,*) 'grestore'
- write(24,*) '25.35 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(',simulation_title,') show'
- write(24,*) 'grestore'
- write(24,*) '26.45 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(2D Spectral Element Method) show'
- write(24,*) 'grestore'
-
- write(24,*) '%'
- write(24,*) '1 1 scale'
- write(24,*) '%'
-
-!
-!---- draw the spectral element mesh
-!
- write(24,*) '%'
- write(24,*) '% spectral element mesh'
- write(24,*) '%'
- write(24,*) '0 setgray'
-
- do ispec = 1, nspec
-
- write(24,*) '% elem ',ispec
-
- do i=1,pointsdisp
- do j=1,pointsdisp
- xinterp(i,j) = 0.d0
- zinterp(i,j) = 0.d0
- do in = 1,ngnod
- nnum = knods(in,ispec)
- xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
- zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
- enddo
- enddo
- enddo
-
- is = 1
- ir = 1
- x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- write(24,*) 'mark'
- write(24,681) x1,z1
-
-! draw straight lines if elements have 4 nodes
-
- ir=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- write(24,681) x2,z2
-
- ir=pointsdisp
- is=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- write(24,681) x2,z2
-
- is=pointsdisp
- ir=1
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- write(24,681) x2,z2
-
- ir=1
- is=2
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- write(24,681) x2,z2
-
- write(24,*) 'CO'
-
- material = kmato(ispec)
-
- mu = elastcoef(2,material)
- lambdaplus2mu = elastcoef(3,material)
- denst = density(material)
-
- cploc = sqrt(lambdaplus2mu/denst)
- csloc = sqrt(mu/denst)
-
- vpmax_local = -HUGEVAL
- vpmin_local = HUGEVAL
- vsmin_local = HUGEVAL
-
- distance_min_local = HUGEVAL
- distance_max_local = -HUGEVAL
-
- do j=1,NGLLZ
- do i=1,NGLLX
-
-!--- if heterogeneous formulation with external velocity model
- if(assign_external_model) then
- cploc = vpext(i,j,ispec)
- csloc = vsext(i,j,ispec)
- denst = rhoext(i,j,ispec)
- endif
-
- vpmax_local = max(vpmax_local,cploc)
- vpmin_local = min(vpmin_local,cploc)
- vsmin_local = min(vsmin_local,csloc)
-
- enddo
- enddo
-
-! compute minimum and maximum size of edges of this grid cell
- distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
- (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
-
- distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
-
- distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
-
- distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
- (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
-
- distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
- distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
-
- distance_min = min(distance_min,distance_min_local)
- distance_max = max(distance_max,distance_max_local)
-
- courant_stability_number = vpmax_local * deltat / (distance_min_local * percent_GLL(NGLLX))
-
-! display bad elements that are above 80% of the threshold
- if(courant_stability_number >= 0.80 * courant_stability_number_max) then
- write(24,*) '1 0 0 RG GF 0 setgray ST'
- else
-! do not color the elements if below the threshold
- write(24,*) 'ST'
- endif
-
- enddo ! end of loop on all the spectral elements
-
- write(24,*) '%'
- write(24,*) 'grestore'
- write(24,*) 'showpage'
-
- close(24)
-
- print *,'End of creation of PostScript file with stability condition'
-
-!
-!--------------------------------------------------------------------------------
-!
-
- print *
- print *,'Creating PostScript file with mesh dispersion'
-
-!
-!---- open PostScript file
-!
- if(any_elastic) then
- open(unit=24,file='OUTPUT_FILES/mesh_S_wave_dispersion.ps',status='unknown')
- else
- open(unit=24,file='OUTPUT_FILES/mesh_P_wave_dispersion.ps',status='unknown')
- endif
-
-!
-!---- write PostScript header
-!
- write(24,10) simulation_title
- write(24,*) '/CM {28.5 mul} def'
- write(24,*) '/LR {rlineto} def'
- write(24,*) '/LT {lineto} def'
- write(24,*) '/L {lineto} def'
- write(24,*) '/MR {rmoveto} def'
- write(24,*) '/MV {moveto} def'
- write(24,*) '/M {moveto} def'
- write(24,*) '/ST {stroke} def'
- write(24,*) '/CP {closepath} def'
- write(24,*) '/RG {setrgbcolor} def'
- write(24,*) '/GF {gsave fill grestore} def'
- write(24,*) '% different useful symbols'
- write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
- write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
- write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
- write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
- write(24,*) '0.01 CM setlinewidth} def'
- write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
- write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
- write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
- write(24,*) 'grestore 0.01 CM setlinewidth} def'
- write(24,*) '%'
- write(24,*) '% macro to draw the contour of the elements'
- write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
- write(24,*) '%'
- write(24,*) '.01 CM setlinewidth'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.35 CM scalefont setfont'
- 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 scalefont setfont} def'
- write(24,*) '%'
- write(24,*) 'gsave newpath 90 rotate'
- write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
- write(24,*) '%'
-
-!
-!--- write captions of PostScript figure
-!
- write(24,*) '0 setgray'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.5 CM scalefont setfont'
-
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.6 CM scalefont setfont'
- 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 scalefont setfont'
- write(24,*) '.8 0 .8 setrgbcolor'
- write(24,*) '24.35 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- if(any_elastic) then
- write(24,*) '(Mesh elastic S-wave dispersion \(red = good, blue = bad\)) show'
- else
- write(24,*) '(Mesh acoustic P-wave dispersion \(red = good, blue = bad\)) show'
- endif
- write(24,*) 'grestore'
- write(24,*) '25.35 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(',simulation_title,') show'
- write(24,*) 'grestore'
- write(24,*) '26.45 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(2D Spectral Element Method) show'
- write(24,*) 'grestore'
-
- write(24,*) '%'
- write(24,*) '1 1 scale'
- write(24,*) '%'
-
-!
-!---- draw the spectral element mesh
-!
- write(24,*) '%'
- write(24,*) '% spectral element mesh'
- write(24,*) '%'
- write(24,*) '0 setgray'
-
- do ispec = 1, nspec
-
- write(24,*) '% elem ',ispec
-
- do i=1,pointsdisp
- do j=1,pointsdisp
- xinterp(i,j) = 0.d0
- zinterp(i,j) = 0.d0
- do in = 1,ngnod
- nnum = knods(in,ispec)
- xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
- zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
- enddo
- enddo
- enddo
-
- is = 1
- ir = 1
- x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- write(24,*) 'mark'
- write(24,681) x1,z1
-
-! draw straight lines if elements have 4 nodes
-
- ir=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- write(24,681) x2,z2
-
- ir=pointsdisp
- is=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- write(24,681) x2,z2
-
- is=pointsdisp
- ir=1
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- write(24,681) x2,z2
-
- ir=1
- is=2
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- write(24,681) x2,z2
-
- write(24,*) 'CO'
-
- material = kmato(ispec)
-
- mu = elastcoef(2,material)
- lambdaplus2mu = elastcoef(3,material)
- denst = density(material)
-
- cploc = sqrt(lambdaplus2mu/denst)
- csloc = sqrt(mu/denst)
-
- vpmax_local = -HUGEVAL
- vpmin_local = HUGEVAL
- vsmin_local = HUGEVAL
-
- distance_min_local = HUGEVAL
- distance_max_local = -HUGEVAL
-
- do j=1,NGLLZ
- do i=1,NGLLX
-
-!--- if heterogeneous formulation with external velocity model
- if(assign_external_model) then
- cploc = vpext(i,j,ispec)
- csloc = vsext(i,j,ispec)
- denst = rhoext(i,j,ispec)
- endif
-
- vpmax_local = max(vpmax_local,cploc)
- vpmin_local = min(vpmin_local,cploc)
- vsmin_local = min(vsmin_local,csloc)
-
- enddo
- enddo
-
-! compute minimum and maximum size of edges of this grid cell
- distance_1 = sqrt((coord(1,ibool(1,1,ispec)) - coord(1,ibool(NGLLX,1,ispec)))**2 + &
- (coord(2,ibool(1,1,ispec)) - coord(2,ibool(NGLLX,1,ispec)))**2)
-
- distance_2 = sqrt((coord(1,ibool(NGLLX,1,ispec)) - coord(1,ibool(NGLLX,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,1,ispec)) - coord(2,ibool(NGLLX,NGLLZ,ispec)))**2)
-
- distance_3 = sqrt((coord(1,ibool(NGLLX,NGLLZ,ispec)) - coord(1,ibool(1,NGLLZ,ispec)))**2 + &
- (coord(2,ibool(NGLLX,NGLLZ,ispec)) - coord(2,ibool(1,NGLLZ,ispec)))**2)
-
- distance_4 = sqrt((coord(1,ibool(1,NGLLZ,ispec)) - coord(1,ibool(1,1,ispec)))**2 + &
- (coord(2,ibool(1,NGLLZ,ispec)) - coord(2,ibool(1,1,ispec)))**2)
-
- distance_min_local = min(distance_1,distance_2,distance_3,distance_4)
- distance_max_local = max(distance_1,distance_2,distance_3,distance_4)
-
- distance_min = min(distance_min,distance_min_local)
- distance_max = max(distance_max,distance_max_local)
-
-! display mesh dispersion for S waves if there is at least one elastic element in the mesh
- if(any_elastic) then
-
-! ignore fluid regions with Vs = 0
- if(csloc > 0.0001d0) then
-
- lambdaS_local = vsmin_local / (distance_max_local / (NGLLX - 1))
-
-! display very good elements that are above 80% of the threshold in red
- if(lambdaS_local >= 0.80 * lambdaSmax) then
- write(24,*) '1 0 0 RG GF 0 setgray ST'
-
-! display bad elements that are below 120% of the threshold in blue
- else if(lambdaS_local <= 1.20 * lambdaSmin) then
- write(24,*) '0 0 1 RG GF 0 setgray ST'
-
- else
-! do not color the elements if not close to the threshold
- write(24,*) 'ST'
- endif
-
- else
-! do not color the elements if S-wave velocity undefined
- write(24,*) 'ST'
- endif
-
-! display mesh dispersion for P waves if there is no elastic element in the mesh
- else
-
- lambdaP_local = vpmin_local / (distance_max_local / (NGLLX - 1))
-
-! display very good elements that are above 80% of the threshold in red
- if(lambdaP_local >= 0.80 * lambdaPmax) then
- write(24,*) '1 0 0 RG GF 0 setgray ST'
-
-! display bad elements that are below 120% of the threshold in blue
- else if(lambdaP_local <= 1.20 * lambdaPmin) then
- write(24,*) '0 0 1 RG GF 0 setgray ST'
-
- else
-! do not color the elements if not close to the threshold
- write(24,*) 'ST'
- endif
-
- endif
-
- enddo ! end of loop on all the spectral elements
-
- write(24,*) '%'
- write(24,*) 'grestore'
- write(24,*) 'showpage'
-
- close(24)
-
- print *,'End of creation of PostScript file with mesh dispersion'
-
-!
-!--------------------------------------------------------------------------------
-!
-
- print *
- print *,'Creating PostScript file with velocity model'
-
-!
-!---- open PostScript file
-!
- open(unit=24,file='OUTPUT_FILES/P_velocity_model.ps',status='unknown')
-
-!
-!---- write PostScript header
-!
- write(24,10) simulation_title
- write(24,*) '/CM {28.5 mul} def'
- write(24,*) '/LR {rlineto} def'
- write(24,*) '/LT {lineto} def'
- write(24,*) '/L {lineto} def'
- write(24,*) '/MR {rmoveto} def'
- write(24,*) '/MV {moveto} def'
- write(24,*) '/M {moveto} def'
- write(24,*) '/ST {stroke} def'
- write(24,*) '/CP {closepath} def'
- write(24,*) '/RG {setrgbcolor} def'
- write(24,*) '/GF {gsave fill grestore} def'
- write(24,*) '% different useful symbols'
- write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
- write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
- write(24,*) 'CP fill} def'
- write(24,*) '/Cross {gsave 0.05 CM setlinewidth'
- write(24,*) 'gsave 3 3 MR -6. -6. LR ST grestore'
- write(24,*) 'gsave 3 -3 MR -6. 6. LR ST grestore'
- write(24,*) '0.01 CM setlinewidth} def'
- write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
- write(24,*) '/Diamond {gsave 0.05 CM setlinewidth 0 4.2 MR'
- write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
- write(24,*) 'grestore 0.01 CM setlinewidth} def'
- write(24,*) '%'
- write(24,*) '% macro to draw the contour of the elements'
- write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
- write(24,*) '%'
- write(24,*) '.01 CM setlinewidth'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.35 CM scalefont setfont'
- 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 scalefont setfont} def'
- write(24,*) '%'
- write(24,*) 'gsave newpath 90 rotate'
- write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
- write(24,*) '%'
-
-!
-!--- write captions of PostScript figure
-!
- write(24,*) '0 setgray'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.5 CM scalefont setfont'
-
- write(24,*) '%'
- write(24,*) '/Times-Roman findfont'
- write(24,*) '.6 CM scalefont setfont'
- 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 scalefont setfont'
- write(24,*) '.8 0 .8 setrgbcolor'
- write(24,*) '24.35 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(P-velocity model \(dark = fast, light = slow\)) show'
- write(24,*) 'grestore'
- write(24,*) '25.35 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(',simulation_title,') show'
- write(24,*) 'grestore'
- write(24,*) '26.45 CM 18.9 CM MV'
- write(24,*) usoffset,' CM 2 div neg 0 MR'
- write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(2D Spectral Element Method) show'
- write(24,*) 'grestore'
-
- write(24,*) '%'
- write(24,*) '1 1 scale'
- write(24,*) '%'
-
-!
-!---- draw the spectral element mesh
-!
- write(24,*) '%'
- write(24,*) '% spectral element mesh'
- write(24,*) '%'
- write(24,*) '0 setgray'
-
- do ispec = 1, nspec
-
- write(24,*) '% elem ',ispec
-
- do i=1,pointsdisp
- do j=1,pointsdisp
- xinterp(i,j) = 0.d0
- zinterp(i,j) = 0.d0
- do in = 1,ngnod
- nnum = knods(in,ispec)
- xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
- zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
- enddo
- enddo
- enddo
-
- is = 1
- ir = 1
- x1 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z1 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x1 = x1 * centim
- z1 = z1 * centim
- write(24,*) 'mark'
- write(24,681) x1,z1
-
-! draw straight lines if elements have 4 nodes
-
- ir=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- write(24,681) x2,z2
-
- ir=pointsdisp
- is=pointsdisp
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- write(24,681) x2,z2
-
- is=pointsdisp
- ir=1
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- write(24,681) x2,z2
-
- ir=1
- is=2
- x2 = (xinterp(ir,is)-xmin)*ratio_page + orig_x
- z2 = (zinterp(ir,is)-zmin)*ratio_page + orig_z
- x2 = x2 * centim
- z2 = z2 * centim
- write(24,681) x2,z2
-
- write(24,*) 'CO'
-
- if((vpmax-vpmin)/vpmin > 0.02d0) then
- if(assign_external_model) then
-! use lower-left corner
- x1 = (vpext(1,1,ispec)-vpmin) / (vpmax-vpmin)
- else
- material = kmato(ispec)
- mu = elastcoef(2,material)
- lambdaplus2mu = elastcoef(3,material)
- denst = density(material)
- cploc = sqrt(lambdaplus2mu/denst)
- x1 = (cploc-vpmin)/(vpmax-vpmin)
- endif
- else
- x1 = 0.5d0
- endif
-
-! rescale to avoid very dark gray levels
- x1 = x1*0.7 + 0.2
- if(x1 > 1.d0) x1=1.d0
-
-! invert scale: white = vpmin, dark gray = vpmax
- x1 = 1.d0 - x1
-
-! display P-velocity model using gray levels
- write(24,*) sngl(x1),' setgray GF 0 setgray ST'
-
- enddo ! end of loop on all the spectral elements
-
- write(24,*) '%'
- write(24,*) 'grestore'
- write(24,*) 'showpage'
-
- close(24)
-
- print *,'End of creation of PostScript file with velocity model'
-
- 10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a50,/,'%% Created by: Specfem2D',/,'%% Author: Dimitri Komatitsch',/,'%%')
-
- 681 format(f6.2,1x,f6.2)
-
- end subroutine checkgrid
-
Added: seismo/2D/SPECFEM2D/trunk/locate_receivers.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/locate_receivers.F90 2007-06-26 00:32:15 UTC (rev 8521)
+++ seismo/2D/SPECFEM2D/trunk/locate_receivers.F90 2007-12-07 23:53:16 UTC (rev 8522)
@@ -0,0 +1,195 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 5.2
+! ------------------------------
+!
+! Dimitri Komatitsch
+! University of Pau, France
+!
+! (c) April 2007
+!
+!========================================================================
+
+!----
+!---- 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) > TINYVAL) stop 'stations with non-zero burial not implemented yet'
+
+! compute distance between source and receiver
+ distance_receiver = sqrt((st_zval(irec)-z_source)**2 + (st_xval(irec)-x_source)**2)
+
+ 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
+
Deleted: seismo/2D/SPECFEM2D/trunk/locate_receivers.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/locate_receivers.f90 2007-06-26 00:32:15 UTC (rev 8521)
+++ seismo/2D/SPECFEM2D/trunk/locate_receivers.f90 2007-12-07 23:53:16 UTC (rev 8522)
@@ -1,195 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 5.2
-! ------------------------------
-!
-! Dimitri Komatitsch
-! University of Pau, France
-!
-! (c) April 2007
-!
-!========================================================================
-
-!----
-!---- 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) > TINYVAL) stop 'stations with non-zero burial not implemented yet'
-
-! compute distance between source and receiver
- distance_receiver = sqrt((st_zval(irec)-z_source)**2 + (st_xval(irec)-x_source)**2)
-
- 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/locate_source_force.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/locate_source_force.F90 2007-06-26 00:32:15 UTC (rev 8521)
+++ seismo/2D/SPECFEM2D/trunk/locate_source_force.F90 2007-12-07 23:53:16 UTC (rev 8522)
@@ -0,0 +1,93 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 5.2
+! ------------------------------
+!
+! Dimitri Komatitsch
+! University of Pau, France
+!
+! (c) April 2007
+!
+!========================================================================
+
+ subroutine locate_source_force(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,"(1x,f12.3,1x,f12.3,1x,f12.3,1x,f12.3,f12.3)") x_source,z_source,coord(1,iglob_source),coord(2,iglob_source),distmin
+ write(iout,*)
+ write(iout,*)
+ write(iout,"('Maximum distance between asked and real =',f12.3)") distminmax
+
+ 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 locate_source_force
+
Deleted: seismo/2D/SPECFEM2D/trunk/locate_source_force.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/locate_source_force.f90 2007-06-26 00:32:15 UTC (rev 8521)
+++ seismo/2D/SPECFEM2D/trunk/locate_source_force.f90 2007-12-07 23:53:16 UTC (rev 8522)
@@ -1,93 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 5.2
-! ------------------------------
-!
-! Dimitri Komatitsch
-! University of Pau, France
-!
-! (c) April 2007
-!
-!========================================================================
-
- subroutine locate_source_force(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,"(1x,f12.3,1x,f12.3,1x,f12.3,1x,f12.3,f12.3)") x_source,z_source,coord(1,iglob_source),coord(2,iglob_source),distmin
- write(iout,*)
- write(iout,*)
- write(iout,"('Maximum distance between asked and real =',f12.3)") distminmax
-
- 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 locate_source_force
-
Added: seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.F90 2007-06-26 00:32:15 UTC (rev 8521)
+++ seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.F90 2007-12-07 23:53:16 UTC (rev 8522)
@@ -0,0 +1,152 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 5.2
+! ------------------------------
+!
+! Dimitri Komatitsch
+! University of Pau, France
+!
+! (c) April 2007
+!
+!========================================================================
+
+!----
+!---- locate_source_moment_tensor finds the correct position of the moment-tensor source
+!----
+
+ subroutine locate_source_moment_tensor(ibool,coord,nspec,npoin,xigll,zigll,x_source,z_source, &
+ ispec_selected_source,xi_source,gamma_source,coorg,knods,ngnod,npgeo)
+
+ implicit none
+
+ include "constants.h"
+
+ integer 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 i,j,ispec,iglob,iter_loop,ix_initial_guess,iz_initial_guess
+
+ double precision x_source,z_source,dist
+ 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
+ double precision distmin,final_distance
+
+! source information
+ integer ispec_selected_source
+ double precision xi_source,gamma_source
+
+! **************
+
+ write(IOUT,*)
+ write(IOUT,*) '*******************************'
+ write(IOUT,*) ' locating moment-tensor source'
+ write(IOUT,*) '*******************************'
+ write(IOUT,*)
+
+! set distance to huge initial value
+ distmin=HUGEVAL
+
+ 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((x_source-dble(coord(1,iglob)))**2 + (z_source-dble(coord(2,iglob)))**2)
+
+! keep this point if it is closer to the source
+ if(dist < distmin) then
+ distmin = dist
+ ispec_selected_source = 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 source
+! ****************************************
+
+! 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_source,ngnod,nspec,npgeo)
+
+! compute distance to target location
+ dx = - (x - x_source)
+ dz = - (z - z_source)
+
+! 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 source 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_source,ngnod,nspec,npgeo)
+
+! store xi,gamma of point found
+ xi_source = xi
+ gamma_source = gamma
+
+! compute final distance between asked and found
+ final_distance = sqrt((x_source-x)**2 + (z_source-z)**2)
+
+ write(IOUT,*)
+ write(IOUT,*) 'Moment-tensor source:'
+
+ if(final_distance == HUGEVAL) stop 'error locating moment-tensor source'
+
+ write(IOUT,*) ' original x: ',sngl(x_source)
+ write(IOUT,*) ' original z: ',sngl(z_source)
+ write(IOUT,*) 'closest estimate found: ',sngl(final_distance),' m away'
+ write(IOUT,*) ' in element ',ispec_selected_source
+ write(IOUT,*) ' at xi,gamma coordinates = ',xi_source,gamma_source
+ write(IOUT,*)
+
+ write(IOUT,*)
+ write(IOUT,*) 'end of moment-tensor source detection'
+ write(IOUT,*)
+
+ end subroutine locate_source_moment_tensor
+
Deleted: seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.f90 2007-06-26 00:32:15 UTC (rev 8521)
+++ seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.f90 2007-12-07 23:53:16 UTC (rev 8522)
@@ -1,152 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 5.2
-! ------------------------------
-!
-! Dimitri Komatitsch
-! University of Pau, France
-!
-! (c) April 2007
-!
-!========================================================================
-
-!----
-!---- locate_source_moment_tensor finds the correct position of the moment-tensor source
-!----
-
- subroutine locate_source_moment_tensor(ibool,coord,nspec,npoin,xigll,zigll,x_source,z_source, &
- ispec_selected_source,xi_source,gamma_source,coorg,knods,ngnod,npgeo)
-
- implicit none
-
- include "constants.h"
-
- integer 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 i,j,ispec,iglob,iter_loop,ix_initial_guess,iz_initial_guess
-
- double precision x_source,z_source,dist
- 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
- double precision distmin,final_distance
-
-! source information
- integer ispec_selected_source
- double precision xi_source,gamma_source
-
-! **************
-
- write(IOUT,*)
- write(IOUT,*) '*******************************'
- write(IOUT,*) ' locating moment-tensor source'
- write(IOUT,*) '*******************************'
- write(IOUT,*)
-
-! set distance to huge initial value
- distmin=HUGEVAL
-
- 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((x_source-dble(coord(1,iglob)))**2 + (z_source-dble(coord(2,iglob)))**2)
-
-! keep this point if it is closer to the source
- if(dist < distmin) then
- distmin = dist
- ispec_selected_source = 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 source
-! ****************************************
-
-! 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_source,ngnod,nspec,npgeo)
-
-! compute distance to target location
- dx = - (x - x_source)
- dz = - (z - z_source)
-
-! 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 source 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_source,ngnod,nspec,npgeo)
-
-! store xi,gamma of point found
- xi_source = xi
- gamma_source = gamma
-
-! compute final distance between asked and found
- final_distance = sqrt((x_source-x)**2 + (z_source-z)**2)
-
- write(IOUT,*)
- write(IOUT,*) 'Moment-tensor source:'
-
- if(final_distance == HUGEVAL) stop 'error locating moment-tensor source'
-
- write(IOUT,*) ' original x: ',sngl(x_source)
- write(IOUT,*) ' original z: ',sngl(z_source)
- write(IOUT,*) 'closest estimate found: ',sngl(final_distance),' m away'
- write(IOUT,*) ' in element ',ispec_selected_source
- write(IOUT,*) ' at xi,gamma coordinates = ',xi_source,gamma_source
- write(IOUT,*)
-
- write(IOUT,*)
- write(IOUT,*) 'end of moment-tensor source detection'
- write(IOUT,*)
-
- end subroutine locate_source_moment_tensor
-
Added: seismo/2D/SPECFEM2D/trunk/meshfem2D.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/meshfem2D.F90 2007-06-26 00:32:15 UTC (rev 8521)
+++ seismo/2D/SPECFEM2D/trunk/meshfem2D.F90 2007-12-07 23:53:16 UTC (rev 8522)
@@ -0,0 +1,964 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 5.2
+! ------------------------------
+!
+! Dimitri Komatitsch
+! University of Pau, France
+!
+! (c) April 2007
+!
+!========================================================================
+
+!========================================================================
+!
+! Basic mesh generator for SPECFEM2D
+!
+!========================================================================
+
+! If you use this code for your own research, please cite:
+!
+! @ARTICLE{KoTr99,
+! author={D. Komatitsch and J. Tromp},
+! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
+! journal={Geophys. J. Int.},
+! year=1999,
+! volume=139,
+! number=3,
+! pages={806-822},
+! doi={10.1046/j.1365-246x.1999.00967.x}}
+!
+! @ARTICLE{KoVi98,
+! author={D. Komatitsch and J. P. Vilotte},
+! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
+! journal={Bull. Seismol. Soc. Am.},
+! year=1998,
+! volume=88,
+! number=2,
+! pages={368-392}}
+
+ program meshfem2D
+
+ implicit none
+
+ include "constants.h"
+
+! 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
+
+! to store density and velocity model
+ double precision, dimension(:), allocatable :: rho,cp,cs,aniso3,aniso4
+ integer, dimension(:), allocatable :: icodemat
+ integer, dimension(:,:), allocatable :: num_material
+
+! 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 and receivers
+ integer source_type,time_function_type,nrec_total,irec_global_number
+ double precision xs,zs,f0,t0,angleforce,Mxx,Mzz,Mxz,factor,xrec,zrec
+
+ character(len=50) interfacesfile,title
+
+ integer imaterial_number,inumelem
+ integer nelemabs,nelem_acoustic_surface,npgeo,nspec
+ integer k,icol,ili,istepx,istepz,ix,iz,irec,i,j
+ integer ixdebregion,ixfinregion,izdebregion,izfinregion
+ integer iregion,imaterial,nbregion,nb_materials
+ integer NTSTEP_BETWEEN_OUTPUT_INFO,pointsdisp,subsamp,seismotype,imagetype
+ integer ngnod,nt,nx,nz,nxread,nzread,icodematread,ireceiverlines,nreceiverlines
+
+ integer, dimension(:), allocatable :: nrec
+
+ logical codetop,codebottom,codeleft,coderight,output_postscript_snapshot,output_color_image,plot_lowerleft_corner_only
+
+ double precision tang1,tangN,vpregion,vsregion,poisson_ratio
+ double precision cutsnaps,sizemax_arrows,anglerec,xmin,xmax,deltat
+ double precision rhoread,cpread,csread,aniso3read,aniso4read
+
+ double precision, dimension(:), allocatable :: xdeb,zdeb,xfin,zfin
+
+ logical interpol,gnuplot,assign_external_model,outputgrid
+ logical abstop,absbottom,absleft,absright
+ logical source_surf,meshvect,initialfield,modelvect,boundvect
+ logical TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
+
+ logical, dimension(:), allocatable :: enreg_surf
+
+ integer, external :: num
+ double precision, external :: value_spline
+
+! flag to indicate an anisotropic material
+ integer, parameter :: ANISOTROPIC_MATERIAL = 2
+
+! file number for interface file
+ 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=IIN,file='DATA/Par_file',status='old')
+
+! read file names and path for output
+ call read_value_string(IIN,IGNORE_JUNK,title)
+ call read_value_string(IIN,IGNORE_JUNK,interfacesfile)
+
+ write(*,*) 'Title of the simulation'
+ write(*,*) title
+ print *
+
+! read grid parameters
+ call read_value_double_precision(IIN,IGNORE_JUNK,xmin)
+ call read_value_double_precision(IIN,IGNORE_JUNK,xmax)
+ call read_value_integer(IIN,IGNORE_JUNK,nx)
+ call read_value_integer(IIN,IGNORE_JUNK,ngnod)
+ call read_value_logical(IIN,IGNORE_JUNK,initialfield)
+ call read_value_logical(IIN,IGNORE_JUNK,assign_external_model)
+ call read_value_logical(IIN,IGNORE_JUNK,TURN_ANISOTROPY_ON)
+ call read_value_logical(IIN,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=IIN_INTERFACES,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
+ call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK,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(IIN_INTERFACES)
+
+! 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
+
+! multiply by 2 if elements have 9 nodes
+ if(ngnod == 9) then
+ nx = nx * 2
+ nz = nz * 2
+ nz_layer(:) = nz_layer(:) * 2
+ endif
+
+! read absorbing boundaries parameters
+ call read_value_logical(IIN,IGNORE_JUNK,absbottom)
+ call read_value_logical(IIN,IGNORE_JUNK,absright)
+ call read_value_logical(IIN,IGNORE_JUNK,abstop)
+ call read_value_logical(IIN,IGNORE_JUNK,absleft)
+
+! read time step parameters
+ call read_value_integer(IIN,IGNORE_JUNK,nt)
+ call read_value_double_precision(IIN,IGNORE_JUNK,deltat)
+
+! read source parameters
+ call read_value_logical(IIN,IGNORE_JUNK,source_surf)
+ call read_value_double_precision(IIN,IGNORE_JUNK,xs)
+ call read_value_double_precision(IIN,IGNORE_JUNK,zs)
+ call read_value_integer(IIN,IGNORE_JUNK,source_type)
+ call read_value_integer(IIN,IGNORE_JUNK,time_function_type)
+ call read_value_double_precision(IIN,IGNORE_JUNK,f0)
+ call read_value_double_precision(IIN,IGNORE_JUNK,angleforce)
+ call read_value_double_precision(IIN,IGNORE_JUNK,Mxx)
+ call read_value_double_precision(IIN,IGNORE_JUNK,Mzz)
+ call read_value_double_precision(IIN,IGNORE_JUNK,Mxz)
+ call read_value_double_precision(IIN,IGNORE_JUNK,factor)
+
+! if Dirac source time function, use a very thin Gaussian instead
+! if Heaviside source time function, use a very thin error function instead
+ if(time_function_type == 4 .or. time_function_type == 5) f0 = 1.d0 / (10.d0 * deltat)
+
+! time delay of the source in seconds, use a 20 % security margin (use 2 / f0 if error function)
+ if(time_function_type == 5) then
+ t0 = 2.0d0 / f0
+ else
+ t0 = 1.20d0 / f0
+ endif
+
+ print *
+ print *,'Source:'
+ print *,'Position xs, zs = ',xs,zs
+ print *,'Frequency, delay = ',f0,t0
+ print *,'Source type (1=force, 2=explosion): ',source_type
+ print *,'Time function type (1=Ricker, 2=First derivative, 3=Gaussian, 4=Dirac, 5=Heaviside): ',time_function_type
+ print *,'Angle of the source if force = ',angleforce
+ print *,'Mxx of the source if moment tensor = ',Mxx
+ print *,'Mzz of the source if moment tensor = ',Mzz
+ print *,'Mxz of the source if moment tensor = ',Mxz
+ print *,'Multiplying factor = ',factor
+
+! read receiver line parameters
+ call read_value_integer(IIN,IGNORE_JUNK,seismotype)
+ call read_value_integer(IIN,IGNORE_JUNK,nreceiverlines)
+ call read_value_double_precision(IIN,IGNORE_JUNK,anglerec)
+
+ if(nreceiverlines < 1) stop 'number of receiver lines must be greater than 1'
+
+! allocate receiver line arrays
+ allocate(nrec(nreceiverlines))
+ allocate(xdeb(nreceiverlines))
+ allocate(zdeb(nreceiverlines))
+ allocate(xfin(nreceiverlines))
+ allocate(zfin(nreceiverlines))
+ allocate(enreg_surf(nreceiverlines))
+
+! loop on all the receiver lines
+ do ireceiverlines = 1,nreceiverlines
+ call read_value_integer(IIN,IGNORE_JUNK,nrec(ireceiverlines))
+ call read_value_double_precision(IIN,IGNORE_JUNK,xdeb(ireceiverlines))
+ call read_value_double_precision(IIN,IGNORE_JUNK,zdeb(ireceiverlines))
+ call read_value_double_precision(IIN,IGNORE_JUNK,xfin(ireceiverlines))
+ call read_value_double_precision(IIN,IGNORE_JUNK,zfin(ireceiverlines))
+ call read_value_logical(IIN,IGNORE_JUNK,enreg_surf(ireceiverlines))
+ enddo
+
+! read display parameters
+ call read_value_integer(IIN,IGNORE_JUNK,NTSTEP_BETWEEN_OUTPUT_INFO)
+ call read_value_logical(IIN,IGNORE_JUNK,output_postscript_snapshot)
+ call read_value_logical(IIN,IGNORE_JUNK,output_color_image)
+ call read_value_integer(IIN,IGNORE_JUNK,imagetype)
+ call read_value_double_precision(IIN,IGNORE_JUNK,cutsnaps)
+ call read_value_logical(IIN,IGNORE_JUNK,meshvect)
+ call read_value_logical(IIN,IGNORE_JUNK,modelvect)
+ call read_value_logical(IIN,IGNORE_JUNK,boundvect)
+ call read_value_logical(IIN,IGNORE_JUNK,interpol)
+ call read_value_integer(IIN,IGNORE_JUNK,pointsdisp)
+ call read_value_integer(IIN,IGNORE_JUNK,subsamp)
+ call read_value_double_precision(IIN,IGNORE_JUNK,sizemax_arrows)
+ call read_value_logical(IIN,IGNORE_JUNK,gnuplot)
+ call read_value_logical(IIN,IGNORE_JUNK,outputgrid)
+
+! can use only one point to display lower-left corner only for interpolated snapshot
+ if(pointsdisp < 3) then
+ pointsdisp = 3
+ plot_lowerleft_corner_only = .true.
+ else
+ plot_lowerleft_corner_only = .false.
+ endif
+
+! read the different material materials
+ call read_value_integer(IIN,IGNORE_JUNK,nb_materials)
+ if(nb_materials <= 0) stop 'Negative number of materials not allowed!'
+
+ allocate(icodemat(nb_materials))
+ allocate(rho(nb_materials))
+ allocate(cp(nb_materials))
+ allocate(cs(nb_materials))
+ allocate(aniso3(nb_materials))
+ allocate(aniso4(nb_materials))
+ allocate(num_material(nx,nz))
+
+ icodemat(:) = 0
+ rho(:) = 0.d0
+ cp(:) = 0.d0
+ cs(:) = 0.d0
+ aniso3(:) = 0.d0
+ aniso4(:) = 0.d0
+ num_material(:,:) = 0
+
+ do imaterial=1,nb_materials
+ call read_material_parameters(IIN,DONT_IGNORE_JUNK,i,icodematread,rhoread,cpread,csread,aniso3read,aniso4read)
+ if(i < 1 .or. i > nb_materials) stop 'Wrong material 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'
+
+ aniso3(i) = aniso3read
+ aniso4(i) = aniso4read
+ enddo
+
+ print *
+ print *, 'Nb of solid or fluid materials = ',nb_materials
+ print *
+ do i=1,nb_materials
+ if(icodemat(i) /= ANISOTROPIC_MATERIAL) then
+ print *,'Material #',i,' isotropic'
+ print *,'rho,cp,cs = ',rho(i),cp(i),cs(i)
+ if(cs(i) < TINYVAL) then
+ print *,'Material is fluid'
+ else
+ print *,'Material is solid'
+ endif
+ else
+ print *,'Material #',i,' anisotropic'
+ print *,'rho,c11,c13,c33,c44 = ',rho(i),cp(i),cs(i),aniso3(i),aniso4(i)
+ endif
+ print *
+ enddo
+
+! read the material numbers for each region
+ call read_value_integer(IIN,IGNORE_JUNK,nbregion)
+
+ if(nbregion <= 0) stop 'Negative number of regions not allowed!'
+
+ print *
+ print *, 'Nb of regions in the mesh = ',nbregion
+ print *
+
+ do iregion = 1,nbregion
+
+ call read_region_coordinates(IIN,DONT_IGNORE_JUNK,ixdebregion,ixfinregion,izdebregion,izfinregion,imaterial_number)
+
+ if(imaterial_number < 1) stop 'Negative material number not allowed!'
+ if(ixdebregion < 1) stop 'Left coordinate of region negative!'
+ if(ixfinregion > nxread) stop 'Right coordinate of region too high!'
+ if(izdebregion < 1) stop 'Bottom coordinate of region negative!'
+ if(izfinregion > nzread) stop 'Top coordinate of region too high!'
+
+ print *,'Region ',iregion
+ print *,'IX from ',ixdebregion,' to ',ixfinregion
+ print *,'IZ from ',izdebregion,' to ',izfinregion
+
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL) then
+ vpregion = cp(imaterial_number)
+ vsregion = cs(imaterial_number)
+ print *,'Material # ',imaterial_number,' isotropic'
+ if(vsregion < TINYVAL) then
+ print *,'Material is fluid'
+ else
+ print *,'Material is solid'
+ endif
+ print *,'vp = ',vpregion
+ print *,'vs = ',vsregion
+ print *,'rho = ',rho(imaterial_number)
+ poisson_ratio = 0.5d0*(vpregion*vpregion-2.d0*vsregion*vsregion) / (vpregion*vpregion-vsregion*vsregion)
+ print *,'Poisson''s ratio = ',poisson_ratio
+ if(poisson_ratio <= -1.00001d0 .or. poisson_ratio >= 0.50001d0) stop 'incorrect value of Poisson''s ratio'
+ else
+ print *,'Material # ',imaterial_number,' anisotropic'
+ print *,'c11 = ',cp(imaterial_number)
+ print *,'c13 = ',cs(imaterial_number)
+ print *,'c33 = ',aniso3(imaterial_number)
+ print *,'c44 = ',aniso4(imaterial_number)
+ print *,'rho = ',rho(imaterial_number)
+ endif
+ print *,' -----'
+
+! store density and velocity model
+ do i = ixdebregion,ixfinregion
+ do j = izdebregion,izfinregion
+ if(ngnod == 4) then
+ num_material(i,j) = imaterial_number
+ else
+ num_material(2*(i-1)+1,2*(j-1)+1) = imaterial_number
+ num_material(2*(i-1)+1,2*(j-1)+2) = imaterial_number
+ num_material(2*(i-1)+2,2*(j-1)+1) = imaterial_number
+ num_material(2*(i-1)+2,2*(j-1)+2) = imaterial_number
+ endif
+ enddo
+ enddo
+
+ enddo
+
+ if(minval(num_material) <= 0) stop 'Velocity model not entirely set...'
+
+ close(IIN)
+
+ print *
+ print *,'Parameter file successfully read... '
+
+!---
+
+ if(ngnod /= 4 .and. ngnod /= 9) stop 'ngnod different from 4 or 9!'
+
+ print *
+ if(ngnod == 4) then
+ print *,'The mesh contains ',nx,' x ',nz,' elements'
+ else
+ print *,'The mesh contains ',nx/2,' x ',nz/2,' elements'
+ endif
+ print *
+ print *,'Control elements have ',ngnod,' nodes'
+ print *
+
+!---
+
+! 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=IIN_INTERFACES,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
+ call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK, &
+ xinterface_bottom(ipoint_current),zinterface_bottom(ipoint_current))
+ enddo
+
+! loop on all the layers
+ 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
+ call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK, &
+ xinterface_top(ipoint_current),zinterface_top(ipoint_current))
+ enddo
+
+! compute the spline for the bottom interface, impose the tangent on both edges
+ tang1 = (zinterface_bottom(2)-zinterface_bottom(1)) / (xinterface_bottom(2)-xinterface_bottom(1))
+ tangN = (zinterface_bottom(npoints_interface_bottom)-zinterface_bottom(npoints_interface_bottom-1)) / &
+ (xinterface_bottom(npoints_interface_bottom)-xinterface_bottom(npoints_interface_bottom-1))
+ call spline(xinterface_bottom,zinterface_bottom,npoints_interface_bottom,tang1,tangN,coefs_interface_bottom)
+
+! compute the spline for the top interface, impose the tangent on both edges
+ tang1 = (zinterface_top(2)-zinterface_top(1)) / (xinterface_top(2)-xinterface_top(1))
+ tangN = (zinterface_top(npoints_interface_top)-zinterface_top(npoints_interface_top-1)) / &
+ (xinterface_top(npoints_interface_top)-xinterface_top(npoints_interface_top-1))
+ call spline(xinterface_top,zinterface_top,npoints_interface_top,tang1,tangN,coefs_interface_top)
+
+! check if we are in the last layer, which contains topography,
+! and modify the position of the source accordingly if it is located exactly at the surface
+ if(source_surf .and. ilayer == number_of_layers) &
+ zs = value_spline(xs,xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
+
+! compute the offset of this layer in terms of number of spectral elements below along Z
+ if(ilayer > 1) then
+ ioffset = sum(nz_layer(1:ilayer-1))
+ else
+ ioffset = 0
+ endif
+
+!--- definition of the mesh
+
+ do ix = 0,nx
+
+! evenly spaced points along 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
+
+! the top interface becomes the bottom interface before switching to the next layer
+ npoints_interface_bottom = npoints_interface_top
+ xinterface_bottom(:) = xinterface_top(:)
+ zinterface_bottom(:) = zinterface_top(:)
+
+ enddo
+
+ close(IIN_INTERFACES)
+
+! compute min and max of X and Z in the grid
+ print *
+ print *,'Min and max value of X in the grid = ',minval(x),maxval(x)
+ print *,'Min and max value of Z in the grid = ',minval(z),maxval(z)
+ print *
+
+! ***
+! *** create a Gnuplot file that displays the grid
+! ***
+
+ print *
+ print *,'Saving the grid in Gnuplot format...'
+
+ open(unit=20,file='OUTPUT_FILES/gridfile.gnu',status='unknown')
+
+! draw horizontal lines of the grid
+ print *,'drawing horizontal lines of the grid'
+ 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,*) sngl(x(icol,ili)),sngl(z(icol,ili))
+ write(20,*) sngl(x(icol+istepx,ili)),sngl(z(icol+istepx,ili))
+ write(20,10)
+ enddo
+ enddo
+
+! draw vertical lines of the grid
+ print *,'drawing vertical lines of the grid'
+ 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,*) sngl(x(icol,ili)),sngl(z(icol,ili))
+ write(20,*) sngl(x(icol,ili+istepz)),sngl(z(icol,ili+istepz))
+ write(20,10)
+ enddo
+ enddo
+
+ 10 format('')
+
+ close(20)
+
+! create a Gnuplot script to display the grid
+ open(unit=20,file='OUTPUT_FILES/plotgnu',status='unknown')
+ write(20,*) '#set term X11'
+ write(20,*) 'set term postscript landscape monochrome solid "Helvetica" 22'
+ write(20,*) 'set output "grid.ps"'
+ write(20,*) '#set xrange [',sngl(minval(x)),':',sngl(maxval(x)),']'
+ write(20,*) '#set yrange [',sngl(minval(z)),':',sngl(maxval(z)),']'
+! use same unit length on both X and Y axes
+ write(20,*) 'set size ratio -1'
+ write(20,*) 'plot "gridfile.gnu" title "Macrobloc mesh" w l'
+ write(20,*) 'pause -1 "Hit any key..."'
+ close(20)
+
+ print *,'Grid saved in Gnuplot format...'
+ print *
+
+! *** generate the database for the solver
+
+ open(unit=15,file='OUTPUT_FILES/Database',status='unknown')
+
+ write(15,*) '#'
+ write(15,*) '# Database for SPECFEM2D'
+ write(15,*) '# Dimitri Komatitsch, (c) University of Pau, France'
+ write(15,*) '#'
+
+ write(15,*) 'Title of the simulation'
+ write(15,"(a50)") 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,*) 'NTSTEP_BETWEEN_OUTPUT_INFO'
+ write(15,*) NTSTEP_BETWEEN_OUTPUT_INFO
+
+ write(15,*) 'output_postscript_snapshot output_color_image colors numbers'
+ write(15,*) output_postscript_snapshot,output_color_image,' 1 0'
+
+ write(15,*) 'meshvect modelvect boundvect cutsnaps subsamp sizemax_arrows'
+ write(15,*) meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows
+
+ write(15,*) 'anglerec'
+ write(15,*) anglerec
+
+ write(15,*) 'initialfield'
+ write(15,*) initialfield
+
+ write(15,*) 'seismotype imagetype'
+ write(15,*) seismotype,imagetype
+
+ write(15,*) 'assign_external_model outputgrid TURN_ANISOTROPY_ON TURN_ATTENUATION_ON'
+ write(15,*) assign_external_model,outputgrid,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
+
+ write(15,*) 'nt deltat'
+ write(15,*) nt,deltat
+
+ write(15,*) 'source'
+ write(15,*) source_type,time_function_type,xs,zs,f0,t0,factor,angleforce,Mxx,Mzz,Mxz
+
+ write(15,*) 'Coordinates of macrobloc mesh (coorg):'
+ do j=0,nz
+ do i=0,nx
+ write(15,*) num(i,j,nx),x(i,j),z(i,j)
+ enddo
+ enddo
+
+!
+!--- definition of absorbing boundaries
+!
+ nelemabs = 0
+ if(absbottom) nelemabs = nelemabs + nx
+ if(abstop) nelemabs = nelemabs + nx
+ if(absleft) nelemabs = nelemabs + nz
+ if(absright) nelemabs = nelemabs + nz
+
+! we have counted the elements twice if they have nine nodes
+ if(ngnod == 9) nelemabs = nelemabs / 2
+
+! also remove the corner elements, which have been counted twice
+ if(absbottom .and. absleft) nelemabs = nelemabs - 1
+ if(absbottom .and. absright) nelemabs = nelemabs - 1
+ if(abstop .and. absleft) nelemabs = nelemabs - 1
+ if(abstop .and. absright) nelemabs = nelemabs - 1
+
+! count the number of acoustic free-surface elements
+ nelem_acoustic_surface = 0
+ do j = 1,nzread
+ do i = 1,nxread
+ if(ngnod == 4) then
+ imaterial_number = num_material(i,j)
+ else
+ imaterial_number = num_material(2*(i-1)+1,2*(j-1)+1)
+ endif
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. cs(imaterial_number) < TINYVAL &
+ .and. j == nzread) nelem_acoustic_surface = nelem_acoustic_surface + 1
+ enddo
+ enddo
+
+ write(15,*) 'numat ngnod nspec pointsdisp plot_lowerleft_corner_only'
+ write(15,*) nb_materials,ngnod,nspec,pointsdisp,plot_lowerleft_corner_only
+ write(15,*) 'nelemabs nelem_acoustic_surface'
+ write(15,*) nelemabs,nelem_acoustic_surface
+
+ write(15,*) 'Material sets (num 1 rho vp vs 0 0) or (num 2 rho c11 c13 c33 c44)'
+ do i=1,nb_materials
+ write(15,*) i,icodemat(i),rho(i),cp(i),cs(i),aniso3(i),aniso4(i)
+ enddo
+
+
+ write(15,*) 'Arrays kmato and knods for each bloc:'
+
+ k = 0
+ if(ngnod == 4) then
+ do j=0,nz-1
+ do i=0,nx-1
+ k = k + 1
+ imaterial_number = num_material(i+1,j+1)
+ write(15,*) k,imaterial_number,num(i,j,nx),num(i+1,j,nx),num(i+1,j+1,nx),num(i,j+1,nx)
+ enddo
+ enddo
+ else
+ do j=0,nz-2,2
+ do i=0,nx-2,2
+ k = k + 1
+ imaterial_number = num_material(i+1,j+1)
+ write(15,*) k,imaterial_number,num(i,j,nx),num(i+2,j,nx),num(i+2,j+2,nx),num(i,j+2,nx), &
+ num(i+1,j,nx),num(i+2,j+1,nx),num(i+1,j+2,nx),num(i,j+1,nx),num(i+1,j+1,nx)
+ enddo
+ enddo
+ endif
+
+!
+!--- save absorbing boundaries
+!
+ print *
+ print *,'There is a total of ',nelemabs,' absorbing elements'
+ print *
+ print *,'Active absorbing boundaries:'
+ print *
+ print *,'Bottom = ',absbottom
+ print *,'Right = ',absright
+ print *,'Top = ',abstop
+ print *,'Left = ',absleft
+ print *
+
+! generate the list of absorbing elements
+ if(nelemabs > 0) then
+ write(15,*) 'List of absorbing elements (bottom right top left):'
+ do iz = 1,nzread
+ do ix = 1,nxread
+ codebottom = .false.
+ coderight = .false.
+ codetop = .false.
+ codeleft = .false.
+ inumelem = (iz-1)*nxread + ix
+ if(absbottom .and. iz == 1) codebottom = .true.
+ if(absright .and. ix == nxread) coderight = .true.
+ if(abstop .and. iz == nzread) codetop = .true.
+ if(absleft .and. ix == 1) codeleft = .true.
+ if(codebottom .or. coderight .or. codetop .or. codeleft) write(15,*) inumelem,codebottom,coderight,codetop,codeleft
+ enddo
+ enddo
+ endif
+
+!
+!--- save acoustic free-surface elements
+!
+ print *
+ print *,'There is a total of ',nelem_acoustic_surface,' acoustic free-surface elements'
+ print *
+
+! generate the list of acoustic free-surface elements
+ if(nelem_acoustic_surface > 0) then
+ write(15,*) 'List of acoustic free-surface elements:'
+ do j = 1,nzread
+ do i = 1,nxread
+ inumelem = (j-1)*nxread + i
+ if(ngnod == 4) then
+ imaterial_number = num_material(i,j)
+ else
+ imaterial_number = num_material(2*(i-1)+1,2*(j-1)+1)
+ endif
+! in this simple mesher, it is always the top edge that is at the free surface
+ if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. cs(imaterial_number) < TINYVAL .and. j == nzread) &
+ write(15,*) inumelem,ITOP
+ enddo
+ enddo
+ endif
+
+ close(15)
+
+! print position of the source
+ print *
+ print *,'Position (x,z) of the source = ',xs,zs
+ print *
+
+!--- compute position of the receivers and write the STATIONS file
+
+ print *
+ print *,'writing the DATA/STATIONS file'
+ print *
+
+! total number of receivers in all the receiver lines
+ nrec_total = sum(nrec)
+
+ print *
+ print *,'There are ',nrec_total,' receivers'
+
+ print *
+ print *,'Position (x,z) of the ',nrec_total,' receivers'
+ print *
+
+ open(unit=15,file='DATA/STATIONS',status='unknown')
+ write(15,*) nrec_total
+
+ irec_global_number = 0
+
+! loop on all the receiver lines
+ do ireceiverlines = 1,nreceiverlines
+
+! loop on all the receivers of this receiver line
+ do irec = 1,nrec(ireceiverlines)
+
+! compute global receiver number
+ irec_global_number = irec_global_number + 1
+
+! compute coordinates of the receiver
+ if(nrec(ireceiverlines) > 1) then
+ xrec = xdeb(ireceiverlines) + dble(irec-1)*(xfin(ireceiverlines)-xdeb(ireceiverlines))/dble(nrec(ireceiverlines)-1)
+ zrec = zdeb(ireceiverlines) + dble(irec-1)*(zfin(ireceiverlines)-zdeb(ireceiverlines))/dble(nrec(ireceiverlines)-1)
+ else
+ xrec = xdeb(ireceiverlines)
+ zrec = zdeb(ireceiverlines)
+ endif
+
+! modify position of receiver if we must record exactly at the surface
+ if(enreg_surf(ireceiverlines)) &
+ zrec = value_spline(xrec,xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
+
+! display position of the receiver
+ print *,'Receiver ',irec_global_number,' = ',xrec,zrec
+
+ write(15,"('S',i4.4,' AA ',f20.7,1x,f20.7,' 0.0 0.0')") irec_global_number,xrec,zrec
+
+ enddo
+ enddo
+
+ close(15)
+
+ print *
+
+ end program meshfem2D
+
+! *******************
+! meshing subroutines
+! *******************
+
+!--- global node number
+
+ integer function num(i,j,nx)
+
+ implicit none
+
+ integer i,j,nx
+
+ num = j*(nx+1) + i + 1
+
+ end function num
+
+!--- spline to describe the interfaces
+
+ 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
+
+! assign the value on the edge if point is outside the model
+ if(xp < xinterface(1)) xp = xinterface(1)
+ if(xp > xinterface(npoints_interface)) xp = xinterface(npoints_interface)
+
+ call splint(xinterface,zinterface,coefs_interface,npoints_interface,xp,value_spline)
+
+ end function value_spline
+
+! --------------------------------------
+
+! compute spline coefficients (Numerical Recipes)
+! modified to use dynamic allocation
+
+ 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
+
+! --------------
+
+! evaluate 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
+
Deleted: seismo/2D/SPECFEM2D/trunk/meshfem2D.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/meshfem2D.f90 2007-06-26 00:32:15 UTC (rev 8521)
+++ seismo/2D/SPECFEM2D/trunk/meshfem2D.f90 2007-12-07 23:53:16 UTC (rev 8522)
@@ -1,964 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 5.2
-! ------------------------------
-!
-! Dimitri Komatitsch
-! University of Pau, France
-!
-! (c) April 2007
-!
-!========================================================================
-
-!========================================================================
-!
-! Basic mesh generator for SPECFEM2D
-!
-!========================================================================
-
-! If you use this code for your own research, please cite:
-!
-! @ARTICLE{KoTr99,
-! author={D. Komatitsch and J. Tromp},
-! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
-! journal={Geophys. J. Int.},
-! year=1999,
-! volume=139,
-! number=3,
-! pages={806-822},
-! doi={10.1046/j.1365-246x.1999.00967.x}}
-!
-! @ARTICLE{KoVi98,
-! author={D. Komatitsch and J. P. Vilotte},
-! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
-! journal={Bull. Seismol. Soc. Am.},
-! year=1998,
-! volume=88,
-! number=2,
-! pages={368-392}}
-
- program meshfem2D
-
- implicit none
-
- include "constants.h"
-
-! 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
-
-! to store density and velocity model
- double precision, dimension(:), allocatable :: rho,cp,cs,aniso3,aniso4
- integer, dimension(:), allocatable :: icodemat
- integer, dimension(:,:), allocatable :: num_material
-
-! 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 and receivers
- integer source_type,time_function_type,nrec_total,irec_global_number
- double precision xs,zs,f0,t0,angleforce,Mxx,Mzz,Mxz,factor,xrec,zrec
-
- character(len=50) interfacesfile,title
-
- integer imaterial_number,inumelem
- integer nelemabs,nelem_acoustic_surface,npgeo,nspec
- integer k,icol,ili,istepx,istepz,ix,iz,irec,i,j
- integer ixdebregion,ixfinregion,izdebregion,izfinregion
- integer iregion,imaterial,nbregion,nb_materials
- integer NTSTEP_BETWEEN_OUTPUT_INFO,pointsdisp,subsamp,seismotype,imagetype
- integer ngnod,nt,nx,nz,nxread,nzread,icodematread,ireceiverlines,nreceiverlines
-
- integer, dimension(:), allocatable :: nrec
-
- logical codetop,codebottom,codeleft,coderight,output_postscript_snapshot,output_color_image,plot_lowerleft_corner_only
-
- double precision tang1,tangN,vpregion,vsregion,poisson_ratio
- double precision cutsnaps,sizemax_arrows,anglerec,xmin,xmax,deltat
- double precision rhoread,cpread,csread,aniso3read,aniso4read
-
- double precision, dimension(:), allocatable :: xdeb,zdeb,xfin,zfin
-
- logical interpol,gnuplot,assign_external_model,outputgrid
- logical abstop,absbottom,absleft,absright
- logical source_surf,meshvect,initialfield,modelvect,boundvect
- logical TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
-
- logical, dimension(:), allocatable :: enreg_surf
-
- integer, external :: num
- double precision, external :: value_spline
-
-! flag to indicate an anisotropic material
- integer, parameter :: ANISOTROPIC_MATERIAL = 2
-
-! file number for interface file
- 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=IIN,file='DATA/Par_file',status='old')
-
-! read file names and path for output
- call read_value_string(IIN,IGNORE_JUNK,title)
- call read_value_string(IIN,IGNORE_JUNK,interfacesfile)
-
- write(*,*) 'Title of the simulation'
- write(*,*) title
- print *
-
-! read grid parameters
- call read_value_double_precision(IIN,IGNORE_JUNK,xmin)
- call read_value_double_precision(IIN,IGNORE_JUNK,xmax)
- call read_value_integer(IIN,IGNORE_JUNK,nx)
- call read_value_integer(IIN,IGNORE_JUNK,ngnod)
- call read_value_logical(IIN,IGNORE_JUNK,initialfield)
- call read_value_logical(IIN,IGNORE_JUNK,assign_external_model)
- call read_value_logical(IIN,IGNORE_JUNK,TURN_ANISOTROPY_ON)
- call read_value_logical(IIN,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=IIN_INTERFACES,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
- call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK,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(IIN_INTERFACES)
-
-! 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
-
-! multiply by 2 if elements have 9 nodes
- if(ngnod == 9) then
- nx = nx * 2
- nz = nz * 2
- nz_layer(:) = nz_layer(:) * 2
- endif
-
-! read absorbing boundaries parameters
- call read_value_logical(IIN,IGNORE_JUNK,absbottom)
- call read_value_logical(IIN,IGNORE_JUNK,absright)
- call read_value_logical(IIN,IGNORE_JUNK,abstop)
- call read_value_logical(IIN,IGNORE_JUNK,absleft)
-
-! read time step parameters
- call read_value_integer(IIN,IGNORE_JUNK,nt)
- call read_value_double_precision(IIN,IGNORE_JUNK,deltat)
-
-! read source parameters
- call read_value_logical(IIN,IGNORE_JUNK,source_surf)
- call read_value_double_precision(IIN,IGNORE_JUNK,xs)
- call read_value_double_precision(IIN,IGNORE_JUNK,zs)
- call read_value_integer(IIN,IGNORE_JUNK,source_type)
- call read_value_integer(IIN,IGNORE_JUNK,time_function_type)
- call read_value_double_precision(IIN,IGNORE_JUNK,f0)
- call read_value_double_precision(IIN,IGNORE_JUNK,angleforce)
- call read_value_double_precision(IIN,IGNORE_JUNK,Mxx)
- call read_value_double_precision(IIN,IGNORE_JUNK,Mzz)
- call read_value_double_precision(IIN,IGNORE_JUNK,Mxz)
- call read_value_double_precision(IIN,IGNORE_JUNK,factor)
-
-! if Dirac source time function, use a very thin Gaussian instead
-! if Heaviside source time function, use a very thin error function instead
- if(time_function_type == 4 .or. time_function_type == 5) f0 = 1.d0 / (10.d0 * deltat)
-
-! time delay of the source in seconds, use a 20 % security margin (use 2 / f0 if error function)
- if(time_function_type == 5) then
- t0 = 2.0d0 / f0
- else
- t0 = 1.20d0 / f0
- endif
-
- print *
- print *,'Source:'
- print *,'Position xs, zs = ',xs,zs
- print *,'Frequency, delay = ',f0,t0
- print *,'Source type (1=force, 2=explosion): ',source_type
- print *,'Time function type (1=Ricker, 2=First derivative, 3=Gaussian, 4=Dirac, 5=Heaviside): ',time_function_type
- print *,'Angle of the source if force = ',angleforce
- print *,'Mxx of the source if moment tensor = ',Mxx
- print *,'Mzz of the source if moment tensor = ',Mzz
- print *,'Mxz of the source if moment tensor = ',Mxz
- print *,'Multiplying factor = ',factor
-
-! read receiver line parameters
- call read_value_integer(IIN,IGNORE_JUNK,seismotype)
- call read_value_integer(IIN,IGNORE_JUNK,nreceiverlines)
- call read_value_double_precision(IIN,IGNORE_JUNK,anglerec)
-
- if(nreceiverlines < 1) stop 'number of receiver lines must be greater than 1'
-
-! allocate receiver line arrays
- allocate(nrec(nreceiverlines))
- allocate(xdeb(nreceiverlines))
- allocate(zdeb(nreceiverlines))
- allocate(xfin(nreceiverlines))
- allocate(zfin(nreceiverlines))
- allocate(enreg_surf(nreceiverlines))
-
-! loop on all the receiver lines
- do ireceiverlines = 1,nreceiverlines
- call read_value_integer(IIN,IGNORE_JUNK,nrec(ireceiverlines))
- call read_value_double_precision(IIN,IGNORE_JUNK,xdeb(ireceiverlines))
- call read_value_double_precision(IIN,IGNORE_JUNK,zdeb(ireceiverlines))
- call read_value_double_precision(IIN,IGNORE_JUNK,xfin(ireceiverlines))
- call read_value_double_precision(IIN,IGNORE_JUNK,zfin(ireceiverlines))
- call read_value_logical(IIN,IGNORE_JUNK,enreg_surf(ireceiverlines))
- enddo
-
-! read display parameters
- call read_value_integer(IIN,IGNORE_JUNK,NTSTEP_BETWEEN_OUTPUT_INFO)
- call read_value_logical(IIN,IGNORE_JUNK,output_postscript_snapshot)
- call read_value_logical(IIN,IGNORE_JUNK,output_color_image)
- call read_value_integer(IIN,IGNORE_JUNK,imagetype)
- call read_value_double_precision(IIN,IGNORE_JUNK,cutsnaps)
- call read_value_logical(IIN,IGNORE_JUNK,meshvect)
- call read_value_logical(IIN,IGNORE_JUNK,modelvect)
- call read_value_logical(IIN,IGNORE_JUNK,boundvect)
- call read_value_logical(IIN,IGNORE_JUNK,interpol)
- call read_value_integer(IIN,IGNORE_JUNK,pointsdisp)
- call read_value_integer(IIN,IGNORE_JUNK,subsamp)
- call read_value_double_precision(IIN,IGNORE_JUNK,sizemax_arrows)
- call read_value_logical(IIN,IGNORE_JUNK,gnuplot)
- call read_value_logical(IIN,IGNORE_JUNK,outputgrid)
-
-! can use only one point to display lower-left corner only for interpolated snapshot
- if(pointsdisp < 3) then
- pointsdisp = 3
- plot_lowerleft_corner_only = .true.
- else
- plot_lowerleft_corner_only = .false.
- endif
-
-! read the different material materials
- call read_value_integer(IIN,IGNORE_JUNK,nb_materials)
- if(nb_materials <= 0) stop 'Negative number of materials not allowed!'
-
- allocate(icodemat(nb_materials))
- allocate(rho(nb_materials))
- allocate(cp(nb_materials))
- allocate(cs(nb_materials))
- allocate(aniso3(nb_materials))
- allocate(aniso4(nb_materials))
- allocate(num_material(nx,nz))
-
- icodemat(:) = 0
- rho(:) = 0.d0
- cp(:) = 0.d0
- cs(:) = 0.d0
- aniso3(:) = 0.d0
- aniso4(:) = 0.d0
- num_material(:,:) = 0
-
- do imaterial=1,nb_materials
- call read_material_parameters(IIN,DONT_IGNORE_JUNK,i,icodematread,rhoread,cpread,csread,aniso3read,aniso4read)
- if(i < 1 .or. i > nb_materials) stop 'Wrong material 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'
-
- aniso3(i) = aniso3read
- aniso4(i) = aniso4read
- enddo
-
- print *
- print *, 'Nb of solid or fluid materials = ',nb_materials
- print *
- do i=1,nb_materials
- if(icodemat(i) /= ANISOTROPIC_MATERIAL) then
- print *,'Material #',i,' isotropic'
- print *,'rho,cp,cs = ',rho(i),cp(i),cs(i)
- if(cs(i) < TINYVAL) then
- print *,'Material is fluid'
- else
- print *,'Material is solid'
- endif
- else
- print *,'Material #',i,' anisotropic'
- print *,'rho,c11,c13,c33,c44 = ',rho(i),cp(i),cs(i),aniso3(i),aniso4(i)
- endif
- print *
- enddo
-
-! read the material numbers for each region
- call read_value_integer(IIN,IGNORE_JUNK,nbregion)
-
- if(nbregion <= 0) stop 'Negative number of regions not allowed!'
-
- print *
- print *, 'Nb of regions in the mesh = ',nbregion
- print *
-
- do iregion = 1,nbregion
-
- call read_region_coordinates(IIN,DONT_IGNORE_JUNK,ixdebregion,ixfinregion,izdebregion,izfinregion,imaterial_number)
-
- if(imaterial_number < 1) stop 'Negative material number not allowed!'
- if(ixdebregion < 1) stop 'Left coordinate of region negative!'
- if(ixfinregion > nxread) stop 'Right coordinate of region too high!'
- if(izdebregion < 1) stop 'Bottom coordinate of region negative!'
- if(izfinregion > nzread) stop 'Top coordinate of region too high!'
-
- print *,'Region ',iregion
- print *,'IX from ',ixdebregion,' to ',ixfinregion
- print *,'IZ from ',izdebregion,' to ',izfinregion
-
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL) then
- vpregion = cp(imaterial_number)
- vsregion = cs(imaterial_number)
- print *,'Material # ',imaterial_number,' isotropic'
- if(vsregion < TINYVAL) then
- print *,'Material is fluid'
- else
- print *,'Material is solid'
- endif
- print *,'vp = ',vpregion
- print *,'vs = ',vsregion
- print *,'rho = ',rho(imaterial_number)
- poisson_ratio = 0.5d0*(vpregion*vpregion-2.d0*vsregion*vsregion) / (vpregion*vpregion-vsregion*vsregion)
- print *,'Poisson''s ratio = ',poisson_ratio
- if(poisson_ratio <= -1.00001d0 .or. poisson_ratio >= 0.50001d0) stop 'incorrect value of Poisson''s ratio'
- else
- print *,'Material # ',imaterial_number,' anisotropic'
- print *,'c11 = ',cp(imaterial_number)
- print *,'c13 = ',cs(imaterial_number)
- print *,'c33 = ',aniso3(imaterial_number)
- print *,'c44 = ',aniso4(imaterial_number)
- print *,'rho = ',rho(imaterial_number)
- endif
- print *,' -----'
-
-! store density and velocity model
- do i = ixdebregion,ixfinregion
- do j = izdebregion,izfinregion
- if(ngnod == 4) then
- num_material(i,j) = imaterial_number
- else
- num_material(2*(i-1)+1,2*(j-1)+1) = imaterial_number
- num_material(2*(i-1)+1,2*(j-1)+2) = imaterial_number
- num_material(2*(i-1)+2,2*(j-1)+1) = imaterial_number
- num_material(2*(i-1)+2,2*(j-1)+2) = imaterial_number
- endif
- enddo
- enddo
-
- enddo
-
- if(minval(num_material) <= 0) stop 'Velocity model not entirely set...'
-
- close(IIN)
-
- print *
- print *,'Parameter file successfully read... '
-
-!---
-
- if(ngnod /= 4 .and. ngnod /= 9) stop 'ngnod different from 4 or 9!'
-
- print *
- if(ngnod == 4) then
- print *,'The mesh contains ',nx,' x ',nz,' elements'
- else
- print *,'The mesh contains ',nx/2,' x ',nz/2,' elements'
- endif
- print *
- print *,'Control elements have ',ngnod,' nodes'
- print *
-
-!---
-
-! 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=IIN_INTERFACES,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
- call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK, &
- xinterface_bottom(ipoint_current),zinterface_bottom(ipoint_current))
- enddo
-
-! loop on all the layers
- 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
- call read_two_interface_points(IIN_INTERFACES,DONT_IGNORE_JUNK, &
- xinterface_top(ipoint_current),zinterface_top(ipoint_current))
- enddo
-
-! compute the spline for the bottom interface, impose the tangent on both edges
- tang1 = (zinterface_bottom(2)-zinterface_bottom(1)) / (xinterface_bottom(2)-xinterface_bottom(1))
- tangN = (zinterface_bottom(npoints_interface_bottom)-zinterface_bottom(npoints_interface_bottom-1)) / &
- (xinterface_bottom(npoints_interface_bottom)-xinterface_bottom(npoints_interface_bottom-1))
- call spline(xinterface_bottom,zinterface_bottom,npoints_interface_bottom,tang1,tangN,coefs_interface_bottom)
-
-! compute the spline for the top interface, impose the tangent on both edges
- tang1 = (zinterface_top(2)-zinterface_top(1)) / (xinterface_top(2)-xinterface_top(1))
- tangN = (zinterface_top(npoints_interface_top)-zinterface_top(npoints_interface_top-1)) / &
- (xinterface_top(npoints_interface_top)-xinterface_top(npoints_interface_top-1))
- call spline(xinterface_top,zinterface_top,npoints_interface_top,tang1,tangN,coefs_interface_top)
-
-! check if we are in the last layer, which contains topography,
-! and modify the position of the source accordingly if it is located exactly at the surface
- if(source_surf .and. ilayer == number_of_layers) &
- zs = value_spline(xs,xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
-
-! compute the offset of this layer in terms of number of spectral elements below along Z
- if(ilayer > 1) then
- ioffset = sum(nz_layer(1:ilayer-1))
- else
- ioffset = 0
- endif
-
-!--- definition of the mesh
-
- do ix = 0,nx
-
-! evenly spaced points along 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
-
-! the top interface becomes the bottom interface before switching to the next layer
- npoints_interface_bottom = npoints_interface_top
- xinterface_bottom(:) = xinterface_top(:)
- zinterface_bottom(:) = zinterface_top(:)
-
- enddo
-
- close(IIN_INTERFACES)
-
-! compute min and max of X and Z in the grid
- print *
- print *,'Min and max value of X in the grid = ',minval(x),maxval(x)
- print *,'Min and max value of Z in the grid = ',minval(z),maxval(z)
- print *
-
-! ***
-! *** create a Gnuplot file that displays the grid
-! ***
-
- print *
- print *,'Saving the grid in Gnuplot format...'
-
- open(unit=20,file='OUTPUT_FILES/gridfile.gnu',status='unknown')
-
-! draw horizontal lines of the grid
- print *,'drawing horizontal lines of the grid'
- 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,*) sngl(x(icol,ili)),sngl(z(icol,ili))
- write(20,*) sngl(x(icol+istepx,ili)),sngl(z(icol+istepx,ili))
- write(20,10)
- enddo
- enddo
-
-! draw vertical lines of the grid
- print *,'drawing vertical lines of the grid'
- 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,*) sngl(x(icol,ili)),sngl(z(icol,ili))
- write(20,*) sngl(x(icol,ili+istepz)),sngl(z(icol,ili+istepz))
- write(20,10)
- enddo
- enddo
-
- 10 format('')
-
- close(20)
-
-! create a Gnuplot script to display the grid
- open(unit=20,file='OUTPUT_FILES/plotgnu',status='unknown')
- write(20,*) '#set term X11'
- write(20,*) 'set term postscript landscape monochrome solid "Helvetica" 22'
- write(20,*) 'set output "grid.ps"'
- write(20,*) '#set xrange [',sngl(minval(x)),':',sngl(maxval(x)),']'
- write(20,*) '#set yrange [',sngl(minval(z)),':',sngl(maxval(z)),']'
-! use same unit length on both X and Y axes
- write(20,*) 'set size ratio -1'
- write(20,*) 'plot "gridfile.gnu" title "Macrobloc mesh" w l'
- write(20,*) 'pause -1 "Hit any key..."'
- close(20)
-
- print *,'Grid saved in Gnuplot format...'
- print *
-
-! *** generate the database for the solver
-
- open(unit=15,file='OUTPUT_FILES/Database',status='unknown')
-
- write(15,*) '#'
- write(15,*) '# Database for SPECFEM2D'
- write(15,*) '# Dimitri Komatitsch, (c) University of Pau, France'
- write(15,*) '#'
-
- write(15,*) 'Title of the simulation'
- write(15,"(a50)") 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,*) 'NTSTEP_BETWEEN_OUTPUT_INFO'
- write(15,*) NTSTEP_BETWEEN_OUTPUT_INFO
-
- write(15,*) 'output_postscript_snapshot output_color_image colors numbers'
- write(15,*) output_postscript_snapshot,output_color_image,' 1 0'
-
- write(15,*) 'meshvect modelvect boundvect cutsnaps subsamp sizemax_arrows'
- write(15,*) meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows
-
- write(15,*) 'anglerec'
- write(15,*) anglerec
-
- write(15,*) 'initialfield'
- write(15,*) initialfield
-
- write(15,*) 'seismotype imagetype'
- write(15,*) seismotype,imagetype
-
- write(15,*) 'assign_external_model outputgrid TURN_ANISOTROPY_ON TURN_ATTENUATION_ON'
- write(15,*) assign_external_model,outputgrid,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
-
- write(15,*) 'nt deltat'
- write(15,*) nt,deltat
-
- write(15,*) 'source'
- write(15,*) source_type,time_function_type,xs,zs,f0,t0,factor,angleforce,Mxx,Mzz,Mxz
-
- write(15,*) 'Coordinates of macrobloc mesh (coorg):'
- do j=0,nz
- do i=0,nx
- write(15,*) num(i,j,nx),x(i,j),z(i,j)
- enddo
- enddo
-
-!
-!--- definition of absorbing boundaries
-!
- nelemabs = 0
- if(absbottom) nelemabs = nelemabs + nx
- if(abstop) nelemabs = nelemabs + nx
- if(absleft) nelemabs = nelemabs + nz
- if(absright) nelemabs = nelemabs + nz
-
-! we have counted the elements twice if they have nine nodes
- if(ngnod == 9) nelemabs = nelemabs / 2
-
-! also remove the corner elements, which have been counted twice
- if(absbottom .and. absleft) nelemabs = nelemabs - 1
- if(absbottom .and. absright) nelemabs = nelemabs - 1
- if(abstop .and. absleft) nelemabs = nelemabs - 1
- if(abstop .and. absright) nelemabs = nelemabs - 1
-
-! count the number of acoustic free-surface elements
- nelem_acoustic_surface = 0
- do j = 1,nzread
- do i = 1,nxread
- if(ngnod == 4) then
- imaterial_number = num_material(i,j)
- else
- imaterial_number = num_material(2*(i-1)+1,2*(j-1)+1)
- endif
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. cs(imaterial_number) < TINYVAL &
- .and. j == nzread) nelem_acoustic_surface = nelem_acoustic_surface + 1
- enddo
- enddo
-
- write(15,*) 'numat ngnod nspec pointsdisp plot_lowerleft_corner_only'
- write(15,*) nb_materials,ngnod,nspec,pointsdisp,plot_lowerleft_corner_only
- write(15,*) 'nelemabs nelem_acoustic_surface'
- write(15,*) nelemabs,nelem_acoustic_surface
-
- write(15,*) 'Material sets (num 1 rho vp vs 0 0) or (num 2 rho c11 c13 c33 c44)'
- do i=1,nb_materials
- write(15,*) i,icodemat(i),rho(i),cp(i),cs(i),aniso3(i),aniso4(i)
- enddo
-
-
- write(15,*) 'Arrays kmato and knods for each bloc:'
-
- k = 0
- if(ngnod == 4) then
- do j=0,nz-1
- do i=0,nx-1
- k = k + 1
- imaterial_number = num_material(i+1,j+1)
- write(15,*) k,imaterial_number,num(i,j,nx),num(i+1,j,nx),num(i+1,j+1,nx),num(i,j+1,nx)
- enddo
- enddo
- else
- do j=0,nz-2,2
- do i=0,nx-2,2
- k = k + 1
- imaterial_number = num_material(i+1,j+1)
- write(15,*) k,imaterial_number,num(i,j,nx),num(i+2,j,nx),num(i+2,j+2,nx),num(i,j+2,nx), &
- num(i+1,j,nx),num(i+2,j+1,nx),num(i+1,j+2,nx),num(i,j+1,nx),num(i+1,j+1,nx)
- enddo
- enddo
- endif
-
-!
-!--- save absorbing boundaries
-!
- print *
- print *,'There is a total of ',nelemabs,' absorbing elements'
- print *
- print *,'Active absorbing boundaries:'
- print *
- print *,'Bottom = ',absbottom
- print *,'Right = ',absright
- print *,'Top = ',abstop
- print *,'Left = ',absleft
- print *
-
-! generate the list of absorbing elements
- if(nelemabs > 0) then
- write(15,*) 'List of absorbing elements (bottom right top left):'
- do iz = 1,nzread
- do ix = 1,nxread
- codebottom = .false.
- coderight = .false.
- codetop = .false.
- codeleft = .false.
- inumelem = (iz-1)*nxread + ix
- if(absbottom .and. iz == 1) codebottom = .true.
- if(absright .and. ix == nxread) coderight = .true.
- if(abstop .and. iz == nzread) codetop = .true.
- if(absleft .and. ix == 1) codeleft = .true.
- if(codebottom .or. coderight .or. codetop .or. codeleft) write(15,*) inumelem,codebottom,coderight,codetop,codeleft
- enddo
- enddo
- endif
-
-!
-!--- save acoustic free-surface elements
-!
- print *
- print *,'There is a total of ',nelem_acoustic_surface,' acoustic free-surface elements'
- print *
-
-! generate the list of acoustic free-surface elements
- if(nelem_acoustic_surface > 0) then
- write(15,*) 'List of acoustic free-surface elements:'
- do j = 1,nzread
- do i = 1,nxread
- inumelem = (j-1)*nxread + i
- if(ngnod == 4) then
- imaterial_number = num_material(i,j)
- else
- imaterial_number = num_material(2*(i-1)+1,2*(j-1)+1)
- endif
-! in this simple mesher, it is always the top edge that is at the free surface
- if(icodemat(imaterial_number) /= ANISOTROPIC_MATERIAL .and. cs(imaterial_number) < TINYVAL .and. j == nzread) &
- write(15,*) inumelem,ITOP
- enddo
- enddo
- endif
-
- close(15)
-
-! print position of the source
- print *
- print *,'Position (x,z) of the source = ',xs,zs
- print *
-
-!--- compute position of the receivers and write the STATIONS file
-
- print *
- print *,'writing the DATA/STATIONS file'
- print *
-
-! total number of receivers in all the receiver lines
- nrec_total = sum(nrec)
-
- print *
- print *,'There are ',nrec_total,' receivers'
-
- print *
- print *,'Position (x,z) of the ',nrec_total,' receivers'
- print *
-
- open(unit=15,file='DATA/STATIONS',status='unknown')
- write(15,*) nrec_total
-
- irec_global_number = 0
-
-! loop on all the receiver lines
- do ireceiverlines = 1,nreceiverlines
-
-! loop on all the receivers of this receiver line
- do irec = 1,nrec(ireceiverlines)
-
-! compute global receiver number
- irec_global_number = irec_global_number + 1
-
-! compute coordinates of the receiver
- if(nrec(ireceiverlines) > 1) then
- xrec = xdeb(ireceiverlines) + dble(irec-1)*(xfin(ireceiverlines)-xdeb(ireceiverlines))/dble(nrec(ireceiverlines)-1)
- zrec = zdeb(ireceiverlines) + dble(irec-1)*(zfin(ireceiverlines)-zdeb(ireceiverlines))/dble(nrec(ireceiverlines)-1)
- else
- xrec = xdeb(ireceiverlines)
- zrec = zdeb(ireceiverlines)
- endif
-
-! modify position of receiver if we must record exactly at the surface
- if(enreg_surf(ireceiverlines)) &
- zrec = value_spline(xrec,xinterface_top,zinterface_top,coefs_interface_top,npoints_interface_top)
-
-! display position of the receiver
- print *,'Receiver ',irec_global_number,' = ',xrec,zrec
-
- write(15,"('S',i4.4,' AA ',f20.7,1x,f20.7,' 0.0 0.0')") irec_global_number,xrec,zrec
-
- enddo
- enddo
-
- close(15)
-
- print *
-
- end program meshfem2D
-
-! *******************
-! meshing subroutines
-! *******************
-
-!--- global node number
-
- integer function num(i,j,nx)
-
- implicit none
-
- integer i,j,nx
-
- num = j*(nx+1) + i + 1
-
- end function num
-
-!--- spline to describe the interfaces
-
- 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
-
-! assign the value on the edge if point is outside the model
- if(xp < xinterface(1)) xp = xinterface(1)
- if(xp > xinterface(npoints_interface)) xp = xinterface(npoints_interface)
-
- call splint(xinterface,zinterface,coefs_interface,npoints_interface,xp,value_spline)
-
- end function value_spline
-
-! --------------------------------------
-
-! compute spline coefficients (Numerical Recipes)
-! modified to use dynamic allocation
-
- 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
-
-! --------------
-
-! evaluate 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
-
Added: seismo/2D/SPECFEM2D/trunk/specfem2D.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/specfem2D.F90 2007-06-26 00:32:15 UTC (rev 8521)
+++ seismo/2D/SPECFEM2D/trunk/specfem2D.F90 2007-12-07 23:53:16 UTC (rev 8522)
@@ -0,0 +1,1944 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 5.2
+! ------------------------------
+!
+! Dimitri Komatitsch
+! University of Pau, France
+!
+! (c) April 2007
+!
+!========================================================================
+
+!====================================================================================
+!
+! An explicit 2D spectral element solver for the anelastic anisotropic wave equation
+!
+!====================================================================================
+
+! If you use this code for your own research, please cite:
+!
+! @ARTICLE{KoTr99,
+! author={D. Komatitsch and J. Tromp},
+! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
+! journal={Geophys. J. Int.},
+! year=1999,
+! volume=139,
+! number=3,
+! pages={806-822},
+! doi={10.1046/j.1365-246x.1999.00967.x}}
+!
+! @ARTICLE{KoVi98,
+! author={D. Komatitsch and J. P. Vilotte},
+! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
+! journal={Bull. Seismol. Soc. Am.},
+! year=1998,
+! volume=88,
+! number=2,
+! pages={368-392}}
+
+!
+! version 5.2, Dimitri Komatitsch, April 2007:
+! - general fluid/solid implementation with any number, shape and orientation of
+! matching edges
+! - absorbing edges with any normal vector
+! - general numbering of absorbing and acoustic free surface edges
+! - cleaned implementation of attenuation as in Carcione (1993)
+! - merged loops in the solver for efficiency
+! - simplified input of external model
+! - added CPU time information
+! - translated many comments from French to English
+!
+! version 5.1, Dimitri Komatitsch, January 2005:
+! - more general mesher with any number of curved layers
+! - Dirac and Gaussian time sources and corresponding convolution routine
+! - option for acoustic medium instead of elastic
+! - receivers at any location, not only grid points
+! - moment-tensor source at any location, not only a grid point
+! - color snapshots
+! - more flexible DATA/Par_file with any number of comment lines
+! - Xsu scripts for seismograms
+! - subtract t0 from seismograms
+! - seismograms and snapshots in pressure in addition to vector field
+!
+! version 5.0, Dimitri Komatitsch, May 2004:
+! - got rid of useless routines, suppressed commons etc.
+! - weak formulation based explicitly on stress tensor
+! - implementation of full anisotropy
+! - 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
+!
+
+! in case of an acoustic medium, a displacement potential Chi is used as in Chaljub and Valette,
+! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
+! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
+! This permits acoustic-elastic coupling based on a non-iterative time scheme.
+! Displacement is then: u = grad(Chi)
+! Velocity is then: v = grad(Chi_dot) (Chi_dot being the time derivative of Chi)
+! and pressure is: p = - rho * Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
+! The source in an acoustic element is a pressure source.
+
+ program specfem2D
+
+ implicit none
+
+ include "constants.h"
+
+ character(len=80) datlin
+
+ integer :: source_type,time_function_type
+ double precision :: x_source,z_source,xi_source,gamma_source,Mxx,Mzz,Mxz,f0,t0,factor,angleforce,hdur,hdur_gauss
+ double precision, dimension(NDIM,NGLLX,NGLLZ) :: sourcearray
+
+ 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
+
+! for seismograms
+ double precision, dimension(:,:), allocatable :: sisux,sisuz
+! vector field in an element
+ double precision, dimension(NDIM,NGLLX,NGLLX) :: vector_field_element
+! pressure in an element
+ double precision, dimension(NGLLX,NGLLX) :: pressure_element
+
+! to write seismograms in single precision SEP and double precision binary format
+ real(kind=4), dimension(:), allocatable :: buffer_binary_single
+ double precision, dimension(:), allocatable :: buffer_binary_double
+
+ integer :: i,j,k,it,irec,ipoin,ip,id,nbpoin,inump,n,ispec,iedge,npoin,npgeo,iglob
+ logical :: anyabs
+ double precision :: dxd,dzd,valux,valuz,hlagrange,rhol,cosrot,sinrot,xi,gamma,x,z
+
+! 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
+
+! derivatives of Lagrange polynomials
+ double precision, dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ double precision, dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+
+! Jacobian matrix and determinant
+ double precision :: xixl,xizl,gammaxl,gammazl,jacobianl
+
+! material properties of the elastic medium
+ double precision :: mul_relaxed,lambdal_relaxed,cpsquare
+
+ double precision, dimension(:,:), allocatable :: coord,accel_elastic,veloc_elastic,displ_elastic, &
+ flagrange,xinterp,zinterp,Uxinterp,Uzinterp,elastcoef,vector_field_display
+
+! for acoustic medium
+ double precision, dimension(:), allocatable :: potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
+
+ double precision, dimension(:), allocatable :: rmass_inverse_elastic,rmass_inverse_acoustic,density,displread,velocread,accelread
+
+ double precision, dimension(:,:,:), allocatable :: vpext,vsext,rhoext
+ double precision :: previous_vsext
+
+ double precision, dimension(:,:,:), allocatable :: shape2D,shape2D_display,xix,xiz,gammax,gammaz,jacobian
+
+ double precision, dimension(:,:,:,:), allocatable :: dershape2D,dershape2D_display
+
+ integer, dimension(:,:,:), allocatable :: ibool
+ integer, dimension(:,:), allocatable :: knods
+ integer, dimension(:), allocatable :: kmato,numabs,ispecnum_acoustic_surface,iedgenum_acoustic_surface, &
+ ibegin_bottom,iend_bottom,ibegin_top,iend_top,jbegin_left,jend_left,jbegin_right,jend_right
+
+ integer ispec_selected_source,iglob_source,ix_source,iz_source
+ double precision a,displnorm_all
+ double precision, dimension(:), allocatable :: source_time_function
+ double precision, external :: erf
+
+ double precision :: vpmin,vpmax
+
+ integer :: colors,numbers,subsamp,imagetype,NTSTEP_BETWEEN_OUTPUT_INFO,nrec,seismotype
+ integer :: numat,ngnod,nspec,pointsdisp,nelemabs,nelem_acoustic_surface,ispecabs
+
+ logical interpol,meshvect,modelvect,boundvect,assign_external_model,initialfield, &
+ outputgrid,gnuplot,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON,output_postscript_snapshot,output_color_image, &
+ plot_lowerleft_corner_only
+
+ double precision :: cutsnaps,sizemax_arrows,anglerec,xirec,gammarec
+
+! for absorbing and acoustic free surface conditions
+ integer :: ispec_acoustic_surface,inum,numabsread,numacoustread,iedgeacoustread
+ logical :: codeabsread(4)
+ double precision :: nx,nz,weight,xxi,zgamma
+
+ logical, dimension(:,:), allocatable :: codeabs
+
+! for attenuation
+ integer nspec_allocate
+ double precision :: deltatsquare,deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
+
+ double precision, dimension(:,:,:), allocatable :: &
+ e1_mech1,e11_mech1,e13_mech1,e1_mech2,e11_mech2,e13_mech2, &
+ dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
+
+! for fluid/solid coupling and edge detection
+ logical, dimension(:), allocatable :: elastic
+ integer, dimension(NEDGES) :: i_begin,j_begin,i_end,j_end
+ integer, dimension(NGLLX,NEDGES) :: ivalue,jvalue,ivalue_inverse,jvalue_inverse
+ integer, dimension(:), allocatable :: fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge, &
+ fluid_solid_elastic_ispec,fluid_solid_elastic_iedge
+ integer :: num_fluid_solid_edges,num_fluid_solid_edges_alloc,ispec_acoustic,ispec_elastic, &
+ iedge_acoustic,iedge_elastic,ipoin1D,iglob2
+ logical :: any_acoustic,any_elastic,coupled_acoustic_elastic
+ double precision :: displ_x,displ_z,displ_n,zxi,xgamma,jacobian1D,pressure
+
+! for color images
+ integer :: NX_IMAGE_color,NZ_IMAGE_color,iplus1,jplus1,iminus1,jminus1,count_passes
+ double precision :: xmin_color_image,xmax_color_image, &
+ zmin_color_image,zmax_color_image,size_pixel_horizontal,size_pixel_vertical
+ integer, dimension(:,:), allocatable :: iglob_image_color,copy_iglob_image_color
+ double precision, dimension(:,:), allocatable :: image_color_data
+
+! timing information for the stations
+ character(len=MAX_LENGTH_STATION_NAME), allocatable, dimension(:) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), allocatable, dimension(:) :: network_name
+
+! title of the plot
+ character(len=60) simulation_title
+
+! 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
+
+! timer to count elapsed time
+ character(len=8) datein
+ character(len=10) timein
+ character(len=5) :: zone
+ integer, dimension(8) :: time_values
+ integer ihours,iminutes,iseconds,int_tCPU
+ double precision :: time_start,time_end,tCPU
+
+!***********************************************************************
+!
+! i n i t i a l i z a t i o n p h a s e
+!
+!***********************************************************************
+
+ open(IIN,file='OUTPUT_FILES/Database',status='old',action='read')
+
+! determine if we write to file instead of standard output
+ if(IOUT /= ISTANDARD_OUTPUT) open(IOUT,file='simulation_results.txt',status='unknown')
+
+!
+!--- read job title and skip remaining titles of the input file
+!
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a80)") datlin
+ read(IIN,"(a50)") simulation_title
+
+!
+!---- print the date, time and start-up banner
+!
+ call datim(simulation_title)
+
+ write(IOUT,*)
+ write(IOUT,*)
+ write(IOUT,*) '*********************'
+ write(IOUT,*) '**** ****'
+ write(IOUT,*) '**** SPECFEM2D ****'
+ write(IOUT,*) '**** ****'
+ write(IOUT,*) '*********************'
+
+!
+!---- read parameters from input file
+!
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) npgeo
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) gnuplot,interpol
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) NTSTEP_BETWEEN_OUTPUT_INFO
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) output_postscript_snapshot,output_color_image,colors,numbers
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows
+ cutsnaps = cutsnaps / 100.d0
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) anglerec
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) initialfield
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) seismotype,imagetype
+ if(seismotype < 1 .or. seismotype > 4) stop 'Wrong type for seismogram output'
+ if(imagetype < 1 .or. imagetype > 4) stop 'Wrong type for snapshots'
+
+ read(IIN,"(a80)") datlin
+ read(IIN,*) assign_external_model,outputgrid,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
+
+!---- check parameters read
+ write(IOUT,200) npgeo,NDIM
+ write(IOUT,600) NTSTEP_BETWEEN_OUTPUT_INFO,colors,numbers
+ write(IOUT,700) seismotype,anglerec
+ write(IOUT,750) initialfield,assign_external_model,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON,outputgrid
+ write(IOUT,800) imagetype,100.d0*cutsnaps,subsamp
+
+!---- read time step
+ read(IIN,"(a80)") datlin
+ read(IIN,*) NSTEP,deltat
+ write(IOUT,703) NSTEP,deltat,NSTEP*deltat
+
+!
+!---- read source information
+!
+ read(IIN,"(a80)") datlin
+ read(IIN,*) source_type,time_function_type,x_source,z_source,f0,t0,factor,angleforce,Mxx,Mzz,Mxz
+
+!
+!----- 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,Mxx,Mzz,Mxz
+ 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,"(a80)") 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,"(a80)") datlin
+ read(IIN,*) numat,ngnod,nspec,pointsdisp,plot_lowerleft_corner_only
+ read(IIN,"(a80)") datlin
+ read(IIN,*) nelemabs,nelem_acoustic_surface
+
+!
+!---- allocate arrays
+!
+ allocate(shape2D(ngnod,NGLLX,NGLLZ))
+ allocate(dershape2D(NDIM,ngnod,NGLLX,NGLLZ))
+ allocate(shape2D_display(ngnod,pointsdisp,pointsdisp))
+ allocate(dershape2D_display(NDIM,ngnod,pointsdisp,pointsdisp))
+ 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(flagrange(NGLLX,pointsdisp))
+ allocate(xinterp(pointsdisp,pointsdisp))
+ allocate(zinterp(pointsdisp,pointsdisp))
+ allocate(Uxinterp(pointsdisp,pointsdisp))
+ allocate(Uzinterp(pointsdisp,pointsdisp))
+ allocate(density(numat))
+ allocate(elastcoef(4,numat))
+ allocate(kmato(nspec))
+ allocate(knods(ngnod,nspec))
+ allocate(ibool(NGLLX,NGLLZ,nspec))
+ allocate(elastic(nspec))
+
+! --- 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(ibegin_bottom(nelemabs))
+ allocate(iend_bottom(nelemabs))
+ allocate(ibegin_top(nelemabs))
+ allocate(iend_top(nelemabs))
+
+ allocate(jbegin_left(nelemabs))
+ allocate(jend_left(nelemabs))
+ allocate(jbegin_right(nelemabs))
+ allocate(jend_right(nelemabs))
+
+! --- allocate array for free surface condition in acoustic medium
+ if(nelem_acoustic_surface <= 0) then
+ nelem_acoustic_surface = 0
+ allocate(ispecnum_acoustic_surface(1))
+ allocate(iedgenum_acoustic_surface(1))
+ else
+ allocate(ispecnum_acoustic_surface(nelem_acoustic_surface))
+ allocate(iedgenum_acoustic_surface(nelem_acoustic_surface))
+ endif
+
+!
+!---- print element group main parameters
+!
+ write(IOUT,107)
+ write(IOUT,207) nspec,ngnod,NGLLX,NGLLZ,NGLLX*NGLLZ,pointsdisp,numat,nelemabs
+
+! set up Gauss-Lobatto-Legendre derivation matrices
+ call define_derivation_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz,hprimewgll_xx,hprimewgll_zz)
+
+!
+!---- read the material properties
+!
+ call gmat01(density,elastcoef,numat)
+
+!
+!---- read spectral macrobloc data
+!
+ n = 0
+ read(IIN,"(a80)") datlin
+ do ispec = 1,nspec
+ read(IIN,*) n,kmato(n),(knods(k,n), k=1,ngnod)
+ enddo
+
+!
+!---- determine if each spectral element is elastic or acoustic
+!
+ any_acoustic = .false.
+ any_elastic = .false.
+ do ispec = 1,nspec
+ mul_relaxed = elastcoef(2,kmato(ispec))
+ if(mul_relaxed < TINYVAL) then
+ elastic(ispec) = .false.
+ any_acoustic = .true.
+ else
+ elastic(ispec) = .true.
+ any_elastic = .true.
+ endif
+ enddo
+
+ if(TURN_ATTENUATION_ON) then
+ nspec_allocate = nspec
+ else
+ nspec_allocate = 1
+ endif
+
+! allocate memory variables for attenuation
+ allocate(e1_mech1(NGLLX,NGLLZ,nspec_allocate))
+ allocate(e11_mech1(NGLLX,NGLLZ,nspec_allocate))
+ allocate(e13_mech1(NGLLX,NGLLZ,nspec_allocate))
+ allocate(e1_mech2(NGLLX,NGLLZ,nspec_allocate))
+ allocate(e11_mech2(NGLLX,NGLLZ,nspec_allocate))
+ allocate(e13_mech2(NGLLX,NGLLZ,nspec_allocate))
+ allocate(dux_dxl_n(NGLLX,NGLLZ,nspec_allocate))
+ allocate(duz_dzl_n(NGLLX,NGLLZ,nspec_allocate))
+ allocate(duz_dxl_n(NGLLX,NGLLZ,nspec_allocate))
+ allocate(dux_dzl_n(NGLLX,NGLLZ,nspec_allocate))
+ allocate(dux_dxl_np1(NGLLX,NGLLZ,nspec_allocate))
+ allocate(duz_dzl_np1(NGLLX,NGLLZ,nspec_allocate))
+ allocate(duz_dxl_np1(NGLLX,NGLLZ,nspec_allocate))
+ allocate(dux_dzl_np1(NGLLX,NGLLZ,nspec_allocate))
+
+!
+!---- read absorbing boundary data
+!
+ if(anyabs) then
+ read(IIN,"(a80)") datlin
+ do inum = 1,nelemabs
+ read(IIN,*) numabsread,codeabsread(1),codeabsread(2),codeabsread(3),codeabsread(4)
+ if(numabsread < 1 .or. numabsread > nspec) stop 'Wrong absorbing element number'
+ numabs(inum) = numabsread
+ codeabs(IBOTTOM,inum) = codeabsread(1)
+ codeabs(IRIGHT,inum) = codeabsread(2)
+ codeabs(ITOP,inum) = codeabsread(3)
+ codeabs(ILEFT,inum) = codeabsread(4)
+ enddo
+ write(IOUT,*)
+ write(IOUT,*) 'Number of absorbing elements: ',nelemabs
+ endif
+
+!
+!---- read acoustic free surface data
+!
+ if(nelem_acoustic_surface > 0) then
+ read(IIN,"(a80)") datlin
+ do inum = 1,nelem_acoustic_surface
+ read(IIN,*) numacoustread,iedgeacoustread
+ if(numacoustread < 1 .or. numacoustread > nspec) stop 'Wrong acoustic free surface element number'
+ if(iedgeacoustread < 1 .or. iedgeacoustread > NEDGES) stop 'Wrong acoustic free surface edge number'
+ ispecnum_acoustic_surface(inum) = numacoustread
+ iedgenum_acoustic_surface(inum) = iedgeacoustread
+ enddo
+ write(IOUT,*)
+ write(IOUT,*) 'Number of free surface elements: ',nelem_acoustic_surface
+ endif
+
+!
+!---- 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
+!
+
+! "slow and clean" or "quick and dirty" version
+ 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,pointsdisp
+ do i = 1,pointsdisp
+ xirec = 2.d0*dble(i-1)/dble(pointsdisp-1) - 1.d0
+ gammarec = 2.d0*dble(j-1)/dble(pointsdisp-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,pointsdisp
+ xirec = 2.d0*dble(i-1)/dble(pointsdisp-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))
+
+! to write seismograms in single precision SEP and double precision binary format
+ allocate(buffer_binary_single(NSTEP*nrec))
+ allocate(buffer_binary_double(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))
+
+! allocate other global arrays
+ allocate(coord(NDIM,npoin))
+
+! to display acoustic elements
+ allocate(vector_field_display(NDIM,npoin))
+
+ if(assign_external_model) then
+ allocate(vpext(NGLLX,NGLLZ,nspec))
+ allocate(vsext(NGLLX,NGLLZ,nspec))
+ allocate(rhoext(NGLLX,NGLLZ,nspec))
+ else
+ allocate(vpext(1,1,1))
+ allocate(vsext(1,1,1))
+ allocate(rhoext(1,1,1))
+ endif
+
+!
+!---- 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
+ write(IOUT,*)
+ write(IOUT,*) 'Saving the grid in a text file...'
+ write(IOUT,*)
+ open(unit=55,file='OUTPUT_FILES/grid_points_and_model.txt',status='unknown')
+ write(55,*) npoin
+ do n = 1,npoin
+ write(55,*) (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)
+
+!
+!---- assign external velocity and density model if needed
+!
+ if(assign_external_model) then
+ write(IOUT,*)
+ write(IOUT,*) 'Assigning external velocity and density model...'
+ write(IOUT,*)
+ if(TURN_ANISOTROPY_ON .or. TURN_ATTENUATION_ON) &
+ stop 'cannot have anisotropy nor attenuation if external model in current version'
+ any_acoustic = .false.
+ any_elastic = .false.
+ do ispec = 1,nspec
+ previous_vsext = -1.d0
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+ call define_external_model(coord(1,iglob),coord(2,iglob),kmato(ispec), &
+ rhoext(i,j,ispec),vpext(i,j,ispec),vsext(i,j,ispec))
+! stop if the same element is assigned both acoustic and elastic points in external model
+ if(.not. (i == 1 .and. j == 1) .and. &
+ ((vsext(i,j,ispec) >= TINYVAL .and. previous_vsext < TINYVAL) .or. &
+ (vsext(i,j,ispec) < TINYVAL .and. previous_vsext >= TINYVAL))) &
+ stop 'external velocity model cannot be both fluid and solid inside the same spectral element'
+ if(vsext(i,j,ispec) < TINYVAL) then
+ elastic(ispec) = .false.
+ any_acoustic = .true.
+ else
+ elastic(ispec) = .true.
+ any_elastic = .true.
+ endif
+ previous_vsext = vsext(i,j,ispec)
+ enddo
+ enddo
+ enddo
+ endif
+
+!
+!---- perform basic checks on parameters read
+!
+
+! for acoustic
+ if(TURN_ANISOTROPY_ON .and. .not. any_elastic) stop 'cannot have anisotropy if acoustic simulation only'
+
+ if(TURN_ATTENUATION_ON .and. .not. any_elastic) stop 'currently cannot have attenuation if acoustic simulation only'
+
+! for attenuation
+ if(TURN_ANISOTROPY_ON .and. TURN_ATTENUATION_ON) stop 'cannot have anisotropy and attenuation both turned on in current version'
+
+!
+!---- define coefficients of the Newmark time scheme
+!
+ deltatover2 = HALF*deltat
+ deltatsquareover2 = HALF*deltat*deltat
+
+!---- define actual location of source and receivers
+ if(source_type == 1) then
+! collocated force source
+ call locate_source_force(coord,ibool,npoin,nspec,x_source,z_source,source_type, &
+ ix_source,iz_source,ispec_selected_source,iglob_source)
+
+! check that acoustic source is not exactly on the free surface because pressure is zero there
+ do ispec_acoustic_surface = 1,nelem_acoustic_surface
+ ispec = ispecnum_acoustic_surface(ispec_acoustic_surface)
+ iedge = iedgenum_acoustic_surface(ispec_acoustic_surface)
+ if(.not. elastic(ispec) .and. ispec == ispec_selected_source) then
+ if((iedge == IBOTTOM .and. iz_source == 1) .or. &
+ (iedge == ITOP .and. iz_source == NGLLZ) .or. &
+ (iedge == ILEFT .and. ix_source == 1) .or. &
+ (iedge == IRIGHT .and. ix_source == NGLLX)) &
+ stop 'an acoustic source cannot be located exactly on the free surface because pressure is zero there'
+ endif
+ enddo
+
+ else if(source_type == 2) then
+! moment-tensor source
+ call locate_source_moment_tensor(ibool,coord,nspec,npoin,xigll,zigll,x_source,z_source, &
+ ispec_selected_source,xi_source,gamma_source,coorg,knods,ngnod,npgeo)
+
+! compute source array for moment-tensor source
+ call compute_arrays_source(ispec_selected_source,xi_source,gamma_source,sourcearray, &
+ Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,nspec)
+
+ else
+ stop 'incorrect source type'
+ endif
+
+
+! 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)
+
+! check if acoustic receiver is exactly on the free surface because pressure is zero there
+ do ispec_acoustic_surface = 1,nelem_acoustic_surface
+ ispec = ispecnum_acoustic_surface(ispec_acoustic_surface)
+ iedge = iedgenum_acoustic_surface(ispec_acoustic_surface)
+ do irec = 1,nrec
+ if(.not. elastic(ispec) .and. ispec == ispec_selected_rec(irec)) then
+ if((iedge == IBOTTOM .and. gamma_receiver(irec) < -0.99d0) .or. &
+ (iedge == ITOP .and. gamma_receiver(irec) > 0.99d0) .or. &
+ (iedge == ILEFT .and. xi_receiver(irec) < -0.99d0) .or. &
+ (iedge == IRIGHT .and. xi_receiver(irec) > 0.99d0)) then
+ if(seismotype == 4) then
+ stop 'an acoustic pressure receiver cannot be located exactly on the free surface because pressure is zero there'
+ else
+ print *, '**********************************************************************'
+ print *, '*** Warning: acoustic receiver located exactly on the free surface ***'
+ print *, '*** Warning: tangential component will be zero there ***'
+ print *, '**********************************************************************'
+ print *
+ endif
+ endif
+ endif
+ enddo
+ enddo
+
+! define and store Lagrange interpolators at all the receivers
+ do irec = 1,nrec
+ call lagrange_any(xi_receiver(irec),NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(gamma_receiver(irec),NGLLZ,zigll,hgammar,hpgammar)
+ hxir_store(irec,:) = hxir(:)
+ hgammar_store(irec,:) = hgammar(:)
+ enddo
+
+! displacement, velocity, acceleration and inverse of the mass matrix for elastic elements
+ if(any_elastic) then
+ allocate(displ_elastic(NDIM,npoin))
+ allocate(veloc_elastic(NDIM,npoin))
+ allocate(accel_elastic(NDIM,npoin))
+ allocate(rmass_inverse_elastic(npoin))
+ else
+! allocate unused arrays with fictitious size
+ allocate(displ_elastic(1,1))
+ allocate(veloc_elastic(1,1))
+ allocate(accel_elastic(1,1))
+ allocate(rmass_inverse_elastic(1))
+ endif
+
+! potential, its first and second derivative, and inverse of the mass matrix for acoustic elements
+ if(any_acoustic) then
+ allocate(potential_acoustic(npoin))
+ allocate(potential_dot_acoustic(npoin))
+ allocate(potential_dot_dot_acoustic(npoin))
+ allocate(rmass_inverse_acoustic(npoin))
+ else
+! allocate unused arrays with fictitious size
+ allocate(potential_acoustic(1))
+ allocate(potential_dot_acoustic(1))
+ allocate(potential_dot_dot_acoustic(1))
+ allocate(rmass_inverse_acoustic(1))
+ endif
+
+!
+!---- build the global mass matrix and invert it once and for all
+!
+ if(any_elastic) rmass_inverse_elastic(:) = ZERO
+ if(any_acoustic) rmass_inverse_acoustic(:) = ZERO
+ do ispec = 1,nspec
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+ iglob = ibool(i,j,ispec)
+! if external density model
+ if(assign_external_model) then
+ rhol = rhoext(i,j,ispec)
+ cpsquare = vpext(i,j,ispec)**2
+ else
+ rhol = density(kmato(ispec))
+ lambdal_relaxed = elastcoef(1,kmato(ispec))
+ mul_relaxed = elastcoef(2,kmato(ispec))
+ cpsquare = (lambdal_relaxed + 2.d0*mul_relaxed) / rhol
+ endif
+! for acoustic medium
+ if(elastic(ispec)) then
+ rmass_inverse_elastic(iglob) = rmass_inverse_elastic(iglob) + wxgll(i)*wzgll(j)*rhol*jacobian(i,j,ispec)
+ else
+ rmass_inverse_acoustic(iglob) = rmass_inverse_acoustic(iglob) + wxgll(i)*wzgll(j)*jacobian(i,j,ispec) / cpsquare
+ endif
+ enddo
+ enddo
+ enddo
+
+! fill mass matrix with fictitious non-zero values to make sure it can be inverted globally
+ if(any_elastic) where(rmass_inverse_elastic <= 0.d0) rmass_inverse_elastic = 1.d0
+ if(any_acoustic) where(rmass_inverse_acoustic <= 0.d0) rmass_inverse_acoustic = 1.d0
+
+! compute the inverse of the mass matrix
+ if(any_elastic) rmass_inverse_elastic(:) = 1 / rmass_inverse_elastic(:)
+ if(any_acoustic) rmass_inverse_acoustic(:) = 1 / rmass_inverse_acoustic(:)
+
+! check the mesh, stability and number of points per wavelength
+ call checkgrid(vpext,vsext,rhoext,density,elastcoef,ibool,kmato,coord,npoin,vpmin,vpmax, &
+ assign_external_model,nspec,numat,deltat,f0,t0,initialfield,time_function_type, &
+ coorg,xinterp,zinterp,shape2D_display,knods,simulation_title,npgeo,pointsdisp,ngnod,any_elastic)
+
+! convert receiver angle to radians
+ anglerec = anglerec * pi / 180.d0
+
+!
+!---- for color images
+!
+
+ if(output_color_image) then
+
+! horizontal size of the image
+ xmin_color_image = minval(coord(1,:))
+ xmax_color_image = maxval(coord(1,:))
+
+! vertical size of the image, slightly increase it to go beyond maximum topography
+ zmin_color_image = minval(coord(2,:))
+ zmax_color_image = maxval(coord(2,:))
+ zmax_color_image = zmin_color_image + 1.05d0 * (zmax_color_image - zmin_color_image)
+
+! compute number of pixels in the horizontal direction based on typical number
+! of spectral elements in a given direction (may give bad results for very elongated models)
+ NX_IMAGE_color = nint(sqrt(dble(npgeo))) * (NGLLX-1) + 1
+
+! compute number of pixels in the vertical direction based on ratio of sizes
+ NZ_IMAGE_color = nint(NX_IMAGE_color * (zmax_color_image - zmin_color_image) / (xmax_color_image - xmin_color_image))
+
+! convert pixel sizes to even numbers because easier to reduce size, create MPEG movies in postprocessing
+ NX_IMAGE_color = 2 * (NX_IMAGE_color / 2)
+ NZ_IMAGE_color = 2 * (NZ_IMAGE_color / 2)
+
+! allocate an array for image data
+ allocate(image_color_data(NX_IMAGE_color,NZ_IMAGE_color))
+
+! allocate an array for the grid point that corresponds to a given image data point
+ allocate(iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color))
+ allocate(copy_iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color))
+
+! create all the pixels
+ write(IOUT,*)
+ write(IOUT,*) 'locating all the pixels of color images'
+
+ size_pixel_horizontal = (xmax_color_image - xmin_color_image) / dble(NX_IMAGE_color-1)
+ size_pixel_vertical = (zmax_color_image - zmin_color_image) / dble(NZ_IMAGE_color-1)
+
+ iglob_image_color(:,:) = -1
+
+! loop on all the grid points to map them to a pixel in the image
+ do n=1,npoin
+
+! compute the coordinates of this pixel
+ i = nint((coord(1,n) - xmin_color_image) / size_pixel_horizontal + 1)
+ j = nint((coord(2,n) - zmin_color_image) / size_pixel_vertical + 1)
+
+! avoid edge effects
+ if(i < 1) i = 1
+ if(i > NX_IMAGE_color) i = NX_IMAGE_color
+
+ if(j < 1) j = 1
+ if(j > NZ_IMAGE_color) j = NZ_IMAGE_color
+
+! assign this point to this pixel
+ iglob_image_color(i,j) = n
+
+ enddo
+
+! locate missing pixels based on a minimum distance criterion
+! cannot do more than two iterations typically because some pixels must never be found
+! because they do not exist (for instance if they are located above topography)
+ do count_passes = 1,2
+
+ print *,'pass ',count_passes,' to locate the missing pixels of color images'
+
+ copy_iglob_image_color(:,:) = iglob_image_color(:,:)
+
+ do j = 1,NZ_IMAGE_color
+ do i = 1,NX_IMAGE_color
+
+ if(copy_iglob_image_color(i,j) == -1) then
+
+ iplus1 = i + 1
+ iminus1 = i - 1
+
+ jplus1 = j + 1
+ jminus1 = j - 1
+
+! avoid edge effects
+ if(iminus1 < 1) iminus1 = 1
+ if(iplus1 > NX_IMAGE_color) iplus1 = NX_IMAGE_color
+
+ if(jminus1 < 1) jminus1 = 1
+ if(jplus1 > NZ_IMAGE_color) jplus1 = NZ_IMAGE_color
+
+! use neighbors of this pixel to fill the holes
+
+! horizontal
+ if(copy_iglob_image_color(iplus1,j) /= -1) then
+ iglob_image_color(i,j) = copy_iglob_image_color(iplus1,j)
+
+ else if(copy_iglob_image_color(iminus1,j) /= -1) then
+ iglob_image_color(i,j) = copy_iglob_image_color(iminus1,j)
+
+! vertical
+ else if(copy_iglob_image_color(i,jplus1) /= -1) then
+ iglob_image_color(i,j) = copy_iglob_image_color(i,jplus1)
+
+ else if(copy_iglob_image_color(i,jminus1) /= -1) then
+ iglob_image_color(i,j) = copy_iglob_image_color(i,jminus1)
+
+! diagonal
+ else if(copy_iglob_image_color(iminus1,jminus1) /= -1) then
+ iglob_image_color(i,j) = copy_iglob_image_color(iminus1,jminus1)
+
+ else if(copy_iglob_image_color(iplus1,jminus1) /= -1) then
+ iglob_image_color(i,j) = copy_iglob_image_color(iplus1,jminus1)
+
+ else if(copy_iglob_image_color(iminus1,jplus1) /= -1) then
+ iglob_image_color(i,j) = copy_iglob_image_color(iminus1,jplus1)
+
+ else if(copy_iglob_image_color(iplus1,jplus1) /= -1) then
+ iglob_image_color(i,j) = copy_iglob_image_color(iplus1,jplus1)
+
+ endif
+
+ endif
+
+ enddo
+ enddo
+
+ enddo
+
+ deallocate(copy_iglob_image_color)
+
+ write(IOUT,*) 'done locating all the pixels of color images'
+
+ endif
+
+!
+!---- initialize seismograms
+!
+ sisux = ZERO
+ sisuz = ZERO
+
+ cosrot = cos(anglerec)
+ sinrot = sin(anglerec)
+
+! initialize arrays to zero
+ displ_elastic = ZERO
+ veloc_elastic = ZERO
+ accel_elastic = ZERO
+
+ potential_acoustic = ZERO
+ potential_dot_acoustic = ZERO
+ potential_dot_dot_acoustic = ZERO
+
+!
+!---- read initial fields from external file if needed
+!
+ if(initialfield) then
+ write(IOUT,*)
+ write(IOUT,*) 'Reading initial fields from external file...'
+ write(IOUT,*)
+ if(any_acoustic) stop 'initial field currently implemented for purely elastic simulation only'
+ open(unit=55,file='OUTPUT_FILES/wavefields.txt',status='unknown')
+ read(55,*) nbpoin
+ if(nbpoin /= npoin) stop 'Wrong number of points in input file'
+ 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_elastic(:,inump) = displread
+ veloc_elastic(:,inump) = velocread
+ accel_elastic(:,inump) = accelread
+ enddo
+ deallocate(displread)
+ deallocate(velocread)
+ deallocate(accelread)
+ close(55)
+ write(IOUT,*) 'Max norm of initial elastic displacement = ',maxval(sqrt(displ_elastic(1,:)**2 + displ_elastic(2,:)**2))
+ endif
+
+ 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))
+
+ write(IOUT,*)
+ write(IOUT,*) 'Saving the source time function in a text file...'
+ write(IOUT,*)
+ open(unit=55,file='OUTPUT_FILES/source.txt',status='unknown')
+
+! loop on all the time steps
+ 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)
+
+! Heaviside source time function (we use a very thin error function instead)
+ else if(time_function_type == 5) then
+ hdur = 1.d0 / f0
+ hdur_gauss = hdur * 5.d0 / 3.d0
+ source_time_function(it) = factor * 0.5d0*(1.0d0+erf(SOURCE_DECAY_RATE*(time-t0)/hdur_gauss))
+
+ else
+ stop 'unknown source time function'
+ endif
+
+! output absolute time in third column, in case user wants to check it as well
+ write(55,*) sngl(time),sngl(source_time_function(it)),sngl(time-t0)
+
+ enddo
+
+ close(55)
+
+ else
+
+ allocate(source_time_function(1))
+
+ endif
+
+!
+!---- check that no element has both acoustic free surface and top absorbing surface
+!
+ do ispec_acoustic_surface = 1,nelem_acoustic_surface
+ ispec = ispecnum_acoustic_surface(ispec_acoustic_surface)
+ iedge = iedgenum_acoustic_surface(ispec_acoustic_surface)
+ if(elastic(ispec)) then
+ stop 'elastic element detected in acoustic free surface'
+ else
+ do inum = 1,nelemabs
+ if(numabs(inum) == ispec .and. codeabs(iedge,inum)) &
+ stop 'acoustic free surface cannot be both absorbing and free'
+ enddo
+ endif
+ enddo
+
+! determine if coupled fluid-solid simulation
+ coupled_acoustic_elastic = any_acoustic .and. any_elastic
+
+! fluid/solid edge detection
+! very basic algorithm in O(nspec^2), simple double loop on the elements
+! and then loop on the four corners of each of the two elements, could be signficantly improved
+
+ num_fluid_solid_edges_alloc = 0
+
+ if(coupled_acoustic_elastic) then
+ print *
+ print *,'Mixed acoustic/elastic simulation'
+ print *
+ print *,'Beginning of fluid/solid edge detection (slow algorithm for now, will be improved later)'
+
+! define the edges of a given element
+ i_begin(IBOTTOM) = 1
+ j_begin(IBOTTOM) = 1
+ i_end(IBOTTOM) = NGLLX
+ j_end(IBOTTOM) = 1
+
+ i_begin(IRIGHT) = NGLLX
+ j_begin(IRIGHT) = 1
+ i_end(IRIGHT) = NGLLX
+ j_end(IRIGHT) = NGLLZ
+
+ i_begin(ITOP) = NGLLX
+ j_begin(ITOP) = NGLLZ
+ i_end(ITOP) = 1
+ j_end(ITOP) = NGLLZ
+
+ i_begin(ILEFT) = 1
+ j_begin(ILEFT) = NGLLZ
+ i_end(ILEFT) = 1
+ j_end(ILEFT) = 1
+
+! define i and j points for each edge
+ do ipoin1D = 1,NGLLX
+
+ ivalue(ipoin1D,IBOTTOM) = ipoin1D
+ ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
+ jvalue(ipoin1D,IBOTTOM) = 1
+ jvalue_inverse(ipoin1D,IBOTTOM) = 1
+
+ ivalue(ipoin1D,IRIGHT) = NGLLX
+ ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
+ jvalue(ipoin1D,IRIGHT) = ipoin1D
+ jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
+
+ ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
+ ivalue_inverse(ipoin1D,ITOP) = ipoin1D
+ jvalue(ipoin1D,ITOP) = NGLLZ
+ jvalue_inverse(ipoin1D,ITOP) = NGLLZ
+
+ ivalue(ipoin1D,ILEFT) = 1
+ ivalue_inverse(ipoin1D,ILEFT) = 1
+ jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
+ jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
+
+ enddo
+
+! double loop on all the elements
+ do ispec_acoustic = 1, nspec
+ do ispec_elastic = 1, nspec
+
+! one element must be acoustic and the other must be elastic
+! use acoustic element as master to avoid double detection of the same pair (one on each side)
+ if(ispec_acoustic /= ispec_elastic .and. .not. elastic(ispec_acoustic) .and. elastic(ispec_elastic)) then
+
+! loop on the four edges of the two elements
+ do iedge_acoustic = 1,NEDGES
+ do iedge_elastic = 1,NEDGES
+
+! error if the two edges match in direct order
+ if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic) .and. &
+ ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic)) &
+ stop 'topology error (non-inverted coupled elements) found in fluid/solid edge detection'
+
+! the two edges can match in inverse order
+ if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic) .and. &
+ ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic)) &
+ num_fluid_solid_edges_alloc = num_fluid_solid_edges_alloc + 1
+
+ enddo
+ enddo
+
+ endif
+
+ enddo
+ enddo
+
+ print *,'Number of fluid/solid edges detected in mesh = ',num_fluid_solid_edges_alloc
+
+! allocate arrays for fluid/solid matching
+ allocate(fluid_solid_acoustic_ispec(num_fluid_solid_edges_alloc))
+ allocate(fluid_solid_acoustic_iedge(num_fluid_solid_edges_alloc))
+ allocate(fluid_solid_elastic_ispec(num_fluid_solid_edges_alloc))
+ allocate(fluid_solid_elastic_iedge(num_fluid_solid_edges_alloc))
+
+! double loop on all the elements
+ print *,'Creating fluid/solid edge topology...'
+
+ num_fluid_solid_edges = 0
+
+ do ispec_acoustic = 1, nspec
+ do ispec_elastic = 1, nspec
+
+! one element must be acoustic and the other must be elastic
+! use acoustic element as master to avoid double detection of the same pair (one on each side)
+ if(ispec_acoustic /= ispec_elastic .and. .not. elastic(ispec_acoustic) .and. elastic(ispec_elastic)) then
+
+! loop on the four edges of the two elements
+ do iedge_acoustic = 1,NEDGES
+ do iedge_elastic = 1,NEDGES
+
+! store the matching topology if the two edges match in inverse order
+ if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic) .and. &
+ ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
+ ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic)) then
+ num_fluid_solid_edges = num_fluid_solid_edges + 1
+ fluid_solid_acoustic_ispec(num_fluid_solid_edges) = ispec_acoustic
+ fluid_solid_acoustic_iedge(num_fluid_solid_edges) = iedge_acoustic
+ fluid_solid_elastic_ispec(num_fluid_solid_edges) = ispec_elastic
+ fluid_solid_elastic_iedge(num_fluid_solid_edges) = iedge_elastic
+! print *,'edge ',iedge_acoustic,' of acoustic element ',ispec_acoustic, &
+! ' is in contact with edge ',iedge_elastic,' of elastic element ',ispec_elastic
+ endif
+
+ enddo
+ enddo
+
+ endif
+
+ enddo
+ enddo
+
+ if(num_fluid_solid_edges /= num_fluid_solid_edges_alloc) stop 'error in creation of arrays for fluid/solid matching'
+
+! make sure fluid/solid matching has been perfectly detected: check that the grid points
+! have the same physical coordinates
+! loop on all the coupling edges
+
+ print *,'Checking fluid/solid edge topology...'
+
+ do inum = 1,num_fluid_solid_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_solid_acoustic_ispec(inum)
+ iedge_acoustic = fluid_solid_acoustic_iedge(inum)
+
+! get the corresponding edge of the elastic element
+ ispec_elastic = fluid_solid_elastic_ispec(inum)
+ iedge_elastic = fluid_solid_elastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the elastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_elastic)
+ j = jvalue_inverse(ipoin1D,iedge_elastic)
+ iglob = ibool(i,j,ispec_elastic)
+
+! get point values for the acoustic side
+ i = ivalue(ipoin1D,iedge_acoustic)
+ j = jvalue(ipoin1D,iedge_acoustic)
+ iglob2 = ibool(i,j,ispec_acoustic)
+
+! if distance between the two points is not negligible, there is an error, since it should be zero
+ if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
+ stop 'error in fluid/solid coupling buffer'
+
+ enddo
+
+ enddo
+
+ print *,'End of fluid/solid edge detection'
+ print *
+
+ else
+
+! allocate dummy arrays for fluid/solid matching if purely acoustic or purely elastic
+ allocate(fluid_solid_acoustic_ispec(1))
+ allocate(fluid_solid_acoustic_iedge(1))
+ allocate(fluid_solid_elastic_ispec(1))
+ allocate(fluid_solid_elastic_iedge(1))
+
+ endif
+
+! default values for acoustic absorbing edges
+ ibegin_bottom(:) = 1
+ ibegin_top(:) = 1
+
+ iend_bottom(:) = NGLLX
+ iend_top(:) = NGLLX
+
+ jbegin_left(:) = 1
+ jbegin_right(:) = 1
+
+ jend_left(:) = NGLLZ
+ jend_right(:) = NGLLZ
+
+! exclude common points between acoustic absorbing edges and acoustic/elastic matching interfaces
+ if(coupled_acoustic_elastic .and. anyabs) then
+
+ print *,'excluding common points between acoustic absorbing edges and acoustic/elastic matching interfaces, if any'
+
+! loop on all the absorbing elements
+ do ispecabs = 1,nelemabs
+
+ ispec = numabs(ispecabs)
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_solid_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_solid_acoustic_ispec(inum)
+ iedge_acoustic = fluid_solid_acoustic_iedge(inum)
+
+! if acoustic absorbing element and acoustic/elastic coupled element is the same
+ if(ispec_acoustic == ispec) then
+
+ if(iedge_acoustic == IBOTTOM) then
+ jbegin_left(ispecabs) = 2
+ jbegin_right(ispecabs) = 2
+ endif
+
+ if(iedge_acoustic == ITOP) then
+ jend_left(ispecabs) = NGLLZ - 1
+ jend_right(ispecabs) = NGLLZ - 1
+ endif
+
+ if(iedge_acoustic == ILEFT) then
+ ibegin_bottom(ispecabs) = 2
+ ibegin_top(ispecabs) = 2
+ endif
+
+ if(iedge_acoustic == IRIGHT) then
+ iend_bottom(ispecabs) = NGLLX - 1
+ iend_top(ispecabs) = NGLLX - 1
+ endif
+
+ endif
+
+ enddo
+
+ enddo
+
+ endif
+
+!
+!---- s t a r t t i m e i t e r a t i o n s
+!
+
+ write(IOUT,400)
+
+! count elapsed wall-clock time
+ datein = ''
+ timein = ''
+ zone = ''
+
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! *********************************************************
+! ************* MAIN LOOP OVER THE TIME STEPS *************
+! *********************************************************
+
+ do it = 1,NSTEP
+
+! compute current time
+ time = (it-1)*deltat
+
+! update displacement using finite-difference time scheme (Newmark)
+ if(any_elastic) then
+ displ_elastic = displ_elastic + deltat*veloc_elastic + deltatsquareover2*accel_elastic
+ veloc_elastic = veloc_elastic + deltatover2*accel_elastic
+ accel_elastic = ZERO
+ endif
+
+ if(any_acoustic) then
+
+ potential_acoustic = potential_acoustic + deltat*potential_dot_acoustic + deltatsquareover2*potential_dot_dot_acoustic
+ potential_dot_acoustic = potential_dot_acoustic + deltatover2*potential_dot_dot_acoustic
+ potential_dot_dot_acoustic = ZERO
+
+! free surface for an acoustic medium
+ call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,ispecnum_acoustic_surface,iedgenum_acoustic_surface, &
+ ibool,nelem_acoustic_surface,npoin,nspec)
+
+! *********************************************************
+! ************* compute forces for the acoustic elements
+! *********************************************************
+
+ call compute_forces_acoustic(npoin,nspec,nelemabs,numat, &
+ iglob_source,ispec_selected_source,source_type,it,NSTEP,anyabs, &
+ assign_external_model,initialfield,ibool,kmato,numabs, &
+ elastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,density,elastcoef,xix,xiz,gammax,gammaz,jacobian, &
+ vpext,vsext,rhoext,source_time_function,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll, &
+ ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
+ jbegin_left,jend_left,jbegin_right,jend_right)
+
+ endif ! end of test if any acoustic element
+
+! *********************************************************
+! ************* add coupling with the elastic side
+! *********************************************************
+
+ if(coupled_acoustic_elastic) then
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_solid_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_solid_acoustic_ispec(inum)
+ iedge_acoustic = fluid_solid_acoustic_iedge(inum)
+
+! get the corresponding edge of the elastic element
+ ispec_elastic = fluid_solid_elastic_ispec(inum)
+ iedge_elastic = fluid_solid_elastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the elastic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_elastic)
+ j = jvalue_inverse(ipoin1D,iedge_elastic)
+ iglob = ibool(i,j,ispec_elastic)
+
+ displ_x = displ_elastic(1,iglob)
+ displ_z = displ_elastic(2,iglob)
+
+! get point values for the acoustic side
+ i = ivalue(ipoin1D,iedge_acoustic)
+ j = jvalue(ipoin1D,iedge_acoustic)
+ iglob = ibool(i,j,ispec_acoustic)
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+ if(iedge_acoustic == IBOTTOM .or. iedge_acoustic == ITOP) then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ else
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ endif
+
+! compute dot product
+ displ_n = displ_x*nx + displ_z*nz
+
+! formulation with generalized potential
+ weight = jacobian1D * wxgll(i)
+
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*displ_n
+
+ enddo
+
+ enddo
+
+ endif
+
+! ************************************************************************************
+! ************* multiply by the inverse of the mass matrix and update velocity
+! ************************************************************************************
+
+ if(any_acoustic) then
+
+ potential_dot_dot_acoustic = potential_dot_dot_acoustic * rmass_inverse_acoustic
+ potential_dot_acoustic = potential_dot_acoustic + deltatover2*potential_dot_dot_acoustic
+
+! free surface for an acoustic medium
+ call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
+ potential_acoustic,ispecnum_acoustic_surface,iedgenum_acoustic_surface, &
+ ibool,nelem_acoustic_surface,npoin,nspec)
+ endif
+
+! *********************************************************
+! ************* main solver for the elastic elements
+! *********************************************************
+
+ if(any_elastic) &
+ call compute_forces_elastic(npoin,nspec,nelemabs,numat,iglob_source, &
+ ispec_selected_source,source_type,it,NSTEP,anyabs,assign_external_model, &
+ initialfield,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,angleforce,deltatcube, &
+ deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,elastic,codeabs, &
+ accel_elastic,veloc_elastic,displ_elastic,density,elastcoef,xix,xiz,gammax,gammaz, &
+ jacobian,vpext,vsext,rhoext,source_time_function,sourcearray,e1_mech1,e11_mech1, &
+ e13_mech1,e1_mech2,e11_mech2,e13_mech2,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
+ dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
+ hprime_zz,hprimewgll_zz,wxgll,wzgll)
+
+! *********************************************************
+! ************* add coupling with the acoustic side
+! *********************************************************
+
+ if(coupled_acoustic_elastic) then
+
+! loop on all the coupling edges
+ do inum = 1,num_fluid_solid_edges
+
+! get the edge of the acoustic element
+ ispec_acoustic = fluid_solid_acoustic_ispec(inum)
+ iedge_acoustic = fluid_solid_acoustic_iedge(inum)
+
+! get the corresponding edge of the elastic element
+ ispec_elastic = fluid_solid_elastic_ispec(inum)
+ iedge_elastic = fluid_solid_elastic_iedge(inum)
+
+! implement 1D coupling along the edge
+ do ipoin1D = 1,NGLLX
+
+! get point values for the acoustic side, which matches our side in the inverse direction
+ i = ivalue_inverse(ipoin1D,iedge_acoustic)
+ j = jvalue_inverse(ipoin1D,iedge_acoustic)
+ iglob = ibool(i,j,ispec_acoustic)
+
+! get density of the fluid, depending if external density model
+ if(assign_external_model) then
+ rhol = rhoext(i,j,ispec_acoustic)
+ else
+ rhol = density(kmato(ispec_acoustic))
+ endif
+
+! compute pressure on the fluid/solid edge
+ pressure = - rhol * potential_dot_dot_acoustic(iglob)
+
+! get point values for the elastic side
+ i = ivalue(ipoin1D,iedge_elastic)
+ j = jvalue(ipoin1D,iedge_elastic)
+ iglob = ibool(i,j,ispec_elastic)
+
+! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
+! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
+! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
+! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
+! Blackwell Science, page 110, equation (4.60).
+ if(iedge_acoustic == IBOTTOM .or. iedge_acoustic == ITOP) then
+ xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xxi**2 + zxi**2)
+ nx = + zxi / jacobian1D
+ nz = - xxi / jacobian1D
+ else
+ xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
+ jacobian1D = sqrt(xgamma**2 + zgamma**2)
+ nx = + zgamma / jacobian1D
+ nz = - xgamma / jacobian1D
+ endif
+
+! formulation with generalized potential
+ weight = jacobian1D * wxgll(i)
+
+ accel_elastic(1,iglob) = accel_elastic(1,iglob) + weight*nx*pressure
+ accel_elastic(2,iglob) = accel_elastic(2,iglob) + weight*nz*pressure
+
+ enddo
+
+ enddo
+
+ endif
+
+! ************************************************************************************
+! ************* multiply by the inverse of the mass matrix and update velocity
+! ************************************************************************************
+
+ if(any_elastic) then
+ accel_elastic(1,:) = accel_elastic(1,:) * rmass_inverse_elastic
+ accel_elastic(2,:) = accel_elastic(2,:) * rmass_inverse_elastic
+ veloc_elastic = veloc_elastic + deltatover2*accel_elastic
+ endif
+
+!---- display time step and max of norm of displacement
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then
+
+ write(IOUT,*)
+ if(time >= 1.d-3 .and. time < 1000.d0) then
+ write(IOUT,"('Time step number ',i6,' t = ',f9.4,' s')") it,time
+ else
+ write(IOUT,"('Time step number ',i6,' t = ',1pe12.6,' s')") it,time
+ endif
+
+ if(any_elastic) then
+ displnorm_all = maxval(sqrt(displ_elastic(1,:)**2 + displ_elastic(2,:)**2))
+ write(IOUT,*) 'Max norm of vector field in solid = ',displnorm_all
+! check stability of the code in solid, exit if unstable
+ if(displnorm_all > STABILITY_THRESHOLD) stop 'code became unstable and blew up in solid'
+ endif
+
+ if(any_acoustic) then
+ displnorm_all = maxval(abs(potential_acoustic(:)))
+ write(IOUT,*) 'Max absolute value of scalar field in fluid = ',displnorm_all
+! check stability of the code in fluid, exit if unstable
+ if(displnorm_all > STABILITY_THRESHOLD) stop 'code became unstable and blew up in fluid'
+ endif
+
+ write(IOUT,*)
+ endif
+
+! loop on all the receivers to compute and store the seismograms
+ do irec = 1,nrec
+
+ ispec = ispec_selected_rec(irec)
+
+! compute pressure in this element if needed
+ if(seismotype == 4) then
+
+ call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,elastic, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
+ numat,kmato,density,elastcoef,vpext,vsext,rhoext,ispec,e1_mech1,e11_mech1, &
+ e1_mech2,e11_mech2,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON)
+
+ else if(.not. elastic(ispec)) then
+
+! for acoustic medium, compute vector field from gradient of potential for seismograms
+ if(seismotype == 1) then
+ call compute_vector_one_element(vector_field_element,potential_acoustic,displ_elastic,elastic, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec)
+ else if(seismotype == 2) then
+ call compute_vector_one_element(vector_field_element,potential_dot_acoustic,veloc_elastic,elastic, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec)
+ else if(seismotype == 3) then
+ call compute_vector_one_element(vector_field_element,potential_dot_dot_acoustic,accel_elastic,elastic, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec)
+ endif
+
+ endif
+
+! perform the general interpolation using Lagrange polynomials
+ valux = ZERO
+ valuz = ZERO
+
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,ispec)
+
+ hlagrange = hxir_store(irec,i)*hgammar_store(irec,j)
+
+ if(seismotype == 4) then
+
+ dxd = pressure_element(i,j)
+ dzd = ZERO
+
+ else if(.not. elastic(ispec)) then
+
+ dxd = vector_field_element(1,i,j)
+ dzd = vector_field_element(2,i,j)
+
+ else if(seismotype == 1) then
+
+ dxd = displ_elastic(1,iglob)
+ dzd = displ_elastic(2,iglob)
+
+ else if(seismotype == 2) then
+
+ dxd = veloc_elastic(1,iglob)
+ dzd = veloc_elastic(2,iglob)
+
+ else if(seismotype == 3) then
+
+ dxd = accel_elastic(1,iglob)
+ dzd = accel_elastic(2,iglob)
+
+ endif
+
+! compute interpolated field
+ valux = valux + dxd*hlagrange
+ valuz = valuz + dzd*hlagrange
+
+ enddo
+ enddo
+
+! rotate seismogram components if needed, except if recording pressure, which is a scalar
+ if(seismotype /= 4) then
+ sisux(it,irec) = cosrot*valux + sinrot*valuz
+ sisuz(it,irec) = - sinrot*valux + cosrot*valuz
+ else
+ sisux(it,irec) = valux
+ sisuz(it,irec) = ZERO
+ endif
+
+ enddo
+
+!
+!---- display results at given time steps
+!
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
+
+!
+!---- PostScript display
+!
+ if(output_postscript_snapshot) then
+
+ write(IOUT,*) 'Writing PostScript file'
+
+ if(imagetype == 1) then
+
+ write(IOUT,*) 'drawing displacement vector as small arrows...'
+
+ call compute_vector_whole_medium(potential_acoustic,displ_elastic,elastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
+
+ call plotpost(vector_field_display,coord,vpext,x_source,z_source,st_xval,st_zval, &
+ it,deltat,coorg,xinterp,zinterp,shape2D_display, &
+ Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ numabs,codeabs,anyabs,simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
+ colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
+ boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
+ nspec,ngnod,coupled_acoustic_elastic,any_acoustic,plot_lowerleft_corner_only, &
+ fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges)
+
+ else if(imagetype == 2) then
+
+ write(IOUT,*) 'drawing velocity vector as small arrows...'
+
+ call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,elastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
+
+ call plotpost(vector_field_display,coord,vpext,x_source,z_source,st_xval,st_zval, &
+ it,deltat,coorg,xinterp,zinterp,shape2D_display, &
+ Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ numabs,codeabs,anyabs,simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
+ colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
+ boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
+ nspec,ngnod,coupled_acoustic_elastic,any_acoustic,plot_lowerleft_corner_only, &
+ fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges)
+
+ else if(imagetype == 3) then
+
+ write(IOUT,*) 'drawing acceleration vector as small arrows...'
+
+ call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,elastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
+
+ call plotpost(vector_field_display,coord,vpext,x_source,z_source,st_xval,st_zval, &
+ it,deltat,coorg,xinterp,zinterp,shape2D_display, &
+ Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ numabs,codeabs,anyabs,simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
+ colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
+ boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
+ nspec,ngnod,coupled_acoustic_elastic,any_acoustic,plot_lowerleft_corner_only, &
+ fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges)
+
+ else if(imagetype == 4) then
+
+ write(IOUT,*) 'cannot draw scalar pressure field as a vector plot, skipping...'
+
+ else
+ stop 'wrong type for snapshots'
+ endif
+
+ if(imagetype /= 4) write(IOUT,*) 'PostScript file written'
+
+ endif
+
+!
+!---- display color image
+!
+ if(output_color_image) then
+
+ write(IOUT,*) 'Creating color image of size ',NX_IMAGE_color,' x ',NZ_IMAGE_color
+
+ if(imagetype == 1) then
+
+ write(IOUT,*) 'drawing image of vertical component of displacement vector...'
+
+ call compute_vector_whole_medium(potential_acoustic,displ_elastic,elastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
+
+ else if(imagetype == 2) then
+
+ write(IOUT,*) 'drawing image of vertical component of velocity vector...'
+
+ call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,elastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
+
+ else if(imagetype == 3) then
+
+ write(IOUT,*) 'drawing image of vertical component of acceleration vector...'
+
+ call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,elastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
+
+ else if(imagetype == 4) then
+
+ write(IOUT,*) 'drawing image of pressure field...'
+
+ call compute_pressure_whole_medium(potential_dot_dot_acoustic,displ_elastic,elastic,vector_field_display, &
+ xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
+ numat,kmato,density,elastcoef,vpext,vsext,rhoext,e1_mech1,e11_mech1, &
+ e1_mech2,e11_mech2,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON)
+
+ else
+ stop 'wrong type for snapshots'
+ endif
+
+ image_color_data(:,:) = 0.d0
+ do j = 1,NZ_IMAGE_color
+ do i = 1,NX_IMAGE_color
+ iglob = iglob_image_color(i,j)
+! draw vertical component of field
+! or pressure which is stored in the same array used as temporary storage
+ if(iglob /= -1) image_color_data(i,j) = vector_field_display(2,iglob)
+ enddo
+ enddo
+
+ call create_color_image(image_color_data,iglob_image_color,NX_IMAGE_color,NZ_IMAGE_color,it,cutsnaps)
+
+ write(IOUT,*) 'Color image created'
+
+ endif
+
+!---- save temporary or final seismograms
+ call write_seismograms(sisux,sisuz,station_name,network_name,NSTEP, &
+ nrec,deltat,seismotype,st_xval,it,t0,buffer_binary_single,buffer_binary_double)
+
+! count elapsed wall-clock time
+ call date_and_time(datein,timein,zone,time_values)
+! time_values(3): day of the month
+! time_values(5): hour of the day
+! time_values(6): minutes of the hour
+! time_values(7): seconds of the minute
+! time_values(8): milliseconds of the second
+! this fails if we cross the end of the month
+ time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
+ 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
+
+! elapsed time since beginning of the simulation
+ tCPU = time_end - time_start
+ int_tCPU = int(tCPU)
+ ihours = int_tCPU / 3600
+ iminutes = (int_tCPU - 3600*ihours) / 60
+ iseconds = int_tCPU - 3600*ihours - 60*iminutes
+ write(*,*) 'Elapsed time in seconds = ',tCPU
+ write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ write(*,*)
+
+ endif
+
+ enddo ! end of the main time loop
+
+! print exit banner
+ call datim(simulation_title)
+
+!
+!---- close output file
+!
+ if(IOUT /= ISTANDARD_OUTPUT) close(IOUT)
+
+!
+!---- formats
+!
+
+ 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,13('='),//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,13('='),//5x, &
+ 'Display frequency . . . (NTSTEP_BETWEEN_OUTPUT_INFO) = ',i6/ 5x, &
+ 'Color display . . . . . . . . . . . . . . . (colors) = ',i6/ 5x, &
+ ' == 0 black and white display ', / 5x, &
+ ' == 1 color display ', /5x, &
+ 'Numbered mesh . . . . . . . . . . . . . . .(numbers) = ',i6/ 5x, &
+ ' == 0 do not number the mesh ', /5x, &
+ ' == 1 number the mesh ')
+
+ 700 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
+ 'Seismograms recording type . . . . . . .(seismotype) = ',i6/5x, &
+ 'Angle for first line of receivers. . . . .(anglerec) = ',f6.2)
+
+ 750 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
+ 'Read external initial field. . . . . .(initialfield) = ',l6/5x, &
+ 'Assign external model . . . .(assign_external_model) = ',l6/5x, &
+ 'Turn anisotropy on or off. . . .(TURN_ANISOTROPY_ON) = ',l6/5x, &
+ 'Turn attenuation on or off. . .(TURN_ATTENUATION_ON) = ',l6/5x, &
+ 'Save grid in external file or not. . . .(outputgrid) = ',l6)
+
+ 800 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
+ 'Vector display type . . . . . . . . . . .(imagetype) = ',i6/5x, &
+ 'Percentage of cut for vector plots . . . .(cutsnaps) = ',f6.2/5x, &
+ 'Subsampling for velocity model display. . .(subsamp) = ',i6)
+
+ 703 format(//' I t e r a t i o n s '/1x,19('='),//5x, &
+ '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 . . .(pointsdisp) =',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. . . . . . . . . . . . . . = Moment-tensor',/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, &
+ 'Mxx. . . . . . . . . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Mzz. . . . . . . . . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Mxz. . . . . . . . . . . . . . . . . . =',1pe20.10)
+
+ end program specfem2D
+
Deleted: seismo/2D/SPECFEM2D/trunk/specfem2D.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/specfem2D.f90 2007-06-26 00:32:15 UTC (rev 8521)
+++ seismo/2D/SPECFEM2D/trunk/specfem2D.f90 2007-12-07 23:53:16 UTC (rev 8522)
@@ -1,1944 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 5.2
-! ------------------------------
-!
-! Dimitri Komatitsch
-! University of Pau, France
-!
-! (c) April 2007
-!
-!========================================================================
-
-!====================================================================================
-!
-! An explicit 2D spectral element solver for the anelastic anisotropic wave equation
-!
-!====================================================================================
-
-! If you use this code for your own research, please cite:
-!
-! @ARTICLE{KoTr99,
-! author={D. Komatitsch and J. Tromp},
-! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
-! journal={Geophys. J. Int.},
-! year=1999,
-! volume=139,
-! number=3,
-! pages={806-822},
-! doi={10.1046/j.1365-246x.1999.00967.x}}
-!
-! @ARTICLE{KoVi98,
-! author={D. Komatitsch and J. P. Vilotte},
-! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
-! journal={Bull. Seismol. Soc. Am.},
-! year=1998,
-! volume=88,
-! number=2,
-! pages={368-392}}
-
-!
-! version 5.2, Dimitri Komatitsch, April 2007:
-! - general fluid/solid implementation with any number, shape and orientation of
-! matching edges
-! - absorbing edges with any normal vector
-! - general numbering of absorbing and acoustic free surface edges
-! - cleaned implementation of attenuation as in Carcione (1993)
-! - merged loops in the solver for efficiency
-! - simplified input of external model
-! - added CPU time information
-! - translated many comments from French to English
-!
-! version 5.1, Dimitri Komatitsch, January 2005:
-! - more general mesher with any number of curved layers
-! - Dirac and Gaussian time sources and corresponding convolution routine
-! - option for acoustic medium instead of elastic
-! - receivers at any location, not only grid points
-! - moment-tensor source at any location, not only a grid point
-! - color snapshots
-! - more flexible DATA/Par_file with any number of comment lines
-! - Xsu scripts for seismograms
-! - subtract t0 from seismograms
-! - seismograms and snapshots in pressure in addition to vector field
-!
-! version 5.0, Dimitri Komatitsch, May 2004:
-! - got rid of useless routines, suppressed commons etc.
-! - weak formulation based explicitly on stress tensor
-! - implementation of full anisotropy
-! - 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
-!
-
-! in case of an acoustic medium, a displacement potential Chi is used as in Chaljub and Valette,
-! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
-! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
-! This permits acoustic-elastic coupling based on a non-iterative time scheme.
-! Displacement is then: u = grad(Chi)
-! Velocity is then: v = grad(Chi_dot) (Chi_dot being the time derivative of Chi)
-! and pressure is: p = - rho * Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
-! The source in an acoustic element is a pressure source.
-
- program specfem2D
-
- implicit none
-
- include "constants.h"
-
- character(len=80) datlin
-
- integer :: source_type,time_function_type
- double precision :: x_source,z_source,xi_source,gamma_source,Mxx,Mzz,Mxz,f0,t0,factor,angleforce,hdur,hdur_gauss
- double precision, dimension(NDIM,NGLLX,NGLLZ) :: sourcearray
-
- 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
-
-! for seismograms
- double precision, dimension(:,:), allocatable :: sisux,sisuz
-! vector field in an element
- double precision, dimension(NDIM,NGLLX,NGLLX) :: vector_field_element
-! pressure in an element
- double precision, dimension(NGLLX,NGLLX) :: pressure_element
-
-! to write seismograms in single precision SEP and double precision binary format
- real(kind=4), dimension(:), allocatable :: buffer_binary_single
- double precision, dimension(:), allocatable :: buffer_binary_double
-
- integer :: i,j,k,it,irec,ipoin,ip,id,nbpoin,inump,n,ispec,iedge,npoin,npgeo,iglob
- logical :: anyabs
- double precision :: dxd,dzd,valux,valuz,hlagrange,rhol,cosrot,sinrot,xi,gamma,x,z
-
-! 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
-
-! derivatives of Lagrange polynomials
- double precision, dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
- double precision, dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
-
-! Jacobian matrix and determinant
- double precision :: xixl,xizl,gammaxl,gammazl,jacobianl
-
-! material properties of the elastic medium
- double precision :: mul_relaxed,lambdal_relaxed,cpsquare
-
- double precision, dimension(:,:), allocatable :: coord,accel_elastic,veloc_elastic,displ_elastic, &
- flagrange,xinterp,zinterp,Uxinterp,Uzinterp,elastcoef,vector_field_display
-
-! for acoustic medium
- double precision, dimension(:), allocatable :: potential_dot_dot_acoustic,potential_dot_acoustic,potential_acoustic
-
- double precision, dimension(:), allocatable :: rmass_inverse_elastic,rmass_inverse_acoustic,density,displread,velocread,accelread
-
- double precision, dimension(:,:,:), allocatable :: vpext,vsext,rhoext
- double precision :: previous_vsext
-
- double precision, dimension(:,:,:), allocatable :: shape2D,shape2D_display,xix,xiz,gammax,gammaz,jacobian
-
- double precision, dimension(:,:,:,:), allocatable :: dershape2D,dershape2D_display
-
- integer, dimension(:,:,:), allocatable :: ibool
- integer, dimension(:,:), allocatable :: knods
- integer, dimension(:), allocatable :: kmato,numabs,ispecnum_acoustic_surface,iedgenum_acoustic_surface, &
- ibegin_bottom,iend_bottom,ibegin_top,iend_top,jbegin_left,jend_left,jbegin_right,jend_right
-
- integer ispec_selected_source,iglob_source,ix_source,iz_source
- double precision a,displnorm_all
- double precision, dimension(:), allocatable :: source_time_function
- double precision, external :: erf
-
- double precision :: vpmin,vpmax
-
- integer :: colors,numbers,subsamp,imagetype,NTSTEP_BETWEEN_OUTPUT_INFO,nrec,seismotype
- integer :: numat,ngnod,nspec,pointsdisp,nelemabs,nelem_acoustic_surface,ispecabs
-
- logical interpol,meshvect,modelvect,boundvect,assign_external_model,initialfield, &
- outputgrid,gnuplot,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON,output_postscript_snapshot,output_color_image, &
- plot_lowerleft_corner_only
-
- double precision :: cutsnaps,sizemax_arrows,anglerec,xirec,gammarec
-
-! for absorbing and acoustic free surface conditions
- integer :: ispec_acoustic_surface,inum,numabsread,numacoustread,iedgeacoustread
- logical :: codeabsread(4)
- double precision :: nx,nz,weight,xxi,zgamma
-
- logical, dimension(:,:), allocatable :: codeabs
-
-! for attenuation
- integer nspec_allocate
- double precision :: deltatsquare,deltatcube,deltatfourth,twelvedeltat,fourdeltatsquare
-
- double precision, dimension(:,:,:), allocatable :: &
- e1_mech1,e11_mech1,e13_mech1,e1_mech2,e11_mech2,e13_mech2, &
- dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n,dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1
-
-! for fluid/solid coupling and edge detection
- logical, dimension(:), allocatable :: elastic
- integer, dimension(NEDGES) :: i_begin,j_begin,i_end,j_end
- integer, dimension(NGLLX,NEDGES) :: ivalue,jvalue,ivalue_inverse,jvalue_inverse
- integer, dimension(:), allocatable :: fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge, &
- fluid_solid_elastic_ispec,fluid_solid_elastic_iedge
- integer :: num_fluid_solid_edges,num_fluid_solid_edges_alloc,ispec_acoustic,ispec_elastic, &
- iedge_acoustic,iedge_elastic,ipoin1D,iglob2
- logical :: any_acoustic,any_elastic,coupled_acoustic_elastic
- double precision :: displ_x,displ_z,displ_n,zxi,xgamma,jacobian1D,pressure
-
-! for color images
- integer :: NX_IMAGE_color,NZ_IMAGE_color,iplus1,jplus1,iminus1,jminus1,count_passes
- double precision :: xmin_color_image,xmax_color_image, &
- zmin_color_image,zmax_color_image,size_pixel_horizontal,size_pixel_vertical
- integer, dimension(:,:), allocatable :: iglob_image_color,copy_iglob_image_color
- double precision, dimension(:,:), allocatable :: image_color_data
-
-! timing information for the stations
- character(len=MAX_LENGTH_STATION_NAME), allocatable, dimension(:) :: station_name
- character(len=MAX_LENGTH_NETWORK_NAME), allocatable, dimension(:) :: network_name
-
-! title of the plot
- character(len=60) simulation_title
-
-! 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
-
-! timer to count elapsed time
- character(len=8) datein
- character(len=10) timein
- character(len=5) :: zone
- integer, dimension(8) :: time_values
- integer ihours,iminutes,iseconds,int_tCPU
- double precision :: time_start,time_end,tCPU
-
-!***********************************************************************
-!
-! i n i t i a l i z a t i o n p h a s e
-!
-!***********************************************************************
-
- open(IIN,file='OUTPUT_FILES/Database',status='old',action='read')
-
-! determine if we write to file instead of standard output
- if(IOUT /= ISTANDARD_OUTPUT) open(IOUT,file='simulation_results.txt',status='unknown')
-
-!
-!--- read job title and skip remaining titles of the input file
-!
- read(IIN,"(a80)") datlin
- read(IIN,"(a80)") datlin
- read(IIN,"(a80)") datlin
- read(IIN,"(a80)") datlin
- read(IIN,"(a80)") datlin
- read(IIN,"(a50)") simulation_title
-
-!
-!---- print the date, time and start-up banner
-!
- call datim(simulation_title)
-
- write(IOUT,*)
- write(IOUT,*)
- write(IOUT,*) '*********************'
- write(IOUT,*) '**** ****'
- write(IOUT,*) '**** SPECFEM2D ****'
- write(IOUT,*) '**** ****'
- write(IOUT,*) '*********************'
-
-!
-!---- read parameters from input file
-!
-
- read(IIN,"(a80)") datlin
- read(IIN,*) npgeo
-
- read(IIN,"(a80)") datlin
- read(IIN,*) gnuplot,interpol
-
- read(IIN,"(a80)") datlin
- read(IIN,*) NTSTEP_BETWEEN_OUTPUT_INFO
-
- read(IIN,"(a80)") datlin
- read(IIN,*) output_postscript_snapshot,output_color_image,colors,numbers
-
- read(IIN,"(a80)") datlin
- read(IIN,*) meshvect,modelvect,boundvect,cutsnaps,subsamp,sizemax_arrows
- cutsnaps = cutsnaps / 100.d0
-
- read(IIN,"(a80)") datlin
- read(IIN,*) anglerec
-
- read(IIN,"(a80)") datlin
- read(IIN,*) initialfield
-
- read(IIN,"(a80)") datlin
- read(IIN,*) seismotype,imagetype
- if(seismotype < 1 .or. seismotype > 4) stop 'Wrong type for seismogram output'
- if(imagetype < 1 .or. imagetype > 4) stop 'Wrong type for snapshots'
-
- read(IIN,"(a80)") datlin
- read(IIN,*) assign_external_model,outputgrid,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
-
-!---- check parameters read
- write(IOUT,200) npgeo,NDIM
- write(IOUT,600) NTSTEP_BETWEEN_OUTPUT_INFO,colors,numbers
- write(IOUT,700) seismotype,anglerec
- write(IOUT,750) initialfield,assign_external_model,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON,outputgrid
- write(IOUT,800) imagetype,100.d0*cutsnaps,subsamp
-
-!---- read time step
- read(IIN,"(a80)") datlin
- read(IIN,*) NSTEP,deltat
- write(IOUT,703) NSTEP,deltat,NSTEP*deltat
-
-!
-!---- read source information
-!
- read(IIN,"(a80)") datlin
- read(IIN,*) source_type,time_function_type,x_source,z_source,f0,t0,factor,angleforce,Mxx,Mzz,Mxz
-
-!
-!----- 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,Mxx,Mzz,Mxz
- 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,"(a80)") 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,"(a80)") datlin
- read(IIN,*) numat,ngnod,nspec,pointsdisp,plot_lowerleft_corner_only
- read(IIN,"(a80)") datlin
- read(IIN,*) nelemabs,nelem_acoustic_surface
-
-!
-!---- allocate arrays
-!
- allocate(shape2D(ngnod,NGLLX,NGLLZ))
- allocate(dershape2D(NDIM,ngnod,NGLLX,NGLLZ))
- allocate(shape2D_display(ngnod,pointsdisp,pointsdisp))
- allocate(dershape2D_display(NDIM,ngnod,pointsdisp,pointsdisp))
- 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(flagrange(NGLLX,pointsdisp))
- allocate(xinterp(pointsdisp,pointsdisp))
- allocate(zinterp(pointsdisp,pointsdisp))
- allocate(Uxinterp(pointsdisp,pointsdisp))
- allocate(Uzinterp(pointsdisp,pointsdisp))
- allocate(density(numat))
- allocate(elastcoef(4,numat))
- allocate(kmato(nspec))
- allocate(knods(ngnod,nspec))
- allocate(ibool(NGLLX,NGLLZ,nspec))
- allocate(elastic(nspec))
-
-! --- 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(ibegin_bottom(nelemabs))
- allocate(iend_bottom(nelemabs))
- allocate(ibegin_top(nelemabs))
- allocate(iend_top(nelemabs))
-
- allocate(jbegin_left(nelemabs))
- allocate(jend_left(nelemabs))
- allocate(jbegin_right(nelemabs))
- allocate(jend_right(nelemabs))
-
-! --- allocate array for free surface condition in acoustic medium
- if(nelem_acoustic_surface <= 0) then
- nelem_acoustic_surface = 0
- allocate(ispecnum_acoustic_surface(1))
- allocate(iedgenum_acoustic_surface(1))
- else
- allocate(ispecnum_acoustic_surface(nelem_acoustic_surface))
- allocate(iedgenum_acoustic_surface(nelem_acoustic_surface))
- endif
-
-!
-!---- print element group main parameters
-!
- write(IOUT,107)
- write(IOUT,207) nspec,ngnod,NGLLX,NGLLZ,NGLLX*NGLLZ,pointsdisp,numat,nelemabs
-
-! set up Gauss-Lobatto-Legendre derivation matrices
- call define_derivation_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz,hprimewgll_xx,hprimewgll_zz)
-
-!
-!---- read the material properties
-!
- call gmat01(density,elastcoef,numat)
-
-!
-!---- read spectral macrobloc data
-!
- n = 0
- read(IIN,"(a80)") datlin
- do ispec = 1,nspec
- read(IIN,*) n,kmato(n),(knods(k,n), k=1,ngnod)
- enddo
-
-!
-!---- determine if each spectral element is elastic or acoustic
-!
- any_acoustic = .false.
- any_elastic = .false.
- do ispec = 1,nspec
- mul_relaxed = elastcoef(2,kmato(ispec))
- if(mul_relaxed < TINYVAL) then
- elastic(ispec) = .false.
- any_acoustic = .true.
- else
- elastic(ispec) = .true.
- any_elastic = .true.
- endif
- enddo
-
- if(TURN_ATTENUATION_ON) then
- nspec_allocate = nspec
- else
- nspec_allocate = 1
- endif
-
-! allocate memory variables for attenuation
- allocate(e1_mech1(NGLLX,NGLLZ,nspec_allocate))
- allocate(e11_mech1(NGLLX,NGLLZ,nspec_allocate))
- allocate(e13_mech1(NGLLX,NGLLZ,nspec_allocate))
- allocate(e1_mech2(NGLLX,NGLLZ,nspec_allocate))
- allocate(e11_mech2(NGLLX,NGLLZ,nspec_allocate))
- allocate(e13_mech2(NGLLX,NGLLZ,nspec_allocate))
- allocate(dux_dxl_n(NGLLX,NGLLZ,nspec_allocate))
- allocate(duz_dzl_n(NGLLX,NGLLZ,nspec_allocate))
- allocate(duz_dxl_n(NGLLX,NGLLZ,nspec_allocate))
- allocate(dux_dzl_n(NGLLX,NGLLZ,nspec_allocate))
- allocate(dux_dxl_np1(NGLLX,NGLLZ,nspec_allocate))
- allocate(duz_dzl_np1(NGLLX,NGLLZ,nspec_allocate))
- allocate(duz_dxl_np1(NGLLX,NGLLZ,nspec_allocate))
- allocate(dux_dzl_np1(NGLLX,NGLLZ,nspec_allocate))
-
-!
-!---- read absorbing boundary data
-!
- if(anyabs) then
- read(IIN,"(a80)") datlin
- do inum = 1,nelemabs
- read(IIN,*) numabsread,codeabsread(1),codeabsread(2),codeabsread(3),codeabsread(4)
- if(numabsread < 1 .or. numabsread > nspec) stop 'Wrong absorbing element number'
- numabs(inum) = numabsread
- codeabs(IBOTTOM,inum) = codeabsread(1)
- codeabs(IRIGHT,inum) = codeabsread(2)
- codeabs(ITOP,inum) = codeabsread(3)
- codeabs(ILEFT,inum) = codeabsread(4)
- enddo
- write(IOUT,*)
- write(IOUT,*) 'Number of absorbing elements: ',nelemabs
- endif
-
-!
-!---- read acoustic free surface data
-!
- if(nelem_acoustic_surface > 0) then
- read(IIN,"(a80)") datlin
- do inum = 1,nelem_acoustic_surface
- read(IIN,*) numacoustread,iedgeacoustread
- if(numacoustread < 1 .or. numacoustread > nspec) stop 'Wrong acoustic free surface element number'
- if(iedgeacoustread < 1 .or. iedgeacoustread > NEDGES) stop 'Wrong acoustic free surface edge number'
- ispecnum_acoustic_surface(inum) = numacoustread
- iedgenum_acoustic_surface(inum) = iedgeacoustread
- enddo
- write(IOUT,*)
- write(IOUT,*) 'Number of free surface elements: ',nelem_acoustic_surface
- endif
-
-!
-!---- 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
-!
-
-! "slow and clean" or "quick and dirty" version
- 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,pointsdisp
- do i = 1,pointsdisp
- xirec = 2.d0*dble(i-1)/dble(pointsdisp-1) - 1.d0
- gammarec = 2.d0*dble(j-1)/dble(pointsdisp-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,pointsdisp
- xirec = 2.d0*dble(i-1)/dble(pointsdisp-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))
-
-! to write seismograms in single precision SEP and double precision binary format
- allocate(buffer_binary_single(NSTEP*nrec))
- allocate(buffer_binary_double(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))
-
-! allocate other global arrays
- allocate(coord(NDIM,npoin))
-
-! to display acoustic elements
- allocate(vector_field_display(NDIM,npoin))
-
- if(assign_external_model) then
- allocate(vpext(NGLLX,NGLLZ,nspec))
- allocate(vsext(NGLLX,NGLLZ,nspec))
- allocate(rhoext(NGLLX,NGLLZ,nspec))
- else
- allocate(vpext(1,1,1))
- allocate(vsext(1,1,1))
- allocate(rhoext(1,1,1))
- endif
-
-!
-!---- 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
- write(IOUT,*)
- write(IOUT,*) 'Saving the grid in a text file...'
- write(IOUT,*)
- open(unit=55,file='OUTPUT_FILES/grid_points_and_model.txt',status='unknown')
- write(55,*) npoin
- do n = 1,npoin
- write(55,*) (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)
-
-!
-!---- assign external velocity and density model if needed
-!
- if(assign_external_model) then
- write(IOUT,*)
- write(IOUT,*) 'Assigning external velocity and density model...'
- write(IOUT,*)
- if(TURN_ANISOTROPY_ON .or. TURN_ATTENUATION_ON) &
- stop 'cannot have anisotropy nor attenuation if external model in current version'
- any_acoustic = .false.
- any_elastic = .false.
- do ispec = 1,nspec
- previous_vsext = -1.d0
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
- call define_external_model(coord(1,iglob),coord(2,iglob),kmato(ispec), &
- rhoext(i,j,ispec),vpext(i,j,ispec),vsext(i,j,ispec))
-! stop if the same element is assigned both acoustic and elastic points in external model
- if(.not. (i == 1 .and. j == 1) .and. &
- ((vsext(i,j,ispec) >= TINYVAL .and. previous_vsext < TINYVAL) .or. &
- (vsext(i,j,ispec) < TINYVAL .and. previous_vsext >= TINYVAL))) &
- stop 'external velocity model cannot be both fluid and solid inside the same spectral element'
- if(vsext(i,j,ispec) < TINYVAL) then
- elastic(ispec) = .false.
- any_acoustic = .true.
- else
- elastic(ispec) = .true.
- any_elastic = .true.
- endif
- previous_vsext = vsext(i,j,ispec)
- enddo
- enddo
- enddo
- endif
-
-!
-!---- perform basic checks on parameters read
-!
-
-! for acoustic
- if(TURN_ANISOTROPY_ON .and. .not. any_elastic) stop 'cannot have anisotropy if acoustic simulation only'
-
- if(TURN_ATTENUATION_ON .and. .not. any_elastic) stop 'currently cannot have attenuation if acoustic simulation only'
-
-! for attenuation
- if(TURN_ANISOTROPY_ON .and. TURN_ATTENUATION_ON) stop 'cannot have anisotropy and attenuation both turned on in current version'
-
-!
-!---- define coefficients of the Newmark time scheme
-!
- deltatover2 = HALF*deltat
- deltatsquareover2 = HALF*deltat*deltat
-
-!---- define actual location of source and receivers
- if(source_type == 1) then
-! collocated force source
- call locate_source_force(coord,ibool,npoin,nspec,x_source,z_source,source_type, &
- ix_source,iz_source,ispec_selected_source,iglob_source)
-
-! check that acoustic source is not exactly on the free surface because pressure is zero there
- do ispec_acoustic_surface = 1,nelem_acoustic_surface
- ispec = ispecnum_acoustic_surface(ispec_acoustic_surface)
- iedge = iedgenum_acoustic_surface(ispec_acoustic_surface)
- if(.not. elastic(ispec) .and. ispec == ispec_selected_source) then
- if((iedge == IBOTTOM .and. iz_source == 1) .or. &
- (iedge == ITOP .and. iz_source == NGLLZ) .or. &
- (iedge == ILEFT .and. ix_source == 1) .or. &
- (iedge == IRIGHT .and. ix_source == NGLLX)) &
- stop 'an acoustic source cannot be located exactly on the free surface because pressure is zero there'
- endif
- enddo
-
- else if(source_type == 2) then
-! moment-tensor source
- call locate_source_moment_tensor(ibool,coord,nspec,npoin,xigll,zigll,x_source,z_source, &
- ispec_selected_source,xi_source,gamma_source,coorg,knods,ngnod,npgeo)
-
-! compute source array for moment-tensor source
- call compute_arrays_source(ispec_selected_source,xi_source,gamma_source,sourcearray, &
- Mxx,Mzz,Mxz,xix,xiz,gammax,gammaz,xigll,zigll,nspec)
-
- else
- stop 'incorrect source type'
- endif
-
-
-! 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)
-
-! check if acoustic receiver is exactly on the free surface because pressure is zero there
- do ispec_acoustic_surface = 1,nelem_acoustic_surface
- ispec = ispecnum_acoustic_surface(ispec_acoustic_surface)
- iedge = iedgenum_acoustic_surface(ispec_acoustic_surface)
- do irec = 1,nrec
- if(.not. elastic(ispec) .and. ispec == ispec_selected_rec(irec)) then
- if((iedge == IBOTTOM .and. gamma_receiver(irec) < -0.99d0) .or. &
- (iedge == ITOP .and. gamma_receiver(irec) > 0.99d0) .or. &
- (iedge == ILEFT .and. xi_receiver(irec) < -0.99d0) .or. &
- (iedge == IRIGHT .and. xi_receiver(irec) > 0.99d0)) then
- if(seismotype == 4) then
- stop 'an acoustic pressure receiver cannot be located exactly on the free surface because pressure is zero there'
- else
- print *, '**********************************************************************'
- print *, '*** Warning: acoustic receiver located exactly on the free surface ***'
- print *, '*** Warning: tangential component will be zero there ***'
- print *, '**********************************************************************'
- print *
- endif
- endif
- endif
- enddo
- enddo
-
-! define and store Lagrange interpolators at all the receivers
- do irec = 1,nrec
- call lagrange_any(xi_receiver(irec),NGLLX,xigll,hxir,hpxir)
- call lagrange_any(gamma_receiver(irec),NGLLZ,zigll,hgammar,hpgammar)
- hxir_store(irec,:) = hxir(:)
- hgammar_store(irec,:) = hgammar(:)
- enddo
-
-! displacement, velocity, acceleration and inverse of the mass matrix for elastic elements
- if(any_elastic) then
- allocate(displ_elastic(NDIM,npoin))
- allocate(veloc_elastic(NDIM,npoin))
- allocate(accel_elastic(NDIM,npoin))
- allocate(rmass_inverse_elastic(npoin))
- else
-! allocate unused arrays with fictitious size
- allocate(displ_elastic(1,1))
- allocate(veloc_elastic(1,1))
- allocate(accel_elastic(1,1))
- allocate(rmass_inverse_elastic(1))
- endif
-
-! potential, its first and second derivative, and inverse of the mass matrix for acoustic elements
- if(any_acoustic) then
- allocate(potential_acoustic(npoin))
- allocate(potential_dot_acoustic(npoin))
- allocate(potential_dot_dot_acoustic(npoin))
- allocate(rmass_inverse_acoustic(npoin))
- else
-! allocate unused arrays with fictitious size
- allocate(potential_acoustic(1))
- allocate(potential_dot_acoustic(1))
- allocate(potential_dot_dot_acoustic(1))
- allocate(rmass_inverse_acoustic(1))
- endif
-
-!
-!---- build the global mass matrix and invert it once and for all
-!
- if(any_elastic) rmass_inverse_elastic(:) = ZERO
- if(any_acoustic) rmass_inverse_acoustic(:) = ZERO
- do ispec = 1,nspec
- do j = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool(i,j,ispec)
-! if external density model
- if(assign_external_model) then
- rhol = rhoext(i,j,ispec)
- cpsquare = vpext(i,j,ispec)**2
- else
- rhol = density(kmato(ispec))
- lambdal_relaxed = elastcoef(1,kmato(ispec))
- mul_relaxed = elastcoef(2,kmato(ispec))
- cpsquare = (lambdal_relaxed + 2.d0*mul_relaxed) / rhol
- endif
-! for acoustic medium
- if(elastic(ispec)) then
- rmass_inverse_elastic(iglob) = rmass_inverse_elastic(iglob) + wxgll(i)*wzgll(j)*rhol*jacobian(i,j,ispec)
- else
- rmass_inverse_acoustic(iglob) = rmass_inverse_acoustic(iglob) + wxgll(i)*wzgll(j)*jacobian(i,j,ispec) / cpsquare
- endif
- enddo
- enddo
- enddo
-
-! fill mass matrix with fictitious non-zero values to make sure it can be inverted globally
- if(any_elastic) where(rmass_inverse_elastic <= 0.d0) rmass_inverse_elastic = 1.d0
- if(any_acoustic) where(rmass_inverse_acoustic <= 0.d0) rmass_inverse_acoustic = 1.d0
-
-! compute the inverse of the mass matrix
- if(any_elastic) rmass_inverse_elastic(:) = 1 / rmass_inverse_elastic(:)
- if(any_acoustic) rmass_inverse_acoustic(:) = 1 / rmass_inverse_acoustic(:)
-
-! check the mesh, stability and number of points per wavelength
- call checkgrid(vpext,vsext,rhoext,density,elastcoef,ibool,kmato,coord,npoin,vpmin,vpmax, &
- assign_external_model,nspec,numat,deltat,f0,t0,initialfield,time_function_type, &
- coorg,xinterp,zinterp,shape2D_display,knods,simulation_title,npgeo,pointsdisp,ngnod,any_elastic)
-
-! convert receiver angle to radians
- anglerec = anglerec * pi / 180.d0
-
-!
-!---- for color images
-!
-
- if(output_color_image) then
-
-! horizontal size of the image
- xmin_color_image = minval(coord(1,:))
- xmax_color_image = maxval(coord(1,:))
-
-! vertical size of the image, slightly increase it to go beyond maximum topography
- zmin_color_image = minval(coord(2,:))
- zmax_color_image = maxval(coord(2,:))
- zmax_color_image = zmin_color_image + 1.05d0 * (zmax_color_image - zmin_color_image)
-
-! compute number of pixels in the horizontal direction based on typical number
-! of spectral elements in a given direction (may give bad results for very elongated models)
- NX_IMAGE_color = nint(sqrt(dble(npgeo))) * (NGLLX-1) + 1
-
-! compute number of pixels in the vertical direction based on ratio of sizes
- NZ_IMAGE_color = nint(NX_IMAGE_color * (zmax_color_image - zmin_color_image) / (xmax_color_image - xmin_color_image))
-
-! convert pixel sizes to even numbers because easier to reduce size, create MPEG movies in postprocessing
- NX_IMAGE_color = 2 * (NX_IMAGE_color / 2)
- NZ_IMAGE_color = 2 * (NZ_IMAGE_color / 2)
-
-! allocate an array for image data
- allocate(image_color_data(NX_IMAGE_color,NZ_IMAGE_color))
-
-! allocate an array for the grid point that corresponds to a given image data point
- allocate(iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color))
- allocate(copy_iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color))
-
-! create all the pixels
- write(IOUT,*)
- write(IOUT,*) 'locating all the pixels of color images'
-
- size_pixel_horizontal = (xmax_color_image - xmin_color_image) / dble(NX_IMAGE_color-1)
- size_pixel_vertical = (zmax_color_image - zmin_color_image) / dble(NZ_IMAGE_color-1)
-
- iglob_image_color(:,:) = -1
-
-! loop on all the grid points to map them to a pixel in the image
- do n=1,npoin
-
-! compute the coordinates of this pixel
- i = nint((coord(1,n) - xmin_color_image) / size_pixel_horizontal + 1)
- j = nint((coord(2,n) - zmin_color_image) / size_pixel_vertical + 1)
-
-! avoid edge effects
- if(i < 1) i = 1
- if(i > NX_IMAGE_color) i = NX_IMAGE_color
-
- if(j < 1) j = 1
- if(j > NZ_IMAGE_color) j = NZ_IMAGE_color
-
-! assign this point to this pixel
- iglob_image_color(i,j) = n
-
- enddo
-
-! locate missing pixels based on a minimum distance criterion
-! cannot do more than two iterations typically because some pixels must never be found
-! because they do not exist (for instance if they are located above topography)
- do count_passes = 1,2
-
- print *,'pass ',count_passes,' to locate the missing pixels of color images'
-
- copy_iglob_image_color(:,:) = iglob_image_color(:,:)
-
- do j = 1,NZ_IMAGE_color
- do i = 1,NX_IMAGE_color
-
- if(copy_iglob_image_color(i,j) == -1) then
-
- iplus1 = i + 1
- iminus1 = i - 1
-
- jplus1 = j + 1
- jminus1 = j - 1
-
-! avoid edge effects
- if(iminus1 < 1) iminus1 = 1
- if(iplus1 > NX_IMAGE_color) iplus1 = NX_IMAGE_color
-
- if(jminus1 < 1) jminus1 = 1
- if(jplus1 > NZ_IMAGE_color) jplus1 = NZ_IMAGE_color
-
-! use neighbors of this pixel to fill the holes
-
-! horizontal
- if(copy_iglob_image_color(iplus1,j) /= -1) then
- iglob_image_color(i,j) = copy_iglob_image_color(iplus1,j)
-
- else if(copy_iglob_image_color(iminus1,j) /= -1) then
- iglob_image_color(i,j) = copy_iglob_image_color(iminus1,j)
-
-! vertical
- else if(copy_iglob_image_color(i,jplus1) /= -1) then
- iglob_image_color(i,j) = copy_iglob_image_color(i,jplus1)
-
- else if(copy_iglob_image_color(i,jminus1) /= -1) then
- iglob_image_color(i,j) = copy_iglob_image_color(i,jminus1)
-
-! diagonal
- else if(copy_iglob_image_color(iminus1,jminus1) /= -1) then
- iglob_image_color(i,j) = copy_iglob_image_color(iminus1,jminus1)
-
- else if(copy_iglob_image_color(iplus1,jminus1) /= -1) then
- iglob_image_color(i,j) = copy_iglob_image_color(iplus1,jminus1)
-
- else if(copy_iglob_image_color(iminus1,jplus1) /= -1) then
- iglob_image_color(i,j) = copy_iglob_image_color(iminus1,jplus1)
-
- else if(copy_iglob_image_color(iplus1,jplus1) /= -1) then
- iglob_image_color(i,j) = copy_iglob_image_color(iplus1,jplus1)
-
- endif
-
- endif
-
- enddo
- enddo
-
- enddo
-
- deallocate(copy_iglob_image_color)
-
- write(IOUT,*) 'done locating all the pixels of color images'
-
- endif
-
-!
-!---- initialize seismograms
-!
- sisux = ZERO
- sisuz = ZERO
-
- cosrot = cos(anglerec)
- sinrot = sin(anglerec)
-
-! initialize arrays to zero
- displ_elastic = ZERO
- veloc_elastic = ZERO
- accel_elastic = ZERO
-
- potential_acoustic = ZERO
- potential_dot_acoustic = ZERO
- potential_dot_dot_acoustic = ZERO
-
-!
-!---- read initial fields from external file if needed
-!
- if(initialfield) then
- write(IOUT,*)
- write(IOUT,*) 'Reading initial fields from external file...'
- write(IOUT,*)
- if(any_acoustic) stop 'initial field currently implemented for purely elastic simulation only'
- open(unit=55,file='OUTPUT_FILES/wavefields.txt',status='unknown')
- read(55,*) nbpoin
- if(nbpoin /= npoin) stop 'Wrong number of points in input file'
- 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_elastic(:,inump) = displread
- veloc_elastic(:,inump) = velocread
- accel_elastic(:,inump) = accelread
- enddo
- deallocate(displread)
- deallocate(velocread)
- deallocate(accelread)
- close(55)
- write(IOUT,*) 'Max norm of initial elastic displacement = ',maxval(sqrt(displ_elastic(1,:)**2 + displ_elastic(2,:)**2))
- endif
-
- 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))
-
- write(IOUT,*)
- write(IOUT,*) 'Saving the source time function in a text file...'
- write(IOUT,*)
- open(unit=55,file='OUTPUT_FILES/source.txt',status='unknown')
-
-! loop on all the time steps
- 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)
-
-! Heaviside source time function (we use a very thin error function instead)
- else if(time_function_type == 5) then
- hdur = 1.d0 / f0
- hdur_gauss = hdur * 5.d0 / 3.d0
- source_time_function(it) = factor * 0.5d0*(1.0d0+erf(SOURCE_DECAY_RATE*(time-t0)/hdur_gauss))
-
- else
- stop 'unknown source time function'
- endif
-
-! output absolute time in third column, in case user wants to check it as well
- write(55,*) sngl(time),sngl(source_time_function(it)),sngl(time-t0)
-
- enddo
-
- close(55)
-
- else
-
- allocate(source_time_function(1))
-
- endif
-
-!
-!---- check that no element has both acoustic free surface and top absorbing surface
-!
- do ispec_acoustic_surface = 1,nelem_acoustic_surface
- ispec = ispecnum_acoustic_surface(ispec_acoustic_surface)
- iedge = iedgenum_acoustic_surface(ispec_acoustic_surface)
- if(elastic(ispec)) then
- stop 'elastic element detected in acoustic free surface'
- else
- do inum = 1,nelemabs
- if(numabs(inum) == ispec .and. codeabs(iedge,inum)) &
- stop 'acoustic free surface cannot be both absorbing and free'
- enddo
- endif
- enddo
-
-! determine if coupled fluid-solid simulation
- coupled_acoustic_elastic = any_acoustic .and. any_elastic
-
-! fluid/solid edge detection
-! very basic algorithm in O(nspec^2), simple double loop on the elements
-! and then loop on the four corners of each of the two elements, could be signficantly improved
-
- num_fluid_solid_edges_alloc = 0
-
- if(coupled_acoustic_elastic) then
- print *
- print *,'Mixed acoustic/elastic simulation'
- print *
- print *,'Beginning of fluid/solid edge detection (slow algorithm for now, will be improved later)'
-
-! define the edges of a given element
- i_begin(IBOTTOM) = 1
- j_begin(IBOTTOM) = 1
- i_end(IBOTTOM) = NGLLX
- j_end(IBOTTOM) = 1
-
- i_begin(IRIGHT) = NGLLX
- j_begin(IRIGHT) = 1
- i_end(IRIGHT) = NGLLX
- j_end(IRIGHT) = NGLLZ
-
- i_begin(ITOP) = NGLLX
- j_begin(ITOP) = NGLLZ
- i_end(ITOP) = 1
- j_end(ITOP) = NGLLZ
-
- i_begin(ILEFT) = 1
- j_begin(ILEFT) = NGLLZ
- i_end(ILEFT) = 1
- j_end(ILEFT) = 1
-
-! define i and j points for each edge
- do ipoin1D = 1,NGLLX
-
- ivalue(ipoin1D,IBOTTOM) = ipoin1D
- ivalue_inverse(ipoin1D,IBOTTOM) = NGLLX - ipoin1D + 1
- jvalue(ipoin1D,IBOTTOM) = 1
- jvalue_inverse(ipoin1D,IBOTTOM) = 1
-
- ivalue(ipoin1D,IRIGHT) = NGLLX
- ivalue_inverse(ipoin1D,IRIGHT) = NGLLX
- jvalue(ipoin1D,IRIGHT) = ipoin1D
- jvalue_inverse(ipoin1D,IRIGHT) = NGLLZ - ipoin1D + 1
-
- ivalue(ipoin1D,ITOP) = NGLLX - ipoin1D + 1
- ivalue_inverse(ipoin1D,ITOP) = ipoin1D
- jvalue(ipoin1D,ITOP) = NGLLZ
- jvalue_inverse(ipoin1D,ITOP) = NGLLZ
-
- ivalue(ipoin1D,ILEFT) = 1
- ivalue_inverse(ipoin1D,ILEFT) = 1
- jvalue(ipoin1D,ILEFT) = NGLLZ - ipoin1D + 1
- jvalue_inverse(ipoin1D,ILEFT) = ipoin1D
-
- enddo
-
-! double loop on all the elements
- do ispec_acoustic = 1, nspec
- do ispec_elastic = 1, nspec
-
-! one element must be acoustic and the other must be elastic
-! use acoustic element as master to avoid double detection of the same pair (one on each side)
- if(ispec_acoustic /= ispec_elastic .and. .not. elastic(ispec_acoustic) .and. elastic(ispec_elastic)) then
-
-! loop on the four edges of the two elements
- do iedge_acoustic = 1,NEDGES
- do iedge_elastic = 1,NEDGES
-
-! error if the two edges match in direct order
- if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
- ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic) .and. &
- ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
- ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic)) &
- stop 'topology error (non-inverted coupled elements) found in fluid/solid edge detection'
-
-! the two edges can match in inverse order
- if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
- ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic) .and. &
- ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
- ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic)) &
- num_fluid_solid_edges_alloc = num_fluid_solid_edges_alloc + 1
-
- enddo
- enddo
-
- endif
-
- enddo
- enddo
-
- print *,'Number of fluid/solid edges detected in mesh = ',num_fluid_solid_edges_alloc
-
-! allocate arrays for fluid/solid matching
- allocate(fluid_solid_acoustic_ispec(num_fluid_solid_edges_alloc))
- allocate(fluid_solid_acoustic_iedge(num_fluid_solid_edges_alloc))
- allocate(fluid_solid_elastic_ispec(num_fluid_solid_edges_alloc))
- allocate(fluid_solid_elastic_iedge(num_fluid_solid_edges_alloc))
-
-! double loop on all the elements
- print *,'Creating fluid/solid edge topology...'
-
- num_fluid_solid_edges = 0
-
- do ispec_acoustic = 1, nspec
- do ispec_elastic = 1, nspec
-
-! one element must be acoustic and the other must be elastic
-! use acoustic element as master to avoid double detection of the same pair (one on each side)
- if(ispec_acoustic /= ispec_elastic .and. .not. elastic(ispec_acoustic) .and. elastic(ispec_elastic)) then
-
-! loop on the four edges of the two elements
- do iedge_acoustic = 1,NEDGES
- do iedge_elastic = 1,NEDGES
-
-! store the matching topology if the two edges match in inverse order
- if(ibool(i_begin(iedge_acoustic),j_begin(iedge_acoustic),ispec_acoustic) == &
- ibool(i_end(iedge_elastic),j_end(iedge_elastic),ispec_elastic) .and. &
- ibool(i_end(iedge_acoustic),j_end(iedge_acoustic),ispec_acoustic) == &
- ibool(i_begin(iedge_elastic),j_begin(iedge_elastic),ispec_elastic)) then
- num_fluid_solid_edges = num_fluid_solid_edges + 1
- fluid_solid_acoustic_ispec(num_fluid_solid_edges) = ispec_acoustic
- fluid_solid_acoustic_iedge(num_fluid_solid_edges) = iedge_acoustic
- fluid_solid_elastic_ispec(num_fluid_solid_edges) = ispec_elastic
- fluid_solid_elastic_iedge(num_fluid_solid_edges) = iedge_elastic
-! print *,'edge ',iedge_acoustic,' of acoustic element ',ispec_acoustic, &
-! ' is in contact with edge ',iedge_elastic,' of elastic element ',ispec_elastic
- endif
-
- enddo
- enddo
-
- endif
-
- enddo
- enddo
-
- if(num_fluid_solid_edges /= num_fluid_solid_edges_alloc) stop 'error in creation of arrays for fluid/solid matching'
-
-! make sure fluid/solid matching has been perfectly detected: check that the grid points
-! have the same physical coordinates
-! loop on all the coupling edges
-
- print *,'Checking fluid/solid edge topology...'
-
- do inum = 1,num_fluid_solid_edges
-
-! get the edge of the acoustic element
- ispec_acoustic = fluid_solid_acoustic_ispec(inum)
- iedge_acoustic = fluid_solid_acoustic_iedge(inum)
-
-! get the corresponding edge of the elastic element
- ispec_elastic = fluid_solid_elastic_ispec(inum)
- iedge_elastic = fluid_solid_elastic_iedge(inum)
-
-! implement 1D coupling along the edge
- do ipoin1D = 1,NGLLX
-
-! get point values for the elastic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_elastic)
- j = jvalue_inverse(ipoin1D,iedge_elastic)
- iglob = ibool(i,j,ispec_elastic)
-
-! get point values for the acoustic side
- i = ivalue(ipoin1D,iedge_acoustic)
- j = jvalue(ipoin1D,iedge_acoustic)
- iglob2 = ibool(i,j,ispec_acoustic)
-
-! if distance between the two points is not negligible, there is an error, since it should be zero
- if(sqrt((coord(1,iglob) - coord(1,iglob2))**2 + (coord(2,iglob) - coord(2,iglob2))**2) > TINYVAL) &
- stop 'error in fluid/solid coupling buffer'
-
- enddo
-
- enddo
-
- print *,'End of fluid/solid edge detection'
- print *
-
- else
-
-! allocate dummy arrays for fluid/solid matching if purely acoustic or purely elastic
- allocate(fluid_solid_acoustic_ispec(1))
- allocate(fluid_solid_acoustic_iedge(1))
- allocate(fluid_solid_elastic_ispec(1))
- allocate(fluid_solid_elastic_iedge(1))
-
- endif
-
-! default values for acoustic absorbing edges
- ibegin_bottom(:) = 1
- ibegin_top(:) = 1
-
- iend_bottom(:) = NGLLX
- iend_top(:) = NGLLX
-
- jbegin_left(:) = 1
- jbegin_right(:) = 1
-
- jend_left(:) = NGLLZ
- jend_right(:) = NGLLZ
-
-! exclude common points between acoustic absorbing edges and acoustic/elastic matching interfaces
- if(coupled_acoustic_elastic .and. anyabs) then
-
- print *,'excluding common points between acoustic absorbing edges and acoustic/elastic matching interfaces, if any'
-
-! loop on all the absorbing elements
- do ispecabs = 1,nelemabs
-
- ispec = numabs(ispecabs)
-
-! loop on all the coupling edges
- do inum = 1,num_fluid_solid_edges
-
-! get the edge of the acoustic element
- ispec_acoustic = fluid_solid_acoustic_ispec(inum)
- iedge_acoustic = fluid_solid_acoustic_iedge(inum)
-
-! if acoustic absorbing element and acoustic/elastic coupled element is the same
- if(ispec_acoustic == ispec) then
-
- if(iedge_acoustic == IBOTTOM) then
- jbegin_left(ispecabs) = 2
- jbegin_right(ispecabs) = 2
- endif
-
- if(iedge_acoustic == ITOP) then
- jend_left(ispecabs) = NGLLZ - 1
- jend_right(ispecabs) = NGLLZ - 1
- endif
-
- if(iedge_acoustic == ILEFT) then
- ibegin_bottom(ispecabs) = 2
- ibegin_top(ispecabs) = 2
- endif
-
- if(iedge_acoustic == IRIGHT) then
- iend_bottom(ispecabs) = NGLLX - 1
- iend_top(ispecabs) = NGLLX - 1
- endif
-
- endif
-
- enddo
-
- enddo
-
- endif
-
-!
-!---- s t a r t t i m e i t e r a t i o n s
-!
-
- write(IOUT,400)
-
-! count elapsed wall-clock time
- datein = ''
- timein = ''
- zone = ''
-
- call date_and_time(datein,timein,zone,time_values)
-! time_values(3): day of the month
-! time_values(5): hour of the day
-! time_values(6): minutes of the hour
-! time_values(7): seconds of the minute
-! time_values(8): milliseconds of the second
-! this fails if we cross the end of the month
- time_start = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
- 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
-
-! *********************************************************
-! ************* MAIN LOOP OVER THE TIME STEPS *************
-! *********************************************************
-
- do it = 1,NSTEP
-
-! compute current time
- time = (it-1)*deltat
-
-! update displacement using finite-difference time scheme (Newmark)
- if(any_elastic) then
- displ_elastic = displ_elastic + deltat*veloc_elastic + deltatsquareover2*accel_elastic
- veloc_elastic = veloc_elastic + deltatover2*accel_elastic
- accel_elastic = ZERO
- endif
-
- if(any_acoustic) then
-
- potential_acoustic = potential_acoustic + deltat*potential_dot_acoustic + deltatsquareover2*potential_dot_dot_acoustic
- potential_dot_acoustic = potential_dot_acoustic + deltatover2*potential_dot_dot_acoustic
- potential_dot_dot_acoustic = ZERO
-
-! free surface for an acoustic medium
- call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic,ispecnum_acoustic_surface,iedgenum_acoustic_surface, &
- ibool,nelem_acoustic_surface,npoin,nspec)
-
-! *********************************************************
-! ************* compute forces for the acoustic elements
-! *********************************************************
-
- call compute_forces_acoustic(npoin,nspec,nelemabs,numat, &
- iglob_source,ispec_selected_source,source_type,it,NSTEP,anyabs, &
- assign_external_model,initialfield,ibool,kmato,numabs, &
- elastic,codeabs,potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic,density,elastcoef,xix,xiz,gammax,gammaz,jacobian, &
- vpext,vsext,rhoext,source_time_function,hprime_xx,hprimewgll_xx, &
- hprime_zz,hprimewgll_zz,wxgll,wzgll, &
- ibegin_bottom,iend_bottom,ibegin_top,iend_top, &
- jbegin_left,jend_left,jbegin_right,jend_right)
-
- endif ! end of test if any acoustic element
-
-! *********************************************************
-! ************* add coupling with the elastic side
-! *********************************************************
-
- if(coupled_acoustic_elastic) then
-
-! loop on all the coupling edges
- do inum = 1,num_fluid_solid_edges
-
-! get the edge of the acoustic element
- ispec_acoustic = fluid_solid_acoustic_ispec(inum)
- iedge_acoustic = fluid_solid_acoustic_iedge(inum)
-
-! get the corresponding edge of the elastic element
- ispec_elastic = fluid_solid_elastic_ispec(inum)
- iedge_elastic = fluid_solid_elastic_iedge(inum)
-
-! implement 1D coupling along the edge
- do ipoin1D = 1,NGLLX
-
-! get point values for the elastic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_elastic)
- j = jvalue_inverse(ipoin1D,iedge_elastic)
- iglob = ibool(i,j,ispec_elastic)
-
- displ_x = displ_elastic(1,iglob)
- displ_z = displ_elastic(2,iglob)
-
-! get point values for the acoustic side
- i = ivalue(ipoin1D,iedge_acoustic)
- j = jvalue(ipoin1D,iedge_acoustic)
- iglob = ibool(i,j,ispec_acoustic)
-
-! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
-! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
-! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
-! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
-! Blackwell Science, page 110, equation (4.60).
- if(iedge_acoustic == IBOTTOM .or. iedge_acoustic == ITOP) then
- xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = + zxi / jacobian1D
- nz = - xxi / jacobian1D
- else
- xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = + zgamma / jacobian1D
- nz = - xgamma / jacobian1D
- endif
-
-! compute dot product
- displ_n = displ_x*nx + displ_z*nz
-
-! formulation with generalized potential
- weight = jacobian1D * wxgll(i)
-
- potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + weight*displ_n
-
- enddo
-
- enddo
-
- endif
-
-! ************************************************************************************
-! ************* multiply by the inverse of the mass matrix and update velocity
-! ************************************************************************************
-
- if(any_acoustic) then
-
- potential_dot_dot_acoustic = potential_dot_dot_acoustic * rmass_inverse_acoustic
- potential_dot_acoustic = potential_dot_acoustic + deltatover2*potential_dot_dot_acoustic
-
-! free surface for an acoustic medium
- call enforce_acoustic_free_surface(potential_dot_dot_acoustic,potential_dot_acoustic, &
- potential_acoustic,ispecnum_acoustic_surface,iedgenum_acoustic_surface, &
- ibool,nelem_acoustic_surface,npoin,nspec)
- endif
-
-! *********************************************************
-! ************* main solver for the elastic elements
-! *********************************************************
-
- if(any_elastic) &
- call compute_forces_elastic(npoin,nspec,nelemabs,numat,iglob_source, &
- ispec_selected_source,source_type,it,NSTEP,anyabs,assign_external_model, &
- initialfield,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON,angleforce,deltatcube, &
- deltatfourth,twelvedeltat,fourdeltatsquare,ibool,kmato,numabs,elastic,codeabs, &
- accel_elastic,veloc_elastic,displ_elastic,density,elastcoef,xix,xiz,gammax,gammaz, &
- jacobian,vpext,vsext,rhoext,source_time_function,sourcearray,e1_mech1,e11_mech1, &
- e13_mech1,e1_mech2,e11_mech2,e13_mech2,dux_dxl_n,duz_dzl_n,duz_dxl_n,dux_dzl_n, &
- dux_dxl_np1,duz_dzl_np1,duz_dxl_np1,dux_dzl_np1,hprime_xx,hprimewgll_xx, &
- hprime_zz,hprimewgll_zz,wxgll,wzgll)
-
-! *********************************************************
-! ************* add coupling with the acoustic side
-! *********************************************************
-
- if(coupled_acoustic_elastic) then
-
-! loop on all the coupling edges
- do inum = 1,num_fluid_solid_edges
-
-! get the edge of the acoustic element
- ispec_acoustic = fluid_solid_acoustic_ispec(inum)
- iedge_acoustic = fluid_solid_acoustic_iedge(inum)
-
-! get the corresponding edge of the elastic element
- ispec_elastic = fluid_solid_elastic_ispec(inum)
- iedge_elastic = fluid_solid_elastic_iedge(inum)
-
-! implement 1D coupling along the edge
- do ipoin1D = 1,NGLLX
-
-! get point values for the acoustic side, which matches our side in the inverse direction
- i = ivalue_inverse(ipoin1D,iedge_acoustic)
- j = jvalue_inverse(ipoin1D,iedge_acoustic)
- iglob = ibool(i,j,ispec_acoustic)
-
-! get density of the fluid, depending if external density model
- if(assign_external_model) then
- rhol = rhoext(i,j,ispec_acoustic)
- else
- rhol = density(kmato(ispec_acoustic))
- endif
-
-! compute pressure on the fluid/solid edge
- pressure = - rhol * potential_dot_dot_acoustic(iglob)
-
-! get point values for the elastic side
- i = ivalue(ipoin1D,iedge_elastic)
- j = jvalue(ipoin1D,iedge_elastic)
- iglob = ibool(i,j,ispec_elastic)
-
-! compute the 1D Jacobian and the normal to the edge: for their expression see for instance
-! O. C. Zienkiewicz and R. L. Taylor, The Finite Element Method for Solid and Structural Mechanics,
-! Sixth Edition, electronic version, www.amazon.com, p. 204 and Figure 7.7(a),
-! or Y. K. Cheung, S. H. Lo and A. Y. T. Leung, Finite Element Implementation,
-! Blackwell Science, page 110, equation (4.60).
- if(iedge_acoustic == IBOTTOM .or. iedge_acoustic == ITOP) then
- xxi = + gammaz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zxi = - gammax(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xxi**2 + zxi**2)
- nx = + zxi / jacobian1D
- nz = - xxi / jacobian1D
- else
- xgamma = - xiz(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- zgamma = + xix(i,j,ispec_acoustic) * jacobian(i,j,ispec_acoustic)
- jacobian1D = sqrt(xgamma**2 + zgamma**2)
- nx = + zgamma / jacobian1D
- nz = - xgamma / jacobian1D
- endif
-
-! formulation with generalized potential
- weight = jacobian1D * wxgll(i)
-
- accel_elastic(1,iglob) = accel_elastic(1,iglob) + weight*nx*pressure
- accel_elastic(2,iglob) = accel_elastic(2,iglob) + weight*nz*pressure
-
- enddo
-
- enddo
-
- endif
-
-! ************************************************************************************
-! ************* multiply by the inverse of the mass matrix and update velocity
-! ************************************************************************************
-
- if(any_elastic) then
- accel_elastic(1,:) = accel_elastic(1,:) * rmass_inverse_elastic
- accel_elastic(2,:) = accel_elastic(2,:) * rmass_inverse_elastic
- veloc_elastic = veloc_elastic + deltatover2*accel_elastic
- endif
-
-!---- display time step and max of norm of displacement
- if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then
-
- write(IOUT,*)
- if(time >= 1.d-3 .and. time < 1000.d0) then
- write(IOUT,"('Time step number ',i6,' t = ',f9.4,' s')") it,time
- else
- write(IOUT,"('Time step number ',i6,' t = ',1pe12.6,' s')") it,time
- endif
-
- if(any_elastic) then
- displnorm_all = maxval(sqrt(displ_elastic(1,:)**2 + displ_elastic(2,:)**2))
- write(IOUT,*) 'Max norm of vector field in solid = ',displnorm_all
-! check stability of the code in solid, exit if unstable
- if(displnorm_all > STABILITY_THRESHOLD) stop 'code became unstable and blew up in solid'
- endif
-
- if(any_acoustic) then
- displnorm_all = maxval(abs(potential_acoustic(:)))
- write(IOUT,*) 'Max absolute value of scalar field in fluid = ',displnorm_all
-! check stability of the code in fluid, exit if unstable
- if(displnorm_all > STABILITY_THRESHOLD) stop 'code became unstable and blew up in fluid'
- endif
-
- write(IOUT,*)
- endif
-
-! loop on all the receivers to compute and store the seismograms
- do irec = 1,nrec
-
- ispec = ispec_selected_rec(irec)
-
-! compute pressure in this element if needed
- if(seismotype == 4) then
-
- call compute_pressure_one_element(pressure_element,potential_dot_dot_acoustic,displ_elastic,elastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
- numat,kmato,density,elastcoef,vpext,vsext,rhoext,ispec,e1_mech1,e11_mech1, &
- e1_mech2,e11_mech2,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON)
-
- else if(.not. elastic(ispec)) then
-
-! for acoustic medium, compute vector field from gradient of potential for seismograms
- if(seismotype == 1) then
- call compute_vector_one_element(vector_field_element,potential_acoustic,displ_elastic,elastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec)
- else if(seismotype == 2) then
- call compute_vector_one_element(vector_field_element,potential_dot_acoustic,veloc_elastic,elastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec)
- else if(seismotype == 3) then
- call compute_vector_one_element(vector_field_element,potential_dot_dot_acoustic,accel_elastic,elastic, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,ispec)
- endif
-
- endif
-
-! perform the general interpolation using Lagrange polynomials
- valux = ZERO
- valuz = ZERO
-
- do j = 1,NGLLZ
- do i = 1,NGLLX
-
- iglob = ibool(i,j,ispec)
-
- hlagrange = hxir_store(irec,i)*hgammar_store(irec,j)
-
- if(seismotype == 4) then
-
- dxd = pressure_element(i,j)
- dzd = ZERO
-
- else if(.not. elastic(ispec)) then
-
- dxd = vector_field_element(1,i,j)
- dzd = vector_field_element(2,i,j)
-
- else if(seismotype == 1) then
-
- dxd = displ_elastic(1,iglob)
- dzd = displ_elastic(2,iglob)
-
- else if(seismotype == 2) then
-
- dxd = veloc_elastic(1,iglob)
- dzd = veloc_elastic(2,iglob)
-
- else if(seismotype == 3) then
-
- dxd = accel_elastic(1,iglob)
- dzd = accel_elastic(2,iglob)
-
- endif
-
-! compute interpolated field
- valux = valux + dxd*hlagrange
- valuz = valuz + dzd*hlagrange
-
- enddo
- enddo
-
-! rotate seismogram components if needed, except if recording pressure, which is a scalar
- if(seismotype /= 4) then
- sisux(it,irec) = cosrot*valux + sinrot*valuz
- sisuz(it,irec) = - sinrot*valux + cosrot*valuz
- else
- sisux(it,irec) = valux
- sisuz(it,irec) = ZERO
- endif
-
- enddo
-
-!
-!---- display results at given time steps
-!
- if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5 .or. it == NSTEP) then
-
-!
-!---- PostScript display
-!
- if(output_postscript_snapshot) then
-
- write(IOUT,*) 'Writing PostScript file'
-
- if(imagetype == 1) then
-
- write(IOUT,*) 'drawing displacement vector as small arrows...'
-
- call compute_vector_whole_medium(potential_acoustic,displ_elastic,elastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
-
- call plotpost(vector_field_display,coord,vpext,x_source,z_source,st_xval,st_zval, &
- it,deltat,coorg,xinterp,zinterp,shape2D_display, &
- Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
- numabs,codeabs,anyabs,simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
- colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
- boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
- nspec,ngnod,coupled_acoustic_elastic,any_acoustic,plot_lowerleft_corner_only, &
- fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges)
-
- else if(imagetype == 2) then
-
- write(IOUT,*) 'drawing velocity vector as small arrows...'
-
- call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,elastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
-
- call plotpost(vector_field_display,coord,vpext,x_source,z_source,st_xval,st_zval, &
- it,deltat,coorg,xinterp,zinterp,shape2D_display, &
- Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
- numabs,codeabs,anyabs,simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
- colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
- boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
- nspec,ngnod,coupled_acoustic_elastic,any_acoustic,plot_lowerleft_corner_only, &
- fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges)
-
- else if(imagetype == 3) then
-
- write(IOUT,*) 'drawing acceleration vector as small arrows...'
-
- call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,elastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
-
- call plotpost(vector_field_display,coord,vpext,x_source,z_source,st_xval,st_zval, &
- it,deltat,coorg,xinterp,zinterp,shape2D_display, &
- Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
- numabs,codeabs,anyabs,simulation_title,npoin,npgeo,vpmin,vpmax,nrec, &
- colors,numbers,subsamp,imagetype,interpol,meshvect,modelvect, &
- boundvect,assign_external_model,cutsnaps,sizemax_arrows,nelemabs,numat,pointsdisp, &
- nspec,ngnod,coupled_acoustic_elastic,any_acoustic,plot_lowerleft_corner_only, &
- fluid_solid_acoustic_ispec,fluid_solid_acoustic_iedge,num_fluid_solid_edges)
-
- else if(imagetype == 4) then
-
- write(IOUT,*) 'cannot draw scalar pressure field as a vector plot, skipping...'
-
- else
- stop 'wrong type for snapshots'
- endif
-
- if(imagetype /= 4) write(IOUT,*) 'PostScript file written'
-
- endif
-
-!
-!---- display color image
-!
- if(output_color_image) then
-
- write(IOUT,*) 'Creating color image of size ',NX_IMAGE_color,' x ',NZ_IMAGE_color
-
- if(imagetype == 1) then
-
- write(IOUT,*) 'drawing image of vertical component of displacement vector...'
-
- call compute_vector_whole_medium(potential_acoustic,displ_elastic,elastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
-
- else if(imagetype == 2) then
-
- write(IOUT,*) 'drawing image of vertical component of velocity vector...'
-
- call compute_vector_whole_medium(potential_dot_acoustic,veloc_elastic,elastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
-
- else if(imagetype == 3) then
-
- write(IOUT,*) 'drawing image of vertical component of acceleration vector...'
-
- call compute_vector_whole_medium(potential_dot_dot_acoustic,accel_elastic,elastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin)
-
- else if(imagetype == 4) then
-
- write(IOUT,*) 'drawing image of pressure field...'
-
- call compute_pressure_whole_medium(potential_dot_dot_acoustic,displ_elastic,elastic,vector_field_display, &
- xix,xiz,gammax,gammaz,ibool,hprime_xx,hprime_zz,nspec,npoin,assign_external_model, &
- numat,kmato,density,elastcoef,vpext,vsext,rhoext,e1_mech1,e11_mech1, &
- e1_mech2,e11_mech2,TURN_ATTENUATION_ON,TURN_ANISOTROPY_ON)
-
- else
- stop 'wrong type for snapshots'
- endif
-
- image_color_data(:,:) = 0.d0
- do j = 1,NZ_IMAGE_color
- do i = 1,NX_IMAGE_color
- iglob = iglob_image_color(i,j)
-! draw vertical component of field
-! or pressure which is stored in the same array used as temporary storage
- if(iglob /= -1) image_color_data(i,j) = vector_field_display(2,iglob)
- enddo
- enddo
-
- call create_color_image(image_color_data,iglob_image_color,NX_IMAGE_color,NZ_IMAGE_color,it,cutsnaps)
-
- write(IOUT,*) 'Color image created'
-
- endif
-
-!---- save temporary or final seismograms
- call write_seismograms(sisux,sisuz,station_name,network_name,NSTEP, &
- nrec,deltat,seismotype,st_xval,it,t0,buffer_binary_single,buffer_binary_double)
-
-! count elapsed wall-clock time
- call date_and_time(datein,timein,zone,time_values)
-! time_values(3): day of the month
-! time_values(5): hour of the day
-! time_values(6): minutes of the hour
-! time_values(7): seconds of the minute
-! time_values(8): milliseconds of the second
-! this fails if we cross the end of the month
- time_end = 86400.d0*time_values(3) + 3600.d0*time_values(5) + &
- 60.d0*time_values(6) + time_values(7) + time_values(8) / 1000.d0
-
-! elapsed time since beginning of the simulation
- tCPU = time_end - time_start
- int_tCPU = int(tCPU)
- ihours = int_tCPU / 3600
- iminutes = (int_tCPU - 3600*ihours) / 60
- iseconds = int_tCPU - 3600*ihours - 60*iminutes
- write(*,*) 'Elapsed time in seconds = ',tCPU
- write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
- write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
- write(*,*)
-
- endif
-
- enddo ! end of the main time loop
-
-! print exit banner
- call datim(simulation_title)
-
-!
-!---- close output file
-!
- if(IOUT /= ISTANDARD_OUTPUT) close(IOUT)
-
-!
-!---- formats
-!
-
- 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,13('='),//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,13('='),//5x, &
- 'Display frequency . . . (NTSTEP_BETWEEN_OUTPUT_INFO) = ',i6/ 5x, &
- 'Color display . . . . . . . . . . . . . . . (colors) = ',i6/ 5x, &
- ' == 0 black and white display ', / 5x, &
- ' == 1 color display ', /5x, &
- 'Numbered mesh . . . . . . . . . . . . . . .(numbers) = ',i6/ 5x, &
- ' == 0 do not number the mesh ', /5x, &
- ' == 1 number the mesh ')
-
- 700 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
- 'Seismograms recording type . . . . . . .(seismotype) = ',i6/5x, &
- 'Angle for first line of receivers. . . . .(anglerec) = ',f6.2)
-
- 750 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
- 'Read external initial field. . . . . .(initialfield) = ',l6/5x, &
- 'Assign external model . . . .(assign_external_model) = ',l6/5x, &
- 'Turn anisotropy on or off. . . .(TURN_ANISOTROPY_ON) = ',l6/5x, &
- 'Turn attenuation on or off. . .(TURN_ATTENUATION_ON) = ',l6/5x, &
- 'Save grid in external file or not. . . .(outputgrid) = ',l6)
-
- 800 format(//1x,'C o n t r o l',/1x,13('='),//5x, &
- 'Vector display type . . . . . . . . . . .(imagetype) = ',i6/5x, &
- 'Percentage of cut for vector plots . . . .(cutsnaps) = ',f6.2/5x, &
- 'Subsampling for velocity model display. . .(subsamp) = ',i6)
-
- 703 format(//' I t e r a t i o n s '/1x,19('='),//5x, &
- '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 . . .(pointsdisp) =',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. . . . . . . . . . . . . . = Moment-tensor',/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, &
- 'Mxx. . . . . . . . . . . . . . . . . . =',1pe20.10,/5x, &
- 'Mzz. . . . . . . . . . . . . . . . . . =',1pe20.10,/5x, &
- 'Mxz. . . . . . . . . . . . . . . . . . =',1pe20.10)
-
- end program specfem2D
-
Added: seismo/2D/SPECFEM2D/trunk/write_seismograms.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/write_seismograms.F90 2007-06-26 00:32:15 UTC (rev 8521)
+++ seismo/2D/SPECFEM2D/trunk/write_seismograms.F90 2007-12-07 23:53:16 UTC (rev 8522)
@@ -0,0 +1,255 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 5.2
+! ------------------------------
+!
+! Dimitri Komatitsch
+! University of Pau, France
+!
+! (c) April 2007
+!
+!========================================================================
+
+! write seismograms to text files
+
+ subroutine write_seismograms(sisux,sisuz,station_name,network_name, &
+ NSTEP,nrec,deltat,seismotype,st_xval,it,t0,buffer_binary_single,buffer_binary_double)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nrec,NSTEP,it,seismotype
+ 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,irecord,length_station_name,length_network_name,iorientation,isample,number_of_components
+
+ character(len=4) chn
+ character(len=1) component
+ character(len=150) sisname
+
+! to write seismograms in single precision SEP and double precision binary format
+ real(kind=4), dimension(NSTEP*nrec) :: buffer_binary_single
+ double precision, dimension(NSTEP*nrec) :: buffer_binary_double
+
+! scaling factor for Seismic Unix xsu dislay
+ double precision, parameter :: FACTORXSU = 1.d0
+
+!----
+
+! write seismograms in ASCII format
+
+! save displacement, velocity, acceleration or pressure
+ if(seismotype == 1) then
+ component = 'd'
+ else if(seismotype == 2) then
+ component = 'v'
+ else if(seismotype == 3) then
+ component = 'a'
+ else if(seismotype == 4) then
+ component = 'p'
+ else
+ stop 'wrong component to save for seismograms'
+ endif
+
+ do irec = 1,nrec
+
+! only one seismogram if pressurs
+ if(seismotype == 4) then
+ number_of_components = 1
+ else
+ number_of_components = NDIM
+ endif
+
+ do iorientation = 1,number_of_components
+
+ if(iorientation == 1) then
+ chn = 'BHX'
+ else if(iorientation == 2) then
+ chn = 'BHZ'
+ else
+ stop 'incorrect channel value'
+ endif
+
+! in case of pressure, use different abbreviation
+ if(seismotype == 4) chn = 'PRE'
+
+! create the name of the seismogram file for each slice
+! file name includes the name of the station, the network and the component
+ 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,"('OUTPUT_FILES/',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=11,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(11,*) sngl(dble(isample-1)*deltat - t0),' ',sngl(sisux(isample,irec))
+ else
+ write(11,*) sngl(dble(isample-1)*deltat - t0),' ',sngl(sisuz(isample,irec))
+ endif
+ enddo
+
+ close(11)
+
+ enddo
+
+ enddo
+
+!----
+
+! write seismograms in single precision SEP binary format
+
+! X component
+
+! delete the old files
+ open(unit=11,file='OUTPUT_FILES/Ux_file_single.bin',status='unknown')
+ close(11,status='delete')
+
+ open(unit=11,file='OUTPUT_FILES/Ux_file_double.bin',status='unknown')
+ close(11,status='delete')
+
+ open(unit=11,file='OUTPUT_FILES/pressure_file_single.bin',status='unknown')
+ close(11,status='delete')
+
+ open(unit=11,file='OUTPUT_FILES/pressure_file_double.bin',status='unknown')
+ close(11,status='delete')
+
+ irecord = 0
+ do irec=1,nrec
+ do isample=1,NSTEP
+ irecord = irecord + 1
+ buffer_binary_single(irecord) = sngl(sisux(isample,irec))
+ buffer_binary_double(irecord) = sisux(isample,irec)
+ enddo
+ enddo
+
+! write the new files
+ if(seismotype == 4) then
+ open(unit=11,file='OUTPUT_FILES/pressure_file_single.bin',status='unknown',access='direct',recl=4*NSTEP*nrec)
+ else
+ open(unit=11,file='OUTPUT_FILES/Ux_file_single.bin',status='unknown',access='direct',recl=4*NSTEP*nrec)
+ endif
+ write(11,rec=1) buffer_binary_single
+ close(11)
+
+ if(seismotype == 4) then
+ open(unit=11,file='OUTPUT_FILES/pressure_file_double.bin',status='unknown',access='direct',recl=8*NSTEP*nrec)
+ else
+ open(unit=11,file='OUTPUT_FILES/Ux_file_double.bin',status='unknown',access='direct',recl=8*NSTEP*nrec)
+ endif
+ write(11,rec=1) buffer_binary_double
+ close(11)
+
+! Z component
+
+! delete the old files
+ open(unit=11,file='OUTPUT_FILES/Uz_file_single.bin',status='unknown')
+ close(11,status='delete')
+
+ open(unit=11,file='OUTPUT_FILES/Uz_file_double.bin',status='unknown')
+ close(11,status='delete')
+
+! no Z component seismogram if pressurs
+ if(seismotype /= 4) then
+
+ irecord = 0
+ do irec=1,nrec
+ do isample=1,NSTEP
+ irecord = irecord + 1
+ buffer_binary_single(irecord) = sngl(sisuz(isample,irec))
+ buffer_binary_double(irecord) = sisuz(isample,irec)
+ enddo
+ enddo
+
+! write the new files
+ open(unit=11,file='OUTPUT_FILES/Uz_file_single.bin',status='unknown',access='direct',recl=4*NSTEP*nrec)
+ write(11,rec=1) buffer_binary_single
+ close(11)
+
+ open(unit=11,file='OUTPUT_FILES/Uz_file_double.bin',status='unknown',access='direct',recl=8*NSTEP*nrec)
+ write(11,rec=1) buffer_binary_double
+ close(11)
+
+ endif
+
+!----
+
+! ligne de recepteurs pour Xsu
+ open(unit=11,file='OUTPUT_FILES/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,"(f12.5)") st_xval(irec)
+ if(irec < nrec) write(11,*) ','
+ enddo
+
+ if(seismotype == 1) then
+ write(11,*) '@title="Ux at displacement@component"@<@Ux_file_single.bin'
+ else if(seismotype == 2) then
+ write(11,*) '@title="Ux at velocity@component"@<@Ux_file_single.bin'
+ else
+ write(11,*) '@title="Ux at acceleration@component"@<@Ux_file_single.bin'
+ endif
+
+ close(11)
+
+! script de visualisation
+ open(unit=11,file='OUTPUT_FILES/show_receiver_line_Xsu',status='unknown')
+ write(11,"('#!/bin/csh')")
+ 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
+ 110 format('xwigb at xcur=',f8.2,'@n1=',i6,'@d1=',f15.8,'@f1=',f15.8,'@label1="Time@(s)"@label2="x@(m)"@n2=',i6,'@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_single.bin/Ux_file_single.bin > uxpoly.ps/g'' ', &
+ '-e ''1,$s/Uz_file_single.bin/Uz_file_single.bin > uzpoly.ps/g'' receiver_line_Xsu_XWindow > receiver_line_Xsu_postscript')
+
+ end subroutine write_seismograms
+
Deleted: seismo/2D/SPECFEM2D/trunk/write_seismograms.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/write_seismograms.f90 2007-06-26 00:32:15 UTC (rev 8521)
+++ seismo/2D/SPECFEM2D/trunk/write_seismograms.f90 2007-12-07 23:53:16 UTC (rev 8522)
@@ -1,255 +0,0 @@
-
-!========================================================================
-!
-! S P E C F E M 2 D Version 5.2
-! ------------------------------
-!
-! Dimitri Komatitsch
-! University of Pau, France
-!
-! (c) April 2007
-!
-!========================================================================
-
-! write seismograms to text files
-
- subroutine write_seismograms(sisux,sisuz,station_name,network_name, &
- NSTEP,nrec,deltat,seismotype,st_xval,it,t0,buffer_binary_single,buffer_binary_double)
-
- implicit none
-
- include "constants.h"
-
- integer nrec,NSTEP,it,seismotype
- 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,irecord,length_station_name,length_network_name,iorientation,isample,number_of_components
-
- character(len=4) chn
- character(len=1) component
- character(len=150) sisname
-
-! to write seismograms in single precision SEP and double precision binary format
- real(kind=4), dimension(NSTEP*nrec) :: buffer_binary_single
- double precision, dimension(NSTEP*nrec) :: buffer_binary_double
-
-! scaling factor for Seismic Unix xsu dislay
- double precision, parameter :: FACTORXSU = 1.d0
-
-!----
-
-! write seismograms in ASCII format
-
-! save displacement, velocity, acceleration or pressure
- if(seismotype == 1) then
- component = 'd'
- else if(seismotype == 2) then
- component = 'v'
- else if(seismotype == 3) then
- component = 'a'
- else if(seismotype == 4) then
- component = 'p'
- else
- stop 'wrong component to save for seismograms'
- endif
-
- do irec = 1,nrec
-
-! only one seismogram if pressurs
- if(seismotype == 4) then
- number_of_components = 1
- else
- number_of_components = NDIM
- endif
-
- do iorientation = 1,number_of_components
-
- if(iorientation == 1) then
- chn = 'BHX'
- else if(iorientation == 2) then
- chn = 'BHZ'
- else
- stop 'incorrect channel value'
- endif
-
-! in case of pressure, use different abbreviation
- if(seismotype == 4) chn = 'PRE'
-
-! create the name of the seismogram file for each slice
-! file name includes the name of the station, the network and the component
- 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,"('OUTPUT_FILES/',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=11,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(11,*) sngl(dble(isample-1)*deltat - t0),' ',sngl(sisux(isample,irec))
- else
- write(11,*) sngl(dble(isample-1)*deltat - t0),' ',sngl(sisuz(isample,irec))
- endif
- enddo
-
- close(11)
-
- enddo
-
- enddo
-
-!----
-
-! write seismograms in single precision SEP binary format
-
-! X component
-
-! delete the old files
- open(unit=11,file='OUTPUT_FILES/Ux_file_single.bin',status='unknown')
- close(11,status='delete')
-
- open(unit=11,file='OUTPUT_FILES/Ux_file_double.bin',status='unknown')
- close(11,status='delete')
-
- open(unit=11,file='OUTPUT_FILES/pressure_file_single.bin',status='unknown')
- close(11,status='delete')
-
- open(unit=11,file='OUTPUT_FILES/pressure_file_double.bin',status='unknown')
- close(11,status='delete')
-
- irecord = 0
- do irec=1,nrec
- do isample=1,NSTEP
- irecord = irecord + 1
- buffer_binary_single(irecord) = sngl(sisux(isample,irec))
- buffer_binary_double(irecord) = sisux(isample,irec)
- enddo
- enddo
-
-! write the new files
- if(seismotype == 4) then
- open(unit=11,file='OUTPUT_FILES/pressure_file_single.bin',status='unknown',access='direct',recl=4*NSTEP*nrec)
- else
- open(unit=11,file='OUTPUT_FILES/Ux_file_single.bin',status='unknown',access='direct',recl=4*NSTEP*nrec)
- endif
- write(11,rec=1) buffer_binary_single
- close(11)
-
- if(seismotype == 4) then
- open(unit=11,file='OUTPUT_FILES/pressure_file_double.bin',status='unknown',access='direct',recl=8*NSTEP*nrec)
- else
- open(unit=11,file='OUTPUT_FILES/Ux_file_double.bin',status='unknown',access='direct',recl=8*NSTEP*nrec)
- endif
- write(11,rec=1) buffer_binary_double
- close(11)
-
-! Z component
-
-! delete the old files
- open(unit=11,file='OUTPUT_FILES/Uz_file_single.bin',status='unknown')
- close(11,status='delete')
-
- open(unit=11,file='OUTPUT_FILES/Uz_file_double.bin',status='unknown')
- close(11,status='delete')
-
-! no Z component seismogram if pressurs
- if(seismotype /= 4) then
-
- irecord = 0
- do irec=1,nrec
- do isample=1,NSTEP
- irecord = irecord + 1
- buffer_binary_single(irecord) = sngl(sisuz(isample,irec))
- buffer_binary_double(irecord) = sisuz(isample,irec)
- enddo
- enddo
-
-! write the new files
- open(unit=11,file='OUTPUT_FILES/Uz_file_single.bin',status='unknown',access='direct',recl=4*NSTEP*nrec)
- write(11,rec=1) buffer_binary_single
- close(11)
-
- open(unit=11,file='OUTPUT_FILES/Uz_file_double.bin',status='unknown',access='direct',recl=8*NSTEP*nrec)
- write(11,rec=1) buffer_binary_double
- close(11)
-
- endif
-
-!----
-
-! ligne de recepteurs pour Xsu
- open(unit=11,file='OUTPUT_FILES/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,"(f12.5)") st_xval(irec)
- if(irec < nrec) write(11,*) ','
- enddo
-
- if(seismotype == 1) then
- write(11,*) '@title="Ux at displacement@component"@<@Ux_file_single.bin'
- else if(seismotype == 2) then
- write(11,*) '@title="Ux at velocity@component"@<@Ux_file_single.bin'
- else
- write(11,*) '@title="Ux at acceleration@component"@<@Ux_file_single.bin'
- endif
-
- close(11)
-
-! script de visualisation
- open(unit=11,file='OUTPUT_FILES/show_receiver_line_Xsu',status='unknown')
- write(11,"('#!/bin/csh')")
- 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
- 110 format('xwigb at xcur=',f8.2,'@n1=',i6,'@d1=',f15.8,'@f1=',f15.8,'@label1="Time@(s)"@label2="x@(m)"@n2=',i6,'@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_single.bin/Ux_file_single.bin > uxpoly.ps/g'' ', &
- '-e ''1,$s/Uz_file_single.bin/Uz_file_single.bin > uzpoly.ps/g'' receiver_line_Xsu_XWindow > receiver_line_Xsu_postscript')
-
- end subroutine write_seismograms
-
More information about the cig-commits
mailing list