[cig-commits] r8412 - in seismo/2D/SPECFEM2D/trunk: . MAILLE90
SPECFEM90
walter at geodynamics.org
walter at geodynamics.org
Fri Dec 7 15:44:02 PST 2007
Author: walter
Date: 2007-12-07 15:44:01 -0800 (Fri, 07 Dec 2007)
New Revision: 8412
Added:
seismo/2D/SPECFEM2D/trunk/MAILLE90/
seismo/2D/SPECFEM2D/trunk/MAILLE90/Par
seismo/2D/SPECFEM2D/trunk/MAILLE90/circ.f90
seismo/2D/SPECFEM2D/trunk/MAILLE90/interf_paco.dat
seismo/2D/SPECFEM2D/trunk/MAILLE90/maille.f90
seismo/2D/SPECFEM2D/trunk/MAILLE90/maille_non_struct_2.f90
seismo/2D/SPECFEM2D/trunk/MAILLE90/maille_non_struct_3.f90
seismo/2D/SPECFEM2D/trunk/MAILLE90/maille_struct.f90
seismo/2D/SPECFEM2D/trunk/MAILLE90/profilx.dat
seismo/2D/SPECFEM2D/trunk/MAILLE90/profily.dat
seismo/2D/SPECFEM2D/trunk/MAILLE90/topoarticle.dat
seismo/2D/SPECFEM2D/trunk/SPECFEM90/
seismo/2D/SPECFEM2D/trunk/SPECFEM90/Makefile
seismo/2D/SPECFEM2D/trunk/SPECFEM90/calc_energie.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/calcdivcurl.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/calcforce.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/checkgrid.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/checksource.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/contol.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/createnum_fast.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/createnum_slow.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/datim.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/defarrays.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/dirac.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/dircty.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/endw1.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/endw2.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/ezfftf.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/gammaf.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/getelspec.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/getltf.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/getrecepts.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/getspec.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/gmat01.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/hdgll.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/hgll.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/intseq.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/jacg.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/jacobf.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/modifperio.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/modules.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotavs.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotgll.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotpost.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotvect.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/pndleg.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/pnleg.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/pnormj.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/positrec.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/positsource.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/q49shape.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/q49spec.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/qinpspec.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/qmasspec.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/qsumspec.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/ricker.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/setcor.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/specfem.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/storearray.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/writeseis.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/zwgjd.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/zwgljd.f90
Log:
Initial revision
Added: seismo/2D/SPECFEM2D/trunk/MAILLE90/Par
===================================================================
--- seismo/2D/SPECFEM2D/trunk/MAILLE90/Par 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/MAILLE90/Par 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,118 @@
+# ----------------------------------------------------------------
+#
+# This is the parameter file
+# Put variable names first and actual value after 15th column
+#
+# ----------------------------------------------------------------
+<- ->
+#
+# File names and path for different outputs
+#
+title =PML thin slice periodic conditions
+topofile =topoPMLthinslice.dat
+interffile =none
+#
+# geometry of the model (origin lower-left corner = 0,0) and mesh description
+#
+xmin =0.0d0 ! abscissa of left side of the model
+xmax =15.d0 ! abscissa of right side of the model
+nx =20 ! number of elements along X
+nz =100 ! number of elements along Z
+idegpoly =5 ! degre approximation spectrale (nb points - 1)
+ngnod =4 ! nb noeuds de controle pour blocs generes (4 ou 9)
+ratio =0.967741 ! ratio pour separation en deux zones
+initialfield =.false. ! use a plane wave as source or not
+ireadmodel =.false. ! use a plane wave as source or not
+iexec =.true. ! only simulate memory allocation or not
+#
+# absorbing boundaries parameters
+#
+absorbhaut =.false. ! Absorbing boundary active or not
+absorbbas =.false.
+absorbgauche =.false.
+absorbdroite =.false.
+periohaut =.true. ! Periodic boundary active or not
+periogauche =.false.
+#
+# time step parameters
+#
+nt =7500 ! nb total de pas de temps
+dt =2.e-5 ! valeur du pas de temps
+niter =1 ! nb d'iterations de corrector
+#
+# sources parameters
+#
+nbsources =1 ! nb of sources
+isources_surf =.false. ! sources dans le volume ou a la surface
+valseuil =5. ! threshold for maximum frequency of the source
+freqmaxrep =3000. ! maximum frequency for plots of source function
+# source #1
+xs =9.0 ! source location x in meters 4.5
+zs =27.75 ! source location z in meters
+f0 =700.0 ! central source frequency (Hz)
+t0 =0.0015d0 ! time delay of the source in seconds
+source_type =1 ! source type : force=1 or explosion=2
+itimetype =6 ! time type : dirac=7 ricker=6 first_deriv=5
+angle =0. ! angle of the source (for a force only) -90.
+factor =1.d10 ! amplification factor
+#
+# receiver line parameters
+#
+sismos =.true. ! store the seismograms or not
+isamp =5 ! sampling rate for seismogram output
+ienreg_surf =.false. ! enregistrement dans le volume ou a la surface
+isismostype =1 ! record 1=displacement 2=velocity 3=acceleration
+### first line ###
+nrec =2 ! number of receivers
+xdeb =3.75d0 ! first receiver x in meters 10.5
+zdeb =33.75d0 ! first receiver z in meters
+xfin =3.75d0 ! last receiver x in meters
+zfin =33.75d0 ! last receiver z in meters
+anglerec =0.d0 ! angle to rotate the components at the receivers
+irepr =1 ! representation (1=X 2=Z 3=distance)
+### second line (optional) ###
+nrec2 =0 ! number of receivers
+xfin2 =3900.d0 ! last receiver x in meters
+zfin2 =1920.d0 ! last receiver z in meters
+anglerec2 =0.d0 ! angle to rotate the components at the receivers
+###
+factorxsu =3.5 ! factor for Seismic Unix seismograms
+n1ana =1 ! first receiver for analytical solution
+n2ana =50 ! second receiver for analytical solution
+factorana =1.d6 ! factor for analytical solution
+#
+# display parameters
+#
+display =.true. ! display the simulation using PostScript or not
+itaff =200 ! display frequency in time steps
+itfirstaff =5 ! time step of first display
+iaffinfo =40 ! interval in time steps to output some basic info
+ivectplot =.true. ! vector plots or not
+ivecttype =1 ! display 1=displacement 2=velocity 3=acceleration
+cutvect =0.5 ! amplitude min affichee en % pour vector plots
+imeshvect =.true. ! display mesh on vector plots or not
+imodelvect =.false. ! display velocity model on vector plots or not
+iboundvect =.true. ! display boundary conditions on vector plots
+interpol =.false. ! interpolation of the display or not
+iptsdisp =6 ! nb of points for interpolation of the display
+isubsamp =2 ! subsampling of color snapshots
+scalex =1. ! X-scaling du display pour PostScript
+scalez =1. ! Z-scaling du display pour PostScript
+sizemax =1. ! taille de la plus grande fleche en centimetres
+usletter =.true. ! US letter paper or French A4
+orig_x =2.4d0 ! X-axis origin of PostScript plot in centimeters
+orig_z =2.9d0 ! Z-axis origin of PostScript plot in centimeters
+ignuplot =.false. ! generate a GNUPLOT file for the grid
+iavs =.false. ! generate an AVS file for the grid and data
+ioutputgrid =.false. ! save the grid in a text file or not
+compenergy =.false. ! compute the total and potential energy or not
+#
+# velocity and density model (nx,nz)
+#
+nbmodels =2 ! nb de modeles differents (rho,vp,vs) 1400.
+1 0 2200.d0 2000.d0 1154.73d0 0 0
+2 0 2200.d0 2000.d0 1154.73d0 0 0
+nbzone =3 ! nb of zones and model number for each zone
+1 20 1 100 1
+17 20 1 100 2
+1 4 1 100 2
Added: seismo/2D/SPECFEM2D/trunk/MAILLE90/circ.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/MAILLE90/circ.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/MAILLE90/circ.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,830 @@
+!
+!=====================================================================
+!
+! P r e m a i l l e u r - 2 D
+! ---------------------------
+!
+! Version 2.1
+! -----------
+!
+! Dimitri Komatitsch
+!
+! Departement de Sismologie
+! Institut de Physique du Globe de Paris
+!
+! (c) Institut de Physique du Globe de Paris, Octobre 1996
+!
+!=====================================================================
+!
+
+! DK DK Mexico August 1999 : mise a jour format base de donnees
+
+ program circ
+
+ implicit double precision (a-h,o-z)
+
+! max size of the model in elements
+ parameter(mnx=7)
+ parameter(mnz=7)
+
+ parameter(pi=3.141592653589793d0)
+
+! seuil pour considerer deux points comme confondus
+ parameter(rseuil=1.d-2)
+
+! stockage de la grille curvi (x et z)
+ parameter(npoinz1=(4*mnx+1)*(mnz+1))
+ parameter(nelemz1=(4*mnx)*mnz)
+ double precision x1(0:4*mnx,0:mnz)
+ double precision z1(0:4*mnx,0:mnz)
+ parameter(npoinz3=(2*mnx+1)*(4*mnz+1))
+ parameter(nelemz3=(2*mnx)*(4*mnz))
+ double precision x3(0:2*mnx,0:4*mnz)
+ double precision z3(0:2*mnx,0:4*mnz)
+ parameter(npoinz4=(2*mnx+1)*(2*mnz+1))
+ parameter(nelemz4=(2*mnx)*(2*mnz))
+ double precision x4(0:2*mnx,0:2*mnz)
+ double precision z4(0:2*mnx,0:2*mnz)
+
+ parameter(npoinz1b=(2*mnx+1)*(mnz+1))
+ parameter(nelemz1b=(2*mnx)*mnz)
+ double precision x1b(0:2*mnx,0:mnz)
+ double precision z1b(0:2*mnx,0:mnz)
+ parameter(npoinz2b=(mnx+1)*(2*mnz+1))
+ parameter(nelemz2b=mnx*(2*mnz))
+ double precision x2b(0:mnx,0:2*mnz)
+ double precision z2b(0:mnx,0:2*mnz)
+ parameter(npoinz3b=(4*mnx+1)*(4*mnz+1))
+ parameter(nelemz3b=(4*mnx)*(4*mnz))
+ double precision x3b(0:4*mnx,0:4*mnz)
+ double precision z3b(0:4*mnx,0:4*mnz)
+ parameter(npoinz4b=(2*mnx+1)*(2*mnz+1))
+ parameter(nelemz4b=(2*mnx)*(2*mnz))
+ double precision x4b(0:2*mnx,0:2*mnz)
+ double precision z4b(0:2*mnx,0:2*mnz)
+
+! nombre max de points de maillage, et nombre exact d'elements
+ parameter(npoin = npoinz1+npoinz3+npoinz4+ &
+ npoinz1b+npoinz2b+npoinz3b+npoinz4b)
+ parameter(nelem = nelemz1+nelemz3+nelemz4+ &
+ nelemz1b+nelemz2b+nelemz3b+nelemz4b)
+
+! coordonnees geometriques des points
+ double precision xpoint(npoin)
+ double precision zpoint(npoin)
+
+! coordonnees des sommets de chaque element
+ double precision x1e(nelem)
+ double precision z1e(nelem)
+ double precision x2e(nelem)
+ double precision z2e(nelem)
+ double precision x3e(nelem)
+ double precision z3e(nelem)
+ double precision x4e(nelem)
+ double precision z4e(nelem)
+
+! numero des points des elements
+ integer numpoin1(nelem)
+ integer numpoin2(nelem)
+ integer numpoin3(nelem)
+ integer numpoin4(nelem)
+
+! nom du fichier GNUPLOT contenant la grille
+ character file1*50
+ character title*50
+ character external_mod*50
+
+ logical iexternal, aleatoire, topoplane, simulate, absstacey
+ logical absorbhaut, absorbbas, absorbgauche, sismos
+ logical absorbdroite, absorbstacey, absorbmodar, ifullabs
+
+ logical display, ignuplot, ivectplot, icolorplot, imeshvect
+ logical imeshcolor, imodelvect, iboundvect, interpol, isymbols, initialfield
+ logical usletter,compenergy
+
+ print *,'Nombre d''elements = ',nelem
+ print *,'Nombre max de points = ',npoin
+
+ nx = mnx
+ nz = mnz
+
+ R = 1.
+
+! ***************************************
+! *** ZONE DE DROITE
+! ***************************************
+
+! generer les points de base de l'interpolation lineaire (zone 1)
+ theta_init = 3 * pi / 2.
+ delta_theta = pi / 2.
+ do i=0,4*nx
+
+! --- point de depart
+ if(i < 2*nx) then
+ x1(i,0) = 2.*R * real(i) / real(2*nx)
+ z1(i,0) = - 2.*R
+ else
+ x1(i,0) = 2.*R
+ z1(i,0) = - 2.*R * (1. - real(i - 2*nx) / real(2*nx))
+ endif
+
+! --- point d'arrivee
+ theta_i = theta_init + delta_theta * real(i) / real(4*nx)
+ x1(i,nz) = dcos(theta_i)
+ z1(i,nz) = dsin(theta_i)
+
+! --- points intermediaires par interpolation lineaire
+ do j=1,nz-1
+ eta_j = real(j) / real(nz)
+ x1(i,j) = (1.-eta_j)*x1(i,0) + eta_j*x1(i,nz)
+ z1(i,j) = (1.-eta_j)*z1(i,0) + eta_j*z1(i,nz)
+ enddo
+ enddo
+
+! generer zone de gauche (zone 3)
+ do i=0,2*nx
+ do j=0,4*nz
+ x3(i,j) = 5. * real(i) / real(2*nx) + 2.
+ if(j <= 2*nz) then
+ z3(i,j) = 7. * real(j) / real(2*nz) - 9.
+ else
+ z3(i,j) = 2. * real(j-2*nz) / real(2*nz) - 2.
+ endif
+ enddo
+ enddo
+
+! generer zone du bas (zone 4)
+ do i=0,2*nx
+ do j=0,2*nz
+ x4(i,j) = 2. * real(i) / real(2*nx)
+ z4(i,j) = 7. * real(j) / real(2*nz) - 9.
+ enddo
+ enddo
+
+! ***************************************
+! *** ZONE DE GAUCHE
+! ***************************************
+
+! generer les points de base de l'interpolation lineaire (zone 1)
+ theta_init = pi / 4.
+ delta_theta = pi / 4.
+ do i=0,2*nx
+! --- point de depart
+ x1b(i,0) = 2.*R * (real(i) / real(2*nx) - 1.)
+ z1b(i,0) = - 2.*R
+
+! --- point d'arrivee
+ theta_i = theta_init + delta_theta * real(i) / real(2*nx)
+ x1b(i,nz) = - dcos(theta_i)
+ z1b(i,nz) = - dsin(theta_i)
+
+! --- points intermediaires par interpolation lineaire
+ do j=1,nz-1
+ eta_j = real(j) / real(nz)
+ x1b(i,j) = (1.-eta_j)*x1b(i,0) + eta_j*x1b(i,nz)
+ z1b(i,j) = (1.-eta_j)*z1b(i,0) + eta_j*z1b(i,nz)
+ enddo
+ enddo
+
+! generer les points de base de l'interpolation lineaire (zone 2)
+ theta_init = pi / 4.
+ do j=0,2*nz
+! --- point de depart
+ x2b(0,j) = - 2.*R
+ z2b(0,j) = 2.*R * (real(j) / real(2*nz) - 1.)
+
+! --- point d'arrivee
+ theta_i = theta_init - &
+ delta_theta * real(j) / real(2*nz)
+ x2b(nx,j) = - dcos(theta_i)
+ z2b(nx,j) = - dsin(theta_i)
+
+! --- points intermediaires par interpolation lineaire
+ do i=1,nx-1
+ eta_j = real(i) / real(nx)
+ x2b(i,j) = (1.-eta_j)*x2b(0,j) + eta_j*x2b(nx,j)
+ z2b(i,j) = (1.-eta_j)*z2b(0,j) + eta_j*z2b(nx,j)
+ enddo
+
+ enddo
+
+! generer zone de gauche (zone 3)
+ do i=0,4*nx
+ do j=0,4*nz
+ x3b(i,j) = 10. * real(i) / real(4*nx) - 12.
+ if(j <= 2*nz) then
+ z3b(i,j) = 7. * real(j) / real(2*nz) - 9.
+ else
+ z3b(i,j) = 2. * real(j-2*nz) / real(2*nz) - 2.
+ endif
+ enddo
+ enddo
+
+! generer zone du bas (zone 4)
+ do i=0,2*nx
+ do j=0,2*nz
+ x4b(i,j) = 2. * real(i) / real(2*nx) - 2.
+ z4b(i,j) = 7. * real(j) / real(2*nz) - 9.
+ enddo
+ enddo
+
+! ***
+! *** generer un fichier 'GNUPLOT' pour le controle de la grille ***
+! ***
+
+ write(*,*)' '
+ write(*,*)' Ecriture de la grille format GNUPLOT...'
+
+ file1='grid.GNU'
+
+ open(unit=20,file=file1,status='unknown')
+
+! *** dessiner la zone 1
+ do j=0,nz
+ do i=0,4*nx-1
+ write(20,*) real(x1(i,j)),real(z1(i,j))
+ write(20,*) real(x1(i+1,j)),real(z1(i+1,j))
+ write(20,100)
+ enddo
+ enddo
+
+ do i=0,4*nx
+ do j=0,nz-1
+ write(20,*) real(x1(i,j)),real(z1(i,j))
+ write(20,*) real(x1(i,j+1)),real(z1(i,j+1))
+ write(20,100)
+ enddo
+ enddo
+
+! *** dessiner la zone 3
+ do j=0,4*nz
+ do i=0,2*nx-1
+ write(20,*) real(x3(i,j)),real(z3(i,j))
+ write(20,*) real(x3(i+1,j)),real(z3(i+1,j))
+ write(20,100)
+ enddo
+ enddo
+
+ do i=0,2*nx
+ do j=0,4*nz-1
+ write(20,*) real(x3(i,j)),real(z3(i,j))
+ write(20,*) real(x3(i,j+1)),real(z3(i,j+1))
+ write(20,100)
+ enddo
+ enddo
+
+! *** dessiner la zone 4
+ do j=0,2*nz
+ do i=0,2*nx-1
+ write(20,*) real(x4(i,j)),real(z4(i,j))
+ write(20,*) real(x4(i+1,j)),real(z4(i+1,j))
+ write(20,100)
+ enddo
+ enddo
+
+ do i=0,2*nx
+ do j=0,2*nz-1
+ write(20,*) real(x4(i,j)),real(z4(i,j))
+ write(20,*) real(x4(i,j+1)),real(z4(i,j+1))
+ write(20,100)
+ enddo
+ enddo
+
+! *** dessiner la zone 1
+ do j=0,nz
+ do i=0,2*nx-1
+ write(20,*) real(x1b(i,j)),real(z1b(i,j))
+ write(20,*) real(x1b(i+1,j)),real(z1b(i+1,j))
+ write(20,100)
+ enddo
+ enddo
+
+ do i=0,2*nx
+ do j=0,nz-1
+ write(20,*) real(x1b(i,j)),real(z1b(i,j))
+ write(20,*) real(x1b(i,j+1)),real(z1b(i,j+1))
+ write(20,100)
+ enddo
+ enddo
+
+! *** dessiner la zone 2
+ do j=0,2*nz
+ do i=0,nx-1
+ write(20,*) real(x2b(i,j)),real(z2b(i,j))
+ write(20,*) real(x2b(i+1,j)),real(z2b(i+1,j))
+ write(20,100)
+ enddo
+ enddo
+
+ do i=0,nx
+ do j=0,2*nz-1
+ write(20,*) real(x2b(i,j)),real(z2b(i,j))
+ write(20,*) real(x2b(i,j+1)),real(z2b(i,j+1))
+ write(20,100)
+ enddo
+ enddo
+
+! *** dessiner la zone 3
+ do j=0,4*nz
+ do i=0,4*nx-1
+ write(20,*) real(x3b(i,j)),real(z3b(i,j))
+ write(20,*) real(x3b(i+1,j)),real(z3b(i+1,j))
+ write(20,100)
+ enddo
+ enddo
+
+ do i=0,4*nx
+ do j=0,4*nz-1
+ write(20,*) real(x3b(i,j)),real(z3b(i,j))
+ write(20,*) real(x3b(i,j+1)),real(z3b(i,j+1))
+ write(20,100)
+ enddo
+ enddo
+
+! *** dessiner la zone 4
+ do j=0,2*nz
+ do i=0,2*nx-1
+ write(20,*) real(x4b(i,j)),real(z4b(i,j))
+ write(20,*) real(x4b(i+1,j)),real(z4b(i+1,j))
+ write(20,100)
+ enddo
+ enddo
+
+ do i=0,2*nx
+ do j=0,2*nz-1
+ write(20,*) real(x4b(i,j)),real(z4b(i,j))
+ write(20,*) real(x4b(i,j+1)),real(z4b(i,j+1))
+ write(20,100)
+ enddo
+ enddo
+
+ close(20)
+
+ write(*,*)' Fin ecriture de la grille format GNUPLOT'
+ write(*,*)' '
+
+ 100 format('')
+
+! ***
+! *** generer la liste des points geometriques
+! ***
+
+ numerocourant = 1
+
+! *** zone 1
+ do j=0,nz
+ do i=0,4*nx
+ xpoint(numerocourant) = x1(i,j)
+ zpoint(numerocourant) = z1(i,j)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 3
+ do j=0,4*nz
+ do i=0,2*nx
+ xpoint(numerocourant) = x3(i,j)
+ zpoint(numerocourant) = z3(i,j)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 4
+ do j=0,2*nz
+ do i=0,2*nx
+ xpoint(numerocourant) = x4(i,j)
+ zpoint(numerocourant) = z4(i,j)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 1
+ do j=0,nz
+ do i=0,2*nx
+ xpoint(numerocourant) = x1b(i,j)
+ zpoint(numerocourant) = z1b(i,j)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 2
+ do j=0,2*nz
+ do i=0,nx
+ xpoint(numerocourant) = x2b(i,j)
+ zpoint(numerocourant) = z2b(i,j)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 3
+ do j=0,4*nz
+ do i=0,4*nx
+ xpoint(numerocourant) = x3b(i,j)
+ zpoint(numerocourant) = z3b(i,j)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 4
+ do j=0,2*nz
+ do i=0,2*nx
+ xpoint(numerocourant) = x4b(i,j)
+ zpoint(numerocourant) = z4b(i,j)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+ print *,'nb de points stockes = ',numerocourant - 1
+
+! ***
+! *** generer la liste des elements
+! ***
+
+ numerocourant = 1
+ imaxabs = 0
+
+! *** zone 1
+ do j=0,nz-1
+ do i=0,4*nx-1
+ x1e(numerocourant) = x1(i,j)
+ z1e(numerocourant) = z1(i,j)
+ x2e(numerocourant) = x1(i+1,j)
+ z2e(numerocourant) = z1(i+1,j)
+ x3e(numerocourant) = x1(i+1,j+1)
+ z3e(numerocourant) = z1(i+1,j+1)
+ x4e(numerocourant) = x1(i,j+1)
+ z4e(numerocourant) = z1(i,j+1)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 3
+ do j=0,4*nz-1
+ do i=0,2*nx-1
+ x1e(numerocourant) = x3(i,j)
+ z1e(numerocourant) = z3(i,j)
+ x2e(numerocourant) = x3(i+1,j)
+ z2e(numerocourant) = z3(i+1,j)
+ x3e(numerocourant) = x3(i+1,j+1)
+ z3e(numerocourant) = z3(i+1,j+1)
+ x4e(numerocourant) = x3(i,j+1)
+ z4e(numerocourant) = z3(i,j+1)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 4
+ do j=0,2*nz-1
+ do i=0,2*nx-1
+ x1e(numerocourant) = x4(i,j)
+ z1e(numerocourant) = z4(i,j)
+ x2e(numerocourant) = x4(i+1,j)
+ z2e(numerocourant) = z4(i+1,j)
+ x3e(numerocourant) = x4(i+1,j+1)
+ z3e(numerocourant) = z4(i+1,j+1)
+ x4e(numerocourant) = x4(i,j+1)
+ z4e(numerocourant) = z4(i,j+1)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 1
+ do j=0,nz-1
+ do i=0,2*nx-1
+ x1e(numerocourant) = x1b(i,j)
+ z1e(numerocourant) = z1b(i,j)
+ x2e(numerocourant) = x1b(i+1,j)
+ z2e(numerocourant) = z1b(i+1,j)
+ x3e(numerocourant) = x1b(i+1,j+1)
+ z3e(numerocourant) = z1b(i+1,j+1)
+ x4e(numerocourant) = x1b(i,j+1)
+ z4e(numerocourant) = z1b(i,j+1)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 2
+ do j=0,2*nz-1
+ do i=0,nx-1
+ x1e(numerocourant) = x2b(i,j)
+ z1e(numerocourant) = z2b(i,j)
+ x2e(numerocourant) = x2b(i+1,j)
+ z2e(numerocourant) = z2b(i+1,j)
+ x3e(numerocourant) = x2b(i+1,j+1)
+ z3e(numerocourant) = z2b(i+1,j+1)
+ x4e(numerocourant) = x2b(i,j+1)
+ z4e(numerocourant) = z2b(i,j+1)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 3
+ do j=0,4*nz-1
+ do i=0,4*nx-1
+ x1e(numerocourant) = x3b(i,j)
+ z1e(numerocourant) = z3b(i,j)
+ x2e(numerocourant) = x3b(i+1,j)
+ z2e(numerocourant) = z3b(i+1,j)
+ x3e(numerocourant) = x3b(i+1,j+1)
+ z3e(numerocourant) = z3b(i+1,j+1)
+ x4e(numerocourant) = x3b(i,j+1)
+ z4e(numerocourant) = z3b(i,j+1)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+! *** zone 4
+ do j=0,2*nz-1
+ do i=0,2*nx-1
+ x1e(numerocourant) = x4b(i,j)
+ z1e(numerocourant) = z4b(i,j)
+ x2e(numerocourant) = x4b(i+1,j)
+ z2e(numerocourant) = z4b(i+1,j)
+ x3e(numerocourant) = x4b(i+1,j+1)
+ z3e(numerocourant) = z4b(i+1,j+1)
+ x4e(numerocourant) = x4b(i,j+1)
+ z4e(numerocourant) = z4b(i,j+1)
+ numerocourant = numerocourant + 1
+ enddo
+ enddo
+
+ print *,'nb d''elements stockes = ',numerocourant - 1
+
+! ***
+! *** creation des elements sous forme topologique
+! ***
+
+ write(*,*)' '
+ write(*,*)' Creation de la topologie des elements...'
+
+ file1='topoelements.txt'
+
+ do i=1,nelem
+
+! recherche point 1
+ do j=1,npoin
+ dist = dsqrt((x1e(i)-xpoint(j))**2 + &
+ (z1e(i)-zpoint(j))**2)
+ if(dist <= rseuil) then
+ nump1 = j
+ goto 401
+ endif
+ enddo
+ stop 'point not found !'
+ 401 continue
+
+! recherche point 2
+ do j=1,npoin
+ dist = dsqrt((x2e(i)-xpoint(j))**2 + &
+ (z2e(i)-zpoint(j))**2)
+ if(dist <= rseuil) then
+ nump2 = j
+ goto 402
+ endif
+ enddo
+ stop 'point not found !'
+ 402 continue
+
+! recherche point 3
+ do j=1,npoin
+ dist = dsqrt((x3e(i)-xpoint(j))**2 + &
+ (z3e(i)-zpoint(j))**2)
+ if(dist <= rseuil) then
+ nump3 = j
+ goto 403
+ endif
+ enddo
+ stop 'point not found !'
+ 403 continue
+
+! recherche point 4
+ do j=1,npoin
+ dist = dsqrt((x4e(i)-xpoint(j))**2 + &
+ (z4e(i)-zpoint(j))**2)
+ if(dist <= rseuil) then
+ nump4 = j
+ goto 404
+ endif
+ enddo
+ stop 'point not found !'
+ 404 continue
+
+ numpoin1(i) = nump1
+ numpoin2(i) = nump2
+ numpoin3(i) = nump3
+ numpoin4(i) = nump4
+
+ enddo
+
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+! *** generation de la base de donnees
+
+ write(*,*)
+ write(*,*) 'Generation de la base de donnees...'
+
+ open(unit=15,file='../SPECFEM90/DataBase',status='unknown')
+
+ title = 'Modele Canyon Paco'
+ write(15,*) '#'
+ write(15,*) '# Base de Donnees pour Specfem - Premailleur Fortran 90'
+ write(15,*) '# ',title
+ write(15,*) '# Dimitri Komatitsch, (c) EPS - Harvard February 1998'
+ write(15,*) '#'
+
+ write(15,*) 'Titre simulation'
+ write(15,40) title
+
+ ndofn = 2
+ ndime = 2
+ ngnod = 4
+ nnode = 4
+ nbcnd = 0
+ nofst = 0
+ npgeo = npoin
+ nspel = nelem
+ nbmodeles = 1
+ nbsources = 1
+ nrec = 150
+ lquad = 1
+ iexternal = .false.
+ aleatoire = .false.
+ topoplane = .false.
+ simulate = .false.
+
+ absorbhaut = .false.
+ absorbbas = .false.
+ absorbgauche = .false.
+ absorbdroite = .false.
+ absorbstacey = .true.
+ absorbmodar = .false.
+ ifullabs = .false.
+
+ sismos = .true.
+ isamp = 20
+ nrec1 = nrec
+ nrec2 = 0
+ anglerec = 0.
+ anglerec2 = 0.
+ irepr = 1
+ nrecsur3 = nrec / 3
+
+ nt = 20000
+ dt = 0.625e-3
+ niter = 1
+ alphanewm = 0.
+ betanewm = 0.
+ gammanewm = 0.5
+ display = .true.
+ ignuplot = .false.
+ ivectplot = .true.
+ icolorplot = .false.
+ imeshvect = .true.
+ imeshcolor = .false.
+ imodelvect = .false.
+ iboundvect = .false.
+ interpol = .true.
+ isymbols = .true.
+
+!! DK DK Mexico August 1999, temporarily suppress external field
+ initialfield = .true.
+ initialfield = .false.
+
+ itaff = 2000
+ itfirstaff = 5
+ cutvect = 1.
+ cutcolor = 2.2
+ scalex = 1.
+ scalez = 1.
+ sizemax = 1.
+ iptsdisp = 7
+ isubsamp = 2
+ orig_x = 2.3
+ orig_z = 3.4
+ factorana = 50000.
+ factorxsu = 3.5
+ n1ana = 1
+ n2ana = nrec1
+
+ write(15,*) 'ndofn ndime npgeo'
+ write(15,*) ndofn,ndime,npgeo
+
+ write(15,*) 'display ignuplot interpol'
+ write(15,*) display,ignuplot,interpol
+
+ write(15,*) 'itaff itfirstaff icolor inumber'
+ write(15,*) itaff,itfirstaff,0,0
+
+ write(15,*) 'ivectplot imeshvect imodelvect iboundvect cutvect isubsamp'
+ write(15,*) ivectplot,imeshvect,imodelvect,iboundvect,cutvect,isubsamp
+
+ usletter = .true.
+ write(15,*) 'scalex scalez sizemax angle rapport USletter'
+ write(15,*) scalex,scalez,sizemax,20.,0.40,usletter
+
+ write(15,*) 'orig_x orig_z isymbols'
+ write(15,*) orig_x,orig_z,isymbols
+
+ valseuil = 5.00
+ freqmaxrep = 100.
+ write(15,*) 'valseuil freqmaxrep'
+ write(15,*) valseuil,freqmaxrep
+
+ write(15,*) 'sismos nrec nrec1 nrec2 isamp'
+ write(15,*) sismos,nrec,nrec1,nrec2,isamp
+
+ write(15,*) 'irepr anglerec anglerec2'
+ write(15,*) irepr,anglerec,anglerec2
+
+ compenergy = .false.
+ absstacey = .true.
+ write(15,*) 'topoplane absstacey compenergy'
+ write(15,*) topoplane,absstacey,compenergy
+
+ write(15,*) 'initialfield factorana factorxsu n1ana n2ana'
+ write(15,*) initialfield,factorana,factorxsu,n1ana,n2ana
+
+ write(15,*) 'isismostype ivecttype iaffinfo'
+ write(15,*) '1, 1, 40'
+ write(15,*) 'ireadmodel ioutputgrid iavs ivisual3'
+ write(15,*) 'F, F, F, F'
+
+ write(15,*) 'iexec iecho'
+ write(15,*) '1 1'
+
+ write(15,*) 'ncycl dtinc niter'
+ write(15,*) nt,dt,niter
+
+ write(15,*) 'alpha beta gamma'
+ write(15,*) alphanewm,betanewm,gammanewm
+
+ nbsources = 1
+ write(15,*) 'nltfl (number of force or pressure sources)'
+ write(15,*) nbsources
+
+ itimetype = 6
+ isource_type = 2
+ f0 = 2.
+ t0 = 0.55
+ xs = +1.
+ zs = -2.
+ angle = 0.
+ factor = 1.
+ xoffs = 12.
+ zoffs = 9.
+ write(15,*) 'Collocated forces and/or pressure sources:'
+ write(15,*) itimetype,isource_type, &
+ xs+xoffs,zs+zoffs,f0,t0,factor,angle,0
+
+ write(15,*) 'Receivers (number, angle, position in meters)'
+ do irec=1,nrec
+ if(irec <= nrecsur3) then
+ xrec = 2.*dble(irec-1)/dble(nrecsur3-1) + 9.
+ zrec = 9.
+ else if(irec >= 2*nrecsur3) then
+ xrec = 2.*dble(irec-2*nrecsur3)/dble(nrecsur3) + 13.
+ zrec = 9.
+ else
+ angle = pi + pi*dble(irec-nrecsur3)/dble(nrecsur3)
+ xrec = 12. + dcos(angle)
+ zrec = 9. + dsin(angle)
+ endif
+ write(15,*) irec,xrec,zrec
+ enddo
+
+ write(15,*) 'Coordinates of spectral control points'
+ do i=1,npoin
+ write(15,*) i,xpoint(i)+xoffs,zpoint(i)+zoffs
+ enddo
+
+ netyp = 2
+ nxgll = 6
+ nelemperio = 0
+ nelemabs = 0
+
+ write(15,*) 'params spectraux'
+ write(15,*) netyp,nbmodeles,ngnod,nxgll,nxgll,nspel,iptsdisp, &
+ nelemabs,nelemperio
+
+ write(15,*) 'Material sets (num 0 rho vp vs 0 0)'
+ rho = 1.
+ cp = 2.
+ cs = 1.
+ write(15,*) nbmodeles,0,rho,cp,cs,0,0
+
+ write(15,*) 'Spectral elements topology'
+
+ imatnum = 1
+
+ do i=1,nspel
+ write(15,*) i,imatnum,numpoin1(i),numpoin2(i),numpoin3(i), &
+ numpoin4(i)
+ enddo
+
+ close(15)
+
+ 40 format(a50)
+
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+ end program circ
Added: seismo/2D/SPECFEM2D/trunk/MAILLE90/interf_paco.dat
===================================================================
--- seismo/2D/SPECFEM2D/trunk/MAILLE90/interf_paco.dat 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/MAILLE90/interf_paco.dat 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,212 @@
+ 211
+ 0. 4000.0000000000
+ 33.333333333333 4000.0000000000
+ 66.666666666667 4000.0000000000
+ 100.000000000000 4000.0000000000
+ 133.33333333333 4000.0000000000
+ 166.66666666667 4000.0000000000
+ 200.00000000000 4000.0000000000
+ 233.33333333333 4000.0000000000
+ 266.66666666667 4000.0000000000
+ 300.00000000000 4000.0000000000
+ 333.33333333333 4000.0000000000
+ 366.66666666667 4000.0000000000
+ 400.00000000000 4000.0000000000
+ 433.33333333333 4000.0000000000
+ 466.66666666667 4000.0000000000
+ 500.00000000000 4000.0000000000
+ 533.33333333333 4000.0000000000
+ 566.66666666667 4000.0000000000
+ 600.00000000000 4000.0000000000
+ 633.33333333333 4000.0000000000
+ 666.66666666667 4000.0000000000
+ 700.00000000000 4000.0000000000
+ 733.33333333333 4000.0000000000
+ 766.66666666667 4000.0000000000
+ 800.00000000000 4000.0000000000
+ 833.33333333333 4000.0000000000
+ 866.66666666667 4000.0000000000
+ 900.00000000000 4000.0000000000
+ 933.33333333333 4000.0000000000
+ 966.66666666667 4000.0000000000
+ 1000.00000000000 4000.0000000000
+ 1033.3333333333 4000.0000000000
+ 1066.6666666667 4000.0000000000
+ 1100.0000000000 4000.0000000000
+ 1133.3333333333 4000.0000000000
+ 1166.6666666667 4000.0000000000
+ 1200.0000000000 4000.0000000000
+ 1233.3333333333 4000.0000000000
+ 1266.6666666667 4000.0000000000
+ 1300.0000000000 4000.0000000000
+ 1333.3333333333 4000.0000000000
+ 1366.6666666667 4000.0000000000
+ 1400.0000000000 4000.0000000000
+ 1433.3333333333 4000.0000000000
+ 1466.6666666667 4000.0000000000
+ 1500.0000000000 4000.0000000000
+ 1533.3333333333 4000.0000000000
+ 1566.6666666667 4000.0000000000
+ 1600.0000000000 4000.0000000000
+ 1633.3333333333 4000.0000000000
+ 1666.6666666667 4000.0000000000
+ 1700.0000000000 4000.0000000000
+ 1733.3333333333 4000.0000000000
+ 1766.6666666667 4000.0000000000
+ 1800.0000000000 4000.0000000000
+ 1833.3333333333 4000.0000000000
+ 1866.6666666667 4000.0000000000
+ 1900.0000000000 4000.0000000000
+ 1933.3333333333 4000.0000000000
+ 1966.6666666667 4000.0000000000
+ 2000.0000000000 4000.0000000000
+ 2033.3333333333 4000.0000000000
+ 2066.6666666667 4000.0000000000
+ 2100.0000000000 4000.0000000000
+ 2133.3333333333 4000.0000000000
+ 2166.6666666667 4000.0000000000
+ 2200.0000000000 4000.0000000000
+ 2233.3333333333 4000.0000000000
+ 2266.6666666667 4000.0000000000
+ 2300.0000000000 4000.0000000000
+ 2333.3333333333 4000.0000000000
+ 2366.6666666667 4000.0000000000
+ 2400.0000000000 4000.0000000000
+ 2433.3333333333 4000.0000000000
+ 2466.6666666667 4000.0000000000
+ 2500.0000000000 4000.0000000000
+ 2533.3333333333 3998.6304738452
+ 2566.6666666667 3994.5369001959
+ 2600.0000000000 3987.7641291015
+ 2633.3333333333 3978.3863644593
+ 2666.6666666667 3966.5063510209
+ 2700.0000000000 3952.2542486992
+ 2733.3333333333 3935.7862065095
+ 2766.6666666667 3917.2826517676
+ 2800.0000000000 3896.9463132909
+ 2833.3333333333 3875.0000002591
+ 2866.6666666667 3851.6841610696
+ 2900.0000000000 3827.2542489351
+ 2933.3333333333 3801.9779230848
+ 2966.6666666667 3776.1321162334
+ 3000.0000000000 3750.0000004487
+ 3033.3333333333 3723.8678846591
+ 3066.6666666667 3698.0220777930
+ 3100.0000000000 3672.7457519184
+ 3133.3333333333 3648.3158397503
+ 3166.6666666667 3625.0000005181
+ 3200.0000000000 3603.0536874351
+ 3233.3333333333 3582.7173488994
+ 3266.6666666667 3564.2137940910
+ 3300.0000000000 3547.7457518283
+ 3333.3333333333 3533.4936494278
+ 3366.6666666667 3521.6136359057
+ 3400.0000000000 3512.2358711758
+ 3433.3333333333 3505.4630999907
+ 3466.6666666667 3501.3695262486
+ 3500.0000000000 3500.0000000000
+ 3533.3333333333 3501.3695260610
+ 3566.6666666667 3505.4630996175
+ 3600.0000000000 3512.2358706212
+ 3633.3333333333 3521.6136351757
+ 3666.6666666667 3533.4936485304
+ 3700.0000000000 3547.7457507733
+ 3733.3333333333 3564.2137928900
+ 3766.6666666667 3582.7173475655
+ 3800.0000000000 3603.0536859830
+ 3833.3333333333 3624.9999989637
+ 3866.6666666667 3648.3158381106
+ 3900.0000000000 3672.7457502113
+ 3933.3333333333 3698.0220760373
+ 3966.6666666667 3723.8678828740
+ 4000.0000000000 3749.9999986538
+ 4033.3333333333 3776.1321144484
+ 4066.6666666667 3801.9779213292
+ 4100.0000000000 3827.2542472281
+ 4133.3333333333 3851.6841594298
+ 4166.6666666667 3874.9999987046
+ 4200.0000000000 3896.9463118388
+ 4233.3333333333 3917.2826504337
+ 4266.6666666667 3935.7862053084
+ 4300.0000000000 3952.2542476442
+ 4333.3333333333 3966.5063501234
+ 4366.6666666667 3978.3863637293
+ 4400.0000000000 3987.7641285469
+ 4433.3333333333 3994.5368998227
+ 4466.6666666667 3998.6304736576
+ 4500.0000000000 4000.0000000000
+ 4533.3333333333 4000.0000000000
+ 4566.6666666667 4000.0000000000
+ 4600.0000000000 4000.0000000000
+ 4633.3333333333 4000.0000000000
+ 4666.6666666667 4000.0000000000
+ 4700.0000000000 4000.0000000000
+ 4733.3333333333 4000.0000000000
+ 4766.6666666667 4000.0000000000
+ 4800.0000000000 4000.0000000000
+ 4833.3333333333 4000.0000000000
+ 4866.6666666667 4000.0000000000
+ 4900.0000000000 4000.0000000000
+ 4933.3333333333 4000.0000000000
+ 4966.6666666667 4000.0000000000
+ 5000.0000000000 4000.0000000000
+ 5033.3333333333 4000.0000000000
+ 5066.6666666667 4000.0000000000
+ 5100.0000000000 4000.0000000000
+ 5133.3333333333 4000.0000000000
+ 5166.6666666667 4000.0000000000
+ 5200.0000000000 4000.0000000000
+ 5233.3333333333 4000.0000000000
+ 5266.6666666667 4000.0000000000
+ 5300.0000000000 4000.0000000000
+ 5333.3333333333 4000.0000000000
+ 5366.6666666667 4000.0000000000
+ 5400.0000000000 4000.0000000000
+ 5433.3333333333 4000.0000000000
+ 5466.6666666667 4000.0000000000
+ 5500.0000000000 4000.0000000000
+ 5533.3333333333 4000.0000000000
+ 5566.6666666667 4000.0000000000
+ 5600.0000000000 4000.0000000000
+ 5633.3333333333 4000.0000000000
+ 5666.6666666667 4000.0000000000
+ 5700.0000000000 4000.0000000000
+ 5733.3333333333 4000.0000000000
+ 5766.6666666667 4000.0000000000
+ 5800.0000000000 4000.0000000000
+ 5833.3333333333 4000.0000000000
+ 5866.6666666667 4000.0000000000
+ 5900.0000000000 4000.0000000000
+ 5933.3333333333 4000.0000000000
+ 5966.6666666667 4000.0000000000
+ 6000.0000000000 4000.0000000000
+ 6033.3333333333 4000.0000000000
+ 6066.6666666667 4000.0000000000
+ 6100.0000000000 4000.0000000000
+ 6133.3333333333 4000.0000000000
+ 6166.6666666667 4000.0000000000
+ 6200.0000000000 4000.0000000000
+ 6233.3333333333 4000.0000000000
+ 6266.6666666667 4000.0000000000
+ 6300.0000000000 4000.0000000000
+ 6333.3333333333 4000.0000000000
+ 6366.6666666667 4000.0000000000
+ 6400.0000000000 4000.0000000000
+ 6433.3333333333 4000.0000000000
+ 6466.6666666667 4000.0000000000
+ 6500.0000000000 4000.0000000000
+ 6533.3333333333 4000.0000000000
+ 6566.6666666667 4000.0000000000
+ 6600.0000000000 4000.0000000000
+ 6633.3333333333 4000.0000000000
+ 6666.6666666667 4000.0000000000
+ 6700.0000000000 4000.0000000000
+ 6733.3333333333 4000.0000000000
+ 6766.6666666667 4000.0000000000
+ 6800.0000000000 4000.0000000000
+ 6833.3333333333 4000.0000000000
+ 6866.6666666667 4000.0000000000
+ 6900.0000000000 4000.0000000000
+ 6933.3333333333 4000.0000000000
+ 6966.6666666667 4000.0000000000
+ 7000.0000000000 4000.0000000000
Added: seismo/2D/SPECFEM2D/trunk/MAILLE90/maille.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/MAILLE90/maille.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/MAILLE90/maille.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,1162 @@
+!=====================================================================
+!
+! P r e m a i l l e u r F o r t r a n 9 0
+! -------------------------------------------
+!
+! Version 2.0
+! -----------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+!
+! (c) February 1998
+!
+!=====================================================================
+
+ program maille
+
+ implicit none
+
+! definir les tableaux pour allocation dynamique
+
+! coordinates of the grid points
+ double precision, allocatable :: x(:,:),z(:,:)
+
+! variables needed to compute the transformation
+ double precision, allocatable :: psi(:),eta(:),absx(:), &
+ a00(:),a01(:),valeta(:),bot0(:),top0(:),bot_p(:),top_p(:)
+
+! stockage du modele de vitesse et densite
+ double precision, allocatable :: rho(:),cp(:),cs(:),aniso3(:),aniso4(:)
+ integer, allocatable :: icodemat(:)
+ integer, allocatable :: num_modele(:,:)
+
+! the topography data
+ double precision, allocatable :: xtopo(:),ztopo(:),coefs_topo(:), &
+ xinterf(:),zinterf(:),coefs_interf(:)
+
+! arrays for the source
+ double precision, allocatable :: xs(:),zs(:),f0(:),t0(:),angle(:),factor(:)
+ integer, allocatable :: isource_type(:),itimetype(:)
+
+! arrays for the receivers
+ double precision, allocatable :: xrec(:),zrec(:)
+
+! nom du fichier GNUPLOT contenant la grille
+ character(len=50) file1
+
+ character(len=50) interffile,topofile,title
+ character(len=15) junk
+
+ integer imatnum,inumabs,inumelem,nelemperio,nxgll,netyp
+ integer icodehaut,icodebas,icodegauche,icodedroite
+ integer nelemabs,ndime,npgeo,nspel,ndofn,ninterf,ntopo
+ integer k,icol,ili,istepx,istepz,ncut,ix,iz,irec,i,j
+ integer ixdebzone,ixfinzone,izdebzone,izfinzone,imodnum
+ integer izone,imodele,nbzone,nbmodeles,iaffinfo
+ integer itaff,itfirstaff,iptsdisp,isubsamp,nrec,n1ana,n2ana
+ integer irepr,nrec1,nrec2,isamp,nbsources,isismostype,ivecttype
+ integer ngnod,nt,niter,idegpoly,nx,nz,nxread,nzread
+ integer inumelem2,ix2,iz2,inumperio
+ integer icodematread
+
+ double precision valseuil,freqmaxrep,ratio
+ double precision tang1,tangN,vpzone,vszone
+ double precision orig_x,orig_z,sizemax,cutvect,scalex,scalez
+ double precision factorxsu,factorana,xspacerec,zspacerec
+ double precision anglerec,anglerec2,xfin,zfin,xfin2,zfin2,xdeb,zdeb,xmin,xmax
+ double precision dt
+ double precision rhoread,cpread,csread,aniso3read,aniso4read
+
+ logical interpol,ignuplot,ireadmodel,iavs,ioutputgrid
+ logical abshaut,absbas,absgauche,absdroite
+ logical periohaut,periogauche
+ logical sismos,isources_surf,ienreg_surf,display
+ logical ivectplot,imeshvect,isymbols
+ logical iexec,initialfield
+ logical imodelvect,iboundvect,usletter,compenergy
+
+ integer, external :: num
+ double precision, external :: bottom,botprime,spl,spl_prime,dens
+
+! --- code des numeros d'aretes pour les bords absorbants
+ integer, parameter :: iaretebas = 1
+ integer, parameter :: iaretedroite = 2
+ integer, parameter :: iaretehaut = 3
+ integer, parameter :: iaretegauche = 4
+
+! ***
+! *** read the parameter file
+! ***
+
+ print *,' Reading the parameter file ... '
+ print *
+
+ open(unit=10,file='Par',status='old')
+
+! formats
+
+ 1 format(a,f12.5)
+ 2 format(a,i8)
+ 3 format(a,a)
+ 4 format(a,l8)
+
+! read the header
+ do i=1,10
+ read(10,*)
+ enddo
+
+! read file names and path for output
+ read(10,3)junk,title
+ read(10,3)junk,topofile
+ read(10,3)junk,interffile
+
+ write(*,*) 'Titre de la simulation'
+ write(*,*) title
+ print *
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read grid parameters
+ read(10,1)junk,xmin
+ read(10,1)junk,xmax
+ read(10,2)junk,nx
+ read(10,2)junk,nz
+ read(10,2)junk,idegpoly
+ read(10,2)junk,ngnod
+ read(10,1)junk,ratio
+ read(10,4)junk,initialfield
+ read(10,4)junk,ireadmodel
+ read(10,4)junk,iexec
+
+ nxread = nx
+ nzread = nz
+
+! multiplier par 2 si elements 9 noeuds
+ if(ngnod == 9) then
+ nx = nx * 2
+ nz = nz * 2
+ endif
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read absorbing boundaries parameters
+ read(10,4)junk,abshaut
+ read(10,4)junk,absbas
+ read(10,4)junk,absgauche
+ read(10,4)junk,absdroite
+ read(10,4)junk,periohaut
+ read(10,4)junk,periogauche
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read time step parameters
+ read(10,2)junk,nt
+ read(10,1)junk,dt
+ read(10,2)junk,niter
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read source parameters
+ read(10,2)junk,nbsources
+ read(10,4)junk,isources_surf
+ read(10,1)junk,valseuil
+ read(10,1)junk,freqmaxrep
+ print *,'Nb de sources a lire : ',nbsources
+
+ allocate(xs(nbsources))
+ allocate(zs(nbsources))
+ allocate(f0(nbsources))
+ allocate(t0(nbsources))
+ allocate(isource_type(nbsources))
+ allocate(itimetype(nbsources))
+ allocate(angle(nbsources))
+ allocate(factor(nbsources))
+
+ do i=1,nbsources
+ read(10,*)
+ read(10,1)junk,xs(i)
+ read(10,1)junk,zs(i)
+ read(10,1)junk,f0(i)
+ read(10,1)junk,t0(i)
+ read(10,2)junk,isource_type(i)
+ read(10,2)junk,itimetype(i)
+ read(10,1)junk,angle(i)
+ read(10,1)junk,factor(i)
+
+ print *
+ print *,' Source #',i
+ print *,'Position xs, zs = ',xs(i),zs(i)
+ print *,'Frequency, delay = ',f0(i),t0(i)
+ print *,'Source type (1=force 2=explo) : ', &
+ isource_type(i)
+ print *,'Angle of the source if force = ',angle(i)
+ print *,'Multiplying factor = ',factor(i)
+ enddo
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read receivers line parameters
+ read(10,4)junk,sismos
+ read(10,2)junk,isamp
+ read(10,4)junk,ienreg_surf
+ read(10,2)junk,isismostype
+ read(10,*)
+ read(10,2)junk,nrec1
+ read(10,1)junk,xdeb
+ read(10,1)junk,zdeb
+ read(10,1)junk,xfin
+ read(10,1)junk,zfin
+ read(10,1)junk,anglerec
+ read(10,2)junk,irepr
+ read(10,*)
+ read(10,2)junk,nrec2
+ read(10,1)junk,xfin2
+ read(10,1)junk,zfin2
+ read(10,1)junk,anglerec2
+ read(10,*)
+ read(10,1)junk,factorxsu
+ read(10,2)junk,n1ana
+ read(10,2)junk,n2ana
+ read(10,1)junk,factorana
+
+! determination et affichage position ligne de receivers
+ if(nrec2 < 0) stop 'negative value of nrec2 !'
+
+ if(nrec2 == 0) then
+ nrec = nrec1
+ else
+ nrec = nrec1 + nrec2 - 1
+ endif
+
+ allocate(xrec(nrec))
+ allocate(zrec(nrec))
+
+ if(nrec2 == 0) then
+ print *
+ print *,'There are ',nrec,' receivers on a single line'
+ xspacerec=(xfin-xdeb)/dble(nrec-1)
+ zspacerec=(zfin-zdeb)/dble(nrec-1)
+ do i=1,nrec
+ xrec(i) = xdeb + dble(i-1)*xspacerec
+ zrec(i) = zdeb + dble(i-1)*zspacerec
+ enddo
+ else
+ print *
+ print *,'There are ',nrec,' receivers on two lines'
+ print *,'First line contains ',nrec1,' receivers'
+ print *,'Second line contains ',nrec2,' receivers'
+ xspacerec=(xfin-xdeb)/dble(nrec1-1)
+ zspacerec=(zfin-zdeb)/dble(nrec1-1)
+ do i=1,nrec1
+ xrec(i) = xdeb + dble(i-1)*xspacerec
+ zrec(i) = zdeb + dble(i-1)*zspacerec
+ enddo
+ xspacerec=(xfin2-xfin)/dble(nrec2-1)
+ zspacerec=(zfin2-zfin)/dble(nrec2-1)
+ do i=1,nrec2
+ xrec(i+nrec1-1) = xfin + dble(i-1)*xspacerec
+ zrec(i+nrec1-1) = zfin + dble(i-1)*zspacerec
+ enddo
+ endif
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read display parameters
+ read(10,4)junk,display
+ read(10,2)junk,itaff
+ read(10,2)junk,itfirstaff
+ read(10,2)junk,iaffinfo
+ read(10,4)junk,ivectplot
+ read(10,2)junk,ivecttype
+ read(10,1)junk,cutvect
+ read(10,4)junk,imeshvect
+ read(10,4)junk,imodelvect
+ read(10,4)junk,iboundvect
+ read(10,4)junk,interpol
+ read(10,2)junk,iptsdisp
+ read(10,2)junk,isubsamp
+ read(10,1)junk,scalex
+ read(10,1)junk,scalez
+ read(10,1)junk,sizemax
+ read(10,4)junk,usletter
+ read(10,1)junk,orig_x
+ read(10,1)junk,orig_z
+ read(10,4)junk,ignuplot
+ read(10,4)junk,iavs
+ read(10,4)junk,ioutputgrid
+ read(10,4)junk,compenergy
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! lecture des differents modeles de materiaux
+
+ read(10,2)junk,nbmodeles
+ if(nbmodeles <= 0) stop 'Negative number of models not allowed !!'
+
+ allocate(icodemat(nbmodeles))
+ allocate(rho(nbmodeles))
+ allocate(cp(nbmodeles))
+ allocate(cs(nbmodeles))
+ allocate(aniso3(nbmodeles))
+ allocate(aniso4(nbmodeles))
+ allocate(num_modele(nx,nz))
+
+ icodemat(:) = 0
+ rho(:) = 0.d0
+ cp(:) = 0.d0
+ cs(:) = 0.d0
+ aniso3(:) = 0.d0
+ aniso4(:) = 0.d0
+ num_modele(:,:) = 0
+
+ do imodele=1,nbmodeles
+ read(10,*) i,icodematread,rhoread,cpread,csread,aniso3read,aniso4read
+ if(i<1 .or. i>nbmodeles) stop 'Wrong material point number'
+ icodemat(i) = icodematread
+ rho(i) = rhoread
+ cp(i) = cpread
+ cs(i) = csread
+ aniso3(i) = aniso3read
+ aniso4(i) = aniso4read
+ if(i <= 0) stop 'Negative model number not allowed !!'
+ if (rho(i) < 0.d0 .or. cp(i) < 0.d0 .or. cs(i) < 0.d0) &
+ stop 'Negative value of velocity or density'
+ enddo
+
+ print *
+ print *, 'Nb de modeles de roche = ',nbmodeles
+ print *
+ do i=1,nbmodeles
+ if(icodemat(i) /= 2) then
+ print *,'Modele #',i,' isotrope'
+ print *,'rho,cp,cs = ',rho(i),cp(i),cs(i)
+ else
+ print *,'Modele #',i,' anisotrope'
+ print *,'rho,c11,c13,c33,c44 = ',rho(i),cp(i),cs(i),aniso3(i),aniso4(i)
+ endif
+ enddo
+ print *
+
+! *** lecture des numeros de modele des differentes zones
+ read(10,2)junk,nbzone
+
+ if(nbzone <= 0) stop 'Negative number of zones not allowed !!'
+
+ print *
+ print *, 'Nb de zones du modele = ',nbzone
+ print *
+
+ do izone=1,nbzone
+ read(10,*) ixdebzone,ixfinzone,izdebzone,izfinzone,imodnum
+
+ if (imodnum < 1) stop 'Negative model number not allowed !!'
+ if (ixdebzone < 1) stop 'Left coordinate of zone negative !!'
+ if (ixfinzone > nxread) stop 'Right coordinate of zone too high !!'
+ if (izdebzone < 1) stop 'Bottom coordinate of zone negative !!'
+ if (izfinzone > nzread) stop 'Top coordinate of zone too high !!'
+
+ print *,'Zone ',izone
+ print *,'IX from ',ixdebzone,' to ',ixfinzone
+ print *,'IZ from ',izdebzone,' to ',izfinzone
+ if(icodemat(imodnum) /= 2) then
+ vpzone = cp(imodnum)
+ vszone = cs(imodnum)
+ print *,'Model # ',imodnum,' isotrope'
+ print *,'vp = ',vpzone
+ print *,'vs = ',vszone
+ print *,'rho = ',rho(imodnum)
+ print *,'Poisson''s ratio = ', &
+ 0.5d0*(vpzone*vpzone-2.d0*vszone*vszone)/(vpzone*vpzone-vszone*vszone)
+ else
+ print *,'Model # ',imodnum,' anisotrope'
+ print *,'c11 = ',cp(imodnum)
+ print *,'c13 = ',cs(imodnum)
+ print *,'c33 = ',aniso3(imodnum)
+ print *,'c44 = ',aniso4(imodnum)
+ print *,'rho = ',rho(imodnum)
+ endif
+ print *,' -----'
+
+! stocker le modele de vitesse et densite
+ do i=ixdebzone,ixfinzone
+ do j=izdebzone,izfinzone
+ if(ngnod == 4) then
+ num_modele(i,j) = imodnum
+ else
+ num_modele(2*(i-1)+1,2*(j-1)+1) = imodnum
+ num_modele(2*(i-1)+1,2*(j-1)+2) = imodnum
+ num_modele(2*(i-1)+2,2*(j-1)+1) = imodnum
+ num_modele(2*(i-1)+2,2*(j-1)+2) = imodnum
+ endif
+ enddo
+ enddo
+
+ enddo
+
+ if (minval(num_modele) <= 0) stop 'Velocity model not entirely set...'
+
+ close(10)
+
+ print *
+ print *,' Parameter file successfully read... '
+
+! --------- fin lecture fichier parametres --------------
+
+ allocate(psi(0:nx))
+ allocate(eta(0:nz))
+ allocate(absx(0:nx))
+ allocate(a00(0:nz))
+ allocate(a01(0:nz))
+ allocate(valeta(0:nz))
+ allocate(bot0(0:nx))
+ allocate(top0(0:nx))
+ allocate(bot_p(0:nx))
+ allocate(top_p(0:nx))
+
+! calcul des points regulierement espaces
+ do i=0,nx
+ psi(i) = i/dble(nx)
+ enddo
+ do j=0,nz
+ eta(j) = j/dble(nz)
+ enddo
+
+! quelques verifications de base a faire
+
+ if(ngnod /= 4.and.ngnod /= 9) stop 'erreur ngnod different de 4 ou 9 !!'
+
+ if (ngnod == 4) then
+ print *
+ print *,'Le maillage comporte ',nx,' x ',nz,' elements'
+ print *,'La grille equivalente a une taille de ', &
+ nx*idegpoly + 1,' x ',nz*idegpoly + 1,' points (', &
+ (nx*idegpoly + 1)*(nz*idegpoly + 1),' points)'
+ else
+ print *
+ print *,'Le maillage comporte ',nx/2,' x ',nz/2,' elements'
+ print *,'La grille equivalente a une taille de ', &
+ nx*idegpoly/2 + 1,' x ',nz*idegpoly/2 + 1,' points (', &
+ (nx*idegpoly/2 + 1)*(nz*idegpoly/2 + 1),' points)'
+
+ endif
+ print *,'Chaque element comporte ',idegpoly+1,' points dans chaque direction'
+ print *,'Les elements de controle sont des elements ',ngnod,' noeuds'
+ print *
+
+!------------------------------------------------------
+
+ allocate(x(0:nx,0:nz))
+ allocate(z(0:nx,0:nz))
+
+ x(:,:)=0.d0
+ z(:,:)=0.d0
+
+! get topography data from external file
+ print *,'Reading topography from file ',topofile
+ open(unit=15,file=topofile,status='old')
+ read(15,*) ntopo
+ if (ntopo < 2) stop 'Not enough topography points (min 2)'
+ print *,'Reading ',ntopo,' points from topography file'
+ print *
+
+ allocate(xtopo(ntopo))
+ allocate(ztopo(ntopo))
+ allocate(coefs_topo(ntopo))
+
+ do i=1,ntopo
+ read(15,*) xtopo(i),ztopo(i)
+ enddo
+ close(15)
+
+! get interface data from external file, if any
+ if(interffile /= 'none') then
+ print *,'Reading interface from file ',interffile
+ open(unit=15,file=interffile,status='old')
+ read(15,*) ninterf
+ if (ninterf < 2) stop 'Not enough interface points (min 2)'
+ print *,'Reading ',ninterf,' points from interface file'
+
+ allocate(xinterf(ninterf))
+ allocate(zinterf(ninterf))
+ allocate(coefs_interf(ninterf))
+
+ do i=1,ninterf
+ read(15,*) xinterf(i),zinterf(i)
+ enddo
+
+ close(15)
+ else
+ print *,'*** No interface file specified ***'
+ endif
+
+! check the values read
+ print *
+ print *, 'Topography data points (x,z)'
+ print *, '----------------------------'
+ print *
+ print *, 'Topo 1 = (',xtopo(1),',',ztopo(1),')'
+ print *, 'Topo ntopo = (',xtopo(ntopo),',',ztopo(ntopo),')'
+
+!--- calculate the spline function for the topography
+!--- imposer les tangentes aux deux bords
+ tang1 = (ztopo(2)-ztopo(1))/(xtopo(2)-xtopo(1))
+ tangN = (ztopo(ntopo)-ztopo(ntopo-1))/(xtopo(ntopo)-xtopo(ntopo-1))
+ call spline(xtopo,ztopo,ntopo,tang1,tangN,coefs_topo)
+
+!--- calculate the spline function for the interface
+!--- imposer les tangentes aux deux bords
+ if (interffile /= 'none') then
+ tang1 = (zinterf(2)-zinterf(1))/(xinterf(2)-xinterf(1))
+ tangN = (zinterf(ntopo)-zinterf(ntopo-1))/(xinterf(ntopo)-xinterf(ntopo-1))
+ call spline(xinterf,zinterf,Ninterf,tang1,tangN,coefs_interf)
+ endif
+
+! *** afficher limites du modele lu
+ print *
+ print *, 'Limites absolues modele fichier topo :'
+ print *
+ print *, 'Xmin = ',minval(xtopo),' Xmax = ',maxval(xtopo)
+ print *, 'Zmin = ',minval(ztopo),' Zmax = ',maxval(ztopo)
+ print *
+
+! *** eventuellement modifier sources si sources en surface
+ print *
+ print *, 'Position (x,z) des ',nbsources,' sources'
+ print *
+ do i=1,nbsources
+ if(isources_surf) then
+ zs(i) = spl(xs(i),xtopo,ztopo,coefs_topo,ntopo)
+ endif
+ print *, 'Source ',i,' = ',xs(i),zs(i)
+ enddo
+
+! *** eventuellement modifier recepteurs si enregistrement en surface
+ print *
+ print *, 'Position (x,z) des ',nrec,' receivers'
+ print *
+ do irec=1,nrec
+ if(ienreg_surf) then
+ zrec(irec) = spl(xrec(irec),xtopo,ztopo,coefs_topo,ntopo)
+ endif
+ print *, 'Receiver ',irec,' = ',xrec(irec),zrec(irec)
+ enddo
+
+!--- definition du maillage suivant X
+ do ix=0,nx
+ absx(ix) = dens(ix,psi,xmin,xmax,nx)
+ enddo
+
+ if (interffile == 'none') then
+
+! *** une seule zone si pas d'interface specifiee
+
+ do iz=0,nz
+ valeta(iz) = eta(iz)
+ a00(iz) = 1-valeta(iz)
+ a01(iz) = valeta(iz)
+ enddo
+
+ do ix=0,nx
+ bot0(ix) = bottom(absx(ix))
+ top0(ix) = spl(absx(ix),xtopo,ztopo,coefs_topo,ntopo)
+ bot_p(ix) = botprime(absx(ix))
+ top_p(ix) = spl_prime(absx(ix),xtopo,ztopo,coefs_topo,ntopo)
+ enddo
+
+! valeurs de x et y pour display domaine physique
+ do ix=0,nx
+ do iz=0,nz
+ x(ix,iz) = absx(ix)
+ z(ix,iz) = a00(iz)*bot0(ix) + a01(iz)*top0(ix)
+ enddo
+ enddo
+
+ else
+
+! *** deux zones si topo
+
+ ncut = nint(nz*ratio)
+
+! *** ZONE DU BAS ***
+
+ do iz=0,ncut
+ valeta(iz) = dble(iz)/(nz*ratio)
+ a00(iz) = 1-valeta(iz)
+ a01(iz) = valeta(iz)
+ enddo
+
+ do ix=0,nx
+ bot0(ix) = bottom(absx(ix))
+ top0(ix) = spl(absx(ix),xinterf,zinterf,coefs_interf,ninterf)
+ bot_p(ix) = botprime(absx(ix))
+ top_p(ix) = spl_prime(absx(ix),xinterf,zinterf,coefs_interf,ninterf)
+ enddo
+
+! valeurs de x et y pour display domaine physique
+ do ix=0,nx
+ do iz=0,ncut
+ x(ix,iz) = absx(ix)
+ z(ix,iz) = a00(iz)*bot0(ix) + a01(iz)*top0(ix)
+ enddo
+ enddo
+
+! *** ZONE DU HAUT ***
+
+ do iz=0,nz-ncut
+ valeta(iz) = dble(iz)/(nz*(1.d0-ratio))
+ a00(iz) = 1-valeta(iz)
+ a01(iz) = valeta(iz)
+ enddo
+
+ do ix=0,nx
+ bot0(ix) = spl(absx(ix),xinterf,zinterf,coefs_interf,ninterf)
+ top0(ix) = spl(absx(ix),xtopo,ztopo,coefs_topo,ntopo)
+ bot_p(ix) = spl_prime(absx(ix),xinterf,zinterf,coefs_interf,ninterf)
+ top_p(ix) = spl_prime(absx(ix),xtopo,ztopo,coefs_topo,ntopo)
+ enddo
+
+! valeurs de x et y pour display domaine physique
+ do ix=0,nx
+ do iz=0,nz-ncut
+ x(ix,iz+ncut) = absx(ix)
+ z(ix,iz+ncut) = a00(iz)*bot0(ix) + a01(iz)*top0(ix)
+ enddo
+ enddo
+
+ endif
+
+! calculer min et max de X et Z sur la grille
+ print *
+ print *, 'Valeurs min et max de X sur le maillage = ',minval(x),maxval(x)
+ print *, 'Valeurs min et max de Z sur le maillage = ',minval(z),maxval(z)
+ print *
+
+! ***
+! *** generer un fichier 'GNUPLOT' pour le controle de la grille ***
+! ***
+
+ print *
+ print *,' Ecriture de la grille format GNUPLOT...'
+
+ file1='gridfile.gnu'
+
+ open(unit=20,file=file1,status='unknown')
+
+! dessin de la topo de surface (splines)
+ do i=0,nx-1
+ write(20,15) sngl(absx(i)),sngl(top0(i))
+ write(20,15) sngl(absx(i+1)),sngl(top0(i+1))
+ write(20,10)
+ enddo
+
+! dessin de l'interface du milieu
+ if (interffile /= 'none') then
+ do i=0,nx-1
+ write(20,15) sngl(absx(i)),sngl(bot0(i))
+ write(20,15) sngl(absx(i+1)),sngl(bot0(i+1))
+ write(20,10)
+ enddo
+ endif
+
+! dessin des lignes horizontales de la grille
+ print *, 'Ecriture lignes horizontales'
+ istepx = 1
+ if(ngnod == 4) then
+ istepz = 1
+ else
+ istepz = 2
+ endif
+ do ili=0,nz,istepz
+ do icol=0,nx-istepx,istepx
+ write(20,15) sngl(x(icol,ili)),sngl(z(icol,ili))
+ write(20,15) sngl(x(icol+istepx,ili)),sngl(z(icol+istepx,ili))
+ write(20,10)
+ enddo
+ enddo
+
+! dessin des lignes verticales de la grille
+ print *, 'Ecriture lignes verticales'
+ if(ngnod == 4) then
+ istepx = 1
+ else
+ istepx = 2
+ endif
+ istepz = 1
+ do icol=0,nx,istepx
+ do ili=0,nz-istepz,istepz
+ write(20,15) sngl(x(icol,ili)),sngl(z(icol,ili))
+ write(20,15) sngl(x(icol,ili+istepz)),sngl(z(icol,ili+istepz))
+ write(20,10)
+ enddo
+ enddo
+
+ close(20)
+
+! cree le script de dessin pour gnuplot
+ open(unit=20,file='plotgrid.gnu',status='unknown')
+ write(20,*) 'set term postscript landscape monochrome solid "Helvetica" 22'
+ write(20,*) 'set output "grille.ps"'
+ write(20,*) 'plot "gridfile.gnu" title "Macroblocs mesh" w l'
+ close(20)
+
+ print *,' Fin ecriture de la grille format GNUPLOT'
+ print *
+
+! *** generation de la base de donnees
+
+ open(unit=15,file='../SPECFEM90/DataBase',status='unknown')
+
+ write(15,*) '#'
+ write(15,*) '# Base de Donnees pour Specfem - Premailleur Fortran 90'
+ write(15,*) '# ',title
+ write(15,*) '# Dimitri Komatitsch, (c) EPS - Harvard February 1998'
+ write(15,*) '#'
+
+ write(15,*) 'Titre simulation'
+ write(15,40) title
+
+ ndofn = 2
+ ndime = 2
+ npgeo = (nx+1)*(nz+1)
+ if (ngnod == 4) then
+ nspel = nx*nz
+ else
+ nspel = nx*nz/4
+ endif
+ write(15,*) 'ndofn ndime npgeo'
+ write(15,*) ndofn,ndime,npgeo
+
+ write(15,*) 'display ignuplot interpol'
+ write(15,*) display,ignuplot,interpol
+
+ write(15,*) 'itaff itfirstaff icolor inumber'
+ write(15,*) itaff,itfirstaff,0,0
+
+ write(15,*) 'ivectplot imeshvect imodelvect iboundvect cutvect isubsamp'
+ write(15,*) ivectplot,imeshvect,imodelvect,iboundvect,cutvect,isubsamp
+
+ write(15,*) 'scalex scalez sizemax angle rapport USletter'
+ write(15,*) scalex,scalez,sizemax,20.,0.40,usletter
+
+ write(15,*) 'orig_x orig_z isymbols'
+ write(15,*) orig_x,orig_z,' T'
+
+ write(15,*) 'valseuil freqmaxrep'
+ write(15,*) valseuil,freqmaxrep
+
+ write(15,*) 'sismos nrec nrec1 nrec2 isamp'
+ write(15,*) sismos,nrec,nrec1,nrec2,isamp
+
+ write(15,*) 'irepr anglerec anglerec2'
+ write(15,*) irepr,anglerec,anglerec2
+
+ write(15,*) 'compenergy'
+ write(15,*) compenergy
+
+ write(15,*) 'initialfield factorana factorxsu n1ana n2ana'
+ write(15,*) initialfield,factorana,factorxsu,n1ana,n2ana
+
+ write(15,*) 'isismostype ivecttype iaffinfo'
+ write(15,*) isismostype,ivecttype,iaffinfo
+
+ write(15,*) 'ireadmodel ioutputgrid iavs'
+ write(15,*) ireadmodel,ioutputgrid,iavs
+
+ write(15,*) 'iexec iecho'
+ if(iexec) then
+ write(15,*) '1 1'
+ else
+ write(15,*) '0 1'
+ endif
+
+ write(15,*) 'ncycl dtinc niter'
+ write(15,*) nt,dt,niter
+
+ write(15,*) 'nltfl (number of force or pressure sources)'
+ write(15,*) nbsources
+
+ write(15,*) 'Collocated forces and/or pressure sources:'
+ do i=1,nbsources
+ write(15,*) itimetype(i),isource_type(i), &
+ xs(i)-xmin,zs(i),f0(i),t0(i),factor(i),angle(i),0
+ enddo
+
+ write(15,*) 'Receivers positions:'
+ do irec=1,nrec
+ write(15,*) irec,xrec(irec)-xmin,zrec(irec)
+ enddo
+
+ write(15,*) 'Coordinates of macroblocs mesh (coorg):'
+ do j=0,nz
+ do i=0,nx
+ write(15,*) num(i,j,nx),x(i,j)-xmin,z(i,j)
+ enddo
+ enddo
+
+!
+!--- introduction des bords absorbants
+!
+
+ nelemabs = 0
+ if(absbas) nelemabs = nelemabs + nx
+ if(abshaut) nelemabs = nelemabs + nx
+ if(absgauche) nelemabs = nelemabs + nz
+ if(absdroite) nelemabs = nelemabs + nz
+
+! on a deux fois trop d'elements si elements 9 noeuds
+ if(ngnod == 9) nelemabs = nelemabs / 2
+
+! enlever aussi les coins qui ont ete comptes deux fois
+ if(absbas .and. absgauche) nelemabs = nelemabs - 1
+ if(absbas .and. absdroite) nelemabs = nelemabs - 1
+ if(abshaut .and. absgauche) nelemabs = nelemabs - 1
+ if(abshaut .and. absdroite) nelemabs = nelemabs - 1
+
+!
+!--- introduction des bords periodiques
+!
+
+ nelemperio = 0
+ if(periohaut) nelemperio = nelemperio + nx
+ if(periogauche) nelemperio = nelemperio + nz
+
+! on a deux fois trop d'elements si elements 9 noeuds
+ if(ngnod == 9) nelemperio = nelemperio / 2
+
+ netyp = 2
+ nxgll = idegpoly + 1
+
+ write(15,*) 'netyp numat ngnod nxgll nygll nspec iptsdisp ielemabs ielemperio'
+ write(15,*) netyp,nbmodeles,ngnod,nxgll,nxgll,nspel,iptsdisp, &
+ nelemabs,nelemperio
+
+ write(15,*) 'Material sets (num 0 rho vp vs 0 0) or (num 2 rho c11 c13 c33 c44)'
+ do i=1,nbmodeles
+ write(15,*) i,icodemat(i),rho(i),cp(i),cs(i),aniso3(i),aniso4(i)
+ enddo
+
+
+ write(15,*) 'Arrays kmato and knods for each bloc:'
+
+ k=0
+ if(ngnod == 4) then
+ do j=0,nz-1
+ do i=0,nx-1
+
+ k = k + 1
+ imatnum = num_modele(i+1,j+1)
+ write(15,*) k,imatnum,num(i,j,nx),num(i+1,j,nx),num(i+1,j+1,nx), &
+ num(i,j+1,nx)
+ enddo
+ enddo
+ else
+ do j=0,nz-2,2
+ do i=0,nx-2,2
+
+ k = k + 1
+ imatnum = num_modele(i+1,j+1)
+ write(15,*) k,imatnum,num(i,j,nx),num(i+2,j,nx),num(i+2,j+2,nx), &
+ num(i,j+2,nx),num(i+1,j,nx),num(i+2,j+1,nx), &
+ num(i+1,j+2,nx),num(i,j+1,nx),num(i+1,j+1,nx)
+
+ enddo
+ enddo
+ endif
+
+!
+!--- sauvegarde des bords periodiques
+!
+
+ print *
+ print *,'Au total il y a ',nelemperio,' elements periodiques'
+ print *
+ print *,'Bords periodiques actifs :'
+ print *
+ print *,'Haut = ',periohaut
+ print *,'Gauche = ',periogauche
+ print *
+
+! generer la liste des elements periodiques
+ if(nelemperio > 0) then
+
+ write(15,*) 'Liste des elements periodiques (haut gauche) :'
+ inumperio = 0
+
+ if(periogauche) then
+ do iz=1,nzread
+ ix=1
+ inumelem = (iz-1)*nxread + ix
+ ix2 = nxread
+ inumelem2 = (iz-1)*nxread + ix2
+ inumperio = inumperio + 1
+ write(15,*) inumperio,inumelem,4,inumelem2,2
+ enddo
+ endif
+
+ if(periohaut) then
+ do ix=1,nxread
+ iz=1
+ inumelem = (iz-1)*nxread + ix
+ iz2 = nzread
+ inumelem2 = (iz2-1)*nxread + ix
+ inumperio = inumperio + 1
+ write(15,*) inumperio,inumelem,1,inumelem2,3
+ enddo
+ endif
+
+ endif
+
+!
+!--- sauvegarde des bords absorbants
+!
+
+ print *
+ print *,'Au total il y a ',nelemabs,' elements absorbants'
+ print *
+ print *,'Bords absorbants actifs :'
+ print *
+ print *,'Haut = ',abshaut
+ print *,'Bas = ',absbas
+ print *,'Gauche = ',absgauche
+ print *,'Droite = ',absdroite
+ print *
+
+! generer la liste des elements absorbants
+ if(nelemabs > 0) then
+ write(15,*) 'Liste des elements absorbants (haut bas gauche droite) :'
+ inumabs = 0
+ do iz=1,nzread
+ do ix=1,nxread
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = 0
+ icodedroite = 0
+ inumelem = (iz-1)*nxread + ix
+ if(abshaut .and. iz==nzread) icodehaut = iaretehaut
+ if(absbas .and. iz== 1) icodebas = iaretebas
+ if(absgauche .and. ix== 1) icodegauche = iaretegauche
+ if(absdroite .and. ix==nxread) icodedroite = iaretedroite
+ if(icodehaut>0 .or. icodebas>0 .or. icodegauche>0 .or. icodedroite>0) then
+ inumabs = inumabs + 1
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ endif
+ enddo
+ enddo
+ endif
+
+ close(15)
+
+ 10 format('')
+ 15 format(e10.5,1x,e10.5)
+ 40 format(a50)
+
+ end program maille
+
+! *****************
+! routines maillage
+! *****************
+
+! --- numero global du noeud
+
+ integer function num(i,j,nx)
+ implicit none
+ integer i,j,nx
+
+ num = j*(nx+1) + i + 1
+ return
+ end function num
+
+! ------- definition des fonctions representant les interfaces -------
+
+!
+! --- bas du modele
+!
+
+ double precision function botprime(x)
+ implicit none
+ double precision x
+ botprime = 0.d0
+ return
+ end function botprime
+
+ double precision function bottom(x)
+ implicit none
+ double precision x
+ bottom = 0.d0
+ return
+ end function bottom
+
+!
+! --- representation interfaces par un spline
+!
+
+!--- spline
+ double precision function spl(x,xtopo,ztopo,coefs,ntopo)
+ implicit none
+ integer ntopo
+ double precision x,xp
+ double precision xtopo(ntopo),ztopo(ntopo)
+ double precision coefs(ntopo)
+
+ spl = 0.
+ xp = x
+ if (xp < xtopo(1)) xp = xtopo(1)
+ if (xp > xtopo(ntopo)) xp = xtopo(ntopo)
+ call splint(xtopo,ztopo,coefs,ntopo,xp,spl)
+
+ return
+ end function spl
+
+!--- derivee spline
+ double precision function spl_prime(x,xtopo,ztopo,coefs,ntopo)
+ implicit none
+ integer ntopo
+ double precision x
+ double precision xtopo(ntopo),ztopo(ntopo)
+ double precision coefs(ntopo)
+
+ if (x < xtopo(1).or.x > xtopo(ntopo)) then
+ spl_prime = 0.d0
+ else
+ call splintderiv(xtopo,ztopo,coefs,ntopo,x,spl_prime)
+ endif
+
+ return
+ end function spl_prime
+
+
+! --- fonction de densification du maillage horizontal
+
+ double precision function dens(ix,psi,xmin,xmax,nx)
+ implicit none
+ integer ix,nx
+ double precision psi(0:nx)
+ double precision xmin,xmax
+
+ dens = xmin + dble(xmax-xmin)*psi(ix)
+
+ return
+ end function dens
+
+! --------------------------------------
+
+! routine de calcul des coefs du spline (Numerical Recipes)
+ subroutine spline(x,y,n,yp1,ypn,y2)
+ implicit none
+
+ integer, parameter :: nmax=20000
+ integer n
+ double precision x(n),y(n),y2(n),u(nmax)
+ double precision yp1,ypn
+
+ integer i,k
+ double precision sig,p,qn,un
+
+ if(n > nmax) stop 'array too small in spline'
+ y2(1)=-0.5
+ u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
+ do i=2,n-1
+ sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
+ p=sig*y2(i-1)+2.
+ y2(i)=(sig-1.)/p
+ u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) &
+ /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
+ enddo
+ qn=0.5
+ un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
+ y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
+ do k=n-1,1,-1
+ y2(k)=y2(k)*y2(k+1)+u(k)
+ enddo
+ return
+ end subroutine spline
+
+! --------------
+
+! routine d'evaluation du spline (Numerical Recipes)
+ SUBROUTINE SPLINT(XA,YA,Y2A,N,X,Y)
+ implicit none
+
+ integer n
+ double precision XA(N),YA(N),Y2A(N)
+ double precision x,y
+
+ integer k,klo,khi
+ double precision h,a,b
+
+ KLO=1
+ KHI=N
+ 1 IF (KHI-KLO > 1) THEN
+ K=(KHI+KLO)/2
+ IF(XA(K) > X)THEN
+ KHI=K
+ ELSE
+ KLO=K
+ ENDIF
+ GOTO 1
+ ENDIF
+ 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
+ RETURN
+ end subroutine SPLINT
+
+! --------------
+
+! evaluation de la derivee premiere du spline (inspire de Numerical Recipes)
+ SUBROUTINE SPLINTDERIV(XA,YA,Y2A,N,X,Y)
+ implicit none
+
+ integer n
+ double precision XA(N),YA(N),Y2A(N)
+ double precision x,y
+
+ integer k,klo,khi
+ double precision h,a,b
+
+ KLO=1
+ KHI=N
+ 1 IF (KHI-KLO > 1) THEN
+ K=(KHI+KLO)/2
+ IF(XA(K) > X)THEN
+ KHI=K
+ ELSE
+ KLO=K
+ ENDIF
+ GOTO 1
+ ENDIF
+ H=XA(KHI)-XA(KLO)
+ IF (H == 0.d0) stop 'Bad input in spline derivative evaluation'
+ A=(XA(KHI)-X)/H
+ B=(X-XA(KLO))/H
+
+ Y=(-YA(KLO)+YA(KHI))/h+((-3.0d0*A**2+1.0d0)*Y2A(KLO)+ &
+ (3.0d0*B**2-1.0d0)*Y2A(KHI))*H/6.d0
+ RETURN
+ end subroutine SPLINTDERIV
Added: seismo/2D/SPECFEM2D/trunk/MAILLE90/maille_non_struct_2.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/MAILLE90/maille_non_struct_2.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/MAILLE90/maille_non_struct_2.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,970 @@
+!=====================================================================
+!
+! P r e m a i l l e u r F o r t r a n 9 0
+! -------------------------------------------
+!
+! Version 3.0
+! -----------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+!
+! (c) August 1998
+!
+!=====================================================================
+
+!
+! *** Version optimisee avec maillage non structure Jacques Muller - Elf ***
+! *** Raffinement d'un facteur 2 en surface ***
+!
+
+ program maille_non_struct_2
+
+ implicit none
+
+! definir les tableaux pour allocation dynamique
+
+! coordinates of the grid points
+ double precision, allocatable :: x(:,:),z(:,:)
+
+! variables needed to compute the transformation
+ double precision, allocatable :: psi(:),eta(:),absx(:), &
+ a00(:),a01(:),valeta(:),bot0(:),top0(:)
+
+! stockage du modele de vitesse et densite
+ double precision, allocatable :: rho(:),cp(:),cs(:)
+
+! the topography data
+ double precision, allocatable :: xtopo(:),ztopo(:),coefs_topo(:)
+
+! arrays for the source
+ double precision, allocatable :: xs(:),zs(:),f0(:),t0(:),angle(:),factor(:)
+ integer, allocatable :: isource_type(:),itimetype(:)
+
+! arrays for the receivers
+ double precision, allocatable :: xrec(:),zrec(:)
+
+! nom du fichier GNUPLOT contenant la grille
+ character(len=50) file1
+
+ character(len=50) interffile,topofile,title
+ character(len=15) junk
+
+ integer imatnum,inumabs,inumelem,nelemperio,nxgll,netyp
+ integer icodehaut,icodebas,icodegauche,icodedroite
+ integer nelemabs,npgeo,nspec,ntopo,nspecvolume,nspecWz
+ integer k,icol,ili,istepx,istepz,ncut,ix,iz,irec,i,j,iadd
+ integer ixdebzone,ixfinzone,izdebzone,izfinzone,imodnum
+ integer izone,imodele,nbzone,nbmodeles,iaffinfo
+ integer itaff,itfirstaff,iptsdisp,isubsamp,nrec,n1ana,n2ana
+ integer irepr,nrec1,nrec2,isamp,nbsources,isismostype,ivecttype
+ integer ngnod,nt,niter,idegpoly,nx,nz
+ integer inumelem2,ix2,iz2,inumperio
+ integer icodematread
+
+ double precision valseuil,freqmaxrep,ratio
+ double precision tang1,tangN,vpzone,vszone
+ double precision orig_x,orig_z,sizemax,cutvect,scalex,scalez
+ double precision factorxsu,factorana,xspacerec,zspacerec
+ double precision anglerec,anglerec2,xmin,xmax
+ double precision xfin,zfin,xfin2,zfin2,xdeb,zdeb,xdeb2,zdeb2
+ double precision alphanewm,betanewm,gammanewm,dt
+ double precision rhoread,cpread,csread,aniso3read,aniso4read
+
+ logical interpol,ignuplot,ireadmodel,iavs,ivisual3,ioutputgrid
+ logical abshaut,absbas,absgauche,absdroite,absstacey
+ logical periohaut,periogauche
+ logical sismos,isources_surf,ienreg_surf,ienreg_surf2,display
+ logical ivectplot,imeshvect,isymbols
+ logical topoplane,iexec,initialfield
+ logical imodelvect,iboundvect,usletter,compenergy
+
+ integer, external :: num
+ double precision, external :: bottom,spl,dens
+
+ double precision, parameter :: zero = 0.d0, one = 1.d0
+
+! simulation a 2D
+ integer, parameter :: ndime = 2
+ integer, parameter :: ndofn = 2
+
+! --- code des numeros d'aretes pour les bords absorbants
+ integer, parameter :: iaretebas = 1
+ integer, parameter :: iaretedroite = 2
+ integer, parameter :: iaretehaut = 3
+ integer, parameter :: iaretegauche = 4
+
+! DK DK DK ajout Elf : extraction de la topo du fichier SEP
+!! call system('rm -f topo_from_SEP.dat topo_SEP_maille90.dat ; xextract_topo')
+
+ print *
+ print *,' *** Version optimisee avec maillage non structure ***'
+ print *,' *** Raffinement d''un facteur 2 en surface ***'
+ print *
+
+! ***
+! *** read the parameter file
+! ***
+
+ print *,' Reading the parameter file ... '
+ print *
+
+ open(unit=10,file='Par',status='old')
+
+! formats
+
+ 1 format(a,f12.5)
+ 2 format(a,i8)
+ 3 format(a,a)
+ 4 format(a,l8)
+
+! read the header
+ do i=1,10
+ read(10,*)
+ enddo
+
+! read file names and path for output
+ read(10,3)junk,title
+ read(10,3)junk,topofile
+ read(10,3)junk,interffile
+
+ write(*,*) 'Titre de la simulation'
+ write(*,*) title
+ print *
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read grid parameters
+ read(10,1)junk,xmin
+ read(10,1)junk,xmax
+ read(10,2)junk,nx
+ read(10,2)junk,nz
+ read(10,2)junk,idegpoly
+ read(10,2)junk,ngnod
+ read(10,1)junk,ratio
+ read(10,4)junk,topoplane
+ read(10,4)junk,initialfield
+ read(10,4)junk,ireadmodel
+ read(10,4)junk,iexec
+
+! DK DK forcer pour Elf
+ ngnod = 9
+ topoplane = .false.
+ initialfield = .false.
+
+! pour le non structure, verifier la coherence du maillage
+ if(nx < 2) stop 'nx must be greater or equal to 2'
+ if(nz < 2) stop 'nz must be greater or equal to 2'
+ if(mod(nx,2) /= 0) stop 'nx must be even'
+
+! multiplier par 2 pour implementer le deraffinement non conforme
+ nx = nx * 2
+ nz = nz * 2
+
+! multiplier par 2 pour elements 9 noeuds
+ nx = nx * 2
+ nz = nz * 2
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read absorbing boundaries parameters
+ read(10,4)junk,abshaut
+ read(10,4)junk,absbas
+ read(10,4)junk,absgauche
+ read(10,4)junk,absdroite
+ read(10,4)junk,absstacey
+ read(10,4)junk,periohaut
+ read(10,4)junk,periogauche
+
+! DK DK forcer pour Elf
+ abshaut = .false.
+ periohaut = .false.
+ periogauche = .false.
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read time step parameters
+ read(10,2)junk,nt
+ read(10,1)junk,dt
+ read(10,2)junk,niter
+ read(10,1)junk,alphanewm
+ read(10,1)junk,betanewm
+ read(10,1)junk,gammanewm
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read source parameters
+ read(10,2)junk,nbsources
+ read(10,4)junk,isources_surf
+ read(10,1)junk,valseuil
+ read(10,1)junk,freqmaxrep
+ print *,'Nb de sources a lire : ',nbsources
+
+ allocate(xs(nbsources))
+ allocate(zs(nbsources))
+ allocate(f0(nbsources))
+ allocate(t0(nbsources))
+ allocate(isource_type(nbsources))
+ allocate(itimetype(nbsources))
+ allocate(angle(nbsources))
+ allocate(factor(nbsources))
+
+ do i=1,nbsources
+ read(10,*)
+ read(10,1)junk,xs(i)
+ read(10,1)junk,zs(i)
+ read(10,1)junk,f0(i)
+ read(10,1)junk,t0(i)
+ read(10,2)junk,isource_type(i)
+ read(10,2)junk,itimetype(i)
+ read(10,1)junk,angle(i)
+ read(10,1)junk,factor(i)
+
+ print *
+ print *,' Source #',i
+ print *,'Position xs, zs = ',xs(i),zs(i)
+ print *,'Frequency, delay = ',f0(i),t0(i)
+ print *,'Source type (1=force 2=explo) : ', &
+ isource_type(i)
+ print *,'Angle of the source if force = ',angle(i)
+ print *,'Multiplying factor = ',factor(i)
+ enddo
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read receivers line parameters
+ read(10,4)junk,sismos
+ read(10,2)junk,isamp
+ read(10,2)junk,isismostype
+ read(10,2)junk,irepr
+ read(10,*)
+ read(10,2)junk,nrec1
+ read(10,1)junk,xdeb
+ read(10,1)junk,zdeb
+ read(10,1)junk,xfin
+ read(10,1)junk,zfin
+ read(10,4)junk,ienreg_surf
+ read(10,1)junk,anglerec
+ read(10,*)
+ read(10,2)junk,nrec2
+ read(10,1)junk,xdeb2
+ read(10,1)junk,zdeb2
+ read(10,1)junk,xfin2
+ read(10,1)junk,zfin2
+ read(10,4)junk,ienreg_surf2
+ read(10,1)junk,anglerec2
+ read(10,*)
+ read(10,1)junk,factorxsu
+ read(10,2)junk,n1ana
+ read(10,2)junk,n2ana
+ read(10,1)junk,factorana
+
+! determination et affichage position ligne de receivers
+ if(nrec2 < 0) stop 'negative value of nrec2 !'
+
+ if(nrec2 == 0) then
+ nrec = nrec1
+ else
+ nrec = nrec1 + nrec2
+ endif
+
+! DK DK forcer pour Elf
+ n1ana = 1
+ n2ana = nrec
+
+ allocate(xrec(nrec))
+ allocate(zrec(nrec))
+
+ if(nrec2 == 0) then
+ print *
+ print *,'There are ',nrec,' receivers on a single line'
+ xspacerec=(xfin-xdeb)/dble(nrec-1)
+ zspacerec=(zfin-zdeb)/dble(nrec-1)
+ do i=1,nrec
+ xrec(i) = xdeb + dble(i-1)*xspacerec
+ zrec(i) = zdeb + dble(i-1)*zspacerec
+ enddo
+ else
+ print *
+ print *,'There are ',nrec,' receivers on two lines'
+ print *,'First line contains ',nrec1,' receivers'
+ print *,'Second line contains ',nrec2,' receivers'
+ xspacerec=(xfin-xdeb)/dble(nrec1-1)
+ zspacerec=(zfin-zdeb)/dble(nrec1-1)
+ do i=1,nrec1
+ xrec(i) = xdeb + dble(i-1)*xspacerec
+ zrec(i) = zdeb + dble(i-1)*zspacerec
+ enddo
+ xspacerec=(xfin2-xdeb2)/dble(nrec2-1)
+ zspacerec=(zfin2-zdeb2)/dble(nrec2-1)
+ do i=1,nrec2
+ xrec(i+nrec1) = xdeb2 + dble(i-1)*xspacerec
+ zrec(i+nrec1) = zdeb2 + dble(i-1)*zspacerec
+ enddo
+ endif
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read display parameters
+ read(10,4)junk,display
+ read(10,2)junk,itaff
+ read(10,2)junk,itfirstaff
+ read(10,2)junk,iaffinfo
+ read(10,4)junk,ivectplot
+ read(10,2)junk,ivecttype
+ read(10,1)junk,cutvect
+ read(10,4)junk,imeshvect
+ read(10,4)junk,imodelvect
+ read(10,4)junk,iboundvect
+ read(10,4)junk,interpol
+ read(10,2)junk,iptsdisp
+ read(10,2)junk,isubsamp
+ read(10,1)junk,scalex
+ read(10,1)junk,scalez
+ read(10,1)junk,sizemax
+ read(10,4)junk,usletter
+ read(10,1)junk,orig_x
+ read(10,1)junk,orig_z
+ read(10,4)junk,ignuplot
+ read(10,4)junk,iavs
+ read(10,4)junk,ivisual3
+ read(10,4)junk,ioutputgrid
+ read(10,4)junk,compenergy
+
+! DK DK forcer pour Elf
+ ignuplot = .false.
+ iavs = .false.
+ ivisual3 = .false.
+ compenergy = .false.
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! lecture des differents modeles de materiaux
+
+ read(10,2)junk,nbmodeles
+ if(nbmodeles <= 0) stop 'Negative number of models not allowed !!'
+
+ allocate(rho(nbmodeles))
+ allocate(cp(nbmodeles))
+ allocate(cs(nbmodeles))
+
+ rho(:) = 0.d0
+ cp(:) = 0.d0
+ cs(:) = 0.d0
+
+ do imodele=1,nbmodeles
+ read(10,*) i,icodematread,rhoread,cpread,csread,aniso3read,aniso4read
+ if(i<1 .or. i>nbmodeles) stop 'Wrong material set number'
+ rho(i) = rhoread
+ cp(i) = cpread
+ cs(i) = csread
+ if (rho(i) < 0.d0 .or. cp(i) < 0.d0 .or. cs(i) < 0.d0) &
+ stop 'Negative value of velocity or density'
+ enddo
+
+ print *
+ print *, 'Nb de modeles de roche = ',nbmodeles
+ print *
+ do i=1,nbmodeles
+ print *,'Modele #',i,' isotrope'
+ print *,'rho,cp,cs = ',rho(i),cp(i),cs(i)
+ enddo
+ print *
+
+ close(10)
+
+ print *
+ print *,' Parameter file successfully read... '
+
+! --------- fin lecture fichier parametres --------------
+
+ allocate(psi(0:nx))
+ allocate(eta(0:nz))
+ allocate(absx(0:nx))
+ allocate(a00(0:nz))
+ allocate(a01(0:nz))
+ allocate(valeta(0:nz))
+ allocate(bot0(0:nx))
+ allocate(top0(0:nx))
+
+! calcul des points regulierement espaces
+ do i=0,nx
+ psi(i) = i/dble(nx)
+ enddo
+ do j=0,nz
+ eta(j) = j/dble(nz)
+ enddo
+
+! quelques verifications de base a faire
+
+ if(ngnod /= 9) stop 'erreur ngnod different de 9 !!'
+
+! calcul du nombre total d'elements spectraux, absorbants et periodiques
+ nspecvolume = (nx/2/2)*((nz-4)/2/2)
+ nspecWz = 3*(nx/2/2)
+ nspec = nspecvolume + nspecWz
+ nelemperio = 0
+
+ if(absgauche .or. absdroite .or. absbas) then
+ nelemabs = 2 * (nz/4 - 2) + nx/4 + 2 + 2
+ else
+ nelemabs = 0
+ endif
+
+ print *
+ print *,'Le maillage comporte ',nspec,' elements spectraux (nx = ',nx/4, &
+ ' nz = ',nz/4,')'
+ print *,'soit ',nspecvolume,' elements spectraux dans le volume'
+ print *,'et ',nspecWz,' elements spectraux dans la couche Wz'
+ print *,'Chaque element comporte ',idegpoly+1,' points dans chaque direction'
+ print *,'Le nombre maximum de points theorique est ',nspec*(idegpoly+1)**ndime
+ print *,'Les elements de controle sont des elements ',ngnod,' noeuds'
+ print *
+
+!------------------------------------------------------
+
+ allocate(x(0:nx,0:nz))
+ allocate(z(0:nx,0:nz))
+
+ x(:,:)=0.d0
+ z(:,:)=0.d0
+
+! get topography data from external file
+ print *,'Reading topography from file ',topofile
+ open(unit=15,file=topofile,status='old')
+ read(15,*) ntopo
+ if (ntopo < 2) stop 'Not enough topography points (min 2)'
+ print *,'Reading ',ntopo,' points from topography file'
+ print *
+
+ allocate(xtopo(ntopo))
+ allocate(ztopo(ntopo))
+ allocate(coefs_topo(ntopo))
+
+ do i=1,ntopo
+ read(15,*) xtopo(i),ztopo(i)
+ enddo
+ close(15)
+
+! check the values read
+ print *
+ print *, 'Topography data points (x,z)'
+ print *, '----------------------------'
+ print *
+ print *, 'Topo 1 = (',xtopo(1),',',ztopo(1),')'
+ print *, 'Topo ntopo = (',xtopo(ntopo),',',ztopo(ntopo),')'
+
+!--- calculate the spline function for the topography
+!--- imposer les tangentes aux deux bords
+ tang1 = (ztopo(2)-ztopo(1))/(xtopo(2)-xtopo(1))
+ tangN = (ztopo(ntopo)-ztopo(ntopo-1))/(xtopo(ntopo)-xtopo(ntopo-1))
+ call spline(xtopo,ztopo,ntopo,tang1,tangN,coefs_topo)
+
+! *** afficher limites du modele lu
+ print *
+ print *, 'Limites absolues modele fichier topo :'
+ print *
+ print *, 'Xmin = ',minval(xtopo),' Xmax = ',maxval(xtopo)
+ print *, 'Zmin = ',minval(ztopo),' Zmax = ',maxval(ztopo)
+ print *
+
+! *** modifier sources pour position par rapport a la surface
+ print *
+ print *, 'Position (x,z) des ',nbsources,' sources'
+ print *
+ do i=1,nbsources
+
+! DK DK DK Elf : position source donnee en profondeur par rapport a la topo
+ zs(i) = spl(xs(i),xtopo,ztopo,coefs_topo,ntopo) - zs(i)
+
+ if(isources_surf) zs(i) = spl(xs(i),xtopo,ztopo,coefs_topo,ntopo)
+ print *, 'Source ',i,' = ',xs(i),zs(i)
+ enddo
+
+! *** modifier recepteurs pour enregistrement en surface
+ print *
+ print *, 'Position (x,z) des ',nrec,' receivers'
+ print *
+ do irec=1,nrec
+
+! DK DK DK Elf : distinguer les deux lignes de recepteurs
+ if(irec <= nrec1) then
+ if(ienreg_surf) zrec(irec) = spl(xrec(irec),xtopo,ztopo,coefs_topo,ntopo)
+ else
+ if(ienreg_surf2) zrec(irec) = spl(xrec(irec),xtopo,ztopo,coefs_topo,ntopo)
+ endif
+ print *, 'Receiver ',irec,' = ',xrec(irec),zrec(irec)
+
+ enddo
+
+!--- definition du maillage suivant X
+ do ix=0,nx
+ absx(ix) = dens(ix,psi,xmin,xmax,nx)
+ enddo
+
+! *** une seule zone
+
+ do iz=0,nz
+
+! DK DK DK densification sinusoidale ici en vertical
+ valeta(iz) = eta(iz) + ratio * sin(3.14159265 * eta(iz))
+ if(valeta(iz) < zero) valeta(iz) = zero
+ if(valeta(iz) > one ) valeta(iz) = one
+! DK DK DK densification sinusoidale ici en vertical
+
+ a00(iz) = 1-valeta(iz)
+ a01(iz) = valeta(iz)
+ enddo
+
+ do ix=0,nx
+ bot0(ix) = bottom(absx(ix))
+ top0(ix) = spl(absx(ix),xtopo,ztopo,coefs_topo,ntopo)
+ enddo
+
+! valeurs de x et y pour display domaine physique
+ do ix=0,nx
+ do iz=0,nz
+ x(ix,iz) = absx(ix)
+ z(ix,iz) = a00(iz)*bot0(ix) + a01(iz)*top0(ix)
+ enddo
+ enddo
+
+! calculer min et max de X et Z sur la grille
+ print *
+ print *, 'Valeurs min et max de X sur le maillage = ',minval(x),maxval(x)
+ print *, 'Valeurs min et max de Z sur le maillage = ',minval(z),maxval(z)
+ print *
+
+! *** generation de la base de donnees
+
+ print *
+ print *,' Creation de la base de donnees pour SPECFEM...'
+ print *
+
+ open(unit=15,file='../SPECFEM90/DataBase',status='unknown')
+
+ write(15,*) '#'
+ write(15,*) '# Base de Donnees pour Specfem - Premailleur Fortran 90'
+ write(15,*) '# ',title
+ write(15,*) '# Dimitri Komatitsch, (c) EPS - Harvard August 1998'
+ write(15,*) '#'
+
+ write(15,*) 'Titre simulation'
+ write(15,40) title
+
+ npgeo = (nx+1)*(nz+1)
+ write(15,*) 'ndofn ndime npgeo'
+ write(15,*) ndofn,ndime,npgeo
+
+ write(15,*) 'display ignuplot interpol'
+ write(15,*) display,ignuplot,interpol
+
+ write(15,*) 'itaff itfirstaff icolor inumber'
+ write(15,*) itaff,itfirstaff,0,0
+
+ write(15,*) 'ivectplot imeshvect imodelvect iboundvect cutvect isubsamp'
+ write(15,*) ivectplot,imeshvect,imodelvect,iboundvect,cutvect,isubsamp
+
+ write(15,*) 'scalex scalez sizemax angle rapport USletter'
+ write(15,*) scalex,scalez,sizemax,20.,0.40,usletter
+
+ write(15,*) 'orig_x orig_z isymbols'
+ write(15,*) orig_x,orig_z,' T'
+
+ write(15,*) 'valseuil freqmaxrep'
+ write(15,*) valseuil,freqmaxrep
+
+ write(15,*) 'sismos nrec nrec1 nrec2 isamp'
+ write(15,*) sismos,nrec,nrec1,nrec2,isamp
+
+ write(15,*) 'irepr anglerec anglerec2'
+ write(15,*) irepr,anglerec,anglerec2
+
+ write(15,*) 'topoplane absstacey compenergy'
+ write(15,*) topoplane,absstacey,compenergy
+
+ write(15,*) 'initialfield factorana factorxsu n1ana n2ana'
+ write(15,*) initialfield,factorana,factorxsu,n1ana,n2ana
+
+ write(15,*) 'isismostype ivecttype iaffinfo'
+ write(15,*) isismostype,ivecttype,iaffinfo
+
+ write(15,*) 'ireadmodel ioutputgrid iavs ivisual3'
+ write(15,*) ireadmodel,ioutputgrid,iavs,ivisual3
+
+ write(15,*) 'iexec iecho'
+ if(iexec) then
+ write(15,*) '1 1'
+ else
+ write(15,*) '0 1'
+ endif
+
+ write(15,*) 'ncycl dtinc niter'
+ write(15,*) nt,dt,niter
+
+ write(15,*) 'alpha beta gamma (alpha not used for the moment)'
+ write(15,*) alphanewm,betanewm,gammanewm
+
+ write(15,*) 'nltfl (number of force or pressure sources)'
+ write(15,*) nbsources
+
+ write(15,*) 'Collocated forces and/or pressure sources:'
+ do i=1,nbsources
+ write(15,*) itimetype(i),isource_type(i), &
+ xs(i)-xmin ,zs(i), &
+ f0(i),t0(i),factor(i),angle(i),0
+ enddo
+
+ write(15,*) 'Receivers positions:'
+ do irec=1,nrec
+ write(15,*) irec,xrec(irec)-xmin ,zrec(irec)
+ enddo
+
+ write(15,*) 'Coordinates of macroblocs mesh (coorg):'
+ do j=0,nz
+ do i=0,nx
+ write(15,*) num(i,j,nx),x(i,j)-xmin,z(i,j)
+ enddo
+ enddo
+
+ netyp = 2
+ nxgll = idegpoly + 1
+
+ write(15,*) 'netyp numat ngnod nxgll nygll nspec iptsdisp ielemabs ielemperio'
+ write(15,*) netyp,nbmodeles,ngnod,nxgll,nxgll,nspec,iptsdisp, &
+ nelemabs,nelemperio
+
+ write(15,*) 'Material sets (num 0 rho vp vs 0 0)'
+ do i=1,nbmodeles
+ write(15,*) i,0,rho(i),cp(i),cs(i),0,0
+ enddo
+
+
+ write(15,*) 'Arrays kmato and knods for each bloc:'
+
+ imatnum = 1
+ k=0
+
+! zone structuree dans le volume
+ do j=0,nz-8,4
+ do i=0,nx-4,4
+ k = k + 1
+ write(15,*) k,imatnum,num(i,j,nx),num(i+4,j,nx),num(i+4,j+4,nx), &
+ num(i,j+4,nx),num(i+2,j,nx),num(i+4,j+2,nx), &
+ num(i+2,j+4,nx),num(i,j+2,nx),num(i+2,j+2,nx)
+ enddo
+ enddo
+
+ if(k /= nspecvolume) stop 'nombre d''elements incoherent dans le volume'
+
+! zone non structuree dans la couche Wz
+ j=nz-4
+ do i=0,nx-8,8
+
+! element 1 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i,j,nx),num(i+4,j,nx),num(i+2,j+2,nx), &
+ num(i,j+2,nx),num(i+2,j,nx),num(i+3,j+1,nx), &
+ num(i+1,j+2,nx),num(i,j+1,nx),num(i+1,j+1,nx)
+
+! element 2 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i,j+2,nx),num(i+2,j+2,nx),num(i+2,j+4,nx), &
+ num(i,j+4,nx),num(i+1,j+2,nx),num(i+2,j+3,nx), &
+ num(i+1,j+4,nx),num(i,j+3,nx),num(i+1,j+3,nx)
+
+! element 3 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+2,j+2,nx),num(i+4,j,nx),num(i+4,j+4,nx), &
+ num(i+2,j+4,nx),num(i+3,j+1,nx),num(i+4,j+2,nx), &
+ num(i+3,j+4,nx),num(i+2,j+3,nx),num(i+3,j+3,nx)
+
+! element 4 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+4,j,nx),num(i+6,j+2,nx),num(i+6,j+4,nx), &
+ num(i+4,j+4,nx),num(i+5,j+1,nx),num(i+6,j+3,nx), &
+ num(i+5,j+4,nx),num(i+4,j+2,nx),num(i+5,j+3,nx)
+
+! element 5 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+4,j,nx),num(i+8,j,nx),num(i+8,j+2,nx), &
+ num(i+6,j+2,nx),num(i+6,j,nx),num(i+8,j+1,nx), &
+ num(i+7,j+2,nx),num(i+5,j+1,nx),num(i+7,j+1,nx)
+
+! element 6 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+6,j+2,nx),num(i+8,j+2,nx),num(i+8,j+4,nx), &
+ num(i+6,j+4,nx),num(i+7,j+2,nx),num(i+8,j+3,nx), &
+ num(i+7,j+4,nx),num(i+6,j+3,nx),num(i+7,j+3,nx)
+
+ enddo
+
+ if(k /= nspec) stop 'nombre d''elements incoherent dans la couche Wz'
+
+!
+!--- sauvegarde des bords absorbants
+!
+
+ print *
+ print *,'Au total il y a ',nelemabs,' elements absorbants'
+ print *
+ print *,'Bords absorbants actifs :'
+ print *
+ print *,'Haut = ',abshaut
+ print *,'Bas = ',absbas
+ print *,'Gauche = ',absgauche
+ print *,'Droite = ',absdroite
+ print *
+ print *,'Stacey = ',absstacey
+ print *
+
+! generer la liste des elements absorbants
+ if(nelemabs > 0) then
+ write(15,*) 'Liste des elements absorbants (haut bas gauche droite) :'
+
+! repasser aux vrais valeurs de nx et nz
+ nx = nx / 4
+ nz = nz / 4
+
+ inumabs = 0
+
+! bord absorbant du bas sans les coins
+ iz = 1
+ do ix = 2,nx-1
+ inumabs = inumabs + 1
+ inumelem = (iz-1)*nx + ix
+ icodehaut = 0
+ icodebas = iaretebas
+ icodegauche = 0
+ icodedroite = 0
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+! coin en bas a gauche
+ inumabs = inumabs + 1
+ inumelem = 1
+ icodehaut = 0
+ icodebas = iaretebas
+ icodegauche = iaretegauche
+ icodedroite = 0
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+
+! coin en bas a droite
+ inumabs = inumabs + 1
+ inumelem = nx
+ icodehaut = 0
+ icodebas = iaretebas
+ icodegauche = 0
+ icodedroite = iaretedroite
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+
+! partie structuree du bord de gauche
+ ix = 1
+ do iz = 2,nz-1
+ inumabs = inumabs + 1
+ inumelem = (iz-1)*nx + ix
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = iaretegauche
+ icodedroite = 0
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+! partie structuree du bord de droite
+ ix = nx
+ do iz = 2,nz-1
+ inumabs = inumabs + 1
+ inumelem = (iz-1)*nx + ix
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = 0
+ icodedroite = iaretedroite
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+! partie non structuree du bord de gauche (deux elements)
+ do iadd = 1,2
+ inumabs = inumabs + 1
+ inumelem = nx*(nz-1) + iadd
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = iaretegauche
+ icodedroite = 0
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+! partie non structuree du bord de droite (deux elements)
+ do iadd = 1,2
+ inumabs = inumabs + 1
+ inumelem = nspec - iadd + 1
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = 0
+ icodedroite = iaretedroite
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+ if(inumabs /= nelemabs) stop 'nombre d''elements absorbants incoherent'
+
+ endif
+
+! fermer la base de donnees
+
+ close(15)
+
+ 40 format(a50)
+
+ end program maille_non_struct_2
+
+! *****************
+! routines maillage
+! *****************
+
+! --- numero global du noeud
+
+ integer function num(i,j,nx)
+ implicit none
+ integer i,j,nx
+
+ num = j*(nx+1) + i + 1
+ return
+ end function num
+
+! ------- definition des fonctions representant les interfaces -------
+
+!
+! --- bas du modele
+!
+
+ double precision function bottom(x)
+ implicit none
+ double precision x
+ bottom = 0.d0
+ return
+ end function bottom
+
+!
+! --- representation interfaces par un spline
+!
+
+!--- spline
+ double precision function spl(x,xtopo,ztopo,coefs,ntopo)
+ implicit none
+ integer ntopo
+ double precision x,xp
+ double precision xtopo(ntopo),ztopo(ntopo)
+ double precision coefs(ntopo)
+
+ spl = 0.
+ xp = x
+ if (xp < xtopo(1)) xp = xtopo(1)
+ if (xp > xtopo(ntopo)) xp = xtopo(ntopo)
+ call splint(xtopo,ztopo,coefs,ntopo,xp,spl)
+
+ return
+ end function spl
+
+! --- fonction de densification du maillage horizontal
+
+ double precision function dens(ix,psi,xmin,xmax,nx)
+ implicit none
+ integer ix,nx
+ double precision psi(0:nx)
+ double precision xmin,xmax
+
+ dens = xmin + dble(xmax-xmin)*psi(ix)
+
+ return
+ end function dens
+
+! --------------------------------------
+
+! routine de calcul des coefs du spline (Numerical Recipes)
+ subroutine spline(x,y,n,yp1,ypn,y2)
+ implicit none
+
+ integer n
+ double precision x(n),y(n),y2(n)
+ double precision, dimension(:), allocatable :: u
+ double precision yp1,ypn
+
+ integer i,k
+ double precision sig,p,qn,un
+
+ allocate(u(n))
+
+ y2(1)=-0.5
+ u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
+ do i=2,n-1
+ sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
+ p=sig*y2(i-1)+2.
+ y2(i)=(sig-1.)/p
+ u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) &
+ /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
+ enddo
+ qn=0.5
+ un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
+ y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
+ do k=n-1,1,-1
+ y2(k)=y2(k)*y2(k+1)+u(k)
+ enddo
+
+ deallocate(u)
+
+ return
+ end subroutine spline
+
+! --------------
+
+! routine d'evaluation du spline (Numerical Recipes)
+ SUBROUTINE SPLINT(XA,YA,Y2A,N,X,Y)
+ implicit none
+
+ integer n
+ double precision XA(N),YA(N),Y2A(N)
+ double precision x,y
+
+ integer k,klo,khi
+ double precision h,a,b
+
+ KLO=1
+ KHI=N
+ do while (KHI-KLO > 1)
+ K=(KHI+KLO)/2
+ IF(XA(K) > X)THEN
+ KHI=K
+ ELSE
+ KLO=K
+ ENDIF
+ enddo
+ H=XA(KHI)-XA(KLO)
+ IF (H == 0.d0) stop 'Bad input in spline evaluation'
+ A=(XA(KHI)-X)/H
+ B=(X-XA(KLO))/H
+
+ Y=A*YA(KLO)+B*YA(KHI)+((A**3-A)*Y2A(KLO)+ &
+ (B**3-B)*Y2A(KHI))*(H**2)/6.d0
+ RETURN
+ end subroutine SPLINT
+
Added: seismo/2D/SPECFEM2D/trunk/MAILLE90/maille_non_struct_3.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/MAILLE90/maille_non_struct_3.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/MAILLE90/maille_non_struct_3.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,994 @@
+!=====================================================================
+!
+! P r e m a i l l e u r F o r t r a n 9 0
+! -------------------------------------------
+!
+! Version 3.0
+! -----------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+!
+! (c) August 1998
+!
+!=====================================================================
+
+!
+! *** Version optimisee avec maillage non structure Jacques Muller - Elf ***
+! *** Raffinement d'un facteur 3 en surface ***
+!
+
+ program maille_non_struct_3
+
+ implicit none
+
+! definir les tableaux pour allocation dynamique
+
+! coordinates of the grid points
+ double precision, allocatable :: x(:,:),z(:,:)
+
+! variables needed to compute the transformation
+ double precision, allocatable :: psi(:),eta(:),absx(:), &
+ a00(:),a01(:),valeta(:),bot0(:),top0(:)
+
+! stockage du modele de vitesse et densite
+ double precision, allocatable :: rho(:),cp(:),cs(:)
+
+! the topography data
+ double precision, allocatable :: xtopo(:),ztopo(:),coefs_topo(:)
+
+! arrays for the source
+ double precision, allocatable :: xs(:),zs(:),f0(:),t0(:),angle(:),factor(:)
+ integer, allocatable :: isource_type(:),itimetype(:)
+
+! arrays for the receivers
+ double precision, allocatable :: xrec(:),zrec(:)
+
+! nom du fichier GNUPLOT contenant la grille
+ character(len=50) file1
+
+ character(len=50) interffile,topofile,title
+ character(len=15) junk
+
+ integer imatnum,inumabs,inumelem,nelemperio,nxgll,netyp
+ integer icodehaut,icodebas,icodegauche,icodedroite
+ integer nelemabs,npgeo,nspec,ntopo,nspecvolume,nspecWz
+ integer k,icol,ili,istepx,istepz,ncut,ix,iz,irec,i,j,iadd
+ integer ixdebzone,ixfinzone,izdebzone,izfinzone,imodnum
+ integer izone,imodele,nbzone,nbmodeles,iaffinfo
+ integer itaff,itfirstaff,iptsdisp,isubsamp,nrec,n1ana,n2ana
+ integer irepr,nrec1,nrec2,isamp,nbsources,isismostype,ivecttype
+ integer ngnod,nt,niter,idegpoly,nx,nz
+ integer inumelem2,ix2,iz2,inumperio
+ integer icodematread
+
+ double precision valseuil,freqmaxrep,ratio
+ double precision tang1,tangN,vpzone,vszone
+ double precision orig_x,orig_z,sizemax,cutvect,scalex,scalez
+ double precision factorxsu,factorana,xspacerec,zspacerec
+ double precision anglerec,anglerec2,xmin,xmax
+ double precision xfin,zfin,xfin2,zfin2,xdeb,zdeb,xdeb2,zdeb2
+ double precision alphanewm,betanewm,gammanewm,dt
+ double precision rhoread,cpread,csread,aniso3read,aniso4read
+
+ logical interpol,ignuplot,ireadmodel,iavs,ivisual3,ioutputgrid
+ logical abshaut,absbas,absgauche,absdroite,absstacey
+ logical periohaut,periogauche
+ logical sismos,isources_surf,ienreg_surf,ienreg_surf2,display
+ logical ivectplot,imeshvect,isymbols
+ logical topoplane,iexec,initialfield
+ logical imodelvect,iboundvect,usletter,compenergy
+
+ integer, external :: num
+ double precision, external :: bottom,spl,dens
+
+ double precision, parameter :: zero = 0.d0, one = 1.d0
+
+! simulation a 2D
+ integer, parameter :: ndime = 2
+ integer, parameter :: ndofn = 2
+
+! --- code des numeros d'aretes pour les bords absorbants
+ integer, parameter :: iaretebas = 1
+ integer, parameter :: iaretedroite = 2
+ integer, parameter :: iaretehaut = 3
+ integer, parameter :: iaretegauche = 4
+
+! DK DK DK ajout Elf : extraction de la topo du fichier SEP
+!! call system('rm -f topo_from_SEP.dat topo_SEP_maille90.dat ; xextract_topo')
+
+ print *
+ print *,' *** Version optimisee avec maillage non structure ***'
+ print *,' *** Raffinement d''un facteur 3 en surface ***'
+ print *
+
+! ***
+! *** read the parameter file
+! ***
+
+ print *,' Reading the parameter file ... '
+ print *
+
+ open(unit=10,file='Par',status='old')
+
+! formats
+
+ 1 format(a,f12.5)
+ 2 format(a,i8)
+ 3 format(a,a)
+ 4 format(a,l8)
+
+! read the header
+ do i=1,10
+ read(10,*)
+ enddo
+
+! read file names and path for output
+ read(10,3)junk,title
+ read(10,3)junk,topofile
+ read(10,3)junk,interffile
+
+ write(*,*) 'Titre de la simulation'
+ write(*,*) title
+ print *
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read grid parameters
+ read(10,1)junk,xmin
+ read(10,1)junk,xmax
+ read(10,2)junk,nx
+ read(10,2)junk,nz
+ read(10,2)junk,idegpoly
+ read(10,2)junk,ngnod
+ read(10,1)junk,ratio
+ read(10,4)junk,topoplane
+ read(10,4)junk,initialfield
+ read(10,4)junk,ireadmodel
+ read(10,4)junk,iexec
+
+! DK DK forcer pour Elf
+ ngnod = 9
+ topoplane = .false.
+ initialfield = .false.
+
+! pour le non structure, verifier la coherence du maillage
+ if(nx < 2) stop 'nx must be greater or equal to 2'
+ if(nz < 2) stop 'nz must be greater or equal to 2'
+ if(mod(nx,2) /= 0) stop 'nx must be even'
+
+! multiplier par 3 pour implementer le deraffinement non conforme
+ nx = nx * 3
+ nz = nz * 3
+
+! multiplier par 2 pour elements 9 noeuds
+ nx = nx * 2
+ nz = nz * 2
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read absorbing boundaries parameters
+ read(10,4)junk,abshaut
+ read(10,4)junk,absbas
+ read(10,4)junk,absgauche
+ read(10,4)junk,absdroite
+ read(10,4)junk,absstacey
+ read(10,4)junk,periohaut
+ read(10,4)junk,periogauche
+
+! DK DK forcer pour Elf
+ abshaut = .false.
+ periohaut = .false.
+ periogauche = .false.
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read time step parameters
+ read(10,2)junk,nt
+ read(10,1)junk,dt
+ read(10,2)junk,niter
+ read(10,1)junk,alphanewm
+ read(10,1)junk,betanewm
+ read(10,1)junk,gammanewm
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read source parameters
+ read(10,2)junk,nbsources
+ read(10,4)junk,isources_surf
+ read(10,1)junk,valseuil
+ read(10,1)junk,freqmaxrep
+ print *,'Nb de sources a lire : ',nbsources
+
+ allocate(xs(nbsources))
+ allocate(zs(nbsources))
+ allocate(f0(nbsources))
+ allocate(t0(nbsources))
+ allocate(isource_type(nbsources))
+ allocate(itimetype(nbsources))
+ allocate(angle(nbsources))
+ allocate(factor(nbsources))
+
+ do i=1,nbsources
+ read(10,*)
+ read(10,1)junk,xs(i)
+ read(10,1)junk,zs(i)
+ read(10,1)junk,f0(i)
+ read(10,1)junk,t0(i)
+ read(10,2)junk,isource_type(i)
+ read(10,2)junk,itimetype(i)
+ read(10,1)junk,angle(i)
+ read(10,1)junk,factor(i)
+
+ print *
+ print *,' Source #',i
+ print *,'Position xs, zs = ',xs(i),zs(i)
+ print *,'Frequency, delay = ',f0(i),t0(i)
+ print *,'Source type (1=force 2=explo) : ', &
+ isource_type(i)
+ print *,'Angle of the source if force = ',angle(i)
+ print *,'Multiplying factor = ',factor(i)
+ enddo
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read receivers line parameters
+ read(10,4)junk,sismos
+ read(10,2)junk,isamp
+ read(10,2)junk,isismostype
+ read(10,2)junk,irepr
+ read(10,*)
+ read(10,2)junk,nrec1
+ read(10,1)junk,xdeb
+ read(10,1)junk,zdeb
+ read(10,1)junk,xfin
+ read(10,1)junk,zfin
+ read(10,4)junk,ienreg_surf
+ read(10,1)junk,anglerec
+ read(10,*)
+ read(10,2)junk,nrec2
+ read(10,1)junk,xdeb2
+ read(10,1)junk,zdeb2
+ read(10,1)junk,xfin2
+ read(10,1)junk,zfin2
+ read(10,4)junk,ienreg_surf2
+ read(10,1)junk,anglerec2
+ read(10,*)
+ read(10,1)junk,factorxsu
+ read(10,2)junk,n1ana
+ read(10,2)junk,n2ana
+ read(10,1)junk,factorana
+
+! determination et affichage position ligne de receivers
+ if(nrec2 < 0) stop 'negative value of nrec2 !'
+
+ if(nrec2 == 0) then
+ nrec = nrec1
+ else
+ nrec = nrec1 + nrec2
+ endif
+
+! DK DK forcer pour Elf
+ n1ana = 1
+ n2ana = nrec
+
+ allocate(xrec(nrec))
+ allocate(zrec(nrec))
+
+ if(nrec2 == 0) then
+ print *
+ print *,'There are ',nrec,' receivers on a single line'
+ xspacerec=(xfin-xdeb)/dble(nrec-1)
+ zspacerec=(zfin-zdeb)/dble(nrec-1)
+ do i=1,nrec
+ xrec(i) = xdeb + dble(i-1)*xspacerec
+ zrec(i) = zdeb + dble(i-1)*zspacerec
+ enddo
+ else
+ print *
+ print *,'There are ',nrec,' receivers on two lines'
+ print *,'First line contains ',nrec1,' receivers'
+ print *,'Second line contains ',nrec2,' receivers'
+ xspacerec=(xfin-xdeb)/dble(nrec1-1)
+ zspacerec=(zfin-zdeb)/dble(nrec1-1)
+ do i=1,nrec1
+ xrec(i) = xdeb + dble(i-1)*xspacerec
+ zrec(i) = zdeb + dble(i-1)*zspacerec
+ enddo
+ xspacerec=(xfin2-xdeb2)/dble(nrec2-1)
+ zspacerec=(zfin2-zdeb2)/dble(nrec2-1)
+ do i=1,nrec2
+ xrec(i+nrec1) = xdeb2 + dble(i-1)*xspacerec
+ zrec(i+nrec1) = zdeb2 + dble(i-1)*zspacerec
+ enddo
+ endif
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read display parameters
+ read(10,4)junk,display
+ read(10,2)junk,itaff
+ read(10,2)junk,itfirstaff
+ read(10,2)junk,iaffinfo
+ read(10,4)junk,ivectplot
+ read(10,2)junk,ivecttype
+ read(10,1)junk,cutvect
+ read(10,4)junk,imeshvect
+ read(10,4)junk,imodelvect
+ read(10,4)junk,iboundvect
+ read(10,4)junk,interpol
+ read(10,2)junk,iptsdisp
+ read(10,2)junk,isubsamp
+ read(10,1)junk,scalex
+ read(10,1)junk,scalez
+ read(10,1)junk,sizemax
+ read(10,4)junk,usletter
+ read(10,1)junk,orig_x
+ read(10,1)junk,orig_z
+ read(10,4)junk,ignuplot
+ read(10,4)junk,iavs
+ read(10,4)junk,ivisual3
+ read(10,4)junk,ioutputgrid
+ read(10,4)junk,compenergy
+
+! DK DK forcer pour Elf
+ ignuplot = .false.
+ iavs = .false.
+ ivisual3 = .false.
+ compenergy = .false.
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! lecture des differents modeles de materiaux
+
+ read(10,2)junk,nbmodeles
+ if(nbmodeles <= 0) stop 'Negative number of models not allowed !!'
+
+ allocate(rho(nbmodeles))
+ allocate(cp(nbmodeles))
+ allocate(cs(nbmodeles))
+
+ rho(:) = 0.d0
+ cp(:) = 0.d0
+ cs(:) = 0.d0
+
+ do imodele=1,nbmodeles
+ read(10,*) i,icodematread,rhoread,cpread,csread,aniso3read,aniso4read
+ if(i<1 .or. i>nbmodeles) stop 'Wrong material set number'
+ rho(i) = rhoread
+ cp(i) = cpread
+ cs(i) = csread
+ if (rho(i) < 0.d0 .or. cp(i) < 0.d0 .or. cs(i) < 0.d0) &
+ stop 'Negative value of velocity or density'
+ enddo
+
+ print *
+ print *, 'Nb de modeles de roche = ',nbmodeles
+ print *
+ do i=1,nbmodeles
+ print *,'Modele #',i,' isotrope'
+ print *,'rho,cp,cs = ',rho(i),cp(i),cs(i)
+ enddo
+ print *
+
+ close(10)
+
+ print *
+ print *,' Parameter file successfully read... '
+
+! --------- fin lecture fichier parametres --------------
+
+ allocate(psi(0:nx))
+ allocate(eta(0:nz))
+ allocate(absx(0:nx))
+ allocate(a00(0:nz))
+ allocate(a01(0:nz))
+ allocate(valeta(0:nz))
+ allocate(bot0(0:nx))
+ allocate(top0(0:nx))
+
+! calcul des points regulierement espaces
+ do i=0,nx
+ psi(i) = i/dble(nx)
+ enddo
+ do j=0,nz
+ eta(j) = j/dble(nz)
+ enddo
+
+! quelques verifications de base a faire
+
+ if(ngnod /= 9) stop 'erreur ngnod different de 9 !!'
+
+! calcul du nombre total d'elements spectraux, absorbants et periodiques
+ nspecvolume = (nx/2/3)*((nz-6)/2/3)
+ nspecWz = 5*(nx/2/3)
+ nspec = nspecvolume + nspecWz
+ nelemperio = 0
+
+ if(absgauche .or. absdroite .or. absbas) then
+ nelemabs = 2 * (nz/6 - 2) + nx/6 + 3 + 3
+ else
+ nelemabs = 0
+ endif
+
+ print *
+ print *,'Le maillage comporte ',nspec,' elements spectraux (nx = ',nx/6, &
+ ' nz = ',nz/6,')'
+ print *,'soit ',nspecvolume,' elements spectraux dans le volume'
+ print *,'et ',nspecWz,' elements spectraux dans la couche Wz'
+ print *,'Chaque element comporte ',idegpoly+1,' points dans chaque direction'
+ print *,'Le nombre maximum de points theorique est ',nspec*(idegpoly+1)**ndime
+ print *,'Les elements de controle sont des elements ',ngnod,' noeuds'
+ print *
+
+!------------------------------------------------------
+
+ allocate(x(0:nx,0:nz))
+ allocate(z(0:nx,0:nz))
+
+ x(:,:)=0.d0
+ z(:,:)=0.d0
+
+! get topography data from external file
+ print *,'Reading topography from file ',topofile
+ open(unit=15,file=topofile,status='old')
+ read(15,*) ntopo
+ if (ntopo < 2) stop 'Not enough topography points (min 2)'
+ print *,'Reading ',ntopo,' points from topography file'
+ print *
+
+ allocate(xtopo(ntopo))
+ allocate(ztopo(ntopo))
+ allocate(coefs_topo(ntopo))
+
+ do i=1,ntopo
+ read(15,*) xtopo(i),ztopo(i)
+ enddo
+ close(15)
+
+! check the values read
+ print *
+ print *, 'Topography data points (x,z)'
+ print *, '----------------------------'
+ print *
+ print *, 'Topo 1 = (',xtopo(1),',',ztopo(1),')'
+ print *, 'Topo ntopo = (',xtopo(ntopo),',',ztopo(ntopo),')'
+
+!--- calculate the spline function for the topography
+!--- imposer les tangentes aux deux bords
+ tang1 = (ztopo(2)-ztopo(1))/(xtopo(2)-xtopo(1))
+ tangN = (ztopo(ntopo)-ztopo(ntopo-1))/(xtopo(ntopo)-xtopo(ntopo-1))
+ call spline(xtopo,ztopo,ntopo,tang1,tangN,coefs_topo)
+
+! *** afficher limites du modele lu
+ print *
+ print *, 'Limites absolues modele fichier topo :'
+ print *
+ print *, 'Xmin = ',minval(xtopo),' Xmax = ',maxval(xtopo)
+ print *, 'Zmin = ',minval(ztopo),' Zmax = ',maxval(ztopo)
+ print *
+
+! *** modifier sources pour position par rapport a la surface
+ print *
+ print *, 'Position (x,z) des ',nbsources,' sources'
+ print *
+ do i=1,nbsources
+
+! DK DK DK Elf : position source donnee en profondeur par rapport a la topo
+ zs(i) = spl(xs(i),xtopo,ztopo,coefs_topo,ntopo) - zs(i)
+
+ if(isources_surf) zs(i) = spl(xs(i),xtopo,ztopo,coefs_topo,ntopo)
+ print *, 'Source ',i,' = ',xs(i),zs(i)
+ enddo
+
+! *** modifier recepteurs pour enregistrement en surface
+ print *
+ print *, 'Position (x,z) des ',nrec,' receivers'
+ print *
+ do irec=1,nrec
+
+! DK DK DK Elf : distinguer les deux lignes de recepteurs
+ if(irec <= nrec1) then
+ if(ienreg_surf) zrec(irec) = spl(xrec(irec),xtopo,ztopo,coefs_topo,ntopo)
+ else
+ if(ienreg_surf2) zrec(irec) = spl(xrec(irec),xtopo,ztopo,coefs_topo,ntopo)
+ endif
+ print *, 'Receiver ',irec,' = ',xrec(irec),zrec(irec)
+
+ enddo
+
+!--- definition du maillage suivant X
+ do ix=0,nx
+ absx(ix) = dens(ix,psi,xmin,xmax,nx)
+ enddo
+
+! *** une seule zone
+
+ do iz=0,nz
+
+! DK DK DK densification sinusoidale ici en vertical
+ valeta(iz) = eta(iz) + ratio * sin(3.14159265 * eta(iz))
+ if(valeta(iz) < zero) valeta(iz) = zero
+ if(valeta(iz) > one ) valeta(iz) = one
+! DK DK DK densification sinusoidale ici en vertical
+
+ a00(iz) = 1-valeta(iz)
+ a01(iz) = valeta(iz)
+ enddo
+
+ do ix=0,nx
+ bot0(ix) = bottom(absx(ix))
+ top0(ix) = spl(absx(ix),xtopo,ztopo,coefs_topo,ntopo)
+ enddo
+
+! valeurs de x et y pour display domaine physique
+ do ix=0,nx
+ do iz=0,nz
+ x(ix,iz) = absx(ix)
+ z(ix,iz) = a00(iz)*bot0(ix) + a01(iz)*top0(ix)
+ enddo
+ enddo
+
+! calculer min et max de X et Z sur la grille
+ print *
+ print *, 'Valeurs min et max de X sur le maillage = ',minval(x),maxval(x)
+ print *, 'Valeurs min et max de Z sur le maillage = ',minval(z),maxval(z)
+ print *
+
+! *** generation de la base de donnees
+
+ print *
+ print *,' Creation de la base de donnees pour SPECFEM...'
+ print *
+
+ open(unit=15,file='../SPECFEM90/DataBase',status='unknown')
+
+ write(15,*) '#'
+ write(15,*) '# Base de Donnees pour Specfem - Premailleur Fortran 90'
+ write(15,*) '# ',title
+ write(15,*) '# Dimitri Komatitsch, (c) EPS - Harvard August 1998'
+ write(15,*) '#'
+
+ write(15,*) 'Titre simulation'
+ write(15,40) title
+
+ npgeo = (nx+1)*(nz+1)
+ write(15,*) 'ndofn ndime npgeo'
+ write(15,*) ndofn,ndime,npgeo
+
+ write(15,*) 'display ignuplot interpol'
+ write(15,*) display,ignuplot,interpol
+
+ write(15,*) 'itaff itfirstaff icolor inumber'
+ write(15,*) itaff,itfirstaff,0,0
+
+ write(15,*) 'ivectplot imeshvect imodelvect iboundvect cutvect isubsamp'
+ write(15,*) ivectplot,imeshvect,imodelvect,iboundvect,cutvect,isubsamp
+
+ write(15,*) 'scalex scalez sizemax angle rapport USletter'
+ write(15,*) scalex,scalez,sizemax,20.,0.40,usletter
+
+ write(15,*) 'orig_x orig_z isymbols'
+ write(15,*) orig_x,orig_z,' T'
+
+ write(15,*) 'valseuil freqmaxrep'
+ write(15,*) valseuil,freqmaxrep
+
+ write(15,*) 'sismos nrec nrec1 nrec2 isamp'
+ write(15,*) sismos,nrec,nrec1,nrec2,isamp
+
+ write(15,*) 'irepr anglerec anglerec2'
+ write(15,*) irepr,anglerec,anglerec2
+
+ write(15,*) 'topoplane absstacey compenergy'
+ write(15,*) topoplane,absstacey,compenergy
+
+ write(15,*) 'initialfield factorana factorxsu n1ana n2ana'
+ write(15,*) initialfield,factorana,factorxsu,n1ana,n2ana
+
+ write(15,*) 'isismostype ivecttype iaffinfo'
+ write(15,*) isismostype,ivecttype,iaffinfo
+
+ write(15,*) 'ireadmodel ioutputgrid iavs ivisual3'
+ write(15,*) ireadmodel,ioutputgrid,iavs,ivisual3
+
+ write(15,*) 'iexec iecho'
+ if(iexec) then
+ write(15,*) '1 1'
+ else
+ write(15,*) '0 1'
+ endif
+
+ write(15,*) 'ncycl dtinc niter'
+ write(15,*) nt,dt,niter
+
+ write(15,*) 'alpha beta gamma (alpha not used for the moment)'
+ write(15,*) alphanewm,betanewm,gammanewm
+
+ write(15,*) 'nltfl (number of force or pressure sources)'
+ write(15,*) nbsources
+
+ write(15,*) 'Collocated forces and/or pressure sources:'
+ do i=1,nbsources
+ write(15,*) itimetype(i),isource_type(i), &
+ xs(i)-xmin ,zs(i), &
+ f0(i),t0(i),factor(i),angle(i),0
+ enddo
+
+ write(15,*) 'Receivers positions:'
+ do irec=1,nrec
+ write(15,*) irec,xrec(irec)-xmin ,zrec(irec)
+ enddo
+
+ write(15,*) 'Coordinates of macroblocs mesh (coorg):'
+ do j=0,nz
+ do i=0,nx
+ write(15,*) num(i,j,nx),x(i,j)-xmin,z(i,j)
+ enddo
+ enddo
+
+ netyp = 2
+ nxgll = idegpoly + 1
+
+ write(15,*) 'netyp numat ngnod nxgll nygll nspec iptsdisp ielemabs ielemperio'
+ write(15,*) netyp,nbmodeles,ngnod,nxgll,nxgll,nspec,iptsdisp, &
+ nelemabs,nelemperio
+
+ write(15,*) 'Material sets (num 0 rho vp vs 0 0)'
+ do i=1,nbmodeles
+ write(15,*) i,0,rho(i),cp(i),cs(i),0,0
+ enddo
+
+
+ write(15,*) 'Arrays kmato and knods for each bloc:'
+
+ imatnum = 1
+ k=0
+
+! zone structuree dans le volume
+ do j=0,nz-12,6
+ do i=0,nx-6,6
+ k = k + 1
+ write(15,*) k,imatnum,num(i,j,nx),num(i+6,j,nx),num(i+6,j+6,nx), &
+ num(i,j+6,nx),num(i+3,j,nx),num(i+6,j+3,nx), &
+ num(i+3,j+6,nx),num(i,j+3,nx),num(i+3,j+3,nx)
+ enddo
+ enddo
+
+ if(k /= nspecvolume) stop 'nombre d''elements incoherent dans le volume'
+
+! zone non structuree dans la couche Wz
+ j=nz-6
+ do i=0,nx-12,12
+
+! element 1 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i,j,nx),num(i+6,j,nx),num(i+4,j+2,nx), &
+ num(i,j+2,nx),num(i+3,j,nx),num(i+5,j+1,nx), &
+ num(i+2,j+2,nx),num(i,j+1,nx),num(i+3,j+1,nx)
+
+! element 2 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i,j+2,nx),num(i+4,j+2,nx),num(i+2,j+4,nx), &
+ num(i,j+4,nx),num(i+2,j+2,nx),num(i+3,j+3,nx), &
+ num(i+1,j+4,nx),num(i,j+3,nx),num(i+1,j+3,nx)
+
+! element 3 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i,j+4,nx),num(i+2,j+4,nx),num(i+2,j+6,nx), &
+ num(i,j+6,nx),num(i+1,j+4,nx),num(i+2,j+5,nx), &
+ num(i+1,j+6,nx),num(i,j+5,nx),num(i+1,j+5,nx)
+
+! element 4 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+2,j+4,nx),num(i+4,j+2,nx),num(i+4,j+6,nx), &
+ num(i+2,j+6,nx),num(i+3,j+3,nx),num(i+4,j+4,nx), &
+ num(i+3,j+6,nx),num(i+2,j+5,nx),num(i+3,j+5,nx)
+
+! element 5 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+4,j+2,nx),num(i+6,j,nx),num(i+6,j+6,nx), &
+ num(i+4,j+6,nx),num(i+5,j+1,nx),num(i+6,j+3,nx), &
+ num(i+5,j+6,nx),num(i+4,j+4,nx),num(i+5,j+3,nx)
+
+! element 6 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+6,j,nx),num(i+8,j+2,nx),num(i+8,j+6,nx), &
+ num(i+6,j+6,nx),num(i+7,j+1,nx),num(i+8,j+4,nx), &
+ num(i+7,j+6,nx),num(i+6,j+3,nx),num(i+7,j+3,nx)
+
+! element 7 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+8,j+2,nx),num(i+10,j+4,nx),num(i+10,j+6,nx), &
+ num(i+8,j+6,nx),num(i+9,j+3,nx),num(i+10,j+5,nx), &
+ num(i+9,j+6,nx),num(i+8,j+4,nx),num(i+9,j+4,nx)
+
+! element 8 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+6,j,nx),num(i+12,j,nx),num(i+12,j+2,nx), &
+ num(i+8,j+2,nx),num(i+9,j,nx),num(i+12,j+1,nx), &
+ num(i+10,j+2,nx),num(i+7,j+1,nx),num(i+10,j+1,nx)
+
+! element 9 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+8,j+2,nx),num(i+12,j+2,nx),num(i+12,j+4,nx), &
+ num(i+10,j+4,nx),num(i+10,j+2,nx),num(i+12,j+3,nx), &
+ num(i+11,j+4,nx),num(i+9,j+3,nx),num(i+11,j+3,nx)
+
+! element 10 du raccord
+ k = k + 1
+ write(15,*) k,imatnum,num(i+10,j+4,nx),num(i+12,j+4,nx),num(i+12,j+6,nx),&
+ num(i+10,j+6,nx),num(i+11,j+4,nx),num(i+12,j+5,nx), &
+ num(i+11,j+6,nx),num(i+10,j+5,nx),num(i+11,j+5,nx)
+
+ enddo
+
+ if(k /= nspec) stop 'nombre d''elements incoherent dans la couche Wz'
+
+!
+!--- sauvegarde des bords absorbants
+!
+
+ print *
+ print *,'Au total il y a ',nelemabs,' elements absorbants'
+ print *
+ print *,'Bords absorbants actifs :'
+ print *
+ print *,'Haut = ',abshaut
+ print *,'Bas = ',absbas
+ print *,'Gauche = ',absgauche
+ print *,'Droite = ',absdroite
+ print *
+ print *,'Stacey = ',absstacey
+ print *
+
+! generer la liste des elements absorbants
+ if(nelemabs > 0) then
+ write(15,*) 'Liste des elements absorbants (haut bas gauche droite) :'
+
+! repasser aux vrais valeurs de nx et nz
+ nx = nx / 6
+ nz = nz / 6
+
+ inumabs = 0
+
+! bord absorbant du bas sans les coins
+ iz = 1
+ do ix = 2,nx-1
+ inumabs = inumabs + 1
+ inumelem = (iz-1)*nx + ix
+ icodehaut = 0
+ icodebas = iaretebas
+ icodegauche = 0
+ icodedroite = 0
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+! coin en bas a gauche
+ inumabs = inumabs + 1
+ inumelem = 1
+ icodehaut = 0
+ icodebas = iaretebas
+ icodegauche = iaretegauche
+ icodedroite = 0
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+
+! coin en bas a droite
+ inumabs = inumabs + 1
+ inumelem = nx
+ icodehaut = 0
+ icodebas = iaretebas
+ icodegauche = 0
+ icodedroite = iaretedroite
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+
+! partie structuree du bord de gauche
+ ix = 1
+ do iz = 2,nz-1
+ inumabs = inumabs + 1
+ inumelem = (iz-1)*nx + ix
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = iaretegauche
+ icodedroite = 0
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+! partie structuree du bord de droite
+ ix = nx
+ do iz = 2,nz-1
+ inumabs = inumabs + 1
+ inumelem = (iz-1)*nx + ix
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = 0
+ icodedroite = iaretedroite
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+! partie non structuree du bord de gauche (trois elements)
+ do iadd = 1,3
+ inumabs = inumabs + 1
+ inumelem = nx*(nz-1) + iadd
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = iaretegauche
+ icodedroite = 0
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+! partie non structuree du bord de droite (trois elements)
+ do iadd = 1,3
+ inumabs = inumabs + 1
+ inumelem = nspec - iadd + 1
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = 0
+ icodedroite = iaretedroite
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ enddo
+
+ if(inumabs /= nelemabs) stop 'nombre d''elements absorbants incoherent'
+
+ endif
+
+! fermer la base de donnees
+
+ close(15)
+
+ 40 format(a50)
+
+ end program maille_non_struct_3
+
+! *****************
+! routines maillage
+! *****************
+
+! --- numero global du noeud
+
+ integer function num(i,j,nx)
+ implicit none
+ integer i,j,nx
+
+ num = j*(nx+1) + i + 1
+ return
+ end function num
+
+! ------- definition des fonctions representant les interfaces -------
+
+!
+! --- bas du modele
+!
+
+ double precision function bottom(x)
+ implicit none
+ double precision x
+ bottom = 0.d0
+ return
+ end function bottom
+
+!
+! --- representation interfaces par un spline
+!
+
+!--- spline
+ double precision function spl(x,xtopo,ztopo,coefs,ntopo)
+ implicit none
+ integer ntopo
+ double precision x,xp
+ double precision xtopo(ntopo),ztopo(ntopo)
+ double precision coefs(ntopo)
+
+ spl = 0.
+ xp = x
+ if (xp < xtopo(1)) xp = xtopo(1)
+ if (xp > xtopo(ntopo)) xp = xtopo(ntopo)
+ call splint(xtopo,ztopo,coefs,ntopo,xp,spl)
+
+ return
+ end function spl
+
+! --- fonction de densification du maillage horizontal
+
+ double precision function dens(ix,psi,xmin,xmax,nx)
+ implicit none
+ integer ix,nx
+ double precision psi(0:nx)
+ double precision xmin,xmax
+
+ dens = xmin + dble(xmax-xmin)*psi(ix)
+
+ return
+ end function dens
+
+! --------------------------------------
+
+! routine de calcul des coefs du spline (Numerical Recipes)
+ subroutine spline(x,y,n,yp1,ypn,y2)
+ implicit none
+
+ integer n
+ double precision x(n),y(n),y2(n)
+ double precision, dimension(:), allocatable :: u
+ double precision yp1,ypn
+
+ integer i,k
+ double precision sig,p,qn,un
+
+ allocate(u(n))
+
+ y2(1)=-0.5
+ u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
+ do i=2,n-1
+ sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
+ p=sig*y2(i-1)+2.
+ y2(i)=(sig-1.)/p
+ u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) &
+ /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
+ enddo
+ qn=0.5
+ un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
+ y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
+ do k=n-1,1,-1
+ y2(k)=y2(k)*y2(k+1)+u(k)
+ enddo
+
+ deallocate(u)
+
+ return
+ end subroutine spline
+
+! --------------
+
+! routine d'evaluation du spline (Numerical Recipes)
+ SUBROUTINE SPLINT(XA,YA,Y2A,N,X,Y)
+ implicit none
+
+ integer n
+ double precision XA(N),YA(N),Y2A(N)
+ double precision x,y
+
+ integer k,klo,khi
+ double precision h,a,b
+
+ KLO=1
+ KHI=N
+ do while (KHI-KLO > 1)
+ K=(KHI+KLO)/2
+ IF(XA(K) > X)THEN
+ KHI=K
+ ELSE
+ KLO=K
+ ENDIF
+ enddo
+ H=XA(KHI)-XA(KLO)
+ IF (H == 0.d0) stop 'Bad input in spline evaluation'
+ A=(XA(KHI)-X)/H
+ B=(X-XA(KLO))/H
+
+ Y=A*YA(KLO)+B*YA(KHI)+((A**3-A)*Y2A(KLO)+ &
+ (B**3-B)*Y2A(KHI))*(H**2)/6.d0
+ RETURN
+ end subroutine SPLINT
+
Added: seismo/2D/SPECFEM2D/trunk/MAILLE90/maille_struct.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/MAILLE90/maille_struct.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/MAILLE90/maille_struct.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,920 @@
+!=====================================================================
+!
+! P r e m a i l l e u r F o r t r a n 9 0
+! -------------------------------------------
+!
+! Version 3.0
+! -----------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+!
+! (c) August 1998
+!
+!=====================================================================
+
+!
+! *** Version optimisee avec maillage structure pour Jacques Muller - Elf ***
+!
+
+ program maille_struct
+
+ implicit none
+
+! definir les tableaux pour allocation dynamique
+
+! coordinates of the grid points
+ double precision, allocatable :: x(:,:),z(:,:)
+
+! variables needed to compute the transformation
+ double precision, allocatable :: psi(:),eta(:),absx(:), &
+ a00(:),a01(:),valeta(:),bot0(:),top0(:)
+
+! stockage du modele de vitesse et densite
+ double precision, allocatable :: rho(:),cp(:),cs(:)
+
+! the topography data
+ double precision, allocatable :: xtopo(:),ztopo(:),coefs_topo(:)
+
+! arrays for the source
+ double precision, allocatable :: xs(:),zs(:),f0(:),t0(:),angle(:),factor(:)
+ integer, allocatable :: isource_type(:),itimetype(:)
+
+! arrays for the receivers
+ double precision, allocatable :: xrec(:),zrec(:)
+
+! nom du fichier GNUPLOT contenant la grille
+ character(len=50) file1
+
+ character(len=50) interffile,topofile,title
+ character(len=15) junk
+
+ integer imatnum,inumabs,inumelem,nelemperio,nxgll,netyp
+ integer icodehaut,icodebas,icodegauche,icodedroite
+ integer nelemabs,npgeo,nspec,ntopo
+ integer k,icol,ili,istepx,istepz,ncut,ix,iz,irec,i,j
+ integer ixdebzone,ixfinzone,izdebzone,izfinzone,imodnum
+ integer izone,imodele,nbzone,nbmodeles,iaffinfo
+ integer itaff,itfirstaff,iptsdisp,isubsamp,nrec,n1ana,n2ana
+ integer irepr,nrec1,nrec2,isamp,nbsources,isismostype,ivecttype
+ integer ngnod,nt,niter,idegpoly,nx,nz,nxread,nzread
+ integer inumelem2,ix2,iz2,inumperio
+ integer icodematread
+
+ double precision valseuil,freqmaxrep,ratio
+ double precision tang1,tangN,vpzone,vszone
+ double precision orig_x,orig_z,sizemax,cutvect,scalex,scalez
+ double precision factorxsu,factorana,xspacerec,zspacerec
+ double precision anglerec,anglerec2,xmin,xmax
+ double precision xfin,zfin,xfin2,zfin2,xdeb,zdeb,xdeb2,zdeb2
+ double precision alphanewm,betanewm,gammanewm,dt
+ double precision rhoread,cpread,csread,aniso3read,aniso4read
+
+ logical interpol,ignuplot,ireadmodel,iavs,ivisual3,ioutputgrid
+ logical abshaut,absbas,absgauche,absdroite,absstacey
+ logical periohaut,periogauche
+ logical sismos,isources_surf,ienreg_surf,ienreg_surf2,display
+ logical ivectplot,imeshvect,isymbols
+ logical topoplane,iexec,initialfield
+ logical imodelvect,iboundvect,usletter,compenergy
+
+ integer, external :: num
+ double precision, external :: bottom,spl,dens
+
+ double precision, parameter :: zero = 0.d0, one = 1.d0
+
+! sauvegarde de la grille format Gnuplot
+ logical, parameter :: save_gnuplot = .false.
+
+! --- code des numeros d'aretes pour les bords absorbants
+ integer, parameter :: iaretebas = 1
+ integer, parameter :: iaretedroite = 2
+ integer, parameter :: iaretehaut = 3
+ integer, parameter :: iaretegauche = 4
+
+! simulation a 2D
+ integer, parameter :: ndime = 2
+ integer, parameter :: ndofn = 2
+
+! DK DK DK ajout Elf : extraction de la topo du fichier SEP
+!! call system('rm -f topo_from_SEP.dat topo_SEP_maille90.dat ; xextract_topo')
+
+ print *
+ print *,' *** Version optimisee avec maillage structure ***'
+ print *
+
+! ***
+! *** read the parameter file
+! ***
+
+ print *,' Reading the parameter file ... '
+ print *
+
+ open(unit=10,file='Par',status='old')
+
+! formats
+
+ 1 format(a,f12.5)
+ 2 format(a,i8)
+ 3 format(a,a)
+ 4 format(a,l8)
+
+! read the header
+ do i=1,10
+ read(10,*)
+ enddo
+
+! read file names and path for output
+ read(10,3)junk,title
+ read(10,3)junk,topofile
+ read(10,3)junk,interffile
+
+ write(*,*) 'Titre de la simulation'
+ write(*,*) title
+ print *
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read grid parameters
+ read(10,1)junk,xmin
+ read(10,1)junk,xmax
+ read(10,2)junk,nx
+ read(10,2)junk,nz
+ read(10,2)junk,idegpoly
+ read(10,2)junk,ngnod
+ read(10,1)junk,ratio
+ read(10,4)junk,topoplane
+ read(10,4)junk,initialfield
+ read(10,4)junk,ireadmodel
+ read(10,4)junk,iexec
+
+! DK DK forcer pour Elf
+ ngnod = 9
+ topoplane = .false.
+ initialfield = .false.
+
+ nxread = nx
+ nzread = nz
+
+! multiplier par 2 pour elements 9 noeuds
+ nx = nx * 2
+ nz = nz * 2
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read absorbing boundaries parameters
+ read(10,4)junk,abshaut
+ read(10,4)junk,absbas
+ read(10,4)junk,absgauche
+ read(10,4)junk,absdroite
+ read(10,4)junk,absstacey
+ read(10,4)junk,periohaut
+ read(10,4)junk,periogauche
+
+! DK DK forcer pour Elf
+ abshaut = .false.
+ periohaut = .false.
+ periogauche = .false.
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read time step parameters
+ read(10,2)junk,nt
+ read(10,1)junk,dt
+ read(10,2)junk,niter
+ read(10,1)junk,alphanewm
+ read(10,1)junk,betanewm
+ read(10,1)junk,gammanewm
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read source parameters
+ read(10,2)junk,nbsources
+ read(10,4)junk,isources_surf
+ read(10,1)junk,valseuil
+ read(10,1)junk,freqmaxrep
+ print *,'Nb de sources a lire : ',nbsources
+
+ allocate(xs(nbsources))
+ allocate(zs(nbsources))
+ allocate(f0(nbsources))
+ allocate(t0(nbsources))
+ allocate(isource_type(nbsources))
+ allocate(itimetype(nbsources))
+ allocate(angle(nbsources))
+ allocate(factor(nbsources))
+
+ do i=1,nbsources
+ read(10,*)
+ read(10,1)junk,xs(i)
+ read(10,1)junk,zs(i)
+ read(10,1)junk,f0(i)
+ read(10,1)junk,t0(i)
+ read(10,2)junk,isource_type(i)
+ read(10,2)junk,itimetype(i)
+ read(10,1)junk,angle(i)
+ read(10,1)junk,factor(i)
+
+ print *
+ print *,' Source #',i
+ print *,'Position xs, zs = ',xs(i),zs(i)
+ print *,'Frequency, delay = ',f0(i),t0(i)
+ print *,'Source type (1=force 2=explo) : ', &
+ isource_type(i)
+ print *,'Angle of the source if force = ',angle(i)
+ print *,'Multiplying factor = ',factor(i)
+ enddo
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read receivers line parameters
+ read(10,4)junk,sismos
+ read(10,2)junk,isamp
+ read(10,2)junk,isismostype
+ read(10,2)junk,irepr
+ read(10,*)
+ read(10,2)junk,nrec1
+ read(10,1)junk,xdeb
+ read(10,1)junk,zdeb
+ read(10,1)junk,xfin
+ read(10,1)junk,zfin
+ read(10,4)junk,ienreg_surf
+ read(10,1)junk,anglerec
+ read(10,*)
+ read(10,2)junk,nrec2
+ read(10,1)junk,xdeb2
+ read(10,1)junk,zdeb2
+ read(10,1)junk,xfin2
+ read(10,1)junk,zfin2
+ read(10,4)junk,ienreg_surf2
+ read(10,1)junk,anglerec2
+ read(10,*)
+ read(10,1)junk,factorxsu
+ read(10,2)junk,n1ana
+ read(10,2)junk,n2ana
+ read(10,1)junk,factorana
+
+! determination et affichage position ligne de receivers
+ if(nrec2 < 0) stop 'negative value of nrec2 !'
+
+ if(nrec2 == 0) then
+ nrec = nrec1
+ else
+ nrec = nrec1 + nrec2
+ endif
+
+! DK DK forcer pour Elf
+ n1ana = 1
+ n2ana = nrec
+
+ allocate(xrec(nrec))
+ allocate(zrec(nrec))
+
+ if(nrec2 == 0) then
+ print *
+ print *,'There are ',nrec,' receivers on a single line'
+ xspacerec=(xfin-xdeb)/dble(nrec-1)
+ zspacerec=(zfin-zdeb)/dble(nrec-1)
+ do i=1,nrec
+ xrec(i) = xdeb + dble(i-1)*xspacerec
+ zrec(i) = zdeb + dble(i-1)*zspacerec
+ enddo
+ else
+ print *
+ print *,'There are ',nrec,' receivers on two lines'
+ print *,'First line contains ',nrec1,' receivers'
+ print *,'Second line contains ',nrec2,' receivers'
+ xspacerec=(xfin-xdeb)/dble(nrec1-1)
+ zspacerec=(zfin-zdeb)/dble(nrec1-1)
+ do i=1,nrec1
+ xrec(i) = xdeb + dble(i-1)*xspacerec
+ zrec(i) = zdeb + dble(i-1)*zspacerec
+ enddo
+ xspacerec=(xfin2-xdeb2)/dble(nrec2-1)
+ zspacerec=(zfin2-zdeb2)/dble(nrec2-1)
+ do i=1,nrec2
+ xrec(i+nrec1) = xdeb2 + dble(i-1)*xspacerec
+ zrec(i+nrec1) = zdeb2 + dble(i-1)*zspacerec
+ enddo
+ endif
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! read display parameters
+ read(10,4)junk,display
+ read(10,2)junk,itaff
+ read(10,2)junk,itfirstaff
+ read(10,2)junk,iaffinfo
+ read(10,4)junk,ivectplot
+ read(10,2)junk,ivecttype
+ read(10,1)junk,cutvect
+ read(10,4)junk,imeshvect
+ read(10,4)junk,imodelvect
+ read(10,4)junk,iboundvect
+ read(10,4)junk,interpol
+ read(10,2)junk,iptsdisp
+ read(10,2)junk,isubsamp
+ read(10,1)junk,scalex
+ read(10,1)junk,scalez
+ read(10,1)junk,sizemax
+ read(10,4)junk,usletter
+ read(10,1)junk,orig_x
+ read(10,1)junk,orig_z
+ read(10,4)junk,ignuplot
+ read(10,4)junk,iavs
+ read(10,4)junk,ivisual3
+ read(10,4)junk,ioutputgrid
+ read(10,4)junk,compenergy
+
+! DK DK forcer pour Elf
+ ignuplot = .false.
+ iavs = .false.
+ ivisual3 = .false.
+ compenergy = .false.
+
+! skip comment
+ read(10,*)
+ read(10,*)
+ read(10,*)
+
+! lecture des differents modeles de materiaux
+
+ read(10,2)junk,nbmodeles
+ if(nbmodeles <= 0) stop 'Negative number of models not allowed !!'
+
+ allocate(rho(nbmodeles))
+ allocate(cp(nbmodeles))
+ allocate(cs(nbmodeles))
+
+ rho(:) = 0.d0
+ cp(:) = 0.d0
+ cs(:) = 0.d0
+
+ do imodele=1,nbmodeles
+ read(10,*) i,icodematread,rhoread,cpread,csread,aniso3read,aniso4read
+ if(i<1 .or. i>nbmodeles) stop 'Wrong material set number'
+ rho(i) = rhoread
+ cp(i) = cpread
+ cs(i) = csread
+ if (rho(i) < 0.d0 .or. cp(i) < 0.d0 .or. cs(i) < 0.d0) &
+ stop 'Negative value of velocity or density'
+ enddo
+
+ print *
+ print *, 'Nb de modeles de roche = ',nbmodeles
+ print *
+ do i=1,nbmodeles
+ print *,'Modele #',i,' isotrope'
+ print *,'rho,cp,cs = ',rho(i),cp(i),cs(i)
+ enddo
+ print *
+
+ close(10)
+
+ print *
+ print *,' Parameter file successfully read... '
+
+! --------- fin lecture fichier parametres --------------
+
+ allocate(psi(0:nx))
+ allocate(eta(0:nz))
+ allocate(absx(0:nx))
+ allocate(a00(0:nz))
+ allocate(a01(0:nz))
+ allocate(valeta(0:nz))
+ allocate(bot0(0:nx))
+ allocate(top0(0:nx))
+
+! calcul des points regulierement espaces
+ do i=0,nx
+ psi(i) = i/dble(nx)
+ enddo
+ do j=0,nz
+ eta(j) = j/dble(nz)
+ enddo
+
+! quelques verifications de base a faire
+
+ if(ngnod /= 9) stop 'erreur ngnod different de 9 !!'
+
+ print *
+ print *,'Le maillage uniforme comporte ',nx/2,' x ',nz/2,' elements'
+ print *,'La grille equivalente uniforme a une taille de ', &
+ nx*idegpoly/2 + 1,' x ',nz*idegpoly/2 + 1,' points (', &
+ (nx*idegpoly/2 + 1)*(nz*idegpoly/2 + 1),' points)'
+
+ print *,'Chaque element comporte ',idegpoly+1,' points dans chaque direction'
+ print *,'Les elements de controle sont des elements ',ngnod,' noeuds'
+ print *
+
+!------------------------------------------------------
+
+ allocate(x(0:nx,0:nz))
+ allocate(z(0:nx,0:nz))
+
+ x(:,:)=0.d0
+ z(:,:)=0.d0
+
+! get topography data from external file
+ print *,'Reading topography from file ',topofile
+ open(unit=15,file=topofile,status='old')
+ read(15,*) ntopo
+ if (ntopo < 2) stop 'Not enough topography points (min 2)'
+ print *,'Reading ',ntopo,' points from topography file'
+ print *
+
+ allocate(xtopo(ntopo))
+ allocate(ztopo(ntopo))
+ allocate(coefs_topo(ntopo))
+
+ do i=1,ntopo
+ read(15,*) xtopo(i),ztopo(i)
+ enddo
+ close(15)
+
+! check the values read
+ print *
+ print *, 'Topography data points (x,z)'
+ print *, '----------------------------'
+ print *
+ print *, 'Topo 1 = (',xtopo(1),',',ztopo(1),')'
+ print *, 'Topo ntopo = (',xtopo(ntopo),',',ztopo(ntopo),')'
+
+!--- calculate the spline function for the topography
+!--- imposer les tangentes aux deux bords
+ tang1 = (ztopo(2)-ztopo(1))/(xtopo(2)-xtopo(1))
+ tangN = (ztopo(ntopo)-ztopo(ntopo-1))/(xtopo(ntopo)-xtopo(ntopo-1))
+ call spline(xtopo,ztopo,ntopo,tang1,tangN,coefs_topo)
+
+! *** afficher limites du modele lu
+ print *
+ print *, 'Limites absolues modele fichier topo :'
+ print *
+ print *, 'Xmin = ',minval(xtopo),' Xmax = ',maxval(xtopo)
+ print *, 'Zmin = ',minval(ztopo),' Zmax = ',maxval(ztopo)
+ print *
+
+! *** modifier sources pour position par rapport a la surface
+ print *
+ print *, 'Position (x,z) des ',nbsources,' sources'
+ print *
+ do i=1,nbsources
+
+! DK DK DK Elf : position source donnee en profondeur par rapport a la topo
+ zs(i) = spl(xs(i),xtopo,ztopo,coefs_topo,ntopo) - zs(i)
+
+ if(isources_surf) zs(i) = spl(xs(i),xtopo,ztopo,coefs_topo,ntopo)
+ print *, 'Source ',i,' = ',xs(i),zs(i)
+ enddo
+
+! *** modifier recepteurs pour enregistrement en surface
+ print *
+ print *, 'Position (x,z) des ',nrec,' receivers'
+ print *
+ do irec=1,nrec
+
+! DK DK DK Elf : distinguer les deux lignes de recepteurs
+ if(irec <= nrec1) then
+ if(ienreg_surf) zrec(irec) = spl(xrec(irec),xtopo,ztopo,coefs_topo,ntopo)
+ else
+ if(ienreg_surf2) zrec(irec) = spl(xrec(irec),xtopo,ztopo,coefs_topo,ntopo)
+ endif
+ print *, 'Receiver ',irec,' = ',xrec(irec),zrec(irec)
+
+ enddo
+
+!--- definition du maillage suivant X
+ do ix=0,nx
+ absx(ix) = dens(ix,psi,xmin,xmax,nx)
+ enddo
+
+! *** une seule zone
+
+ do iz=0,nz
+
+! DK DK DK densification sinusoidale ici en vertical
+ valeta(iz) = eta(iz) + ratio * sin(3.14159265 * eta(iz))
+ if(valeta(iz) < zero) valeta(iz) = zero
+ if(valeta(iz) > one ) valeta(iz) = one
+! DK DK DK densification sinusoidale ici en vertical
+
+ a00(iz) = 1-valeta(iz)
+ a01(iz) = valeta(iz)
+ enddo
+
+ do ix=0,nx
+ bot0(ix) = bottom(absx(ix))
+ top0(ix) = spl(absx(ix),xtopo,ztopo,coefs_topo,ntopo)
+ enddo
+
+! valeurs de x et y pour display domaine physique
+ do ix=0,nx
+ do iz=0,nz
+ x(ix,iz) = absx(ix)
+ z(ix,iz) = a00(iz)*bot0(ix) + a01(iz)*top0(ix)
+ enddo
+ enddo
+
+! calculer min et max de X et Z sur la grille
+ print *
+ print *, 'Valeurs min et max de X sur le maillage = ',minval(x),maxval(x)
+ print *, 'Valeurs min et max de Z sur le maillage = ',minval(z),maxval(z)
+ print *
+
+! ***
+! *** generer un fichier 'GNUPLOT' pour le controle de la grille ***
+! ***
+
+ if(save_gnuplot) then
+
+ print *
+ print *,' Ecriture de la grille format GNUPLOT...'
+
+ file1='gridfile.gnu'
+
+ open(unit=20,file=file1,status='unknown')
+
+! dessin de la topo de surface (splines)
+ do i=0,nx-1
+ write(20,15) sngl(absx(i)),sngl(top0(i))
+ write(20,15) sngl(absx(i+1)),sngl(top0(i+1))
+ write(20,10)
+ enddo
+
+! dessin des lignes horizontales de la grille
+ print *, 'Ecriture lignes horizontales'
+ istepx = 1
+ istepz = 2
+ do ili=0,nz,istepz
+ do icol=0,nx-istepx,istepx
+ write(20,15) sngl(x(icol,ili)),sngl(z(icol,ili))
+ write(20,15) sngl(x(icol+istepx,ili)),sngl(z(icol+istepx,ili))
+ write(20,10)
+ enddo
+ enddo
+
+! dessin des lignes verticales de la grille
+ print *, 'Ecriture lignes verticales'
+ istepx = 2
+ istepz = 1
+ do icol=0,nx,istepx
+ do ili=0,nz-istepz,istepz
+ write(20,15) sngl(x(icol,ili)),sngl(z(icol,ili))
+ write(20,15) sngl(x(icol,ili+istepz)),sngl(z(icol,ili+istepz))
+ write(20,10)
+ enddo
+ enddo
+
+ close(20)
+
+! cree le script de dessin pour gnuplot
+ open(unit=20,file='plotgrid.gnu',status='unknown')
+ write(20,*) 'set term postscript landscape monochrome solid "Helvetica" 22'
+ write(20,*) 'set output "grille.ps"'
+ write(20,*) 'plot "gridfile.gnu" title "Macroblocs mesh" w l'
+ close(20)
+
+ print *,' Fin ecriture de la grille format GNUPLOT'
+ print *
+
+ endif
+
+! *** generation de la base de donnees
+
+ print *
+ print *,' Creation de la base de donnees pour SPECFEM...'
+ print *
+
+ open(unit=15,file='../SPECFEM90/DataBase',status='unknown')
+
+ write(15,*) '#'
+ write(15,*) '# Base de Donnees pour Specfem - Premailleur Fortran 90'
+ write(15,*) '# ',title
+ write(15,*) '# Dimitri Komatitsch, (c) EPS - Harvard August 1998'
+ write(15,*) '#'
+
+ write(15,*) 'Titre simulation'
+ write(15,40) title
+
+ npgeo = (nx+1)*(nz+1)
+ nspec = nx*nz/4
+ write(15,*) 'ndofn ndime npgeo'
+ write(15,*) ndofn,ndime,npgeo
+
+ write(15,*) 'display ignuplot interpol'
+ write(15,*) display,ignuplot,interpol
+
+ write(15,*) 'itaff itfirstaff icolor inumber'
+ write(15,*) itaff,itfirstaff,0,0
+
+ write(15,*) 'ivectplot imeshvect imodelvect iboundvect cutvect isubsamp'
+ write(15,*) ivectplot,imeshvect,imodelvect,iboundvect,cutvect,isubsamp
+
+ write(15,*) 'scalex scalez sizemax angle rapport USletter'
+ write(15,*) scalex,scalez,sizemax,20.,0.40,usletter
+
+ write(15,*) 'orig_x orig_z isymbols'
+ write(15,*) orig_x,orig_z,' T'
+
+ write(15,*) 'valseuil freqmaxrep'
+ write(15,*) valseuil,freqmaxrep
+
+ write(15,*) 'sismos nrec nrec1 nrec2 isamp'
+ write(15,*) sismos,nrec,nrec1,nrec2,isamp
+
+ write(15,*) 'irepr anglerec anglerec2'
+ write(15,*) irepr,anglerec,anglerec2
+
+ write(15,*) 'topoplane absstacey compenergy'
+ write(15,*) topoplane,absstacey,compenergy
+
+ write(15,*) 'initialfield factorana factorxsu n1ana n2ana'
+ write(15,*) initialfield,factorana,factorxsu,n1ana,n2ana
+
+ write(15,*) 'isismostype ivecttype iaffinfo'
+ write(15,*) isismostype,ivecttype,iaffinfo
+
+ write(15,*) 'ireadmodel ioutputgrid iavs ivisual3'
+ write(15,*) ireadmodel,ioutputgrid,iavs,ivisual3
+
+ write(15,*) 'iexec iecho'
+ if(iexec) then
+ write(15,*) '1 1'
+ else
+ write(15,*) '0 1'
+ endif
+
+ write(15,*) 'ncycl dtinc niter'
+ write(15,*) nt,dt,niter
+
+ write(15,*) 'alpha beta gamma (alpha not used for the moment)'
+ write(15,*) alphanewm,betanewm,gammanewm
+
+ write(15,*) 'nltfl (number of force or pressure sources)'
+ write(15,*) nbsources
+
+ write(15,*) 'Collocated forces and/or pressure sources:'
+ do i=1,nbsources
+ write(15,*) itimetype(i),isource_type(i), &
+ xs(i)-xmin ,zs(i), &
+ f0(i),t0(i),factor(i),angle(i),0
+ enddo
+
+ write(15,*) 'Receivers positions:'
+ do irec=1,nrec
+ write(15,*) irec,xrec(irec)-xmin ,zrec(irec)
+ enddo
+
+ write(15,*) 'Coordinates of macroblocs mesh (coorg):'
+ do j=0,nz
+ do i=0,nx
+ write(15,*) num(i,j,nx),x(i,j)-xmin,z(i,j)
+ enddo
+ enddo
+
+!
+!--- introduction des bords absorbants
+!
+
+ nelemabs = 0
+ if(absbas) nelemabs = nelemabs + nx
+ if(abshaut) nelemabs = nelemabs + nx
+ if(absgauche) nelemabs = nelemabs + nz
+ if(absdroite) nelemabs = nelemabs + nz
+
+! on a deux fois trop d'elements pour elements 9 noeuds
+ nelemabs = nelemabs / 2
+
+! enlever aussi les coins qui ont ete comptes deux fois
+ if(absbas .and. absgauche) nelemabs = nelemabs - 1
+ if(absbas .and. absdroite) nelemabs = nelemabs - 1
+ if(abshaut .and. absgauche) nelemabs = nelemabs - 1
+ if(abshaut .and. absdroite) nelemabs = nelemabs - 1
+
+ nelemperio = 0
+
+ netyp = 2
+ nxgll = idegpoly + 1
+
+ write(15,*) 'netyp numat ngnod nxgll nygll nspec iptsdisp ielemabs ielemperio'
+ write(15,*) netyp,nbmodeles,ngnod,nxgll,nxgll,nspec,iptsdisp, &
+ nelemabs,nelemperio
+
+ write(15,*) 'Material sets (num 0 rho vp vs 0 0)'
+ do i=1,nbmodeles
+ write(15,*) i,0,rho(i),cp(i),cs(i),0,0
+ enddo
+
+
+ write(15,*) 'Arrays kmato and knods for each bloc:'
+
+ k=0
+ do j=0,nz-2,2
+ do i=0,nx-2,2
+
+ k = k + 1
+ imatnum = 1
+ write(15,*) k,imatnum,num(i,j,nx),num(i+2,j,nx),num(i+2,j+2,nx), &
+ num(i,j+2,nx),num(i+1,j,nx),num(i+2,j+1,nx), &
+ num(i+1,j+2,nx),num(i,j+1,nx),num(i+1,j+1,nx)
+
+ enddo
+ enddo
+
+!
+!--- sauvegarde des bords absorbants
+!
+
+ print *
+ print *,'Au total il y a ',nelemabs,' elements absorbants'
+ print *
+ print *,'Bords absorbants actifs :'
+ print *
+ print *,'Haut = ',abshaut
+ print *,'Bas = ',absbas
+ print *,'Gauche = ',absgauche
+ print *,'Droite = ',absdroite
+ print *
+ print *,'Stacey = ',absstacey
+ print *
+
+! generer la liste des elements absorbants
+ if(nelemabs > 0) then
+ write(15,*) 'Liste des elements absorbants (haut bas gauche droite) :'
+ inumabs = 0
+ do iz=1,nzread
+ do ix=1,nxread
+ icodehaut = 0
+ icodebas = 0
+ icodegauche = 0
+ icodedroite = 0
+ inumelem = (iz-1)*nxread + ix
+ if(abshaut .and. iz==nzread) icodehaut = iaretehaut
+ if(absbas .and. iz== 1) icodebas = iaretebas
+ if(absgauche .and. ix== 1) icodegauche = iaretegauche
+ if(absdroite .and. ix==nxread) icodedroite = iaretedroite
+ if(icodehaut>0 .or. icodebas>0 .or. icodegauche>0 .or. icodedroite>0) then
+ inumabs = inumabs + 1
+ write(15,*) inumabs,inumelem,icodehaut,icodebas,icodegauche,icodedroite
+ endif
+ enddo
+ enddo
+ endif
+
+ close(15)
+
+ 10 format('')
+ 15 format(e10.5,1x,e10.5)
+ 40 format(a50)
+
+ end program maille_struct
+
+! *****************
+! routines maillage
+! *****************
+
+! --- numero global du noeud
+
+ integer function num(i,j,nx)
+ implicit none
+ integer i,j,nx
+
+ num = j*(nx+1) + i + 1
+ return
+ end function num
+
+! ------- definition des fonctions representant les interfaces -------
+
+!
+! --- bas du modele
+!
+
+ double precision function bottom(x)
+ implicit none
+ double precision x
+ bottom = 0.d0
+ return
+ end function bottom
+
+!
+! --- representation interfaces par un spline
+!
+
+!--- spline
+ double precision function spl(x,xtopo,ztopo,coefs,ntopo)
+ implicit none
+ integer ntopo
+ double precision x,xp
+ double precision xtopo(ntopo),ztopo(ntopo)
+ double precision coefs(ntopo)
+
+ spl = 0.
+ xp = x
+ if (xp < xtopo(1)) xp = xtopo(1)
+ if (xp > xtopo(ntopo)) xp = xtopo(ntopo)
+ call splint(xtopo,ztopo,coefs,ntopo,xp,spl)
+
+ return
+ end function spl
+
+! --- fonction de densification du maillage horizontal
+
+ double precision function dens(ix,psi,xmin,xmax,nx)
+ implicit none
+ integer ix,nx
+ double precision psi(0:nx)
+ double precision xmin,xmax
+
+ dens = xmin + dble(xmax-xmin)*psi(ix)
+
+ return
+ end function dens
+
+! --------------------------------------
+
+! routine de calcul des coefs du spline (Numerical Recipes)
+ subroutine spline(x,y,n,yp1,ypn,y2)
+ implicit none
+
+ integer n
+ double precision x(n),y(n),y2(n)
+ double precision, dimension(:), allocatable :: u
+ double precision yp1,ypn
+
+ integer i,k
+ double precision sig,p,qn,un
+
+ allocate(u(n))
+
+ y2(1)=-0.5
+ u(1)=(3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
+ do i=2,n-1
+ sig=(x(i)-x(i-1))/(x(i+1)-x(i-1))
+ p=sig*y2(i-1)+2.
+ y2(i)=(sig-1.)/p
+ u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) &
+ /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
+ enddo
+ qn=0.5
+ un=(3./(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
+ y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
+ do k=n-1,1,-1
+ y2(k)=y2(k)*y2(k+1)+u(k)
+ enddo
+
+ deallocate(u)
+
+ return
+ end subroutine spline
+
+! --------------
+
+! routine d'evaluation du spline (Numerical Recipes)
+ SUBROUTINE SPLINT(XA,YA,Y2A,N,X,Y)
+ implicit none
+
+ integer n
+ double precision XA(N),YA(N),Y2A(N)
+ double precision x,y
+
+ integer k,klo,khi
+ double precision h,a,b
+
+ KLO=1
+ KHI=N
+ do while (KHI-KLO > 1)
+ K=(KHI+KLO)/2
+ IF(XA(K) > X)THEN
+ KHI=K
+ ELSE
+ KLO=K
+ ENDIF
+ enddo
+ H=XA(KHI)-XA(KLO)
+ IF (H == 0.d0) stop 'Bad input in spline evaluation'
+ A=(XA(KHI)-X)/H
+ B=(X-XA(KLO))/H
+
+ Y=A*YA(KLO)+B*YA(KHI)+((A**3-A)*Y2A(KLO)+ &
+ (B**3-B)*Y2A(KHI))*(H**2)/6.d0
+ RETURN
+ end subroutine SPLINT
+
Added: seismo/2D/SPECFEM2D/trunk/MAILLE90/profilx.dat
===================================================================
--- seismo/2D/SPECFEM2D/trunk/MAILLE90/profilx.dat 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/MAILLE90/profilx.dat 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,215 @@
+-4.030060
+-4.031510
+-4.027550
+-4.022690
+-4.017840
+-4.011910
+-3.999230
+-3.972270
+-3.940420
+-3.909460
+-3.885800
+-3.868120
+-3.853440
+-3.840630
+-3.830040
+-3.818850
+-3.804520
+-3.790030
+-3.776320
+-3.765340
+-3.755920
+-3.746830
+-3.735490
+-3.721820
+-3.703930
+-3.679520
+-3.650700
+-3.620200
+-3.591410
+-3.568040
+-3.547570
+-3.528300
+-3.507120
+-3.485880
+-3.468120
+-3.446460
+-3.420720
+-3.390030
+-3.353750
+-3.313270
+-3.264390
+-3.214030
+-3.179940
+-3.155080
+-3.132110
+-3.106450
+-3.075090
+-3.038830
+-2.991240
+-2.916530
+-2.815720
+-2.748110
+-2.712470
+-2.670830
+-2.618150
+-2.555080
+-2.484160
+-2.405320
+-2.321900
+-2.229520
+-2.133560
+-2.070170
+-2.027820
+-1.974430
+-1.907660
+-1.851900
+-1.790190
+-1.724810
+-1.662320
+-1.613210
+-1.567500
+-1.532530
+-1.499660
+-1.420860
+-1.326870
+-1.238010
+-1.149630
+-1.055670
+-0.951941
+-0.830088
+-0.695442
+-0.535123
+-0.303787
+-0.066964
+0.137585
+0.292947
+0.427345
+0.504895
+0.548948
+0.611893
+0.669241
+0.731076
+0.784069
+0.862715
+0.908088
+0.989800
+1.074750
+1.125830
+1.155250
+1.142880
+1.068660
+0.966157
+1.106490
+1.229600
+1.452710
+1.620460
+1.795150
+1.775980
+1.694660
+1.678880
+1.661540
+1.600500
+1.536210
+1.454460
+1.203100
+0.999440
+0.972028
+0.935924
+0.995477
+1.063760
+1.098300
+1.056350
+0.986176
+0.855505
+0.689433
+0.529934
+0.397784
+0.317342
+0.222705
+0.117320
+0.028807
+-0.040407
+-0.118587
+-0.326905
+-0.574415
+-0.741248
+-0.887590
+-1.010380
+-1.087830
+-1.108840
+-1.160430
+-1.209690
+-1.264010
+-1.319100
+-1.348980
+-1.404960
+-1.485740
+-1.575370
+-1.662450
+-1.738790
+-1.798140
+-1.850290
+-1.905520
+-1.951300
+-1.995390
+-2.063230
+-2.151310
+-2.217030
+-2.278450
+-2.333810
+-2.384270
+-2.421330
+-2.443130
+-2.465170
+-2.567050
+-2.690890
+-2.770720
+-2.838250
+-2.898530
+-2.956700
+-3.026270
+-3.102020
+-3.173380
+-3.233160
+-3.285530
+-3.338610
+-3.390250
+-3.433800
+-3.482320
+-3.537380
+-3.588740
+-3.628460
+-3.662240
+-3.688980
+-3.709740
+-3.732810
+-3.750350
+-3.772050
+-3.797530
+-3.827180
+-3.859440
+-3.890500
+-3.918430
+-3.944920
+-3.968160
+-3.987850
+-4.002890
+-4.012180
+-4.014820
+-4.016240
+-4.021080
+-4.025060
+-4.027960
+-4.030390
+-4.031410
+-4.032690
+-4.034570
+-4.035590
+-4.036420
+-4.037270
+-4.037550
+-4.016490
+-4.008760
+-4.007300
+-4.006200
Added: seismo/2D/SPECFEM2D/trunk/MAILLE90/profily.dat
===================================================================
--- seismo/2D/SPECFEM2D/trunk/MAILLE90/profily.dat 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/MAILLE90/profily.dat 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,209 @@
+-4.042630
+-4.033770
+-4.024570
+-4.031010
+-4.027090
+-4.011370
+-3.989330
+-3.963060
+-3.929730
+-3.893400
+-3.854910
+-3.807280
+-3.764700
+-3.718700
+-3.667760
+-3.619570
+-3.579390
+-3.529760
+-3.477630
+-3.427720
+-3.383820
+-3.346060
+-3.312440
+-3.281950
+-3.252910
+-3.222660
+-3.189850
+-3.153580
+-3.113840
+-3.073560
+-3.036520
+-2.994700
+-2.946600
+-2.906230
+-2.856750
+-2.801230
+-2.751650
+-2.709890
+-2.593630
+-2.501410
+-2.339970
+-2.219030
+-2.157610
+-2.126910
+-2.081700
+-2.033360
+-1.993200
+-1.959890
+-1.920950
+-1.885440
+-1.849060
+-1.795820
+-1.723950
+-1.624180
+-1.500000
+-1.379030
+-1.266730
+-1.161710
+-1.064370
+-0.991573
+-0.971158
+-0.935858
+-0.900854
+-0.874644
+-0.842509
+-0.808727
+-0.789044
+-0.797708
+-0.768248
+-0.756078
+-0.738104
+-0.756372
+-0.775592
+-0.795957
+-0.787438
+-0.705082
+-0.595518
+-0.438898
+-0.292028
+-0.145967
+-0.062730
+0.042711
+0.270900
+0.520289
+0.726283
+0.910875
+1.135880
+1.376630
+1.592740
+1.757490
+1.894770
+2.043840
+2.106480
+2.091720
+1.818020
+1.200320
+0.943632
+0.864765
+0.849034
+0.953888
+1.012090
+1.158530
+1.759700
+1.777570
+1.252260
+1.043510
+1.229600
+1.496690
+1.515210
+1.522500
+1.522040
+1.505200
+1.497920
+1.479140
+1.447090
+1.430400
+1.462890
+1.560170
+1.666450
+1.695220
+1.675090
+1.617180
+1.532760
+1.426300
+1.375350
+1.198940
+0.876019
+0.921095
+0.998579
+0.847144
+0.712094
+0.580680
+0.459470
+0.335168
+0.179500
+0.065837
+-0.008686
+-0.125625
+-0.407411
+-0.779719
+-1.215620
+-1.613050
+-1.707880
+-1.708050
+-1.734230
+-1.753980
+-1.773940
+-1.796890
+-1.822940
+-1.854070
+-1.880990
+-1.901660
+-1.965350
+-1.995410
+-1.941710
+-1.898150
+-1.983790
+-2.167880
+-2.287980
+-2.395880
+-2.460820
+-2.487850
+-2.504990
+-2.499650
+-2.511300
+-2.511300
+-2.551220
+-2.608210
+-2.644140
+-2.692670
+-2.720570
+-2.735400
+-2.747100
+-2.788430
+-2.834740
+-2.886570
+-2.951890
+-3.016690
+-3.075140
+-3.116640
+-3.156450
+-3.207550
+-3.258550
+-3.308610
+-3.356020
+-3.398640
+-3.437490
+-3.477580
+-3.513470
+-3.544880
+-3.568640
+-3.600160
+-3.632250
+-3.665310
+-3.697350
+-3.729730
+-3.763660
+-3.795090
+-3.823330
+-3.854270
+-3.883290
+-3.908390
+-3.931510
+-3.955920
+-3.977590
+-3.992900
+-4.004930
+-4.014750
+-4.025040
Added: seismo/2D/SPECFEM2D/trunk/MAILLE90/topoarticle.dat
===================================================================
--- seismo/2D/SPECFEM2D/trunk/MAILLE90/topoarticle.dat 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/MAILLE90/topoarticle.dat 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,210 @@
+ 209
+ 0. 1741.09
+ 12.0192 1743.55
+ 24.0385 1746.09
+ 36.0577 1748.72
+ 48.0769 1751.41
+ 60.0962 1754.16
+ 72.1154 1756.95
+ 84.1346 1759.79
+ 96.1538 1762.66
+ 108.173 1765.56
+ 120.192 1768.47
+ 132.212 1771.38
+ 144.231 1774.30
+ 156.250 1777.21
+ 168.269 1780.11
+ 180.288 1782.99
+ 192.308 1785.85
+ 204.327 1788.68
+ 216.346 1791.46
+ 228.365 1794.20
+ 240.385 1796.89
+ 252.404 1799.52
+ 264.423 1802.09
+ 276.442 1804.60
+ 288.462 1807.02
+ 300.481 1809.37
+ 312.500 1811.63
+ 324.519 1813.80
+ 336.538 1815.90
+ 348.558 1817.91
+ 360.577 1819.86
+ 372.596 1821.73
+ 384.615 1823.53
+ 396.635 1825.27
+ 408.654 1826.95
+ 420.673 1828.58
+ 432.692 1830.19
+ 444.712 1831.78
+ 456.731 1833.38
+ 468.750 1835.00
+ 480.769 1836.67
+ 492.788 1838.40
+ 504.808 1840.21
+ 516.827 1842.10
+ 528.846 1844.02
+ 540.865 1845.95
+ 552.885 1847.86
+ 564.904 1849.70
+ 576.923 1851.44
+ 588.942 1853.05
+ 600.962 1854.49
+ 612.981 1855.74
+ 625.000 1856.81
+ 637.019 1857.72
+ 649.038 1858.49
+ 661.058 1859.13
+ 673.077 1859.68
+ 685.096 1860.15
+ 697.115 1860.56
+ 709.135 1860.92
+ 721.154 1861.22
+ 733.173 1861.42
+ 745.192 1861.49
+ 757.212 1861.39
+ 769.231 1861.09
+ 781.250 1860.56
+ 793.269 1859.75
+ 805.288 1858.64
+ 817.308 1857.17
+ 829.327 1855.28
+ 841.346 1852.89
+ 853.365 1849.93
+ 865.385 1846.34
+ 877.404 1842.04
+ 889.423 1836.97
+ 901.442 1831.04
+ 913.462 1824.28
+ 925.481 1816.85
+ 937.500 1809.00
+ 949.519 1800.95
+ 961.538 1792.92
+ 973.558 1785.14
+ 985.577 1777.84
+ 997.596 1771.25
+ 1009.62 1765.55
+ 1021.63 1760.76
+ 1033.65 1756.75
+ 1045.67 1753.44
+ 1057.69 1750.72
+ 1069.71 1748.49
+ 1081.73 1746.65
+ 1093.75 1745.09
+ 1105.77 1743.72
+ 1117.79 1742.49
+ 1129.81 1741.37
+ 1141.83 1740.35
+ 1153.85 1739.42
+ 1165.87 1738.57
+ 1177.88 1737.79
+ 1189.90 1737.06
+ 1201.92 1736.37
+ 1213.94 1735.72
+ 1225.96 1735.14
+ 1237.98 1734.66
+ 1250.00 1734.30
+ 1262.02 1734.11
+ 1274.04 1734.11
+ 1286.06 1734.33
+ 1298.08 1734.80
+ 1310.10 1735.55
+ 1322.12 1736.55
+ 1334.13 1737.74
+ 1346.15 1739.08
+ 1358.17 1740.50
+ 1370.19 1741.96
+ 1382.21 1743.40
+ 1394.23 1744.77
+ 1406.25 1746.02
+ 1418.27 1747.13
+ 1430.29 1748.10
+ 1442.31 1748.94
+ 1454.33 1749.64
+ 1466.35 1750.22
+ 1478.37 1750.68
+ 1490.38 1751.02
+ 1502.40 1751.25
+ 1514.42 1751.41
+ 1526.44 1751.68
+ 1538.46 1752.23
+ 1550.48 1753.22
+ 1562.50 1754.84
+ 1574.52 1757.27
+ 1586.54 1760.67
+ 1598.56 1765.22
+ 1610.58 1771.04
+ 1622.60 1777.93
+ 1634.62 1785.56
+ 1646.63 1793.60
+ 1658.65 1801.74
+ 1670.67 1809.64
+ 1682.69 1817.00
+ 1694.71 1823.48
+ 1706.73 1828.77
+ 1718.75 1832.75
+ 1730.77 1835.44
+ 1742.79 1836.88
+ 1754.81 1837.11
+ 1766.83 1836.17
+ 1778.85 1834.08
+ 1790.87 1830.90
+ 1802.88 1826.64
+ 1814.90 1821.41
+ 1826.92 1815.42
+ 1838.94 1808.87
+ 1850.96 1802.01
+ 1862.98 1795.03
+ 1875.00 1788.17
+ 1887.02 1781.64
+ 1899.04 1775.67
+ 1911.06 1770.45
+ 1923.08 1765.99
+ 1935.10 1762.29
+ 1947.12 1759.31
+ 1959.13 1757.05
+ 1971.15 1755.47
+ 1983.17 1754.55
+ 1995.19 1754.28
+ 2007.21 1754.63
+ 2019.23 1755.57
+ 2031.25 1757.03
+ 2043.27 1758.96
+ 2055.29 1761.33
+ 2067.31 1764.06
+ 2079.33 1767.11
+ 2091.35 1770.43
+ 2103.37 1773.97
+ 2115.38 1777.65
+ 2127.40 1781.39
+ 2139.42 1785.08
+ 2151.44 1788.64
+ 2163.46 1791.97
+ 2175.48 1794.97
+ 2187.50 1797.54
+ 2199.52 1799.60
+ 2211.54 1801.07
+ 2223.56 1802.01
+ 2235.58 1802.51
+ 2247.60 1802.66
+ 2259.62 1802.56
+ 2271.63 1802.29
+ 2283.65 1801.94
+ 2295.67 1801.62
+ 2307.69 1801.39
+ 2319.71 1801.30
+ 2331.73 1801.30
+ 2343.75 1801.39
+ 2355.77 1801.54
+ 2367.79 1801.73
+ 2379.81 1801.93
+ 2391.83 1802.13
+ 2403.85 1802.30
+ 2415.87 1802.43
+ 2427.88 1802.51
+ 2439.90 1802.55
+ 2451.92 1802.56
+ 2463.94 1802.52
+ 2475.96 1802.45
+ 2487.98 1802.35
+ 2500.00 1802.20
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/Makefile
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/Makefile 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/Makefile 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,198 @@
+#
+# Makefile simple pour f90
+#
+# Dimitri Komatitsch, Harvard University, May 1998
+#
+SHELL=/bin/sh
+
+B = .
+O = obj
+SRC = .
+TRNDIR = ./bak
+
+# Portland
+#F90 = pgf90
+#FLAGS=-c -fast -Mnobounds -Minline -Mneginfo -Mdclchk
+
+# Intel Linux
+F90 = ifort
+FLAGS=-c -O3 -e95 -implicitnone
+
+LINK = $(F90)
+EXEC = xspecfem
+OBJS = $O/modules.o $O/calc_energie.o $O/calcdivcurl.o $O/calcforce.o $O/checkgrid.o\
+ $O/checksource.o $O/contol.o $O/datim.o\
+ $O/defarrays.o $O/dirac.o $O/dircty.o $O/endw1.o $O/endw2.o $O/gammaf.o\
+ $O/getelspec.o $O/getltf.o $O/getrecepts.o $O/getspec.o $O/gmat01.o $O/hdgll.o $O/hgll.o\
+ $O/intseq.o $O/jacg.o $O/jacobf.o $O/modifperio.o $O/plotavs.o $O/plotgll.o\
+ $O/plotpost.o $O/plotvect.o $O/pndleg.o $O/pnleg.o\
+ $O/pnormj.o $O/positrec.o $O/positsource.o $O/q49spec.o $O/qinpspec.o $O/qmasspec.o\
+ $O/qsumspec.o $O/ricker.o $O/setcor.o $O/specfem.o $O/storearray.o \
+ $O/writeseis.o $O/zwgjd.o $O/zwgljd.o $O/createnum_fast.o $O/createnum_slow.o\
+ $O/q49shape.o
+DIRS = .
+
+.f90.o:
+ $(F90) $(FLAGS) $*.f90
+
+default : $(OBJS) mxspecfem
+
+TIMESTAMP: $(SRC)/*.f90 $(SRC)/Makefile
+ cp $? ${TRNDIR}
+ touch TIMESTAMP
+
+mxspecfem : $(DIRS)
+ $(LINK) $(OBJS) -o $(EXEC)
+
+all : clean $(OBJS) mxspecfem
+
+clean :
+ /bin/rm -f $(EXEC) $(EXEC).trace $O/*.o *.o *.mod core *.gnu *.ps Ux* Uz* sources;
+
+$O/calc_energie.o: $(SRC)/calc_energie.f90
+ ${F90} $(FLAGS) -c -o $O/calc_energie.o $(SRC)/calc_energie.f90
+
+$O/calcdivcurl.o: $(SRC)/calcdivcurl.f90
+ ${F90} $(FLAGS) -c -o $O/calcdivcurl.o $(SRC)/calcdivcurl.f90
+
+$O/calcforce.o: $(SRC)/calcforce.f90
+ ${F90} $(FLAGS) -c -o $O/calcforce.o $(SRC)/calcforce.f90
+
+$O/checkgrid.o: $(SRC)/checkgrid.f90
+ ${F90} $(FLAGS) -c -o $O/checkgrid.o $(SRC)/checkgrid.f90
+
+$O/checksource.o: $(SRC)/checksource.f90
+ ${F90} $(FLAGS) -c -o $O/checksource.o $(SRC)/checksource.f90
+
+$O/contol.o: $(SRC)/contol.f90
+ ${F90} $(FLAGS) -c -o $O/contol.o $(SRC)/contol.f90
+
+$O/createnum_fast.o: $(SRC)/createnum_fast.f90
+ ${F90} $(FLAGS) -c -o $O/createnum_fast.o $(SRC)/createnum_fast.f90
+
+$O/createnum_slow.o: $(SRC)/createnum_slow.f90
+ ${F90} $(FLAGS) -c -o $O/createnum_slow.o $(SRC)/createnum_slow.f90
+
+$O/datim.o: $(SRC)/datim.f90
+ ${F90} $(FLAGS) -c -o $O/datim.o $(SRC)/datim.f90
+
+$O/defarrays.o: $(SRC)/defarrays.f90
+ ${F90} $(FLAGS) -c -o $O/defarrays.o $(SRC)/defarrays.f90
+
+$O/dirac.o: $(SRC)/dirac.f90
+ ${F90} $(FLAGS) -c -o $O/dirac.o $(SRC)/dirac.f90
+
+$O/dircty.o: $(SRC)/dircty.f90
+ ${F90} $(FLAGS) -c -o $O/dircty.o $(SRC)/dircty.f90
+
+$O/endw1.o: $(SRC)/endw1.f90
+ ${F90} $(FLAGS) -c -o $O/endw1.o $(SRC)/endw1.f90
+
+$O/endw2.o: $(SRC)/endw2.f90
+ ${F90} $(FLAGS) -c -o $O/endw2.o $(SRC)/endw2.f90
+
+$O/ezfftf.o: $(SRC)/ezfftf.f90
+ ${F90} $(FLAGS) -c -o $O/ezfftf.o $(SRC)/ezfftf.f90
+
+$O/gammaf.o: $(SRC)/gammaf.f90
+ ${F90} $(FLAGS) -c -o $O/gammaf.o $(SRC)/gammaf.f90
+
+$O/getelspec.o: $(SRC)/getelspec.f90
+ ${F90} $(FLAGS) -c -o $O/getelspec.o $(SRC)/getelspec.f90
+
+$O/getltf.o: $(SRC)/getltf.f90
+ ${F90} $(FLAGS) -c -o $O/getltf.o $(SRC)/getltf.f90
+
+$O/getrecepts.o: $(SRC)/getrecepts.f90
+ ${F90} $(FLAGS) -c -o $O/getrecepts.o $(SRC)/getrecepts.f90
+
+$O/getspec.o: $(SRC)/getspec.f90
+ ${F90} $(FLAGS) -c -o $O/getspec.o $(SRC)/getspec.f90
+
+$O/gmat01.o: $(SRC)/gmat01.f90
+ ${F90} $(FLAGS) -c -o $O/gmat01.o $(SRC)/gmat01.f90
+
+$O/hdgll.o: $(SRC)/hdgll.f90
+ ${F90} $(FLAGS) -c -o $O/hdgll.o $(SRC)/hdgll.f90
+
+$O/hgll.o: $(SRC)/hgll.f90
+ ${F90} $(FLAGS) -c -o $O/hgll.o $(SRC)/hgll.f90
+
+$O/intseq.o: $(SRC)/intseq.f90
+ ${F90} $(FLAGS) -c -o $O/intseq.o $(SRC)/intseq.f90
+
+$O/jacg.o: $(SRC)/jacg.f90
+ ${F90} $(FLAGS) -c -o $O/jacg.o $(SRC)/jacg.f90
+
+$O/jacobf.o: $(SRC)/jacobf.f90
+ ${F90} $(FLAGS) -c -o $O/jacobf.o $(SRC)/jacobf.f90
+
+$O/modifperio.o: $(SRC)/modifperio.f90
+ ${F90} $(FLAGS) -c -o $O/modifperio.o $(SRC)/modifperio.f90
+
+$O/modules.o: $(SRC)/modules.f90
+ ${F90} $(FLAGS) -c -o $O/modules.o $(SRC)/modules.f90
+
+$O/plotavs.o: $(SRC)/plotavs.f90
+ ${F90} $(FLAGS) -c -o $O/plotavs.o $(SRC)/plotavs.f90
+
+$O/plotgll.o: $(SRC)/plotgll.f90
+ ${F90} $(FLAGS) -c -o $O/plotgll.o $(SRC)/plotgll.f90
+
+$O/plotpost.o: $(SRC)/plotpost.f90
+ ${F90} $(FLAGS) -c -o $O/plotpost.o $(SRC)/plotpost.f90
+
+$O/plotvect.o: $(SRC)/plotvect.f90
+ ${F90} $(FLAGS) -c -o $O/plotvect.o $(SRC)/plotvect.f90
+
+$O/pndleg.o: $(SRC)/pndleg.f90
+ ${F90} $(FLAGS) -c -o $O/pndleg.o $(SRC)/pndleg.f90
+
+$O/pnleg.o: $(SRC)/pnleg.f90
+ ${F90} $(FLAGS) -c -o $O/pnleg.o $(SRC)/pnleg.f90
+
+$O/pnormj.o: $(SRC)/pnormj.f90
+ ${F90} $(FLAGS) -c -o $O/pnormj.o $(SRC)/pnormj.f90
+
+$O/positrec.o: $(SRC)/positrec.f90
+ ${F90} $(FLAGS) -c -o $O/positrec.o $(SRC)/positrec.f90
+
+$O/positsource.o: $(SRC)/positsource.f90
+ ${F90} $(FLAGS) -c -o $O/positsource.o $(SRC)/positsource.f90
+
+$O/q49shape.o: $(SRC)/q49shape.f90
+ ${F90} $(FLAGS) -c -o $O/q49shape.o $(SRC)/q49shape.f90
+
+$O/q49spec.o: $(SRC)/q49spec.f90
+ ${F90} $(FLAGS) -c -o $O/q49spec.o $(SRC)/q49spec.f90
+
+$O/qinpspec.o: $(SRC)/qinpspec.f90
+ ${F90} $(FLAGS) -c -o $O/qinpspec.o $(SRC)/qinpspec.f90
+
+$O/qmasspec.o: $(SRC)/qmasspec.f90
+ ${F90} $(FLAGS) -c -o $O/qmasspec.o $(SRC)/qmasspec.f90
+
+$O/qsumspec.o: $(SRC)/qsumspec.f90
+ ${F90} $(FLAGS) -c -o $O/qsumspec.o $(SRC)/qsumspec.f90
+
+$O/ricker.o: $(SRC)/ricker.f90
+ ${F90} $(FLAGS) -c -o $O/ricker.o $(SRC)/ricker.f90
+
+$O/setcor.o: $(SRC)/setcor.f90
+ ${F90} $(FLAGS) -c -o $O/setcor.o $(SRC)/setcor.f90
+
+$O/specfem.o: $(SRC)/specfem.f90
+ ${F90} $(FLAGS) -c -o $O/specfem.o $(SRC)/specfem.f90
+
+$O/storearray.o: $(SRC)/storearray.f90
+ ${F90} $(FLAGS) -c -o $O/storearray.o $(SRC)/storearray.f90
+
+$O/writeseis.o: $(SRC)/writeseis.f90
+ ${F90} $(FLAGS) -c -o $O/writeseis.o $(SRC)/writeseis.f90
+
+$O/zwgjd.o: $(SRC)/zwgjd.f90
+ ${F90} $(FLAGS) -c -o $O/zwgjd.o $(SRC)/zwgjd.f90
+
+$O/zwgljd.o: $(SRC)/zwgljd.f90
+ ${F90} $(FLAGS) -c -o $O/zwgljd.o $(SRC)/zwgljd.f90
+
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/calc_energie.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/calc_energie.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/calc_energie.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,141 @@
+
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine calc_energie(hprime,hTprime,ibool,displ,veloc, &
+ Uxnewloc,Uznewloc,kmato,dvolu,xjaci,density,elastcoef,wx,wy, &
+ nxgll,npoin,ndime,nspec,numat)
+
+ use timeparams
+ use energie
+
+ implicit none
+
+ double precision, parameter :: zero = 0.d0, two = 2.d0
+
+ integer nxgll,nspec,ndime,npoin,numat
+
+ double precision hprime(nxgll,nxgll),hTprime(nxgll,nxgll)
+ double precision Uxnewloc(nxgll,nxgll,nspec)
+ double precision Uznewloc(nxgll,nxgll,nspec)
+
+ double precision dUx_dxi,dUz_dxi,dUx_deta,dUz_deta
+ double precision hTprimex,hprimez
+
+ double precision density(numat),elastcoef(4,numat)
+ double precision dvolu(nspec,nxgll,nxgll)
+ double precision xjaci(nspec,ndime,ndime,nxgll,nxgll)
+ double precision wx(nxgll),wy(nxgll)
+
+ integer ibool(nxgll,nxgll,nspec)
+ integer kmato(nspec)
+
+ double precision displ(ndime,npoin),veloc(ndime,npoin)
+
+ integer i,j,k,l,iglobnum,material
+ double precision energie_pot,energie_cin
+ double precision dxux,dzux,dxuz,dzuz
+ double precision rKmod,rlamda,rmu,xix,xiz,etax,etaz,denst,rjacob
+
+! map the global displacement field to the local mesh
+!$PAR DOALL
+!$PAR& READONLY(ibool,displ)
+ do k=1,nspec
+ do j=1,nxgll
+ do i=1,nxgll
+ iglobnum = ibool(i,j,k)
+ Uxnewloc(i,j,k) = displ(1,iglobnum)
+ Uznewloc(i,j,k) = displ(2,iglobnum)
+ enddo
+ enddo
+ enddo
+
+ energie_pot = zero
+ energie_cin = zero
+
+! this loop is simply a reduction
+! on the two scalar variables "energie_cin" and "energie_pot"
+!$PAR DOALL_REDUCTION
+ do k=1,nspec
+
+! get the elastic parameters
+ material = kmato(k)
+
+ rlamda = elastcoef(1,material)
+ rmu = elastcoef(2,material)
+ rKmod = elastcoef(3,material)
+ denst = density(material)
+
+ do j=1,nxgll
+ do i=1,nxgll
+
+! compute the gradient of the displacement field (matrix products)
+ dUx_dxi = zero
+ dUz_dxi = zero
+ dUx_deta = zero
+ dUz_deta = zero
+
+ do l=1,nxgll
+
+ hTprimex = hTprime(i,l)
+ hprimez = hprime(l,j)
+
+ dUx_dxi = dUx_dxi + hTprimex*Uxnewloc(l,j,k)
+ dUz_dxi = dUz_dxi + hTprimex*Uznewloc(l,j,k)
+ dUx_deta = dUx_deta + Uxnewloc(i,l,k)*hprimez
+ dUz_deta = dUz_deta + Uznewloc(i,l,k)*hprimez
+
+ enddo
+
+! apply the chain rule to get this gradient in the physical domain
+ xix = xjaci(k,1,1,i,j)
+ xiz = xjaci(k,1,2,i,j)
+ etax = xjaci(k,2,1,i,j)
+ etaz = xjaci(k,2,2,i,j)
+ rjacob = dvolu(k,i,j)
+
+ dxux = dUx_dxi*xix + dUx_deta*etax
+ dzux = dUx_dxi*xiz + dUx_deta*etaz
+
+ dxuz = dUz_dxi*xix + dUz_deta*etax
+ dzuz = dUz_dxi*xiz + dUz_deta*etaz
+
+ iglobnum = ibool(i,j,k)
+
+! calcul de l'energie cinetique
+ energie_cin = energie_cin + &
+ denst*(veloc(1,iglobnum)**2 + veloc(2,iglobnum)**2) &
+ *wx(i)*wy(j)*rjacob
+
+! calcul de l'energie potentielle elastique
+ energie_pot = energie_pot + &
+ (rKmod*dxux**2 + rKmod*dzuz**2 + two*rlamda*dxux*dzuz + &
+ rmu*(dzux + dxuz)**2)*wx(i)*wy(j)*rjacob
+
+ enddo
+ enddo
+ enddo
+
+! do not forget to divide by two at the end
+ energie_cin = energie_cin / two
+ energie_pot = energie_pot / two
+
+! on sauvegarde aussi l'energie totale qui doit etre constante
+! au cours du temps (une fois que la source a fini d'agir)
+! en l'absence de bords absorbants
+! et decroitre au cours du temps en presence de bords absorbants
+ write(ienergy,*) sngl(time),sngl(energie_cin),sngl(energie_pot), &
+ sngl(energie_cin + energie_pot)
+
+ return
+ end subroutine calc_energie
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/calcdivcurl.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/calcdivcurl.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/calcdivcurl.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,99 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine calcdivcurl(displ,div,curl,hprime,hTprime,ibool, &
+ Uxloc,Uzloc,dUx_dxi,dUz_dxi,dUx_deta,dUz_deta,xjaci)
+!
+!=======================================================================
+!
+! "c a l c d i v c u r l" : Compute the divergence and the curl
+! of the displacement field
+!
+!=======================================================================
+!
+ use mesh01
+ use spela202
+
+ implicit none
+
+ double precision Uxloc(nxgll,nxgll,nspec)
+ double precision Uzloc(nxgll,nxgll,nspec)
+ double precision hprime(nxgll,nxgll)
+ double precision hTprime(nxgll,nxgll)
+ double precision xjaci(nspec,ndime,ndime,nxgll,nxgll)
+ double precision dUx_dxi(nxgll,nxgll,nspec)
+ double precision dUz_dxi(nxgll,nxgll,nspec)
+ double precision dUx_deta(nxgll,nxgll,nspec)
+ double precision dUz_deta(nxgll,nxgll,nspec)
+ double precision displ(ndime,npoin)
+ double precision div(npoin)
+ double precision curl(npoin)
+ integer ibool(nxgll,nxgll,nspec)
+
+ integer i,j,k,l,iglobnum
+ double precision xix,xiz,etax,etaz
+
+
+! definir div et curl
+
+ do i=1,nxgll
+ do j=1,nxgll
+ do k=1,nspec
+ iglobnum = ibool(i,j,k)
+ Uxloc(i,j,k) = displ(1,iglobnum)
+ Uzloc(i,j,k) = displ(2,iglobnum)
+ enddo
+ enddo
+ enddo
+
+ do k=1,nspec
+ do i=1,nxgll
+ do j=1,nxgll
+ dUx_dxi(i,j,k) = 0.d0
+ dUz_dxi(i,j,k) = 0.d0
+ dUx_deta(i,j,k) = 0.d0
+ dUz_deta(i,j,k) = 0.d0
+ do l=1,nxgll
+
+ dUx_dxi(i,j,k) = dUx_dxi(i,j,k) + hTprime(i,l)*Uxloc(l,j,k)
+ dUz_dxi(i,j,k) = dUz_dxi(i,j,k) + hTprime(i,l)*Uzloc(l,j,k)
+ dUx_deta(i,j,k) = dUx_deta(i,j,k) + Uxloc(i,l,k)*hprime(l,j)
+ dUz_deta(i,j,k) = dUz_deta(i,j,k) + Uzloc(i,l,k)*hprime(l,j)
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do k=1,nspec
+ do i=1,nxgll
+ do j=1,nxgll
+
+ xix = xjaci(k,1,1,i,j)
+ xiz = xjaci(k,1,2,i,j)
+ etax = xjaci(k,2,1,i,j)
+ etaz = xjaci(k,2,2,i,j)
+
+ iglobnum = ibool(i,j,k)
+
+ div(iglobnum) = dUx_dxi(i,j,k)*xix + dUx_deta(i,j,k)*etax + &
+ dUz_dxi(i,j,k)*xiz + dUz_deta(i,j,k)*etaz
+ curl(iglobnum) = dUx_dxi(i,j,k)*xiz + dUx_deta(i,j,k)*etaz - &
+ dUz_dxi(i,j,k)*xix - dUz_deta(i,j,k)*etax
+
+ enddo
+ enddo
+ enddo
+
+ return
+ end subroutine calcdivcurl
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/calcforce.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/calcforce.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/calcforce.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,55 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine calcforce(F,ndime,gltfu,nltfl,t)
+
+! calcul de la force source en temps
+
+ implicit none
+
+ integer ndime,nltfl
+ double precision t
+ double precision gltfu(20,nltfl)
+ double precision F(ndime,nltfl)
+
+ integer n,isource
+ double precision funct,angle
+ double precision, external :: ricker,dirac
+
+ do n=1,nltfl
+
+! determiner type de source
+ isource = nint(gltfu(1,n))
+
+! la source est une force colloquee
+ if(nint(gltfu(2,n)) == 1) then
+
+! introduire source suivant son type
+ if(isource == 6) then
+ funct = ricker(t,n,gltfu,nltfl)
+ else if(isource == 7) then
+ funct = dirac(t,n,gltfu,nltfl)
+ else
+ funct = 0.d0
+ endif
+
+ angle = gltfu(8,n)
+ F(1,n) = - dsin(angle) * funct
+ F(2,n) = + dcos(angle) * funct
+
+ endif
+
+ enddo
+
+ return
+ end subroutine calcforce
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/checkgrid.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/checkgrid.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/checkgrid.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,102 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine checkgrid(deltat,gltfu,nltfl,initialfield)
+
+!
+!---- verification taille des mailles, stabilite et nb de points par lambda
+!
+
+ use verifs
+ use spela202
+
+ implicit none
+
+ integer nltfl
+ double precision gltfu(20,nltfl)
+ double precision deltat
+ logical initialfield
+
+ integer n,isource
+ double precision f0,t0
+
+!
+!---- verification taille de grille min et max
+!
+
+ print *
+ print *,'******************************************'
+ print *,'*** Verification parametres simulation ***'
+ print *,'******************************************'
+ print *
+ print *,'*** Taille max grille = ',rsizemax
+ print *,'*** Taille min grille = ',rsizemin
+ print *,'*** Rapport max/min = ',rsizemax/rsizemin
+ print *
+ print *,'*** Stabilite max vitesse P = ',cpoverdxmax*deltat
+ print *,'*** Stabilite min vitesse P = ',cpoverdxmin*deltat
+ print *
+
+!
+!---- boucle sur toutes les sources
+!
+
+ if(.not. initialfield) then
+
+ do n=1,nltfl
+
+!
+!---- determiner type de source
+!
+ isource = nint(gltfu(1,n))
+ f0 = gltfu(5,n)
+ t0 = gltfu(6,n)
+
+!
+!---- utiliser type de source en temps
+!
+ if(isource == 6) then
+ print *,' Source ',n,': Ricker'
+ print *,' Onset time = ',t0
+ print *,' Fundamental period = ',1.d0/f0
+ print *,' Fundamental frequency = ',f0
+ if(t0 <= 1.d0/f0) then
+ stop 'Onset time too small'
+ else
+ print *,' --> onset time ok'
+ endif
+ print *,'----'
+ print *,' Nb pts / lambda P max f0 = ',nxgll*rlamdaPmax/f0
+ print *,' Nb pts / lambda P min f0 = ',nxgll*rlamdaPmin/f0
+ print *,' Nb pts / lambda P max fmax = ',nxgll*rlamdaPmax/(2.5d0*f0)
+ print *,' Nb pts / lambda P min fmax = ',nxgll*rlamdaPmin/(2.5d0*f0)
+ print *,'----'
+ print *,' Nb pts / lambda S max f0 = ',nxgll*rlamdaSmax/f0
+ print *,' Nb pts / lambda S min f0 = ',nxgll*rlamdaSmin/f0
+ print *,' Nb pts / lambda S max fmax = ',nxgll*rlamdaSmax/(2.5d0*f0)
+ print *,' Nb pts / lambda S min fmax = ',nxgll*rlamdaSmin/(2.5d0*f0)
+ print *,'----'
+ else if(isource == 7) then
+ print *,' Source ',n,': dirac **** not checked ****'
+ else
+ stop 'Unknown type of source'
+ endif
+
+ print *
+
+ enddo
+
+ endif
+
+ return
+ end subroutine checkgrid
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/checksource.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/checksource.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/checksource.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,134 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine checksource(gltfu,nltfl,deltat,ncycl)
+
+ use verifs
+
+ implicit none
+
+ integer nltfl,ncycl
+ double precision deltat
+
+ double precision gltfu(20,nltfl)
+
+ double precision, external :: ricker,dirac
+ integer it,n,isource,i,ncycl2,iseuil
+ integer icf(1)
+ double precision absfreq,cf,cmaxf
+
+! pour spectre de la source (en simple precision pour routine Netlib)
+ real, dimension(:), allocatable :: so,ra,rb,wsave
+ real azero,valmax
+
+ print *,'Creating gnuplot file for source time functions'
+
+! arrondir ncycl au nombre pair inferieur
+ ncycl2 = ncycl
+ if(mod(ncycl2,2) /= 0) ncycl2 = ncycl2 - 1
+
+ allocate(so(ncycl2))
+ allocate(ra(ncycl2/2))
+ allocate(rb(ncycl2/2))
+ allocate(wsave(3*ncycl2+15))
+
+ open(unit=11,file='sources',status='unknown')
+
+! boucle sur tous les pas de temps
+ do it=1,ncycl2
+
+! boucle sur toutes les sources
+ do n=1,nltfl
+
+! determiner type de source
+ isource = nint(gltfu(1,n))
+
+! utiliser type de source en temps
+ if(isource == 6) then
+ gltfu(19,n) = ricker(it*deltat,n,gltfu,nltfl)
+ else if(isource == 7) then
+ gltfu(19,n) = dirac(it*deltat,n,gltfu,nltfl)
+ else
+ gltfu(19,n) = 0.d0
+ endif
+
+ enddo
+
+ write(11,*) real(it*deltat),(real(gltfu(19,i)),i=1,nltfl)
+
+ enddo
+
+ close(11)
+
+!
+! check central frequency by computing the Fourier transform of the source
+!
+
+!! DK DK this part suppressed since does not work with range checking
+ goto 333
+
+ azero = 0
+ n = 1
+
+ do it=1,ncycl2
+ so(it)=sngl(ricker(it*deltat,n,gltfu,nltfl))
+ enddo
+
+! initialisation pour routine de FFT de Netlib
+ call ezffti(ncycl2,wsave)
+
+! appel routine de FFT de Netlib
+ call ezfftf(ncycl2,so,azero,ra,rb,wsave)
+
+! prendre le module de l'amplitude spectrale
+ ra(:) = sqrt(ra(:)**2 + rb(:)**2)
+
+! determiner la frequence centrale de la source
+ icf = maxloc(ra(1:ncycl2/2 - 1))
+ cf = icf(1)/(ncycl2*deltat)
+
+! normaliser le spectre d'amplitude
+ valmax = ra(icf(1))
+ ra(:) = ra(:) / valmax
+
+! determiner la frequence maximale de la source
+ iseuil = ncycl2/2 - 1
+ do it=icf(1)+1,ncycl2/2 - 1
+ if(ra(it) < sngl(valseuil)) then
+ iseuil = it
+ exit
+ endif
+ enddo
+ cmaxf = iseuil/(ncycl2*deltat)
+
+ print *,'Estimated central freq of the source is ',cf
+ print *,'Estimated max freq of the source is ',cmaxf
+ print *,'Nyquist frequency for the sampled time function is ',1.d0/(2.d0*deltat)
+
+! sauvegarde du spectre d'amplitude de la source en Hz au format Gnuplot
+ open(unit=10,file='spectrum',status='unknown')
+ do it=1,ncycl2/2 - 1
+ absfreq = it/(ncycl2*deltat)
+ if (absfreq <= sngl(freqmaxrep)) write(10,*) sngl(absfreq),ra(it)
+ enddo
+ close(10)
+
+ 333 continue
+
+ deallocate(so)
+ deallocate(ra)
+ deallocate(rb)
+ deallocate(wsave)
+
+ return
+ end subroutine checksource
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/contol.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/contol.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/contol.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,180 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine contol
+!
+!=======================================================================
+!
+! "C o n t o l" : Reads main control parameters
+! -----------
+!
+!=======================================================================
+!
+
+ use iounit
+ use infos
+ use mesh01
+ use constspec
+ use energie
+ use verifs
+
+ implicit none
+
+ character(len=80) datlin
+
+!
+!-----------------------------------------------------------------------
+!
+!----
+!
+ read(iin , 40) datlin
+ read(iin , * ) ndofn,ndime,npgeo
+!
+!----
+!
+ read(iin , 40) datlin
+ read(iin , * ) display,ignuplot,interpol
+!
+!----
+!
+ read(iin , 40) datlin
+ read(iin , * ) itaff, itfirstaff, icolor, inumber
+!
+!----
+!
+ read(iin , 40) datlin
+ read(iin , * ) ivectplot,imeshvect,imodelvect,iboundvect,cutvect,isubsamp
+ cutvect = cutvect / 100.d0
+!
+!----
+!
+ read(iin , 40) datlin
+ read(iin , * ) scalex,scalez,sizemax,angle,rapport,usletter
+!
+!----
+!
+ read(iin , 40) datlin
+ read(iin , * ) orig_x,orig_z,isymbols
+!
+!----
+!
+ read(iin , 40) datlin
+ read(iin , * ) valseuil,freqmaxrep
+ valseuil = valseuil / 100.d0
+!
+!----
+!
+ read(iin , 40) datlin
+ read(iin , * ) sismos,nrec,nrec1,nrec2,isamp
+!
+!----
+!
+ read(iin , 40) datlin
+ read(iin , * ) irepr,anglerec,anglerec2
+!
+!----
+!
+ read(iin , 40) datlin
+ read(iin , * ) compenergy
+!
+!----
+!
+ read(iin , 40) datlin
+ read(iin , * ) initialfield,factorana,factorxsu,n1ana,n2ana
+!
+!----
+!
+ read(iin , 40) datlin
+ read(iin , * ) isismostype,ivecttype,iaffinfo
+!
+!----
+!
+ read(iin , 40) datlin
+ read(iin , * ) ireadmodel,ioutputgrid,iavs
+!
+!----
+!
+ read(iin , 40) datlin
+ read(iin , * ) iexec,iecho
+!
+!---- output control parameters
+!
+ if(iecho /= 0) then
+ write(iout,200) npgeo,ndofn,ndime
+ write(iout,500) iexec,iecho
+ write(iout,600) itaff,itfirstaff,iaffinfo,icolor,inumber
+ write(iout,700) sismos,nrec,isamp,isismostype,nrec1,nrec2,anglerec, &
+ anglerec2,compenergy,100.d0*valseuil,freqmaxrep
+ write(iout,750) initialfield,ireadmodel,ioutputgrid,iavs
+ write(iout,800) ivecttype,100.d0*cutvect,isubsamp,scalex,scalez, &
+ sizemax,angle,rapport,orig_x,orig_z,usletter
+ endif
+
+ return
+
+ 40 format(a80)
+ 200 format(//1x,'C o n t r o l c a r d n o . 1',/1x,34('='),//5x,&
+ 'Number of spectral elements control nodes. . (npgeo) =',i8/5x, &
+ 'Number of d.o.f per node . . . . . . . . . . (ndofn) =',i8/5x, &
+ 'Number of space dimensions . . . . . . . . . (ndime) =',i8)
+ 500 format(//1x,'C o n t r o l c a r d n o . 2',/1x,34('='),//5x,&
+ 'Execution mode . . . . . . . . . . . . . . . (iexec) =',i5/ 5x, &
+ ' == 0 data check only ', / 5x, &
+ ' == 1 resolution ', / 5x, &
+ 'Data echoing . . . . . . . . . . . . . . . . (iecho) =',i5/ 5x, &
+ ' == 0 do not echo input data ', / 5x, &
+ ' == 1 echo input data - short listing ', / 5x, &
+ ' == 2 echo input data - full listing ')
+ 600 format(//1x,'C o n t r o l c a r d n o . 3',/1x,34('='),//5x, &
+ 'Display frequency . . . . . . . . . . . . . (itaff) = ',i5/ 5x, &
+ 'First display . . . . . . . . . . . . . (itfirstaff) = ',i5/ 5x, &
+ 'Basic info output frequency . . . . . . . (iaffinfo) = ',i5/ 5x, &
+ 'Color display . . . . . . . . . . . . . . . (icolor) = ',i5/ 5x, &
+ ' == 0 black and white display ', / 5x, &
+ ' == 1 color display ', /5x, &
+ 'Numbered mesh . . . . . . . . . . . . . . .(inumber) = ',i5/ 5x, &
+ ' == 0 do not number the mesh ', /5x, &
+ ' == 1 number the mesh ')
+ 700 format(//1x,'C o n t r o l c a r d n o . 4',/1x,34('='),//5x, &
+ 'Record seismograms or not. . . . . . . . . .(sismos) = ',l6/5x, &
+ 'Total number of receivers. . . . . . . . . . .(nrec) = ',i6/5x, &
+ 'Subsampling for seismograms recording . . . .(isamp) = ',i6/5x, &
+ 'Seismograms recording type. . . . . . .(isismostype) = ',i6/5x, &
+ 'Number of receivers on first line . . . . . .(nrec1) = ',i6/5x, &
+ 'Number of receivers on second line. . . . . .(nrec2) = ',i6/5x, &
+ 'Angle for first line of receivers. . . . .(anglerec) = ',f6.2/5x, &
+ 'Angle for second line of receivers. . . .(anglerec2) = ',f6.2/5x, &
+ 'Compute total and potential energy . . .(compenergy) = ',l6/5x, &
+ 'Threshold for maximum frequency in % . . .(valseuil) = ',f6.2/5x, &
+ 'Maximal frequency plotted in spectrum. .(freqmaxrep) = ',1pe8.2)
+ 750 format(//1x,'C o n t r o l c a r d n o . 5',/1x,34('='),//5x, &
+ 'Read external initial field or not . .(initialfield) = ',l6/5x, &
+ 'Read external velocity model or not. . .(ireadmodel) = ',l6/5x, &
+ 'Save grid in external file or not . . .(ioutputgrid) = ',l6/5x, &
+ 'Save results in AVS file or not. . . . . . . .(iavs) = ',l6)
+ 800 format(//1x,'C o n t r o l c a r d n o . 6',/1x,34('='),//5x, &
+ 'Vector display type . . . . . . . . . . .(ivecttype) = ',i6/5x, &
+ 'Percentage of cut for vector plots. . . . .(cutvect) = ',f6.2/5x, &
+ 'Subsampling for velocity model display . .(isubsamp) = ',i6/5x, &
+ 'X-Scaling of plot for PostScript . . . . . .(scalex) = ',f6.2/5x, &
+ 'Z-Scaling of plot for PostScript . . . . . .(scalez) = ',f6.2/5x, &
+ 'Max size of arrows for PostScript . . . . .(sizemax) = ',f6.2/5x, &
+ 'Angle of vector arrows. . . . . . . . . . . .(angle) = ',f6.2/5x, &
+ 'Head to body ratio for arrows . . . . . . .(rapport) = ',f6.2/5x, &
+ 'X origin for Postscript display. . . . . . .(orig_x) = ',f6.2/5x, &
+ 'Z origin for Postscript display. . . . . . .(orig_z) = ',f6.2/5x, &
+ 'US letter format or French A4. . . . . . .(usletter) = ',l6)
+!
+!----
+!
+ end subroutine contol
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/createnum_fast.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/createnum_fast.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/createnum_fast.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,343 @@
+
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine createnum_fast(knods,ibool,kmato,shape,coorg,npoin,ndime,npgeo)
+!
+!=======================================================================
+!
+! "c r e a t e n u m _ f a s t": Equivalent de la routine "createnum_slow"
+! mais avec un algorithme "sale mais tres rapide"
+!
+! Cette version rapide necessite l'allocation de tableaux supplementaires
+!
+! Cette version rapide n'accepte pas les conditions periodiques
+! En cas de conditions periodiques, utiliser la version lente
+!
+!=======================================================================
+!
+
+ use iounit
+ use infos
+ use spela202
+
+ implicit none
+
+ integer npoin,ndime,npgeo
+ integer knods(ngnod,nspec),ibool(nxgll,nygll,nspec),kmato(nspec)
+ double precision shape(ngnod,nxgll,nxgll)
+ double precision coorg(ndime,npgeo)
+
+ integer i,j,numelem
+
+ double precision, parameter :: smallvaltol = 0.000001d0
+ double precision, parameter :: HUGEVAL=1.0d+30
+
+ double precision, parameter :: zero = 0.d0
+
+! tableaux supplementaires pour cette version rapide
+
+ integer, dimension(:), allocatable :: loc,ind,ninseg,iglob,iwork
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: xp,yp,work
+
+ integer ie,nseg,ioff,iseg,ig
+ integer nxyz,ntot,ispec,ieoff,ilocnum,iy,ix,in,nnum
+
+ double precision xmaxval,xminval,ymaxval,yminval,xtol,xtypdist
+ double precision xcor,ycor
+
+!
+!-----------------------------------------------------------------------
+!
+
+!
+!---- create global numbering from mesh structure
+!
+ print *
+ print *
+ print *,'Generating global numbering from mesh structure (fast version)...'
+ print *
+
+ nxyz = nxgll*nygll
+ ntot = nxyz*nspec
+
+ print *,'Allocating a few more arrays for the fast version'
+
+ allocate(loc(ntot))
+ allocate(ind(ntot))
+ allocate(ninseg(ntot))
+ allocate(iglob(ntot))
+ allocate(ifseg(ntot))
+ allocate(xp(ntot))
+ allocate(yp(ntot))
+ allocate(work(ntot))
+ allocate(iwork(ntot))
+
+ print *,'Generating the numbering'
+
+! compute coordinates of the grid points
+ do ispec=1,nspec
+ ieoff = nxyz*(ispec - 1)
+ ilocnum = 0
+
+ do iy = 1,nxgll
+ do ix = 1,nxgll
+
+ ilocnum = ilocnum + 1
+
+ xcor = zero
+ ycor = zero
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xcor = xcor + shape(in,ix,iy)*coorg(1,nnum)
+ ycor = ycor + shape(in,ix,iy)*coorg(2,nnum)
+ enddo
+
+ xp(ilocnum + ieoff) = xcor
+ yp(ilocnum + ieoff) = ycor
+
+ enddo
+ enddo
+
+ enddo
+
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+! Establish initial pointers
+ do ie=1,nspec
+ ieoff = nxyz*(ie -1)
+ do ix=1,nxyz
+ loc (ix+ieoff) = ix+ieoff
+ enddo
+ enddo
+
+! set up local geometric tolerances
+
+ xtypdist=+HUGEVAL
+
+ do ie=1,nspec
+
+ xminval=+HUGEVAL
+ yminval=+HUGEVAL
+ xmaxval=-HUGEVAL
+ ymaxval=-HUGEVAL
+ ieoff=nxyz*(ie-1)
+ do ilocnum=1,nxyz
+ xmaxval=dmax1(xp(ieoff+ilocnum),xmaxval)
+ xminval=dmin1(xp(ieoff+ilocnum),xminval)
+ ymaxval=dmax1(yp(ieoff+ilocnum),ymaxval)
+ yminval=dmin1(yp(ieoff+ilocnum),yminval)
+ enddo
+
+! compute the minimum typical "size" of an element in the mesh
+ xtypdist = dmin1(xtypdist,xmaxval-xminval)
+ xtypdist = dmin1(xtypdist,ymaxval-yminval)
+
+ enddo
+
+! define a tolerance, small with respect to the minimum size
+ xtol=smallvaltol*xtypdist
+
+ ifseg(:) = .false.
+ nseg = 1
+ ifseg(1) = .true.
+ ninseg(1) = ntot
+
+ do j=1,ndime
+! Sort within each segment
+ ioff=1
+ do iseg=1,nseg
+ if (j == 1) then
+ call rank (xp(ioff),ind,ninseg(iseg))
+ else
+ call rank (yp(ioff),ind,ninseg(iseg))
+ endif
+ call swap(xp(ioff),work,ind,ninseg(iseg))
+ call swap(yp(ioff),work,ind,ninseg(iseg))
+ call iswap(loc(ioff),iwork,ind,ninseg(iseg))
+ ioff=ioff+ninseg(iseg)
+ enddo
+! Check for jumps in current coordinate
+ if (j == 1) then
+ do i=2,ntot
+ if (abs(xp(i)-xp(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ else
+ do i=2,ntot
+ if (abs(yp(i)-yp(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ endif
+! Count up number of different segments
+ nseg = 0
+ do i=1,ntot
+ if (ifseg(i)) then
+ nseg = nseg+1
+ ninseg(nseg) = 1
+ else
+ ninseg(nseg) = ninseg(nseg) + 1
+ endif
+ enddo
+ enddo
+!
+! Assign global node numbers (now sorted lexicographically!)
+!
+ ig = 0
+ do i=1,ntot
+ if (ifseg(i)) ig=ig+1
+ iglob(loc(i)) = ig
+ enddo
+
+ npoin = ig
+
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+! recuperer resultat a mon format
+ do ispec=1,nspec
+ ieoff = nxyz*(ispec - 1)
+ ilocnum = 0
+ do iy = 1,nxgll
+ do ix = 1,nxgll
+ ilocnum = ilocnum + 1
+ ibool(ix,iy,ispec) = iglob(ilocnum + ieoff)
+ enddo
+ enddo
+ enddo
+
+ print *,'Deallocating the arrays'
+
+ deallocate(loc)
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iglob)
+ deallocate(ifseg)
+ deallocate(xp)
+ deallocate(yp)
+ deallocate(work)
+ deallocate(iwork)
+
+! verification de la coherence de la numerotation generee
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) &
+ stop 'Error while generating global numbering'
+
+ print *
+ print *,'Total number of points of the global mesh: ',npoin
+ print *
+
+ return
+ end subroutine createnum_fast
+
+
+!-----------------------------------------------------------------------
+ subroutine rank(A,IND,N)
+!
+! Use Heap Sort (p 233 Numerical Recipes)
+!
+ implicit none
+ integer N
+ double precision A(N)
+ integer IND(N)
+
+ integer i,j,l,ir,indx
+ double precision q
+
+ do J=1,N
+ IND(j)=j
+ enddo
+
+ if (n == 1) return
+ L=n/2+1
+ ir=n
+ 100 CONTINUE
+ IF (l > 1) THEN
+ l=l-1
+ indx=ind(l)
+ q=a(indx)
+ ELSE
+ indx=ind(ir)
+ q=a(indx)
+ ind(ir)=ind(1)
+ ir=ir-1
+ if (ir == 1) then
+ ind(1)=indx
+ return
+ endif
+ ENDIF
+ i=l
+ j=l+l
+ 200 CONTINUE
+ IF (J <= IR) THEN
+ IF (J < IR) THEN
+ IF ( A(IND(j)) < A(IND(j+1)) ) j=j+1
+ ENDIF
+ IF (q < A(IND(j))) THEN
+ IND(I)=IND(J)
+ I=J
+ J=J+J
+ ELSE
+ J=IR+1
+ ENDIF
+ GOTO 200
+ ENDIF
+ IND(I)=INDX
+ GOTO 100
+ end subroutine rank
+
+!-----------------------------------------------------------------------
+ subroutine swap(a,w,ind,n)
+!
+! Use IND to sort array A (p 233 Numerical Recipes)
+!
+ implicit none
+
+ integer n
+ double precision A(N),W(N)
+ integer IND(N)
+
+ integer j
+
+ do J=1,N
+ W(j)=A(j)
+ enddo
+
+ do J=1,N
+ A(j)=W(ind(j))
+ enddo
+
+ RETURN
+ end subroutine swap
+
+!-----------------------------------------------------------------------
+
+ subroutine iswap(a,w,ind,n)
+!
+! Use IND to sort array A
+!
+ implicit none
+
+ integer n
+ integer A(N),W(N),IND(N)
+
+ integer j
+
+ do J=1,N
+ W(j)=A(j)
+ enddo
+
+ do J=1,N
+ A(j)=W(ind(j))
+ enddo
+
+ RETURN
+ end subroutine iswap
+
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/createnum_slow.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/createnum_slow.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/createnum_slow.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,310 @@
+
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine createnum_slow(knods,ibool,kmato,npoin)
+!
+!=======================================================================
+!
+! "c r e a t e n u m _ s l o w": generate the global numbering
+!
+!=======================================================================
+!
+
+ use iounit
+ use infos
+ use spela202
+
+ implicit none
+
+ integer knods(ngnod,nspec),ibool(nxgll,nygll,nspec),kmato(nspec)
+ integer npoin
+
+ integer i,j,num2,i2,j2,ipos,ipos2,iloc,jloc,kloc
+ integer ngnodloc,ngnodother,nedgeloc,nedgeother,npedge,numelem,npcorn
+ logical alreadyexist
+
+ integer ngnoddeb(4),ngnodfin(4)
+
+!
+!-----------------------------------------------------------------------
+!
+
+!
+!---- create global numbering from mesh structure
+!
+ print *
+ print *
+ print *,'Generating global numbering from mesh structure (slow version)...'
+ print *
+
+ npoin = 0
+ npedge = 0
+ npcorn = 0
+
+! definition des aretes par rapport aux quatre points de controle
+
+! --- arete 1 relie point 1 a point 2
+ ngnoddeb(1)= 1
+ ngnodfin(1)= 2
+
+! --- arete 2 relie point 2 a point 3
+ ngnoddeb(2)= 2
+ ngnodfin(2)= 3
+
+! --- arete 3 relie point 3 a point 4
+ ngnoddeb(3)= 3
+ ngnodfin(3)= 4
+
+! --- arete 4 relie point 4 a point 1
+ ngnoddeb(4)= 4
+ ngnodfin(4)= 1
+
+! initialisation du tableau de numerotation globale
+ do numelem = 1,nspec
+ do i=1,nxgll
+ do j=1,nygll
+ ibool(i,j,numelem) = 0
+ enddo
+ enddo
+ enddo
+
+ do numelem = 1,nspec
+ do i=1,nxgll
+ do j=1,nygll
+
+! verifier que le point n'a pas deja ete genere
+
+ if(ibool(i,j,numelem) == 0) then
+
+!
+!---- point interieur a un element, donc forcement unique
+!
+ if(i /= 1 .and. i /= nxgll .and. j /= 1 .and. j /= nygll) then
+
+ npoin = npoin + 1
+ ibool(i,j,numelem) = npoin
+
+!
+!---- point au coin d'un element, rechercher les coins des autres elements
+!
+ else if((i == 1.and.j == 1) .or. (i == 1.and.j == nygll) .or. &
+ (i == nxgll.and.j == 1) .or. (i == nxgll.and.j == nygll)) then
+
+! trouver numero local du coin
+ if(i == 1.and.j == 1) then
+ ngnodloc = 1
+ else if(i == nxgll.and.j == 1) then
+ ngnodloc = 2
+ else if(i == nxgll.and.j == nygll) then
+ ngnodloc = 3
+ else if(i == 1.and.j == nygll) then
+ ngnodloc = 4
+ endif
+
+! rechercher si existe deja, forcement dans un element precedent
+
+ alreadyexist = .false.
+
+ if(numelem > 1) then
+
+ do num2=1,numelem-1
+
+! ne rechercher que sur les 4 premiers points de controle et non sur ngnod
+ do ngnodother=1,4
+
+! voir si ce coin a deja ete genere
+ if(knods(ngnodother,num2) == knods(ngnodloc,numelem)) then
+ alreadyexist = .true.
+
+! obtenir la numerotation dans l'autre element
+ if(ngnodother == 1) then
+ i2 = 1
+ j2 = 1
+ else if(ngnodother == 2) then
+ i2 = nxgll
+ j2 = 1
+ else if(ngnodother == 3) then
+ i2 = nxgll
+ j2 = nygll
+ else if(ngnodother == 4) then
+ i2 = 1
+ j2 = nygll
+ else
+ stop 'bad corner'
+ endif
+
+! affecter le meme numero
+ ibool(i,j,numelem) = ibool(i2,j2,num2)
+
+! sortir de la recherche
+ goto 134
+
+ endif
+ enddo
+ enddo
+
+ 134 continue
+
+ endif
+
+! si un ancien point n'a pas ete trouve, en generer un nouveau
+ if(.not. alreadyexist) then
+ npcorn = npcorn + 1
+ npoin = npoin + 1
+ ibool(i,j,numelem) = npoin
+ endif
+
+!
+!---- point a l'interieur d'une arete, rechercher si autre arete correspondante
+!
+ else
+
+! trouver numero local de l'arete
+ if(j == 1) then
+ nedgeloc = 1
+ else if(i == nxgll) then
+ nedgeloc = 2
+ else if(j == nygll) then
+ nedgeloc = 3
+ else if(i == 1) then
+ nedgeloc = 4
+ endif
+
+! rechercher si existe deja, forcement dans un element precedent
+
+ alreadyexist = .false.
+
+ if(numelem > 1) then
+
+ do num2=1,numelem-1
+
+! rechercher sur les 4 aretes
+ do nedgeother=1,4
+
+!--- detecter un eventuel defaut dans la structure topologique du maillage
+
+ if((knods(ngnoddeb(nedgeother),num2) == knods(ngnoddeb(nedgeloc),numelem)) &
+ .and. &
+ (knods(ngnodfin(nedgeother),num2) == knods(ngnodfin(nedgeloc),numelem))) then
+ stop 'Improper topology of the input mesh detected'
+
+!--- sinon voir si cette arete a deja ete generee
+
+ else if((knods(ngnoddeb(nedgeother),num2) == knods(ngnodfin(nedgeloc),numelem)) &
+ .and. &
+ (knods(ngnodfin(nedgeother),num2) == knods(ngnoddeb(nedgeloc),numelem))) then
+
+ alreadyexist = .true.
+
+! obtenir la numerotation dans l'autre element
+! maillage conforme donc on doit supposer que nxgll == nygll
+
+! generer toute l'arete pour eviter des recherches superflues
+ do kloc = 2,nxgll-1
+
+! calculer l'abscisse le long de l'arete de depart
+ if(nedgeloc == 1) then
+ iloc = kloc
+ jloc = 1
+ ipos = iloc
+ else if(nedgeloc == 2) then
+ iloc = nxgll
+ jloc = kloc
+ ipos = jloc
+ else if(nedgeloc == 3) then
+ iloc = kloc
+ jloc = nygll
+ ipos = nxgll - iloc + 1
+ else if(nedgeloc == 4) then
+ iloc = 1
+ jloc = kloc
+ ipos = nygll - jloc + 1
+ else
+ stop 'bad nedgeloc'
+ endif
+
+! calculer l'abscisse le long de l'arete d'arrivee
+! topologie du maillage coherente, donc sens de parcours des aretes opposes
+
+ ipos2 = nxgll - ipos + 1
+
+! calculer les coordonnees reelles dans l'element d'arrivee
+ if(nedgeother == 1) then
+ i2 = ipos2
+ j2 = 1
+ else if(nedgeother == 2) then
+ i2 = nxgll
+ j2 = ipos2
+ else if(nedgeother == 3) then
+ i2 = nxgll - ipos2 + 1
+ j2 = nygll
+ else if(nedgeother == 4) then
+ i2 = 1
+ j2 = nygll - ipos2 + 1
+ else
+ stop 'bad nedgeother'
+ endif
+
+! verifier que le point de depart n'existe pas deja
+ if(ibool(iloc,jloc,numelem) /= 0) stop 'point genere deux fois'
+
+! verifier que le point d'arrivee existe bien deja
+ if(ibool(i2,j2,num2) == 0) stop 'point inconnu dans le maillage'
+
+! affecter le meme numero
+ ibool(iloc,jloc,numelem) = ibool(i2,j2,num2)
+
+ enddo
+
+! sortir de la recherche
+ goto 135
+
+ endif
+ enddo
+ enddo
+
+ 135 continue
+
+ endif
+
+! si un ancien point n'a pas ete trouve, en generer un nouveau
+ if(.not. alreadyexist) then
+ npedge = npedge + 1
+ npoin = npoin + 1
+ ibool(i,j,numelem) = npoin
+ endif
+
+ endif
+
+ endif
+
+ enddo
+ enddo
+ enddo
+
+! verification de la coherence de la numerotation generee
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) &
+ stop 'Error while generating global numbering'
+
+ print *,'Total number of points of the global mesh: ',npoin
+ print *
+ print *,'divided up as follows:'
+ print *
+ print *,'Number of interior points: ',npoin-npedge-npcorn
+ print *,'Number of edge points (without corners): ',npedge
+ print *,'Number of corner points: ',npcorn
+ print *
+
+ return
+ end subroutine createnum_slow
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/datim.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/datim.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/datim.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,61 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine datim (string1,string2,iout)
+!
+!=======================================================================
+!
+! D a t i m : Get date and time using f90 portable routines
+! ---------
+!
+!=======================================================================
+!
+ implicit none
+
+ character(len=*) string1
+ character(len=50) string2
+ character(len=8) datein
+ character(len=10) timein
+ character(len=16) dateprint
+ character(len=8) timeprint
+
+ integer iout
+
+!-----------------------------------------------------------------------
+
+ datein = ''
+ timein = ''
+
+ call date_and_time(datein,timein)
+
+ dateprint = datein(7:8)//' - '//datein(5:6)//' - '//datein(1:4)
+ timeprint = timein(1:2)//':'//timein(3:4)//':'//timein(5:6)
+
+!
+!-------------------------------------------------------------------
+!
+ write(iout,100) string1
+ write(iout,101) string2
+ write(iout,102) dateprint,timeprint
+
+ return
+!
+!---- formats
+!
+
+ 100 format(//1x,79('-')/1x,79('-')/1x,a)
+ 101 format(1x,79('-')/1x,79('-')/1x,a50)
+ 102 format(1x,79('-')/,1x,79('-')/' D a t e : ',a16, &
+ 30x,' T i m e : ',a8/1x,79('-'),/1x,79('-'))
+
+ end subroutine datim
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/defarrays.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/defarrays.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/defarrays.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,440 @@
+
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine defarrays(vpext,vsext,rhoext,density,elastcoef, &
+ xi,yi,wx,wy,hprime,hTprime, &
+ a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13x,a13z, &
+ ibool,iboolori,kmato,dvolu,xjaci,coord,gltfu, &
+ numabs,codeabs,anyabs,anyperio)
+!
+!=======================================================================
+!
+! "d e f a r r a y s" : Define arrays a1 to a13 for the spectral
+! elements solver
+!
+!=======================================================================
+!
+
+ use loadft
+ use iounit
+ use infos
+ use mesh01
+ use spela202
+ use constspec
+ use vparams
+ use verifs
+ use energie
+ use codebord
+
+ implicit none
+
+ integer kmato(nspec),ibool(0:nxgll-1,0:nxgll-1,nspec)
+ integer iboolori(0:nxgll-1,0:nxgll-1,nspec)
+
+ double precision density(numat),elastcoef(4,numat), &
+ xi(0:nxgll-1),yi(0:nygll-1),wx(0:nxgll-1),wy(0:nxgll-1), &
+ dvolu(nspec,0:nxgll-1,0:nxgll-1), &
+ xjaci(nspec,ndime,ndime,0:nxgll-1,0:nxgll-1), &
+ hprime(0:nxgll-1,0:nxgll-1), hTprime(0:nxgll-1,0:nxgll-1)
+
+ double precision coord(ndime,npoin)
+ double precision a1(0:nxgll-1,0:nxgll-1,nspec), &
+ a2(0:nxgll-1,0:nxgll-1,nspec), &
+ a3(0:nxgll-1,0:nxgll-1,nspec),a4(0:nxgll-1,0:nxgll-1,nspec), &
+ a5(0:nxgll-1,0:nxgll-1,nspec),a6(0:nxgll-1,0:nxgll-1,nspec), &
+ a7(0:nxgll-1,0:nxgll-1,nspec),a8(0:nxgll-1,0:nxgll-1,nspec), &
+ a9(0:nxgll-1,0:nxgll-1,nspec),a10(0:nxgll-1,0:nxgll-1,nspec)
+ double precision a13x(0:nxgll-1,0:nxgll-1,nelemabs), &
+ a13z(0:nxgll-1,0:nxgll-1,nelemabs)
+ double precision a11(0:nxgll-1,0:nxgll-1,nltfl), &
+ a12(0:nxgll-1,0:nxgll-1,nltfl)
+
+ double precision gltfu(20,nltfl)
+ double precision vpext(npoin)
+ double precision vsext(npoin)
+ double precision rhoext(npoin)
+
+ integer numabs(nelemabs),codeabs(4,nelemabs)
+
+ double precision, external :: hdgll
+
+ double precision, parameter :: zero=0.d0,one=1.d0
+
+ integer i,j,k
+ integer numelem,material
+ integer ipointnum,n
+ integer isourx,isourz,ielems,ir,is,ip,noffsetelem
+ double precision vsmin,vsmax,densmin,densmax
+ double precision rKmod,rlamda,rmu,xix,xiz,etax,etaz,denst,rjacob
+ double precision rKvol,cploc,csloc,xxi,zeta,rwx,x0,z0
+ double precision c11,c13,c33,c44
+ double precision x1,z1,x2,z2,rdist1,rdist2,rapportmin,rapportmax
+ double precision rlambmin,rlambmax,coefintegr
+ double precision flagxprime,flagzprime,sig0
+ logical anyabs,anyperio,anisotrope
+
+!
+!-----------------------------------------------------------------------
+!
+
+!---- compute parameters a1 to a13 for the spectral elements
+
+ a11 = zero
+ a12 = zero
+
+ a13x = zero
+ a13z = zero
+
+ vpmin = 1.d30
+ vsmin = 1.d30
+ vpmax = -1.d30
+ vsmax = -1.d30
+ densmin = 1.d30
+ densmax = -1.d30
+
+ rsizemin = 1.d30
+ rsizemax = -1.d30
+
+ cpoverdxmin = 1.d30
+ cpoverdxmax = -1.d30
+
+ rlamdaPmin = 1.d30
+ rlamdaSmin = 1.d30
+ rlamdaPmax = -1.d30
+ rlamdaSmax = -1.d30
+
+ do numelem=1,nspec
+
+ material = kmato(numelem)
+
+ rlamda = elastcoef(1,material)
+ rmu = elastcoef(2,material)
+ rKmod = elastcoef(3,material)
+ denst = density(material)
+
+ rKvol = rlamda + 2.d0*rmu/3.d0
+ cploc = dsqrt((rKvol + 4.d0*rmu/3.d0)/denst)
+ csloc = dsqrt(rmu/denst)
+
+! determiner si le materiau est anisotrope ou non
+ if(elastcoef(4,material) > 0.00001d0) then
+ anisotrope = .true.
+ c11 = elastcoef(1,material)
+ c13 = elastcoef(2,material)
+ c33 = elastcoef(3,material)
+ c44 = elastcoef(4,material)
+ else
+ anisotrope = .false.
+ endif
+
+ do i=0,nxgll-1
+ do j=0,nygll-1
+
+ xix = xjaci(numelem,1,1,i,j)
+ xiz = xjaci(numelem,1,2,i,j)
+ etax = xjaci(numelem,2,1,i,j)
+ etaz = xjaci(numelem,2,2,i,j)
+ rjacob = dvolu(numelem,i,j)
+
+ xxi = etaz * rjacob
+ zeta = xix * rjacob
+
+ rwx = - wx(i)*wy(j)
+
+!--- si formulation heterogene pour un modele de vitesse externe
+ if(ireadmodel) then
+ ipointnum = ibool(i,j,numelem)
+ cploc = vpext(ipointnum)
+ csloc = vsext(ipointnum)
+ denst = rhoext(ipointnum)
+ rmu = denst*csloc*csloc
+ rlamda = denst*cploc*cploc - 2.d0*rmu
+ rKmod = rlamda + 2.d0*rmu
+ endif
+
+!--- si materiau transverse isotrope, donner une idee des proprietes
+ if (anisotrope) then
+ cploc = sqrt(c11/denst)
+ csloc = sqrt(c44/denst)
+ endif
+
+!--- calculer min et max du modele de vitesse et densite
+ vpmin = dmin1(vpmin,cploc)
+ vpmax = dmax1(vpmax,cploc)
+
+ vsmin = dmin1(vsmin,csloc)
+ vsmax = dmax1(vsmax,csloc)
+
+ densmin = dmin1(densmin,denst)
+ densmax = dmax1(densmax,denst)
+
+!--- stocker parametres pour verifs diverses
+ if(i /= nxgll-1 .and. j /= nygll-1) then
+
+ if(anyperio) then
+ x0 = coord(1,iboolori(i,j,numelem))
+ z0 = coord(2,iboolori(i,j,numelem))
+ x1 = coord(1,iboolori(i+1,j,numelem))
+ z1 = coord(2,iboolori(i+1,j,numelem))
+ x2 = coord(1,iboolori(i,j+1,numelem))
+ z2 = coord(2,iboolori(i,j+1,numelem))
+ else
+ x0 = coord(1,ibool(i,j,numelem))
+ z0 = coord(2,ibool(i,j,numelem))
+ x1 = coord(1,ibool(i+1,j,numelem))
+ z1 = coord(2,ibool(i+1,j,numelem))
+ x2 = coord(1,ibool(i,j+1,numelem))
+ z2 = coord(2,ibool(i,j+1,numelem))
+ endif
+
+ rdist1 = dsqrt((x1-x0)**2 + (z1-z0)**2)
+ rdist2 = dsqrt((x2-x0)**2 + (z2-z0)**2)
+ rsizemin = dmin1(rsizemin,rdist1)
+ rsizemin = dmin1(rsizemin,rdist2)
+ rsizemax = dmax1(rsizemax,rdist1)
+ rsizemax = dmax1(rsizemax,rdist2)
+
+ rapportmin = cploc / dmax1(rdist1,rdist2)
+ rapportmax = cploc / dmin1(rdist1,rdist2)
+ cpoverdxmin = dmin1(cpoverdxmin,rapportmin)
+ cpoverdxmax = dmax1(cpoverdxmax,rapportmax)
+
+ if(anyperio) then
+ x0 = coord(1,iboolori(0,0,numelem))
+ z0 = coord(2,iboolori(0,0,numelem))
+ x1 = coord(1,iboolori(nxgll-1,0,numelem))
+ z1 = coord(2,iboolori(nxgll-1,0,numelem))
+ x2 = coord(1,iboolori(0,nygll-1,numelem))
+ z2 = coord(2,iboolori(0,nygll-1,numelem))
+ else
+ x0 = coord(1,ibool(0,0,numelem))
+ z0 = coord(2,ibool(0,0,numelem))
+ x1 = coord(1,ibool(nxgll-1,0,numelem))
+ z1 = coord(2,ibool(nxgll-1,0,numelem))
+ x2 = coord(1,ibool(0,nygll-1,numelem))
+ z2 = coord(2,ibool(0,nygll-1,numelem))
+ endif
+
+ rdist1 = dsqrt((x1-x0)**2 + (z1-z0)**2)
+ rdist2 = dsqrt((x2-x0)**2 + (z2-z0)**2)
+
+ rlambmin = cploc/dmax1(rdist1,rdist2)
+ rlambmax = cploc/dmin1(rdist1,rdist2)
+ rlamdaPmin = dmin1(rlamdaPmin,rlambmin)
+ rlamdaPmax = dmax1(rlamdaPmax,rlambmax)
+
+ rlambmin = csloc/dmax1(rdist1,rdist2)
+ rlambmax = csloc/dmin1(rdist1,rdist2)
+ rlamdaSmin = dmin1(rlamdaSmin,rlambmin)
+ rlamdaSmax = dmax1(rlamdaSmax,rlambmax)
+
+ endif
+
+!--- definir tableaux
+ if(.not. anisotrope) then
+ a1(i,j,numelem) = rwx*(rKmod*xix*xix + rmu*xiz*xiz)*rjacob
+ a2(i,j,numelem) = rwx*(rKmod*etax*xix + rmu*etaz*xiz)*rjacob
+ a3(i,j,numelem) = rwx*(rlamda+rmu)*xiz*xix*rjacob
+ a4(i,j,numelem) = rwx*(rlamda*etaz*xix + rmu*etax*xiz)*rjacob
+ a5(i,j,numelem) = rwx*(rKmod*etaz*etaz + rmu*etax*etax)*rjacob
+ a6(i,j,numelem) = rwx*(rKmod*etax*etax + rmu*etaz*etaz)*rjacob
+ a7(i,j,numelem) = rwx*(rlamda*etax*xiz + rmu*etaz*xix)*rjacob
+ a8(i,j,numelem) = rwx*(rlamda+rmu)*etax*etaz*rjacob
+ a9(i,j,numelem) = rwx*(rKmod*xiz*xiz + rmu*xix*xix)*rjacob
+ a10(i,j,numelem) = rwx*(rKmod*etaz*xiz + rmu*etax*xix)*rjacob
+ else
+ a3(i,j,numelem) = rwx*(c13+c44)*xiz*xix*rjacob
+ a4(i,j,numelem) = rwx*(c13*etaz*xix + c44*etax*xiz)*rjacob
+ a7(i,j,numelem) = rwx*(c13*etax*xiz + c44*etaz*xix)*rjacob
+ a8(i,j,numelem) = rwx*(c13+c44)*etax*etaz*rjacob
+
+ a1(i,j,numelem) = rwx*(c11*xix*xix + c44*xiz*xiz)*rjacob
+ a2(i,j,numelem) = rwx*(c11*etax*xix + c44*etaz*xiz)*rjacob
+ a6(i,j,numelem) = rwx*(c11*etax*etax + c44*etaz*etaz)*rjacob
+
+ a5(i,j,numelem) = rwx*(c33*etaz*etaz + c44*etax*etax)*rjacob
+ a9(i,j,numelem) = rwx*(c33*xiz*xiz + c44*xix*xix)*rjacob
+ a10(i,j,numelem) = rwx*(c33*etaz*xiz + c44*etax*xix)*rjacob
+ endif
+
+!--- valeurs pour solution analytique (recuperer deux points de topo)
+ noffsetelem = 20
+ if(numelem == nspec-noffsetelem.and.i == 0.and.j == nygll-1) then
+ cp1 = cploc
+ cs1 = csloc
+ rho1 = denst
+ if(anyperio) then
+ xt1 = coord(1,iboolori(i,j,numelem))
+ zt1 = coord(2,iboolori(i,j,numelem))
+ else
+ xt1 = coord(1,ibool(i,j,numelem))
+ zt1 = coord(2,ibool(i,j,numelem))
+ endif
+ else if(numelem == nspec.and.i == nxgll-1.and. j == nygll-1) then
+ if(anyperio) then
+ xt2 = coord(1,iboolori(i,j,numelem))
+ zt2 = coord(2,iboolori(i,j,numelem))
+ else
+ xt2 = coord(1,ibool(i,j,numelem))
+ zt2 = coord(2,ibool(i,j,numelem))
+ endif
+ else if(numelem == 1) then
+ cp2 = cploc
+ cs2 = csloc
+ rho2 = denst
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ print *
+ print *,'********'
+ print *,'Modele : vitesse P min,max = ',vpmin,vpmax
+ print *,'Modele : vitesse S min,max = ',vsmin,vsmax
+ print *,'Modele : densite min,max = ',densmin,densmax
+ print *,'********'
+ print *
+
+!
+!--- definition coefficients pour bords absorbants
+!
+
+ if(anyabs) then
+
+ do numelem=1,nelemabs
+
+ material = kmato(numabs(numelem))
+
+ rlamda = elastcoef(1,material)
+ rmu = elastcoef(2,material)
+ rKmod = elastcoef(3,material)
+ denst = density(material)
+
+ rKvol = rlamda + 2.d0*rmu/3.d0
+ cploc = dsqrt((rKvol + 4.d0*rmu/3.d0)/denst)
+ csloc = dsqrt(rmu/denst)
+
+ do i=0,nxgll-1
+ do j=0,nygll-1
+
+!--- si formulation heterogene pour un modele de vitesse externe
+ if(ireadmodel) then
+ ipointnum = ibool(i,j,numabs(numelem))
+ cploc = vpext(ipointnum)
+ csloc = vsext(ipointnum)
+ denst = rhoext(ipointnum)
+ rmu = denst*csloc*csloc
+ rlamda = denst*cploc*cploc - 2.d0*rmu
+ rKmod = rlamda + 2.d0*rmu
+ endif
+
+ xix = xjaci(numabs(numelem),1,1,i,j)
+ xiz = xjaci(numabs(numelem),1,2,i,j)
+ etax = xjaci(numabs(numelem),2,1,i,j)
+ etaz = xjaci(numabs(numelem),2,2,i,j)
+ rjacob = dvolu(numabs(numelem),i,j)
+
+ xxi = etaz * rjacob
+ zeta = xix * rjacob
+
+ rwx = - wx(i)*wy(j)
+
+!---- sommer les contributions dans les coins pour l'ancienne formulation
+!---- ne pas sommer les contributions dans les coins pour la nouvelle
+
+! bord absorbant du bas
+ if(codeabs(ibas,numelem) /= 0 .and. j == 0) then
+ coefintegr = wx(i)*xxi
+ a13x(i,j,numelem) = denst*csloc*coefintegr
+ a13z(i,j,numelem) = denst*cploc*coefintegr
+ endif
+
+! bord absorbant du haut (signe moins)
+ if(codeabs(ihaut,numelem) /= 0 .and. j == nygll-1) then
+ coefintegr = wx(i)*xxi
+ a13x(i,j,numelem) = denst*csloc*coefintegr
+ a13z(i,j,numelem) = denst*cploc*coefintegr
+ endif
+
+! bord absorbant de gauche
+ if(codeabs(igauche,numelem) /= 0 .and. i == 0) then
+ coefintegr = wy(j)*zeta
+ a13x(i,j,numelem) = denst*cploc*coefintegr
+ a13z(i,j,numelem) = denst*csloc*coefintegr
+ endif
+
+! bord absorbant de droite
+ if(codeabs(idroite,numelem) /= 0 .and. i == nxgll-1) then
+ coefintegr = wy(j)*zeta
+ a13x(i,j,numelem) = denst*cploc*coefintegr
+ a13z(i,j,numelem) = denst*csloc*coefintegr
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ endif
+
+! pour source explosive
+ do n=1,nltfl
+
+! seulement si source explosive
+ if(nint(gltfu(2,n)) == 2) then
+
+ isourx = nint(gltfu(10,n))
+ isourz = nint(gltfu(11,n))
+ ielems = nint(gltfu(12,n))
+
+ if(isourx == 0.or.isourx == nxgll-1.or.isourz == 0 .or.isourz == nxgll-1) &
+ stop 'Explosive source on element edge'
+
+!---- definir a11 et a12 - dirac (schema en croix)
+
+ xix = xjaci(ielems,1,1,isourx,isourz)
+ xiz = xjaci(ielems,1,2,isourx,isourz)
+ etax = xjaci(ielems,2,1,isourx,isourz)
+ etaz = xjaci(ielems,2,2,isourx,isourz)
+
+ sig0 = one
+
+ do ir=0,nxgll-1
+ flagxprime = hdgll(ir,isourx,xi,nxgll)
+ a11(ir,isourz,n) = a11(ir,isourz,n) + sig0*xix*flagxprime
+ a12(ir,isourz,n) = a12(ir,isourz,n) + sig0*xiz*flagxprime
+ enddo
+
+ do is=0,nygll-1
+ flagzprime = hdgll(is,isourz,yi,nygll)
+ a11(isourx,is,n) = a11(isourx,is,n) + sig0*etax*flagzprime
+ a12(isourx,is,n) = a12(isourx,is,n) + sig0*etaz*flagzprime
+ enddo
+
+ endif
+
+ enddo
+
+!---- compute hprime coefficients (derivatives of Lagrange polynomials)
+!---- (works only if nxgll = nygll)
+ do ip=0,nxgll-1
+ do i=0,nxgll-1
+ hprime(ip,i) = hdgll(ip,i,xi,nxgll)
+ hTprime(i,ip) = hprime(ip,i)
+ enddo
+ enddo
+
+ return
+ end subroutine defarrays
+
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/dirac.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/dirac.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/dirac.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,49 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ double precision function dirac(t,n,gltfu,nltfl)
+
+! calcul du terme temporel de la source pour un Dirac
+
+ use timeparams
+
+ implicit none
+
+ integer nltfl,n
+ double precision t
+ double precision gltfu(20,nltfl)
+
+! "largeur" du dirac (fonction triangle) en nb de pas de temps
+ integer, parameter :: ilength=4
+
+ double precision t0,factor
+
+! parametres pour la source
+ t0 = gltfu(6,n)
+ factor = gltfu(7,n)
+
+! Dirac
+ if(dabs(t-t0) <= deltat*dble(ilength)/2.d0) then
+ if(t <= t0) then
+ dirac = - 2.d0*factor*t/(dble(ilength)*deltat) &
+ + factor*(2.d0*t0/(dble(ilength)*deltat) - 1.d0)
+ else
+ dirac = - 2.d0*factor*t/(dble(-ilength)*deltat) &
+ + factor*(2.d0*t0/(dble(-ilength)*deltat) - 1.d0)
+ endif
+ else
+ dirac = 0.d0
+ endif
+
+ return
+ end function dirac
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/dircty.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/dircty.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/dircty.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,68 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine dircty
+!
+!=======================================================================
+!
+! Dynamic storage allocation :
+! --------------------------
+!
+! Print a directory listing of all dynamically allocated arrays
+! and their properties
+!
+!=======================================================================
+
+ use iounit
+ use arraydir
+
+ implicit none
+
+ integer itotsize,iarray
+ character(len=7) label(3)
+ integer isizevars(3)
+
+! ici codage en dur des tailles des variables en octets
+ isizevars(1) = 4 ! integer
+ isizevars(2) = 4 ! single precision
+ isizevars(3) = 8 ! double precision
+
+ label(1) = 'Integer'
+ label(2) = 'Real '
+ label(3) = 'Double '
+
+! compute total size in bytes
+ itotsize = 0
+ do iarray = 1,nbarrays
+ itotsize = itotsize + arraysizes(iarray)*isizevars(arraytypes(iarray))
+ enddo
+
+ write(iout,100) nbarrays,dble(itotsize)/dble(1024*1024),itotsize, &
+ itotsize/isizevars(3)
+
+ do iarray = 1,nbarrays
+ write(iout,110) iarray,arraysizes(iarray),arraynames(iarray), &
+ label(arraytypes(iarray))
+ enddo
+
+ 100 format(//1x,41('=')/ &
+ ' = D i r e c t o r y l i s t i n g ='/1x,41('=')// &
+ ' Total number of allocated arrays. . . . . . . . . .',i11/ &
+ ' Total size of arrays in megabytes . . . . . . . . .',f11.3/ &
+ ' Total size of arrays in bytes . . . . . . . . . . .',i11/ &
+ ' Total size of arrays in double precision words. . .',i11/// &
+ ' Array nb Size Name Type'/1x,47('=')/)
+ 110 format(i6,3x,i10,5x,a12,2x,a7)
+
+ return
+ end subroutine dircty
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/endw1.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/endw1.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/endw1.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,74 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ double precision function endw1 (n,alpha,beta)
+!
+!=======================================================================
+!
+! E n d w 1 :
+! ---------
+!
+!=======================================================================
+!
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0, &
+ three=3.d0,four=4.d0
+
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+
+ double precision, external :: gammaf
+
+ integer i
+!
+!-----------------------------------------------------------------------
+!
+ f3 = zero
+ apb = alpha+beta
+ if (n == 0) then
+ endw1 = zero
+ return
+ endif
+ f1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if (n == 1) then
+ endw1 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (-two*(beta+two)*fint1 + (apb+four)*fint2) * (apb+three)/four
+ if (n == 2) then
+ endw1 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw1 = f3
+
+ return
+ end function endw1
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/endw2.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/endw2.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/endw2.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,74 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ double precision function endw2 (n,alpha,beta)
+!
+!=======================================================================
+!
+! E n d w 2 :
+! ---------
+!
+!=======================================================================
+!
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0, &
+ three=3.d0,four=4.d0
+
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+
+ double precision, external :: gammaf
+
+ integer i
+
+!
+!-----------------------------------------------------------------------
+!
+ apb = alpha+beta
+ f3 = zero
+ if (n == 0) then
+ endw2 = zero
+ return
+ endif
+ f1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if (n == 1) then
+ endw2 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (two*(alpha+two)*fint1 - (apb+four)*fint2) * (apb+three)/four
+ if (n == 2) then
+ endw2 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw2 = f3
+ return
+ end function endw2
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/ezfftf.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/ezfftf.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/ezfftf.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,558 @@
+
+!
+! Routine de FFT de Netlib, portee en Fortran 90
+!
+
+ SUBROUTINE EZFFTF (N,R,AZERO,A,B,WSAVE)
+
+ implicit real(a-h,o-z)
+ implicit integer(i-n)
+
+ DIMENSION R(*) ,A(1) ,B(1) ,WSAVE(1)
+ IF (N-2 < 0) GOTO 101
+ IF (N-2 == 0) GOTO 102
+ IF (N-2 > 0) GOTO 103
+ 101 AZERO = R(1)
+ RETURN
+ 102 AZERO = .5*(R(1)+R(2))
+ A(1) = .5*(R(1)-R(2))
+ RETURN
+ 103 DO 104 I=1,N
+ WSAVE(I) = R(I)
+ 104 CONTINUE
+ CALL RFFTF (N,WSAVE,WSAVE(N+1))
+ CF = 2./FLOAT(N)
+ CFM = -CF
+ AZERO = .5*CF*WSAVE(1)
+ NS2 = (N+1)/2
+ NS2M = NS2-1
+ DO 105 I=1,NS2M
+ A(I) = CF*WSAVE(2*I)
+ B(I) = CFM*WSAVE(2*I+1)
+ 105 CONTINUE
+ IF (MOD(N,2) == 1) RETURN
+ A(NS2) = .5*CF*WSAVE(N)
+ B(NS2) = 0.
+ RETURN
+ END
+
+ SUBROUTINE RADF2 (IDO,L1,CC,CH,WA1)
+
+ implicit real(a-h,o-z)
+ implicit integer(i-n)
+
+ DIMENSION CH(IDO,2,L1) ,CC(IDO,L1,2) , WA1(1)
+ DO 101 K=1,L1
+ CH(1,1,K) = CC(1,K,1)+CC(1,K,2)
+ CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2)
+ 101 CONTINUE
+ IF (IDO-2 < 0) GOTO 107
+ IF (IDO-2 == 0) GOTO 105
+ IF (IDO-2 > 0) GOTO 102
+ 102 IDP2 = IDO+2
+ DO 104 K=1,L1
+ DO 103 I=3,IDO,2
+ IC = IDP2-I
+ TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ CH(I,1,K) = CC(I,K,1)+TI2
+ CH(IC,2,K) = TI2-CC(I,K,1)
+ CH(I-1,1,K) = CC(I-1,K,1)+TR2
+ CH(IC-1,2,K) = CC(I-1,K,1)-TR2
+ 103 CONTINUE
+ 104 CONTINUE
+ IF (MOD(IDO,2) == 1) RETURN
+ 105 DO 106 K=1,L1
+ CH(1,2,K) = -CC(IDO,K,2)
+ CH(IDO,1,K) = CC(IDO,K,1)
+ 106 CONTINUE
+ 107 RETURN
+ END
+
+ SUBROUTINE RADF3 (IDO,L1,CC,CH,WA1,WA2)
+
+ implicit real(a-h,o-z)
+ implicit integer(i-n)
+
+ DIMENSION CH(IDO,3,L1) ,CC(IDO,L1,3) , WA1(1) ,WA2(1)
+ DATA TAUR,TAUI /-.5,.866025403784439/
+ DO 101 K=1,L1
+ CR2 = CC(1,K,2)+CC(1,K,3)
+ CH(1,1,K) = CC(1,K,1)+CR2
+ CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2))
+ CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2
+ 101 CONTINUE
+ IF (IDO == 1) RETURN
+ IDP2 = IDO+2
+ DO 103 K=1,L1
+ DO 102 I=3,IDO,2
+ IC = IDP2-I
+ DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
+ DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
+ CR2 = DR2+DR3
+ CI2 = DI2+DI3
+ CH(I-1,1,K) = CC(I-1,K,1)+CR2
+ CH(I,1,K) = CC(I,K,1)+CI2
+ TR2 = CC(I-1,K,1)+TAUR*CR2
+ TI2 = CC(I,K,1)+TAUR*CI2
+ TR3 = TAUI*(DI2-DI3)
+ TI3 = TAUI*(DR3-DR2)
+ CH(I-1,3,K) = TR2+TR3
+ CH(IC-1,2,K) = TR2-TR3
+ CH(I,3,K) = TI2+TI3
+ CH(IC,2,K) = TI3-TI2
+ 102 CONTINUE
+ 103 CONTINUE
+ RETURN
+ END
+
+ SUBROUTINE RADF4 (IDO,L1,CC,CH,WA1,WA2,WA3)
+
+ implicit real(a-h,o-z)
+ implicit integer(i-n)
+
+ DIMENSION CC(IDO,L1,4) ,CH(IDO,4,L1) , WA1(1) ,WA2(1) ,WA3(1)
+ DATA HSQT2 /.7071067811865475/
+ DO 101 K=1,L1
+ TR1 = CC(1,K,2)+CC(1,K,4)
+ TR2 = CC(1,K,1)+CC(1,K,3)
+ CH(1,1,K) = TR1+TR2
+ CH(IDO,4,K) = TR2-TR1
+ CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3)
+ CH(1,3,K) = CC(1,K,4)-CC(1,K,2)
+ 101 CONTINUE
+ IF (IDO-2 < 0) GOTO 107
+ IF (IDO-2 == 0) GOTO 105
+ IF (IDO-2 > 0) GOTO 102
+ 102 IDP2 = IDO+2
+ DO 104 K=1,L1
+ DO 103 I=3,IDO,2
+ IC = IDP2-I
+ CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
+ CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
+ CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
+ CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
+ TR1 = CR2+CR4
+ TR4 = CR4-CR2
+ TI1 = CI2+CI4
+ TI4 = CI2-CI4
+ TI2 = CC(I,K,1)+CI3
+ TI3 = CC(I,K,1)-CI3
+ TR2 = CC(I-1,K,1)+CR3
+ TR3 = CC(I-1,K,1)-CR3
+ CH(I-1,1,K) = TR1+TR2
+ CH(IC-1,4,K) = TR2-TR1
+ CH(I,1,K) = TI1+TI2
+ CH(IC,4,K) = TI1-TI2
+ CH(I-1,3,K) = TI4+TR3
+ CH(IC-1,2,K) = TR3-TI4
+ CH(I,3,K) = TR4+TI3
+ CH(IC,2,K) = TR4-TI3
+ 103 CONTINUE
+ 104 CONTINUE
+ IF (MOD(IDO,2) == 1) RETURN
+ 105 CONTINUE
+ DO 106 K=1,L1
+ TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4))
+ TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4))
+ CH(IDO,1,K) = TR1+CC(IDO,K,1)
+ CH(IDO,3,K) = CC(IDO,K,1)-TR1
+ CH(1,2,K) = TI1-CC(IDO,K,3)
+ CH(1,4,K) = TI1+CC(IDO,K,3)
+ 106 CONTINUE
+ 107 RETURN
+ END
+
+ SUBROUTINE RADF5 (IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
+
+ implicit real(a-h,o-z)
+ implicit integer(i-n)
+
+ DIMENSION CC(IDO,L1,5) ,CH(IDO,5,L1) , WA1(1) ,WA2(1) ,WA3(1) ,WA4(1)
+ DATA TR11,TI11,TR12,TI12 /.309016994374947,.951056516295154, &
+ -.809016994374947,.587785252292473/
+ DO 101 K=1,L1
+ CR2 = CC(1,K,5)+CC(1,K,2)
+ CI5 = CC(1,K,5)-CC(1,K,2)
+ CR3 = CC(1,K,4)+CC(1,K,3)
+ CI4 = CC(1,K,4)-CC(1,K,3)
+ CH(1,1,K) = CC(1,K,1)+CR2+CR3
+ CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3
+ CH(1,3,K) = TI11*CI5+TI12*CI4
+ CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3
+ CH(1,5,K) = TI12*CI5-TI11*CI4
+ 101 CONTINUE
+ IF (IDO == 1) RETURN
+ IDP2 = IDO+2
+ DO 103 K=1,L1
+ DO 102 I=3,IDO,2
+ IC = IDP2-I
+ DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
+ DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
+ DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
+ DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
+ DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
+ DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
+ DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5)
+ DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5)
+ CR2 = DR2+DR5
+ CI5 = DR5-DR2
+ CR5 = DI2-DI5
+ CI2 = DI2+DI5
+ CR3 = DR3+DR4
+ CI4 = DR4-DR3
+ CR4 = DI3-DI4
+ CI3 = DI3+DI4
+ CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3
+ CH(I,1,K) = CC(I,K,1)+CI2+CI3
+ TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3
+ TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3
+ TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3
+ TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3
+ TR5 = TI11*CR5+TI12*CR4
+ TI5 = TI11*CI5+TI12*CI4
+ TR4 = TI12*CR5-TI11*CR4
+ TI4 = TI12*CI5-TI11*CI4
+ CH(I-1,3,K) = TR2+TR5
+ CH(IC-1,2,K) = TR2-TR5
+ CH(I,3,K) = TI2+TI5
+ CH(IC,2,K) = TI5-TI2
+ CH(I-1,5,K) = TR3+TR4
+ CH(IC-1,4,K) = TR3-TR4
+ CH(I,5,K) = TI3+TI4
+ CH(IC,4,K) = TI4-TI3
+ 102 CONTINUE
+ 103 CONTINUE
+ RETURN
+ END
+
+ SUBROUTINE RADFG (IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
+
+ implicit real(a-h,o-z)
+ implicit integer(i-n)
+
+ DIMENSION CH(IDO,L1,IP) ,CC(IDO,IP,L1) , &
+ C1(IDO,L1,IP) ,C2(IDL1,IP), &
+ CH2(IDL1,IP) ,WA(1)
+ DATA TPI/6.28318530717959/
+ ARG = TPI/FLOAT(IP)
+ DCP = COS(ARG)
+ DSP = SIN(ARG)
+ IPPH = (IP+1)/2
+ IPP2 = IP+2
+ IDP2 = IDO+2
+ NBD = (IDO-1)/2
+ IF (IDO == 1) GO TO 119
+ DO 101 IK=1,IDL1
+ CH2(IK,1) = C2(IK,1)
+ 101 CONTINUE
+ DO 103 J=2,IP
+ DO 102 K=1,L1
+ CH(1,K,J) = C1(1,K,J)
+ 102 CONTINUE
+ 103 CONTINUE
+ IF (NBD > L1) GO TO 107
+ IS = -IDO
+ DO 106 J=2,IP
+ IS = IS+IDO
+ IDIJ = IS
+ DO 105 I=3,IDO,2
+ IDIJ = IDIJ+2
+ DO 104 K=1,L1
+ CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
+ CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
+ 104 CONTINUE
+ 105 CONTINUE
+ 106 CONTINUE
+ GO TO 111
+ 107 IS = -IDO
+ DO 110 J=2,IP
+ IS = IS+IDO
+ DO 109 K=1,L1
+ IDIJ = IS
+ DO 108 I=3,IDO,2
+ IDIJ = IDIJ+2
+ CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
+ CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
+ 108 CONTINUE
+ 109 CONTINUE
+ 110 CONTINUE
+ 111 IF (NBD < L1) GO TO 115
+ DO 114 J=2,IPPH
+ JC = IPP2-J
+ DO 113 K=1,L1
+ DO 112 I=3,IDO,2
+ C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
+ C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
+ C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
+ C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
+ 112 CONTINUE
+ 113 CONTINUE
+ 114 CONTINUE
+ GO TO 121
+ 115 DO 118 J=2,IPPH
+ JC = IPP2-J
+ DO 117 I=3,IDO,2
+ DO 116 K=1,L1
+ C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
+ C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
+ C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
+ C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
+ 116 CONTINUE
+ 117 CONTINUE
+ 118 CONTINUE
+ GO TO 121
+ 119 DO 120 IK=1,IDL1
+ C2(IK,1) = CH2(IK,1)
+ 120 CONTINUE
+ 121 DO 123 J=2,IPPH
+ JC = IPP2-J
+ DO 122 K=1,L1
+ C1(1,K,J) = CH(1,K,J)+CH(1,K,JC)
+ C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J)
+ 122 CONTINUE
+ 123 CONTINUE
+
+ AR1 = 1.
+ AI1 = 0.
+ DO 127 L=2,IPPH
+ LC = IPP2-L
+ AR1H = DCP*AR1-DSP*AI1
+ AI1 = DCP*AI1+DSP*AR1
+ AR1 = AR1H
+ DO 124 IK=1,IDL1
+ CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2)
+ CH2(IK,LC) = AI1*C2(IK,IP)
+ 124 CONTINUE
+ DC2 = AR1
+ DS2 = AI1
+ AR2 = AR1
+ AI2 = AI1
+ DO 126 J=3,IPPH
+ JC = IPP2-J
+ AR2H = DC2*AR2-DS2*AI2
+ AI2 = DC2*AI2+DS2*AR2
+ AR2 = AR2H
+ DO 125 IK=1,IDL1
+ CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J)
+ CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC)
+ 125 CONTINUE
+ 126 CONTINUE
+ 127 CONTINUE
+ DO 129 J=2,IPPH
+ DO 128 IK=1,IDL1
+ CH2(IK,1) = CH2(IK,1)+C2(IK,J)
+ 128 CONTINUE
+ 129 CONTINUE
+
+ IF (IDO < L1) GO TO 132
+ DO 131 K=1,L1
+ DO 130 I=1,IDO
+ CC(I,1,K) = CH(I,K,1)
+ 130 CONTINUE
+ 131 CONTINUE
+ GO TO 135
+ 132 DO 134 I=1,IDO
+ DO 133 K=1,L1
+ CC(I,1,K) = CH(I,K,1)
+ 133 CONTINUE
+ 134 CONTINUE
+ 135 DO 137 J=2,IPPH
+ JC = IPP2-J
+ J2 = J+J
+ DO 136 K=1,L1
+ CC(IDO,J2-2,K) = CH(1,K,J)
+ CC(1,J2-1,K) = CH(1,K,JC)
+ 136 CONTINUE
+ 137 CONTINUE
+ IF (IDO == 1) RETURN
+ IF (NBD < L1) GO TO 141
+ DO 140 J=2,IPPH
+ JC = IPP2-J
+ J2 = J+J
+ DO 139 K=1,L1
+ DO 138 I=3,IDO,2
+ IC = IDP2-I
+ CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
+ CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
+ CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
+ CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
+ 138 CONTINUE
+ 139 CONTINUE
+ 140 CONTINUE
+ RETURN
+ 141 DO 144 J=2,IPPH
+ JC = IPP2-J
+ J2 = J+J
+ DO 143 I=3,IDO,2
+ IC = IDP2-I
+ DO 142 K=1,L1
+ CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
+ CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
+ CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
+ CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
+ 142 CONTINUE
+ 143 CONTINUE
+ 144 CONTINUE
+ RETURN
+ END
+
+ SUBROUTINE RFFTF (N,R,WSAVE)
+
+ implicit real(a-h,o-z)
+ implicit integer(i-n)
+
+ DIMENSION R(*) ,WSAVE(1)
+ IF (N == 1) RETURN
+ CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))
+ RETURN
+ END
+
+ SUBROUTINE RFFTF1 (N,C,CH,WA,IFAC)
+
+ implicit real(a-h,o-z)
+ implicit integer(i-n)
+
+ DIMENSION CH(1) ,C(1) ,WA(1) ,IFAC(*)
+ NF = IFAC(2)
+ NA = 1
+ L2 = N
+ IW = N
+ DO 111 K1=1,NF
+ KH = NF-K1
+ IP = IFAC(KH+3)
+ L1 = L2/IP
+ IDO = N/L2
+ IDL1 = IDO*L1
+ IW = IW-(IP-1)*IDO
+ NA = 1-NA
+ IF (IP /= 4) GO TO 102
+ IX2 = IW+IDO
+ IX3 = IX2+IDO
+ IF (NA /= 0) GO TO 101
+ CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
+ GO TO 110
+ 101 CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
+ GO TO 110
+ 102 IF (IP /= 2) GO TO 104
+ IF (NA /= 0) GO TO 103
+ CALL RADF2 (IDO,L1,C,CH,WA(IW))
+ GO TO 110
+ 103 CALL RADF2 (IDO,L1,CH,C,WA(IW))
+ GO TO 110
+ 104 IF (IP /= 3) GO TO 106
+ IX2 = IW+IDO
+ IF (NA /= 0) GO TO 105
+ CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2))
+ GO TO 110
+ 105 CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2))
+ GO TO 110
+ 106 IF (IP /= 5) GO TO 108
+ IX2 = IW+IDO
+ IX3 = IX2+IDO
+ IX4 = IX3+IDO
+ IF (NA /= 0) GO TO 107
+ CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
+ GO TO 110
+ 107 CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
+ GO TO 110
+ 108 IF (IDO == 1) NA = 1-NA
+ IF (NA /= 0) GO TO 109
+ CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
+ NA = 1
+ GO TO 110
+ 109 CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
+ NA = 0
+ 110 L2 = L1
+ 111 CONTINUE
+ IF (NA == 1) RETURN
+ DO 112 I=1,N
+ C(I) = CH(I)
+ 112 CONTINUE
+ RETURN
+ END
+
+ SUBROUTINE EZFFTI (N,WSAVE)
+
+ implicit real(a-h,o-z)
+ implicit integer(i-n)
+
+ DIMENSION WSAVE(1)
+ IF (N == 1) RETURN
+ CALL EZFFT1 (N,WSAVE(2*N+1),WSAVE(3*N+1))
+ RETURN
+ END
+
+ SUBROUTINE EZFFT1 (N,WA,IFAC)
+
+ implicit real(a-h,o-z)
+ implicit integer(i-n)
+
+ DIMENSION WA(1) ,IFAC(*) ,NTRYH(4)
+ DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ ,TPI/6.28318530717959/
+ NTRY = 0
+ NL = N
+ NF = 0
+ J = 0
+ 101 J = J+1
+ IF (J-4 <= 0) GOTO 102
+ IF (J-4 > 0) GOTO 103
+ 102 NTRY = NTRYH(J)
+ GO TO 104
+ 103 NTRY = NTRY+2
+ 104 NQ = NL/NTRY
+ NR = NL-NTRY*NQ
+ IF (NR < 0) GOTO 101
+ IF (NR == 0) GOTO 105
+ IF (NR > 0) GOTO 101
+ 105 NF = NF+1
+ IFAC(NF+2) = NTRY
+ NL = NQ
+ IF (NTRY /= 2) GO TO 107
+ IF (NF == 1) GO TO 107
+ DO 106 I=2,NF
+ IB = NF-I+2
+ IFAC(IB+2) = IFAC(IB+1)
+ 106 CONTINUE
+ IFAC(3) = 2
+ 107 IF (NL /= 1) GO TO 104
+ IFAC(1) = N
+ IFAC(2) = NF
+ ARGH = TPI/FLOAT(N)
+ IS = 0
+ NFM1 = NF-1
+ L1 = 1
+ IF (NFM1 == 0) RETURN
+ DO 111 K1=1,NFM1
+ IP = IFAC(K1+2)
+ L2 = L1*IP
+ IDO = N/L2
+ IPM = IP-1
+ ARG1 = FLOAT(L1)*ARGH
+ CH1 = 1.
+ SH1 = 0.
+ DCH1 = COS(ARG1)
+ DSH1 = SIN(ARG1)
+ DO 110 J=1,IPM
+ CH1H = DCH1*CH1-DSH1*SH1
+ SH1 = DCH1*SH1+DSH1*CH1
+ CH1 = CH1H
+ I = IS+2
+ WA(I-1) = CH1
+ WA(I) = SH1
+ IF (IDO < 5) GO TO 109
+ DO 108 II=5,IDO,2
+ I = I+2
+ WA(I-1) = CH1*WA(I-3)-SH1*WA(I-2)
+ WA(I) = CH1*WA(I-2)+SH1*WA(I-3)
+ 108 CONTINUE
+ 109 IS = IS+IDO
+ 110 CONTINUE
+ L1 = L2
+ 111 CONTINUE
+ RETURN
+ END
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/gammaf.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/gammaf.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/gammaf.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,46 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ double precision function gammaf (x)
+!
+!=======================================================================
+!
+! G a m m a f :
+! -----------
+!
+!=======================================================================
+!
+ use defpi
+
+ implicit none
+
+ double precision x
+
+ double precision, parameter :: half=0.5d0,one=1.d0,two=2.d0
+
+ gammaf = one
+
+ if (x == -half) gammaf = -two*dsqrt(pi)
+ if (x == half) gammaf = dsqrt(pi)
+ if (x == one ) gammaf = one
+ if (x == two ) gammaf = one
+ if (x == 1.5d0) gammaf = dsqrt(pi)/2.d0
+ if (x == 2.5d0) gammaf = 1.5d0*dsqrt(pi)/2.d0
+ if (x == 3.5d0) gammaf = 2.5d0*1.5d0*dsqrt(pi)/2.d0
+ if (x == 3.d0 ) gammaf = 2.d0
+ if (x == 4.d0 ) gammaf = 6.d0
+ if (x == 5.d0 ) gammaf = 24.d0
+ if (x == 6.d0 ) gammaf = 120.d0
+
+ return
+ end function gammaf
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/getelspec.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/getelspec.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/getelspec.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,180 @@
+
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine getelspec(knods,ibool,kmato,npoin,numabs,codeabs,codeperio,anyabs,anyperio)
+!
+!=======================================================================
+!
+! "g e t e l s p e c": Read elements topology and material set for
+! spectral elements bloc
+!
+!=======================================================================
+!
+
+ use iounit
+ use infos
+ use spela202
+ use codebord
+
+ implicit none
+
+ character(len=80) datlin
+
+ integer knods(ngnod,nspec),ibool(nxgll,nygll,nspec),kmato(nspec)
+ integer npoin
+ integer numabs(nelemabs),codeabs(4,nelemabs)
+ integer codeperio(4,nelemperio)
+ logical anyabs,anyperio
+
+ integer ie,n,i,k
+ integer inum,itourne,ntourne,nperio,idummy,numabsread
+
+ integer codeabsread(4),codeperioread(4)
+
+!
+!-----------------------------------------------------------------------
+!
+
+!
+!---- read spectral macroblocs data
+!
+ n = 0
+ read(iin,40) datlin
+ do ie = 1,nspec
+ read(iin,*) n,kmato(n),(knods(k,n), k=1,ngnod)
+ enddo
+
+!
+!---- check the input
+!
+ if(iecho == 2) then
+ do ie = 1,nspec
+ if(mod(ie,50) == 1) write(iout,150) (i, i=1,ngnod)
+ write(iout,200) ie,kmato(ie),(knods(k,ie), k=1,ngnod)
+ enddo
+ endif
+
+!
+!---- lire bords absorbants et bords periodiques
+!
+ if(anyperio) then
+ read(iin ,40) datlin
+ do n=1,nelemperio
+ read(iin ,*) inum,codeperioread(1), &
+ codeperioread(2),codeperioread(3),codeperioread(4)
+ if(inum < 1 .or. inum > nelemperio) stop 'Wrong periodic element number'
+ codeperio(1,inum) = codeperioread(1)
+ codeperio(2,inum) = codeperioread(2)
+ codeperio(3,inum) = codeperioread(3)
+ codeperio(4,inum) = codeperioread(4)
+ enddo
+ write(*,*)
+ write(*,*) 'Number of periodic elements : ',nelemperio
+ endif
+
+ if(anyabs) then
+ read(iin ,40) datlin
+ do n=1,nelemabs
+ read(iin ,*) inum,numabsread,codeabsread(1), &
+ codeabsread(2),codeabsread(3),codeabsread(4)
+ if(inum < 1 .or. inum > nelemabs) stop 'Wrong absorbing element number'
+ numabs(inum) = numabsread
+ codeabs(ihaut,inum) = codeabsread(1)
+ codeabs(ibas,inum) = codeabsread(2)
+ codeabs(igauche,inum) = codeabsread(3)
+ codeabs(idroite,inum) = codeabsread(4)
+
+!---- eventuellement tourner element counterclockwise si condition absorbante
+
+ if(codeabs(ibas,inum) == iaretebas .or. &
+ codeabs(ihaut,inum) == iaretehaut .or. &
+ codeabs(igauche,inum) == iaretegauche .or. &
+ codeabs(idroite,inum) == iaretedroite) then
+ ntourne = 0
+
+ else if(codeabs(ibas,inum) == iaretegauche .or. &
+ codeabs(ihaut,inum) == iaretedroite .or. &
+ codeabs(igauche,inum) == iaretehaut .or. &
+ codeabs(idroite,inum) == iaretebas) then
+ ntourne = 3
+
+ else if(codeabs(ibas,inum) == iaretehaut .or. &
+ codeabs(ihaut,inum) == iaretebas .or. &
+ codeabs(igauche,inum) == iaretedroite .or. &
+ codeabs(idroite,inum) == iaretegauche) then
+ ntourne = 2
+
+ else if(codeabs(ibas,inum) == iaretedroite .or. &
+ codeabs(ihaut,inum) == iaretegauche .or. &
+ codeabs(igauche,inum) == iaretebas .or. &
+ codeabs(idroite,inum) == iaretehaut) then
+ ntourne = 1
+ else
+ stop 'Error in absorbing conditions numbering'
+
+ endif
+
+!---- rotate element counterclockwise
+ if(ntourne /= 0) then
+
+ do itourne = 1,ntourne
+
+ idummy = knods(1,numabs(inum))
+ knods(1,numabs(inum)) = knods(2,numabs(inum))
+ knods(2,numabs(inum)) = knods(3,numabs(inum))
+ knods(3,numabs(inum)) = knods(4,numabs(inum))
+ knods(4,numabs(inum)) = idummy
+
+ if(ngnod == 9) then
+ idummy = knods(5,numabs(inum))
+ knods(5,numabs(inum)) = knods(6,numabs(inum))
+ knods(6,numabs(inum)) = knods(7,numabs(inum))
+ knods(7,numabs(inum)) = knods(8,numabs(inum))
+ knods(8,numabs(inum)) = idummy
+ endif
+
+!---- tourner aussi le numero d'arete pour condition periodique si necessaire
+ if(anyperio) then
+ do nperio=1,nelemperio
+ if(codeperio(1,nperio) == numabs(inum)) then
+ codeperio(2,nperio) = codeperio(2,nperio) - 1
+ if(codeperio(2,nperio) == 0) codeperio(2,nperio) = 4
+ endif
+ if(codeperio(3,nperio) == numabs(inum)) then
+ codeperio(4,nperio) = codeperio(4,nperio) - 1
+ if(codeperio(4,nperio) == 0) codeperio(4,nperio) = 4
+ endif
+ enddo
+ endif
+
+ enddo
+
+ endif
+
+ enddo
+ write(*,*)
+ write(*,*) 'Number of absorbing elements : ',nelemabs
+ endif
+
+ return
+!
+!---- formats
+!
+ 40 format(a80)
+ 150 format(///' S p e c t r a l m a c r o b l o c s t o p o l o g y'/1x, &
+ 55('='),//5x,'macrobloc material',9(' node ',i1,:,2x),/5x, &
+ 'number number',//)
+ 200 format(4x,i7,9(3x,i7))
+
+ end subroutine getelspec
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/getltf.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/getltf.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/getltf.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,112 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine getltf(gltfu,nltfl,initialfield)
+!
+!=======================================================================
+!
+! "g e t l t f" : Read and store source functions
+!
+!=======================================================================
+!
+ use iounit
+ use infos
+ use defpi
+
+ implicit none
+
+ character(len=80) datlin
+ character(len=20) funcname(10)
+
+!
+!-----------------------------------------------------------------------
+!
+ integer nltfl
+ double precision gltfu(20,nltfl)
+ logical initialfield
+
+ integer n,isource,iexplo,k
+
+ funcname(1) = ' '
+ funcname(2) = ' '
+ funcname(3) = ' '
+ funcname(4) = 'Gaussian'
+ funcname(5) = 'First derivative of a Gaussian'
+ funcname(6) = 'Ricker'
+ funcname(7) = 'Dirac'
+
+!
+!---- read load function parameters
+!
+ read(iin ,40) datlin
+
+ do n = 1,nltfl
+ read(iin ,*) (gltfu(k,n), k=1,9)
+ enddo
+
+!
+!----- check the input
+!
+ if(iecho /= 0 .and. .not. initialfield) then
+ do n = 1,nltfl
+ if((nint(gltfu(1,n)) < 4).or.(nint(gltfu(1,n)) > 7)) &
+ stop 'Wrong function number in getltf !'
+ if(mod(n,50) == 1) write(iout,100) nltfl
+ isource = nint(gltfu(1,n))
+ iexplo = nint(gltfu(2,n))
+ if (iexplo == 1) then
+ write(iout,210) funcname(isource),(gltfu(k,n), k=3,8)
+ else if(iexplo == 2) then
+ write(iout,220) funcname(isource),(gltfu(k,n), k=3,7)
+ else
+ stop 'Unknown source type number !'
+ endif
+ enddo
+ endif
+!
+!----- convert angle from degrees to radians
+!
+ do n = 1,nltfl
+ isource = nint(gltfu(1,n))
+ iexplo = nint(gltfu(2,n))
+ if(isource >= 4.and.isource <= 6.and.iexplo == 1) then
+ gltfu(8,n) = gltfu(8,n) * pi / 180.d0
+ endif
+ enddo
+
+ return
+!
+!---- formats
+!
+ 40 format(a80)
+ 100 format(//,' S o u r c e F u n c t i o n',/1x,28('='),//5x, &
+ 'Number of source functions. . . . . . . . (nltfl) =',i5)
+ 210 format(//,5x, &
+ 'Source Type. . . . . . . . . . . . . . = Collocated Force',/5x, &
+ 'Function Type. . . . . . . . . . . . . =',1x,a,/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)
+ 220 format(//,5x, &
+ 'Source Type. . . . . . . . . . . . . . = Explosion',/5x, &
+ 'Function Type. . . . . . . . . . . . . =',1x,a,/5x, &
+ 'X-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Y-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Fundamental frequency (Hz) . . . . . . =',1pe20.10,/5x, &
+ 'Time delay (s) . . . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Multiplying factor . . . . . . . . . . =',1pe20.10,/5x)
+
+ end subroutine getltf
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/getrecepts.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/getrecepts.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/getrecepts.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,52 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine getrecepts(posrec,ndime,nrec)
+!
+!=======================================================================
+!
+! "getrecepts" : lecture position recepteurs
+!
+!=======================================================================
+!
+ use iounit
+ use infos
+
+ implicit none
+
+ integer ndime,nrec
+ double precision posrec(ndime,nrec)
+
+ double precision, dimension(:), allocatable :: posrecread
+
+ integer i,j,irec
+ character(len=80) datlin
+
+!
+!---- read receivers position
+!
+ irec = 0
+ read(iin ,40) datlin
+ allocate(posrecread(ndime))
+ do i=1,nrec
+ read(iin ,*) irec,(posrecread(j),j=1,ndime)
+ if(irec<1 .or. irec>nrec) stop 'Wrong receiver number'
+ posrec(:,irec) = posrecread
+ enddo
+ deallocate(posrecread)
+
+ return
+
+ 40 format(a80)
+
+ end subroutine getrecepts
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/getspec.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/getspec.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/getspec.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,68 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine getspec(coorg,npgeo,ndime)
+!
+!=======================================================================
+!
+! "g e t s p e c" : Read spectral macroblocs nodal coordinates
+!
+!=======================================================================
+!
+ use iounit
+ use infos
+ use label1
+
+ implicit none
+
+ integer ndime,npgeo
+ double precision coorg(ndime,npgeo)
+
+ double precision, dimension(:), allocatable :: coorgread
+
+ integer ip,ipoin,n,i,id
+ character(len=80) datlin
+
+!
+!----
+!
+ ipoin = 0
+ read(iin,40) datlin
+ allocate(coorgread(ndime))
+ do ip = 1,npgeo
+ read(iin,*) ipoin,(coorgread(id),id =1,ndime)
+ if(ipoin<1 .or. ipoin>npgeo) stop 'Wrong control point number'
+ coorg(:,ipoin) = coorgread
+ enddo
+ deallocate(coorgread)
+
+!
+!---- check the input
+!
+ if(iecho == 2) then
+ do n = 1,npgeo
+ if(mod(n,50) == 1) write(iout,100) (labelc(i),i=1,ndime)
+ write(iout,200) n, (coorg(i,n), i=1,ndime)
+ enddo
+ endif
+
+ return
+!
+!---- formats
+!
+ 40 format(a80)
+ 100 format(///' S p e c t r a l c o n t r o l p o i n t s'/1x, &
+ 45('=')///,4x,' node number ',10x,2(a5,12x))
+ 200 format(6x,i5,10x,3(1pe15.8,2x))
+!
+ end subroutine getspec
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/gmat01.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/gmat01.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/gmat01.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,167 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine gmat01(density,elastcoef,numat)
+!
+!=======================================================================
+!
+! "g m a t 0 1" : Read properties of a two-dimensional
+! isotropic or anisotropic linear elastic element
+!
+!=======================================================================
+!
+ use iounit
+ use infos
+
+ implicit none
+
+ double precision, parameter :: zero=0.d0,half=0.5d0,one=1.0d0,two=2.0d0
+
+ character(len=80) datlin
+ double precision Kmod,Kvol
+
+ integer numat
+ double precision density(numat),elastcoef(4,numat)
+
+ integer in,n,indic
+ double precision young,poiss,denst,cp,cs,amu,a2mu,alam
+ double precision val1,val2,val3,val4
+ double precision c11,c13,c33,c44
+!
+!-----------------------------------------------------------------------
+!
+ density(:) = zero
+ elastcoef(:,:) = zero
+
+!
+!---- loop over the different material sets
+!
+ if(iecho /= 0) write(iout,100) numat
+
+ read(iin ,40) datlin
+ do in = 1,numat
+
+ read(iin ,*) n,indic,denst,val1,val2,val3,val4
+
+ if(n<1 .or. n>numat) stop 'Wrong material set number'
+
+!---- materiau isotrope, vitesse P et vitesse S donnees
+ if(indic == 0) then
+ cp = val1
+ cs = val2
+ amu = denst*cs*cs
+ a2mu = 2.d0*amu
+ alam = denst*cp*cp - a2mu
+ Kmod = alam + a2mu
+ Kvol = alam + a2mu/3.d0
+ young = 9.d0*Kvol*amu/(3.d0*Kvol + amu)
+ poiss = half*(3.d0*Kvol-a2mu)/(3.d0*Kvol+amu)
+ if (poiss < 0.d0 .or. poiss >= 0.50001d0) &
+ stop 'Poisson''s ratio out of range !'
+
+!---- materiau isotrope, module de Young et coefficient de Poisson donnes
+ else if(indic == 1) then
+ young = val1
+ poiss = val2
+ if (poiss < 0.d0 .or. poiss >= 0.50001d0) &
+ stop 'Poisson''s ratio out of range !'
+ a2mu = young/(one+poiss)
+ amu = half*a2mu
+ alam = a2mu*poiss/(one-two*poiss)
+ Kmod = alam + a2mu
+ Kvol = alam + a2mu/3.d0
+ cp = dsqrt((Kvol + 4.d0*amu/3.d0)/denst)
+ cs = dsqrt(amu/denst)
+
+!---- materiau anisotrope, c11, c13, c33 et c44 donnes en Pascal
+ else if(indic == 2) then
+ c11 = val1
+ c13 = val2
+ c33 = val3
+ c44 = val4
+
+ else
+ stop 'Improper value while reading material sets'
+ endif
+
+!
+!---- set elastic coefficients and density
+!
+! Isotropic : lambda, mu, K (= lambda + 2*mu), zero
+! Transverse anisotropic : c11, c13, c33, c44
+!
+ if(indic == 0 .or. indic == 1) then
+ elastcoef(1,n) = alam
+ elastcoef(2,n) = amu
+ elastcoef(3,n) = Kmod
+ elastcoef(4,n) = zero
+ else
+ elastcoef(1,n) = c11
+ elastcoef(2,n) = c13
+ elastcoef(3,n) = c33
+ elastcoef(4,n) = c44
+ endif
+
+ density(n) = denst
+
+!
+!---- check the input
+!
+ if(iecho /= 0) then
+ if(indic == 0 .or. indic == 1) then
+ write(iout,200) n,cp,cs,denst,poiss,alam,amu,Kvol,young
+ else
+ write(iout,300) n,c11,c13,c33,c44,denst, &
+ sqrt(c33/denst),sqrt(c11/denst),sqrt(c44/denst),sqrt(c44/denst)
+
+ endif
+ endif
+
+ enddo
+
+ return
+!
+!---- formats
+!
+ 40 format(a80)
+ 100 format(//,' M a t e r i a l s e t s : ', &
+ ' 2 D e l a s t i c i t y', &
+ /1x,54('='),//5x, &
+ 'Number of material sets . . . . . . (numat) =',i5)
+ 200 format(//5x,'------------------------',/5x, &
+ '-- Isotropic material --',/5x, &
+ '------------------------',/5x, &
+ 'Material set number. . . . . . . . (jmat) =',i5,/5x, &
+ 'P-wave velocity. . . . . . . . . . . (cp) =',1pe15.8,/5x, &
+ 'S-wave velocity. . . . . . . . . . . (cs) =',1pe15.8,/5x, &
+ 'Mass density. . . . . . . . . . . (denst) =',1pe15.8,/5x, &
+ 'Poisson''s ratio . . . . . . . . . (poiss) =',1pe15.8,/5x, &
+ 'First Lame parameter Lambda. . . . (alam) =',1pe15.8,/5x, &
+ 'Second Lame parameter Mu. . . . . . (amu) =',1pe15.8,/5x, &
+ 'Bulk modulus K . . . . . . . . . . (Kvol) =',1pe15.8,/5x, &
+ 'Young''s modulus E . . . . . . . . (young) =',1pe15.8)
+ 300 format(//5x,'-------------------------------------',/5x, &
+ '-- Transverse anisotropic material --',/5x, &
+ '-------------------------------------',/5x, &
+ 'Material set number. . . . . . . . (jmat) =',i5,/5x, &
+ 'c11 coefficient (Pascal). . . . . . (c11) =',1pe15.8,/5x, &
+ 'c13 coefficient (Pascal). . . . . . (c13) =',1pe15.8,/5x, &
+ 'c33 coefficient (Pascal). . . . . . (c33) =',1pe15.8,/5x, &
+ 'c44 coefficient (Pascal). . . . . . (c44) =',1pe15.8,/5x, &
+ 'Mass density. . . . . . . . . . . (denst) =',1pe15.8,/5x, &
+ 'Velocity of qP along vertical axis. . . . =',1pe15.8,/5x, &
+ 'Velocity of qP along horizontal axis. . . =',1pe15.8,/5x, &
+ 'Velocity of qSV along vertical axis . . . =',1pe15.8,/5x, &
+ 'Velocity of qSV along horizontal axis . . =',1pe15.8)
+
+ end subroutine gmat01
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/hdgll.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/hdgll.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/hdgll.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,51 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ double precision FUNCTION HDGLL (I,j,ZGLL,NZ)
+!-------------------------------------------------------------
+!
+! Compute the value of the derivative of the I-th
+! Lagrangian interpolant through the
+! NZ Gauss-Lobatto Legendre points ZGLL at point ZGLL(j).
+!
+!-------------------------------------------------------------
+
+ implicit none
+
+ integer i,j,nz
+ double precision zgll(0:nz-1)
+
+ integer idegpoly
+ double precision rlegendre1,rlegendre2,rlegendre3
+
+ double precision, external :: pnleg,pndleg
+
+ idegpoly = nz - 1
+ if ((i == 0).and.(j == 0)) then
+ hdgll = - dble(idegpoly)*(dble(idegpoly)+1.d0)/4.d0
+ else if ((i == idegpoly).and.(j == idegpoly)) then
+ hdgll = dble(idegpoly)*(dble(idegpoly)+1.d0)/4.d0
+ else if (i == j) then
+ hdgll = 0.d0
+ else
+ rlegendre1 = pnleg(zgll(j),idegpoly)
+ rlegendre2 = pndleg(zgll(j),idegpoly)
+ rlegendre3 = pnleg(zgll(i),idegpoly)
+ hdgll = rlegendre1 / (rlegendre3*(zgll(j)-zgll(i))) &
+ + (1.d0-zgll(j)*zgll(j))*rlegendre2/(dble(idegpoly)* &
+ (dble(idegpoly)+1.d0)*rlegendre3* &
+ (zgll(j)-zgll(i))*(zgll(j)-zgll(i)))
+ endif
+
+ return
+ end FUNCTION hdgll
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/hgll.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/hgll.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/hgll.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,42 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ double precision FUNCTION HGLL (I,Z,ZGLL,NZ)
+!-------------------------------------------------------------
+!
+! Compute the value of the Lagrangian interpolant L through
+! the NZ Gauss-Lobatto Legendre points ZGLL at the point Z.
+!
+!-------------------------------------------------------------
+
+ implicit none
+
+ integer i,nz
+ double precision z
+ double precision ZGLL(0:nz-1)
+
+ integer n
+ double precision EPS,DZ,ALFAN
+ double precision, external :: PNLEG,PNDLEG
+
+ EPS = 1.d-5
+ DZ = Z - ZGLL(I)
+ IF (dABS(DZ) < EPS) THEN
+ HGLL = 1.d0
+ RETURN
+ ENDIF
+ N = NZ - 1
+ ALFAN = dble(N)*(dble(N)+1.d0)
+ HGLL = - (1.d0-Z*Z)*PNDLEG(Z,N)/ (ALFAN*PNLEG(ZGLL(I),N)*(Z-ZGLL(I)))
+ RETURN
+ end function hgll
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/intseq.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/intseq.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/intseq.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,76 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine intseq
+!
+!=======================================================================
+!
+! "i n t s e q" : Read time iteration and non linear iteration
+! parameters
+!
+!=======================================================================
+!
+! output variables :
+! ----------------
+! .ncycl : number of time steps
+! .niter : Number of non linear or corrector iterations
+! .deltat : Time step increment
+!
+! .nftfl : Load time function for collocated nodal forces
+! .nftfk : Load time function for kinematic constrains
+!
+!=======================================================================
+!
+ use loadft
+ use iounit
+ use infos
+ use timeparams
+
+ implicit none
+
+ character(len=80) datlin
+
+!
+!-----------------------------------------------------------------------
+!
+!---- read first sequence parameters for dynamic analysis
+!
+ read(iin ,40) datlin
+ read(iin ,*) ncycl,deltat,niter
+
+!
+!---- read load time functions parameters
+!
+ read(iin ,40) datlin
+ read(iin ,*) nltfl
+
+ if(iecho /= 0) then
+!
+!---- print requested output
+!
+ write(iout,100) ncycl,deltat,ncycl*deltat,niter
+
+ endif
+
+ return
+!
+!---- formats
+!
+ 40 format(a80)
+ 100 format(//' I t e r a t i o n i n f o s '/1x,29('='),//5x, &
+ 'Number of time iterations . . . . .(ncycl) =',i8,/5x, &
+ 'Time step increment . . . . . . . .(deltat) =',1pe15.6,/5x, &
+ 'Total simulation duration . . . . . (ttot) =',1pe15.6,/5x, &
+ 'Number of corrector iterations. . .(niter) =',i8)
+
+ end subroutine intseq
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/jacg.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/jacg.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/jacg.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,96 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine jacg (xjac,np,alpha,beta)
+!
+!=======================================================================
+!
+! J a c g : Compute np Gauss points, which are the zeros of the
+! Jacobi polynomial with parameter alpha and beta.
+!
+!=======================================================================
+!
+! Note :
+! ----
+! .Alpha and Beta determines the specific type of gauss points.
+! .alpha = beta = 0.0 -> Legendre points
+! .alpha = beta = -0.5 -> Chebyshev points
+!
+!=======================================================================
+!
+ implicit none
+
+ integer np
+ double precision alpha,beta
+ double precision xjac(np)
+
+ integer k,j,i,jmin,jm,n
+ double precision xlast,dth,x,x1,x2,recsum,delx,xmin,swap
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+
+ integer, parameter :: kstop = 10
+ double precision, parameter :: zero = 0.d0, eps = 1.0d-12
+
+!
+!-----------------------------------------------------------------------
+!
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ xlast = 0.d0
+ n = np-1
+ dth = 4.d0*datan(1.d0)/(2.d0*dble(n)+2.d0)
+ p = 0.d0
+ pd = 0.d0
+ jmin = 0
+ do 40 j=1,np
+ if (j == 1) then
+ x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
+ else
+ x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
+ x2 = xlast
+ x = (x1+x2)/2.d0
+ endif
+ do 30 k=1,kstop
+ call jacobf (p,pd,pm1,pdm1,pm2,pdm2,np,alpha,beta,x)
+ recsum = 0.d0
+ jm = j-1
+ do 29 i=1,jm
+ recsum = recsum+1.d0/(x-xjac(np-i+1))
+ 29 continue
+ delx = -p/(pd-recsum*p)
+ x = x+delx
+ if (abs(delx) < eps) goto 31
+ 30 continue
+ 31 continue
+ xjac(np-j+1) = x
+ xlast = x
+ 40 continue
+ do 200 i=1,np
+ xmin = 2.d0
+ do 100 j=i,np
+ if (xjac(j) < xmin) then
+ xmin = xjac(j)
+ jmin = j
+ endif
+ 100 continue
+ if (jmin /= i) then
+ swap = xjac(i)
+ xjac(i) = xjac(jmin)
+ xjac(jmin) = swap
+ endif
+ 200 continue
+ return
+ end subroutine jacg
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/jacobf.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/jacobf.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/jacobf.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,66 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine jacobf (poly,pder,polym1,pderm1,polym2,pderm2,n,alp, &
+ bet,x)
+!
+!=======================================================================
+!
+! J a c o b f : Compute the Jacobi polynomial and its derivative
+! ----------- of degree n at x.
+!
+!=======================================================================
+ implicit none
+
+ double precision poly,pder,polym1,pderm1,polym2,pderm2,alp,bet,x
+ integer n
+
+ double precision apb,polyl,pderl,dk,a1,a2,b3,a3,a4,polyn,pdern,psave,pdsave
+ integer k
+
+ apb = alp+bet
+ poly = 1.d0
+ pder = 0.d0
+ psave = 0.d0
+ pdsave = 0.d0
+
+ if (n == 0) return
+
+ polyl = poly
+ pderl = pder
+ poly = (alp-bet+(apb+2.d0)*x)/2.d0
+ pder = (apb+2.d0)/2.d0
+ if (n == 1) return
+ do 20 k=2,n
+ dk = dble(k)
+ a1 = 2.d0*dk*(dk+apb)*(2.d0*dk+apb-2.d0)
+ a2 = (2.d0*dk+apb-1.d0)*(alp**2-bet**2)
+ b3 = (2.d0*dk+apb-2.d0)
+ a3 = b3*(b3+1.d0)*(b3+2.d0)
+ a4 = 2.d0*(dk+alp-1.d0)*(dk+bet-1.d0)*(2.d0*dk+apb)
+ polyn = ((a2+a3*x)*poly-a4*polyl)/a1
+ pdern = ((a2+a3*x)*pder-a4*pderl+a3*poly)/a1
+ psave = polyl
+ pdsave = pderl
+ polyl = poly
+ poly = polyn
+ pderl = pder
+ pder = pdern
+ 20 continue
+ polym1 = polyl
+ pderm1 = pderl
+ polym2 = psave
+ pderm2 = pdsave
+!
+ return
+ end subroutine jacobf
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/modifperio.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/modifperio.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/modifperio.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,189 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine modifperio(ibool,iboolori,codeperio)
+!
+!=======================================================================
+!
+! "m o d i f p e r i o": Modify the numbering to take periodic
+! boundary conditions into account
+!
+!=======================================================================
+!
+ use spela202
+ use codebord
+
+ implicit none
+
+ integer ibool(nxgll,nygll,nspec),iboolori(nxgll,nygll,nspec)
+ integer codeperio(4,nelemperio)
+
+ integer n,num2,i2,j2,ipos,ipos2,iloc,jloc,kloc
+ integer iloc1,jloc1,iloc2,jloc2
+ integer iother1,jother1,iother2,jother2,iboolother1,iboolother2
+ integer ispec,ix,iy,nedgeloc,nedgeother,numelem
+
+!
+!-----------------------------------------------------------------------
+!
+
+ print *
+ print *
+ print *,'Modifying global numbering for periodic boundaries...'
+ print *
+
+! sauvegarder ancienne numerotation pour representations graphiques
+ iboolori = ibool
+
+ do n=1,nelemperio
+
+ numelem = codeperio(1,n)
+ nedgeloc = codeperio(2,n)
+ num2 = codeperio(3,n)
+ nedgeother = codeperio(4,n)
+
+!
+!---- point a l'interieur d'une arete, modifier dans arete correspondante
+!
+
+! obtenir la numerotation dans l'autre element
+! maillage conforme donc on doit supposer que nxgll == nygll
+
+! modifier tout l'interieur de l'arete
+ do kloc = 2,nxgll-1
+
+! calculer l'abscisse le long de l'arete de depart
+ select case (nedgeloc)
+ case(1)
+ iloc = kloc
+ jloc = 1
+ ipos = iloc
+ case(2)
+ iloc = nxgll
+ jloc = kloc
+ ipos = jloc
+ case(3)
+ iloc = kloc
+ jloc = nygll
+ ipos = nxgll - iloc + 1
+ case(4)
+ iloc = 1
+ jloc = kloc
+ ipos = nygll - jloc + 1
+ end select
+
+! calculer l'abscisse le long de l'arete d'arrivee
+! topologie du maillage coherente, donc sens de parcours des aretes opposes
+
+ ipos2 = nxgll - ipos + 1
+
+! calculer les coordonnees reelles dans l'element d'arrivee
+ select case (nedgeother)
+ case(1)
+ i2 = ipos2
+ j2 = 1
+ case(2)
+ i2 = nxgll
+ j2 = ipos2
+ case(3)
+ i2 = nxgll - ipos2 + 1
+ j2 = nygll
+ case(4)
+ i2 = 1
+ j2 = nygll - ipos2 + 1
+ end select
+
+! implementer la periodicite en affectant le meme numero global
+ ibool(i2,j2,num2) = ibool(iloc,jloc,numelem)
+
+ enddo
+
+!
+!---- cas particulier des coins, recherche sur tous les coins du maillage
+!
+
+! determiner les deux coins delimitant l'arete de depart
+ select case (nedgeloc)
+ case(1)
+ iloc1 = 1
+ jloc1 = 1
+ iloc2 = nxgll
+ jloc2 = 1
+ case(2)
+ iloc1 = nxgll
+ jloc1 = 1
+ iloc2 = nxgll
+ jloc2 = nygll
+ case(3)
+ iloc1 = nxgll
+ jloc1 = nygll
+ iloc2 = 1
+ jloc2 = nygll
+ case(4)
+ iloc1 = 1
+ jloc1 = nygll
+ iloc2 = 1
+ jloc2 = 1
+ end select
+
+! determiner les deux coins delimitant l'arete d'arrivee
+ select case (nedgeother)
+ case(1)
+ iother1 = 1
+ jother1 = 1
+ iother2 = nxgll
+ jother2 = 1
+ case(2)
+ iother1 = nxgll
+ jother1 = 1
+ iother2 = nxgll
+ jother2 = nygll
+ case(3)
+ iother1 = nxgll
+ jother1 = nygll
+ iother2 = 1
+ jother2 = nygll
+ case(4)
+ iother1 = 1
+ jother1 = nygll
+ iother2 = 1
+ jother2 = 1
+ end select
+
+ iboolother1 = ibool(iother1,jother1,num2)
+ iboolother2 = ibool(iother2,jother2,num2)
+
+! rechercher correspondants de ces deux coins parmi autres coins du maillage
+ do ispec = 1,nspec
+
+ if(ispec /= numelem) then
+ do ix = 1,nxgll,nxgll-1
+ do iy = 1,nygll,nygll-1
+
+! affecter le meme numero global en tenant compte du sens inverse des aretes
+ if(ibool(ix,iy,ispec) == iboolother2) &
+ ibool(ix,iy,ispec) = ibool(iloc1,jloc1,numelem)
+
+ if(ibool(ix,iy,ispec) == iboolother1) &
+ ibool(ix,iy,ispec) = ibool(iloc2,jloc2,numelem)
+
+ enddo
+ enddo
+ endif
+
+ enddo
+
+ enddo
+
+ return
+ end subroutine modifperio
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/modules.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/modules.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/modules.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,436 @@
+!
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 3 . 0
+! -----------------------------------
+!
+! Dimitri Komatitsch and Jean-Pierre Vilotte
+! Departement de Sismologie
+! (c) Institut de Physique du Globe de Paris, Octobre 1997
+!
+!=====================================================================
+!
+ module arraydir
+!
+!=======================================================================
+!
+! "arraydir" : for directory of dynamically allocated arrays
+! ----------
+!
+!=======================================================================
+!
+ implicit none
+
+ integer, parameter :: iinteg = 1, isngl = 2, idouble = 3
+ integer, parameter :: maxnbarrays = 250
+ integer, dimension(maxnbarrays), save :: arraysizes,arraytypes
+ character(len=12), dimension(maxnbarrays), save :: arraynames
+ integer, save :: nbarrays
+
+ end module arraydir
+!
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 3 . 0
+! -----------------------------------
+!
+! Dimitri Komatitsch and Jean-Pierre Vilotte
+! Departement de Sismologie
+! (c) Institut de Physique du Globe de Paris, Octobre 1997
+!
+!=====================================================================
+!
+ module captio
+!
+!=======================================================================
+! "captio" :
+! ----------
+!
+!=======================================================================
+!
+ implicit none
+
+ character(len=50), save :: stitle
+ character(len=80), save :: jtitle
+
+ end module captio
+!
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 3 . 0
+! -----------------------------------
+!
+! Dimitri Komatitsch and Jean-Pierre Vilotte
+! Departement de Sismologie
+! (c) Institut de Physique du Globe de Paris, Octobre 1997
+!
+!=====================================================================
+!
+ module codebord
+!
+!=======================================================================
+!
+! "codebord" : Code bords absorbants et periodiques
+! --------
+!
+!=======================================================================
+!
+ implicit none
+
+ integer, parameter :: ihaut = 1
+ integer, parameter :: ibas = 2
+ integer, parameter :: igauche = 3
+ integer, parameter :: idroite = 4
+
+! --- code des numeros d'aretes pour les bords absorbants
+ integer, parameter :: iaretebas = 1
+ integer, parameter :: iaretedroite = 2
+ integer, parameter :: iaretehaut = 3
+ integer, parameter :: iaretegauche = 4
+
+ end module codebord
+!
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 3 . 0
+! -----------------------------------
+!
+! Dimitri Komatitsch and Jean-Pierre Vilotte
+! Departement de Sismologie
+! (c) Institut de Physique du Globe de Paris, Octobre 1997
+!
+!=====================================================================
+!
+ module constspec
+!
+!=======================================================================
+! "constspec" :
+! ----------
+!
+!=======================================================================
+!
+ implicit none
+
+ logical, save :: display,ignuplot,interpol,sismos, &
+ ivectplot,imeshvect,isymbols,simuornot, &
+ imodelvect,iboundvect,initialfield,usletter, &
+ ireadmodel,ioutputgrid,iavs
+
+ integer, save :: nrec,isamp,itaff,itfirstaff, &
+ icolor,inumber,isubsamp,nrec1,nrec2,irepr,n1ana,n2ana, &
+ isismostype,ivecttype,iaffinfo
+
+ double precision, save :: anglerec,anglerec2, &
+ cutvect,scalex,scalez,angle,rapport, &
+ sizex,sizez,orig_x,orig_z,rapp_page, &
+ sizemax,dispmax,factorana,factorxsu,xmin,zmin
+
+ double precision, parameter :: centim = 28.5d0
+
+ end module constspec
+!
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 3 . 0
+! -----------------------------------
+!
+! Dimitri Komatitsch and Jean-Pierre Vilotte
+! Departement de Sismologie
+! (c) Institut de Physique du Globe de Paris, Octobre 1997
+!
+!=====================================================================
+!
+ module defpi
+!
+!=======================================================================
+! "defpi" : Define the constant number pi
+! -----
+!
+!=======================================================================
+!
+ implicit none
+
+ double precision, parameter :: pi = 3.141592653589793d0
+
+ end module defpi
+!
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 3 . 0
+! -----------------------------------
+!
+! Dimitri Komatitsch and Jean-Pierre Vilotte
+! Departement de Sismologie
+! (c) Institut de Physique du Globe de Paris, Octobre 1997
+!
+!=====================================================================
+!
+ module energie
+!
+!=======================================================================
+! "energie" :
+! ----------
+!
+!=======================================================================
+!
+ implicit none
+
+ integer, save :: ienergy
+ logical, save :: compenergy
+
+ end module energie
+!
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 3 . 0
+! -----------------------------------
+!
+! Dimitri Komatitsch and Jean-Pierre Vilotte
+! Departement de Sismologie
+! (c) Institut de Physique du Globe de Paris, Octobre 1997
+!
+!=====================================================================
+!
+ module infos
+!
+!=======================================================================
+! "infos" :
+! ------
+!
+!=======================================================================
+!
+ implicit none
+
+ integer, save :: iecho,iexec
+
+ end module infos
+!
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 3 . 0
+! -----------------------------------
+!
+! Dimitri Komatitsch and Jean-Pierre Vilotte
+! Departement de Sismologie
+! (c) Institut de Physique du Globe de Paris, Octobre 1997
+!
+!=====================================================================
+!
+ module iounit
+!
+!=======================================================================
+! "iounit" :
+! ----------
+!
+!=======================================================================
+!
+ implicit none
+
+ integer, save :: iin, iout
+
+ end module iounit
+!
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 3 . 0
+! -----------------------------------
+!
+! Dimitri Komatitsch and Jean-Pierre Vilotte
+! Departement de Sismologie
+! (c) Institut de Physique du Globe de Paris, Octobre 1997
+!
+!=====================================================================
+!
+ module label1
+!
+!=======================================================================
+!
+! "label1" : Coordinate labels
+! --------
+!
+!=======================================================================
+!
+ implicit none
+
+ character(len=5), dimension(3), save :: labelc
+
+ end module label1
+!
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 3 . 0
+! -----------------------------------
+!
+! Dimitri Komatitsch and Jean-Pierre Vilotte
+! Departement de Sismologie
+! (c) Institut de Physique du Globe de Paris, Octobre 1997
+!
+!=====================================================================
+!
+ module loadft
+!
+!=======================================================================
+! "loadft" :
+! ----------
+!
+!=======================================================================
+!
+ implicit none
+
+ integer, save :: nltfl
+
+ end module loadft
+!
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 3 . 0
+! -----------------------------------
+!
+! Dimitri Komatitsch and Jean-Pierre Vilotte
+! Departement de Sismologie
+! (c) Institut de Physique du Globe de Paris, Octobre 1997
+!
+!=====================================================================
+!
+ module mesh01
+!
+!=======================================================================
+! "mesh01" :
+! ----------
+!
+!=======================================================================
+!
+ implicit none
+
+ integer, save :: npoin,ndofn,ndime,npgeo
+
+ end module mesh01
+!
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 3 . 0
+! -----------------------------------
+!
+! Dimitri Komatitsch and Jean-Pierre Vilotte
+! Departement de Sismologie
+! (c) Institut de Physique du Globe de Paris, Octobre 1997
+!
+!=====================================================================
+!
+ module palette
+!
+!=======================================================================
+! "palette" :
+! ----------
+!
+!=======================================================================
+!
+ implicit none
+
+ integer, parameter :: maxcolors = 128
+
+ double precision, dimension(maxcolors), save :: red,green,blue
+
+ end module palette
+!
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 3 . 0
+! -----------------------------------
+!
+! Dimitri Komatitsch and Jean-Pierre Vilotte
+! Departement de Sismologie
+! (c) Institut de Physique du Globe de Paris, Octobre 1997
+!
+!=====================================================================
+!
+ module spela202
+!
+!=======================================================================
+! "spela202" :
+! ----------
+!
+!=======================================================================
+!
+ implicit none
+
+ integer, save :: numat,ngnod,nxgll,nygll,nspec,iptsdisp,nelemabs,nelemperio
+
+ end module spela202
+!
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 3 . 0
+! -----------------------------------
+!
+! Dimitri Komatitsch and Jean-Pierre Vilotte
+! Departement de Sismologie
+! (c) Institut de Physique du Globe de Paris, Octobre 1997
+!
+!=====================================================================
+!
+ module timeparams
+!
+!=======================================================================
+! "timeparams" :
+! ----------
+!
+!=======================================================================
+!
+ implicit none
+
+ double precision, save :: deltat,time
+ integer, save :: ncycl,niter
+
+ end module timeparams
+!
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 3 . 0
+! -----------------------------------
+!
+! Dimitri Komatitsch and Jean-Pierre Vilotte
+! Departement de Sismologie
+! (c) Institut de Physique du Globe de Paris, Octobre 1997
+!
+!=====================================================================
+!
+ module verifs
+!
+!=======================================================================
+! "verifs" :
+! ----------
+!
+!=======================================================================
+!
+ implicit none
+
+ double precision, save :: rsizemin,rsizemax,cpoverdxmin,cpoverdxmax, &
+ rlamdaSmin,rlamdaSmax,rlamdaPmin,rlamdaPmax,valseuil,freqmaxrep,vpmin,vpmax
+
+ end module verifs
+!
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 3 . 0
+! -----------------------------------
+!
+! Dimitri Komatitsch and Jean-Pierre Vilotte
+! Departement de Sismologie
+! (c) Institut de Physique du Globe de Paris, Octobre 1997
+!
+!=====================================================================
+!
+ module vparams
+!
+!=======================================================================
+! "vparams" :
+! --------
+!
+!=======================================================================
+!
+ implicit none
+
+ double precision, save :: cp1,cs1,rho1,cp2,cs2,rho2,xt1,zt1,xt2,zt2
+
+ end module vparams
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotavs.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotavs.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotavs.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,88 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine plotavs(displ,coord,kmato,ibool,it)
+
+!
+! routine sauvegarde fichier AVS
+!
+
+ use constspec
+ use mesh01
+ use spela202
+
+ implicit none
+
+ integer kmato(nspec)
+ integer ibool(nxgll,nygll,nspec)
+ double precision displ(ndime,npoin),coord(ndime,npoin)
+ integer it
+
+ integer icell,i,j,ispec,iavsfile,ip
+ double precision rmaxnorm
+ character(len=40) name
+
+ print *,'Entering AVS file generation...'
+
+! file number for AVS output
+ iavsfile = 34
+
+!---- ouverture du fichier AVS
+ write(name,222) it
+ open(unit=iavsfile,file=name,status='unknown')
+ 222 format('avs',i5.5,'.inp')
+
+! nb de noeuds, de cellules, de donnees par cellule
+ write(iavsfile,180) npoin,nspec*(nxgll-1)*(nygll-1),1,0,0
+
+! numero et coordonnees des points du maillage (3D fictif avec coordonnee nulle)
+ do ip=1,npoin
+ write(iavsfile,200) ip,coord(1,ip),coord(2,ip)
+ enddo
+
+! numero et topologie des cellules
+ icell = 0
+ do ispec=1,nspec
+ do i=1,nxgll-1
+ do j=1,nxgll-1
+
+ icell = icell + 1
+ write(iavsfile,210) icell,kmato(ispec),ibool(i,j+1,ispec), &
+ ibool(i,j,ispec),ibool(i+1,j,ispec),ibool(i+1,j+1,ispec)
+
+ enddo
+ enddo
+ enddo
+
+! structure data vector et labels bidons
+ write(iavsfile,*) ' 1 1'
+ write(iavsfile,*) ' Label1, Label2'
+
+! donnees aux noeuds (norme du vecteur deplacement, normalisee a 1)
+ rmaxnorm = maxval(sqrt(displ(1,:)**2 + displ(2,:)**2))
+ do ip=1,npoin
+ write(iavsfile,205) ip,sqrt(displ(1,ip)**2 + displ(2,ip)**2)/rmaxnorm
+ enddo
+
+ print *,'Max norme dans output AVS = ',rmaxnorm
+
+ close(iavsfile)
+
+ print *,'End of AVS file generation...'
+
+180 format(i6,1x,i6,1x,i3,1x,i3,1x,i3)
+200 format(i6,1x,e12.5,' 0. ',e12.5)
+205 format(i6,1x,e12.5)
+210 format(i6,1x,i4,' quad ',i6,1x,i6,1x,i6,1x,i6)
+
+ end subroutine plotavs
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotgll.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotgll.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotgll.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,245 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine plotgll(knods,ibool,coorg,coord)
+!
+!=======================================================================
+!
+! "p l o t g l l" : Print the Gauss-Lobatto-Legendre mesh
+! in a Gnuplot file
+!
+!=======================================================================
+!
+ use mesh01
+ use spela202
+ use iounit
+
+ implicit none
+
+ integer knods(ngnod,nspec),ibool(nxgll,nxgll,nspec)
+ double precision coorg(ndime,npgeo),coord(ndime,npoin)
+
+! coordinates of the nodes for Gnuplot file
+ integer maxnnode
+ parameter(maxnnode=9)
+ real xval(maxnnode),zval(maxnnode)
+
+ integer ispel,iy,ix,iglobnum,iglobnum2,ibloc,inode
+ character(len=70) name
+
+!
+!---- print the GLL mesh in a Gnuplot file
+!
+
+ write(iout,*)
+ write(iout,*) 'Generating gnuplot meshes...'
+ write(iout,*)
+
+! create non empty files for the case of 4-nodes elements
+
+ name='macros1.gnu'
+ open(unit=30,file=name,status='unknown')
+
+ name='macros2.gnu'
+ open(unit=31,file=name,status='unknown')
+ write(31,10)
+
+ name='gllmesh1.gnu'
+ open(unit=20,file=name,status='unknown')
+
+ name='gllmesh2.gnu'
+ open(unit=21,file=name,status='unknown')
+ write(21,10)
+
+ do ispel = 1,nspec
+
+!
+!---- plot the lines in xi-direction
+!
+ do iy = 1,nygll
+ do ix = 1,nxgll-1
+!
+!---- get the global point number
+!
+ iglobnum = ibool(ix,iy,ispel)
+!
+!---- do the same for next point on horizontal line
+!
+ iglobnum2 = ibool(ix+1,iy,ispel)
+
+ write(20,15) sngl(coord(1,iglobnum)),sngl(coord(2,iglobnum))
+ write(20,15) sngl(coord(1,iglobnum2)),sngl(coord(2,iglobnum2))
+ write(20,10)
+
+ if ((iy == 1).or.(iy == nygll)) then
+ write(21,15) sngl(coord(1,iglobnum)),sngl(coord(2,iglobnum))
+ write(21,15) sngl(coord(1,iglobnum2)),sngl(coord(2,iglobnum2))
+ write(21,10)
+ endif
+
+ enddo
+ enddo
+
+!
+!---- plot the lines in eta-direction
+!
+ do ix = 1,nxgll
+ do iy = 1,nygll-1
+!
+!---- get the global point number
+!
+ iglobnum = ibool(ix,iy,ispel)
+!
+!---- do the same for next point on vertical line
+!
+ iglobnum2 = ibool(ix,iy+1,ispel)
+
+ write(20,15) sngl(coord(1,iglobnum)),sngl(coord(2,iglobnum))
+ write(20,15) sngl(coord(1,iglobnum2)),sngl(coord(2,iglobnum2))
+ write(20,10)
+
+ if ((ix == 1).or.(ix == nxgll)) then
+ write(21,15) sngl(coord(1,iglobnum)),sngl(coord(2,iglobnum))
+ write(21,15) sngl(coord(1,iglobnum2)),sngl(coord(2,iglobnum2))
+ write(21,10)
+ endif
+
+ enddo
+ enddo
+ enddo
+
+!
+!---- Plot the macroblocs mesh using Gnuplot
+!
+ do ibloc = 1,nspec
+ do inode = 1,ngnod
+
+ xval(inode) = sngl(coorg(1,knods(inode,ibloc)))
+ zval(inode) = sngl(coorg(2,knods(inode,ibloc)))
+
+ enddo
+
+ if(ngnod == 4) then
+!
+!---- 4-noded rectangular element
+!
+
+! draw the edges of the element using one color
+ write(30,15) xval(1),zval(1)
+ write(30,15) xval(2),zval(2)
+ write(30,10)
+ write(30,15) xval(2),zval(2)
+ write(30,15) xval(3),zval(3)
+ write(30,10)
+ write(30,15) xval(3),zval(3)
+ write(30,15) xval(4),zval(4)
+ write(30,10)
+ write(30,15) xval(4),zval(4)
+ write(30,15) xval(1),zval(1)
+ write(30,10)
+
+ else
+
+!
+!---- 9-noded rectangular element
+!
+
+! draw the edges of the element using one color
+ write(30,15) xval(1),zval(1)
+ write(30,15) xval(5),zval(5)
+ write(30,10)
+ write(30,15) xval(5),zval(5)
+ write(30,15) xval(2),zval(2)
+ write(30,10)
+ write(30,15) xval(2),zval(2)
+ write(30,15) xval(6),zval(6)
+ write(30,10)
+ write(30,15) xval(6),zval(6)
+ write(30,15) xval(3),zval(3)
+ write(30,10)
+ write(30,15) xval(3),zval(3)
+ write(30,15) xval(7),zval(7)
+ write(30,10)
+ write(30,15) xval(7),zval(7)
+ write(30,15) xval(4),zval(4)
+ write(30,10)
+ write(30,15) xval(4),zval(4)
+ write(30,15) xval(8),zval(8)
+ write(30,10)
+ write(30,15) xval(8),zval(8)
+ write(30,15) xval(1),zval(1)
+ write(30,10)
+
+! draw middle lines using another color
+ write(31,15) xval(5),zval(5)
+ write(31,15) xval(9),zval(9)
+ write(31,10)
+ write(31,15) xval(9),zval(9)
+ write(31,15) xval(7),zval(7)
+ write(31,10)
+ write(31,15) xval(8),zval(8)
+ write(31,15) xval(9),zval(9)
+ write(31,10)
+ write(31,15) xval(9),zval(9)
+ write(31,15) xval(6),zval(6)
+ write(31,10)
+
+ endif
+
+ enddo
+
+ close(20)
+ close(21)
+
+ close(30)
+ close(31)
+
+!
+!---- generate the command file for Gnuplot
+!
+ open(unit=20,file='plotmeshes',status='unknown')
+ write(20,*) '#!/bin/sh'
+ write(20,10)
+ write(20,*) 'gnuplot macros_mesh.gnu'
+ write(20,*) 'gnuplot gll_mesh.gnu'
+ close(20)
+
+ open(unit=20,file='gll_mesh.gnu',status='unknown')
+ write(20,*) 'set term x11'
+ write(20,*) 'set xlabel "X"'
+ write(20,*) 'set ylabel "Y"'
+ write(20,*) 'set title "Gauss-Lobatto-Legendre Mesh"'
+ write(20,*) 'plot "gllmesh1.gnu" title '''' w l 2,', &
+ ' "gllmesh2.gnu" title '''' w linesp 1 3'
+ write(20,*) 'pause -1 "Hit any key to exit..."'
+ close(20)
+
+ open(unit=20,file='macros_mesh.gnu',status='unknown')
+ write(20,*) 'set term x11'
+ write(20,*) 'set xlabel "X"'
+ write(20,*) 'set ylabel "Y"'
+ write(20,*) 'set title "Spectral Elements (Macroblocs) Mesh"'
+ write(20,*) 'plot "macros2.gnu" title '''' w l 2,', &
+ ' "macros1.gnu" title '''' w linesp 1 3'
+ write(20,*) 'pause -1 "Hit any key to exit..."'
+ close(20)
+
+!
+!----
+!
+
+10 format('')
+15 format(e10.5,1x,e10.5)
+
+ return
+ end subroutine plotgll
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotpost.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotpost.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotpost.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,430 @@
+
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine plotpost(U,coord,vpext,gltfl,posrec,nltfl,it,dt,coorg, &
+ xinterp,zinterp,shapeint, &
+ Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ numabs,codeabs,codeperio,anyabs,anyperio)
+
+!
+! routine affichage postscript
+!
+
+ use palette
+ use captio
+ use timeparams
+ use constspec
+ use mesh01
+ use spela202
+
+ implicit none
+
+!--- ecrire legendes ou non
+ logical, parameter :: legendes=.true.
+
+ integer kmato(nspec),knods(ngnod,nspec)
+ integer ibool(nxgll,nygll,nspec)
+
+ double precision xinterp(iptsdisp,iptsdisp),zinterp(iptsdisp,iptsdisp)
+ double precision shapeint(ngnod,iptsdisp,iptsdisp)
+ double precision Uxinterp(iptsdisp,iptsdisp)
+ double precision Uzinterp(iptsdisp,iptsdisp)
+ double precision flagrange(0:nxgll-1,iptsdisp)
+ double precision density(numat),elastcoef(4,numat)
+
+ integer nltfl,it
+ double precision dt,timeval
+ double precision U(ndime,npoin),coord(ndime,npoin)
+ double precision vpext(npoin)
+
+ double precision coorg(ndime,npgeo)
+ double precision gltfl(20,nltfl)
+ double precision posrec(ndime,nrec)
+
+ integer numabs(nelemabs),codeabs(4,nelemabs)
+ integer codeperio(4,nelemperio)
+ logical anyabs,anyperio
+
+! limite pour afficher des points a la place des recepteurs
+ integer, parameter :: ndots = 10
+
+! taille de la fenetre de display Postscript en pourcentage de la feuille
+ double precision, parameter :: rpercentx = 70.0d0, rpercentz = 77.0d0
+
+ double precision xmax,zmax,height,xw,zw,usoffset
+ integer i,iglobrec,iglobsource,ip
+ character(len=40) name
+
+! papier A4 ou US letter
+ if(usletter) then
+ usoffset = 1.75d0
+ sizex = 27.94d0
+ sizez = 21.59d0
+ else
+ usoffset = 0.
+ sizex = 29.7d0
+ sizez = 21.d0
+ endif
+
+! definition de la palette de couleur
+
+! red
+ red(1) = 1.d0
+ green(1) = 0.d0
+ blue(1) = 0.d0
+! blue
+ red(2) = 0.d0
+ green(2) = 0.d0
+ blue(2) = 1.d0
+! violet
+ red(3) = .93d0
+ green(3) = .51d0
+ blue(3) = .93d0
+! medium orchid
+ red(4) = .73d0
+ green(4) = .33d0
+ blue(4) = .83d0
+! dark orchid
+ red(5) = .6d0
+ green(5) = .2d0
+ blue(5) = .8d0
+! blue violet
+ red(6) = .54d0
+ green(6) = .17d0
+ blue(6) = .89d0
+! slate blue
+ red(7) = .42d0
+ green(7) = .35d0
+ blue(7) = .80d0
+! deep pink
+ red(8) = 1.d0
+ green(8) = .08d0
+ blue(8) = .58d0
+! dodger blue
+ red(9) = .12d0
+ green(9) = .56d0
+ blue(9) = 1.d0
+! dark turquoise
+ red(10) = 0.d0
+ green(10) = .81d0
+ blue(10) = .82d0
+! turquoise
+ red(11) = .25d0
+ green(11) = .88d0
+ blue(11) = .82d0
+! lime green
+ red(12) = .2d0
+ green(12) = .8d0
+ blue(12) = .2d0
+! spring green
+ red(13) = 0.d0
+ green(13) = 1.d0
+ blue(13) = .5d0
+! chartreuse
+ red(14) = .5d0
+ green(14) = 1.d0
+ blue(14) = 0.d0
+! green yellow
+ red(15) = .68d0
+ green(15) = 1.d0
+ blue(15) = .18d0
+! yellow
+ red(16) = 1.d0
+ green(16) = 1.d0
+ blue(16) = 0.d0
+! lemon chiffon
+ red(17) = 1.d0
+ green(17) = .98d0
+ blue(17) = .8d0
+! gold
+ red(18) = 1.d0
+ green(18) = .84d0
+ blue(18) = 0.d0
+! mocassin
+ red(19) = 1.d0
+ green(19) = .89d0
+ blue(19) = .71d0
+! peach puff
+ red(20) = 1.d0
+ green(20) = .85d0
+ blue(20) = .73d0
+
+! recherche des positions maximales des points de la grille
+ xmax=maxval(coord(1,:))
+ zmax=maxval(coord(2,:))
+ write(*,*) 'Max X = ',xmax
+ write(*,*) 'Max Z = ',zmax
+
+! limite du repere physique
+ xmin=0.d0
+ zmin=0.d0
+
+! rapport taille page/taille domaine physique
+ rapp_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) &
+ / 100.d0
+
+! recherche de la valeur maximum de la norme du deplacement
+ dispmax = maxval(sqrt(U(1,:)**2 + U(2,:)**2))
+ write(*,*) 'Max norme = ',dispmax
+
+! hauteur des numeros de domaine en CM
+ height = 0.25d0
+
+!
+!---- ouverture du fichier PostScript
+!
+ write(name,222) it
+ open(unit=24,file=name,status='unknown')
+ 222 format('vect',i5.5,'.ps')
+
+!
+!---- ecriture de l'entete du fichier PostScript
+!
+ write(24,10) stitle
+ write(24,*) '/CM {28.5 mul} def'
+ write(24,*) '/LR {rlineto} def'
+ write(24,*) '/LT {lineto} def'
+ write(24,*) '/L {lineto} def'
+ write(24,*) '/MR {rmoveto} def'
+ write(24,*) '/MV {moveto} def'
+ write(24,*) '/M {moveto} def'
+ write(24,*) '/MK {mark} def'
+ write(24,*) '/ST {stroke} def'
+ write(24,*) '/CP {closepath} def'
+ write(24,*) '/RG {setrgbcolor} def'
+ write(24,*) '/GF {gsave fill grestore} def'
+ write(24,*) '/GG {0 setgray ST} def'
+ write(24,*) '/GC {Colmesh ST} def'
+ write(24,*) '/RF {setrgbcolor fill} def'
+ write(24,*) '/SF {setgray fill} def'
+ write(24,*) '/GS {gsave} def'
+ write(24,*) '/GR {grestore} def'
+ write(24,*) '/SLW {setlinewidth} def'
+ write(24,*) '/SCSF {scalefont setfont} def'
+ write(24,*) '% differents symboles utiles'
+ write(24,*) '/Point {2 0 360 arc CP 0 setgray fill} def'
+ write(24,*) '/VDot {-0.75 -1.5 MR 1.5 0 LR 0 3. LR -1.5 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/HDot {-1.5 -0.75 MR 3. 0 LR 0 1.5 LR -3. 0 LR'
+ write(24,*) 'CP fill} def'
+ write(24,*) '/Cross {GS 0.05 CM SLW'
+ write(24,*) 'GS 3 3 MR -6. -6. LR ST GR'
+ write(24,*) 'GS 3 -3 MR -6. 6. LR ST GR'
+ write(24,*) '0.01 CM SLW} def'
+ write(24,*) '/SmallLine {MV 0.07 CM 0 rlineto} def'
+ write(24,*) '/Losange {GS 0.05 CM SLW 0 4.2 MR'
+ write(24,*) '-3 -4.2 LR 3 -4.2 LR 3 4.2 LR CP ST'
+ write(24,*) 'GR 0.01 CM SLW} def'
+ write(24,*) '%'
+ write(24,*) '% niveaux de gris pour le modele de vitesse'
+ write(24,*) '/BK {setgray fill} def'
+ write(24,*) '% version noir et blanc'
+ write(24,*) '%/BK {pop 1 setgray fill} def'
+ write(24,*) '%'
+ write(24,*) '% magenta pour les vecteurs deplacement'
+ write(24,*) '/Colvects {0.01 CM SLW 1. 0. 1. RG} def'
+ write(24,*) '% version noir et blanc'
+ write(24,*) '%/Colvects {0.01 CM SLW 0. setgray} def'
+ write(24,*) '%'
+ write(24,*) '% chartreuse pour le maillage des macroblocs'
+ write(24,*) '/Colmesh {0.02 CM SLW 0.5 1. 0. RG} def'
+ write(24,*) '% version noir et blanc'
+ write(24,*) '%/Colmesh {0.02 CM SLW 0. setgray} def'
+ write(24,*) '%'
+ write(24,*) '% cyan pour les sources et recepteurs'
+ write(24,*) '/Colreceiv {0. 1. 1. RG} def'
+ write(24,*) '% version noir et blanc'
+ write(24,*) '%/Colreceiv {0. setgray} def'
+ write(24,*) '%'
+ write(24,*) '% macro dessin fleche'
+ write(24,*) '/F {MV LR gsave LR ST grestore LR ST} def'
+ write(24,*) '% macro dessin contour elements'
+ write(24,*) '/CO {M counttomark 2 idiv {L} repeat cleartomark CP} def'
+ write(24,*) '%'
+ write(24,*) '.01 CM SLW'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.35 CM SCSF'
+ write(24,*) '%'
+ write(24,*) '/vshift ',-height/2,' CM def'
+ write(24,*) '/Rshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop neg vshift MR show } def'
+ write(24,*) '/Cshow { currentpoint stroke MV'
+ write(24,*) 'dup stringwidth pop -2 div vshift MR show } def'
+ write(24,*) '/fN {/Helvetica-Bold findfont ',height,' CM SCSF} def'
+ write(24,*) '%'
+ write(24,*) 'gsave newpath 90 rotate'
+ write(24,*) '0 ',-sizez,' CM translate 1. 1. scale'
+ write(24,*) '%'
+
+!
+!--- ecriture des legendes du fichier PostScript
+!
+ write(24,*) '0 setgray'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.5 CM SCSF'
+
+ if (legendes) then
+ write(24,*) '24. CM 1.2 CM MV'
+ write(24,610) usoffset,it
+ write(24,*) '%'
+
+ write(24,*) '24. CM 1.95 CM MV'
+ timeval = it*dt
+ if(timeval >= 1.d-3) then
+ write(24,600) usoffset,timeval
+ else
+ write(24,601) usoffset,timeval
+ endif
+ write(24,*) '%'
+ write(24,*) '24. CM 2.7 CM MV'
+ write(24,640) usoffset,dispmax
+ write(24,*) '%'
+ write(24,*) '24. CM 3.45 CM MV'
+ write(24,620) usoffset,cutvect*100.d0
+ write(24,*) '%'
+ write(24,*) '24. CM 4.2 CM MV'
+ write(24,630) usoffset,niter
+
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.6 CM SCSF'
+ if (icolor == 1) write(24,*) '.4 .9 .9 setrgbcolor'
+ write(24,*) '11 CM 1.1 CM MV'
+ write(24,*) '(X axis) show'
+ write(24,*) '%'
+ write(24,*) '1.4 CM 9.5 CM MV'
+ write(24,*) 'currentpoint gsave translate 90 rotate 0 0 moveto'
+ write(24,*) '(Y axis) show'
+ write(24,*) 'grestore'
+ write(24,*) '%'
+ write(24,*) '/Times-Roman findfont'
+ write(24,*) '.7 CM SCSF'
+ if (icolor == 1) write(24,*) '.8 0 .8 setrgbcolor'
+ write(24,*) '24.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ if (ivecttype == 1) then
+ write(24,*) '(Displacement vector field) show'
+ else if (ivecttype == 2) then
+ write(24,*) '(Velocity vector field) show'
+ else if (ivecttype == 3) then
+ write(24,*) '(Acceleration vector field) show'
+ else
+ stop 'Bad field code in PostScript display'
+ endif
+ write(24,*) 'grestore'
+ write(24,*) '25.35 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(',stitle,') show'
+ write(24,*) 'grestore'
+ write(24,*) '26.45 CM 18.9 CM MV'
+ write(24,*) usoffset,' CM 2 div neg 0 MR'
+ write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
+ write(24,*) '(Elastic Wave 2D - Spectral Element Method) show'
+ write(24,*) 'grestore'
+
+ endif
+
+ write(24,*) '%'
+ write(24,*) scalex,' ',scalez,' scale'
+ write(24,*) '%'
+
+!
+!---- plot mesh and displacement vector field in a PostScript file
+!
+ call plotvect(knods,coorg,coord,U, &
+ density,elastcoef,kmato,flagrange,xinterp,zinterp,shapeint, &
+ Uxinterp,Uzinterp,ibool,vpext, &
+ numabs,codeabs,codeperio,anyabs,anyperio)
+
+! sources et recepteurs en couleur si modele de vitesse
+ if(imodelvect) then
+ write(24,*) 'Colreceiv'
+ else
+ write(24,*) '0 setgray'
+ endif
+
+!
+!---- write position of the sources
+!
+ do i=1,nltfl
+
+ iglobsource = nint(gltfl(9,i))
+
+ xw = coord(1,iglobsource)
+ zw = coord(2,iglobsource)
+ xw = (xw-xmin)*rapp_page + orig_x
+ zw = (zw-zmin)*rapp_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ write(24,510) xw,zw
+ if (isymbols) then
+ write(24,*) 'Cross'
+ else
+ write(24,*) '(S',i,') show'
+ endif
+ enddo
+
+!
+!---- write position of the receivers
+!
+ do i=1,nrec
+ if(i == n1ana .or. i == n2ana) write(24,*) '% solution analytique trace ',i
+ if(i == 1) write(24,*) '% debut ligne recepteurs'
+ if(i == nrec) write(24,*) '% fin ligne recepteurs'
+
+ iglobrec = nint(posrec(1,i))
+ xw = coord(1,iglobrec)
+ zw = coord(2,iglobrec)
+
+ xw = (xw-xmin)*rapp_page + orig_x
+ zw = (zw-zmin)*rapp_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ write(24,510) xw,zw
+ if (isymbols) then
+ if(nrec > ndots.and.i /= 1.and.i /= nrec &
+ .and.i /= n1ana.and.i /= n2ana) then
+ if(i > nrec1) then
+ write(24,*) 'HDot'
+ else
+ write(24,*) 'VDot'
+ endif
+ else
+ write(24,*) 'Losange'
+ endif
+ else
+ write(24,*) '(R',i,') show'
+ endif
+ enddo
+
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
+
+ close(24)
+
+ 10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a50,/, &
+ '%% Created by: Specfem Version 4.2',/, &
+ '%% Author: Dimitri Komatitsch',/,'%%')
+ 510 format(f5.1,1x,f5.1,' M')
+ 600 format(f6.3,' neg CM 0 MR (Time =',f6.3,' s) show')
+ 601 format(f6.3,' neg CM 0 MR (Time =',1pe10.3,' s) show')
+ 610 format(f6.3,' neg CM 0 MR (Time step = ',i5,') show')
+ 620 format(f6.3,' neg CM 0 MR (Cut =',f5.2,' \%) show')
+ 630 format(f6.3,' neg CM 0 MR (Niter =',i2,') show')
+ 640 format(f6.3,' neg CM 0 MR (Max norm =',1pe10.3,') show')
+
+ end subroutine plotpost
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotvect.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotvect.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotvect.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,631 @@
+
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine plotvect(knods,coorg,coord,displ,density,elastcoef, &
+ kmato,flagrange,xinterp,zinterp,shapeint,Uxinterp,Uzinterp,ibool,vpext, &
+ numabs,codeabs,codeperio,anyabs,anyperio)
+!
+!=======================================================================
+!
+! "p l o t v e c t" : Print the displacement vector field
+! in a PostScript file together with
+! the spectral elements boundaries
+!
+!=======================================================================
+!
+ use palette
+ use constspec
+ use verifs
+ use mesh01
+ use spela202
+ use defpi
+ use codebord
+
+ implicit none
+
+ double precision coorg(ndime,npgeo)
+ double precision displ(ndofn,npoin)
+ double precision coord(ndime,npoin)
+ double precision xinterp(iptsdisp,iptsdisp),zinterp(iptsdisp,iptsdisp)
+ double precision shapeint(ngnod,iptsdisp,iptsdisp)
+ double precision Uxinterp(iptsdisp,iptsdisp)
+ double precision Uzinterp(iptsdisp,iptsdisp)
+ double precision flagrange(0:nxgll-1,iptsdisp)
+ double precision density(numat),elastcoef(4,numat)
+ double precision vpext(npoin)
+
+ integer knods(ngnod,nspec),kmato(nspec)
+ integer ibool(0:nxgll-1,0:nygll-1,nspec)
+
+ integer numabs(nelemabs),codeabs(4,nelemabs)
+ integer codeperio(4,nelemperio)
+ logical anyabs,anyperio
+
+ character(len=100) name
+ character ch1(100),ch2(100)
+ equivalence (name,ch1)
+ logical first
+
+ double precision convert,x1,rlamda,rmu,denst,rKvol,cploc,xw,zw,xa,za,xb,zb
+ double precision z1,x2,z2,d,d1,d2,dummy,theta,thetaup,thetadown
+
+ integer i,k,j,ispec,material,ispel,is,ir,nbcols,imat,icol,l,longueur
+ integer indice,ii,ipoin,in,nnum,ispelabs,ideb,ifin,ibord
+ integer numelem,nedgeloc,num2,nedgeother,n
+
+!
+!-----------------------------------------------------------------------
+!
+!---- print the spectral elements mesh in PostScript
+!
+
+ print *,'Shape functions based on ',ngnod,' control nodes'
+
+ convert = pi/180.d0
+
+!
+!---- draw the velocity model in background
+!
+ if(imodelvect) then
+
+ do ispec=1,nspec
+ do i=0,nxgll-1-isubsamp,isubsamp
+ do j=0,nxgll-1-isubsamp,isubsamp
+
+ if((vpmax-vpmin)/vpmin > 0.02d0) then
+ if(ireadmodel) then
+ x1 = (vpext(ibool(i,j,ispec))-vpmin)/ (vpmax-vpmin)
+ else
+ material = kmato(ispec)
+ rlamda = elastcoef(1,material)
+ rmu = elastcoef(2,material)
+ denst = density(material)
+ rKvol = rlamda + 2.d0*rmu/3.d0
+ cploc = dsqrt((rKvol + 4.d0*rmu/3.d0)/denst)
+ x1 = (cploc-vpmin)/(vpmax-vpmin)
+ endif
+ else
+ x1 = 0.5d0
+ endif
+
+! rescaler pour eviter gris trop sombre
+ x1 = x1*0.7 + 0.2
+ if (x1 > 1.d0) x1=1.d0
+
+! inverser echelle : blanc = vpmin, gris = vpmax
+ x1 = 1.d0 - x1
+
+ xw = coord(1,ibool(i,j,ispec))
+ zw = coord(2,ibool(i,j,ispec))
+ xw = (xw-xmin)*rapp_page + orig_x
+ zw = (zw-zmin)*rapp_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ write(24,500) xw,zw
+ xw = coord(1,ibool(i+isubsamp,j,ispec))
+ zw = coord(2,ibool(i+isubsamp,j,ispec))
+ xw = (xw-xmin)*rapp_page + orig_x
+ zw = (zw-zmin)*rapp_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ write(24,499) xw,zw
+ xw = coord(1,ibool(i+isubsamp,j+isubsamp,ispec))
+ zw = coord(2,ibool(i+isubsamp,j+isubsamp,ispec))
+ xw = (xw-xmin)*rapp_page + orig_x
+ zw = (zw-zmin)*rapp_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ write(24,499) xw,zw
+ xw = coord(1,ibool(i,j+isubsamp,ispec))
+ zw = coord(2,ibool(i,j+isubsamp,ispec))
+ xw = (xw-xmin)*rapp_page + orig_x
+ zw = (zw-zmin)*rapp_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ write(24,499) xw,zw
+ write(24,604) x1
+
+ enddo
+ enddo
+ enddo
+
+ endif
+
+!
+!---- draw spectral element mesh
+!
+
+ if (imeshvect) then
+
+ write(24,*) '%'
+ write(24,*) '% spectral element mesh'
+ write(24,*) '%'
+
+ do ispel=1,nspec
+
+ write(24,*) '% elem ',ispel
+
+ do i=1,iptsdisp
+ do j=1,iptsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispel)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ write(24,*) 'MK'
+ write(24,601) x1,z1
+
+ if (ngnod == 4) then
+
+! tracer des droites si elements 4 noeuds
+
+ ir=iptsdisp
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,601) x2,z2
+
+ ir=iptsdisp
+ is=iptsdisp
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,601) x2,z2
+
+ is=iptsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,601) x2,z2
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,601) x2,z2
+
+ else
+
+! tracer des courbes si elements 9 noeuds
+ do ir=2,iptsdisp
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,601) x2,z2
+ enddo
+
+ ir=iptsdisp
+ do is=2,iptsdisp
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,601) x2,z2
+ enddo
+
+ is=iptsdisp
+ do ir=iptsdisp-1,1,-1
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,601) x2,z2
+ enddo
+
+ ir=1
+ do is=iptsdisp-1,2,-1
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,601) x2,z2
+ enddo
+
+ endif
+
+ write(24,*) 'CO'
+
+ if (icolor == 1) then
+
+! For the moment 20 different colors max
+ nbcols = 20
+
+! Use a different color for each material set
+ imat = kmato(ispel)
+ icol = mod(imat - 1,nbcols) + 1
+
+ write(24,600) red(icol),green(icol),blue(icol)
+
+ endif
+
+ if(imodelvect) then
+ write(24,*) 'GC'
+ else
+ write(24,*) 'GG'
+ endif
+
+! write the element number, the group number and the
+! material number inside the element
+ if (inumber == 1) then
+
+ xw = (coorg(1,knods(1,ispel)) + coorg(1,knods(2,ispel)) + &
+ coorg(1,knods(3,ispel)) + coorg(1,knods(4,ispel))) / 4.d0
+ zw = (coorg(2,knods(1,ispel)) + coorg(2,knods(2,ispel)) + &
+ coorg(2,knods(3,ispel)) + coorg(2,knods(4,ispel))) / 4.d0
+ xw = (xw-xmin)*rapp_page + orig_x
+ zw = (zw-zmin)*rapp_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ if (icolor == 1) write(24,*) '1 setgray'
+
+ write(24,500) xw,zw
+
+!--- ecriture numero de l'element
+ write(24,502) ispel
+
+ endif
+
+ enddo
+
+ endif
+
+!
+!---- draw the boundary conditions
+!
+
+ if((anyabs .or. anyperio) .and. iboundvect) then
+
+ write(24,*) '%'
+ write(24,*) '% boundary conditions on the mesh'
+ write(24,*) '%'
+
+ write(24,*) '0.05 CM SLW'
+
+!--- bords absorbants
+
+ if(anyabs) then
+
+ do ispelabs = 1,nelemabs
+ ispel = numabs(ispelabs)
+
+!--- une couleur pour chaque condition absorbante
+!--- bord absorbant de type "haut" : orange
+!--- bord absorbant de type "bas" : vert clair
+!--- bord absorbant de type "gauche" : rose clair
+!--- bord absorbant de type "droite" : turquoise
+
+ do ibord = 1,4
+
+ if(codeabs(ibord,ispelabs) /= 0) then
+
+ if(ibord == ihaut) then
+ write(24,*) '1. .85 0. RG'
+ ideb = 3
+ ifin = 4
+ else if(ibord == ibas) then
+ write(24,*) '.4 1. .4 RG'
+ ideb = 1
+ ifin = 2
+ else if(ibord == igauche) then
+ write(24,*) '1. .43 1. RG'
+ ideb = 4
+ ifin = 1
+ else if(ibord == idroite) then
+ write(24,*) '.25 1. 1. RG'
+ ideb = 2
+ ifin = 3
+ else
+ stop 'Wrong absorbing boundary code'
+ endif
+
+ x1 = (coorg(1,knods(ideb,ispel))-xmin)*rapp_page + orig_x
+ z1 = (coorg(2,knods(ideb,ispel))-zmin)*rapp_page + orig_z
+ x2 = (coorg(1,knods(ifin,ispel))-xmin)*rapp_page + orig_x
+ z2 = (coorg(2,knods(ifin,ispel))-zmin)*rapp_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,602) x1,z1,x2,z2
+
+ endif
+ enddo
+
+ enddo
+
+ endif
+
+!--- bords periodiques dessines en rouge
+
+ if(anyperio) then
+
+ write(24,*) '1. .15 0.25 RG'
+
+ do n=1,nelemperio
+ numelem = codeperio(1,n)
+ nedgeloc = codeperio(2,n)
+ num2 = codeperio(3,n)
+ nedgeother = codeperio(4,n)
+
+! dessin premiere arete
+ if(nedgeloc == iaretehaut) then
+ ideb = 3
+ ifin = 4
+ else if(nedgeloc == iaretebas) then
+ ideb = 1
+ ifin = 2
+ else if(nedgeloc == iaretegauche) then
+ ideb = 4
+ ifin = 1
+ else if(nedgeloc == iaretedroite) then
+ ideb = 2
+ ifin = 3
+ endif
+
+ x1 = (coorg(1,knods(ideb,numelem))-xmin)*rapp_page + orig_x
+ z1 = (coorg(2,knods(ideb,numelem))-zmin)*rapp_page + orig_z
+ x2 = (coorg(1,knods(ifin,numelem))-xmin)*rapp_page + orig_x
+ z2 = (coorg(2,knods(ifin,numelem))-zmin)*rapp_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,602) x1,z1,x2,z2
+
+! dessin arete correspondante
+ if(nedgeother == iaretehaut) then
+ ideb = 3
+ ifin = 4
+ else if(nedgeother == iaretebas) then
+ ideb = 1
+ ifin = 2
+ else if(nedgeother == iaretegauche) then
+ ideb = 4
+ ifin = 1
+ else if(nedgeother == iaretedroite) then
+ ideb = 2
+ ifin = 3
+ endif
+
+ x1 = (coorg(1,knods(ideb,num2))-xmin)*rapp_page + orig_x
+ z1 = (coorg(2,knods(ideb,num2))-zmin)*rapp_page + orig_z
+ x2 = (coorg(1,knods(ifin,num2))-xmin)*rapp_page + orig_x
+ z2 = (coorg(2,knods(ifin,num2))-zmin)*rapp_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,602) x1,z1,x2,z2
+
+ enddo
+
+ endif
+
+ write(24,*) '0 setgray'
+ write(24,*) '0.01 CM SLW'
+
+ endif
+
+!
+!---- draw the normalized displacement field
+!
+
+! return if the maximum displacement equals zero (no source)
+ if (dispmax == 0.d0) then
+ print *,' null displacement : returning !'
+ return
+ endif
+
+ write(24,*) '%'
+ write(24,*) '% vector field'
+ write(24,*) '%'
+
+! fleches en couleur si modele de vitesse en background
+ if(imodelvect) then
+ write(24,*) 'Colvects'
+ else
+ write(24,*) '0 setgray'
+ endif
+
+ if (interpol) then
+
+ print *,'Interpolating the vector field...'
+
+ do ispel=1,nspec
+
+! interpolation sur grille reguliere
+ if(mod(ispel,100) == 0) &
+ write(*,*) 'Interpolation uniform grid element ',ispel
+
+ do i=1,iptsdisp
+ do j=1,iptsdisp
+
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispel)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+
+ Uxinterp(i,j) = 0.d0
+ Uzinterp(i,j) = 0.d0
+
+ do k=0,nxgll-1
+ do l=0,nxgll-1
+
+ Uxinterp(i,j) = Uxinterp(i,j) + &
+ displ(1,ibool(k,l,ispel))*flagrange(k,i)*flagrange(l,j)
+ Uzinterp(i,j) = Uzinterp(i,j) + &
+ displ(2,ibool(k,l,ispel))*flagrange(k,i)*flagrange(l,j)
+
+ enddo
+ enddo
+
+ x1 =(xinterp(i,j)-xmin)*rapp_page
+ z1 =(zinterp(i,j)-zmin)*rapp_page
+
+ x2 = Uxinterp(i,j)*sizemax/dispmax
+ z2 = Uzinterp(i,j)*sizemax/dispmax
+
+ d = dsqrt(x2**2 + z2**2)
+
+! ignorer si vecteur trop petit
+ if (d > cutvect*sizemax) then
+
+ d1 = d * rapport
+ d2 = d1 * dcos(angle*convert)
+
+ dummy = x2/d
+ if (dummy > 0.9999d0) dummy = 0.9999d0
+ if (dummy < -0.9999d0) dummy = -0.9999d0
+ theta = dacos(dummy)
+
+ if(z2 < 0.d0) theta = 360.d0*convert - theta
+ thetaup = theta - angle*convert
+ thetadown = theta + angle*convert
+
+! tracer le vecteur proprement dit
+ x1 = (orig_x+x1) * centim
+ z1 = (orig_z+z1) * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ xa = -d2*dcos(thetaup)
+ za = -d2*dsin(thetaup)
+ xa = xa * centim
+ za = za * centim
+ xb = -d2*dcos(thetadown)
+ zb = -d2*dsin(thetadown)
+ xb = xb * centim
+ zb = zb * centim
+ write(name,700) xb,zb,xa,za,x2,z2,x1,z1
+
+! filtrer les blancs inutiles pour diminuer taille fichier PostScript
+ longueur = 49
+ indice = 1
+ first = .false.
+ do ii=1,longueur-1
+ if(ch1(ii) /= ' '.or.first) then
+ if(ch1(ii) /= ' '.or.ch1(ii+1) /= ' ') then
+ ch2(indice) = ch1(ii)
+ indice = indice + 1
+ first = .true.
+ endif
+ endif
+ enddo
+ ch2(indice) = ch1(longueur)
+ write(24,200) (ch2(ii),ii=1,indice)
+
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ else
+! tracer les vecteurs deplacement aux noeuds du maillage
+
+ do ipoin=1,npoin
+
+ x1 =(coord(1,ipoin)-xmin)*rapp_page
+ z1 =(coord(2,ipoin)-zmin)*rapp_page
+
+ x2 = displ(1,ipoin)*sizemax/dispmax
+ z2 = displ(2,ipoin)*sizemax/dispmax
+
+ d = dsqrt(x2**2 + z2**2)
+
+! ignorer si vecteur trop petit
+ if (d > cutvect*sizemax) then
+
+ d1 = d * rapport
+ d2 = d1 * dcos(angle*convert)
+
+ dummy = x2/d
+ if (dummy > 0.9999d0) dummy = 0.9999d0
+ if (dummy < -0.9999d0) dummy = -0.9999d0
+ theta = dacos(dummy)
+
+ if(z2 < 0.d0) theta = 360.d0*convert - theta
+ thetaup = theta - angle*convert
+ thetadown = theta + angle*convert
+
+! tracer le vecteur proprement dit
+ x1 = (orig_x+x1) * centim
+ z1 = (orig_z+z1) * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ xa = -d2*dcos(thetaup)
+ za = -d2*dsin(thetaup)
+ xa = xa * centim
+ za = za * centim
+ xb = -d2*dcos(thetadown)
+ zb = -d2*dsin(thetadown)
+ xb = xb * centim
+ zb = zb * centim
+ write(name,700) xb,zb,xa,za,x2,z2,x1,z1
+
+! filtrer les blancs inutiles pour diminuer taille fichier PostScript
+ longueur = 49
+ indice = 1
+ first = .false.
+ do ii=1,longueur-1
+ if(ch1(ii) /= ' '.or.first) then
+ if(ch1(ii) /= ' '.or.ch1(ii+1) /= ' ') then
+ ch2(indice) = ch1(ii)
+ indice = indice + 1
+ first = .true.
+ endif
+ endif
+ enddo
+ ch2(indice) = ch1(longueur)
+ write(24,200) (ch2(ii),ii=1,indice)
+
+ endif
+
+ enddo
+
+ endif
+
+ write(24,*) '0 setgray'
+
+ 200 format(80(a1))
+ 499 format(f5.1,1x,f5.1,' L')
+ 500 format(f5.1,1x,f5.1,' M')
+ 502 format('fN (',i4,') Cshow')
+ 600 format(f4.2,1x,f4.2,1x,f4.2,' RG GF')
+ 601 format(f6.2,1x,f6.2)
+ 602 format(f6.2,1x,f6.2,' M ',f6.2,1x,f6.2,' L ST')
+ 604 format('CP ',f4.2,' BK')
+ 700 format(8(f5.1,1x),'F')
+
+ end subroutine plotvect
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/pndleg.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/pndleg.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/pndleg.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,46 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ double precision FUNCTION PNDLEG (Z,N)
+!-------------------------------------------------------------
+!
+! Compute the derivative of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!-------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P1D,P2D,P3D,FK,P3
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P1D = 0.d0
+ P2D = 1.d0
+ P3D = 1.d0
+ DO 10 K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P3D = ((2.d0*FK+1.d0)*P2 + (2.d0*FK+1.d0)*Z*P2D - FK*P1D) &
+ /(FK+1.d0)
+ P1 = P2
+ P2 = P3
+ P1D = P2D
+ P2D = P3D
+ 10 CONTINUE
+ PNDLEG = P3D
+ RETURN
+ end function pndleg
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/pnleg.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/pnleg.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/pnleg.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,40 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ double precision FUNCTION PNLEG (Z,N)
+!-------------------------------------------------------------
+!
+! Compute the value of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!-------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P3,FK
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P3 = P2
+ DO 10 K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P1 = P2
+ P2 = P3
+ 10 CONTINUE
+ PNLEG = P3
+ RETURN
+ end function pnleg
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/pnormj.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/pnormj.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/pnormj.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,54 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ double precision function pnormj (n,alpha,beta)
+!
+!=======================================================================
+!
+! P n o r m j
+! -----------
+!
+!=======================================================================
+!
+ implicit none
+
+ double precision alpha,beta
+ integer n
+
+ double precision one,two,dn,const,prod,dindx,frac
+ double precision, external :: gammaf
+ integer i
+
+ one = 1.d0
+ two = 2.d0
+ dn = dble(n)
+ const = alpha+beta+one
+ if (n <= 1) then
+ prod = gammaf(dn+alpha)*gammaf(dn+beta)
+ prod = prod/(gammaf(dn)*gammaf(dn+alpha+beta))
+ pnormj = prod * two**const/(two*dn+const)
+ return
+ endif
+ prod = gammaf(alpha+one)*gammaf(beta+one)
+ prod = prod/(two*(one+const)*gammaf(const+one))
+ prod = prod*(one+alpha)*(two+alpha)
+ prod = prod*(one+beta)*(two+beta)
+ do 100 i=3,n
+ dindx = dble(i)
+ frac = (dindx+alpha)*(dindx+beta)/(dindx*(dindx+alpha+beta))
+ prod = prod*frac
+ 100 continue
+ pnormj = prod * two**const/(two*dn+const)
+
+ return
+ end function pnormj
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/positrec.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/positrec.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/positrec.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,78 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine positrec(coord,posrec,ndime,npoin,nrec)
+
+!
+!---- calculer la position reelle des recepteurs
+!
+
+ use iounit
+
+ implicit none
+
+ integer ndime,npoin,nrec
+ double precision coord(ndime,npoin)
+ double precision posrec(ndime,nrec)
+
+ double precision dminmax,dmin,xs,zs,xp,zp,dist
+ integer n,ip,ipoint
+
+ write(iout,200)
+
+ dminmax = -1.d30
+
+ do n=1,nrec
+
+ dmin = +1.d30
+
+! coordonnees demandees
+ xs = posrec(1,n)
+ zs = posrec(2,n)
+
+ do ip=1,npoin
+
+! coordonnees du point de grille
+ xp = coord(1,ip)
+ zp = coord(2,ip)
+
+ dist = dsqrt((xp-xs)**2 + (zp-zs)**2)
+
+! retenir le point pour lequel l'ecart est minimal
+ if (dist < dmin) then
+ dmin = dist
+ ipoint = ip
+ endif
+
+ enddo
+
+ dminmax = dmax1(dmin,dminmax)
+
+ write(iout,150) n,xs,zs,coord(1,ipoint),coord(2,ipoint),dmin
+
+! stocker numero global dans premiere coordonnee
+ posrec(1,n) = dble(ipoint)
+
+ enddo
+
+ write(iout,160) dminmax
+
+ 150 format(1x,i7,1x,f12.3,1x,f12.3,1x,f12.3,1x,f12.3,f12.3)
+ 160 format(/2x,'Maximum distance between asked and real =',f12.3)
+ 200 format(//1x,51('=')/,' = R e c e i v e r s ', &
+ 'r e a l p o s i t i o n s ='/1x,51('=')// &
+ ' Receiver x-asked z-asked ', &
+ 'x-obtain z-obtain dist'/)
+
+ return
+ end subroutine positrec
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/positsource.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/positsource.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/positsource.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,102 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine positsource(coord,ibool,gltfu,ndime,npoin,nltfl,nxgll,nygll,nspec)
+
+!
+!----- calculer la position reelle des sources
+!
+
+ use iounit
+
+ implicit none
+
+ integer ndime,npoin,nltfl,nxgll,nygll,nspec
+ double precision coord(ndime,npoin)
+ double precision gltfu(20,nltfl)
+ integer ibool(0:nxgll-1,0:nygll-1,nspec)
+
+ double precision dminmax,dmin,xs,zs,xp,zp,dist
+ integer n,ip,ipoint,ix,iy,numelem,ilowx,ilowy,ihighx,ihighy
+
+ write(iout,200)
+
+ dminmax = -1.d30
+
+ do n=1,nltfl
+
+ dmin = +1.d30
+
+! coordonnees demandees pour la source
+ xs = gltfu(3,n)
+ zs = gltfu(4,n)
+
+ ilowx = 0
+ ilowy = 0
+ ihighx = nxgll-1
+ ihighy = nygll-1
+
+! on ne fait la recherche que sur l'interieur de l'element si source explosive
+ if(nint(gltfu(2,n)) == 2) then
+ ilowx = 1
+ ilowy = 1
+ ihighx = nxgll-2
+ ihighy = nygll-2
+ endif
+
+! recherche du point de grille le plus proche
+ do numelem=1,nspec
+ do ix=ilowx,ihighx
+ do iy=ilowy,ihighy
+
+! numero global du point
+ ip=ibool(ix,iy,numelem)
+
+! coordonnees du point de grille
+ xp = coord(1,ip)
+ zp = coord(2,ip)
+
+ dist = dsqrt((xp-xs)**2 + (zp-zs)**2)
+
+! retenir le point pour lequel l'ecart est minimal
+ if (dist < dmin) then
+ dmin = dist
+ gltfu(9,n) = ip
+ gltfu(10,n) = ix
+ gltfu(11,n) = iy
+ gltfu(12,n) = numelem
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ ipoint = nint(gltfu(9,n))
+
+ dminmax = dmax1(dmin,dminmax)
+
+ write(iout,150) n,xs,zs,coord(1,ipoint),coord(2,ipoint),dmin
+
+ enddo
+
+ write(iout,160) dminmax
+
+ 150 format(1x,i7,1x,f12.3,1x,f12.3,1x,f12.3,1x,f12.3,f12.3)
+ 160 format(/2x,'Maximum distance between asked and real =',f12.3)
+ 200 format(//1x,48('=')/,' = S o u r c e s ', &
+ 'r e a l p o s i t i o n s ='/1x,48('=')// &
+ ' Source x-asked z-asked ', &
+ 'x-obtain z-obtain dist'/)
+
+ return
+ end subroutine positsource
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/q49shape.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/q49shape.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/q49shape.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,174 @@
+
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine q49shape(shape,dershape,xi,yi,ngnod,nxgll,nygll,ndime)
+!
+!=======================================================================
+!
+! "q 4 9 s h a p e" : set up the shape functions and their derivatives
+! for the isoparametric transformation of the
+! spectral macroblocs.
+! The routine is able to deal with
+! 4 or 9 control nodes for each bloc.
+! The control nodes are defined as follows:
+!
+! 4 . . . . 7 . . . . 3
+! . .
+! . t .
+! . .
+! 8 9 s 6
+! . .
+! . .
+! . .
+! 1 . . . . 5 . . . . 2
+!
+! Local coordinate system : s,t
+!
+!=======================================================================
+!
+
+ implicit none
+
+ integer ngnod,nxgll,nygll,ndime
+
+ double precision shape(ngnod,nxgll,nxgll)
+ double precision dershape(ndime,ngnod,nxgll,nxgll)
+ double precision xi(nxgll),yi(nygll)
+
+ double precision, parameter :: &
+ zero=0.d0,one=1.d0,two=2.d0,half=0.5d0,quart=0.25d0
+
+ integer l1,l2
+ double precision s,sp,sm,t,tp,tm,s2,t2,ss,tt,st
+
+ double precision, external :: hgll
+
+!
+!-----------------------------------------------------------------------
+!
+
+!
+!---- set up the shape functions and their local derivatives
+!
+ if(ngnod == 4) then
+!
+!---- 4-noded rectangular element
+!
+ do l2 = 1,nygll
+
+ t = yi(l2)
+
+ do l1 = 1,nxgll
+
+ s = xi(l1)
+
+ sp = s + one
+ sm = s - one
+ tp = t + one
+ tm = t - one
+
+!
+!---- corner nodes
+!
+ shape(1,l1,l2) = quart * sm * tm
+ shape(2,l1,l2) = - quart * sp * tm
+ shape(3,l1,l2) = quart * sp * tp
+ shape(4,l1,l2) = - quart * sm * tp
+
+ dershape(1,1,l1,l2) = quart * tm
+ dershape(1,2,l1,l2) = - quart * tm
+ dershape(1,3,l1,l2) = quart * tp
+ dershape(1,4,l1,l2) = - quart * tp
+
+ dershape(2,1,l1,l2) = quart * sm
+ dershape(2,2,l1,l2) = - quart * sp
+ dershape(2,3,l1,l2) = quart * sp
+ dershape(2,4,l1,l2) = - quart * sm
+
+ enddo
+ enddo
+
+ else if(ngnod == 9) then
+!
+!---- 9-noded rectangular element
+!
+ do l2 = 1,nygll
+
+ t = yi(l2)
+
+ do l1 = 1,nxgll
+
+ s = xi(l1)
+
+ sp = s + one
+ sm = s - one
+ tp = t + one
+ tm = t - one
+ s2 = s * two
+ t2 = t * two
+ ss = s * s
+ tt = t * t
+ st = s * t
+
+!
+!---- corner nodes
+!
+ shape(1,l1,l2) = quart * sm * st * tm
+ shape(2,l1,l2) = quart * sp * st * tm
+ shape(3,l1,l2) = quart * sp * st * tp
+ shape(4,l1,l2) = quart * sm * st * tp
+
+ dershape(1,1,l1,l2) = quart * tm * t * (s2 - one)
+ dershape(1,2,l1,l2) = quart * tm * t * (s2 + one)
+ dershape(1,3,l1,l2) = quart * tp * t * (s2 + one)
+ dershape(1,4,l1,l2) = quart * tp * t * (s2 - one)
+
+ dershape(2,1,l1,l2) = quart * sm * s * (t2 - one)
+ dershape(2,2,l1,l2) = quart * sp * s * (t2 - one)
+ dershape(2,3,l1,l2) = quart * sp * s * (t2 + one)
+ dershape(2,4,l1,l2) = quart * sm * s * (t2 + one)
+!
+!---- midside nodes
+!
+ shape(5,l1,l2) = half * tm * t * (one - ss)
+ shape(6,l1,l2) = half * sp * s * (one - tt)
+ shape(7,l1,l2) = half * tp * t * (one - ss)
+ shape(8,l1,l2) = half * sm * s * (one - tt)
+
+ dershape(1,5,l1,l2) = -one * st * tm
+ dershape(1,6,l1,l2) = half * (one - tt) * (s2 + one)
+ dershape(1,7,l1,l2) = -one * st * tp
+ dershape(1,8,l1,l2) = half * (one - tt) * (s2 - one)
+
+ dershape(2,5,l1,l2) = half * (one - ss) * (t2 - one)
+ dershape(2,6,l1,l2) = -one * st * sp
+ dershape(2,7,l1,l2) = half * (one - ss) * (t2 + one)
+ dershape(2,8,l1,l2) = -one * st * sm
+!
+!---- center node
+!
+ shape(9,l1,l2) = (one - ss) * (one - tt)
+
+ dershape(1,9,l1,l2) = -one * s2 * (one - tt)
+ dershape(2,9,l1,l2) = -one * t2 * (one - ss)
+
+ enddo
+ enddo
+
+ else
+ stop 'Error : wrong number of control nodes !!'
+ endif
+
+ return
+ end subroutine q49shape
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/q49spec.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/q49spec.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/q49spec.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,209 @@
+
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine q49spec(shape,shapeint,dershape,dvolu,xjaci,xi,yi, &
+ coorg,knods,ngnod,nxgll,nygll,ndime,nspec,npgeo, &
+ xirec,etarec,flagrange,iptsdisp)
+!
+!=======================================================================
+!
+! "q 4 9 s p e c" : set up the jacobian matrix
+! for the isoparametric transformation of the
+! spectral macroblocs.
+! The routine is able to deal with
+! 4 or 9 control nodes for each bloc.
+! The control nodes are defined as follows:
+!
+! 4 . . . . 7 . . . . 3
+! . .
+! . t .
+! . .
+! 8 9 s 6
+! . .
+! . .
+! . .
+! 1 . . . . 5 . . . . 2
+!
+! Local coordinate system : s,t
+!
+!=======================================================================
+!
+
+ implicit none
+
+ integer ngnod,nxgll,nygll,ndime,nspec,npgeo,iptsdisp
+
+ integer knods(ngnod,nspec)
+ double precision shape(ngnod,nxgll,nxgll)
+ double precision shapeint(ngnod,iptsdisp,iptsdisp)
+ double precision dershape(ndime,ngnod,nxgll,nxgll)
+ double precision dvolu(nspec,nxgll,nxgll)
+ double precision xjaci(nspec,ndime,ndime,nxgll,nxgll)
+ double precision coorg(ndime,npgeo)
+ double precision xi(nxgll),yi(nygll)
+ double precision xirec(iptsdisp),etarec(iptsdisp)
+ double precision flagrange(0:nxgll-1,iptsdisp)
+
+ double precision, parameter :: &
+ zero=0.d0,one=1.d0,two=2.d0,half=0.5d0,quart=0.25d0
+
+ integer l1,l2,ispel,in,nnum,ip1,ip2,i,k
+ double precision s,sp,sm,t,tp,tm,s2,t2,ss,tt,st
+ double precision xjac2_11,xjac2_21,xjac2_12,xjac2_22
+
+ double precision, external :: hgll
+
+!
+!-----------------------------------------------------------------------
+!
+
+!
+!---- compute the jacobian matrix at the integration points
+!
+
+ do ispel = 1,nspec
+
+ do ip1 = 1,nxgll
+ do ip2 = 1,nygll
+
+ xjac2_11 = zero
+ xjac2_21 = zero
+ xjac2_12 = zero
+ xjac2_22 = zero
+
+ do in = 1,ngnod
+
+ nnum = knods(in,ispel)
+
+ xjac2_11 = xjac2_11 + dershape(1,in,ip1,ip2)*coorg(1,nnum)
+ xjac2_21 = xjac2_21 + dershape(1,in,ip1,ip2)*coorg(2,nnum)
+ xjac2_12 = xjac2_12 + dershape(2,in,ip1,ip2)*coorg(1,nnum)
+ xjac2_22 = xjac2_22 + dershape(2,in,ip1,ip2)*coorg(2,nnum)
+
+ enddo
+
+!
+!---- invert the jacobian matrix
+!
+
+ dvolu(ispel,ip1,ip2) = xjac2_11*xjac2_22 - xjac2_12*xjac2_21
+
+ if (dvolu(ispel,ip1,ip2) <= zero) stop 'Error : Jacobian undefined !!'
+
+ xjaci(ispel,1,1,ip1,ip2) = xjac2_22 / dvolu(ispel,ip1,ip2)
+ xjaci(ispel,2,1,ip1,ip2) = - xjac2_21 / dvolu(ispel,ip1,ip2)
+ xjaci(ispel,1,2,ip1,ip2) = - xjac2_12 / dvolu(ispel,ip1,ip2)
+ xjaci(ispel,2,2,ip1,ip2) = xjac2_11 / dvolu(ispel,ip1,ip2)
+
+ enddo
+ enddo
+
+ enddo
+
+!---- calcul des coordonnees interpolees avec les fonctions de forme
+!---- interpolation sur grille reguliere en (xi,eta)
+
+ do i=1,iptsdisp
+ xirec(i) = 2.d0*dble(i-1)/dble(iptsdisp-1) - 1.d0
+ etarec(i) = 2.d0*dble(i-1)/dble(iptsdisp-1) - 1.d0
+ enddo
+
+!---- calcul des interpolateurs de Lagrange (suppose nxgll = nygll)
+ do i=0,nxgll-1
+ do k=1,iptsdisp
+ flagrange(i,k) = hgll(i,xirec(k),xi,nxgll)
+ enddo
+ enddo
+
+!
+!---- set up the shape functions for the interpolated grid
+!
+ if(ngnod == 4) then
+!
+!---- 4-noded rectangular element
+!
+ do l2 = 1,iptsdisp
+
+ t = etarec(l2)
+
+ do l1 = 1,iptsdisp
+
+ s = xirec(l1)
+
+ sp = s + one
+ sm = s - one
+ tp = t + one
+ tm = t - one
+
+!
+!---- corner nodes
+!
+ shapeint(1,l1,l2) = quart * sm * tm
+ shapeint(2,l1,l2) = - quart * sp * tm
+ shapeint(3,l1,l2) = quart * sp * tp
+ shapeint(4,l1,l2) = - quart * sm * tp
+
+ enddo
+ enddo
+
+ else if(ngnod == 9) then
+!
+!---- 9-noded rectangular element
+!
+ do l2 = 1,iptsdisp
+
+ t = etarec(l2)
+
+ do l1 = 1,iptsdisp
+
+ s = xirec(l1)
+
+ sp = s + one
+ sm = s - one
+ tp = t + one
+ tm = t - one
+ s2 = s * two
+ t2 = t * two
+ ss = s * s
+ tt = t * t
+ st = s * t
+
+!
+!---- corner nodes
+!
+ shapeint(1,l1,l2) = quart * sm * st * tm
+ shapeint(2,l1,l2) = quart * sp * st * tm
+ shapeint(3,l1,l2) = quart * sp * st * tp
+ shapeint(4,l1,l2) = quart * sm * st * tp
+
+!
+!---- midside nodes
+!
+ shapeint(5,l1,l2) = half * tm * t * (one - ss)
+ shapeint(6,l1,l2) = half * sp * s * (one - tt)
+ shapeint(7,l1,l2) = half * tp * t * (one - ss)
+ shapeint(8,l1,l2) = half * sm * s * (one - tt)
+
+!
+!---- center node
+!
+ shapeint(9,l1,l2) = (one - ss) * (one - tt)
+
+ enddo
+ enddo
+
+ endif
+
+ return
+ end subroutine q49spec
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/qinpspec.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/qinpspec.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/qinpspec.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,141 @@
+
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine qinpspec(density,elastcoef,xi,yi,wx,wy,knods, &
+ ibool,kmato,shape,shapeint,dershape,dvolu,xjaci, &
+ coorg,xirec,etarec,flagrange, &
+ numabs,codeabs,codeperio,anyabs,anyperio)
+!
+!=======================================================================
+!
+! "q i n p s p e c" : Read, generate and write data for the spectral
+! elements
+!
+!=======================================================================
+!
+
+ use iounit
+ use infos
+ use mesh01
+ use spela202
+
+ implicit none
+
+ double precision, parameter :: zero=0.d0
+ double precision, parameter :: gaussalpha=zero,gaussbeta=zero
+
+! choix entre version lente et rapide pour la numerotation globale
+ logical, parameter :: fast_numbering = .false.
+
+ integer knods(ngnod,nspec),kmato(nspec),ibool(0:nxgll-1,0:nxgll-1,nspec)
+
+ double precision density(numat),elastcoef(4,numat), &
+ xi(0:nxgll-1),yi(0:nygll-1),wx(0:nxgll-1),wy(0:nxgll-1), &
+ dvolu(nspec,nxgll,nxgll),xjaci(nspec,ndime,ndime,nxgll,nxgll), &
+ coorg(ndime,npgeo)
+ double precision shape(ngnod,nxgll,nxgll)
+ double precision shapeint(ngnod,iptsdisp,iptsdisp)
+ double precision dershape(ndime,ngnod,nxgll,nxgll)
+ double precision xirec(iptsdisp),etarec(iptsdisp)
+ double precision flagrange(0:nxgll-1,iptsdisp)
+
+ integer numabs(nelemabs),codeabs(4,nelemabs)
+ integer codeperio(4,nelemperio)
+ logical anyabs,anyperio
+
+ integer nelemabs2,nelemperio2
+
+!
+!-----------------------------------------------------------------------
+!
+
+! check that numbering is fine (no fast numbering if periodic conditions)
+ if(fast_numbering .and. anyperio) stop 'no fast numbering if periodic conditions'
+
+!
+!---- print element group main parameters
+!
+ nelemabs2 = nelemabs
+ nelemperio2 = nelemperio
+ if(.not. anyabs) nelemabs2 = 0
+ if(.not. anyperio) nelemperio2 = 0
+ if(iecho /= 0) then
+ write(iout,100)
+ write(iout,200) nspec,ngnod,nxgll, &
+ nygll,nxgll*nygll,iptsdisp,numat,nelemabs2,nelemperio2
+ endif
+
+!
+!---- set up coordinates of the Gauss-Lobatto-Legendre points
+!
+ call zwgljd(xi,wx,nxgll,gaussalpha,gaussbeta)
+ call zwgljd(yi,wy,nygll,gaussalpha,gaussbeta)
+
+!
+!---- if nb of points is odd, the middle abscissa is exactly zero
+!
+ if(mod(nxgll,2) /= 0) xi((nxgll-1)/2) = zero
+ if(mod(nygll,2) /= 0) yi((nygll-1)/2) = zero
+
+!
+!---- read the material properties
+!
+ call gmat01(density,elastcoef,numat)
+
+!
+!---- read topology and material number for spectral elements
+!
+ call getelspec(knods,ibool,kmato,npoin,numabs,codeabs,codeperio,anyabs,anyperio)
+
+!
+!---- compute the spectral element shape functions and their local derivatives
+!
+ call q49shape(shape,dershape,xi,yi,ngnod,nxgll,nygll,ndime)
+
+!
+!---- generate the global numbering
+!
+
+! version "propre mais lente" ou version "sale mais rapide"
+ if(fast_numbering) then
+ call createnum_fast(knods,ibool,kmato,shape,coorg,npoin,ndime,npgeo)
+ else
+ call createnum_slow(knods,ibool,kmato,npoin)
+ endif
+
+!
+!---- compute the spectral element jacobian matrix
+!
+
+ call q49spec(shape,shapeint,dershape,dvolu,xjaci,xi,yi,coorg, &
+ knods,ngnod,nxgll,nygll,ndime,nspec,npgeo, &
+ xirec,etarec,flagrange,iptsdisp)
+
+ return
+!
+!---- formats
+!
+ 100 format(/5x,'--> Isoparametric Spectral Elements <--',//)
+ 200 format(5x, &
+ 'Number of spectral elements . . . . . (nspec) =',i7,/5x, &
+ 'Number of control nodes per element . (ngnod) =',i7,/5x, &
+ 'Number of points in X-direction . . . (nxgll) =',i7,/5x, &
+ 'Number of points in Y-direction . . . (nygll) =',i7,/5x, &
+ 'Number of points per element. . .(nxgll*nygll) =',i7,/5x, &
+ 'Number of points for display . . . .(iptsdisp) =',i7,/5x, &
+ 'Number of element material sets . . . (numat) =',i7,/5x, &
+ 'Number of absorbing elements . . . .(nelemabs) =',i7,/5x, &
+ 'Number of periodic elements. . . .(nelemperio) =',i7)
+
+ end subroutine qinpspec
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/qmasspec.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/qmasspec.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/qmasspec.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,72 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine qmasspec(rhoext,wx,wy,ibool,dvolu,rmass,density,kmato,npoin)
+!
+!=======================================================================
+!
+! "q m a s s p e c" : Build the mass matrix for the spectral
+! elements
+!
+!=======================================================================
+!
+ use spela202
+ use constspec
+
+ implicit none
+
+ integer npoin
+
+ double precision wx(0:nxgll-1),wy(0:nygll-1),rmass(npoin), &
+ dvolu(nspec,0:nxgll-1,0:nxgll-1),density(numat)
+ double precision rhoext(npoin)
+
+ integer kmato(nspec),ibool(0:nxgll-1,0:nxgll-1,nspec)
+
+ integer numelem,material,i,j,iglobnum
+ double precision denst
+
+ double precision, parameter :: zero=0.d0, one=1.d0
+
+!
+!---- compute the mass matrix by summing the contribution of each point
+!
+
+ rmass = zero
+
+ do numelem = 1,nspec
+
+ material = kmato(numelem)
+ denst = density(material)
+
+ do i=0,nxgll-1
+ do j=0,nygll-1
+
+ iglobnum = ibool(i,j,numelem)
+
+!--- si formulation heterogene pour un modele de densite externe
+ if(ireadmodel) denst = rhoext(iglobnum)
+
+ rmass(iglobnum) = rmass(iglobnum) + &
+ denst * wx(i) * wy(j) * dvolu(numelem,i,j)
+
+ enddo
+ enddo
+
+ enddo
+
+!---- in case of periodic boundary conditions, fill the mass matrix
+ where(rmass == zero) rmass = one
+
+ return
+ end subroutine qmasspec
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/qsumspec.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/qsumspec.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/qsumspec.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,222 @@
+
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine qsumspec(hprime,hTprime, &
+ a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13x,a13z,force, &
+ ibool,displ,veloc,accel,Uxnewloc,Uznewloc, &
+ rmass,nxgll,npoin,ndime,nspec,gltfu,nltfl,initialfield, &
+ numabs,is_bordabs,nelemabs,anyabs)
+
+ use timeparams
+
+ implicit none
+
+ integer nxgll,npoin,ndime,nspec,nltfl,nelemabs
+ logical anyabs
+
+ double precision hprime(nxgll,nxgll),hTprime(nxgll,nxgll)
+ double precision a1(nxgll,nxgll,nspec),a2(nxgll,nxgll,nspec), &
+ a3(nxgll,nxgll,nspec),a4(nxgll,nxgll,nspec),a5(nxgll,nxgll,nspec), &
+ a6(nxgll,nxgll,nspec),a7(nxgll,nxgll,nspec), &
+ a8(nxgll,nxgll,nspec),a9(nxgll,nxgll,nspec),a10(nxgll,nxgll,nspec)
+ double precision a11(nxgll,nxgll,nltfl),a12(nxgll,nxgll,nltfl)
+ double precision a13x(nxgll,nxgll,nelemabs)
+ double precision a13z(nxgll,nxgll,nelemabs)
+ double precision Uxnewloc(nxgll,nxgll,nspec)
+ double precision Uznewloc(nxgll,nxgll,nspec)
+
+ integer numabs(nelemabs)
+ integer is_bordabs(nspec)
+
+! petits tableaux locaux (could be suppressed if needed)
+! maxnxgll est la valeur maximale possible du degre polynomial (10 par exemple)
+ integer, parameter :: maxnxgll = 10
+ double precision Uxoldloc(maxnxgll,maxnxgll)
+ double precision Uzoldloc(maxnxgll,maxnxgll)
+ double precision t1(maxnxgll,maxnxgll)
+ double precision t2(maxnxgll,maxnxgll)
+ double precision t3(maxnxgll,maxnxgll)
+ double precision t4(maxnxgll,maxnxgll)
+
+ double precision dUx_dxi,dUz_dxi,dUx_deta,dUz_deta
+ double precision hprimex,hTprimex,hprimez,hTprimez
+
+ integer ibool(nxgll,nxgll,nspec)
+
+ double precision rmass(npoin)
+ double precision force(ndime,nltfl)
+ double precision displ(ndime,npoin),veloc(ndime,npoin),accel(ndime,npoin)
+
+ double precision gltfu(20,nltfl)
+
+ double precision, external :: dirac,ricker
+
+ integer i,j,k,l,n,isource,ielems,iglobsource,iglobnum,ip,numer_abs
+ double precision sig
+ logical initialfield
+
+ double precision, parameter :: zero=0.d0
+
+! main loop on all the spectral elements
+ do k=1,nspec
+
+! map the global displacement field to the local mesh
+ do j=1,nxgll
+ do i=1,nxgll
+ iglobnum = ibool(i,j,k)
+ Uxoldloc(i,j) = displ(1,iglobnum)
+ Uzoldloc(i,j) = displ(2,iglobnum)
+ enddo
+ enddo
+
+ do j=1,nxgll
+ do i=1,nxgll
+
+! compute the gradient of the displacement field (matrix products)
+ dUx_dxi = zero
+ dUz_dxi = zero
+ dUx_deta = zero
+ dUz_deta = zero
+
+ do l=1,nxgll
+
+ hTprimex = hTprime(i,l)
+ hprimez = hprime(l,j)
+
+ dUx_dxi = dUx_dxi + hTprimex*Uxoldloc(l,j)
+ dUz_dxi = dUz_dxi + hTprimex*Uzoldloc(l,j)
+ dUx_deta = dUx_deta + Uxoldloc(i,l)*hprimez
+ dUz_deta = dUz_deta + Uzoldloc(i,l)*hprimez
+
+ enddo
+
+! compute the local arrays using the components of the stiffness matrix
+ t1(i,j) = a1(i,j,k)*dUx_dxi + a2(i,j,k)*dUx_deta + &
+ a3(i,j,k)*dUz_dxi + a4(i,j,k)*dUz_deta
+ t2(i,j) = a2(i,j,k)*dUx_dxi + a6(i,j,k)*dUx_deta + &
+ a7(i,j,k)*dUz_dxi + a8(i,j,k)*dUz_deta
+ t3(i,j)= a3(i,j,k)*dUx_dxi + a7(i,j,k)*dUx_deta + &
+ a9(i,j,k)*dUz_dxi + a10(i,j,k)*dUz_deta
+ t4(i,j)= a4(i,j,k)*dUx_dxi + a8(i,j,k)*dUx_deta + &
+ a10(i,j,k)*dUz_dxi + a5(i,j,k)*dUz_deta
+
+ enddo
+ enddo
+
+! compute the local forces (sum of two matrix products)
+ do j=1,nxgll
+ do i=1,nxgll
+ Uxnewloc(i,j,k) = zero
+ Uznewloc(i,j,k) = zero
+
+ do l=1,nxgll
+
+ hprimex = hprime(i,l)
+ hTprimez = hTprime(l,j)
+
+ Uxnewloc(i,j,k) = Uxnewloc(i,j,k) + &
+ hprimex*t1(l,j) + t2(i,l)*hTprimez
+ Uznewloc(i,j,k) = Uznewloc(i,j,k) + &
+ hprimex*t3(l,j) + t4(i,l)*hTprimez
+
+ enddo
+
+ enddo
+ enddo
+
+! conditions absorbantes nouvelle formulation
+! pas de dependance par l'adressage indirect
+! car chaque element absorbant est mappe sur un element spectral different
+ if(anyabs) then
+ numer_abs = is_bordabs(k)
+ if(numer_abs .gt. 0) then
+ do j=1,nxgll
+ do i=1,nxgll
+ if(a13x(i,j,numer_abs) .ne. zero) then
+ iglobnum = ibool(i,j,k)
+ Uxnewloc(i,j,k) = Uxnewloc(i,j,k) - &
+ a13x(i,j,numer_abs)*veloc(1,iglobnum)
+ Uznewloc(i,j,k) = Uznewloc(i,j,k) - &
+ a13z(i,j,numer_abs)*veloc(2,iglobnum)
+ endif
+ enddo
+ enddo
+ endif
+ endif
+
+! assemblage des contributions des differents elements
+ do j=1,nxgll
+ do i=1,nxgll
+ iglobnum = ibool(i,j,k)
+ accel(1,iglobnum) = accel(1,iglobnum) + Uxnewloc(i,j,k)
+ accel(2,iglobnum) = accel(2,iglobnum) + Uznewloc(i,j,k)
+ enddo
+ enddo
+
+ enddo
+
+! --- ajouter sources forces colloquees
+
+ if(.not. initialfield) then
+ do n=1,nltfl
+ iglobsource = nint(gltfu(9,n))
+ accel(:,iglobsource) = accel(:,iglobsource) + force(:,n)
+ enddo
+ endif
+
+!---- ajouter sources explosives
+
+ if(.not. initialfield) then
+
+ do n=1,nltfl
+
+! seulement si source explosive
+ if(nint(gltfu(2,n)) == 2) then
+
+! determiner type de source en temps
+ isource = nint(gltfu(1,n))
+
+! introduire source suivant son type
+ if(isource == 6) then
+ sig = ricker(time,n,gltfu,nltfl)
+ else if(isource == 7) then
+ sig = dirac(time,n,gltfu,nltfl)
+ else
+ sig = zero
+ endif
+
+! recuperer numero d'element de la source
+ ielems = nint(gltfu(12,n))
+
+ do i=1,nxgll
+ do j=1,nxgll
+ iglobnum = ibool(i,j,ielems)
+ accel(1,iglobnum) = accel(1,iglobnum) + a11(i,j,n)*sig
+ accel(2,iglobnum) = accel(2,iglobnum) + a12(i,j,n)*sig
+ enddo
+ enddo
+
+ endif
+
+ enddo
+
+ endif
+
+! --- multiplier par l'inverse de la matrice de masse
+
+ accel(1,:) = accel(1,:)*rmass(:)
+ accel(2,:) = accel(2,:)*rmass(:)
+
+ return
+ end subroutine qsumspec
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/ricker.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/ricker.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/ricker.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,38 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ double precision function ricker(t,n,gltfu,nltfl)
+
+! calcul du terme temporel de la source pour un Ricker
+
+ use defpi
+
+ implicit none
+
+ integer nltfl,n
+ double precision t
+ double precision gltfu(20,nltfl)
+
+ double precision f0,t0,factor,a
+
+! parametres pour la source
+ f0 = gltfu(5,n)
+ t0 = gltfu(6,n)
+ factor = gltfu(7,n)
+
+! Ricker
+ a = pi*pi*f0*f0
+ ricker = - factor * (1.d0-2.d0*a*(t-t0)**2)*exp(-a*(t-t0)**2)
+
+ return
+ end function ricker
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/setcor.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/setcor.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/setcor.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,104 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine setcor(coord,npoin,ndime,knods,shape,ibool,coorg, &
+ nxgll,nygll,nspec,npgeo,ngnod,ioutputgrid)
+!
+!=======================================================================
+!
+! "s e t c o r" : set the global nodal coordinates
+!
+!=======================================================================
+!
+ use iounit
+ use infos
+ use label1
+
+ implicit none
+
+ integer npoin,ndime,nxgll,nygll,nspec,npgeo,ngnod
+
+ integer knods(ngnod,nspec),ibool(nxgll,nygll,nspec)
+ double precision coord(ndime,npoin),coorg(ndime,npgeo)
+ double precision shape(ngnod,nxgll,nygll)
+
+ logical ioutputgrid
+
+ integer n,i,ip1,ip2,ispel,in,nnum
+ double precision xcor,zcor
+
+ double precision, parameter :: zero = 0.d0
+
+!
+!---- initialisation des labels
+!
+ labelc(1) = ' x1'
+ labelc(2) = ' x2'
+ labelc(3) = ' x3'
+
+!
+!---- generation des coordonnees physiques des points globaux
+!
+ do ispel = 1,nspec
+ do ip1 = 1,nxgll
+ do ip2 = 1,nygll
+
+ xcor = zero
+ zcor = zero
+ do in = 1,ngnod
+ nnum = knods(in,ispel)
+ xcor = xcor + shape(in,ip1,ip2)*coorg(1,nnum)
+ zcor = zcor + shape(in,ip1,ip2)*coorg(2,nnum)
+ enddo
+
+ coord(1,ibool(ip1,ip2,ispel)) = xcor
+ coord(2,ibool(ip1,ip2,ispel)) = zcor
+
+ enddo
+ enddo
+ enddo
+
+!
+!---- check the input
+!
+ if(iecho == 2) then
+ do n = 1,npoin
+ if(mod(n,50) == 1) write(iout,100) (labelc(i),i=1,ndime)
+ write(iout,200) n, (coord(i,n), i=1,ndime)
+ enddo
+ endif
+
+!
+!---- sauvegarde de la grille de points dans un fichier
+!
+ if(ioutputgrid) then
+ print *
+ print *,'Saving the grid in a text file...'
+ print *
+ open(unit=55,file='gridpoints.txt',status='unknown')
+ write(55,*) npoin
+ do n = 1,npoin
+ write(55,*) n, (coord(i,n), i=1,ndime)
+ enddo
+ close(55)
+ endif
+
+ return
+!
+!---- formats
+!
+ 100 format(///' n o d a l c o o r d i n a t e d a t a'/1x, &
+ 42('=')///,4x,' node number ',10x,2(a5,12x))
+ 200 format(4x,i7,10x,3(1pe15.8,2x))
+
+ end subroutine setcor
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/specfem.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/specfem.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/specfem.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,824 @@
+
+!=====================================================================
+!
+! S p e c f e m
+! -------------
+!
+! Version 4.2
+! -----------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+!
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+!
+! (c) June 1998
+!
+!=====================================================================
+!
+! An explicit spectral element solver for the
+!
+! elastic wave equation
+!
+!=======================================================================
+
+ program main
+!
+!=======================================================================
+!
+! "m a i n" : Allocate memory, initialize arrays and iterate in time
+! -------
+!
+! ======================================================================
+!
+ use iounit
+ use captio
+ use infos
+ use mesh01
+ use constspec
+ use timeparams
+ use defpi
+ use spela202
+ use energie
+ use arraydir
+ use loadft
+
+ implicit none
+
+ double precision, parameter :: zero = 0.d0, one = 1.d0
+
+ character(len=80) datlin
+
+ double precision, dimension(:,:), allocatable :: gltfu,force,coorg,posrec
+
+! simple precision pour stockage sismogrammes au format SEP
+ real, dimension(:,:), allocatable :: sisux,sisuz
+
+ logical anyabs,anyperio
+
+ integer i,it,irec,iter,itsis,iglobrec,iglobsource
+ integer nbpoin,inump,n,npoinext,nseis,netyp,ipoin,ispec
+
+ double precision valux,valuz,rhoextread,vpextread,vsextread
+ double precision dcosrot,dsinrot,dcosrot1,dsinrot1,dcosrot2,dsinrot2
+
+! coefficients of the explicit Newmark time scheme
+ double precision deltatover2,deltatsqover2
+
+!
+!---- tableaux pour allocation dynamique
+!
+
+ double precision, dimension(:), allocatable :: &
+ xi,yi,wx,wy,xirec,etarec
+
+ double precision, dimension(:,:), allocatable :: &
+ hprime,hTprime,flagrange,xinterp,zinterp,Uxinterp,Uzinterp,elastcoef, &
+ coord,accel,veloc,displ,vpred
+
+ double precision, dimension(:), allocatable :: rmass, &
+ fglobx,fglobz,density,vpext,vsext,rhoext,displread,velocread,accelread
+
+ double precision, dimension(:,:,:), allocatable :: shapeint,shape,dvolu, &
+ a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13x,a13z,Uxnewloc,Uznewloc
+
+ double precision, dimension(:,:,:,:), allocatable :: dershape
+
+ double precision, dimension(:,:,:,:,:), allocatable :: xjaci
+
+ integer, dimension(:,:,:), allocatable :: ibool,iboolori
+ integer, dimension(:,:), allocatable :: knods,codeabs,codeperio
+ integer, dimension(:), allocatable :: kmato,numabs,is_bordabs
+
+!
+!***********************************************************************
+!
+! i n i t i a l i z a t i o n p h a s e
+!
+!***********************************************************************
+!
+!---- Assign unit numbers
+!
+ iin = 8
+ open (iin,file='DataBase')
+
+ iout = 6
+! ecriture dans un fichier texte et non ecran
+! iout = 16
+! open (iout,file='results.txt')
+
+! fichier pour le stockage des courbes d'energie
+ ienergy = 17
+
+!
+!--- read job title and skip remaining titles of the input file
+!
+ read(iin ,40) datlin
+ read(iin ,40) datlin
+ read(iin ,40) jtitle
+ read(iin ,40) datlin
+ read(iin ,40) datlin
+ read(iin ,40) datlin
+ read(iin ,45) stitle
+!
+!---- Print the date, time and start-up banner
+!
+ call datim('Program S P E C F E M : start',stitle,iout)
+
+ write(*,*)
+ write(*,*)
+ write(*,*) '******************************************'
+ write(*,*) '**** ****'
+ write(*,*) '**** SPECFEM VERSION 4.2 FORTRAN 90 ****'
+ write(*,*) '**** ****'
+ write(*,*) '******************************************'
+
+!
+!***********************************************************************
+!
+! i n p u t p h a s e
+!
+!***********************************************************************
+!
+
+!
+!---- read first control parameters
+!
+ call contol
+!
+!---- read iteration parameters
+!
+ call intseq
+!
+!---- allocate first arrays needed
+!
+
+! mettre a zero la structure de stockage des tableaux
+ nbarrays = 0
+ arraysizes(:) = 0
+ arraynames(:) = ' '
+
+ if(sismos) then
+ nseis = ncycl/isamp
+ else
+ nseis = 1
+ endif
+
+ allocate(sisux(nseis,nrec))
+ allocate(sisuz(nseis,nrec))
+ allocate(posrec(ndime,max(nrec,1)))
+ allocate(coorg(ndime,npgeo))
+ allocate(force(ndime,max(nltfl,1)))
+ allocate(gltfu(20,max(nltfl,1)))
+
+ call storearray('sisux',nseis*nrec,isngl)
+ call storearray('sisuz',nseis*nrec,isngl)
+ call storearray('posrec',ndime*max(nrec,1),idouble)
+ call storearray('coorg',ndime*npgeo,idouble)
+ call storearray('force',ndime*max(nltfl,1),idouble)
+ call storearray('gltfu',20*max(nltfl,1),idouble)
+
+!-----------------------------------------------------------------------
+
+!
+!---- read load time functions
+!
+
+!
+!---- Collocated forces or pressure sources
+!
+ if(nltfl > 0) call getltf(gltfu,nltfl,initialfield)
+
+!
+!---- lecture position receivers
+!
+ if(nrec > 0) call getrecepts(posrec,ndime,nrec)
+
+!
+!---- read the spectral macroblocs nodal coordinates
+!
+ call getspec(coorg,npgeo,ndime)
+
+!
+!***********************************************************************
+!
+! S p e c t r a l E l e m e n t s P a r a m e t e r s
+!
+!***********************************************************************
+!
+
+!
+!---- read the basic properties of the spectral elements
+!
+ read(iin ,40) datlin
+ read(iin ,*) netyp,numat,ngnod,nxgll,nygll,nspec,iptsdisp,nelemabs,nelemperio
+
+!
+!---- check that the mesh is conform
+!
+ if(nxgll /= nygll) stop 'Non conform mesh in input'
+!
+!***********************************************************************
+!
+! A l l o c a t e a r r a y s
+!
+!***********************************************************************
+!
+
+allocate(shape(ngnod,nxgll,nygll))
+allocate(shapeint(ngnod,iptsdisp,iptsdisp))
+allocate(dershape(ndime,ngnod,nxgll,nygll))
+allocate(dvolu(nspec,nxgll,nygll))
+allocate(xjaci(nspec,ndime,ndime,nxgll,nygll))
+allocate(hprime(nxgll,nygll))
+allocate(hTprime(nxgll,nygll))
+allocate(a1(nxgll,nygll,nspec))
+allocate(a2(nxgll,nygll,nspec))
+allocate(a3(nxgll,nygll,nspec))
+allocate(a4(nxgll,nygll,nspec))
+allocate(a5(nxgll,nygll,nspec))
+allocate(a6(nxgll,nygll,nspec))
+allocate(a7(nxgll,nygll,nspec))
+allocate(a8(nxgll,nygll,nspec))
+allocate(a9(nxgll,nygll,nspec))
+allocate(a10(nxgll,nygll,nspec))
+allocate(a11(nxgll,nygll,max(nltfl,1)))
+allocate(a12(nxgll,nygll,max(nltfl,1)))
+allocate(xi(nxgll))
+allocate(yi(nygll))
+allocate(wx(nxgll))
+allocate(wy(nygll))
+allocate(Uxnewloc(nxgll,nygll,nspec))
+allocate(Uznewloc(nxgll,nygll,nspec))
+allocate(xirec(iptsdisp))
+allocate(etarec(iptsdisp))
+allocate(flagrange(nxgll,iptsdisp))
+allocate(xinterp(iptsdisp,iptsdisp))
+allocate(zinterp(iptsdisp,iptsdisp))
+allocate(Uxinterp(iptsdisp,iptsdisp))
+allocate(Uzinterp(iptsdisp,iptsdisp))
+allocate(density(numat))
+allocate(elastcoef(4,numat))
+
+allocate(kmato(nspec))
+allocate(knods(ngnod,nspec))
+allocate(ibool(nxgll,nygll,nspec))
+
+! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+ call storearray('shape',ngnod*nxgll*nygll,idouble)
+ call storearray('shapeint',ngnod*iptsdisp*iptsdisp,idouble)
+ call storearray('dershape',ndime*ngnod*nxgll*nygll,idouble)
+ call storearray('dvolu',nspec*nxgll*nygll,idouble)
+ call storearray('xjaci',nspec*ndime*ndime*nxgll*nygll,idouble)
+ call storearray('hprime',nxgll*nygll,idouble)
+ call storearray('hTprime',nxgll*nygll,idouble)
+ call storearray('a1',nxgll*nygll*nspec,idouble)
+ call storearray('a2',nxgll*nygll*nspec,idouble)
+ call storearray('a3',nxgll*nygll*nspec,idouble)
+ call storearray('a4',nxgll*nygll*nspec,idouble)
+ call storearray('a5',nxgll*nygll*nspec,idouble)
+ call storearray('a6',nxgll*nygll*nspec,idouble)
+ call storearray('a7',nxgll*nygll*nspec,idouble)
+ call storearray('a8',nxgll*nygll*nspec,idouble)
+ call storearray('a9',nxgll*nygll*nspec,idouble)
+ call storearray('a10',nxgll*nygll*nspec,idouble)
+ call storearray('a11',nxgll*nygll*max(nltfl,1),idouble)
+ call storearray('a12',nxgll*nygll*max(nltfl,1),idouble)
+ call storearray('xi',nxgll,idouble)
+ call storearray('yi',nygll,idouble)
+ call storearray('wx',nxgll,idouble)
+ call storearray('wy',nygll,idouble)
+ call storearray('Uxnewloc',nxgll*nygll*nspec,idouble)
+ call storearray('Uznewloc',nxgll*nygll*nspec,idouble)
+ call storearray('xirec',iptsdisp,idouble)
+ call storearray('etarec',iptsdisp,idouble)
+ call storearray('flagrange',nxgll*iptsdisp,idouble)
+ call storearray('xinterp',iptsdisp*iptsdisp,idouble)
+ call storearray('zinterp',iptsdisp*iptsdisp,idouble)
+ call storearray('Uxinterp',iptsdisp*iptsdisp,idouble)
+ call storearray('Uzinterp',iptsdisp*iptsdisp,idouble)
+ call storearray('density',numat,idouble)
+ call storearray('elastcoef',4*numat,idouble)
+
+ call storearray('kmato',nspec,iinteg)
+ call storearray('knods',ngnod*nspec,iinteg)
+ call storearray('ibool',nxgll*nygll*nspec,iinteg)
+
+! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+! --- allocate arrays for absorbing and periodic boundary conditions
+
+ if(nelemabs <= 0) then
+ nelemabs = 1
+ anyabs = .false.
+ else
+ anyabs = .true.
+ endif
+ allocate(is_bordabs(nspec))
+ allocate(numabs(nelemabs))
+ allocate(codeabs(4,nelemabs))
+ call storearray('is_bordabs',nspec,iinteg)
+ call storearray('numabs',nelemabs,iinteg)
+ call storearray('codeabs',4*nelemabs,iinteg)
+
+ if(nelemperio <= 0) then
+ nelemperio = 1
+ anyperio = .false.
+!!!!!!!!!!!! allocate(iboolori(1,1,1))
+!!! DK DK fix bug with Linux pgf90 compiler
+ allocate(iboolori(nxgll,nygll,nspec))
+ call storearray('iboolori',1,iinteg)
+ else
+ anyperio = .true.
+ allocate(iboolori(nxgll,nygll,nspec))
+ call storearray('iboolori',nxgll*nygll*nspec,iinteg)
+ endif
+ allocate(codeperio(4,nelemperio))
+ call storearray('codeperio',4*nelemperio,iinteg)
+
+!
+!---- input element data and compute total number of points
+!
+ call qinpspec(density,elastcoef,xi,yi,wx,wy,knods, &
+ ibool,kmato,shape,shapeint,dershape,dvolu,xjaci,coorg, &
+ xirec,etarec,flagrange,numabs,codeabs,codeperio,anyabs,anyperio)
+
+!
+!---- close input file
+!
+ close(iin)
+
+!
+!---- allocation des autres tableaux pour la grille globale et les bords
+!
+
+ allocate(coord(ndime,npoin))
+ allocate(accel(ndime,npoin))
+ allocate(displ(ndime,npoin))
+ allocate(veloc(ndime,npoin))
+ allocate(vpred(ndime,npoin))
+ allocate(rmass(npoin))
+ allocate(fglobx(npoin))
+ allocate(fglobz(npoin))
+
+ if(ireadmodel) then
+ npoinext = npoin
+ else
+ npoinext = 1
+ endif
+ allocate(vpext(npoinext))
+ allocate(vsext(npoinext))
+ allocate(rhoext(npoinext))
+
+ allocate(a13x(nxgll,nygll,nelemabs))
+ allocate(a13z(nxgll,nygll,nelemabs))
+
+! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+ call storearray('coord',ndime*npoin,idouble)
+ call storearray('accel',ndime*npoin,idouble)
+ call storearray('displ',ndime*npoin,idouble)
+ call storearray('veloc',ndime*npoin,idouble)
+ call storearray('vpred',ndime*npoin,idouble)
+ call storearray('rmass',npoin,idouble)
+ call storearray('fglobx',npoin,idouble)
+ call storearray('fglobz',npoin,idouble)
+ call storearray('vpext',npoinext,idouble)
+ call storearray('vsext',npoinext,idouble)
+ call storearray('rhoext',npoinext,idouble)
+
+ call storearray('a13x',nxgll*nygll*nelemabs,idouble)
+ call storearray('a13z',nxgll*nygll*nelemabs,idouble)
+
+! ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+!
+!---- list a short directory after input phase
+!
+ if(iecho /= 0) call dircty
+
+!
+!---- set the coordinates of the points of the global grid
+!
+ call setcor(coord,npoin,ndime,knods,shape,ibool,coorg,nxgll,nygll, &
+ nspec,npgeo,ngnod,ioutputgrid)
+
+!
+!----- plot the GLL mesh in a Gnuplot file
+!
+ if (ignuplot) call plotgll(knods,ibool,coorg,coord)
+
+!
+!---- define coefficients of the Newmark time scheme
+!
+ deltatover2 = 0.5d0*deltat
+ deltatsqover2 = deltat*deltat/2.d0
+
+!
+!---- mettre en oeuvre les periodic boundary conditions
+!
+ if(anyperio) call modifperio(ibool,iboolori,codeperio)
+
+!
+!---- definir la position reelle des points source et recepteurs
+!
+ call positsource(coord,ibool,gltfu,ndime,npoin,nltfl,nxgll,nygll,nspec)
+ call positrec(coord,posrec,ndime,npoin,nrec)
+
+!
+!---- eventuellement lecture d'un modele externe de vitesse et de densite
+!
+ if(ireadmodel) then
+ print *
+ print *,'Reading velocity and density model from external file...'
+ print *
+ open(unit=55,file='extmodel.txt',status='unknown')
+ read(55,*) nbpoin
+ if(nbpoin /= npoin) stop 'Wrong number of points in input file'
+ do n = 1,npoin
+ read(55,*) inump,rhoextread,vpextread,vsextread
+ if(inump<1 .or. inump>npoin) stop 'Wrong point number'
+ rhoext(inump) = rhoextread
+ vpext(inump) = vpextread
+ vsext(inump) = vsextread
+ enddo
+ close(55)
+ endif
+
+!
+!---- build the mass matrix for spectral elements
+!
+ call qmasspec(rhoext,wx,wy,ibool,dvolu,rmass,density,kmato,npoin)
+
+!
+!---- definir les tableaux a1 a a13
+!
+ call defarrays(vpext,vsext,rhoext,density,elastcoef, &
+ xi,yi,wx,wy,hprime,hTprime, &
+ a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13x,a13z, &
+ ibool,iboolori,kmato,dvolu,xjaci,coord,gltfu, &
+ numabs,codeabs,anyabs,anyperio)
+
+! initialiser les tableaux a zero
+ accel = zero
+ veloc = zero
+ displ = zero
+ vpred = zero
+ force = zero
+
+!
+!--- precalculer l'inverse de la matrice de masse pour efficacite
+!
+ rmass(:) = one / rmass(:)
+
+! calculer la numerotation inverse pour les bords absorbants
+ is_bordabs(:) = 0
+ if(anyabs) then
+ do ispec = 1,nelemabs
+ is_bordabs(numabs(ispec)) = ispec
+ enddo
+ endif
+
+! convertir angle recepteurs en radians
+ anglerec = anglerec * pi / 180.d0
+ anglerec2 = anglerec2 * pi / 180.d0
+
+!
+!---- eventuellement lecture des champs initiaux dans un fichier
+!
+ if(initialfield) then
+ print *
+ print *,'Reading initial fields from external file...'
+ print *
+ open(unit=55,file='wavefields.txt',status='unknown')
+ read(55,*) nbpoin
+ if(nbpoin /= npoin) stop 'Wrong number of points in input file'
+ allocate(displread(ndime))
+ allocate(velocread(ndime))
+ allocate(accelread(ndime))
+ do n = 1,npoin
+ read(55,*) inump, (displread(i), i=1,ndime), &
+ (velocread(i), i=1,ndime), (accelread(i), i=1,ndime)
+ if(inump<1 .or. inump>npoin) stop 'Wrong point number'
+ displ(:,inump) = displread
+ veloc(:,inump) = velocread
+ accel(:,inump) = accelread
+ enddo
+ deallocate(displread)
+ deallocate(velocread)
+ deallocate(accelread)
+ close(55)
+ endif
+
+!
+!---- afficher le max du deplacement initial
+!
+ print *,'Max norme U initial = ',maxval(sqrt(displ(1,:)**2 + displ(2,:)**2))
+
+!
+!---- verification des fonctions temporelles des sources
+!
+ if(.not. initialfield) call checksource(gltfu,nltfl,deltat,ncycl)
+
+!
+!---- verifier le maillage, la stabilite et le nb de points par lambda
+!
+ call checkgrid(deltat,gltfu,nltfl,initialfield)
+
+!
+!---- if data check mode then stop
+!
+ if(iexec == 0) then
+ print *,'**********************************'
+ print *,'* Aborting, data check mode only *'
+ print *,'**********************************'
+ call datim('Program S P E C F E M : end data checking',stitle,iout)
+ stop
+ endif
+
+!
+!---- initialiser sismogrammes
+!
+ sisux = sngl(zero)
+ sisuz = sngl(zero)
+
+ dcosrot1 = dcos(anglerec)
+ dsinrot1 = dsin(anglerec)
+ dcosrot2 = dcos(anglerec2)
+ dsinrot2 = dsin(anglerec2)
+
+!
+!---- ouvrir fichier pour courbe d'energie
+!
+ if(compenergy) open(unit=ienergy,file='energy.gnu',status='unknown')
+
+!
+!---- s t a r t t i m e i t e r a t i o n s
+!
+
+ write(iout,400)
+
+! boucle principale d'evolution en temps
+ do it=1,ncycl
+
+ if(mod(it-1,iaffinfo) == 0) then
+ time = (it-1)*deltat
+ if(time >= 1.d-3) then
+ write(iout,100) it,time
+ else
+ write(iout,101) it,time
+ endif
+ endif
+
+! calculer le predictor
+ displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsqover2*accel(:,:)
+ vpred(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+
+! initialisation pour les iterations
+ veloc(:,:) = vpred(:,:)
+
+! calculer le terme source
+ call calcforce(force,ndime,gltfu,nltfl,it*deltat)
+
+! iteration sur le residu d'acceleration
+ do iter = 1,niter
+
+ accel(:,:) = zero
+
+!
+!---- calcul du residu d'acceleration pour le multicorrector
+!---- retourne dans accel le terme Fext - M*A(i,n+1) - K*D(i,n+1)
+!
+ time = it*deltat
+ call qsumspec(hprime,hTprime, &
+ a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13x,a13z,force, &
+ ibool,displ,veloc,accel, &
+ Uxnewloc,Uznewloc,rmass,nxgll,npoin,ndime, &
+ nspec,gltfu,nltfl,initialfield, &
+ numabs,is_bordabs,nelemabs,anyabs)
+
+!
+!---- mise a jour globale du deplacement par multicorrector
+!
+
+ veloc(:,:) = vpred(:,:) + deltatover2*accel(:,:)
+
+ enddo
+
+!
+!----- calcul de l'energie cinetique et potentielle
+!
+ if(compenergy) &
+ call calc_energie(hprime,hTprime,ibool,displ,veloc, &
+ Uxnewloc,Uznewloc,kmato,dvolu,xjaci,density,elastcoef, &
+ wx,wy,nxgll,npoin,ndime,nspec,numat)
+
+!
+!---- afficher le max du deplacement a certains pas de temps
+!
+ if(mod(it-1,iaffinfo) == 0) &
+ print *,'Max norme U = ',maxval(sqrt(displ(1,:)**2 + displ(2,:)**2))
+
+!
+!---- affichage des resultats a certains pas de temps
+!
+ if (display .and. it > 1 .and. (mod(it-1,itaff) == 0 .or. &
+ it == itfirstaff .or. it == ncycl)) then
+
+ time = it*deltat
+ write(iout,*)
+ if(time >= 1.d-3) then
+ write(iout,110) time
+ else
+ write(iout,111) time
+ endif
+ write(iout,*)
+
+!
+!---- affichage postscript
+!
+ if (ivectplot) then
+ write(iout,*) 'Dump PostScript'
+ if(ivecttype == 1) then
+ write(iout,*) 'Drawing displacement field...'
+ call plotpost(displ,coord,vpext,gltfu,posrec, &
+ nltfl,it,deltat,coorg,xinterp,zinterp,shapeint, &
+ Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ numabs,codeabs,codeperio,anyabs,anyperio)
+ else if(ivecttype == 2) then
+ write(iout,*) 'Drawing velocity field...'
+ call plotpost(veloc,coord,vpext,gltfu,posrec, &
+ nltfl,it,deltat,coorg,xinterp,zinterp,shapeint, &
+ Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ numabs,codeabs,codeperio,anyabs,anyperio)
+ else if(ivecttype == 3) then
+ write(iout,*) 'Drawing acceleration field...'
+ call plotpost(accel,coord,vpext,gltfu,posrec, &
+ nltfl,it,deltat,coorg,xinterp,zinterp,shapeint, &
+ Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ numabs,codeabs,codeperio,anyabs,anyperio)
+ else
+ stop 'Wrong field code for PostScript display'
+ endif
+ write(iout,*) 'Fin dump PostScript'
+ endif
+
+!
+!---- generation fichier AVS
+!
+ if(iavs) then
+ if(anyperio) then
+ call plotavs(displ,coord,kmato,iboolori,it)
+ else
+ call plotavs(displ,coord,kmato,ibool,it)
+ endif
+ endif
+
+ endif
+
+! stockage des sismogrammes
+ if(sismos .and. (mod(it-1,isamp) == 0 .or. it == ncycl)) then
+
+ do irec=1,nrec
+ iglobrec = nint(posrec(1,irec))
+
+ if(isismostype == 1) then
+ valux = displ(1,iglobrec)
+ valuz = displ(2,iglobrec)
+ else if(isismostype == 2) then
+ valux = veloc(1,iglobrec)
+ valuz = veloc(2,iglobrec)
+ else if(isismostype == 3) then
+ valux = accel(1,iglobrec)
+ valuz = accel(2,iglobrec)
+ else
+ stop 'Wrong field code for seismogram output'
+ endif
+
+! distinguer les deux lignes de recepteurs
+ if(irec <= nrec1) then
+ dcosrot = dcosrot1
+ dsinrot = dsinrot1
+ else
+ dcosrot = dcosrot2
+ dsinrot = dsinrot2
+ endif
+
+! rotation eventuelle des composantes
+ itsis = min(it/isamp + 1,nseis)
+ sisux(itsis,irec) = sngl(dcosrot*valux + dsinrot*valuz)
+ sisuz(itsis,irec) = - sngl(dsinrot*valux + dcosrot*valuz)
+
+ enddo
+
+ endif
+
+ enddo
+
+!
+!---- sauvegarder sismogrammes en fin de simulation
+!
+ if(sismos) call writeseis(sisux,sisuz,coord,posrec,ndime,npoin,nseis,nrec, &
+ isamp,deltat,factorxsu,n1ana,n2ana,irepr,nrec1,nrec2,isismostype)
+
+!
+!---- fermer fichier pour courbe d'energie et creer un petit script gnuplot
+!
+ if(compenergy) then
+ close(ienergy)
+ open(unit=ienergy,file='plotenergy',status='unknown')
+ write(ienergy,*) 'set term postscript landscape color solid "Helvetica" 22'
+ write(ienergy,*) 'set output "energy.ps"'
+ write(ienergy,*) 'set xlabel "Time (s)"'
+ write(ienergy,*) 'set ylabel "Energy (J)"'
+ write(ienergy,*) 'plot "energy.gnu" us 1:4 t ''Total Energy'' w l 1, "energy.gnu" us 1:3 t ''Potential Energy'' w l 2'
+ close(ienergy)
+ endif
+
+! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+
+!
+!---- desallouer tous les tableaux avant de terminer l'execution
+!
+ deallocate(sisux)
+ deallocate(sisuz)
+ deallocate(posrec)
+ deallocate(coorg)
+ deallocate(coord)
+ deallocate(force)
+ deallocate(gltfu)
+ deallocate(accel)
+ deallocate(displ)
+ deallocate(veloc)
+ deallocate(vpred)
+ deallocate(rmass)
+ deallocate(fglobx)
+ deallocate(fglobz)
+ deallocate(shape)
+ deallocate(shapeint)
+ deallocate(dershape)
+ deallocate(dvolu)
+ deallocate(xjaci)
+ deallocate(hprime)
+ deallocate(hTprime)
+ deallocate(ibool)
+ deallocate(a1)
+ deallocate(a2)
+ deallocate(a3)
+ deallocate(a4)
+ deallocate(a5)
+ deallocate(a6)
+ deallocate(a7)
+ deallocate(a8)
+ deallocate(a9)
+ deallocate(a10)
+ deallocate(a13x)
+ deallocate(a13z)
+ deallocate(a11)
+ deallocate(a12)
+ deallocate(xi)
+ deallocate(yi)
+ deallocate(wx)
+ deallocate(wy)
+ deallocate(Uxnewloc)
+ deallocate(Uznewloc)
+ deallocate(xirec)
+ deallocate(etarec)
+ deallocate(flagrange)
+ deallocate(xinterp)
+ deallocate(zinterp)
+ deallocate(Uxinterp)
+ deallocate(Uzinterp)
+ deallocate(density)
+ deallocate(elastcoef)
+ deallocate(kmato)
+ deallocate(knods)
+ deallocate(numabs)
+ deallocate(codeabs)
+ deallocate(codeperio)
+
+ call datim('Program S P E C F E M : end',stitle,iout)
+
+!
+!---- close output file
+!
+ close(iout)
+
+ stop
+
+!
+!---- formats
+!
+ 40 format(a80)
+ 45 format(a50)
+ 100 format('Pas de temps numero ',i5,' t = ',f7.4,' s')
+ 101 format('Pas de temps numero ',i5,' t = ',1pe10.4,' s')
+ 110 format('Sauvegarde deplacement temps t = ',f7.4,' s')
+ 111 format('Sauvegarde deplacement temps t = ',1pe10.4,' s')
+ 400 format(/1x,41('=')/,' = T i m e ', &
+ 'e v o l u t i o n l o o p ='/1x,41('=')/)
+
+ end program main
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/storearray.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/storearray.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/storearray.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,45 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine storearray(name,isize,itype)
+!
+!=======================================================================
+!
+! Dynamic storage : store the array properties
+! ----------------
+!
+!=======================================================================
+
+ use iounit
+ use arraydir
+
+ implicit none
+
+ character(len=*) name
+ integer isize,itype
+
+ if(itype /= iinteg .and. itype /= isngl .and. itype /= idouble) &
+ stop 'Wrong array type in dynamic allocation'
+
+ if(isize <= 0) &
+ stop 'Incoherent array size in dynamic allocation'
+
+ nbarrays = nbarrays + 1
+ if(nbarrays > maxnbarrays) stop 'Maximum number of arrays reached'
+
+ arraysizes(nbarrays) = isize
+ arraytypes(nbarrays) = itype
+ arraynames(nbarrays) = name
+
+ return
+ end subroutine storearray
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/writeseis.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/writeseis.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/writeseis.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,561 @@
+
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine writeseis(sisux,sisuz,coord,posrec,ndime, &
+ npoin,nseis,nrec,isamp,deltat,factorxsu, &
+ n1ana,n2ana,irepr,nrec1,nrec2,isismostype)
+
+!
+!---- sauvegarde des sismogrammes en fin de simulation
+!
+
+ implicit none
+
+ integer ndime,npoin,nseis
+ integer nrec,isamp,n1ana,n2ana,irepr,nrec1,nrec2,isismostype
+ double precision deltat,factorxsu
+
+! simple precision pour le stockage au format SEP
+ real sisux(nseis,nrec)
+ real sisuz(nseis,nrec)
+
+ double precision coord(ndime,npoin)
+ double precision posrec(ndime,nrec)
+
+ logical invert
+ integer nt,irec,i,iana,it
+ double precision xval,xvaladd
+
+ write(*,*) 'Sauvegarde sismos sur disk ...'
+
+ nt = nseis
+
+ write(*,*)
+ write(*,*) ' valeur de isamp = ',isamp
+ write(*,*) ' nb d''echantillons stockes en temps = ',nt
+ write(*,*) ' nb de recepteurs = ',nrec
+ write(*,*)
+
+ write(*,*) 'Sauvegarde sismos sur disk ...'
+
+!----
+
+ write(*,*)
+ write(*,*) 'Sauvegarde traces format SEP...'
+ write(*,*) 'DK DK using ASCII instead of SEP'
+
+ goto 333
+
+! ecriture au format binaire deplacement horizontal
+ open(unit=11,file='Ux_file',status='unknown', &
+ access='direct',recl=nt*nrec*4)
+ write(11,rec=1) (sisux(i,1),i=1,nt*nrec)
+ close(11)
+
+! ecriture au format binaire deplacement vertical
+ open(unit=11,file='Uz_file',status='unknown', &
+ access='direct',recl=nt*nrec*4)
+ write(11,rec=1) (sisuz(i,1),i=1,nt*nrec)
+ close(11)
+
+ 333 continue
+
+! ecriture au format ASCII
+ open(unit=11,file='Ux_file.dat',status='unknown')
+!!!!!!! DK DK UUUUUUU only one receiver for tests do irec=1,nrec
+ do irec=1,1
+ do it=1,nt
+ write(11,*) sngl(dble(it-1)*dble(isamp)*deltat),sisux(it,irec)
+ enddo
+ enddo
+ close(11)
+ open(unit=11,file='Uz_file.dat',status='unknown')
+!!!!!!! DK DK UUUUUUU only one receiver for tests do irec=1,nrec
+ do irec=1,1
+ do it=1,nt
+ write(11,*) sngl(dble(it-1)*dble(isamp)*deltat),sisuz(it,irec)
+ enddo
+ enddo
+ close(11)
+
+!----
+
+ write(*,*)
+ write(*,*) 'Sauvegarde headers pour visu...'
+
+!----
+!---- ligne de recepteurs pour Xwindow
+!----
+
+ open(unit=12,file='xline',status='unknown')
+
+ write(12,100) factorxsu,nseis,deltat*isamp,nrec
+! inverser representation si recepteurs orientes negativement
+ invert = .false.
+ if(irepr == 1.and.coord(1,nint(posrec(1,nrec))) < &
+ coord(1,nint(posrec(1,1)))) then
+ invert = .true.
+ endif
+ if(irepr == 2.and.coord(2,nint(posrec(1,nrec))) < &
+ coord(2,nint(posrec(1,1)))) then
+ invert = .true.
+ endif
+
+!--- premiere partie de la ligne de recepteurs
+ do irec=1,nrec1
+! recepteurs en distance
+ if(irepr == 3.or.nrec2 > 0) then
+ xval = dsqrt((coord(1,nint(posrec(1,irec))) - &
+ coord(1,nint(posrec(1,1))))**2 + &
+ (coord(2,nint(posrec(1,irec))) - &
+ coord(2,nint(posrec(1,1))))**2)
+! recepteurs suivant coordonnee X
+ else if(irepr == 1) then
+ if(invert) then
+ xval = coord(1,nint(posrec(1,1))) - coord(1,nint(posrec(1,irec)))
+ else
+ xval = coord(1,nint(posrec(1,irec)))
+ endif
+! recepteurs suivant coordonnee Z
+ else if(irepr == 2) then
+ if(invert) then
+ xval = coord(2,nint(posrec(1,1))) - coord(2,nint(posrec(1,irec)))
+ else
+ xval = coord(2,nint(posrec(1,irec)))
+ endif
+ else
+ stop 'wrong value of irepr !'
+ endif
+
+ write(12,140) xval
+
+ if (irec < nrec1) write(12,*) ','
+ enddo
+
+!--- deuxieme partie de la ligne de recepteurs
+ if(nrec2 > 0) then
+ write(12,*) ','
+ xvaladd = xval
+ do irec=nrec1+1,nrec
+ xval = &
+ dsqrt((coord(1,nint(posrec(1,irec))) - coord(1,nint(posrec(1,nrec1))))**2 + &
+ (coord(2,nint(posrec(1,irec))) - coord(2,nint(posrec(1,nrec1))))**2)
+ write(12,140) xval + xvaladd
+ if (irec < nrec) write(12,*) ','
+ enddo
+ endif
+
+ if(isismostype == 1) then
+ write(12,*) '@title="Ux at displacement@component"@<@Ux_file'
+ else if(isismostype == 2) then
+ write(12,*) '@title="Ux at velocity@component"@<@Ux_file'
+ else
+ write(12,*) '@title="Ux at acceleration@component"@<@Ux_file'
+ endif
+
+ close(12)
+
+!----
+!---- script de visualisation
+!----
+
+ open(unit=12,file='showseis',status='unknown')
+ write(12,110)
+ write(12,*)
+ write(12,*) '/bin/rm -f tempfile psline'
+ write(12,*) '# concatener toutes les lignes'
+ write(12,*) 'tr -d ''\012'' <xline >tempfile'
+ write(12,*) '# remettre fin de ligne'
+ write(12,*) 'echo " " >> tempfile'
+ write(12,*) '# supprimer espaces, changer arobas, dupliquer'
+ write(12,137)
+ write(12,*) '/bin/rm -f tempfile'
+ write(12,*) '# copier fichier pour sortie postscript'
+ write(12,130)
+ write(12,*) '/bin/rm -f tempfile'
+ write(12,*) 'echo ''rm -f uxpoly.ps uzpoly.ps'' > tempfile'
+ write(12,*) 'cat tempfile psline > tempfile2'
+ write(12,*) '/bin/mv -f tempfile2 psline'
+ write(12,*) '/bin/rm -f tempfile'
+ write(12,*) '# executer commande xsu'
+ write(12,*) 'sh xline'
+ write(12,*) '/bin/rm -f tempfile tempfile2'
+ close(12)
+
+!----
+!---- une trace pour Xwindow
+!----
+
+ open(unit=12,file='xtrace',status='unknown')
+ write(12,110)
+ write(12,*)
+ write(12,*) 'set nt = ',nseis
+ write(12,*) 'set dt = ',sngl(deltat*isamp)
+ write(12,*) '@ trace=10000'
+ write(12,*) 'while ($trace > -1)'
+ write(12,*) 'echo Donnez le numero de trace a visualiser :'
+ write(12,*) 'set rep=$<'
+ write(12,*) '@ trace = $rep'
+ write(12,*) 'echo Trace demandee : $trace'
+ write(12,*) '# traces commencent a zero dans format SEP'
+ write(12,*) '@ septrace = $trace - 1'
+ if(isismostype == 1) then
+ write(12,120)
+ write(12,125)
+ else if(isismostype == 2) then
+ write(12,121)
+ write(12,126)
+ else
+ write(12,122)
+ write(12,127)
+ endif
+ write(12,*) 'end'
+ close(12)
+
+!----
+!---- une trace pour postscript
+!----
+
+ open(unit=12,file='pstrace',status='unknown')
+ write(12,110)
+ write(12,*)
+ write(12,*) 'set nt = ',nseis
+ write(12,*) 'set dt = ',sngl(deltat*isamp)
+ write(12,*) '@ trace=10000'
+ write(12,*) 'while ($trace > -1)'
+ write(12,*) 'echo Donnez le numero de trace a tranformer en postscript :'
+ write(12,*) 'set rep=$<'
+ write(12,*) '@ trace = $rep'
+ write(12,*) 'echo Trace demandee : $trace'
+ write(12,*) '# traces commencent a zero dans format SEP'
+ write(12,*) '@ septrace = $trace - 1'
+ write(12,*) 'rm -f uxtrace{$trace}.ps uztrace{$trace}.ps'
+ if(isismostype == 1) then
+ write(12,220)
+ write(12,225)
+ else if(isismostype == 2) then
+ write(12,221)
+ write(12,226)
+ else
+ write(12,222)
+ write(12,227)
+ endif
+ write(12,*) 'end'
+ close(12)
+
+!----
+!---- une trace avec comparaison analytique pour Xwindow
+!----
+
+ open(unit=12,file='xcomptrace',status='unknown')
+ write(12,110)
+ write(12,*)
+ write(12,*) 'set nt = ',nseis
+ write(12,*) 'set dt = ',sngl(deltat*isamp)
+ write(12,*) 'set traceana1 = ',n1ana
+ write(12,*) 'set traceana2 = ',n2ana
+ write(12,*) '# traces commencent a zero dans format SEP'
+ write(12,*) '@ septraceana1 = $traceana1 - 1'
+ write(12,*) '@ septraceana2 = $traceana2 - 1'
+ write(12,*) '# premiere trace analytique'
+ write(12,*) '@ septraceref = 0'
+ write(12,*) '/bin/rm -f tutuan tutucomp'
+ write(12,320) 1,'x','x'
+ write(12,330) 'x',1
+ write(12,*) '/bin/rm -f tutuan tutucomp'
+ write(12,320) 1,'z','z'
+ write(12,330) 'z',1
+ write(12,*) '# deuxieme trace analytique'
+ write(12,*) '@ septraceref = 1'
+ write(12,*) '/bin/rm -f tutuan tutucomp'
+ write(12,320) 2,'x','x'
+ write(12,330) 'x',2
+ write(12,*) '/bin/rm -f tutuan tutucomp'
+ write(12,320) 2,'z','z'
+ write(12,330) 'z',2
+ write(12,*) '/bin/rm -f tutuan tutucomp'
+ close(12)
+
+!----
+!---- une trace avec comparaison analytique pour postscript
+!----
+
+ open(unit=12,file='pscomptrace',status='unknown')
+ write(12,110)
+ write(12,*)
+ write(12,*) 'set nt = ',nseis
+ write(12,*) 'set dt = ',sngl(deltat*isamp)
+ write(12,*) 'set traceana1 = ',n1ana
+ write(12,*) 'set traceana2 = ',n2ana
+ write(12,*) '# traces commencent a zero dans format SEP'
+ write(12,*) '@ septraceana1 = $traceana1 - 1'
+ write(12,*) '@ septraceana2 = $traceana2 - 1'
+ write(12,*) 'echo Generating PostScript files...'
+ write(12,*) '/bin/rm -f uxtracecompana1.ps uztracecompana1.ps'
+ write(12,*) '/bin/rm -f uxtracecompana2.ps uztracecompana2.ps'
+ write(12,*) '# premiere trace analytique'
+ write(12,*) '@ septraceref = 0'
+ write(12,*) '/bin/rm -f tutuan tutucomp'
+ write(12,320) 1,'x','x'
+ write(12,340) 'x',1,'x',1
+ write(12,*) '/bin/rm -f tutuan tutucomp'
+ write(12,320) 1,'z','z'
+ write(12,340) 'z',1,'z',1
+ write(12,*) '# deuxieme trace analytique'
+ write(12,*) '@ septraceref = 1'
+ write(12,*) '/bin/rm -f tutuan tutucomp'
+ write(12,320) 2,'x','x'
+ write(12,340) 'x',2,'x',2
+ write(12,*) '/bin/rm -f tutuan tutucomp'
+ write(12,320) 2,'z','z'
+ write(12,340) 'z',2,'z',2
+ write(12,*) '/bin/rm -f tutuan tutucomp'
+ close(12)
+
+!----
+!---- residus trace analytique pour Xwindow
+!----
+
+ open(unit=12,file='xresid',status='unknown')
+ write(12,110)
+ write(12,*)
+ write(12,*) 'set nt = ',nseis
+ write(12,*) 'set dt = ',sngl(deltat*isamp)
+ write(12,*) '@ trace=',n1ana
+ write(12,*) '@ septrace = $trace - 1'
+ iana = 0
+ write(12,170)
+ write(12,150) iana,iana
+ write(12,160)
+ write(12,*) '@ trace=',n2ana
+ write(12,*) '@ septrace = $trace - 1'
+ iana = 1
+ write(12,170)
+ write(12,150) iana,iana
+ write(12,160)
+ write(12,170)
+ close(12)
+
+!----
+!---- residus trace analytique pour PostScript (utilise Gnuplot)
+!----
+
+! facteur d'amplification des residus
+ open(unit=12,file='psresid',status='unknown')
+ write(12,110)
+ write(12,*)
+ write(12,*) 'set ampli = 5'
+ write(12,*) 'set nt = ',nseis
+ write(12,*) 'set dt = ',sngl(deltat*isamp)
+ write(12,200)
+ write(12,*) '@ trace=',n1ana
+ write(12,*) '@ septrace = $trace - 1'
+ iana = 0
+ write(12,170)
+ write(12,171)
+ write(12,151) iana,iana
+ write(12,152)
+ write(12,154)
+ write(12,155)
+ write(12,*) '@ trace=',n2ana
+ write(12,*) '@ septrace = $trace - 1'
+ iana = 1
+ write(12,170)
+ write(12,171)
+ write(12,151) iana,iana
+ write(12,152)
+ write(12,154)
+ write(12,155)
+ write(12,170)
+ write(12,171)
+ close(12)
+
+ 100 format('xwigb at xcur=',f8.2,'@n1=',i5, &
+ '@d1=',f15.8,'@label1="Time@(s)"@label2="x@(m)"@n2=', &
+ i5,'@x2=')
+ 110 format('#!/bin/csh -f')
+ 120 format('subset < Ux_file n1=$nt', &
+ ' if2s=$septrace n2s=1 | xgraph -geometry 1085x272', &
+ ' label1="Time (s)" label2="Amplitude (m)" ', &
+ ' n=$nt style=normal d1=$dt', &
+ ' title="Ux displacement component trace "$trace &')
+ 121 format('subset < Ux_file n1=$nt', &
+ ' if2s=$septrace n2s=1 | xgraph -geometry 1085x272', &
+ ' label1="Time (s)" label2="Amplitude (m)" ', &
+ ' n=$nt style=normal d1=$dt', &
+ ' title="Ux velocity component trace "$trace &')
+ 122 format('subset < Ux_file n1=$nt', &
+ ' if2s=$septrace n2s=1 | xgraph -geometry 1085x272', &
+ ' label1="Time (s)" label2="Amplitude (m)" ', &
+ ' n=$nt style=normal d1=$dt', &
+ ' title="Ux acceleration component trace "$trace &')
+ 125 format('subset < Uz_file n1=$nt', &
+ ' if2s=$septrace n2s=1 | xgraph -geometry 1085x272', &
+ ' label1="Time (s)" label2="Amplitude (m)" ', &
+ ' n=$nt style=normal d1=$dt', &
+ ' title="Uz displacement component trace "$trace &')
+ 126 format('subset < Uz_file n1=$nt', &
+ ' if2s=$septrace n2s=1 | xgraph -geometry 1085x272', &
+ ' label1="Time (s)" label2="Amplitude (m)" ', &
+ ' n=$nt style=normal d1=$dt', &
+ ' title="Uz velocity component trace "$trace &')
+ 127 format('subset < Uz_file n1=$nt', &
+ ' if2s=$septrace n2s=1 | xgraph -geometry 1085x272', &
+ ' label1="Time (s)" label2="Amplitude (m)" ', &
+ ' n=$nt style=normal d1=$dt', &
+ ' title="Uz acceleration component trace "$trace &')
+ 220 format('subset < Ux_file n1=$nt', &
+ ' if2s=$septrace n2s=1 | psgraph ', &
+ ' label1="Time (s)" label2="Amplitude (m)" ', &
+ ' n=$nt style=normal d1=$dt hbox=4.0 wbox=6.0', &
+ ' title="Ux displacement component trace "$trace > uxtrace{$trace}.ps')
+ 221 format('subset < Ux_file n1=$nt', &
+ ' if2s=$septrace n2s=1 | psgraph ', &
+ ' label1="Time (s)" label2="Amplitude (m)" ', &
+ ' n=$nt style=normal d1=$dt hbox=4.0 wbox=6.0', &
+ ' title="Ux velocity component trace "$trace > uxtrace{$trace}.ps')
+ 222 format('subset < Ux_file n1=$nt', &
+ ' if2s=$septrace n2s=1 | psgraph ', &
+ ' label1="Time (s)" label2="Amplitude (m)" ', &
+ ' n=$nt style=normal d1=$dt hbox=4.0 wbox=6.0', &
+ ' title="Ux acceleration component trace "$trace > uxtrace{$trace}.ps')
+ 225 format('subset < Uz_file n1=$nt', &
+ ' if2s=$septrace n2s=1 | psgraph ', &
+ ' label1="Time (s)" label2="Amplitude (m)" ', &
+ ' n=$nt style=normal d1=$dt hbox=4.0 wbox=6.0', &
+ ' title="Uz displacement component trace "$trace > uztrace{$trace}.ps')
+ 226 format('subset < Uz_file n1=$nt', &
+ ' if2s=$septrace n2s=1 | psgraph ', &
+ ' label1="Time (s)" label2="Amplitude (m)" ', &
+ ' n=$nt style=normal d1=$dt hbox=4.0 wbox=6.0', &
+ ' title="Uz velocity component trace "$trace > uztrace{$trace}.ps')
+ 227 format('subset < Uz_file n1=$nt', &
+ ' if2s=$septrace n2s=1 | psgraph ', &
+ ' label1="Time (s)" label2="Amplitude (m)" ', &
+ ' n=$nt style=normal d1=$dt hbox=4.0 wbox=6.0', &
+ ' title="Uz acceleration component trace "$trace > uztrace{$trace}.ps')
+ 130 format('sed -e ''1,$s/xwigb/pswigp/g'' ', &
+ '-e ''1,$s/Ux_file/Ux_file > uxpoly.ps/g'' ', &
+ '-e ''1,$s/Uz_file/Uz_file > uzpoly.ps/g'' ', &
+ 'xline > psline')
+ 137 format('sed -e ''1,$s/ //g'' -e ''1,$s/@/ /g'' ', &
+ '-e ''1,1p'' -e ''$,$s/Ux/Uz/g'' <tempfile > xline')
+ 140 format(f9.2)
+ 150 format('echo Extracting trace $trace...'/, &
+ 'subset < Ux_file_an n1=$nt if2s=',i1,' n2s=1 > Ux_num1'/, &
+ 'subset < Uz_file_an n1=$nt if2s=',i1,' n2s=1 > Uz_num1'/, &
+ 'subset < Ux_file n1=$nt if2s=$septrace n2s=1 > Ux_num2'/, &
+ 'subset < Uz_file n1=$nt if2s=$septrace n2s=1 > Uz_num2'/, &
+ 'cat Ux_num1 Ux_num2 > Ux_num'/, &
+ 'cat Uz_num1 Uz_num2 > Uz_num'/, &
+ 'suaddhead ns=$nt ftn=0 < Ux_num1 > Ux_num1_segy'/, &
+ 'suaddhead ns=$nt ftn=0 < Uz_num1 > Uz_num1_segy'/, &
+ 'suaddhead ns=$nt ftn=0 < Ux_num2 > Ux_num2_segy'/, &
+ 'suaddhead ns=$nt ftn=0 < Uz_num2 > Uz_num2_segy'/, &
+ 'echo Computing residuals...'/, &
+ 'suop2 Ux_num2_segy Ux_num1_segy op=diff > Ux_num_segy'/, &
+ 'suop2 Uz_num2_segy Uz_num1_segy op=diff > Uz_num_segy'/, &
+ 'sustrip head=/dev/null outpar=/dev/null ftn=0 ', &
+ '<Ux_num_segy > Ux_num_resid'/, &
+ 'sustrip head=/dev/null outpar=/dev/null ftn=0 ', &
+ '<Uz_num_segy > Uz_num_resid'/, &
+ 'cat Ux_num_resid >> Ux_num'/, &
+ 'cat Uz_num_resid >> Uz_num')
+ 151 format('echo Extracting trace $trace...'/, &
+ 'subset < Ux_file_an n1=$nt if2s=',i1,' n2s=1 > Ux_num1'/, &
+ 'subset < Uz_file_an n1=$nt if2s=',i1,' n2s=1 > Uz_num1'/, &
+ 'subset < Ux_file n1=$nt if2s=$septrace n2s=1 > Ux_num'/, &
+ 'subset < Uz_file n1=$nt if2s=$septrace n2s=1 > Uz_num'/, &
+ 'suaddhead ns=$nt ftn=0 < Ux_num1 > Ux_num1_segy'/, &
+ 'suaddhead ns=$nt ftn=0 < Uz_num1 > Uz_num1_segy'/, &
+ 'suaddhead ns=$nt ftn=0 < Ux_num > Ux_num2_segy'/, &
+ 'suaddhead ns=$nt ftn=0 < Uz_num > Uz_num2_segy'/, &
+ 'echo Computing residuals...'/, &
+ 'suop2 Ux_num2_segy Ux_num1_segy op=diff > Ux_num_segy'/, &
+ 'suop2 Uz_num2_segy Uz_num1_segy op=diff > Uz_num_segy'/, &
+ 'sustrip head=/dev/null outpar=/dev/null ftn=0 ', &
+ '<Ux_num_segy > Ux_num_resid'/, &
+ 'sustrip head=/dev/null outpar=/dev/null ftn=0 ', &
+ '<Uz_num_segy > Uz_num_resid')
+ 152 format('echo Multiplying residuals by $ampli ...',/, &
+ '/bin/rm -f prog_awk',/, &
+ 'echo \{print NR\*$dt , \$1\*=$ampli\} > prog_awk',/, &
+ 'b2a n1=1 outpar=/dev/null < Ux_num_resid | awk -f prog_awk', &
+ ' > Ux_num_resid_asc_mul',/, &
+ 'b2a n1=1 outpar=/dev/null < Uz_num_resid | awk -f prog_awk', &
+ ' > Uz_num_resid_asc_mul',/, &
+ '/bin/rm -f prog_awk',/, &
+ 'echo \{print NR\*$dt , \$1\} > prog_awk',/, &
+ 'b2a n1=1 outpar=/dev/null < Ux_num | awk -f prog_awk', &
+ ' > Ux_num_asc_txt',/, &
+ 'b2a n1=1 outpar=/dev/null < Uz_num | awk -f prog_awk', &
+ ' > Uz_num_asc_txt')
+ 154 format('echo Generating PostScript files...',/, &
+ 'gnuplot << EOF',/, &
+ 'set output "uxresid$trace.ps"',/, &
+ 'set term postscript landscape color solid "Helvetica" 22',/, &
+ 'set xrange [0:$tottime]',/, &
+ 'set title "Ux residuals trace $trace"',/, &
+ 'set xlabel "Time (s)"',/, &
+ 'set ylabel "Amplitude (m)"',/, &
+ 'set nozeroaxis',/, &
+ 'set data style lines',/, &
+ 'plot "Ux_num_asc_txt" us 1:2 title ', &
+ '"Numerical results" w l 1,', &
+ ' "Ux_num_resid_asc_mul" us 1:2 title ', &
+ '"Residuals * $ampli" w l 2',/, &
+ 'EOF')
+ 155 format('gnuplot << EOF',/, &
+ 'set output "uzresid$trace.ps"',/, &
+ 'set term postscript landscape color solid "Helvetica" 22',/, &
+ 'set xrange [0:$tottime]',/, &
+ 'set title "Uz residuals trace $trace"',/, &
+ 'set xlabel "Time (s)"',/, &
+ 'set ylabel "Amplitude (m)"',/, &
+ 'set nozeroaxis',/, &
+ 'set data style lines',/, &
+ 'plot "Uz_num_asc_txt" us 1:2 title ', &
+ '"Numerical results" w l 1,', &
+ ' "Uz_num_resid_asc_mul" us 1:2 title ', &
+ '"Residuals * $ampli" w l 2',/, &
+ 'EOF')
+ 160 format('xgraph -geometry 1085x272 label1="Time (s)" ', &
+ 'label2="Amplitude (m)" title="Ux residuals trace $trace ', &
+ '(blue=Numerical red=Analytical green=Residuals)" ', &
+ 'n=$nt style=normal d1=$dt nplot=3 linecolor=2,4,3 < Ux_num &',/, &
+ 'xgraph -geometry 1085x272 label1="Time (s)" ', &
+ 'label2="Amplitude (m)" title="Uz residuals trace $trace ', &
+ '(blue=Numerical red=Analytical green=Residuals)" ', &
+ 'n=$nt style=normal d1=$dt nplot=3 linecolor=2,4,3 < Uz_num &')
+ 170 format('/bin/rm -f Ux_num1 Ux_num2 Ux_num Ux_num1_segy Ux_num2_segy ', &
+ 'Ux_num_segy Ux_num_resid Ux_num_segy Ux_num_resid_asc_mul ', &
+ 'Ux_num_asc_txt Uz_num1 Uz_num2 Uz_num Uz_num1_segy Uz_num2_segy ', &
+ 'Uz_num_segy Uz_num_resid Uz_num_segy Uz_num_resid_asc_mul Uz_num_asc_txt')
+ 171 format('/bin/rm -f prog_awk')
+ 200 format('set tottime = `echo $dt | awk ''{ print $1*i }'' i=$nt `', &
+ /,'echo Total time $tottime seconds...')
+ 320 format('subset n1=$nt if2s=$septraceana',i1,' n2s=1 < U',a1,'_file ', &
+ '> tutucomp ; subset n1=$nt if2s=$septraceref n2s=1 < U',a1,'_file_an ', &
+ '> tutuan')
+ 330 format('cat tutuan tutucomp | xgraph -geometry 1085x272 ', &
+ 'linecolor=2,4 label1="Time (s)" label2="Amplitude (m)" nplot=2 ', &
+ 'n=$nt,$nt style=normal d1=$dt title="U',a1,' component numerical ', &
+ '(blue) and analytical (red) trace "$traceana',i1,' &')
+ 340 format('cat tutuan tutucomp | psgraph hbox=4.0 wbox=6.0 ', &
+ 'linecolor=red,blue label1="Time (s)" label2="Amplitude (m)" nplot=2 ', &
+ 'n=$nt,$nt style=normal d1=$dt title="U',a1,' numerical (blue) ', &
+ 'and analytical (red) trace "$traceana',i1,' > u',a1,'tracecompana',i1,'.ps')
+
+ return
+ end subroutine writeseis
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/zwgjd.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/zwgjd.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/zwgjd.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,82 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine zwgjd(z,w,np,alpha,beta)
+!
+!=======================================================================
+!
+! Z w g j d : Generate np Gauss-Jacobi points and weights
+! associated with Jacobi polynomial of degree n = np-1
+!
+!=======================================================================
+!
+! Note : Coefficients alpha and beta must be greater than -1.
+! ----
+!
+!=======================================================================
+!
+ implicit none
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision z(np),w(np)
+ double precision alpha,beta
+
+ integer n,np1,np2,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision apb,dnp1,dnp2,fac1,fac2,fac3,fnorm,rcoef
+ double precision, external :: gammaf,pnormj
+!
+!-----------------------------------------------------------------------
+!
+ pd = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ apb = alpha+beta
+ p = zero
+ pdm1 = zero
+
+ if (np <= 0) stop 'Minimum number of Gauss points is 1'
+
+ if ((alpha <= -one).or.(beta <= -one)) &
+ stop 'Alpha and Beta must be greater than -1'
+
+ if (np == 1) then
+ z(1) = (beta-alpha)/(apb+two)
+ w(1) = gammaf(alpha+one)*gammaf(beta+one)/gammaf(apb+two) * two**(apb+one)
+ return
+ endif
+
+ call jacg (z,np,alpha,beta)
+
+ np1 = n+1
+ np2 = n+2
+ dnp1 = dble(np1)
+ dnp2 = dble(np2)
+ fac1 = dnp1+alpha+beta+one
+ fac2 = fac1+dnp1
+ fac3 = fac2+one
+ fnorm = pnormj(np1,alpha,beta)
+ rcoef = (fnorm*fac2*fac3)/(two*fac1*dnp2)
+ do i=1,np
+ call jacobf (p,pd,pm1,pdm1,pm2,pdm2,np2,alpha,beta,z(i))
+ w(i) = -rcoef/(p*pdm1)
+ enddo
+
+ return
+ end subroutine zwgjd
Added: seismo/2D/SPECFEM2D/trunk/SPECFEM90/zwgljd.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/zwgljd.f90 2007-12-07 23:43:55 UTC (rev 8411)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/zwgljd.f90 2007-12-07 23:44:01 UTC (rev 8412)
@@ -0,0 +1,77 @@
+!=====================================================================
+!
+! S p e c f e m V e r s i o n 4 . 2
+! -----------------------------------
+!
+! Dimitri Komatitsch
+! Department of Earth and Planetary Sciences - Harvard University
+! Jean-Pierre Vilotte
+! Departement de Sismologie - IPGP - Paris
+! (c) June 1998
+!
+!=====================================================================
+
+ subroutine zwgljd (z,w,np,alpha,beta)
+!
+!=======================================================================
+!
+! Z w g l j d : Generate np Gauss-Lobatto-Jacobi points and the
+! ----------- weights associated with Jacobi polynomials of degree
+! n = np-1.
+!
+!=======================================================================
+!
+! Note : alpha and beta coefficients must be greater than -1.
+! ----
+! Legendre polynomials are special case of Jacobi polynomials
+! just by setting alpha and beta to 0.
+!
+!=======================================================================
+!
+ implicit none
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision alpha,beta
+ double precision z(np), w(np)
+
+ integer n,nm1,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision alpg,betg
+ double precision, external :: endw1,endw2
+!
+!-----------------------------------------------------------------------
+!
+ p = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ nm1 = n-1
+ pd = zero
+
+ if (np <= 1) stop 'Minimum number of Gauss-Lobatto points is 2'
+
+ if ((alpha <= -one).or.(beta <= -one)) &
+ stop 'Alpha and Beta must be greater than -1'
+
+ if (nm1 > 0) then
+ alpg = alpha+one
+ betg = beta+one
+ call zwgjd (z(2),w(2),nm1,alpg,betg)
+ endif
+ z(1) = - one
+ z(np) = one
+ do 110 i=2,np-1
+ w(i) = w(i)/(one-z(i)**2)
+ 110 continue
+ call jacobf (p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(1))
+ w(1) = endw1 (n,alpha,beta)/(two*pd)
+ call jacobf (p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(np))
+ w(np) = endw2 (n,alpha,beta)/(two*pd)
+
+ return
+ end subroutine zwgljd
More information about the cig-commits
mailing list