[cig-commits] r8418 - seismo/2D/SPECFEM2D/trunk/SPECFEM90
walter at geodynamics.org
walter at geodynamics.org
Fri Dec 7 15:44:39 PST 2007
Author: walter
Date: 2007-12-07 15:44:38 -0800 (Fri, 07 Dec 2007)
New Revision: 8418
Added:
seismo/2D/SPECFEM2D/trunk/SPECFEM90/constants.h
seismo/2D/SPECFEM2D/trunk/SPECFEM90/gll_library.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/lagrange_poly.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/specfem2D.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/write_seismograms.f90
Removed:
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/checksource.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/contol.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/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/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/qinpspec.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
Modified:
seismo/2D/SPECFEM2D/trunk/SPECFEM90/Makefile
seismo/2D/SPECFEM2D/trunk/SPECFEM90/checkgrid.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/gmat01.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotgll.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotpost.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/qmasspec.f90
seismo/2D/SPECFEM2D/trunk/SPECFEM90/qsumspec.f90
Log:
cleaned SEM_2D_Dimitri solver, converted to version 5.0 with no modules,
suppressed useless or obsolete subroutines
Modified: seismo/2D/SPECFEM2D/trunk/SPECFEM90/Makefile
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/Makefile 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/Makefile 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,202 +1,93 @@
#
-# Makefile simple pour f90
+# Makefile for SPECFEM2D version 5.0
#
-# Dimitri Komatitsch, Harvard University, May 1998
+# Dimitri Komatitsch, Universite de Pau et des Pays de l'Adour, May 2004
#
SHELL=/bin/sh
-B = .
O = obj
-SRC = .
-TRNDIR = ./bak
-# Portland
+# Portland Linux
#F90 = pgf90
-#FLAGS=-c -fast -Mnobounds -Minline -Mneginfo -Mdclchk
+#FLAGS=-fast -Mnobounds -Minline -Mneginfo -Mdclchk
-# Dec Alpha
-#F90 = f90
-#FLAGS=-c -fast -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nounderflow -check bounds
-
# Intel Linux
F90 = ifort
-FLAGS=-c -O3 -e95 -implicitnone
+#FLAGS=-O0 -implicitnone -warn stderrors -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check bounds -C
+FLAGS=-fast -implicitnone -warn stderrors -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nobounds
+# Dec Alpha
+#F90 = f90
+#FLAGS=-O0 -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nounderflow -check bounds -C
+##FLAGS=-fast -warn truncated_source -warn argument_checking -warn unused -warn declarations -std95 -check nounderflow -check nobounds
+
LINK = $(F90)
-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 = .
+EXEC = xspecfem2D
+OBJS = $O/checkgrid.o $O/datim.o $O/defarrays.o\
+ $O/lagrange_poly.o $O/gmat01.o $O/gll_library.o $O/plotgll.o\
+ $O/plotpost.o $O/positrec.o $O/positsource.o $O/q49spec.o\
+ $O/qmasspec.o $O/qsumspec.o $O/specfem2D.o\
+ $O/write_seismograms.o $O/createnum_fast.o $O/createnum_slow.o $O/q49shape.o
-.f90.o:
- $(F90) $(FLAGS) $*.f90
+default: all
-default : $(OBJS) mxspecfem
-
-TIMESTAMP: $(SRC)/*.f90 $(SRC)/Makefile
- cp $? ${TRNDIR}
- touch TIMESTAMP
-
-mxspecfem : $(DIRS)
- $(LINK) $(OBJS) -o $(EXEC)
-
-all : clean $(OBJS) mxspecfem
-
-clean :
+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
+all: $(OBJS)
+ $(LINK) $(FLAGS) -o $(EXEC) $(OBJS)
+
+$O/checkgrid.o: checkgrid.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/checkgrid.o checkgrid.f90
-$O/calcdivcurl.o: $(SRC)/calcdivcurl.f90
- ${F90} $(FLAGS) -c -o $O/calcdivcurl.o $(SRC)/calcdivcurl.f90
+$O/createnum_fast.o: createnum_fast.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/createnum_fast.o createnum_fast.f90
-$O/calcforce.o: $(SRC)/calcforce.f90
- ${F90} $(FLAGS) -c -o $O/calcforce.o $(SRC)/calcforce.f90
+$O/createnum_slow.o: createnum_slow.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/createnum_slow.o createnum_slow.f90
-$O/checkgrid.o: $(SRC)/checkgrid.f90
- ${F90} $(FLAGS) -c -o $O/checkgrid.o $(SRC)/checkgrid.f90
+$O/datim.o: datim.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/datim.o datim.f90
-$O/checksource.o: $(SRC)/checksource.f90
- ${F90} $(FLAGS) -c -o $O/checksource.o $(SRC)/checksource.f90
+$O/defarrays.o: defarrays.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/defarrays.o defarrays.f90
-$O/contol.o: $(SRC)/contol.f90
- ${F90} $(FLAGS) -c -o $O/contol.o $(SRC)/contol.f90
+$O/lagrange_poly.o: lagrange_poly.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/lagrange_poly.o lagrange_poly.f90
-$O/createnum_fast.o: $(SRC)/createnum_fast.f90
- ${F90} $(FLAGS) -c -o $O/createnum_fast.o $(SRC)/createnum_fast.f90
+$O/gmat01.o: gmat01.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/gmat01.o gmat01.f90
-$O/createnum_slow.o: $(SRC)/createnum_slow.f90
- ${F90} $(FLAGS) -c -o $O/createnum_slow.o $(SRC)/createnum_slow.f90
+$O/gll_library.o: gll_library.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/gll_library.o gll_library.f90
-$O/datim.o: $(SRC)/datim.f90
- ${F90} $(FLAGS) -c -o $O/datim.o $(SRC)/datim.f90
+$O/plotgll.o: plotgll.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/plotgll.o plotgll.f90
-$O/defarrays.o: $(SRC)/defarrays.f90
- ${F90} $(FLAGS) -c -o $O/defarrays.o $(SRC)/defarrays.f90
+$O/plotpost.o: plotpost.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/plotpost.o plotpost.f90
-$O/dirac.o: $(SRC)/dirac.f90
- ${F90} $(FLAGS) -c -o $O/dirac.o $(SRC)/dirac.f90
+$O/positrec.o: positrec.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/positrec.o positrec.f90
-$O/dircty.o: $(SRC)/dircty.f90
- ${F90} $(FLAGS) -c -o $O/dircty.o $(SRC)/dircty.f90
+$O/positsource.o: positsource.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/positsource.o positsource.f90
-$O/endw1.o: $(SRC)/endw1.f90
- ${F90} $(FLAGS) -c -o $O/endw1.o $(SRC)/endw1.f90
+$O/q49shape.o: q49shape.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/q49shape.o q49shape.f90
-$O/endw2.o: $(SRC)/endw2.f90
- ${F90} $(FLAGS) -c -o $O/endw2.o $(SRC)/endw2.f90
+$O/q49spec.o: q49spec.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/q49spec.o q49spec.f90
-$O/ezfftf.o: $(SRC)/ezfftf.f90
- ${F90} $(FLAGS) -c -o $O/ezfftf.o $(SRC)/ezfftf.f90
+$O/qmasspec.o: qmasspec.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/qmasspec.o qmasspec.f90
-$O/gammaf.o: $(SRC)/gammaf.f90
- ${F90} $(FLAGS) -c -o $O/gammaf.o $(SRC)/gammaf.f90
+$O/qsumspec.o: qsumspec.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/qsumspec.o qsumspec.f90
-$O/getelspec.o: $(SRC)/getelspec.f90
- ${F90} $(FLAGS) -c -o $O/getelspec.o $(SRC)/getelspec.f90
+$O/specfem2D.o: specfem2D.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/specfem2D.o specfem2D.f90
-$O/getltf.o: $(SRC)/getltf.f90
- ${F90} $(FLAGS) -c -o $O/getltf.o $(SRC)/getltf.f90
+$O/write_seismograms.o: write_seismograms.f90 constants.h
+ ${F90} $(FLAGS) -c -o $O/write_seismograms.o write_seismograms.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
-
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/calc_energie.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/calc_energie.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/calc_energie.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,141 +0,0 @@
-
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/calcdivcurl.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/calcdivcurl.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/calcdivcurl.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,99 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/calcforce.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/calcforce.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/calcforce.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,55 +0,0 @@
-!=====================================================================
-!
-! 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
Modified: seismo/2D/SPECFEM2D/trunk/SPECFEM90/checkgrid.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/checkgrid.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/checkgrid.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,33 +1,33 @@
-!=====================================================================
+
+!========================================================================
!
-! S p e c f e m V e r s i o n 4 . 2
-! -----------------------------------
+! S P E C F E M 2 D Version 5.0
+! ------------------------------
!
! Dimitri Komatitsch
-! Department of Earth and Planetary Sciences - Harvard University
-! Jean-Pierre Vilotte
-! Departement de Sismologie - IPGP - Paris
-! (c) June 1998
+! Universite de Pau et des Pays de l'Adour, France
!
-!=====================================================================
+! (c) May 2004
+!
+!========================================================================
- subroutine checkgrid(deltat,gltfu,nltfl,initialfield)
+ subroutine checkgrid(deltat,gltfu,initialfield,rsizemin,rsizemax, &
+ cpoverdxmin,cpoverdxmax,rlamdaSmin,rlamdaSmax,rlamdaPmin,rlamdaPmax)
!
!---- 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
+ include "constants.h"
+
+ double precision gltfu(20)
+ double precision deltat,rsizemin,rsizemax,cpoverdxmin,cpoverdxmax, &
+ rlamdaSmin,rlamdaSmax,rlamdaPmin,rlamdaPmax
+
logical initialfield
- integer n,isource
double precision f0,t0
!
@@ -47,56 +47,32 @@
print *,'*** Stabilite min vitesse P = ',cpoverdxmin*deltat
print *
-!
-!---- boucle sur toutes les sources
-!
-
if(.not. initialfield) then
- do n=1,nltfl
+ f0 = gltfu(5)
+ t0 = gltfu(6)
-!
-!---- determiner type de source
-!
- isource = nint(gltfu(1,n))
- f0 = gltfu(5,n)
- t0 = gltfu(6,n)
+ print *,' Onset time = ',t0
+ print *,' Fundamental period = ',1.d0/f0
+ print *,' Fundamental frequency = ',f0
+ if(t0 <= 1.d0/f0) then
+ stop 'Onset time too small'
+ else
+ print *,' --> onset time ok'
+ endif
+ print *,'----'
+ print *,' Nb pts / lambda P max f0 = ',NGLLX*rlamdaPmax/f0
+ print *,' Nb pts / lambda P min f0 = ',NGLLX*rlamdaPmin/f0
+ print *,' Nb pts / lambda P max fmax = ',NGLLX*rlamdaPmax/(2.5d0*f0)
+ print *,' Nb pts / lambda P min fmax = ',NGLLX*rlamdaPmin/(2.5d0*f0)
+ print *,'----'
+ print *,' Nb pts / lambda S max f0 = ',NGLLX*rlamdaSmax/f0
+ print *,' Nb pts / lambda S min f0 = ',NGLLX*rlamdaSmin/f0
+ print *,' Nb pts / lambda S max fmax = ',NGLLX*rlamdaSmax/(2.5d0*f0)
+ print *,' Nb pts / lambda S min fmax = ',NGLLX*rlamdaSmin/(2.5d0*f0)
+ print *,'----'
-!
-!---- 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
+
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/checksource.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/checksource.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/checksource.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,134 +0,0 @@
-!=====================================================================
-!
-! 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/constants.h
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/constants.h 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/constants.h 2007-12-07 23:44:38 UTC (rev 8418)
@@ -0,0 +1,77 @@
+
+! polynomial degree
+ integer, parameter :: NGLLX = 5
+ integer, parameter :: NGLLY = NGLLX
+
+! select fast (Paul Fischer) or slow (topology only) global numbering algorithm
+ logical, parameter :: FAST_NUMBERING = .true.
+
+! mesh tolerance for fast global numbering
+ double precision, parameter :: SMALLVALTOL = 0.000001d0
+
+! input and output files
+ integer, parameter :: IIN = 40
+
+! uncomment this to write to standard output
+ integer, parameter :: IOUT = 6
+! uncomment this to write to file instead
+! integer, parameter :: IOUT = 41
+
+! flags for absorbing boundaries
+ integer, parameter :: IHAUT = 1
+ integer, parameter :: IBAS = 2
+ integer, parameter :: IGAUCHE = 3
+ integer, parameter :: IDROITE = 4
+
+ integer, parameter :: IARETEBAS = 1
+ integer, parameter :: IARETEDROITE = 2
+ integer, parameter :: IARETEHAUT = 3
+ integer, parameter :: IARETEGAUCHE = 4
+
+! a few useful constants
+ double precision, parameter :: ZERO = 0.d0,ONE = 1.d0
+ double precision, parameter :: HALF = 0.5d0,TWO = 2.0d0
+ double precision, parameter :: PI = 3.141592653589793d0
+
+! parameters to define the Gauss-Lobatto-Legendre points
+ double precision, parameter :: GAUSSALPHA = ZERO,GAUSSBETA = ZERO
+
+! large value for maximum
+ double precision, parameter :: HUGEVAL = 1.d+30
+
+! number of spatial dimensions
+ integer, parameter :: NDIME = 2
+
+! X and Z scaling du display pour PostScript
+ double precision, parameter :: SCALEX = 1.d0
+ double precision, parameter :: SCALEZ = 1.d0
+
+! taille de la plus grande fleche en centimetres
+ double precision, parameter :: SIZEMAX = 1.d0
+
+! US letter paper or European A4
+ logical, parameter :: US_LETTER = .false.
+
+! write symbols on PostScript display
+ logical, parameter :: ISYMBOLS = .true.
+
+! X and Z axis origin of PostScript plot in centimeters
+ double precision, parameter :: ORIG_X = 2.4d0
+ double precision, parameter :: ORIG_Z = 2.9d0
+
+! dot to centimeter conversion for PostScript
+ double precision, parameter :: CENTIM = 28.5d0
+
+! parameters for arrows for PostScript snapshot
+ double precision, parameter :: ANGLE = 20.d0
+ double precision, parameter :: RAPPORT = 0.40d0
+
+! ecrire legendes ou non in PostScript display
+ logical, parameter :: LEGENDES = .true.
+
+! limite pour afficher des points a la place des recepteurs
+ integer, parameter :: NDOTS = 30
+
+! taille de la fenetre de display Postscript en pourcentage de la feuille
+ double precision, parameter :: RPERCENTX = 70.0d0,RPERCENTZ = 77.0d0
+
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/contol.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/contol.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/contol.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,180 +0,0 @@
-!=====================================================================
-!
-! 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
Modified: seismo/2D/SPECFEM2D/trunk/SPECFEM90/createnum_fast.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/createnum_fast.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/createnum_fast.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,52 +1,32 @@
-!=====================================================================
+!========================================================================
!
-! S p e c f e m V e r s i o n 4 . 2
-! -----------------------------------
+! S P E C F E M 2 D Version 5.0
+! ------------------------------
!
! Dimitri Komatitsch
-! Department of Earth and Planetary Sciences - Harvard University
-! Jean-Pierre Vilotte
-! Departement de Sismologie - IPGP - Paris
-! (c) June 1998
+! Universite de Pau et des Pays de l'Adour, France
!
-!=====================================================================
-
- subroutine createnum_fast(knods,ibool,shape,coorg,npoin,ndime,npgeo)
+! (c) May 2004
!
-!=======================================================================
-!
-! "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
+ subroutine createnum_fast(knods,ibool,shape,coorg,npoin,npgeo,nspec,ngnod)
+! equivalent de la routine "createnum_slow" mais algorithme plus rapide
+
implicit none
- integer npoin,ndime,npgeo
- integer knods(ngnod,nspec),ibool(nxgll,nygll,nspec)
- double precision shape(ngnod,nxgll,nxgll)
- double precision coorg(ndime,npgeo)
+ include "constants.h"
+ integer npoin,npgeo,nspec,ngnod
+ integer knods(ngnod,nspec),ibool(NGLLX,NGLLY,nspec)
+ double precision shape(ngnod,NGLLX,NGLLX)
+ double precision coorg(NDIME,npgeo)
+
integer i,j
- 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
@@ -57,23 +37,15 @@
double precision xmaxval,xminval,ymaxval,yminval,xtol,xtypdist
double precision xcor,ycor
-!
-!-----------------------------------------------------------------------
-!
-
-!
-!---- create global numbering from mesh structure
-!
+!---- create global mesh numbering
print *
print *
- print *,'Generating global numbering from mesh structure (fast version)...'
+ print *,'Generating global mesh numbering (fast version)...'
print *
- nxyz = nxgll*nygll
+ nxyz = NGLLX*NGLLY
ntot = nxyz*nspec
- print *,'Allocating a few more arrays for the fast version'
-
allocate(loc(ntot))
allocate(ind(ntot))
allocate(ninseg(ntot))
@@ -84,15 +56,13 @@
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
+ do iy = 1,NGLLX
+ do ix = 1,NGLLX
ilocnum = ilocnum + 1
@@ -154,7 +124,7 @@
ifseg(1) = .true.
ninseg(1) = ntot
- do j=1,ndime
+ do j=1,NDIME
! Sort within each segment
ioff=1
do iseg=1,nseg
@@ -206,16 +176,14 @@
do ispec=1,nspec
ieoff = nxyz*(ispec - 1)
ilocnum = 0
- do iy = 1,nxgll
- do ix = 1,nxgll
+ do iy = 1,NGLLX
+ do ix = 1,NGLLX
ilocnum = ilocnum + 1
ibool(ix,iy,ispec) = iglob(ilocnum + ieoff)
enddo
enddo
enddo
- print *,'Deallocating the arrays'
-
deallocate(loc)
deallocate(ind)
deallocate(ninseg)
@@ -227,18 +195,17 @@
deallocate(iwork)
! verification de la coherence de la numerotation generee
- if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) &
- stop 'Error while generating global numbering'
+ 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)
@@ -258,24 +225,24 @@
if (n == 1) return
L=n/2+1
ir=n
- 100 CONTINUE
+ 100 continue
IF (l > 1) THEN
- l=l-1
- indx=ind(l)
- q=a(indx)
+ 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
+ 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
+ 200 continue
IF (J <= IR) THEN
IF (J < IR) THEN
IF ( A(IND(j)) < A(IND(j+1)) ) j=j+1
@@ -291,9 +258,11 @@
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)
@@ -307,14 +276,13 @@
integer j
do J=1,N
- W(j)=A(j)
+ W(j)=A(j)
enddo
do J=1,N
- A(j)=W(ind(j))
+ A(j)=W(ind(j))
enddo
- RETURN
end subroutine swap
!-----------------------------------------------------------------------
@@ -331,13 +299,12 @@
integer j
do J=1,N
- W(j)=A(j)
+ W(j)=A(j)
enddo
do J=1,N
- A(j)=W(ind(j))
+ A(j)=W(ind(j))
enddo
- RETURN
end subroutine iswap
Modified: seismo/2D/SPECFEM2D/trunk/SPECFEM90/createnum_slow.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/createnum_slow.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/createnum_slow.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,52 +1,39 @@
-!=====================================================================
+!========================================================================
!
-! S p e c f e m V e r s i o n 4 . 2
-! -----------------------------------
+! S P E C F E M 2 D Version 5.0
+! ------------------------------
!
! Dimitri Komatitsch
-! Department of Earth and Planetary Sciences - Harvard University
-! Jean-Pierre Vilotte
-! Departement de Sismologie - IPGP - Paris
-! (c) June 1998
+! Universite de Pau et des Pays de l'Adour, France
!
-!=====================================================================
-
- subroutine createnum_slow(knods,ibool,npoin)
+! (c) May 2004
!
-!=======================================================================
-!
-! "c r e a t e n u m _ s l o w": generate the global numbering
-!
-!=======================================================================
-!
+!========================================================================
- use iounit
- use infos
- use spela202
+ subroutine createnum_slow(knods,ibool,npoin,nspec,ngnod)
+! generate the global numbering
+
implicit none
- integer knods(ngnod,nspec),ibool(nxgll,nygll,nspec)
- integer npoin
+ include "constants.h"
+ integer npoin,nspec,ngnod
+
+ integer knods(ngnod,nspec),ibool(NGLLX,NGLLY,nspec)
+
integer i,j,num2,i2,j2,ipos,ipos2,iloc,jloc,kloc
integer ngnodloc,ngnodother,nedgeloc,nedgeother,npedge,numelem,npcorn
+
logical alreadyexist
integer ngnoddeb(4),ngnodfin(4)
-!
-!-----------------------------------------------------------------------
-!
-
-!
-!---- create global numbering from mesh structure
-!
+!---- create global mesh numbering
print *
+ print *,'Generating global mesh numbering (slow version)...'
print *
- print *,'Generating global numbering from mesh structure (slow version)...'
- print *
npoin = 0
npedge = 0
@@ -71,26 +58,20 @@
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
+ ibool(:,:,:) = 0
do numelem = 1,nspec
- do i=1,nxgll
- do j=1,nygll
+ do i=1,NGLLX
+ do j=1,NGLLY
! verifier que le point n'a pas deja ete genere
- if(ibool(i,j,numelem) == 0) then
+ 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
+ if(i /= 1 .and. i /= NGLLX .and. j /= 1 .and. j /= NGLLY) then
npoin = npoin + 1
ibool(i,j,numelem) = npoin
@@ -98,17 +79,17 @@
!
!---- 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
+ else if((i == 1 .and. j == 1) .or. (i == 1 .and. j == NGLLY) .or. &
+ (i == NGLLX .and. j == 1) .or. (i == NGLLX .and. j == NGLLY)) then
! trouver numero local du coin
- if(i == 1.and.j == 1) then
+ if(i == 1 .and. j == 1) then
ngnodloc = 1
- else if(i == nxgll.and.j == 1) then
+ else if(i == NGLLX .and. j == 1) then
ngnodloc = 2
- else if(i == nxgll.and.j == nygll) then
+ else if(i == NGLLX .and. j == NGLLY) then
ngnodloc = 3
- else if(i == 1.and.j == nygll) then
+ else if(i == 1 .and. j == NGLLY) then
ngnodloc = 4
endif
@@ -116,7 +97,7 @@
alreadyexist = .false.
- if(numelem > 1) then
+ if(numelem > 1) then
do num2=1,numelem-1
@@ -124,22 +105,22 @@
do ngnodother=1,4
! voir si ce coin a deja ete genere
- if(knods(ngnodother,num2) == knods(ngnodloc,numelem)) then
+ if(knods(ngnodother,num2) == knods(ngnodloc,numelem)) then
alreadyexist = .true.
! obtenir la numerotation dans l'autre element
- if(ngnodother == 1) then
+ if(ngnodother == 1) then
i2 = 1
j2 = 1
- else if(ngnodother == 2) then
- i2 = nxgll
+ else if(ngnodother == 2) then
+ i2 = NGLLX
j2 = 1
- else if(ngnodother == 3) then
- i2 = nxgll
- j2 = nygll
- else if(ngnodother == 4) then
+ else if(ngnodother == 3) then
+ i2 = NGLLX
+ j2 = NGLLY
+ else if(ngnodother == 4) then
i2 = 1
- j2 = nygll
+ j2 = NGLLY
else
stop 'bad corner'
endif
@@ -173,9 +154,9 @@
! trouver numero local de l'arete
if(j == 1) then
nedgeloc = 1
- else if(i == nxgll) then
+ else if(i == NGLLX) then
nedgeloc = 2
- else if(j == nygll) then
+ else if(j == NGLLY) then
nedgeloc = 3
else if(i == 1) then
nedgeloc = 4
@@ -185,7 +166,7 @@
alreadyexist = .false.
- if(numelem > 1) then
+ if(numelem > 1) then
do num2=1,numelem-1
@@ -194,9 +175,9 @@
!--- detecter un eventuel defaut dans la structure topologique du maillage
- if((knods(ngnoddeb(nedgeother),num2) == knods(ngnoddeb(nedgeloc),numelem)) &
+ if((knods(ngnoddeb(nedgeother),num2) == knods(ngnoddeb(nedgeloc),numelem)) &
.and. &
- (knods(ngnodfin(nedgeother),num2) == knods(ngnodfin(nedgeloc),numelem))) then
+ (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
@@ -208,28 +189,28 @@
alreadyexist = .true.
! obtenir la numerotation dans l'autre element
-! maillage conforme donc on doit supposer que nxgll == nygll
+! maillage conforme donc on doit supposer que NGLLX == NGLLY
! generer toute l'arete pour eviter des recherches superflues
- do kloc = 2,nxgll-1
+ do kloc = 2,NGLLX-1
! calculer l'abscisse le long de l'arete de depart
- if(nedgeloc == 1) then
+ if(nedgeloc == 1) then
iloc = kloc
jloc = 1
ipos = iloc
- else if(nedgeloc == 2) then
- iloc = nxgll
+ else if(nedgeloc == 2) then
+ iloc = NGLLX
jloc = kloc
ipos = jloc
- else if(nedgeloc == 3) then
+ else if(nedgeloc == 3) then
iloc = kloc
- jloc = nygll
- ipos = nxgll - iloc + 1
- else if(nedgeloc == 4) then
+ jloc = NGLLY
+ ipos = NGLLX - iloc + 1
+ else if(nedgeloc == 4) then
iloc = 1
jloc = kloc
- ipos = nygll - jloc + 1
+ ipos = NGLLY - jloc + 1
else
stop 'bad nedgeloc'
endif
@@ -237,30 +218,30 @@
! 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
+ ipos2 = NGLLX - ipos + 1
! calculer les coordonnees reelles dans l'element d'arrivee
- if(nedgeother == 1) then
+ if(nedgeother == 1) then
i2 = ipos2
j2 = 1
- else if(nedgeother == 2) then
- i2 = nxgll
+ else if(nedgeother == 2) then
+ i2 = NGLLX
j2 = ipos2
- else if(nedgeother == 3) then
- i2 = nxgll - ipos2 + 1
- j2 = nygll
- else if(nedgeother == 4) then
+ else if(nedgeother == 3) then
+ i2 = NGLLX - ipos2 + 1
+ j2 = NGLLY
+ else if(nedgeother == 4) then
i2 = 1
- j2 = nygll - ipos2 + 1
+ j2 = NGLLY - 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'
+ 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'
+ if(ibool(i2,j2,num2) == 0) stop 'point inconnu dans le maillage'
! affecter le meme numero
ibool(iloc,jloc,numelem) = ibool(i2,j2,num2)
@@ -294,17 +275,15 @@
enddo
! verification de la coherence de la numerotation generee
- if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) &
- stop 'Error while generating global numbering'
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) stop 'Error while generating global numbering'
print *,'Total number of points of the global mesh: ',npoin
+ print *,'distributed as follows:'
print *
- print *,'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
+
Modified: seismo/2D/SPECFEM2D/trunk/SPECFEM90/datim.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/datim.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/datim.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,38 +1,30 @@
-!=====================================================================
+
+!========================================================================
!
-! S p e c f e m V e r s i o n 4 . 2
-! -----------------------------------
+! S P E C F E M 2 D Version 5.0
+! ------------------------------
!
! Dimitri Komatitsch
-! Department of Earth and Planetary Sciences - Harvard University
-! Jean-Pierre Vilotte
-! Departement de Sismologie - IPGP - Paris
-! (c) June 1998
+! Universite de Pau et des Pays de l'Adour, France
!
-!=====================================================================
-
- subroutine datim (string1,string2,iout)
+! (c) May 2004
!
-!=======================================================================
-!
-! D a t i m : Get date and time using f90 portable routines
-! ---------
-!
-!=======================================================================
-!
+!========================================================================
+
+ subroutine datim(string_input)
+
+! get date and time using f90 portable routines
+
implicit none
- character(len=*) string1
- character(len=50) string2
+ include "constants.h"
+
+ character(len=50) string_input
character(len=8) datein
- character(len=10) timein
+ character(len=10) timein
character(len=16) dateprint
- character(len=8) timeprint
+ character(len=8) timeprint
- integer iout
-
-!-----------------------------------------------------------------------
-
datein = ''
timein = ''
@@ -41,21 +33,17 @@
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
+ write(iout,100)
+ write(iout,101) string_input
+ 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('-'))
+ 100 format(//1x,79('-')/1x,79('-')/1x,'Program SPECFEM2D: ')
+ 101 format(1x,79('-')/1x,79('-')/1x,a50)
+ 102 format(1x,79('-')/,1x,79('-')/' D a t e : ',a16,30x,' T i m e : ',a8/1x,79('-'),/1x,79('-'))
end subroutine datim
+
Modified: seismo/2D/SPECFEM2D/trunk/SPECFEM90/defarrays.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/defarrays.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/defarrays.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,89 +1,73 @@
-!=====================================================================
+!========================================================================
!
-! S p e c f e m V e r s i o n 4 . 2
-! -----------------------------------
+! S P E C F E M 2 D Version 5.0
+! ------------------------------
!
! Dimitri Komatitsch
-! Department of Earth and Planetary Sciences - Harvard University
-! Jean-Pierre Vilotte
-! Departement de Sismologie - IPGP - Paris
-! (c) June 1998
+! Universite de Pau et des Pays de l'Adour, France
!
-!=====================================================================
+! (c) May 2004
+!
+!========================================================================
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
-!
-!=======================================================================
-!
+ xigll,yigll,wxgll,wygll,hprime,hTprime, &
+ a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13x,a13z, &
+ ibool,kmato,dvolu,xjaci,coord,gltfu, &
+ numabs,codeabs,anyabs,npoin,rsizemin,rsizemax, &
+ cpoverdxmin,cpoverdxmax,rlamdaSmin,rlamdaSmax, &
+ rlamdaPmin,rlamdaPmax,vpmin,vpmax,ireadmodel,nelemabs,nspec,numat)
- use loadft
- use iounit
- use infos
- use mesh01
- use spela202
- use constspec
- use vparams
- use verifs
- use energie
- use codebord
+! define all the arrays for the variational formulation
+
implicit none
- integer kmato(nspec),ibool(0:nxgll-1,0:nxgll-1,nspec)
- integer iboolori(0:nxgll-1,0:nxgll-1,nspec)
+ include "constants.h"
+ integer i,j,ispec,material,ipointnum,npoin,nelemabs,nspec,numat
+ integer isourx,isourz,ielems,ir,is,ip
+
+ integer kmato(nspec),ibool(NGLLX,NGLLX,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)
+ xigll(NGLLX),yigll(NGLLY),wxgll(NGLLX),wygll(NGLLX), &
+ dvolu(nspec,NGLLX,NGLLX), &
+ xjaci(nspec,NDIME,NDIME,NGLLX,NGLLX), &
+ hprime(NGLLX,NGLLX), hTprime(NGLLX,NGLLX)
- 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 coord(NDIME,npoin)
+ double precision a1(NGLLX,NGLLX,nspec),a2(NGLLX,NGLLX,nspec), &
+ a3(NGLLX,NGLLX,nspec),a4(NGLLX,NGLLX,nspec), &
+ a5(NGLLX,NGLLX,nspec),a6(NGLLX,NGLLX,nspec), &
+ a7(NGLLX,NGLLX,nspec),a8(NGLLX,NGLLX,nspec), &
+ a9(NGLLX,NGLLX,nspec),a10(NGLLX,NGLLX,nspec)
+ double precision a13x(NGLLX,NGLLX,nelemabs),a13z(NGLLX,NGLLX,nelemabs)
+ double precision a11(NGLLX,NGLLX),a12(NGLLX,NGLLX)
- double precision gltfu(20,nltfl)
+ double precision gltfu(20)
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
- 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 rKvol,cploc,csloc,xxi,zeta,rwgll,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
+ double precision rsizemin,rsizemax,cpoverdxmin,cpoverdxmax, &
+ rlamdaSmin,rlamdaSmax,rlamdaPmin,rlamdaPmax,vpmin,vpmax
+
+ logical anyabs,anisotrope,ireadmodel
+
+ integer numabs(nelemabs),codeabs(4,nelemabs)
+
+ double precision, external :: lagrange_deriv_GLL
+
!
!-----------------------------------------------------------------------
!
@@ -96,28 +80,29 @@
a13x = zero
a13z = zero
- vpmin = 1.d30
- vsmin = 1.d30
- vpmax = -1.d30
- vsmax = -1.d30
- densmin = 1.d30
- densmax = -1.d30
+ vpmin = HUGEVAL
+ vsmin = HUGEVAL
+ vpmax = -HUGEVAL
+ vsmax = -HUGEVAL
+ densmin = HUGEVAL
+ densmax = -HUGEVAL
- rsizemin = 1.d30
- rsizemax = -1.d30
+ rsizemin = HUGEVAL
+ rsizemax = -HUGEVAL
- cpoverdxmin = 1.d30
- cpoverdxmax = -1.d30
+ cpoverdxmin = HUGEVAL
+ cpoverdxmax = -HUGEVAL
- rlamdaPmin = 1.d30
- rlamdaSmin = 1.d30
- rlamdaPmax = -1.d30
- rlamdaSmax = -1.d30
+ rlamdaPmin = HUGEVAL
+ rlamdaSmin = HUGEVAL
+ rlamdaPmax = -HUGEVAL
+ rlamdaSmax = -HUGEVAL
- do numelem=1,nspec
+ do ispec=1,nspec
- material = kmato(numelem)
+ material = kmato(ispec)
+
rlamda = elastcoef(1,material)
rmu = elastcoef(2,material)
rKmod = elastcoef(3,material)
@@ -138,23 +123,23 @@
anisotrope = .false.
endif
- do i=0,nxgll-1
- do j=0,nygll-1
+ do j=1,NGLLY
+ do i=1,NGLLX
- 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)
+ xix = xjaci(ispec,1,1,i,j)
+ xiz = xjaci(ispec,1,2,i,j)
+ etax = xjaci(ispec,2,1,i,j)
+ etaz = xjaci(ispec,2,2,i,j)
+ rjacob = dvolu(ispec,i,j)
xxi = etaz * rjacob
zeta = xix * rjacob
- rwx = - wx(i)*wy(j)
+ rwgll = - wxgll(i)*wygll(j)
!--- si formulation heterogene pour un modele de vitesse externe
if(ireadmodel) then
- ipointnum = ibool(i,j,numelem)
+ ipointnum = ibool(i,j,ispec)
cploc = vpext(ipointnum)
csloc = vsext(ipointnum)
denst = rhoext(ipointnum)
@@ -164,7 +149,7 @@
endif
!--- si materiau transverse isotrope, donner une idee des proprietes
- if (anisotrope) then
+ if(anisotrope) then
cploc = sqrt(c11/denst)
csloc = sqrt(c44/denst)
endif
@@ -180,26 +165,18 @@
densmax = dmax1(densmax,denst)
!--- stocker parametres pour verifs diverses
- if(i /= nxgll-1 .and. j /= nygll-1) then
+ if(i < NGLLX .and. j < NGLLY) 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
+ x0 = coord(1,ibool(i,j,ispec))
+ z0 = coord(2,ibool(i,j,ispec))
+ x1 = coord(1,ibool(i+1,j,ispec))
+ z1 = coord(2,ibool(i+1,j,ispec))
+ x2 = coord(1,ibool(i,j+1,ispec))
+ z2 = coord(2,ibool(i,j+1,ispec))
rdist1 = 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)
@@ -210,21 +187,12 @@
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
+ x0 = coord(1,ibool(1,1,ispec))
+ z0 = coord(2,ibool(1,1,ispec))
+ x1 = coord(1,ibool(NGLLX,1,ispec))
+ z1 = coord(2,ibool(NGLLX,1,ispec))
+ x2 = coord(1,ibool(1,NGLLY,ispec))
+ z2 = coord(2,ibool(1,NGLLY,ispec))
rdist1 = dsqrt((x1-x0)**2 + (z1-z0)**2)
rdist2 = dsqrt((x2-x0)**2 + (z2-z0)**2)
@@ -243,58 +211,31 @@
!--- 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
+ a1(i,j,ispec) = rwgll*(rKmod*xix*xix + rmu*xiz*xiz)*rjacob
+ a2(i,j,ispec) = rwgll*(rKmod*etax*xix + rmu*etaz*xiz)*rjacob
+ a3(i,j,ispec) = rwgll*(rlamda+rmu)*xiz*xix*rjacob
+ a4(i,j,ispec) = rwgll*(rlamda*etaz*xix + rmu*etax*xiz)*rjacob
+ a5(i,j,ispec) = rwgll*(rKmod*etaz*etaz + rmu*etax*etax)*rjacob
+ a6(i,j,ispec) = rwgll*(rKmod*etax*etax + rmu*etaz*etaz)*rjacob
+ a7(i,j,ispec) = rwgll*(rlamda*etax*xiz + rmu*etaz*xix)*rjacob
+ a8(i,j,ispec) = rwgll*(rlamda+rmu)*etax*etaz*rjacob
+ a9(i,j,ispec) = rwgll*(rKmod*xiz*xiz + rmu*xix*xix)*rjacob
+ a10(i,j,ispec) = rwgll*(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
+ a3(i,j,ispec) = rwgll*(c13+c44)*xiz*xix*rjacob
+ a4(i,j,ispec) = rwgll*(c13*etaz*xix + c44*etax*xiz)*rjacob
+ a7(i,j,ispec) = rwgll*(c13*etax*xiz + c44*etaz*xix)*rjacob
+ a8(i,j,ispec) = rwgll*(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
+ a1(i,j,ispec) = rwgll*(c11*xix*xix + c44*xiz*xiz)*rjacob
+ a2(i,j,ispec) = rwgll*(c11*etax*xix + c44*etaz*xiz)*rjacob
+ a6(i,j,ispec) = rwgll*(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
+ a5(i,j,ispec) = rwgll*(c33*etaz*etaz + c44*etax*etax)*rjacob
+ a9(i,j,ispec) = rwgll*(c33*xiz*xiz + c44*xix*xix)*rjacob
+ a10(i,j,ispec) = rwgll*(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
@@ -313,9 +254,9 @@
if(anyabs) then
- do numelem=1,nelemabs
+ do ispec=1,nelemabs
- material = kmato(numabs(numelem))
+ material = kmato(numabs(ispec))
rlamda = elastcoef(1,material)
rmu = elastcoef(2,material)
@@ -326,12 +267,12 @@
cploc = dsqrt((rKvol + 4.d0*rmu/3.d0)/denst)
csloc = dsqrt(rmu/denst)
- do i=0,nxgll-1
- do j=0,nygll-1
+ do i=1,NGLLX
+ do j=1,NGLLY
!--- si formulation heterogene pour un modele de vitesse externe
if(ireadmodel) then
- ipointnum = ibool(i,j,numabs(numelem))
+ ipointnum = ibool(i,j,numabs(ispec))
cploc = vpext(ipointnum)
csloc = vsext(ipointnum)
denst = rhoext(ipointnum)
@@ -340,46 +281,46 @@
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)
+ xix = xjaci(numabs(ispec),1,1,i,j)
+ xiz = xjaci(numabs(ispec),1,2,i,j)
+ etax = xjaci(numabs(ispec),2,1,i,j)
+ etaz = xjaci(numabs(ispec),2,2,i,j)
+ rjacob = dvolu(numabs(ispec),i,j)
xxi = etaz * rjacob
zeta = xix * rjacob
- rwx = - wx(i)*wy(j)
+ rwgll = - wxgll(i)*wygll(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
+ if(codeabs(ibas,ispec) /= 1 .and. j == 1) then
+ coefintegr = wxgll(i)*xxi
+ a13x(i,j,ispec) = denst*csloc*coefintegr
+ a13z(i,j,ispec) = 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
+ if(codeabs(ihaut,ispec) /= 1 .and. j == NGLLY) then
+ coefintegr = wxgll(i)*xxi
+ a13x(i,j,ispec) = denst*csloc*coefintegr
+ a13z(i,j,ispec) = 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
+ if(codeabs(igauche,ispec) /= 1 .and. i == 1) then
+ coefintegr = wygll(j)*zeta
+ a13x(i,j,ispec) = denst*cploc*coefintegr
+ a13z(i,j,ispec) = 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
+ if(codeabs(idroite,ispec) /= 1 .and. i == NGLLX) then
+ coefintegr = wygll(j)*zeta
+ a13x(i,j,ispec) = denst*cploc*coefintegr
+ a13z(i,j,ispec) = denst*csloc*coefintegr
endif
enddo
@@ -388,17 +329,14 @@
endif
-! pour source explosive
- do n=1,nltfl
-
! seulement si source explosive
- if(nint(gltfu(2,n)) == 2) then
+ if(nint(gltfu(2)) == 2) then
- isourx = nint(gltfu(10,n))
- isourz = nint(gltfu(11,n))
- ielems = nint(gltfu(12,n))
+ isourx = nint(gltfu(10))
+ isourz = nint(gltfu(11))
+ ielems = nint(gltfu(12))
- if(isourx == 0.or.isourx == nxgll-1.or.isourz == 0 .or.isourz == nxgll-1) &
+ if(isourx == 1.or.isourx == NGLLX.or.isourz == 1 .or.isourz == NGLLX) &
stop 'Explosive source on element edge'
!---- definir a11 et a12 - dirac (schema en croix)
@@ -410,31 +348,28 @@
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
+ do ir=1,NGLLX
+ flagxprime = lagrange_deriv_GLL(ir-1,isourx-1,xigll,NGLLX)
+ a11(ir,isourz) = a11(ir,isourz) + sig0*xix*flagxprime
+ a12(ir,isourz) = a12(ir,isourz) + 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
+ do is=1,NGLLY
+ flagzprime = lagrange_deriv_GLL(is-1,isourz-1,yigll,NGLLY)
+ a11(isourx,is) = a11(isourx,is) + sig0*etax*flagzprime
+ a12(isourx,is) = a12(isourx,is) + 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)
+!---- (works only if NGLLX = NGLLY)
+ do ip=1,NGLLX
+ do i=1,NGLLX
+ hprime(ip,i) = lagrange_deriv_GLL(ip-1,i-1,xigll,NGLLX)
hTprime(i,ip) = hprime(ip,i)
enddo
enddo
- return
end subroutine defarrays
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/dirac.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/dirac.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/dirac.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,49 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/dircty.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/dircty.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/dircty.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,68 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/endw1.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/endw1.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/endw1.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,74 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/endw2.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/endw2.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/endw2.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,74 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/ezfftf.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/ezfftf.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/ezfftf.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,558 +0,0 @@
-
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/gammaf.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/gammaf.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/gammaf.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,46 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/getelspec.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/getelspec.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/getelspec.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,179 +0,0 @@
-
-!=====================================================================
-!
-! 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,kmato,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),kmato(nspec)
- 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/getltf.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/getltf.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/getltf.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,112 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/getrecepts.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/getrecepts.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/getrecepts.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,52 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/getspec.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/getspec.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/getspec.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,68 +0,0 @@
-!=====================================================================
-!
-! 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/gll_library.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/gll_library.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/gll_library.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -0,0 +1,529 @@
+
+!=======================================================================
+!
+! Library to compute the Gauss-Lobatto-Legendre points and weights
+! Based on Gauss-Lobatto routines from M.I.T.
+! Department of Mechanical Engineering
+!
+!=======================================================================
+
+ double precision function endw1(n,alpha,beta)
+
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+ double precision, external :: gammaf
+ integer i
+
+ f3 = zero
+ apb = alpha+beta
+ if (n == 0) then
+ endw1 = zero
+ return
+ endif
+ f1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if (n == 1) then
+ endw1 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (-two*(beta+two)*fint1 + (apb+four)*fint2) * (apb+three)/four
+ if (n == 2) then
+ endw1 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw1 = f3
+
+ end function endw1
+
+!
+!=======================================================================
+!
+
+ double precision function endw2(n,alpha,beta)
+
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+ double precision, external :: gammaf
+ integer i
+
+ apb = alpha+beta
+ f3 = zero
+ if (n == 0) then
+ endw2 = zero
+ return
+ endif
+ f1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if (n == 1) then
+ endw2 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (two*(alpha+two)*fint1 - (apb+four)*fint2) * (apb+three)/four
+ if (n == 2) then
+ endw2 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw2 = f3
+
+ end function endw2
+
+!
+!=======================================================================
+!
+
+ double precision function gammaf (x)
+
+ implicit none
+
+ double precision, parameter :: pi = 3.141592653589793d0
+
+ double precision x
+
+ double precision, parameter :: half=0.5d0,one=1.d0,two=2.d0
+
+ gammaf = one
+
+ if (x == -half) gammaf = -two*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
+
+ end function gammaf
+
+!
+!=====================================================================
+!
+
+ subroutine jacg (xjac,np,alpha,beta)
+
+!=======================================================================
+!
+! computes np Gauss points, which are the zeros of the
+! Jacobi polynomial with parameters alpha and beta
+!
+! .alpha = beta = 0.0 -> Legendre points
+! .alpha = beta = -0.5 -> Chebyshev points
+!
+!=======================================================================
+
+ implicit none
+
+ integer np
+ double precision alpha,beta
+ double precision xjac(np)
+
+ integer k,j,i,jmin,jm,n
+ double precision xlast,dth,x,x1,x2,recsum,delx,xmin,swap
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+
+ integer, parameter :: K_MAX_ITER = 10
+ double precision, parameter :: zero = 0.d0, eps = 1.0d-12
+
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ xlast = 0.d0
+ n = np-1
+ dth = 4.d0*datan(1.d0)/(2.d0*dble(n)+2.d0)
+ p = 0.d0
+ pd = 0.d0
+ jmin = 0
+ do j=1,np
+ if(j == 1) then
+ x = 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 k=1,K_MAX_ITER
+ call jacobf (p,pd,pm1,pdm1,pm2,pdm2,np,alpha,beta,x)
+ recsum = 0.d0
+ jm = j-1
+ do i=1,jm
+ recsum = recsum+1.d0/(x-xjac(np-i+1))
+ enddo
+ delx = -p/(pd-recsum*p)
+ x = x+delx
+ if(abs(delx) < eps) goto 31
+ enddo
+ 31 continue
+ xjac(np-j+1) = x
+ xlast = x
+ enddo
+ do i=1,np
+ xmin = 2.d0
+ do j=i,np
+ if(xjac(j) < xmin) then
+ xmin = xjac(j)
+ jmin = j
+ endif
+ enddo
+ if(jmin /= i) then
+ swap = xjac(i)
+ xjac(i) = xjac(jmin)
+ xjac(jmin) = swap
+ endif
+ enddo
+
+ end subroutine jacg
+
+!
+!=====================================================================
+!
+
+ subroutine jacobf (poly,pder,polym1,pderm1,polym2,pderm2,n,alp,bet,x)
+
+!=======================================================================
+!
+! Computes the Jacobi polynomial of degree n and its derivative at x
+!
+!=======================================================================
+
+ implicit none
+
+ double precision poly,pder,polym1,pderm1,polym2,pderm2,alp,bet,x
+ integer n
+
+ double precision apb,polyl,pderl,dk,a1,a2,b3,a3,a4,polyn,pdern,psave,pdsave
+ integer k
+
+ apb = alp+bet
+ poly = 1.d0
+ pder = 0.d0
+ psave = 0.d0
+ pdsave = 0.d0
+
+ if (n == 0) return
+
+ polyl = poly
+ pderl = pder
+ poly = (alp-bet+(apb+2.d0)*x)/2.d0
+ pder = (apb+2.d0)/2.d0
+ if (n == 1) return
+
+ do k=2,n
+ dk = dble(k)
+ a1 = 2.d0*dk*(dk+apb)*(2.d0*dk+apb-2.d0)
+ a2 = (2.d0*dk+apb-1.d0)*(alp**2-bet**2)
+ b3 = (2.d0*dk+apb-2.d0)
+ a3 = b3*(b3+1.d0)*(b3+2.d0)
+ a4 = 2.d0*(dk+alp-1.d0)*(dk+bet-1.d0)*(2.d0*dk+apb)
+ polyn = ((a2+a3*x)*poly-a4*polyl)/a1
+ pdern = ((a2+a3*x)*pder-a4*pderl+a3*poly)/a1
+ psave = polyl
+ pdsave = pderl
+ polyl = poly
+ poly = polyn
+ pderl = pder
+ pder = pdern
+ enddo
+
+ polym1 = polyl
+ pderm1 = pderl
+ polym2 = psave
+ pderm2 = pdsave
+
+ end subroutine jacobf
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision FUNCTION PNDLEG (Z,N)
+
+!------------------------------------------------------------------------
+!
+! Compute the derivative of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!------------------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P1D,P2D,P3D,FK,P3
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P1D = 0.d0
+ P2D = 1.d0
+ P3D = 1.d0
+
+ do K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P3D = ((2.d0*FK+1.d0)*P2 + (2.d0*FK+1.d0)*Z*P2D - FK*P1D) / (FK+1.d0)
+ P1 = P2
+ P2 = P3
+ P1D = P2D
+ P2D = P3D
+ enddo
+
+ PNDLEG = P3D
+
+ end function pndleg
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision FUNCTION PNLEG (Z,N)
+
+!------------------------------------------------------------------------
+!
+! Compute the value of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!------------------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P3,FK
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P3 = P2
+
+ do K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P1 = P2
+ P2 = P3
+ enddo
+
+ PNLEG = P3
+
+ end function pnleg
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision function pnormj (n,alpha,beta)
+
+ implicit none
+
+ double precision alpha,beta
+ integer n
+
+ double precision one,two,dn,const,prod,dindx,frac
+ double precision, external :: gammaf
+ integer i
+
+ one = 1.d0
+ two = 2.d0
+ dn = dble(n)
+ const = alpha+beta+one
+
+ if (n <= 1) then
+ prod = gammaf(dn+alpha)*gammaf(dn+beta)
+ prod = prod/(gammaf(dn)*gammaf(dn+alpha+beta))
+ pnormj = prod * two**const/(two*dn+const)
+ return
+ endif
+
+ prod = gammaf(alpha+one)*gammaf(beta+one)
+ prod = prod/(two*(one+const)*gammaf(const+one))
+ prod = prod*(one+alpha)*(two+alpha)
+ prod = prod*(one+beta)*(two+beta)
+
+ do i=3,n
+ dindx = dble(i)
+ frac = (dindx+alpha)*(dindx+beta)/(dindx*(dindx+alpha+beta))
+ prod = prod*frac
+ enddo
+
+ pnormj = prod * two**const/(two*dn+const)
+
+ end function pnormj
+
+!
+!------------------------------------------------------------------------
+!
+
+ subroutine zwgjd(z,w,np,alpha,beta)
+
+!=======================================================================
+!
+! Z w g j d : Generate np Gauss-Jacobi points and weights
+! associated with Jacobi polynomial of degree n = np-1
+!
+! Note : Coefficients alpha and beta must be greater than -1.
+! ----
+!=======================================================================
+
+ implicit none
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision z(np),w(np)
+ double precision alpha,beta
+
+ integer n,np1,np2,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision apb,dnp1,dnp2,fac1,fac2,fac3,fnorm,rcoef
+ double precision, external :: gammaf,pnormj
+
+ pd = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ apb = alpha+beta
+ p = zero
+ pdm1 = zero
+
+ if (np <= 0) stop 'minimum number of Gauss points is 1'
+
+ if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
+
+ if (np == 1) then
+ z(1) = (beta-alpha)/(apb+two)
+ w(1) = gammaf(alpha+one)*gammaf(beta+one)/gammaf(apb+two) * two**(apb+one)
+ return
+ endif
+
+ call jacg(z,np,alpha,beta)
+
+ np1 = n+1
+ np2 = n+2
+ dnp1 = dble(np1)
+ dnp2 = dble(np2)
+ fac1 = dnp1+alpha+beta+one
+ fac2 = fac1+dnp1
+ fac3 = fac2+one
+ fnorm = pnormj(np1,alpha,beta)
+ rcoef = (fnorm*fac2*fac3)/(two*fac1*dnp2)
+ do i=1,np
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,np2,alpha,beta,z(i))
+ w(i) = -rcoef/(p*pdm1)
+ enddo
+
+ end subroutine zwgjd
+
+!
+!------------------------------------------------------------------------
+!
+
+ subroutine zwgljd(z,w,np,alpha,beta)
+
+!=======================================================================
+!
+! Z w g l j d : Generate np Gauss-Lobatto-Jacobi points and the
+! ----------- weights associated with Jacobi polynomials of degree
+! n = np-1.
+!
+! Note : alpha and beta coefficients must be greater than -1.
+! Legendre polynomials are special case of Jacobi polynomials
+! just by setting alpha and beta to 0.
+!
+!=======================================================================
+
+ implicit none
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision alpha,beta
+ double precision z(np), w(np)
+
+ integer n,nm1,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision alpg,betg
+ double precision, external :: endw1,endw2
+
+ p = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ nm1 = n-1
+ pd = zero
+
+ if (np <= 1) stop 'minimum number of Gauss-Lobatto points is 2'
+
+! with spectral elements, use at least 3 points
+ if (np <= 2) stop 'minimum number of Gauss-Lobatto points for the SEM is 3'
+
+ if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
+
+ if (nm1 > 0) then
+ alpg = alpha+one
+ betg = beta+one
+ call zwgjd(z(2),w(2),nm1,alpg,betg)
+ endif
+
+ z(1) = - one
+ z(np) = one
+
+ do i=2,np-1
+ w(i) = w(i)/(one-z(i)**2)
+ enddo
+
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(1))
+ w(1) = endw1(n,alpha,beta)/(two*pd)
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(np))
+ w(np) = endw2(n,alpha,beta)/(two*pd)
+
+ end subroutine zwgljd
+
Modified: seismo/2D/SPECFEM2D/trunk/SPECFEM90/gmat01.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/gmat01.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/gmat01.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,31 +1,23 @@
-!=====================================================================
+
+!========================================================================
!
-! S p e c f e m V e r s i o n 4 . 2
-! -----------------------------------
+! S P E C F E M 2 D Version 5.0
+! ------------------------------
!
! Dimitri Komatitsch
-! Department of Earth and Planetary Sciences - Harvard University
-! Jean-Pierre Vilotte
-! Departement de Sismologie - IPGP - Paris
-! (c) June 1998
+! Universite de Pau et des Pays de l'Adour, France
!
-!=====================================================================
+! (c) May 2004
+!
+!========================================================================
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
+! read properties of a 2D isotropic or anisotropic linear elastic element
+
implicit none
- double precision, parameter :: zero=0.d0,half=0.5d0,one=1.0d0,two=2.0d0
+ include "constants.h"
character(len=80) datlin
double precision Kmod,Kvol
@@ -37,16 +29,14 @@
double precision young,poiss,denst,cp,cs,amu,a2mu,alam
double precision val1,val2,val3,val4
double precision c11,c13,c33,c44
+
!
-!-----------------------------------------------------------------------
+!---- loop over the different material sets
!
density(:) = zero
elastcoef(:,:) = zero
-!
-!---- loop over the different material sets
-!
- if(iecho /= 0) write(iout,100) numat
+ write(iout,100) numat
read(iin ,40) datlin
do in = 1,numat
@@ -66,15 +56,13 @@
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 !'
+ 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 !'
+ 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)
@@ -117,27 +105,22 @@
!
!---- 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
+ 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
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)
+ /1x,54('='),//5x,'Number of material sets . . . . . . (numat) =',i5)
200 format(//5x,'------------------------',/5x, &
'-- Isotropic material --',/5x, &
'------------------------',/5x, &
@@ -165,3 +148,4 @@
'Velocity of qSV along horizontal axis . . =',1pe15.8)
end subroutine gmat01
+
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/hdgll.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/hdgll.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/hdgll.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,51 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/hgll.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/hgll.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/hgll.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,42 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/intseq.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/intseq.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/intseq.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,76 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/jacg.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/jacg.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/jacg.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,96 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/jacobf.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/jacobf.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/jacobf.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,66 +0,0 @@
-!=====================================================================
-!
-! 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/lagrange_poly.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/lagrange_poly.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/lagrange_poly.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -0,0 +1,85 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 5.0
+! ------------------------------
+!
+! Dimitri Komatitsch
+! Universite de Pau et des Pays de l'Adour, France
+!
+! (c) May 2004
+!
+!========================================================================
+
+ 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)))
+
+ end function hgll
+
+!
+!=====================================================================
+!
+
+! subroutine to compute the derivative of the Lagrange interpolants
+! at the GLL points at any given GLL point
+
+ double precision function lagrange_deriv_GLL(I,j,ZGLL,NZ)
+
+!------------------------------------------------------------------------
+!
+! Compute the value of the derivative of the I-th
+! Lagrange interpolant through the
+! NZ Gauss-Lobatto Legendre points ZGLL at point ZGLL(j)
+!
+!------------------------------------------------------------------------
+
+ implicit none
+
+ integer i,j,nz
+ double precision zgll(0:nz-1)
+
+ integer degpoly
+
+ double precision, external :: pnleg,pndleg
+
+ degpoly = nz - 1
+ if (i == 0 .and. j == 0) then
+ lagrange_deriv_GLL = - dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
+ else if (i == degpoly .and. j == degpoly) then
+ lagrange_deriv_GLL = dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
+ else if (i == j) then
+ lagrange_deriv_GLL = 0.d0
+ else
+ lagrange_deriv_GLL = pnleg(zgll(j),degpoly) / &
+ (pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))) &
+ + (1.d0-zgll(j)*zgll(j))*pndleg(zgll(j),degpoly) / (dble(degpoly)* &
+ (dble(degpoly)+1.d0)*pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))*(zgll(j)-zgll(i)))
+ endif
+
+ end function lagrange_deriv_GLL
+
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/modifperio.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/modifperio.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/modifperio.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,189 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/modules.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/modules.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/modules.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,436 +0,0 @@
-!
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotavs.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotavs.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotavs.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,88 +0,0 @@
-!=====================================================================
-!
-! 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
Modified: seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotgll.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotgll.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotgll.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,44 +1,38 @@
-!=====================================================================
+
+!========================================================================
!
-! S p e c f e m V e r s i o n 4 . 2
-! -----------------------------------
+! S P E C F E M 2 D Version 5.0
+! ------------------------------
!
! Dimitri Komatitsch
-! Department of Earth and Planetary Sciences - Harvard University
-! Jean-Pierre Vilotte
-! Departement de Sismologie - IPGP - Paris
-! (c) June 1998
+! Universite de Pau et des Pays de l'Adour, France
!
-!=====================================================================
-
- subroutine plotgll(knods,ibool,coorg,coord)
+! (c) May 2004
!
-!=======================================================================
-!
-! "p l o t g l l" : Print the Gauss-Lobatto-Legendre mesh
-! in a Gnuplot file
-!
-!=======================================================================
-!
- use mesh01
- use spela202
- use iounit
+!========================================================================
+ subroutine plotgll(knods,ibool,coorg,coord,npoin,npgeo,ngnod,nspec)
+
+! output the Gauss-Lobatto-Legendre mesh in a gnuplot file
+
implicit none
- integer knods(ngnod,nspec),ibool(nxgll,nxgll,nspec)
- double precision coorg(ndime,npgeo),coord(ndime,npoin)
+ include "constants.h"
+ integer ispec,iy,ix,iglobnum,iglobnum2,ibloc,inode,npoin,npgeo,ngnod,nspec
+
+ integer knods(ngnod,nspec),ibool(NGLLX,NGLLX,nspec)
+
+ double precision coorg(NDIME,npgeo),coord(NDIME,npoin)
+
! coordinates of the nodes for Gnuplot file
- integer maxnnode
- parameter(maxnnode=9)
- real xval(maxnnode),zval(maxnnode)
+ integer, parameter :: MAXNGNOD = 9
+ double precision xval(MAXNGNOD),zval(MAXNGNOD)
- integer ispel,iy,ix,iglobnum,iglobnum2,ibloc,inode
character(len=70) name
!
-!---- print the GLL mesh in a Gnuplot file
+!---- output the GLL mesh in a Gnuplot file
!
write(iout,*)
@@ -61,75 +55,75 @@
open(unit=21,file=name,status='unknown')
write(21,10)
- do ispel = 1,nspec
+ do ispec = 1,nspec
!
!---- plot the lines in xi-direction
!
- do iy = 1,nygll
- do ix = 1,nxgll-1
+ do iy = 1,NGLLY
+ do ix = 1,NGLLX-1
!
!---- get the global point number
!
- iglobnum = ibool(ix,iy,ispel)
+ iglobnum = ibool(ix,iy,ispec)
!
!---- do the same for next point on horizontal line
!
- iglobnum2 = ibool(ix+1,iy,ispel)
+ iglobnum2 = ibool(ix+1,iy,ispec)
- write(20,15) sngl(coord(1,iglobnum)),sngl(coord(2,iglobnum))
- write(20,15) sngl(coord(1,iglobnum2)),sngl(coord(2,iglobnum2))
+ write(20,15) coord(1,iglobnum),coord(2,iglobnum)
+ write(20,15) coord(1,iglobnum2),coord(2,iglobnum2)
write(20,10)
- if ((iy == 1).or.(iy == 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)
+ if(iy == 1 .or. iy == NGLLY) then
+ write(21,15) coord(1,iglobnum),coord(2,iglobnum)
+ write(21,15) coord(1,iglobnum2),coord(2,iglobnum2)
+ write(21,10)
endif
- enddo
+ enddo
enddo
!
!---- plot the lines in eta-direction
!
- do ix = 1,nxgll
- do iy = 1,nygll-1
+ do ix = 1,NGLLX
+ do iy = 1,NGLLY-1
!
!---- get the global point number
!
- iglobnum = ibool(ix,iy,ispel)
+ iglobnum = ibool(ix,iy,ispec)
!
!---- do the same for next point on vertical line
!
- iglobnum2 = ibool(ix,iy+1,ispel)
+ iglobnum2 = ibool(ix,iy+1,ispec)
- write(20,15) sngl(coord(1,iglobnum)),sngl(coord(2,iglobnum))
- write(20,15) sngl(coord(1,iglobnum2)),sngl(coord(2,iglobnum2))
+ write(20,15) coord(1,iglobnum),coord(2,iglobnum)
+ write(20,15) coord(1,iglobnum2),coord(2,iglobnum2)
write(20,10)
- if ((ix == 1).or.(ix == 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)
+ if(ix == 1 .or. ix == NGLLX) then
+ write(21,15) coord(1,iglobnum),coord(2,iglobnum)
+ write(21,15) coord(1,iglobnum2),coord(2,iglobnum2)
+ write(21,10)
endif
- enddo
+ enddo
enddo
enddo
!
-!---- Plot the macroblocs mesh using Gnuplot
+!---- plot the macrobloc 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)))
+ xval(inode) = coorg(1,knods(inode,ibloc))
+ zval(inode) = coorg(2,knods(inode,ibloc))
enddo
- if(ngnod == 4) then
+ if(ngnod == 4) then
!
!---- 4-noded rectangular element
!
@@ -207,14 +201,7 @@
!
!---- 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')
+ open(unit=20,file='plotall_gll_mesh.gnu',status='unknown')
write(20,*) 'set term x11'
write(20,*) 'set xlabel "X"'
write(20,*) 'set ylabel "Y"'
@@ -224,11 +211,11 @@
write(20,*) 'pause -1 "Hit any key to exit..."'
close(20)
- open(unit=20,file='macros_mesh.gnu',status='unknown')
+ open(unit=20,file='plotall_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,*) 'set title "Spectral Element (Macrobloc) Mesh"'
write(20,*) 'plot "macros2.gnu" title '''' w l 2,', &
' "macros1.gnu" title '''' w linesp 1 3'
write(20,*) 'pause -1 "Hit any key to exit..."'
@@ -238,8 +225,8 @@
!----
!
-10 format('')
-15 format(e10.5,1x,e10.5)
+ 10 format('')
+ 15 format(e10.5,1x,e10.5)
- return
end subroutine plotgll
+
Modified: seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotpost.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotpost.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotpost.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,80 +1,90 @@
-!=====================================================================
+!========================================================================
!
-! S p e c f e m V e r s i o n 4 . 2
-! -----------------------------------
+! S P E C F E M 2 D Version 5.0
+! ------------------------------
!
! Dimitri Komatitsch
-! Department of Earth and Planetary Sciences - Harvard University
-! Jean-Pierre Vilotte
-! Departement de Sismologie - IPGP - Paris
-! (c) June 1998
+! Universite de Pau et des Pays de l'Adour, France
!
-!=====================================================================
+! (c) May 2004
+!
+!========================================================================
- subroutine plotpost(U,coord,vpext,gltfl,posrec,nltfl,it,dt,coorg, &
+ subroutine plotpost(displ,coord,vpext,gltfl,posrec,it,dt,coorg, &
xinterp,zinterp,shapeint, &
Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
- numabs,codeabs,codeperio,anyabs,anyperio)
+ numabs,codeabs,anyabs,stitle,npoin,npgeo,vpmin,vpmax,nrec, &
+ icolor,inumber,isubsamp,ivecttype,interpol,imeshvect,imodelvect, &
+ iboundvect,ireadmodel,cutvect,nelemabs,numat,iptsdisp,nspec,ngnod)
!
! 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.
+ include "constants.h"
+! color palette
+ integer, parameter :: MAXCOLORS = 100
+ double precision, dimension(MAXCOLORS) :: red,green,blue
+
+ integer it,nrec,nelemabs,numat,iptsdisp,nspec
+ integer i,iglobrec,iglobsource,npoin,npgeo,ngnod
+
integer kmato(nspec),knods(ngnod,nspec)
- integer ibool(nxgll,nygll,nspec)
+ integer ibool(NGLLX,NGLLY,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 flagrange(NGLLX,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 displ(NDIME,npoin),coord(NDIME,npoin)
double precision vpext(npoin)
- double precision coorg(ndime,npgeo)
- double precision gltfl(20,nltfl)
- double precision posrec(ndime,nrec)
+ double precision coorg(NDIME,npgeo)
+ double precision gltfl(20)
+ double precision posrec(NDIME,nrec)
integer numabs(nelemabs),codeabs(4,nelemabs)
- integer codeperio(4,nelemperio)
- logical anyabs,anyperio
+ logical anyabs
-! limite pour afficher des points a la place des recepteurs
- integer, parameter :: ndots = 10
+ double precision xmax,zmax,height,xw,zw,usoffset,sizex,sizez,vpmin,vpmax
-! taille de la fenetre de display Postscript en pourcentage de la feuille
- double precision, parameter :: rpercentx = 70.0d0, rpercentz = 77.0d0
+ character(len=100) name
+ character ch1(100),ch2(100)
+ equivalence (name,ch1)
+ logical first
- double precision xmax,zmax,height,xw,zw,usoffset
- integer i,iglobrec,iglobsource
- character(len=40) name
+ double precision convert,x1,rlamda,rmu,denst,rKvol,cploc,xa,za,xb,zb
+ double precision z1,x2,z2,d,d1,d2,dummy,theta,thetaup,thetadown
+ integer k,j,ispec,material,is,ir,nbcols,imat,icol,l,longueur
+ integer indice,ii,ipoin,in,nnum,ispecabs,ideb,ifin,ibord
+
+ integer icolor,inumber,isubsamp,ivecttype
+ logical interpol,imeshvect,imodelvect,iboundvect,ireadmodel
+ double precision cutvect
+
+ double precision rapp_page,dispmax,xmin,zmin
+
+! title of the plot
+ character(len=60) stitle
+
! papier A4 ou US letter
- if(usletter) then
- usoffset = 1.75d0
- sizex = 27.94d0
- sizez = 21.59d0
+ if(US_LETTER) then
+ usoffset = 1.75d0
+ sizex = 27.94d0
+ sizez = 21.59d0
else
- usoffset = 0.
- sizex = 29.7d0
- sizez = 21.d0
+ usoffset = 0.
+ sizex = 29.7d0
+ sizez = 21.d0
endif
! definition de la palette de couleur
@@ -175,7 +185,7 @@
/ 100.d0
! recherche de la valeur maximum de la norme du deplacement
- dispmax = maxval(sqrt(U(1,:)**2 + U(2,:)**2))
+ dispmax = maxval(sqrt(displ(1,:)**2 + displ(2,:)**2))
write(*,*) 'Max norme = ',dispmax
! hauteur des numeros de domaine en CM
@@ -292,9 +302,6 @@
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'
@@ -342,13 +349,491 @@
write(24,*) '%'
!
-!---- plot mesh and displacement vector field in a PostScript file
+!---- print the spectral elements mesh in PostScript
!
- call plotvect(knods,coorg,coord,U, &
- density,elastcoef,kmato,flagrange,xinterp,zinterp,shapeint, &
- Uxinterp,Uzinterp,ibool,vpext, &
- numabs,codeabs,codeperio,anyabs,anyperio)
+ 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=1,NGLLX-isubsamp,isubsamp
+ do j=1,NGLLX-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 ispec=1,nspec
+
+ write(24,*) '% elem ',ispec
+
+ do i=1,iptsdisp
+ do j=1,iptsdisp
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+ enddo
+ enddo
+
+ is = 1
+ ir = 1
+ x1 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z1 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ write(24,*) 'MK'
+ write(24,681) x1,z1
+
+ if (ngnod == 4) then
+
+! tracer des droites si elements 4 noeuds
+
+ ir=iptsdisp
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ ir=iptsdisp
+ is=iptsdisp
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ is=iptsdisp
+ ir=1
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ ir=1
+ is=2
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+
+ else
+
+! tracer des courbes si elements 9 noeuds
+ do ir=2,iptsdisp
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+ enddo
+
+ ir=iptsdisp
+ do is=2,iptsdisp
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+ enddo
+
+ is=iptsdisp
+ do ir=iptsdisp-1,1,-1
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+ enddo
+
+ ir=1
+ do is=iptsdisp-1,2,-1
+ x2 = (xinterp(ir,is)-xmin)*rapp_page + orig_x
+ z2 = (zinterp(ir,is)-zmin)*rapp_page + orig_z
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,681) x2,z2
+ enddo
+
+ endif
+
+ write(24,*) 'CO'
+
+ if (icolor == 1) then
+
+! For the moment 20 different colors max
+ nbcols = 20
+
+! Use a different color for each material set
+ imat = kmato(ispec)
+ icol = mod(imat - 1,nbcols) + 1
+
+ write(24,680) red(icol),green(icol),blue(icol)
+
+ endif
+
+ if(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,ispec)) + coorg(1,knods(2,ispec)) + &
+ coorg(1,knods(3,ispec)) + coorg(1,knods(4,ispec))) / 4.d0
+ zw = (coorg(2,knods(1,ispec)) + coorg(2,knods(2,ispec)) + &
+ coorg(2,knods(3,ispec)) + coorg(2,knods(4,ispec))) / 4.d0
+ xw = (xw-xmin)*rapp_page + orig_x
+ zw = (zw-zmin)*rapp_page + orig_z
+ xw = xw * centim
+ zw = zw * centim
+ if (icolor == 1) write(24,*) '1 setgray'
+
+ write(24,500) xw,zw
+
+!--- ecriture numero de l'element
+ write(24,502) ispec
+
+ endif
+
+ enddo
+
+ endif
+
+!
+!---- draw the boundary conditions
+!
+
+ if(anyabs .and. 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 ispecabs = 1,nelemabs
+ ispec = numabs(ispecabs)
+
+!--- une couleur pour chaque condition absorbante
+!--- bord absorbant de type "haut" : orange
+!--- bord absorbant de type "bas" : vert clair
+!--- bord absorbant de type "gauche" : rose clair
+!--- bord absorbant de type "droite" : turquoise
+
+ do ibord = 1,4
+
+ if(codeabs(ibord,ispecabs) /= 0) then
+
+ if(ibord == 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,ispec))-xmin)*rapp_page + orig_x
+ z1 = (coorg(2,knods(ideb,ispec))-zmin)*rapp_page + orig_z
+ x2 = (coorg(1,knods(ifin,ispec))-xmin)*rapp_page + orig_x
+ z2 = (coorg(2,knods(ifin,ispec))-zmin)*rapp_page + orig_z
+ x1 = x1 * centim
+ z1 = z1 * centim
+ x2 = x2 * centim
+ z2 = z2 * centim
+ write(24,602) x1,z1,x2,z2
+
+ endif
+ enddo
+
+ enddo
+
+ endif
+
+ write(24,*) '0 setgray'
+ write(24,*) '0.01 CM SLW'
+
+ endif
+
+!
+!---- draw the normalized displacement field
+!
+
+! return if the maximum displacement equals zero (no source)
+ if (dispmax == 0.d0) then
+ print *,' null displacement : returning !'
+ return
+ endif
+
+ write(24,*) '%'
+ write(24,*) '% vector field'
+ write(24,*) '%'
+
+! fleches en couleur si modele de vitesse en background
+ if(imodelvect) then
+ write(24,*) 'Colvects'
+ else
+ write(24,*) '0 setgray'
+ endif
+
+ if (interpol) then
+
+ print *,'Interpolating the vector field...'
+
+ do ispec=1,nspec
+
+! interpolation sur grille reguliere
+ if(mod(ispec,100) == 0) &
+ write(*,*) 'Interpolation uniform grid element ',ispec
+
+ do i=1,iptsdisp
+ do j=1,iptsdisp
+
+ xinterp(i,j) = 0.d0
+ zinterp(i,j) = 0.d0
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xinterp(i,j) = xinterp(i,j) + shapeint(in,i,j)*coorg(1,nnum)
+ zinterp(i,j) = zinterp(i,j) + shapeint(in,i,j)*coorg(2,nnum)
+ enddo
+
+ Uxinterp(i,j) = 0.d0
+ Uzinterp(i,j) = 0.d0
+
+ do k=1,NGLLX
+ do l=1,NGLLX
+
+ Uxinterp(i,j) = Uxinterp(i,j) + &
+ displ(1,ibool(k,l,ispec))*flagrange(k,i)*flagrange(l,j)
+ Uzinterp(i,j) = Uzinterp(i,j) + &
+ displ(2,ibool(k,l,ispec))*flagrange(k,i)*flagrange(l,j)
+
+ enddo
+ enddo
+
+ x1 =(xinterp(i,j)-xmin)*rapp_page
+ z1 =(zinterp(i,j)-zmin)*rapp_page
+
+ x2 = Uxinterp(i,j)*sizemax/dispmax
+ z2 = Uzinterp(i,j)*sizemax/dispmax
+
+ d = 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'
+
! sources et recepteurs en couleur si modele de vitesse
if(imodelvect) then
write(24,*) 'Colreceiv'
@@ -357,12 +842,10 @@
endif
!
-!---- write position of the sources
+!---- write position of the source
!
- do i=1,nltfl
+ iglobsource = nint(gltfl(9))
- iglobsource = nint(gltfl(9,i))
-
xw = coord(1,iglobsource)
zw = coord(2,iglobsource)
xw = (xw-xmin)*rapp_page + orig_x
@@ -371,17 +854,15 @@
zw = zw * centim
write(24,510) xw,zw
if (isymbols) then
- write(24,*) 'Cross'
+ write(24,*) 'Cross'
else
- write(24,*) '(S',i,') show'
+ write(24,*) '(S) 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'
@@ -395,17 +876,12 @@
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
+ if(nrec > ndots .and. i /= 1 .and. i /= nrec) then
+ write(24,*) 'VDot'
+ else
+ write(24,*) 'Losange'
+ endif
else
- write(24,*) 'Losange'
- endif
- else
write(24,*) '(R',i,') show'
endif
enddo
@@ -417,14 +893,24 @@
close(24)
10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a50,/, &
- '%% Created by: Specfem Version 4.2',/, &
+ '%% Created by: Specfem Version 5.0',/, &
'%% Author: Dimitri Komatitsch',/,'%%')
510 format(f5.1,1x,f5.1,' M')
600 format(f6.3,' neg CM 0 MR (Time =',f6.3,' s) show')
601 format(f6.3,' neg CM 0 MR (Time =',1pe10.3,' s) show')
610 format(f6.3,' neg CM 0 MR (Time step = ',i5,') show')
620 format(f6.3,' neg CM 0 MR (Cut =',f5.2,' \%) show')
- 630 format(f6.3,' neg CM 0 MR (Niter =',i2,') show')
640 format(f6.3,' neg CM 0 MR (Max norm =',1pe10.3,') show')
+ 200 format(80(a1))
+ 499 format(f5.1,1x,f5.1,' L')
+ 500 format(f5.1,1x,f5.1,' M')
+ 502 format('fN (',i4,') Cshow')
+ 680 format(f4.2,1x,f4.2,1x,f4.2,' RG GF')
+ 681 format(f6.2,1x,f6.2)
+ 602 format(f6.2,1x,f6.2,' M ',f6.2,1x,f6.2,' L ST')
+ 604 format('CP ',f4.2,' BK')
+ 700 format(8(f5.1,1x),'F')
+
end subroutine plotpost
+
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotvect.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotvect.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/plotvect.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,631 +0,0 @@
-
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/pndleg.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/pndleg.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/pndleg.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,46 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/pnleg.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/pnleg.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/pnleg.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,40 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/pnormj.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/pnormj.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/pnormj.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,54 +0,0 @@
-!=====================================================================
-!
-! 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
Modified: seismo/2D/SPECFEM2D/trunk/SPECFEM90/positrec.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/positrec.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/positrec.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,62 +1,62 @@
-!=====================================================================
+
+!========================================================================
!
-! S p e c f e m V e r s i o n 4 . 2
-! -----------------------------------
+! S P E C F E M 2 D Version 5.0
+! ------------------------------
!
! Dimitri Komatitsch
-! Department of Earth and Planetary Sciences - Harvard University
-! Jean-Pierre Vilotte
-! Departement de Sismologie - IPGP - Paris
-! (c) June 1998
+! Universite de Pau et des Pays de l'Adour, France
!
-!=====================================================================
+! (c) May 2004
+!
+!========================================================================
- subroutine positrec(coord,posrec,ndime,npoin,nrec)
+ subroutine positrec(coord,posrec,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)
+ include "constants.h"
+ integer 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
+ dminmax = -HUGEVAL
do n=1,nrec
- dmin = +1.d30
+ dmin = +HUGEVAL
! coordonnees demandees
xs = posrec(1,n)
zs = posrec(2,n)
- do ip=1,npoin
+ do ip=1,npoin
! coordonnees du point de grille
- xp = coord(1,ip)
- zp = coord(2,ip)
+ xp = coord(1,ip)
+ zp = coord(2,ip)
- dist = dsqrt((xp-xs)**2 + (zp-zs)**2)
+ 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
+ if (dist < dmin) then
+ dmin = dist
+ ipoint = ip
+ endif
- enddo
+ enddo
- dminmax = dmax1(dmin,dminmax)
+ dminmax = dmax1(dmin,dminmax)
write(iout,150) n,xs,zs,coord(1,ipoint),coord(2,ipoint),dmin
@@ -74,5 +74,5 @@
' Receiver x-asked z-asked ', &
'x-obtain z-obtain dist'/)
- return
end subroutine positrec
+
Modified: seismo/2D/SPECFEM2D/trunk/SPECFEM90/positsource.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/positsource.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/positsource.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,57 +1,55 @@
-!=====================================================================
+
+!========================================================================
!
-! S p e c f e m V e r s i o n 4 . 2
-! -----------------------------------
+! S P E C F E M 2 D Version 5.0
+! ------------------------------
!
! Dimitri Komatitsch
-! Department of Earth and Planetary Sciences - Harvard University
-! Jean-Pierre Vilotte
-! Departement de Sismologie - IPGP - Paris
-! (c) June 1998
+! Universite de Pau et des Pays de l'Adour, France
!
-!=====================================================================
+! (c) May 2004
+!
+!========================================================================
- subroutine positsource(coord,ibool,gltfu,ndime,npoin,nltfl,nxgll,nygll,nspec)
+ subroutine positsource(coord,ibool,gltfu,npoin,nspec)
!
-!----- calculer la position reelle des sources
+!----- calculer la position reelle de la source
!
- 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)
+ include "constants.h"
+ integer npoin,nspec
+ double precision coord(NDIME,npoin)
+ double precision gltfu(20)
+ integer ibool(NGLLX,NGLLY,nspec)
+
double precision dminmax,dmin,xs,zs,xp,zp,dist
- integer n,ip,ipoint,ix,iy,numelem,ilowx,ilowy,ihighx,ihighy
+ integer ip,ipoint,ix,iy,numelem,ilowx,ilowy,ihighx,ihighy
write(iout,200)
- dminmax = -1.d30
+ dminmax = -HUGEVAL
- do n=1,nltfl
+ dmin = +HUGEVAL
- dmin = +1.d30
-
! coordonnees demandees pour la source
- xs = gltfu(3,n)
- zs = gltfu(4,n)
+ xs = gltfu(3)
+ zs = gltfu(4)
- 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
+ ihighx = NGLLX
+ ihighy = NGLLY
+
+! on ne fait la recherche que sur l'interieur de l'element si source explosive
+ if(nint(gltfu(2)) == 2) then
+ ilowx = 2
+ ilowy = 2
+ ihighx = NGLLX-1
+ ihighy = NGLLY-1
endif
! recherche du point de grille le plus proche
@@ -70,33 +68,29 @@
! 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
+ dmin = dist
+ gltfu(9) = ip
+ gltfu(10) = ix
+ gltfu(11) = iy
+ gltfu(12) = numelem
endif
enddo
enddo
enddo
- ipoint = nint(gltfu(9,n))
+ ipoint = nint(gltfu(9))
dminmax = dmax1(dmin,dminmax)
- write(iout,150) n,xs,zs,coord(1,ipoint),coord(2,ipoint),dmin
-
- enddo
-
+ write(iout,150) xs,zs,coord(1,ipoint),coord(2,ipoint),dmin
write(iout,160) dminmax
- 150 format(1x,i7,1x,f12.3,1x,f12.3,1x,f12.3,1x,f12.3,f12.3)
+ 150 format(1x,f12.3,1x,f12.3,1x,f12.3,1x,f12.3,f12.3)
160 format(/2x,'Maximum distance between asked and real =',f12.3)
200 format(//1x,48('=')/,' = S o u r c e s ', &
'r e a l p o s i t i o n s ='/1x,48('=')// &
- ' Source x-asked z-asked ', &
- 'x-obtain z-obtain dist'/)
+ ' Source x-asked z-asked x-obtain z-obtain dist'/)
- return
end subroutine positsource
+
Modified: seismo/2D/SPECFEM2D/trunk/SPECFEM90/q49shape.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/q49shape.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/q49shape.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,19 +1,18 @@
-!=====================================================================
+!========================================================================
!
-! S p e c f e m V e r s i o n 4 . 2
-! -----------------------------------
+! S P E C F E M 2 D Version 5.0
+! ------------------------------
!
! Dimitri Komatitsch
-! Department of Earth and Planetary Sciences - Harvard University
-! Jean-Pierre Vilotte
-! Departement de Sismologie - IPGP - Paris
-! (c) June 1998
+! Universite de Pau et des Pays de l'Adour, France
!
-!=====================================================================
-
- subroutine q49shape(shape,dershape,xi,yi,ngnod,nxgll,nygll,ndime)
+! (c) May 2004
!
+!========================================================================
+
+ subroutine q49shape(shape,dershape,xi,yi,ngnod,NGLLX,NGLLY,NDIME)
+
!=======================================================================
!
! "q 4 9 s h a p e" : set up the shape functions and their derivatives
@@ -36,15 +35,14 @@
! Local coordinate system : s,t
!
!=======================================================================
-!
implicit none
- integer ngnod,nxgll,nygll,ndime
+ integer ngnod,NGLLX,NGLLY,NDIME
- double precision shape(ngnod,nxgll,nxgll)
- double precision dershape(ndime,ngnod,nxgll,nxgll)
- double precision xi(nxgll),yi(nygll)
+ double precision shape(ngnod,NGLLX,NGLLX)
+ double precision dershape(NDIME,ngnod,NGLLX,NGLLX)
+ double precision xi(NGLLX),yi(NGLLY)
double precision, parameter :: &
zero=0.d0,one=1.d0,two=2.d0,half=0.5d0,quart=0.25d0
@@ -55,21 +53,17 @@
double precision, external :: hgll
!
-!-----------------------------------------------------------------------
-!
-
-!
!---- set up the shape functions and their local derivatives
!
- if(ngnod == 4) then
+ if(ngnod == 4) then
!
!---- 4-noded rectangular element
!
- do l2 = 1,nygll
+ do l2 = 1,NGLLY
t = yi(l2)
- do l1 = 1,nxgll
+ do l1 = 1,NGLLX
s = xi(l1)
@@ -99,15 +93,15 @@
enddo
enddo
- else if(ngnod == 9) then
+ else if(ngnod == 9) then
!
!---- 9-noded rectangular element
!
- do l2 = 1,nygll
+ do l2 = 1,NGLLY
t = yi(l2)
- do l1 = 1,nxgll
+ do l1 = 1,NGLLX
s = xi(l1)
@@ -167,8 +161,8 @@
enddo
else
- stop 'Error : wrong number of control nodes !!'
+ stop 'Error : wrong number of control nodes'
endif
- return
end subroutine q49shape
+
Modified: seismo/2D/SPECFEM2D/trunk/SPECFEM90/q49spec.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/q49spec.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/q49spec.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,21 +1,20 @@
-!=====================================================================
+!========================================================================
!
-! S p e c f e m V e r s i o n 4 . 2
-! -----------------------------------
+! S P E C F E M 2 D Version 5.0
+! ------------------------------
!
! Dimitri Komatitsch
-! Department of Earth and Planetary Sciences - Harvard University
-! Jean-Pierre Vilotte
-! Departement de Sismologie - IPGP - Paris
-! (c) June 1998
+! Universite de Pau et des Pays de l'Adour, France
!
-!=====================================================================
+! (c) May 2004
+!
+!========================================================================
subroutine q49spec(shapeint,dershape,dvolu,xjaci,xi, &
- coorg,knods,ngnod,nxgll,nygll,ndime,nspec,npgeo, &
+ coorg,knods,ngnod,NGLLX,NGLLY,NDIME,nspec,npgeo, &
xirec,etarec,flagrange,iptsdisp)
-!
+
!=======================================================================
!
! "q 4 9 s p e c" : set up the jacobian matrix
@@ -38,43 +37,38 @@
! Local coordinate system : s,t
!
!=======================================================================
-!
implicit none
- integer ngnod,nxgll,nygll,ndime,nspec,npgeo,iptsdisp
+ integer ngnod,NGLLX,NGLLY,NDIME,nspec,npgeo,iptsdisp
integer knods(ngnod,nspec)
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)
+ double precision dershape(NDIME,ngnod,NGLLX,NGLLX)
+ double precision dvolu(nspec,NGLLX,NGLLX)
+ double precision xjaci(nspec,NDIME,NDIME,NGLLX,NGLLX)
+ double precision coorg(NDIME,npgeo)
+ double precision xi(NGLLX)
double precision xirec(iptsdisp),etarec(iptsdisp)
- double precision flagrange(0:nxgll-1,iptsdisp)
+ double precision flagrange(NGLLX,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
+ integer l1,l2,ispec,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 ispec = 1,nspec
- do ip1 = 1,nxgll
- do ip2 = 1,nygll
+ do ip1 = 1,NGLLX
+ do ip2 = 1,NGLLY
xjac2_11 = zero
xjac2_21 = zero
@@ -83,7 +77,7 @@
do in = 1,ngnod
- nnum = knods(in,ispel)
+ nnum = knods(in,ispec)
xjac2_11 = xjac2_11 + dershape(1,in,ip1,ip2)*coorg(1,nnum)
xjac2_21 = xjac2_21 + dershape(1,in,ip1,ip2)*coorg(2,nnum)
@@ -96,14 +90,14 @@
!---- invert the jacobian matrix
!
- dvolu(ispel,ip1,ip2) = xjac2_11*xjac2_22 - xjac2_12*xjac2_21
+ dvolu(ispec,ip1,ip2) = xjac2_11*xjac2_22 - xjac2_12*xjac2_21
- if (dvolu(ispel,ip1,ip2) <= zero) stop 'Error : Jacobian undefined !!'
+ if (dvolu(ispec,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)
+ xjaci(ispec,1,1,ip1,ip2) = xjac2_22 / dvolu(ispec,ip1,ip2)
+ xjaci(ispec,2,1,ip1,ip2) = - xjac2_21 / dvolu(ispec,ip1,ip2)
+ xjaci(ispec,1,2,ip1,ip2) = - xjac2_12 / dvolu(ispec,ip1,ip2)
+ xjaci(ispec,2,2,ip1,ip2) = xjac2_11 / dvolu(ispec,ip1,ip2)
enddo
enddo
@@ -114,21 +108,21 @@
!---- 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
+ 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
+!---- calcul des interpolateurs de Lagrange (suppose NGLLX = NGLLY)
+ do i=1,NGLLX
+ do k=1,iptsdisp
+ flagrange(i,k) = hgll(i-1,xirec(k),xi,NGLLX)
+ enddo
enddo
!
!---- set up the shape functions for the interpolated grid
!
- if(ngnod == 4) then
+ if(ngnod == 4) then
!
!---- 4-noded rectangular element
!
@@ -156,7 +150,7 @@
enddo
enddo
- else if(ngnod == 9) then
+ else if(ngnod == 9) then
!
!---- 9-noded rectangular element
!
@@ -204,5 +198,5 @@
endif
- return
end subroutine q49spec
+
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/qinpspec.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/qinpspec.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/qinpspec.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,141 +0,0 @@
-
-!=====================================================================
-!
-! 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,kmato,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,shape,coorg,npoin,ndime,npgeo)
- else
- call createnum_slow(knods,ibool,npoin)
- endif
-
-!
-!---- compute the spectral element jacobian matrix
-!
-
- call q49spec(shapeint,dershape,dvolu,xjaci,xi,coorg, &
- knods,ngnod,nxgll,nygll,ndime,nspec,npgeo, &
- xirec,etarec,flagrange,iptsdisp)
-
-!
-!---- 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
-
Modified: seismo/2D/SPECFEM2D/trunk/SPECFEM90/qmasspec.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/qmasspec.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/qmasspec.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,43 +1,35 @@
-!=====================================================================
+
+!========================================================================
!
-! S p e c f e m V e r s i o n 4 . 2
-! -----------------------------------
+! S P E C F E M 2 D Version 5.0
+! ------------------------------
!
! Dimitri Komatitsch
-! Department of Earth and Planetary Sciences - Harvard University
-! Jean-Pierre Vilotte
-! Departement de Sismologie - IPGP - Paris
-! (c) June 1998
+! Universite de Pau et des Pays de l'Adour, France
!
-!=====================================================================
-
- subroutine qmasspec(rhoext,wx,wy,ibool,dvolu,rmass,density,kmato,npoin)
+! (c) May 2004
!
-!=======================================================================
-!
-! "q m a s s p e c" : Build the mass matrix for the spectral
-! elements
-!
-!=======================================================================
-!
- use spela202
- use constspec
+!========================================================================
+ subroutine qmasspec(rhoext,wxgll,wygll,ibool,dvolu,rmass,density,kmato,npoin,ireadmodel,nspec,numat)
+
+! build the mass matrix
+
implicit none
- integer npoin
+ include "constants.h"
- double precision wx(0:nxgll-1),wy(0:nygll-1),rmass(npoin), &
- dvolu(nspec,0:nxgll-1,0:nxgll-1),density(numat)
+ integer npoin,nspec,numat
+
+ double precision wxgll(NGLLX),wygll(NGLLY),rmass(npoin),dvolu(nspec,NGLLX,NGLLX),density(numat)
double precision rhoext(npoin)
- integer kmato(nspec),ibool(0:nxgll-1,0:nxgll-1,nspec)
+ integer kmato(nspec),ibool(NGLLX,NGLLX,nspec)
integer numelem,material,i,j,iglobnum
+ logical ireadmodel
double precision denst
- double precision, parameter :: zero=0.d0, one=1.d0
-
!
!---- compute the mass matrix by summing the contribution of each point
!
@@ -49,24 +41,20 @@
material = kmato(numelem)
denst = density(material)
- do i=0,nxgll-1
- do j=0,nygll-1
+ do i=1,NGLLX
+ do j=1,NGLLY
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)
+ rmass(iglobnum) = rmass(iglobnum) + denst * wxgll(i) * wygll(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
+
Modified: seismo/2D/SPECFEM2D/trunk/SPECFEM90/qsumspec.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/qsumspec.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/qsumspec.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,86 +1,80 @@
-!=====================================================================
+!========================================================================
!
-! S p e c f e m V e r s i o n 4 . 2
-! -----------------------------------
+! S P E C F E M 2 D Version 5.0
+! ------------------------------
!
! Dimitri Komatitsch
-! Department of Earth and Planetary Sciences - Harvard University
-! Jean-Pierre Vilotte
-! Departement de Sismologie - IPGP - Paris
-! (c) June 1998
+! Universite de Pau et des Pays de l'Adour, France
!
-!=====================================================================
+! (c) May 2004
+!
+!========================================================================
subroutine qsumspec(hprime,hTprime, &
- a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13x,a13z,force, &
+ a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13x,a13z, &
ibool,displ,veloc,accel,Uxnewloc,Uznewloc, &
- rmass,nxgll,npoin,ndime,nspec,gltfu,nltfl,initialfield, &
- is_bordabs,nelemabs,anyabs)
+ rmass,npoin,nspec,gltfu,initialfield, &
+ is_bordabs,nelemabs,anyabs,time)
- use timeparams
-
implicit none
- integer nxgll,npoin,ndime,nspec,nltfl,nelemabs
+ include "constants.h"
+
+ integer npoin,nspec,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)
+ double precision hprime(NGLLX,NGLLX),hTprime(NGLLX,NGLLX)
+ double precision a1(NGLLX,NGLLX,nspec),a2(NGLLX,NGLLX,nspec), &
+ a3(NGLLX,NGLLX,nspec),a4(NGLLX,NGLLX,nspec),a5(NGLLX,NGLLX,nspec), &
+ a6(NGLLX,NGLLX,nspec),a7(NGLLX,NGLLX,nspec), &
+ a8(NGLLX,NGLLX,nspec),a9(NGLLX,NGLLX,nspec),a10(NGLLX,NGLLX,nspec)
+ double precision a11(NGLLX,NGLLX),a12(NGLLX,NGLLX)
+ double precision a13x(NGLLX,NGLLX,nelemabs)
+ double precision a13z(NGLLX,NGLLX,nelemabs)
+ double precision Uxnewloc(NGLLX,NGLLX,nspec)
+ double precision Uznewloc(NGLLX,NGLLX,nspec)
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)
+! local arrays
+ double precision Uxoldloc(NGLLX,NGLLX)
+ double precision Uzoldloc(NGLLX,NGLLX)
+ double precision t1(NGLLX,NGLLX)
+ double precision t2(NGLLX,NGLLX)
+ double precision t3(NGLLX,NGLLX)
+ double precision t4(NGLLX,NGLLX)
double precision dUx_dxi,dUz_dxi,dUx_deta,dUz_deta
double precision hprimex,hTprimex,hprimez,hTprimez
- integer ibool(nxgll,nxgll,nspec)
+ integer ibool(NGLLX,NGLLX,nspec)
double precision rmass(npoin)
- double precision force(ndime,nltfl)
- double precision displ(ndime,npoin),veloc(ndime,npoin),accel(ndime,npoin)
+ double precision displ(NDIME,npoin),veloc(NDIME,npoin),accel(NDIME,npoin)
- double precision gltfu(20,nltfl)
+ double precision gltfu(20)
- double precision, external :: dirac,ricker
-
- integer i,j,k,l,n,isource,ielems,iglobsource,iglobnum,numer_abs
- double precision sig
+ integer i,j,k,l,ielems,iglobsource,iglobnum,numer_abs
+ double precision ricker,time
logical initialfield
- double precision, parameter :: zero=0.d0
+ double precision f0,t0,factor,a,angleforce
! 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
+ do j=1,NGLLX
+ do i=1,NGLLX
+ 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
+ do j=1,NGLLX
+ do i=1,NGLLX
! compute the gradient of the displacement field (matrix products)
dUx_dxi = zero
@@ -88,17 +82,17 @@
dUx_deta = zero
dUz_deta = zero
- do l=1,nxgll
+ do l=1,NGLLX
- hTprimex = hTprime(i,l)
- hprimez = hprime(l,j)
+ 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
+ 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
+ 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 + &
@@ -110,29 +104,27 @@
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
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 j=1,NGLLX
+ do i=1,NGLLX
- do l=1,nxgll
+ Uxnewloc(i,j,k) = zero
+ Uznewloc(i,j,k) = zero
- hprimex = hprime(i,l)
- hTprimez = hTprime(l,j)
+ do l=1,NGLLX
+ 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
+ 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
enddo
- enddo
! conditions absorbantes nouvelle formulation
! pas de dependance par l'adressage indirect
@@ -140,82 +132,67 @@
if(anyabs) then
numer_abs = is_bordabs(k)
if(numer_abs .gt. 0) then
- do j=1,nxgll
- do i=1,nxgll
+ do j=1,NGLLX
+ do i=1,NGLLX
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
+ 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)
+ do j=1,NGLLX
+ do i=1,NGLLX
+ 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
enddo
-! --- ajouter sources forces colloquees
-
+! --- add the source
if(.not. initialfield) then
- do n=1,nltfl
- iglobsource = nint(gltfu(9,n))
- accel(:,iglobsource) = accel(:,iglobsource) + force(:,n)
- enddo
- endif
-!---- ajouter sources explosives
+ f0 = gltfu(5)
+ t0 = gltfu(6)
+ factor = gltfu(7)
+ angleforce = gltfu(8)
- if(.not. initialfield) then
+! Ricker wavelet for the source time function
+ a = pi*pi*f0*f0
+ ricker = - factor * (1.d0-2.d0*a*(time-t0)**2)*exp(-a*(time-t0)**2)
- do n=1,nltfl
+! --- collocated force
+ if(nint(gltfu(2)) == 1) then
+ iglobsource = nint(gltfu(9))
+ accel(1,iglobsource) = accel(1,iglobsource) - dsin(angleforce)*ricker
+ accel(2,iglobsource) = accel(2,iglobsource) + dcos(angleforce)*ricker
-! seulement si source explosive
- if(nint(gltfu(2,n)) == 2) then
+!---- explosion
+ else if(nint(gltfu(2)) == 2) then
+! recuperer numero d'element de la source
+ ielems = nint(gltfu(12))
+ do i=1,NGLLX
+ do j=1,NGLLX
+ iglobnum = ibool(i,j,ielems)
+ accel(1,iglobnum) = accel(1,iglobnum) + a11(i,j)*ricker
+ accel(2,iglobnum) = accel(2,iglobnum) + a12(i,j)*ricker
+ enddo
+ enddo
+ endif
-! 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
+ stop 'wrong source type'
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
+
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/ricker.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/ricker.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/ricker.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,38 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/setcor.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/setcor.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/setcor.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,104 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/specfem.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/specfem.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/specfem.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,822 +0,0 @@
-
-!=====================================================================
-!
-! 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
- integer nbpoin,inump,n,npoinext,nseis,netyp,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,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/specfem2D.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/specfem2D.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/specfem2D.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -0,0 +1,807 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 5.0
+! ------------------------------
+!
+! Dimitri Komatitsch
+! Universite de Pau et des Pays de l'Adour, France
+!
+! (c) May 2004
+!
+!========================================================================
+
+!========================================================================
+!
+! An explicit 2D spectral element solver for the elastic wave equation
+!
+!========================================================================
+
+! cleaned version 5.0 is based on SPECFEM2D version 4.2
+! (c) June 1998 by Dimitri Komatitsch, Harvard University, USA
+! and Jean-Pierre Vilotte, Institut de Physique du Globe de Paris, France
+
+! version 5.0 : got rid of useless routines, suppressed commons etc.
+
+ program specfem2D
+
+ implicit none
+
+ include "constants.h"
+
+ character(len=80) datlin
+
+ double precision gltfu(20)
+
+ double precision, dimension(:,:), allocatable :: coorg,posrec
+ double precision, dimension(:), allocatable :: coorgread
+ double precision, dimension(:), allocatable :: posrecread
+
+ double precision, dimension(:,:), allocatable :: sisux,sisuz
+
+ logical anyabs
+
+ integer i,j,it,irec,iglobrec,ipoin,ip,id,ip1,ip2,in,nnum
+ integer nbpoin,inump,n,npoinext,netyp,ispec,npoin,npgeo
+
+ double precision valux,valuz,rhoextread,vpextread,vsextread
+ double precision dcosrot,dsinrot,xcor,zcor
+
+! coefficients of the explicit Newmark time scheme
+ integer NSTEP
+ double precision deltatover2,deltatsqover2,time,deltat
+
+ double precision, dimension(:), allocatable :: xigll,yigll,wxgll,wygll,xirec,etarec
+
+ double precision, dimension(:,:), allocatable :: coord,accel,veloc,displ, &
+ hprime,hTprime,flagrange,xinterp,zinterp,Uxinterp,Uzinterp,elastcoef
+
+ 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,a13x,a13z,Uxnewloc,Uznewloc
+
+ double precision, dimension(:,:), allocatable :: a11,a12
+
+ double precision, dimension(:,:,:,:), allocatable :: dershape
+
+ double precision, dimension(:,:,:,:,:), allocatable :: xjaci
+
+ integer, dimension(:,:,:), allocatable :: ibool
+ integer, dimension(:,:), allocatable :: knods,codeabs
+ integer, dimension(:), allocatable :: kmato,numabs,is_bordabs
+
+ integer ie,k
+ integer inum,itourne,ntourne,idummy,numabsread
+ integer isource,iexplo
+ integer codeabsread(4)
+
+ double precision rsizemin,rsizemax,cpoverdxmin,cpoverdxmax, &
+ rlamdaSmin,rlamdaSmax,rlamdaPmin,rlamdaPmax,vpmin,vpmax
+
+ integer icolor,inumber,isubsamp,ivecttype,itaff,nrec,isismostype
+ integer numat,ngnod,nspec,iptsdisp,nelemabs
+
+ logical interpol,imeshvect,imodelvect,iboundvect,ireadmodel,initialfield, &
+ ioutputgrid,ignuplot
+
+ double precision cutvect,anglerec
+
+! title of the plot
+ character(len=60) stitle
+
+!
+!***********************************************************************
+!
+! i n i t i a l i z a t i o n p h a s e
+!
+!***********************************************************************
+
+ open (IIN,file='DataBase')
+
+! uncomment this to write to file instead of standard output
+! open (IOUT,file='results_simulation.txt')
+
+!
+!--- read job title and skip remaining titles of the input file
+!
+ read(IIN,40) datlin
+ read(IIN,40) datlin
+ read(IIN,40) datlin
+ read(IIN,40) datlin
+ read(IIN,40) datlin
+ read(IIN,45) stitle
+
+!
+!---- print the date, time and start-up banner
+!
+ call datim(stitle)
+
+ write(*,*)
+ write(*,*)
+ write(*,*) '*********************************'
+ write(*,*) '**** ****'
+ write(*,*) '**** SPECFEM2D VERSION 5.0 ****'
+ write(*,*) '**** ****'
+ write(*,*) '*********************************'
+
+!
+!---- read parameters from input file
+!
+
+ read(IIN,40) datlin
+ read(IIN,*) npgeo
+
+ read(IIN,40) datlin
+ read(IIN,*) ignuplot,interpol
+
+ read(IIN,40) datlin
+ read(IIN,*) itaff,icolor,inumber
+
+ read(IIN,40) datlin
+ read(IIN,*) imeshvect,imodelvect,iboundvect,cutvect,isubsamp
+ cutvect = cutvect / 100.d0
+
+ read(IIN,40) datlin
+ read(IIN,*) nrec,anglerec
+
+ read(IIN,40) datlin
+ read(IIN,*) initialfield
+
+ read(IIN,40) datlin
+ read(IIN,*) isismostype,ivecttype
+
+ read(IIN,40) datlin
+ read(IIN,*) ireadmodel,ioutputgrid
+
+!---- check parameters read
+ write(IOUT,200) npgeo,NDIME
+ write(IOUT,600) itaff,icolor,inumber
+ write(IOUT,700) nrec,isismostype,anglerec
+ write(IOUT,750) initialfield,ireadmodel,ioutputgrid
+ write(IOUT,800) ivecttype,100.d0*cutvect,isubsamp
+
+!---- read time step
+ read(IIN,40) datlin
+ read(IIN,*) NSTEP,deltat
+ write(IOUT,703) NSTEP,deltat,NSTEP*deltat
+
+!
+!---- allocate first arrays needed
+!
+ if(nrec < 1) stop 'need at least one receiver'
+ allocate(sisux(NSTEP,nrec))
+ allocate(sisuz(NSTEP,nrec))
+ allocate(posrec(NDIME,nrec))
+ allocate(coorg(NDIME,npgeo))
+
+!
+!---- read source information
+!
+ read(IIN,40) datlin
+ read(IIN,*) (gltfu(k), k=1,9)
+
+!
+!----- check the input
+!
+ if(.not. initialfield) then
+ if(nint(gltfu(1)) /= 6) stop 'Wrong function number in getltf !'
+ isource = nint(gltfu(1))
+ iexplo = nint(gltfu(2))
+ if (iexplo == 1) then
+ write(IOUT,212) (gltfu(k), k=3,8)
+ else if(iexplo == 2) then
+ write(IOUT,222) (gltfu(k), k=3,7)
+ else
+ stop 'Unknown source type number !'
+ endif
+ endif
+
+!
+!----- convert angle from degrees to radians
+!
+ isource = nint(gltfu(1))
+ iexplo = nint(gltfu(2))
+ if(isource >= 4.and.isource <= 6.and.iexplo == 1) gltfu(8) = gltfu(8) * pi / 180.d0
+
+!
+!---- read receiver locations
+!
+ 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)
+
+!
+!---- read the spectral macrobloc nodal coordinates
+!
+ 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)
+
+!
+!---- read the basic properties of the spectral elements
+!
+ read(IIN ,40) datlin
+ read(IIN ,*) netyp,numat,ngnod,nspec,iptsdisp,nelemabs
+
+!
+!---- allocate arrays
+!
+
+allocate(shape(ngnod,NGLLX,NGLLY))
+allocate(shapeint(ngnod,iptsdisp,iptsdisp))
+allocate(dershape(NDIME,ngnod,NGLLX,NGLLY))
+allocate(dvolu(nspec,NGLLX,NGLLY))
+allocate(xjaci(nspec,NDIME,NDIME,NGLLX,NGLLY))
+allocate(hprime(NGLLX,NGLLY))
+allocate(hTprime(NGLLX,NGLLY))
+allocate(a1(NGLLX,NGLLY,nspec))
+allocate(a2(NGLLX,NGLLY,nspec))
+allocate(a3(NGLLX,NGLLY,nspec))
+allocate(a4(NGLLX,NGLLY,nspec))
+allocate(a5(NGLLX,NGLLY,nspec))
+allocate(a6(NGLLX,NGLLY,nspec))
+allocate(a7(NGLLX,NGLLY,nspec))
+allocate(a8(NGLLX,NGLLY,nspec))
+allocate(a9(NGLLX,NGLLY,nspec))
+allocate(a10(NGLLX,NGLLY,nspec))
+allocate(a11(NGLLX,NGLLY))
+allocate(a12(NGLLX,NGLLY))
+allocate(xigll(NGLLX))
+allocate(yigll(NGLLY))
+allocate(wxgll(NGLLX))
+allocate(wygll(NGLLY))
+allocate(Uxnewloc(NGLLX,NGLLY,nspec))
+allocate(Uznewloc(NGLLX,NGLLY,nspec))
+allocate(xirec(iptsdisp))
+allocate(etarec(iptsdisp))
+allocate(flagrange(NGLLX,iptsdisp))
+allocate(xinterp(iptsdisp,iptsdisp))
+allocate(zinterp(iptsdisp,iptsdisp))
+allocate(Uxinterp(iptsdisp,iptsdisp))
+allocate(Uzinterp(iptsdisp,iptsdisp))
+allocate(density(numat))
+allocate(elastcoef(4,numat))
+allocate(kmato(nspec))
+allocate(knods(ngnod,nspec))
+allocate(ibool(NGLLX,NGLLY,nspec))
+
+! --- allocate arrays for absorbing 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))
+
+!
+!---- print element group main parameters
+!
+ write(IOUT,107)
+ write(IOUT,207) nspec,ngnod,NGLLX,NGLLY,NGLLX*NGLLY,iptsdisp,numat,nelemabs
+
+!
+!---- set up coordinates of the Gauss-Lobatto-Legendre points
+!
+ call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
+
+!
+!---- if nb of points is odd, the middle abscissa is exactly zero
+!
+ if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO
+ if(mod(NGLLY,2) /= 0) yigll((NGLLY-1)/2+1) = ZERO
+
+!
+!---- read the material properties
+!
+ call gmat01(density,elastcoef,numat)
+
+!
+!---- read spectral macrobloc data
+!
+ n = 0
+ read(IIN,40) datlin
+ do ie = 1,nspec
+ read(IIN,*) n,kmato(n),(knods(k,n), k=1,ngnod)
+ enddo
+
+!
+!---- read absorbing boundary data
+!
+ if(anyabs) then
+ read(IIN ,40) datlin
+ do n=1,nelemabs
+ read(IIN ,*) inum,numabsread,codeabsread(1), &
+ codeabsread(2),codeabsread(3),codeabsread(4)
+ if(inum < 1 .or. inum > nelemabs) stop 'Wrong absorbing element number'
+ numabs(inum) = numabsread
+ codeabs(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
+
+ enddo
+
+ endif
+
+ enddo
+ write(*,*)
+ write(*,*) 'Number of absorbing elements: ',nelemabs
+ endif
+
+
+!
+!---- compute the spectral element shape functions and their local derivatives
+!
+ call q49shape(shape,dershape,xigll,yigll,ngnod,NGLLX,NGLLY,NDIME)
+
+!
+!---- generate the global numbering
+!
+
+! version "propre mais lente" ou version "sale mais rapide"
+ if(fast_numbering) then
+ call createnum_fast(knods,ibool,shape,coorg,npoin,npgeo,nspec,ngnod)
+ else
+ call createnum_slow(knods,ibool,npoin,nspec,ngnod)
+ endif
+
+!
+!---- compute the spectral element jacobian matrix
+!
+
+ call q49spec(shapeint,dershape,dvolu,xjaci,xigll,coorg,knods,ngnod, &
+ NGLLX,NGLLY,NDIME,nspec,npgeo,xirec,etarec,flagrange,iptsdisp)
+
+!
+!---- 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(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(NGLLX,NGLLY,nelemabs))
+ allocate(a13z(NGLLX,NGLLY,nelemabs))
+
+!
+!---- set the coordinates of the points of the global grid
+!
+ do ispec = 1,nspec
+ do ip1 = 1,NGLLX
+ do ip2 = 1,NGLLY
+
+ xcor = zero
+ zcor = zero
+ do in = 1,ngnod
+ nnum = knods(in,ispec)
+ xcor = xcor + shape(in,ip1,ip2)*coorg(1,nnum)
+ zcor = zcor + shape(in,ip1,ip2)*coorg(2,nnum)
+ enddo
+
+ coord(1,ibool(ip1,ip2,ispec)) = xcor
+ coord(2,ibool(ip1,ip2,ispec)) = zcor
+
+ enddo
+ enddo
+ enddo
+
+!
+!--- save the grid of points in a file
+!
+ 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
+
+!
+!----- plot the GLL mesh in a Gnuplot file
+!
+ if(ignuplot) call plotgll(knods,ibool,coorg,coord,npoin,npgeo,ngnod,nspec)
+
+!
+!---- define coefficients of the Newmark time scheme
+!
+ deltatover2 = 0.5d0*deltat
+ deltatsqover2 = deltat*deltat/2.d0
+
+!
+!---- definir la position reelle des points source et recepteurs
+!
+ call positsource(coord,ibool,gltfu,npoin,nspec)
+ call positrec(coord,posrec,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,wxgll,wygll,ibool,dvolu,rmass,density,kmato,npoin,ireadmodel,nspec,numat)
+
+!
+!---- definir les tableaux a1 a a13
+!
+ call defarrays(vpext,vsext,rhoext,density,elastcoef, &
+ xigll,yigll,wxgll,wygll,hprime,hTprime, &
+ a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13x,a13z, &
+ ibool,kmato,dvolu,xjaci,coord,gltfu, &
+ numabs,codeabs,anyabs,npoin,rsizemin,rsizemax, &
+ cpoverdxmin,cpoverdxmax,rlamdaSmin,rlamdaSmax, &
+ rlamdaPmin,rlamdaPmax,vpmin,vpmax,ireadmodel,nelemabs,nspec,numat)
+
+! initialiser les tableaux a zero
+ accel = zero
+ veloc = zero
+ displ = 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
+
+!
+!---- 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))
+
+!
+!---- verifier le maillage, la stabilite et le nb de points par lambda
+!
+ call checkgrid(deltat,gltfu,initialfield,rsizemin,rsizemax, &
+ cpoverdxmin,cpoverdxmax,rlamdaSmin,rlamdaSmax,rlamdaPmin,rlamdaPmax)
+
+!
+!---- initialiser sismogrammes
+!
+ sisux = zero
+ sisuz = zero
+
+ dcosrot = dcos(anglerec)
+ dsinrot = dsin(anglerec)
+
+!
+!---- s t a r t t i m e i t e r a t i o n s
+!
+
+ write(IOUT,400)
+
+! boucle principale d'evolution en temps
+ do it=1,NSTEP
+
+! compute current time
+ time = (it-1)*deltat
+
+ if(mod(it-1,itaff) == 0) then
+ 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(:,:)
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+ accel(:,:) = zero
+
+!
+!---- calcul du residu d'acceleration pour le corrector
+!---- retourne dans accel le terme Fext - M*A(i,n+1) - K*D(i,n+1)
+!
+ call qsumspec(hprime,hTprime,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13x,a13z, &
+ ibool,displ,veloc,accel,Uxnewloc,Uznewloc,rmass,npoin, &
+ nspec,gltfu,initialfield,is_bordabs,nelemabs,anyabs,time)
+
+!
+!---- mise a jour globale du deplacement par corrector
+!
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+
+!
+!---- display max of norm of displacement
+!
+ if(mod(it-1,itaff) == 0) &
+ print *,'Max norme U = ',maxval(sqrt(displ(1,:)**2 + displ(2,:)**2))
+
+! store the seismograms
+ 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
+
+! rotation eventuelle des composantes
+ sisux(it,irec) = dcosrot*valux + dsinrot*valuz
+ sisuz(it,irec) = - dsinrot*valux + dcosrot*valuz
+
+ enddo
+
+!
+!---- affichage des resultats a certains pas de temps
+!
+ if(mod(it,itaff) == 0 .or. it == 5 .or. it == NSTEP) then
+
+ write(IOUT,*)
+ if(time >= 1.d-3) then
+ write(IOUT,110) time
+ else
+ write(IOUT,111) time
+ endif
+ write(IOUT,*)
+
+!
+!---- affichage postscript
+!
+ write(IOUT,*) 'Dump PostScript'
+ if(ivecttype == 1) then
+ write(IOUT,*) 'drawing displacement field...'
+ call plotpost(displ,coord,vpext,gltfu,posrec, &
+ it,deltat,coorg,xinterp,zinterp,shapeint, &
+ Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ numabs,codeabs,anyabs,stitle,npoin,npgeo,vpmin,vpmax,nrec, &
+ icolor,inumber,isubsamp,ivecttype,interpol,imeshvect,imodelvect, &
+ iboundvect,ireadmodel,cutvect,nelemabs,numat,iptsdisp,nspec,ngnod)
+ else if(ivecttype == 2) then
+ write(IOUT,*) 'drawing velocity field...'
+ call plotpost(veloc,coord,vpext,gltfu,posrec, &
+ it,deltat,coorg,xinterp,zinterp,shapeint, &
+ Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ numabs,codeabs,anyabs,stitle,npoin,npgeo,vpmin,vpmax,nrec, &
+ icolor,inumber,isubsamp,ivecttype,interpol,imeshvect,imodelvect, &
+ iboundvect,ireadmodel,cutvect,nelemabs,numat,iptsdisp,nspec,ngnod)
+ else if(ivecttype == 3) then
+ write(IOUT,*) 'drawing acceleration field...'
+ call plotpost(accel,coord,vpext,gltfu,posrec, &
+ it,deltat,coorg,xinterp,zinterp,shapeint, &
+ Uxinterp,Uzinterp,flagrange,density,elastcoef,knods,kmato,ibool, &
+ numabs,codeabs,anyabs,stitle,npoin,npgeo,vpmin,vpmax,nrec, &
+ icolor,inumber,isubsamp,ivecttype,interpol,imeshvect,imodelvect, &
+ iboundvect,ireadmodel,cutvect,nelemabs,numat,iptsdisp,nspec,ngnod)
+ else
+ stop 'wrong field code for PostScript display'
+ endif
+ write(IOUT,*) 'Fin dump PostScript'
+
+!---- save temporary seismograms
+ call write_seismograms(sisux,sisuz,NSTEP,nrec,deltat)
+
+ endif
+
+ enddo ! end of the main time loop
+
+!---- save final seismograms
+ call write_seismograms(sisux,sisuz,NSTEP,nrec,deltat)
+
+! print exit banner
+ call datim(stitle)
+
+!
+!---- close output file
+!
+ close(IOUT)
+
+!
+!---- formats
+!
+ 40 format(a80)
+ 45 format(a50)
+ 100 format('Pas de temps numero ',i5,' t = ',f7.4,' s')
+ 101 format('Pas de temps numero ',i5,' t = ',1pe10.4,' s')
+ 110 format('Sauvegarde deplacement temps t = ',f7.4,' s')
+ 111 format('Sauvegarde deplacement temps t = ',1pe10.4,' s')
+ 400 format(/1x,41('=')/,' = T i m e e v o l u t i o n l o o p ='/1x,41('=')/)
+
+ 200 format(//1x,'C o n t r o l',/1x,34('='),//5x,&
+ 'Number of spectral element control nodes. . (npgeo) =',i8/5x, &
+ 'Number of space dimensions . . . . . . . . . (NDIME) =',i8)
+ 600 format(//1x,'C o n t r o l',/1x,34('='),//5x, &
+ 'Display frequency . . . . . . . . . . . . . (itaff) = ',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',/1x,34('='),//5x, &
+ 'Total number of receivers. . . . . . . . . . .(nrec) = ',i6/5x, &
+ 'Seismograms recording type. . . . . . .(isismostype) = ',i6/5x, &
+ 'Angle for first line of receivers. . . . .(anglerec) = ',f6.2)
+ 750 format(//1x,'C o n t r o l',/1x,34('='),//5x, &
+ 'Read external initial field or not . .(initialfield) = ',l6/5x, &
+ 'Read external velocity model or not. . .(ireadmodel) = ',l6/5x, &
+ 'Save grid in external file or not . . .(ioutputgrid) = ',l6)
+ 800 format(//1x,'C o n t r o l',/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)
+
+ 703 format(//' I t e r a t i o n s '/1x,29('='),//5x, &
+ 'Number of time iterations . . . . .(NSTEP) =',i8,/5x, &
+ 'Time step increment . . . . . . . .(deltat) =',1pe15.6,/5x, &
+ 'Total simulation duration . . . . . (ttot) =',1pe15.6)
+
+ 107 format(/5x,'--> Isoparametric Spectral Elements <--',//)
+ 207 format(5x, &
+ 'Number of spectral elements . . . . . (nspec) =',i7,/5x, &
+ 'Number of control nodes per element . (ngnod) =',i7,/5x, &
+ 'Number of points in X-direction . . . (NGLLX) =',i7,/5x, &
+ 'Number of points in Y-direction . . . (NGLLY) =',i7,/5x, &
+ 'Number of points per element. . .(NGLLX*NGLLY) =',i7,/5x, &
+ 'Number of points for display . . . .(iptsdisp) =',i7,/5x, &
+ 'Number of element material sets . . . (numat) =',i7,/5x, &
+ 'Number of absorbing elements . . . .(nelemabs) =',i7)
+
+ 212 format(//,5x, &
+ 'Source Type. . . . . . . . . . . . . . = Collocated Force',/5x, &
+ 'X-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Y-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Fundamental frequency (Hz) . . . . . . =',1pe20.10,/5x, &
+ 'Time delay (s) . . . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Multiplying factor . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Angle from vertical direction (deg). . =',1pe20.10,/5x)
+ 222 format(//,5x, &
+ 'Source Type. . . . . . . . . . . . . . = Explosion',/5x, &
+ 'X-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Y-position (meters). . . . . . . . . . =',1pe20.10,/5x, &
+ 'Fundamental frequency (Hz) . . . . . . =',1pe20.10,/5x, &
+ 'Time delay (s) . . . . . . . . . . . . =',1pe20.10,/5x, &
+ 'Multiplying factor . . . . . . . . . . =',1pe20.10,/5x)
+
+ end program specfem2D
+
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/storearray.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/storearray.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/storearray.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,45 +0,0 @@
-!=====================================================================
-!
-! 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/write_seismograms.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/write_seismograms.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/write_seismograms.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -0,0 +1,54 @@
+
+!========================================================================
+!
+! S P E C F E M 2 D Version 5.0
+! ------------------------------
+!
+! Dimitri Komatitsch
+! Universite de Pau et des Pays de l'Adour, France
+!
+! (c) May 2004
+!
+!========================================================================
+
+ subroutine write_seismograms(sisux,sisuz,nt,nrec,deltat)
+
+! save the seismograms in ASCII format
+
+ implicit none
+
+ integer nt,nrec
+ double precision deltat
+
+ double precision sisux(nt,nrec)
+ double precision sisuz(nt,nrec)
+
+ integer irec,it
+
+ character(len=100) name
+
+! X component
+ do irec=1,nrec
+ write(name,221) irec
+ open(unit=11,file=name,status='unknown')
+ do it=1,nt
+ write(11,*) sngl(dble(it-1)*deltat),' ',sngl(sisux(it,irec))
+ enddo
+ close(11)
+ enddo
+
+! Z component
+ do irec=1,nrec
+ write(name,222) irec
+ open(unit=11,file=name,status='unknown')
+ do it=1,nt
+ write(11,*) sngl(dble(it-1)*deltat),' ',sngl(sisuz(it,irec))
+ enddo
+ close(11)
+ enddo
+
+ 221 format('Ux_file_',i3.3,'.dat')
+ 222 format('Uz_file_',i3.3,'.dat')
+
+ end subroutine write_seismograms
+
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/writeseis.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/writeseis.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/writeseis.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,561 +0,0 @@
-
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/zwgjd.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/zwgjd.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/zwgjd.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,82 +0,0 @@
-!=====================================================================
-!
-! 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
Deleted: seismo/2D/SPECFEM2D/trunk/SPECFEM90/zwgljd.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/SPECFEM90/zwgljd.f90 2004-05-16 01:34:24 UTC (rev 8417)
+++ seismo/2D/SPECFEM2D/trunk/SPECFEM90/zwgljd.f90 2007-12-07 23:44:38 UTC (rev 8418)
@@ -1,77 +0,0 @@
-!=====================================================================
-!
-! 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