[cig-commits] r15850 - in seismo/3D/SPECFEM3D_SESAME/trunk: . UTILS/Visualization/opendx_AVS_GMT decompose_mesh_SCOTCH
danielpeter at geodynamics.org
danielpeter at geodynamics.org
Mon Oct 19 19:18:58 PDT 2009
Author: danielpeter
Date: 2009-10-19 19:18:56 -0700 (Mon, 19 Oct 2009)
New Revision: 15850
Added:
seismo/3D/SPECFEM3D_SESAME/trunk/get_element_face.f90
seismo/3D/SPECFEM3D_SESAME/trunk/prepare_assemble_MPI.f90
Modified:
seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/opendx_AVS_GMT/create_highres_shakemaps_AVS_DX.f90
seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/opendx_AVS_GMT/extract_shakemap_GMT.f90
seismo/3D/SPECFEM3D_SESAME/trunk/calc_jacobian.f90
seismo/3D/SPECFEM3D_SESAME/trunk/combine_AVS_DX.f90
seismo/3D/SPECFEM3D_SESAME/trunk/combine_vol_data.f90
seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_with_Deville.f90
seismo/3D/SPECFEM3D_SESAME/trunk/constants.h.in
seismo/3D/SPECFEM3D_SESAME/trunk/create_header_file.f90
seismo/3D/SPECFEM3D_SESAME/trunk/create_movie_shakemap_AVS_DX_GMT.f90
seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90
seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90
seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90
seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90
seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90
seismo/3D/SPECFEM3D_SESAME/trunk/get_absorb.f90
seismo/3D/SPECFEM3D_SESAME/trunk/get_global.f90
seismo/3D/SPECFEM3D_SESAME/trunk/get_jacobian_boundaries.f90
seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90
seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90
seismo/3D/SPECFEM3D_SESAME/trunk/locate_source.f90
seismo/3D/SPECFEM3D_SESAME/trunk/memory_eval.f90
seismo/3D/SPECFEM3D_SESAME/trunk/parallel.f90
seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90
seismo/3D/SPECFEM3D_SESAME/trunk/save_arrays_solver.f90
seismo/3D/SPECFEM3D_SESAME/trunk/save_header_file.f90
seismo/3D/SPECFEM3D_SESAME/trunk/serial.f90
seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90
seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90
seismo/3D/SPECFEM3D_SESAME/trunk/write_seismograms.f90
Log:
modified absorbing boundary routines for irregular meshes; further structuring of meshing routines; added files get_element_face.f90 and prepare_assemble_MPI.f90
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in 2009-10-20 02:18:56 UTC (rev 15850)
@@ -72,6 +72,7 @@
$O/get_absorb.o \
$O/get_attenuation_model.o \
$O/get_cmt.o \
+ $O/get_element_face.o \
$O/get_global.o \
$O/get_jacobian_boundaries.o \
$O/get_shape2D.o \
@@ -84,7 +85,7 @@
$O/locate_source.o \
$O/generate_databases.o \
$O/netlib_specfun_erf.o \
- $O/read_arrays_buffers_solver.o \
+ $O/prepare_assemble_MPI.o \
$O/read_topo_bathy_file.o \
$O/read_parameter_file.o \
$O/read_value_parameters.o \
@@ -113,6 +114,7 @@
# $O/interpolate_gocad_block_HR.o \
# $O/interpolate_gocad_block_MR.o \
# $O/mesh_vertical.o \
+# $O/read_arrays_buffers_solver.o \
# $O/read_moho_map.o \
# $O/salton_trough_gocad.o \
# $O/socal_model.o \
@@ -122,11 +124,9 @@
# solver objects with statically allocated arrays; dependent upon
# values_from_mesher.h
SOLVER_ARRAY_OBJECTS = \
- $O/assemble_MPI_scalar.o \
- $O/assemble_MPI_vector.o \
+ $O/specfem3D_par.o \
$O/compute_forces_no_Deville.o \
$O/compute_forces_with_Deville.o \
- $O/specfem3D_par.o \
$O/initialize_simulation.o \
$O/read_mesh_databases.o \
$O/setup_GLL_points.o \
@@ -138,6 +138,8 @@
$O/iterate_time.o \
$O/finalize_simulation.o \
$O/specfem3D.o \
+ $O/assemble_MPI_scalar.o \
+ $O/assemble_MPI_vector.o \
$(EMPTY_MACRO)
###
@@ -384,6 +386,9 @@
$O/create_movie_shakemap_AVS_DX_GMT.o: constants.h create_movie_shakemap_AVS_DX_GMT.f90
${FCCOMPILE_CHECK} -c -o $O/create_movie_shakemap_AVS_DX_GMT.o create_movie_shakemap_AVS_DX_GMT.f90
+$O/get_element_face.o: constants.h get_element_face.f90
+ ${FCCOMPILE_CHECK} -c -o $O/get_element_face.o get_element_face.f90
+
$O/get_global.o: constants.h get_global.f90
${FCCOMPILE_CHECK} -c -o $O/get_global.o get_global.f90
@@ -438,9 +443,6 @@
$O/create_serial_name_database.o: constants.h create_serial_name_database.f90
${FCCOMPILE_CHECK} -c -o $O/create_serial_name_database.o create_serial_name_database.f90
-$O/read_arrays_buffers_solver.o: constants.h read_arrays_buffers_solver.f90
- ${FCCOMPILE_CHECK} -c -o $O/read_arrays_buffers_solver.o read_arrays_buffers_solver.f90
-
$O/define_derivation_matrices.o: constants.h define_derivation_matrices.f90
${FCCOMPILE_CHECK} -c -o $O/define_derivation_matrices.o define_derivation_matrices.f90
@@ -459,6 +461,9 @@
$O/combine_surf_data.o: constants.h combine_surf_data.f90
${FCCOMPILE_CHECK} -c -o $O/combine_surf_data.o combine_surf_data.f90
+$O/prepare_assemble_MPI.o: constants.h prepare_assemble_MPI.f90
+ ${FCCOMPILE_CHECK} -c -o $O/prepare_assemble_MPI.o prepare_assemble_MPI.f90
+
### compilation with optimization
$O/specfem3D.o: constants.h specfem3D.f90
@@ -522,6 +527,9 @@
#$O/read_arrays_solver.o: constants.h OUTPUT_FILES/values_from_mesher.h read_arrays_solver.f90
# ${FCCOMPILE_CHECK} -c -o $O/read_arrays_solver.o read_arrays_solver.f90
+#--obsolete
+#$O/read_arrays_buffers_solver.o: constants.h read_arrays_buffers_solver.f90
+# ${FCCOMPILE_CHECK} -c -o $O/read_arrays_buffers_solver.o read_arrays_buffers_solver.f90
###
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/opendx_AVS_GMT/create_highres_shakemaps_AVS_DX.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/opendx_AVS_GMT/create_highres_shakemaps_AVS_DX.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/opendx_AVS_GMT/create_highres_shakemaps_AVS_DX.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -37,9 +37,6 @@
! number of points in each AVS or OpenDX quadrangular cell for movies
integer, parameter :: NGNOD2D_AVS_DX = 4
-! number of points per surface element
- integer, parameter :: NGLLSQUARE = NGLLX * NGLLY
-
!! DK DK for high-res movies
integer, parameter :: NGNOD2D_AVS_DX_HIGHRES = NGLLSQUARE
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/opendx_AVS_GMT/extract_shakemap_GMT.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/opendx_AVS_GMT/extract_shakemap_GMT.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/UTILS/Visualization/opendx_AVS_GMT/extract_shakemap_GMT.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -39,9 +39,6 @@
! number of points in each AVS or OpenDX quadrangular cell for movies
integer, parameter :: NGNOD2D_AVS_DX = 4
-! number of points per surface element
- integer, parameter :: NGLLSQUARE = NGLLX * NGLLY
-
!! DK DK for high-res movies
integer, parameter :: NGNOD2D_AVS_DX_HIGHRES = NGLLSQUARE
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/calc_jacobian.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/calc_jacobian.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/calc_jacobian.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -24,9 +24,10 @@
!=====================================================================
subroutine calc_jacobian(myrank,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore,jacobianstore, &
- xstore,ystore,zstore,xelm,yelm,zelm,shape3D,dershape3D,ispec,nspec)
+ etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore,jacobianstore, &
+ xstore,ystore,zstore, &
+ xelm,yelm,zelm,shape3D,dershape3D,ispec,nspec)
implicit none
@@ -143,3 +144,220 @@
end subroutine calc_jacobian
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+! This subroutine recomputes the 3D jacobian for one element
+! based upon all GLL points
+! Hejun Zhu OCT16,2009
+
+! input: myrank,
+! xstore,ystore,zstore ----- input position
+! xigll,yigll,zigll ----- gll points position
+! ispec,nspec ----- element number
+! ACTUALLY_STORE_ARRAYS ------ save array or not
+
+! output: xixstore,xiystore,xizstore,
+! etaxstore,etaystore,etazstore,
+! gammaxstore,gammaystore,gammazstore ------ parameters used for calculating jacobian
+
+
+ subroutine recalc_jacobian_gll3D(myrank,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore,jacobianstore, &
+ xstore,ystore,zstore, &
+ ispec,nspec, &
+ xigll,yigll,zigll, &
+ ACTUALLY_STORE_ARRAYS)
+
+ implicit none
+
+ include "constants.h"
+
+ ! input parameter
+ integer::myrank,ispec,nspec
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
+ double precision, dimension(NGLLX):: xigll
+ double precision, dimension(NGLLY):: yigll
+ double precision, dimension(NGLLZ):: zigll
+ logical::ACTUALLY_STORE_ARRAYS
+
+
+ ! output results
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
+ xixstore,xiystore,xizstore,&
+ etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore,&
+ jacobianstore
+
+
+ ! other parameters for this subroutine
+ integer:: i,j,k,i1,j1,k1
+ double precision:: xxi,xeta,xgamma,yxi,yeta,ygamma,zxi,zeta,zgamma
+ double precision:: xi,eta,gamma
+ double precision,dimension(NGLLX):: hxir,hpxir
+ double precision,dimension(NGLLY):: hetar,hpetar
+ double precision,dimension(NGLLZ):: hgammar,hpgammar
+ double precision:: hlagrange,hlagrange_xi,hlagrange_eta,hlagrange_gamma
+ double precision:: jacobian
+ double precision:: xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+
+
+
+ ! test parameters which can be deleted
+ double precision:: xmesh,ymesh,zmesh
+ double precision:: sumshape,sumdershapexi,sumdershapeeta,sumdershapegamma
+
+ ! first go over all 125 gll points
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ xxi = 0.0
+ xeta = 0.0
+ xgamma = 0.0
+ yxi = 0.0
+ yeta = 0.0
+ ygamma = 0.0
+ zxi = 0.0
+ zeta = 0.0
+ zgamma = 0.0
+
+ xi = xigll(i)
+ eta = yigll(j)
+ gamma = zigll(k)
+
+ ! calculate lagrange polynomial and its derivative
+ call lagrange_any(xi,NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(eta,NGLLY,yigll,hetar,hpetar)
+ call lagrange_any(gamma,NGLLZ,zigll,hgammar,hpgammar)
+
+ ! test parameters
+ sumshape = 0.0
+ sumdershapexi = 0.0
+ sumdershapeeta = 0.0
+ sumdershapegamma = 0.0
+ xmesh = 0.0
+ ymesh = 0.0
+ zmesh = 0.0
+
+
+ do k1 = 1,NGLLZ
+ do j1 = 1,NGLLY
+ do i1 = 1,NGLLX
+ hlagrange = hxir(i1)*hetar(j1)*hgammar(k1)
+ hlagrange_xi = hpxir(i1)*hetar(j1)*hgammar(k1)
+ hlagrange_eta = hxir(i1)*hpetar(j1)*hgammar(k1)
+ hlagrange_gamma = hxir(i1)*hetar(j1)*hpgammar(k1)
+
+
+ xxi = xxi + xstore(i1,j1,k1,ispec)*hlagrange_xi
+ xeta = xeta + xstore(i1,j1,k1,ispec)*hlagrange_eta
+ xgamma = xgamma + xstore(i1,j1,k1,ispec)*hlagrange_gamma
+
+ yxi = yxi + ystore(i1,j1,k1,ispec)*hlagrange_xi
+ yeta = yeta + ystore(i1,j1,k1,ispec)*hlagrange_eta
+ ygamma = ygamma + ystore(i1,j1,k1,ispec)*hlagrange_gamma
+
+ zxi = zxi + zstore(i1,j1,k1,ispec)*hlagrange_xi
+ zeta = zeta + zstore(i1,j1,k1,ispec)*hlagrange_eta
+ zgamma = zgamma + zstore(i1,j1,k1,ispec)*hlagrange_gamma
+
+ ! test the lagrange polynomial and its derivate
+ xmesh = xmesh + xstore(i1,j1,k1,ispec)*hlagrange
+ ymesh = ymesh + ystore(i1,j1,k1,ispec)*hlagrange
+ zmesh = zmesh + zstore(i1,j1,k1,ispec)*hlagrange
+ sumshape = sumshape + hlagrange
+ sumdershapexi = sumdershapexi + hlagrange_xi
+ sumdershapeeta = sumdershapeeta + hlagrange_eta
+ sumdershapegamma = sumdershapegamma + hlagrange_gamma
+
+ end do
+ end do
+ end do
+
+ ! Check the lagrange polynomial and its derivative
+ if (xmesh /=xstore(i,j,k,ispec).or.ymesh/=ystore(i,j,k,ispec).or.zmesh/=zstore(i,j,k,ispec)) then
+ call exit_MPI(myrank,'new mesh positions are wrong in recalc_jacobian_gall3D.f90')
+ end if
+ if(abs(sumshape-one) > TINYVAL) then
+ call exit_MPI(myrank,'error shape functions in recalc_jacobian_gll3D.f90')
+ end if
+ if(abs(sumdershapexi) > TINYVAL) then
+ call exit_MPI(myrank,'error derivative xi shape functions in recalc_jacobian_gll3D.f90')
+ end if
+ if(abs(sumdershapeeta) > TINYVAL) then
+ call exit_MPI(myrank,'error derivative eta shape functions in recalc_jacobian_gll3D.f90')
+ end if
+ if(abs(sumdershapegamma) > TINYVAL) then
+ call exit_MPI(myrank,'error derivative gamma shape functions in recalc_jacobian_gll3D.f90')
+ end if
+
+
+ jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
+ xeta*(yxi*zgamma-ygamma*zxi) + &
+ xgamma*(yxi*zeta-yeta*zxi)
+
+ ! Check the jacobian
+ if(jacobian <= ZERO) then
+ call exit_MPI(myrank,'3D Jacobian undefined in recalc_jacobian_gll3D.f90')
+ end if
+
+ ! invert the relation (Fletcher p. 50 vol. 2)
+ xix = (yeta*zgamma-ygamma*zeta) / jacobian
+ xiy = (xgamma*zeta-xeta*zgamma) / jacobian
+ xiz = (xeta*ygamma-xgamma*yeta) / jacobian
+ etax = (ygamma*zxi-yxi*zgamma) / jacobian
+ etay = (xxi*zgamma-xgamma*zxi) / jacobian
+ etaz = (xgamma*yxi-xxi*ygamma) / jacobian
+ gammax = (yxi*zeta-yeta*zxi) / jacobian
+ gammay = (xeta*zxi-xxi*zeta) / jacobian
+ gammaz = (xxi*yeta-xeta*yxi) / jacobian
+
+
+ ! compute and store the jacobian for the solver
+ jacobian = 1. / (xix*(etay*gammaz-etaz*gammay) &
+ -xiy*(etax*gammaz-etaz*gammax) &
+ +xiz*(etax*gammay-etay*gammax))
+
+ ! resave the derivatives and the jacobian
+ ! distinguish between single and double precision for reals
+ if (ACTUALLY_STORE_ARRAYS) then
+
+ if (myrank == 0) then
+ print*,'xix before',xixstore(i,j,k,ispec),'after',xix
+ print*,'etax before',etaxstore(i,j,k,ispec),'after',etax
+ print*,'gammax before',gammaxstore(i,j,k,ispec),'after',gammax
+ end if
+
+ if(CUSTOM_REAL == SIZE_REAL) then
+ xixstore(i,j,k,ispec) = sngl(xix)
+ xiystore(i,j,k,ispec) = sngl(xiy)
+ xizstore(i,j,k,ispec) = sngl(xiz)
+ etaxstore(i,j,k,ispec) = sngl(etax)
+ etaystore(i,j,k,ispec) = sngl(etay)
+ etazstore(i,j,k,ispec) = sngl(etaz)
+ gammaxstore(i,j,k,ispec) = sngl(gammax)
+ gammaystore(i,j,k,ispec) = sngl(gammay)
+ gammazstore(i,j,k,ispec) = sngl(gammaz)
+ jacobianstore(i,j,k,ispec) = sngl(jacobian)
+ else
+ xixstore(i,j,k,ispec) = xix
+ xiystore(i,j,k,ispec) = xiy
+ xizstore(i,j,k,ispec) = xiz
+ etaxstore(i,j,k,ispec) = etax
+ etaystore(i,j,k,ispec) = etay
+ etazstore(i,j,k,ispec) = etaz
+ gammaxstore(i,j,k,ispec) = gammax
+ gammaystore(i,j,k,ispec) = gammay
+ gammazstore(i,j,k,ispec) = gammaz
+ jacobianstore(i,j,k,ispec) = jacobian
+ endif
+ end if
+ enddo
+ enddo
+ enddo
+
+ end subroutine recalc_jacobian_gll3D
+
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/combine_AVS_DX.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/combine_AVS_DX.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/combine_AVS_DX.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -117,6 +117,8 @@
! ************** PROGRAM STARTS HERE **************
+! only for old regular meshes!
+
print *
print *,'Recombining all AVS or DX files for slices'
print *
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/combine_vol_data.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/combine_vol_data.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/combine_vol_data.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -23,7 +23,7 @@
!
!=====================================================================
- program combine_paraview_data
+ program combine_paraview_data_ext_mesh
! puts the output of SPECFEM3D in ParaView format.
! see http://www.paraview.org for details
@@ -31,6 +31,8 @@
! combines the database files on several slices.
! the local database file needs to have been collected onto the frontend (copy_local_database.pl)
+! works for external, unregular meshes
+
implicit none
include 'constants.h'
@@ -130,27 +132,7 @@
! counts total number of points (all slices)
npp = 0
nee = 0
- if( USE_EXTERNAL_MESH ) then
- call combine_vol_data_count_totals_ext_mesh(num_node,node_list,indir,npp,nee,HIGH_RESOLUTION_MESH)
- else
- ! old version uses values_from_mesher.h
- nspec = NSPEC_AB
- nglob = NGLOB_AB
-
- ! total number of global points
- npp = nglob * num_node
-
- ! total number of elements
- nelement = nspec * (NGLLX-1) * (NGLLY-1) * (NGLLZ-1)
- nee = nelement * num_node
-
- allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(mask_ibool(NGLOB_AB))
- allocate(data(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(dat(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(xstore(NGLOB_AB),ystore(NGLOB_AB),zstore(NGLOB_AB))
- allocate(num_ibool(NGLOB_AB))
- endif ! USE_EXTERNAL_MESH
+ call combine_vol_data_count_totals_ext_mesh(num_node,node_list,indir,npp,nee,HIGH_RESOLUTION_MESH)
! write point and scalar information
@@ -163,24 +145,19 @@
print *, 'Reading slice ', iproc
write(prname,'(a,i6.6,a)') trim(indir)//'/proc',iproc,'_'
- if( USE_EXTERNAL_MESH ) then
- open(unit=27,file=prname(1:len_trim(prname))//'external_mesh.bin',status='old',action='read',form='unformatted')
- read(27) NSPEC_AB
- read(27) NGLOB_AB
- close(27)
- nspec = NSPEC_AB
- nglob = NGLOB_AB
+ open(unit=27,file=prname(1:len_trim(prname))//'external_mesh.bin',status='old',action='read',form='unformatted')
+ read(27) NSPEC_AB
+ read(27) NGLOB_AB
+ close(27)
+ nspec = NSPEC_AB
+ nglob = NGLOB_AB
- allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(mask_ibool(NGLOB_AB))
- allocate(data(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(dat(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(xstore(NGLOB_AB),ystore(NGLOB_AB),zstore(NGLOB_AB))
- endif
+ allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(mask_ibool(NGLOB_AB))
+ allocate(data(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(dat(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(xstore(NGLOB_AB),ystore(NGLOB_AB),zstore(NGLOB_AB))
- ! stores number of points supposed to write out
- if( .not. USE_EXTERNAL_MESH ) npoint = nglob
-
! data file
local_data_file = trim(prname) // trim(filename) // '.bin'
open(unit = 27,file = trim(local_data_file),status='old',action='read', iostat = ios,form ='unformatted')
@@ -218,20 +195,13 @@
xstore,ystore,zstore,dat,&
it,npp,prname,numpoin)
endif
-
- ! checks number of points written
- if( .not. USE_EXTERNAL_MESH ) then
- if (numpoin /= npoint) stop 'Error: number of points are not consistent'
- endif
print*,' points:',np,numpoin
! stores total number of points written
np = np + numpoin
- if( USE_EXTERNAL_MESH ) then
- deallocate(ibool,mask_ibool,data,dat,xstore,ystore,zstore)
- endif
+ deallocate(ibool,mask_ibool,data,dat,xstore,ystore,zstore)
enddo ! all slices for points
@@ -250,20 +220,16 @@
print *, 'Reading slice ', iproc
write(prname,'(a,i6.6,a)') trim(indir)//'/proc',iproc,'_'
- if( USE_EXTERNAL_MESH ) then
- open(unit=27,file=prname(1:len_trim(prname))//'external_mesh.bin',status='old',action='read',form='unformatted')
- read(27) NSPEC_AB
- read(27) NGLOB_AB
- close(27)
- nspec = NSPEC_AB
- nglob = NGLOB_AB
-
- allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(mask_ibool(NGLOB_AB))
- allocate(num_ibool(NGLOB_AB))
- else
- np = npoint * (it-1)
- endif
+ open(unit=27,file=prname(1:len_trim(prname))//'external_mesh.bin',status='old',action='read',form='unformatted')
+ read(27) NSPEC_AB
+ read(27) NGLOB_AB
+ close(27)
+ nspec = NSPEC_AB
+ nglob = NGLOB_AB
+
+ allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(mask_ibool(NGLOB_AB))
+ allocate(num_ibool(NGLOB_AB))
! ibool file
local_ibool_file = trim(prname) // 'ibool' // '.bin'
@@ -292,9 +258,7 @@
ne = ne + nelement
- if( USE_EXTERNAL_MESH ) then
- deallocate(ibool,mask_ibool,num_ibool)
- endif
+ deallocate(ibool,mask_ibool,num_ibool)
enddo ! num_node
@@ -432,44 +396,31 @@
character(len=150) :: local_file
! corner locations
- if( USE_EXTERNAL_MESH ) then
- ! reads in coordinate files
- local_file = trim(prname)//'x.bin'
- open(unit = 27,file = trim(prname)//'x.bin',status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) then
- print *,'Error opening ',trim(local_file)
- stop
- endif
- read(27) xstore
- close(27)
- local_file = trim(prname)//'y.bin'
- open(unit = 27,file = trim(prname)//'y.bin',status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) then
- print *,'Error opening ',trim(local_file)
- stop
- endif
- read(27) ystore
- close(27)
- local_file = trim(prname)//'z.bin'
- open(unit = 27,file = trim(prname)//'z.bin',status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) then
- print *,'Error opening ',trim(local_file)
- stop
- endif
- read(27) zstore
- close(27)
- else
- open(unit = 25, file = trim(prname) // 'AVS_DXpoints.txt', status = 'old', iostat = ios)
- if (ios /= 0) then
- print *,'Error opening ',trim(prname) // 'AVS_DXpoints.txt'
- stop
- endif
- read(25,*) npoint
-
- if (it == 1) then
- npp = npoint * num_node
- endif
+ ! reads in coordinate files
+ local_file = trim(prname)//'x.bin'
+ open(unit = 27,file = trim(prname)//'x.bin',status='old',action='read', iostat = ios,form ='unformatted')
+ if (ios /= 0) then
+ print *,'Error opening ',trim(local_file)
+ stop
endif
+ read(27) xstore
+ close(27)
+ local_file = trim(prname)//'y.bin'
+ open(unit = 27,file = trim(prname)//'y.bin',status='old',action='read', iostat = ios,form ='unformatted')
+ if (ios /= 0) then
+ print *,'Error opening ',trim(local_file)
+ stop
+ endif
+ read(27) ystore
+ close(27)
+ local_file = trim(prname)//'z.bin'
+ open(unit = 27,file = trim(prname)//'z.bin',status='old',action='read', iostat = ios,form ='unformatted')
+ if (ios /= 0) then
+ print *,'Error opening ',trim(local_file)
+ stop
+ endif
+ read(27) zstore
+ close(27)
! writes out total number of points
if (it == 1) then
@@ -491,13 +442,9 @@
if(.not. mask_ibool(iglob1)) then
numpoin = numpoin + 1
- if( USE_EXTERNAL_MESH ) then
- x = xstore(iglob1)
- y = ystore(iglob1)
- z = zstore(iglob1)
- else
- read(25,*) njunk, x, y, z
- endif
+ x = xstore(iglob1)
+ y = ystore(iglob1)
+ z = zstore(iglob1)
call write_real(x)
call write_real(y)
call write_real(z)
@@ -506,13 +453,9 @@
endif
if(.not. mask_ibool(iglob2)) then
numpoin = numpoin + 1
- if( USE_EXTERNAL_MESH ) then
- x = xstore(iglob2)
- y = ystore(iglob2)
- z = zstore(iglob2)
- else
- read(25,*) njunk, x, y, z
- endif
+ x = xstore(iglob2)
+ y = ystore(iglob2)
+ z = zstore(iglob2)
call write_real(x)
call write_real(y)
call write_real(z)
@@ -521,13 +464,9 @@
endif
if(.not. mask_ibool(iglob3)) then
numpoin = numpoin + 1
- if( USE_EXTERNAL_MESH ) then
- x = xstore(iglob3)
- y = ystore(iglob3)
- z = zstore(iglob3)
- else
- read(25,*) njunk, x, y, z
- endif
+ x = xstore(iglob3)
+ y = ystore(iglob3)
+ z = zstore(iglob3)
call write_real(x)
call write_real(y)
call write_real(z)
@@ -536,13 +475,9 @@
endif
if(.not. mask_ibool(iglob4)) then
numpoin = numpoin + 1
- if( USE_EXTERNAL_MESH ) then
- x = xstore(iglob4)
- y = ystore(iglob4)
- z = zstore(iglob4)
- else
- read(25,*) njunk, x, y, z
- endif
+ x = xstore(iglob4)
+ y = ystore(iglob4)
+ z = zstore(iglob4)
call write_real(x)
call write_real(y)
call write_real(z)
@@ -551,13 +486,9 @@
endif
if(.not. mask_ibool(iglob5)) then
numpoin = numpoin + 1
- if( USE_EXTERNAL_MESH ) then
- x = xstore(iglob5)
- y = ystore(iglob5)
- z = zstore(iglob5)
- else
- read(25,*) njunk, x, y, z
- endif
+ x = xstore(iglob5)
+ y = ystore(iglob5)
+ z = zstore(iglob5)
call write_real(x)
call write_real(y)
call write_real(z)
@@ -566,13 +497,9 @@
endif
if(.not. mask_ibool(iglob6)) then
numpoin = numpoin + 1
- if( USE_EXTERNAL_MESH ) then
- x = xstore(iglob6)
- y = ystore(iglob6)
- z = zstore(iglob6)
- else
- read(25,*) njunk, x, y, z
- endif
+ x = xstore(iglob6)
+ y = ystore(iglob6)
+ z = zstore(iglob6)
call write_real(x)
call write_real(y)
call write_real(z)
@@ -581,13 +508,9 @@
endif
if(.not. mask_ibool(iglob7)) then
numpoin = numpoin + 1
- if( USE_EXTERNAL_MESH ) then
- x = xstore(iglob7)
- y = ystore(iglob7)
- z = zstore(iglob7)
- else
- read(25,*) njunk, x, y, z
- endif
+ x = xstore(iglob7)
+ y = ystore(iglob7)
+ z = zstore(iglob7)
call write_real(x)
call write_real(y)
call write_real(z)
@@ -596,13 +519,9 @@
endif
if(.not. mask_ibool(iglob8)) then
numpoin = numpoin + 1
- if( USE_EXTERNAL_MESH ) then
- x = xstore(iglob8)
- y = ystore(iglob8)
- z = zstore(iglob8)
- else
- read(25,*) njunk, x, y, z
- endif
+ x = xstore(iglob8)
+ y = ystore(iglob8)
+ z = zstore(iglob8)
call write_real(x)
call write_real(y)
call write_real(z)
@@ -610,9 +529,7 @@
mask_ibool(iglob8) = .true.
endif
enddo ! ispec
-
- if( .not. USE_EXTERNAL_MESH ) close(25)
-
+
end subroutine combine_vol_data_write_corners
@@ -723,134 +640,95 @@
character(len=150) :: local_element_file
- if( USE_EXTERNAL_MESH ) then
+ ! outputs total number of elements for all slices
+ if (it == 1) then
+ call write_integer(nee)
+ end if
- ! outputs total number of elements for all slices
- if (it == 1) then
- call write_integer(nee)
- end if
+ num_ibool(:) = 0
+ mask_ibool(:) = .false.
+ numpoin = 0
+
+ do ispec=1,nspec
+ ! gets corner indices
+ iglob1=ibool(1,1,1,ispec)
+ iglob2=ibool(NGLLX,1,1,ispec)
+ iglob3=ibool(NGLLX,NGLLY,1,ispec)
+ iglob4=ibool(1,NGLLY,1,ispec)
+ iglob5=ibool(1,1,NGLLZ,ispec)
+ iglob6=ibool(NGLLX,1,NGLLZ,ispec)
+ iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ iglob8=ibool(1,NGLLY,NGLLZ,ispec)
- num_ibool(:) = 0
- mask_ibool(:) = .false.
- numpoin = 0
+ ! sets increasing numbering
+ if(.not. mask_ibool(iglob1)) then
+ numpoin = numpoin + 1
+ num_ibool(iglob1) = numpoin
+ mask_ibool(iglob1) = .true.
+ endif
+ if(.not. mask_ibool(iglob2)) then
+ numpoin = numpoin + 1
+ num_ibool(iglob2) = numpoin
+ mask_ibool(iglob2) = .true.
+ endif
+ if(.not. mask_ibool(iglob3)) then
+ numpoin = numpoin + 1
+ num_ibool(iglob3) = numpoin
+ mask_ibool(iglob3) = .true.
+ endif
+ if(.not. mask_ibool(iglob4)) then
+ numpoin = numpoin + 1
+ num_ibool(iglob4) = numpoin
+ mask_ibool(iglob4) = .true.
+ endif
+ if(.not. mask_ibool(iglob5)) then
+ numpoin = numpoin + 1
+ num_ibool(iglob5) = numpoin
+ mask_ibool(iglob5) = .true.
+ endif
+ if(.not. mask_ibool(iglob6)) then
+ numpoin = numpoin + 1
+ num_ibool(iglob6) = numpoin
+ mask_ibool(iglob6) = .true.
+ endif
+ if(.not. mask_ibool(iglob7)) then
+ numpoin = numpoin + 1
+ num_ibool(iglob7) = numpoin
+ mask_ibool(iglob7) = .true.
+ endif
+ if(.not. mask_ibool(iglob8)) then
+ numpoin = numpoin + 1
+ num_ibool(iglob8) = numpoin
+ mask_ibool(iglob8) = .true.
+ endif
+
+ ! outputs corner indices (starting with 0 )
+ n1 = num_ibool(iglob1) -1 + np
+ n2 = num_ibool(iglob2) -1 + np
+ n3 = num_ibool(iglob3) -1 + np
+ n4 = num_ibool(iglob4) -1 + np
+ n5 = num_ibool(iglob5) -1 + np
+ n6 = num_ibool(iglob6) -1 + np
+ n7 = num_ibool(iglob7) -1 + np
+ n8 = num_ibool(iglob8) -1 + np
- do ispec=1,nspec
- ! gets corner indices
- iglob1=ibool(1,1,1,ispec)
- iglob2=ibool(NGLLX,1,1,ispec)
- iglob3=ibool(NGLLX,NGLLY,1,ispec)
- iglob4=ibool(1,NGLLY,1,ispec)
- iglob5=ibool(1,1,NGLLZ,ispec)
- iglob6=ibool(NGLLX,1,NGLLZ,ispec)
- iglob7=ibool(NGLLX,NGLLY,NGLLZ,ispec)
- iglob8=ibool(1,NGLLY,NGLLZ,ispec)
+ call write_integer(n1)
+ call write_integer(n2)
+ call write_integer(n3)
+ call write_integer(n4)
+ call write_integer(n5)
+ call write_integer(n6)
+ call write_integer(n7)
+ call write_integer(n8)
- ! sets increasing numbering
- if(.not. mask_ibool(iglob1)) then
- numpoin = numpoin + 1
- num_ibool(iglob1) = numpoin
- mask_ibool(iglob1) = .true.
- endif
- if(.not. mask_ibool(iglob2)) then
- numpoin = numpoin + 1
- num_ibool(iglob2) = numpoin
- mask_ibool(iglob2) = .true.
- endif
- if(.not. mask_ibool(iglob3)) then
- numpoin = numpoin + 1
- num_ibool(iglob3) = numpoin
- mask_ibool(iglob3) = .true.
- endif
- if(.not. mask_ibool(iglob4)) then
- numpoin = numpoin + 1
- num_ibool(iglob4) = numpoin
- mask_ibool(iglob4) = .true.
- endif
- if(.not. mask_ibool(iglob5)) then
- numpoin = numpoin + 1
- num_ibool(iglob5) = numpoin
- mask_ibool(iglob5) = .true.
- endif
- if(.not. mask_ibool(iglob6)) then
- numpoin = numpoin + 1
- num_ibool(iglob6) = numpoin
- mask_ibool(iglob6) = .true.
- endif
- if(.not. mask_ibool(iglob7)) then
- numpoin = numpoin + 1
- num_ibool(iglob7) = numpoin
- mask_ibool(iglob7) = .true.
- endif
- if(.not. mask_ibool(iglob8)) then
- numpoin = numpoin + 1
- num_ibool(iglob8) = numpoin
- mask_ibool(iglob8) = .true.
- endif
-
- ! outputs corner indices (starting with 0 )
- n1 = num_ibool(iglob1) -1 + np
- n2 = num_ibool(iglob2) -1 + np
- n3 = num_ibool(iglob3) -1 + np
- n4 = num_ibool(iglob4) -1 + np
- n5 = num_ibool(iglob5) -1 + np
- n6 = num_ibool(iglob6) -1 + np
- n7 = num_ibool(iglob7) -1 + np
- n8 = num_ibool(iglob8) -1 + np
-
- call write_integer(n1)
- call write_integer(n2)
- call write_integer(n3)
- call write_integer(n4)
- call write_integer(n5)
- call write_integer(n6)
- call write_integer(n7)
- call write_integer(n8)
+ enddo
- enddo
-
- ! elements written
- nelement = nspec
+ ! elements written
+ nelement = nspec
+
+ ! updates points written
+ np = np + numpoin
- ! updates points written
- np = np + numpoin
-
- else
- local_element_file = trim(prname) // 'AVS_DXelements.txt'
- open(unit = 26, file = trim(local_element_file), status = 'old', iostat = ios)
- if (ios /= 0) then
- print *,'Error opening ',trim(local_element_file)
- stop
- endif
- print *, trim(local_element_file)
-
- read(26, *) nelement
- if (it == 1) then
- nee = nelement * num_node
- call write_integer(nee)
- end if
-
- do i = 1, nelement
- read(26,*) njunk, njunk2, n1, n2, n3, n4, n5, n6, n7, n8
- n1 = n1+np-1
- n2 = n2+np-1
- n3 = n3+np-1
- n4 = n4+np-1
- n5 = n5+np-1
- n6 = n6+np-1
- n7 = n7+np-1
- n8 = n8+np-1
- call write_integer(n1)
- call write_integer(n2)
- call write_integer(n3)
- call write_integer(n4)
- call write_integer(n5)
- call write_integer(n6)
- call write_integer(n7)
- call write_integer(n8)
- enddo
- close(26)
- endif
-
end subroutine combine_vol_data_write_corner_elements
@@ -938,8 +816,6 @@
nelement = nspec * (NGLLX-1) * (NGLLY-1) * (NGLLZ-1)
! updates points written
- if( USE_EXTERNAL_MESH ) then
- np = np + numpoin
- endif
+ np = np + numpoin
end subroutine combine_vol_data_write_GLL_elements
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_with_Deville.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_with_Deville.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/compute_forces_with_Deville.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -23,20 +23,21 @@
!
!=====================================================================
-subroutine compute_forces_with_Deville(NSPEC_AB,NGLOB_AB,ATTENUATION,displ,accel, &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool,ispec_is_inner,phase_is_inner, &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,xi_source,eta_source,gamma_source,nu_source, &
- hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, & !pll
- one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
- epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz,iflag_attenuation_store, &
- ABSORBING_CONDITIONS, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext,&
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom, &
- nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
- veloc,rho_vp,rho_vs,jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom, &
- normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom)
+subroutine compute_forces_with_Deville(phase_is_inner,NSPEC_AB,NGLOB_AB,ATTENUATION,displ,accel, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappastore,mustore,jacobian,ibool,ispec_is_inner, &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source, &
+ xi_source,eta_source,gamma_source,nu_source, &
+ hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
+ one_minus_sum_beta,factor_common,alphaval,betaval,gammaval, &
+ NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz,iflag_attenuation_store, &
+ ABSORBING_CONDITIONS, &
+ absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
+ absorbing_boundary_ijk,absorbing_boundary_ispec, &
+ num_absorbing_boundary_faces, &
+ veloc,rho_vp,rho_vs)
implicit none
@@ -62,9 +63,6 @@
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc, &
- newtempx1,newtempx2,newtempx3,newtempy1,newtempy2,newtempy3,newtempz1,newtempz2,newtempz3
-
! communication overlap
logical, dimension(NSPEC_AB) :: ispec_is_inner
logical :: phase_is_inner
@@ -78,25 +76,150 @@
double precision :: dt
real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrays
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
- tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+! integer :: isource
+ double precision :: t0
+ double precision :: stf
- integer ispec,iglob
- integer i,j,k
+! memory variables and standard linear solids for attenuation
+ logical :: ATTENUATION
+ integer :: NSPEC_ATTENUATION_AB
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: iflag_attenuation_store
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION) :: one_minus_sum_beta
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: factor_common, alphaval,betaval,gammaval
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB,N_SLS) :: &
+ R_xx,R_yy,R_xy,R_xz,R_yz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB) :: &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
+
+! Stacey conditions
+ logical :: ABSORBING_CONDITIONS
+! integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,nspec2D_top
+! integer :: NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext
+! integer, dimension(nspec2D_xmin) :: ibelm_xmin
+! integer, dimension(nspec2D_xmax) :: ibelm_xmax
+! integer, dimension(nspec2D_ymin) :: ibelm_ymin
+! integer, dimension(nspec2D_ymax) :: ibelm_ymax
+! integer, dimension(nspec2D_bottom) :: ibelm_bottom
+! integer, dimension(nspec2D_top) :: ibelm_top
+! integer :: ibelm_gll_xmin(3,NGLLY,NGLLZ,nspec2D_xmin),ibelm_gll_xmax(3,NGLLY,NGLLZ,nspec2D_xmax), &
+! ibelm_gll_ymin(3,NGLLX,NGLLZ,nspec2D_ymin),ibelm_gll_ymax(3,NGLLX,NGLLZ,nspec2D_ymax), &
+! ibelm_gll_bottom(3,NGLLY,NGLLY,nspec2D_bottom),ibelm_gll_top(3,NGLLY,NGLLY,nspec2D_top)
+! integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_ext) :: nimin,nimax,nkmin_eta
+! integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_ext) :: njmin,njmax,nkmin_xi
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
- real(kind=CUSTOM_REAL) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
- real(kind=CUSTOM_REAL) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
- real(kind=CUSTOM_REAL) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: veloc
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vp,rho_vs
+
+! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmin) :: jacobian2D_xmin
+! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmax) :: jacobian2D_xmax
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymin) :: jacobian2D_ymin
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymax) :: jacobian2D_ymax
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM) :: jacobian2D_bottom
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_top) :: jacobian2D_top
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmin) :: normal_xmin
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmax) :: normal_xmax
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_ymin) :: normal_ymin
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_ymax) :: normal_ymax
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM) :: normal_bottom
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_top) :: normal_top
- real(kind=CUSTOM_REAL) fac1,fac2,fac3
+ integer :: num_absorbing_boundary_faces
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_normal
+ real(kind=CUSTOM_REAL), dimension(NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_jacobian2D
+ integer, dimension(3,NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_ijk
+ integer, dimension(num_absorbing_boundary_faces) :: absorbing_boundary_ispec
- real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
- real(kind=CUSTOM_REAL) kappal
+! computes elastic stiffness term
+ call compute_forces_add_elastic_term(NSPEC_AB,NGLOB_AB,ATTENUATION,displ,accel, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappastore,mustore,jacobian,ibool,ispec_is_inner,phase_is_inner, &
+ one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,&
+ NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz,iflag_attenuation_store )
+
+! adds absorbing boundary term to acceleration (Stacey conditions)
+ if(ABSORBING_CONDITIONS) then
+ call compute_forces_add_elastic_absorbing_boundaries(NSPEC_AB,NGLOB_AB,accel, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
+ absorbing_boundary_ijk,absorbing_boundary_ispec, &
+ num_absorbing_boundary_faces, &
+ veloc,rho_vp,rho_vs)
+ endif
+
+! adds source term
+ call compute_forces_add_source_term( NSPEC_AB,NGLOB_AB,accel, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
+ xi_source,eta_source,gamma_source,nu_source, &
+ hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays )
+
+end subroutine compute_forces_with_Deville
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+! elastic term
+
+subroutine compute_forces_add_elastic_term(NSPEC_AB,NGLOB_AB,ATTENUATION,displ,accel, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappastore,mustore,jacobian,ibool,ispec_is_inner,phase_is_inner, &
+ one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,&
+ NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz,iflag_attenuation_store )
+
+ implicit none
+
+ include "constants.h"
+! include values created by the mesher
+! include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! displacement and acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: displ,accel
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
+ kappastore,mustore,jacobian
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+! memory variables and standard linear solids for attenuation
+ logical :: ATTENUATION
+ integer :: NSPEC_ATTENUATION_AB
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: iflag_attenuation_store
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION) :: one_minus_sum_beta
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: factor_common, alphaval,betaval,gammaval
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB,N_SLS) :: &
+ R_xx,R_yy,R_xy,R_xz,R_yz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB) :: &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
+
+! local parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dummyx_loc,dummyy_loc,dummyz_loc, &
+ newtempx1,newtempx2,newtempx3,newtempy1,newtempy2,newtempy3,newtempz1,newtempz2,newtempz3
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+
! manually inline the calls to the Deville et al. (2002) routines
real(kind=4), dimension(NGLLX,m2) :: B1_m1_m2_5points,B2_m1_m2_5points,B3_m1_m2_5points
real(kind=4), dimension(m1,m2) :: C1_m1_m2_5points,C2_m1_m2_5points,C3_m1_m2_5points
@@ -126,605 +249,851 @@
equivalence(newtempy3,E2_mxm_m2_m1_5points)
equivalence(newtempz3,E3_mxm_m2_m1_5points)
- integer :: isource
- double precision :: t0,f0
-
- double precision :: stf
- real(kind=CUSTOM_REAL) stf_used
- double precision, external :: comp_source_time_function
-
-! memory variables and standard linear solids for attenuation
- integer i_SLS
- integer iselected
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_xx_loc, &
+ epsilondev_yy_loc, epsilondev_xy_loc, epsilondev_xz_loc, epsilondev_yz_loc
real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
real(kind=CUSTOM_REAL) factor_loc,alphaval_loc,betaval_loc,gammaval_loc,Sn,Snp1
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: epsilondev_xx_loc, &
- epsilondev_yy_loc, epsilondev_xy_loc, epsilondev_xz_loc, epsilondev_yz_loc
real(kind=CUSTOM_REAL) epsilon_trace_over_3
-
- logical :: ATTENUATION
- integer :: NSPEC_ATTENUATION_AB
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: iflag_attenuation_store
- real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION) :: one_minus_sum_beta
- real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: factor_common, alphaval,betaval,gammaval
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB,N_SLS) :: &
- R_xx,R_yy,R_xy,R_xz,R_yz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB) :: &
- epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
-
-! Stacey conditions
- logical :: ABSORBING_CONDITIONS
- integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM
- integer :: NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext
- integer, dimension(nspec2D_xmin) :: ibelm_xmin
- integer, dimension(nspec2D_xmax) :: ibelm_xmax
- integer, dimension(nspec2D_ymin) :: ibelm_ymin
- integer, dimension(nspec2D_ymax) :: ibelm_ymax
- integer, dimension(nspec2D_bottom) :: ibelm_bottom
- integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_ext) :: nimin,nimax,nkmin_eta
- integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_ext) :: njmin,njmax,nkmin_xi
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: veloc
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vp,rho_vs
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmin) :: jacobian2D_xmin
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmax) :: jacobian2D_xmax
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymin) :: jacobian2D_ymin
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymax) :: jacobian2D_ymax
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM) :: jacobian2D_bottom
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmin) :: normal_xmin
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmax) :: normal_xmax
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_ymin) :: normal_ymin
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_ymax) :: normal_ymax
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM) :: normal_bottom
- integer :: ispec2D
- real(kind=CUSTOM_REAL) vx,vy,vz,nx,ny,nz,tx,ty,tz,vn,weight
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
+ real(kind=CUSTOM_REAL) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
+ real(kind=CUSTOM_REAL) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
+ real(kind=CUSTOM_REAL) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
+
+ real(kind=CUSTOM_REAL) fac1,fac2,fac3
+
+ real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
+ real(kind=CUSTOM_REAL) kappal
+
+ integer i_SLS,iselected
+
+ integer ispec,iglob
+ integer i,j,k
+
+! loops over all elements
do ispec = 1,NSPEC_AB
- if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
- dummyx_loc(i,j,k) = displ(1,iglob)
- dummyy_loc(i,j,k) = displ(2,iglob)
- dummyz_loc(i,j,k) = displ(3,iglob)
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ dummyx_loc(i,j,k) = displ(1,iglob)
+ dummyy_loc(i,j,k) = displ(2,iglob)
+ dummyz_loc(i,j,k) = displ(3,iglob)
+ enddo
enddo
enddo
- enddo
-! subroutines adapted from Deville, Fischer and Mund, High-order methods
-! for incompressible fluid flow, Cambridge University Press (2002),
-! pages 386 and 389 and Figure 8.3.1
-! call mxm_m1_m2_5points(hprime_xx,dummyx_loc,dummyy_loc,dummyz_loc,tempx1,tempy1,tempz1)
- do j=1,m2
- do i=1,m1
- C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B1_m1_m2_5points(5,j)
+ ! subroutines adapted from Deville, Fischer and Mund, High-order methods
+ ! for incompressible fluid flow, Cambridge University Press (2002),
+ ! pages 386 and 389 and Figure 8.3.1
+ ! call mxm_m1_m2_5points(hprime_xx,dummyx_loc,dummyy_loc,dummyz_loc,tempx1,tempy1,tempz1)
+ do j=1,m2
+ do i=1,m1
+ C1_m1_m2_5points(i,j) = hprime_xx(i,1)*B1_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B1_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B1_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B1_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B1_m1_m2_5points(5,j)
- C2_m1_m2_5points(i,j) = hprime_xx(i,1)*B2_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B2_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B2_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B2_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B2_m1_m2_5points(5,j)
+ C2_m1_m2_5points(i,j) = hprime_xx(i,1)*B2_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B2_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B2_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B2_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B2_m1_m2_5points(5,j)
- C3_m1_m2_5points(i,j) = hprime_xx(i,1)*B3_m1_m2_5points(1,j) + &
- hprime_xx(i,2)*B3_m1_m2_5points(2,j) + &
- hprime_xx(i,3)*B3_m1_m2_5points(3,j) + &
- hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
- hprime_xx(i,5)*B3_m1_m2_5points(5,j)
+ C3_m1_m2_5points(i,j) = hprime_xx(i,1)*B3_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*B3_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*B3_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*B3_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*B3_m1_m2_5points(5,j)
+ enddo
enddo
- enddo
-! call mxm_m1_m1_5points(dummyx_loc(1,1,k),dummyy_loc(1,1,k),dummyz_loc(1,1,k), &
-! hprime_xxT,tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k))
- do j=1,m1
- do i=1,m1
-! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
- do k = 1,NGLLX
- tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyx_loc(i,5,k)*hprime_xxT(5,j)
+ ! call mxm_m1_m1_5points(dummyx_loc(1,1,k),dummyy_loc(1,1,k),dummyz_loc(1,1,k), &
+ ! hprime_xxT,tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k))
+ do j=1,m1
+ do i=1,m1
+ ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
+ do k = 1,NGLLX
+ tempx2(i,j,k) = dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyx_loc(i,5,k)*hprime_xxT(5,j)
- tempy2(i,j,k) = dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyy_loc(i,5,k)*hprime_xxT(5,j)
+ tempy2(i,j,k) = dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyy_loc(i,5,k)*hprime_xxT(5,j)
- tempz2(i,j,k) = dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
- dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
- dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
- dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
- dummyz_loc(i,5,k)*hprime_xxT(5,j)
+ tempz2(i,j,k) = dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
+ dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
+ dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
+ dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
+ dummyz_loc(i,5,k)*hprime_xxT(5,j)
+ enddo
enddo
enddo
- enddo
-! call mxm_m2_m1_5points(dummyx_loc,dummyy_loc,dummyz_loc,tempx3,tempy3,tempz3)
- do j=1,m1
- do i=1,m2
- C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ ! call mxm_m2_m1_5points(dummyx_loc,dummyy_loc,dummyz_loc,tempx3,tempy3,tempz3)
+ do j=1,m1
+ do i=1,m2
+ C1_mxm_m2_m1_5points(i,j) = A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
- C2_mxm_m2_m1_5points(i,j) = A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ C2_mxm_m2_m1_5points(i,j) = A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
- C3_mxm_m2_m1_5points(i,j) = A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
- A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
- A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
- A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
- A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ C3_mxm_m2_m1_5points(i,j) = A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ enddo
enddo
- enddo
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
-! get derivatives of ux, uy and uz with respect to x, y and z
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
- jacobianl = jacobian(i,j,k,ispec)
+ ! get derivatives of ux, uy and uz with respect to x, y and z
+ xixl = xix(i,j,k,ispec)
+ xiyl = xiy(i,j,k,ispec)
+ xizl = xiz(i,j,k,ispec)
+ etaxl = etax(i,j,k,ispec)
+ etayl = etay(i,j,k,ispec)
+ etazl = etaz(i,j,k,ispec)
+ gammaxl = gammax(i,j,k,ispec)
+ gammayl = gammay(i,j,k,ispec)
+ gammazl = gammaz(i,j,k,ispec)
+ jacobianl = jacobian(i,j,k,ispec)
- duxdxl = xixl*tempx1(i,j,k) + etaxl*tempx2(i,j,k) + gammaxl*tempx3(i,j,k)
- duxdyl = xiyl*tempx1(i,j,k) + etayl*tempx2(i,j,k) + gammayl*tempx3(i,j,k)
- duxdzl = xizl*tempx1(i,j,k) + etazl*tempx2(i,j,k) + gammazl*tempx3(i,j,k)
+ duxdxl = xixl*tempx1(i,j,k) + etaxl*tempx2(i,j,k) + gammaxl*tempx3(i,j,k)
+ duxdyl = xiyl*tempx1(i,j,k) + etayl*tempx2(i,j,k) + gammayl*tempx3(i,j,k)
+ duxdzl = xizl*tempx1(i,j,k) + etazl*tempx2(i,j,k) + gammazl*tempx3(i,j,k)
- duydxl = xixl*tempy1(i,j,k) + etaxl*tempy2(i,j,k) + gammaxl*tempy3(i,j,k)
- duydyl = xiyl*tempy1(i,j,k) + etayl*tempy2(i,j,k) + gammayl*tempy3(i,j,k)
- duydzl = xizl*tempy1(i,j,k) + etazl*tempy2(i,j,k) + gammazl*tempy3(i,j,k)
+ duydxl = xixl*tempy1(i,j,k) + etaxl*tempy2(i,j,k) + gammaxl*tempy3(i,j,k)
+ duydyl = xiyl*tempy1(i,j,k) + etayl*tempy2(i,j,k) + gammayl*tempy3(i,j,k)
+ duydzl = xizl*tempy1(i,j,k) + etazl*tempy2(i,j,k) + gammazl*tempy3(i,j,k)
- duzdxl = xixl*tempz1(i,j,k) + etaxl*tempz2(i,j,k) + gammaxl*tempz3(i,j,k)
- duzdyl = xiyl*tempz1(i,j,k) + etayl*tempz2(i,j,k) + gammayl*tempz3(i,j,k)
- duzdzl = xizl*tempz1(i,j,k) + etazl*tempz2(i,j,k) + gammazl*tempz3(i,j,k)
+ duzdxl = xixl*tempz1(i,j,k) + etaxl*tempz2(i,j,k) + gammaxl*tempz3(i,j,k)
+ duzdyl = xiyl*tempz1(i,j,k) + etayl*tempz2(i,j,k) + gammayl*tempz3(i,j,k)
+ duzdzl = xizl*tempz1(i,j,k) + etazl*tempz2(i,j,k) + gammazl*tempz3(i,j,k)
-! precompute some sums to save CPU time
- duxdxl_plus_duydyl = duxdxl + duydyl
- duxdxl_plus_duzdzl = duxdxl + duzdzl
- duydyl_plus_duzdzl = duydyl + duzdzl
- duxdyl_plus_duydxl = duxdyl + duydxl
- duzdxl_plus_duxdzl = duzdxl + duxdzl
- duzdyl_plus_duydzl = duzdyl + duydzl
+ ! precompute some sums to save CPU time
+ duxdxl_plus_duydyl = duxdxl + duydyl
+ duxdxl_plus_duzdzl = duxdxl + duzdzl
+ duydyl_plus_duzdzl = duydyl + duzdzl
+ duxdyl_plus_duydxl = duxdyl + duydxl
+ duzdxl_plus_duxdzl = duzdxl + duxdzl
+ duzdyl_plus_duydzl = duzdyl + duydzl
- kappal = kappastore(i,j,k,ispec)
- mul = mustore(i,j,k,ispec)
-
- if(ATTENUATION) then
- ! compute deviatoric strain
- epsilon_trace_over_3 = ONE_THIRD * (duxdxl + duydyl + duzdzl)
- epsilondev_xx_loc(i,j,k) = duxdxl - epsilon_trace_over_3
- epsilondev_yy_loc(i,j,k) = duydyl - epsilon_trace_over_3
- epsilondev_xy_loc(i,j,k) = 0.5 * duxdyl_plus_duydxl
- epsilondev_xz_loc(i,j,k) = 0.5 * duzdxl_plus_duxdzl
- epsilondev_yz_loc(i,j,k) = 0.5 * duzdyl_plus_duydzl
-
- ! use unrelaxed parameters if attenuation
- mul = mul * one_minus_sum_beta(iflag_attenuation_store(i,j,k,ispec))
- endif
+ kappal = kappastore(i,j,k,ispec)
+ mul = mustore(i,j,k,ispec)
+
+ if(ATTENUATION) then
+ ! compute deviatoric strain
+ epsilon_trace_over_3 = ONE_THIRD * (duxdxl + duydyl + duzdzl)
+ epsilondev_xx_loc(i,j,k) = duxdxl - epsilon_trace_over_3
+ epsilondev_yy_loc(i,j,k) = duydyl - epsilon_trace_over_3
+ epsilondev_xy_loc(i,j,k) = 0.5 * duxdyl_plus_duydxl
+ epsilondev_xz_loc(i,j,k) = 0.5 * duzdxl_plus_duxdzl
+ epsilondev_yz_loc(i,j,k) = 0.5 * duzdyl_plus_duydzl
+
+ ! use unrelaxed parameters if attenuation
+ mul = mul * one_minus_sum_beta(iflag_attenuation_store(i,j,k,ispec))
+ endif
- lambdalplus2mul = kappal + FOUR_THIRDS * mul
- lambdal = lambdalplus2mul - 2.*mul
+ lambdalplus2mul = kappal + FOUR_THIRDS * mul
+ lambdal = lambdalplus2mul - 2.*mul
-! compute stress sigma
- sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
- sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
- sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
+ ! compute stress sigma
+ sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
+ sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
+ sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
- sigma_xy = mul*duxdyl_plus_duydxl
- sigma_xz = mul*duzdxl_plus_duxdzl
- sigma_yz = mul*duzdyl_plus_duydzl
+ sigma_xy = mul*duxdyl_plus_duydxl
+ sigma_xz = mul*duzdxl_plus_duxdzl
+ sigma_yz = mul*duzdyl_plus_duydzl
- ! subtract memory variables if attenuation
- if(ATTENUATION) then
- do i_sls = 1,N_SLS
- R_xx_val = R_xx(i,j,k,ispec,i_sls)
- R_yy_val = R_yy(i,j,k,ispec,i_sls)
- sigma_xx = sigma_xx - R_xx_val
- sigma_yy = sigma_yy - R_yy_val
- sigma_zz = sigma_zz + R_xx_val + R_yy_val
- sigma_xy = sigma_xy - R_xy(i,j,k,ispec,i_sls)
- sigma_xz = sigma_xz - R_xz(i,j,k,ispec,i_sls)
- sigma_yz = sigma_yz - R_yz(i,j,k,ispec,i_sls)
- enddo
- endif
-
+ ! subtract memory variables if attenuation
+ if(ATTENUATION) then
+ do i_sls = 1,N_SLS
+ R_xx_val = R_xx(i,j,k,ispec,i_sls)
+ R_yy_val = R_yy(i,j,k,ispec,i_sls)
+ sigma_xx = sigma_xx - R_xx_val
+ sigma_yy = sigma_yy - R_yy_val
+ sigma_zz = sigma_zz + R_xx_val + R_yy_val
+ sigma_xy = sigma_xy - R_xy(i,j,k,ispec,i_sls)
+ sigma_xz = sigma_xz - R_xz(i,j,k,ispec,i_sls)
+ sigma_yz = sigma_yz - R_yz(i,j,k,ispec,i_sls)
+ enddo
+ endif
+
-! form dot product with test vector, symmetric form
- tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
- tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
- tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
+ ! form dot product with test vector, symmetric form
+ tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_xy*xiyl + sigma_xz*xizl)
+ tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_yz*xizl)
+ tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
- tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
- tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
- tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
+ tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_xy*etayl + sigma_xz*etazl)
+ tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_yz*etazl)
+ tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
- tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
- tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
- tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+ tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_xy*gammayl + sigma_xz*gammazl)
+ tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_yz*gammazl)
+ tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
+ enddo
enddo
enddo
- enddo
-! subroutines adapted from Deville, Fischer and Mund, High-order methods
-! for incompressible fluid flow, Cambridge University Press (2002),
-! pages 386 and 389 and Figure 8.3.1
-! call mxm_m1_m2_5points(hprimewgll_xxT,tempx1,tempy1,tempz1,newtempx1,newtempy1,newtempz1)
- do j=1,m2
- do i=1,m1
- E1_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C1_m1_m2_5points(1,j) + &
- hprimewgll_xxT(i,2)*C1_m1_m2_5points(2,j) + &
- hprimewgll_xxT(i,3)*C1_m1_m2_5points(3,j) + &
- hprimewgll_xxT(i,4)*C1_m1_m2_5points(4,j) + &
- hprimewgll_xxT(i,5)*C1_m1_m2_5points(5,j)
+ ! subroutines adapted from Deville, Fischer and Mund, High-order methods
+ ! for incompressible fluid flow, Cambridge University Press (2002),
+ ! pages 386 and 389 and Figure 8.3.1
+ ! call mxm_m1_m2_5points(hprimewgll_xxT,tempx1,tempy1,tempz1,newtempx1,newtempy1,newtempz1)
+ do j=1,m2
+ do i=1,m1
+ E1_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C1_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*C1_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*C1_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*C1_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*C1_m1_m2_5points(5,j)
- E2_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C2_m1_m2_5points(1,j) + &
- hprimewgll_xxT(i,2)*C2_m1_m2_5points(2,j) + &
- hprimewgll_xxT(i,3)*C2_m1_m2_5points(3,j) + &
- hprimewgll_xxT(i,4)*C2_m1_m2_5points(4,j) + &
- hprimewgll_xxT(i,5)*C2_m1_m2_5points(5,j)
+ E2_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C2_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*C2_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*C2_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*C2_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*C2_m1_m2_5points(5,j)
- E3_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C3_m1_m2_5points(1,j) + &
- hprimewgll_xxT(i,2)*C3_m1_m2_5points(2,j) + &
- hprimewgll_xxT(i,3)*C3_m1_m2_5points(3,j) + &
- hprimewgll_xxT(i,4)*C3_m1_m2_5points(4,j) + &
- hprimewgll_xxT(i,5)*C3_m1_m2_5points(5,j)
+ E3_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*C3_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*C3_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*C3_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*C3_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*C3_m1_m2_5points(5,j)
+ enddo
enddo
- enddo
-! call mxm_m1_m1_5points(tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k), &
-! hprimewgll_xx,newtempx2(1,1,k),newtempy2(1,1,k),newtempz2(1,1,k))
- do i=1,m1
- do j=1,m1
-! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
- do k = 1,NGLLX
- newtempx2(i,j,k) = tempx2(i,1,k)*hprimewgll_xx(1,j) + &
- tempx2(i,2,k)*hprimewgll_xx(2,j) + &
- tempx2(i,3,k)*hprimewgll_xx(3,j) + &
- tempx2(i,4,k)*hprimewgll_xx(4,j) + &
- tempx2(i,5,k)*hprimewgll_xx(5,j)
+ ! call mxm_m1_m1_5points(tempx2(1,1,k),tempy2(1,1,k),tempz2(1,1,k), &
+ ! hprimewgll_xx,newtempx2(1,1,k),newtempy2(1,1,k),newtempz2(1,1,k))
+ do i=1,m1
+ do j=1,m1
+ ! for efficiency it is better to leave this loop on k inside, it leads to slightly faster code
+ do k = 1,NGLLX
+ newtempx2(i,j,k) = tempx2(i,1,k)*hprimewgll_xx(1,j) + &
+ tempx2(i,2,k)*hprimewgll_xx(2,j) + &
+ tempx2(i,3,k)*hprimewgll_xx(3,j) + &
+ tempx2(i,4,k)*hprimewgll_xx(4,j) + &
+ tempx2(i,5,k)*hprimewgll_xx(5,j)
- newtempy2(i,j,k) = tempy2(i,1,k)*hprimewgll_xx(1,j) + &
- tempy2(i,2,k)*hprimewgll_xx(2,j) + &
- tempy2(i,3,k)*hprimewgll_xx(3,j) + &
- tempy2(i,4,k)*hprimewgll_xx(4,j) + &
- tempy2(i,5,k)*hprimewgll_xx(5,j)
+ newtempy2(i,j,k) = tempy2(i,1,k)*hprimewgll_xx(1,j) + &
+ tempy2(i,2,k)*hprimewgll_xx(2,j) + &
+ tempy2(i,3,k)*hprimewgll_xx(3,j) + &
+ tempy2(i,4,k)*hprimewgll_xx(4,j) + &
+ tempy2(i,5,k)*hprimewgll_xx(5,j)
- newtempz2(i,j,k) = tempz2(i,1,k)*hprimewgll_xx(1,j) + &
- tempz2(i,2,k)*hprimewgll_xx(2,j) + &
- tempz2(i,3,k)*hprimewgll_xx(3,j) + &
- tempz2(i,4,k)*hprimewgll_xx(4,j) + &
- tempz2(i,5,k)*hprimewgll_xx(5,j)
+ newtempz2(i,j,k) = tempz2(i,1,k)*hprimewgll_xx(1,j) + &
+ tempz2(i,2,k)*hprimewgll_xx(2,j) + &
+ tempz2(i,3,k)*hprimewgll_xx(3,j) + &
+ tempz2(i,4,k)*hprimewgll_xx(4,j) + &
+ tempz2(i,5,k)*hprimewgll_xx(5,j)
+ enddo
enddo
enddo
- enddo
-! call mxm_m2_m1_5points(tempx3,tempy3,tempz3,hprimewgll_xx,newtempx3,newtempy3,newtempz3)
- do j=1,m1
- do i=1,m2
- E1_mxm_m2_m1_5points(i,j) = C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
- C1_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
- C1_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
- C1_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
- C1_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ ! call mxm_m2_m1_5points(tempx3,tempy3,tempz3,hprimewgll_xx,newtempx3,newtempy3,newtempz3)
+ do j=1,m1
+ do i=1,m2
+ E1_mxm_m2_m1_5points(i,j) = C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ C1_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ C1_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ C1_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ C1_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
- E2_mxm_m2_m1_5points(i,j) = C2_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
- C2_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
- C2_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
- C2_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
- C2_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ E2_mxm_m2_m1_5points(i,j) = C2_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ C2_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ C2_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ C2_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ C2_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
- E3_mxm_m2_m1_5points(i,j) = C3_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
- C3_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
- C3_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
- C3_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
- C3_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ E3_mxm_m2_m1_5points(i,j) = C3_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ C3_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ C3_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ C3_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ C3_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ enddo
enddo
- enddo
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
- fac1 = wgllwgll_yz(j,k)
- fac2 = wgllwgll_xz(i,k)
- fac3 = wgllwgll_xy(i,j)
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
-! sum contributions from each element to the global mesh using indirect addressing
- iglob = ibool(i,j,k,ispec)
- accel(1,iglob) = accel(1,iglob) - fac1*newtempx1(i,j,k) - fac2*newtempx2(i,j,k) - fac3*newtempx3(i,j,k)
- accel(2,iglob) = accel(2,iglob) - fac1*newtempy1(i,j,k) - fac2*newtempy2(i,j,k) - fac3*newtempy3(i,j,k)
- accel(3,iglob) = accel(3,iglob) - fac1*newtempz1(i,j,k) - fac2*newtempz2(i,j,k) - fac3*newtempz3(i,j,k)
+ ! sum contributions from each element to the global mesh using indirect addressing
+ iglob = ibool(i,j,k,ispec)
+ accel(1,iglob) = accel(1,iglob) - fac1*newtempx1(i,j,k) - fac2*newtempx2(i,j,k) - fac3*newtempx3(i,j,k)
+ accel(2,iglob) = accel(2,iglob) - fac1*newtempy1(i,j,k) - fac2*newtempy2(i,j,k) - fac3*newtempy3(i,j,k)
+ accel(3,iglob) = accel(3,iglob) - fac1*newtempz1(i,j,k) - fac2*newtempz2(i,j,k) - fac3*newtempz3(i,j,k)
- ! update memory variables based upon the Runge-Kutta scheme
- if(ATTENUATION) then
-
- ! use Runge-Kutta scheme to march in time
- do i_sls = 1,N_SLS
+ ! update memory variables based upon the Runge-Kutta scheme
+ if(ATTENUATION) then
+
+ ! use Runge-Kutta scheme to march in time
+ do i_sls = 1,N_SLS
- ! get coefficients for that standard linear solid
- iselected = iflag_attenuation_store(i,j,k,ispec)
- factor_loc = mustore(i,j,k,ispec) * factor_common(iselected,i_sls)
- alphaval_loc = alphaval(iselected,i_sls)
- betaval_loc = betaval(iselected,i_sls)
- gammaval_loc = gammaval(iselected,i_sls)
-
- ! term in xx
- Sn = factor_loc * epsilondev_xx(i,j,k,ispec)
- Snp1 = factor_loc * epsilondev_xx_loc(i,j,k)
- R_xx(i,j,k,ispec,i_sls) = alphaval_loc * R_xx(i,j,k,ispec,i_sls) + betaval_loc * Sn + gammaval_loc * Snp1
-
- ! term in yy
- Sn = factor_loc * epsilondev_yy(i,j,k,ispec)
- Snp1 = factor_loc * epsilondev_yy_loc(i,j,k)
- R_yy(i,j,k,ispec,i_sls) = alphaval_loc * R_yy(i,j,k,ispec,i_sls) + betaval_loc * Sn + gammaval_loc * Snp1
+ ! get coefficients for that standard linear solid
+ iselected = iflag_attenuation_store(i,j,k,ispec)
+ factor_loc = mustore(i,j,k,ispec) * factor_common(iselected,i_sls)
+ alphaval_loc = alphaval(iselected,i_sls)
+ betaval_loc = betaval(iselected,i_sls)
+ gammaval_loc = gammaval(iselected,i_sls)
+
+ ! term in xx
+ Sn = factor_loc * epsilondev_xx(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_xx_loc(i,j,k)
+ R_xx(i,j,k,ispec,i_sls) = alphaval_loc * R_xx(i,j,k,ispec,i_sls) + betaval_loc * Sn + gammaval_loc * Snp1
+
+ ! term in yy
+ Sn = factor_loc * epsilondev_yy(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_yy_loc(i,j,k)
+ R_yy(i,j,k,ispec,i_sls) = alphaval_loc * R_yy(i,j,k,ispec,i_sls) + betaval_loc * Sn + gammaval_loc * Snp1
- ! term in zz not computed since zero trace
+ ! term in zz not computed since zero trace
+
+ ! term in xy
+ Sn = factor_loc * epsilondev_xy(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_xy_loc(i,j,k)
+ R_xy(i,j,k,ispec,i_sls) = alphaval_loc * R_xy(i,j,k,ispec,i_sls) + betaval_loc * Sn + gammaval_loc * Snp1
- ! term in xy
- Sn = factor_loc * epsilondev_xy(i,j,k,ispec)
- Snp1 = factor_loc * epsilondev_xy_loc(i,j,k)
- R_xy(i,j,k,ispec,i_sls) = alphaval_loc * R_xy(i,j,k,ispec,i_sls) + betaval_loc * Sn + gammaval_loc * Snp1
-
- ! term in xz
- Sn = factor_loc * epsilondev_xz(i,j,k,ispec)
- Snp1 = factor_loc * epsilondev_xz_loc(i,j,k)
- R_xz(i,j,k,ispec,i_sls) = alphaval_loc * R_xz(i,j,k,ispec,i_sls) + betaval_loc * Sn + gammaval_loc * Snp1
+ ! term in xz
+ Sn = factor_loc * epsilondev_xz(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_xz_loc(i,j,k)
+ R_xz(i,j,k,ispec,i_sls) = alphaval_loc * R_xz(i,j,k,ispec,i_sls) + betaval_loc * Sn + gammaval_loc * Snp1
- ! term in yz
- Sn = factor_loc * epsilondev_yz(i,j,k,ispec)
- Snp1 = factor_loc * epsilondev_yz_loc(i,j,k)
- R_yz(i,j,k,ispec,i_sls) = alphaval_loc * R_yz(i,j,k,ispec,i_sls) + betaval_loc * Sn + gammaval_loc * Snp1
+ ! term in yz
+ Sn = factor_loc * epsilondev_yz(i,j,k,ispec)
+ Snp1 = factor_loc * epsilondev_yz_loc(i,j,k)
+ R_yz(i,j,k,ispec,i_sls) = alphaval_loc * R_yz(i,j,k,ispec,i_sls) + betaval_loc * Sn + gammaval_loc * Snp1
- enddo ! end of loop on memory variables
+ enddo ! end of loop on memory variables
- endif ! end attenuation
+ endif ! end attenuation
+ enddo
enddo
enddo
- enddo
- ! save deviatoric strain for Runge-Kutta scheme
- if(ATTENUATION) then
- epsilondev_xx(:,:,:,ispec) = epsilondev_xx_loc(:,:,:)
- epsilondev_yy(:,:,:,ispec) = epsilondev_yy_loc(:,:,:)
- epsilondev_xy(:,:,:,ispec) = epsilondev_xy_loc(:,:,:)
- epsilondev_xz(:,:,:,ispec) = epsilondev_xz_loc(:,:,:)
- epsilondev_yz(:,:,:,ispec) = epsilondev_yz_loc(:,:,:)
- endif
+ ! save deviatoric strain for Runge-Kutta scheme
+ if(ATTENUATION) then
+ epsilondev_xx(:,:,:,ispec) = epsilondev_xx_loc(:,:,:)
+ epsilondev_yy(:,:,:,ispec) = epsilondev_yy_loc(:,:,:)
+ epsilondev_xy(:,:,:,ispec) = epsilondev_xy_loc(:,:,:)
+ epsilondev_xz(:,:,:,ispec) = epsilondev_xz_loc(:,:,:)
+ epsilondev_yz(:,:,:,ispec) = epsilondev_yz_loc(:,:,:)
+ endif
- endif ! if (ispec_is_inner(ispec) .eqv. phase_is_inner)
+ endif ! if (ispec_is_inner(ispec) .eqv. phase_is_inner)
enddo ! spectral element loop
+end subroutine compute_forces_add_elastic_term
- ! add Stacey conditions
- if(ABSORBING_CONDITIONS) then
-! xmin
- do ispec2D=1,nspec2D_xmin
+!
+!-------------------------------------------------------------------------------------------------
+!
- ispec=ibelm_xmin(ispec2D)
-
- if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+! absorbing boundary term for elastic media (Stacey conditions)
- ! exclude elements that are not on absorbing edges
- if(nkmin_xi(1,ispec2D) == 0 .or. njmin(1,ispec2D) == 0) cycle
+subroutine compute_forces_add_elastic_absorbing_boundaries(NSPEC_AB,NGLOB_AB,accel, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
+ absorbing_boundary_ijk,absorbing_boundary_ispec, &
+ num_absorbing_boundary_faces, &
+ veloc,rho_vp,rho_vs)
- i=1
- do k=nkmin_xi(1,ispec2D),NGLLZ
- do j=njmin(1,ispec2D),njmax(1,ispec2D)
-
- iglob=ibool(i,j,k,ispec)
+ implicit none
- vx=veloc(1,iglob)
- vy=veloc(2,iglob)
- vz=veloc(3,iglob)
- nx=normal_xmin(1,j,k,ispec2D)
- ny=normal_xmin(2,j,k,ispec2D)
- nz=normal_xmin(3,j,k,ispec2D)
+ include "constants.h"
- vn=vx*nx+vy*ny+vz*nz
-
- tx=rho_vp(i,j,k,ispec)*vn*nx+rho_vs(i,j,k,ispec)*(vx-vn*nx)
- ty=rho_vp(i,j,k,ispec)*vn*ny+rho_vs(i,j,k,ispec)*(vy-vn*ny)
- tz=rho_vp(i,j,k,ispec)*vn*nz+rho_vs(i,j,k,ispec)*(vz-vn*nz)
+ integer :: NSPEC_AB,NGLOB_AB
- weight=jacobian2D_xmin(j,k,ispec2D)*wgllwgll_yz(j,k)
-
- accel(1,iglob)=accel(1,iglob) - tx*weight
- accel(2,iglob)=accel(2,iglob) - ty*weight
- accel(3,iglob)=accel(3,iglob) - tz*weight
+! acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: accel
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
- enddo
- enddo
- end if
- enddo
-
-! xmax
- do ispec2D=1,nspec2D_xmax
-
- ispec=ibelm_xmax(ispec2D)
-
- if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-
- ! exclude elements that are not on absorbing edges
- if(nkmin_xi(2,ispec2D) == 0 .or. njmin(2,ispec2D) == 0) cycle
-
- i=NGLLX
- do k=nkmin_xi(2,ispec2D),NGLLZ
- do j=njmin(2,ispec2D),njmax(2,ispec2D)
- iglob=ibool(i,j,k,ispec)
-
- vx=veloc(1,iglob)
- vy=veloc(2,iglob)
- vz=veloc(3,iglob)
+! array with derivatives of Lagrange polynomials and precalculated products
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
- nx=normal_xmax(1,j,k,ispec2D)
- ny=normal_xmax(2,j,k,ispec2D)
- nz=normal_xmax(3,j,k,ispec2D)
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+! Stacey conditions
+! integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,nspec2D_top
+! integer :: NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext
+! integer, dimension(nspec2D_xmin) :: ibelm_xmin
+! integer, dimension(nspec2D_xmax) :: ibelm_xmax
+! integer, dimension(nspec2D_ymin) :: ibelm_ymin
+! integer, dimension(nspec2D_ymax) :: ibelm_ymax
+! integer, dimension(nspec2D_bottom) :: ibelm_bottom
+! integer, dimension(nspec2D_top) :: ibelm_top
- vn=vx*nx+vy*ny+vz*nz
-
- tx=rho_vp(i,j,k,ispec)*vn*nx+rho_vs(i,j,k,ispec)*(vx-vn*nx)
- ty=rho_vp(i,j,k,ispec)*vn*ny+rho_vs(i,j,k,ispec)*(vy-vn*ny)
- tz=rho_vp(i,j,k,ispec)*vn*nz+rho_vs(i,j,k,ispec)*(vz-vn*nz)
+ ! local indices i,j,k of all GLL points on xmin boundary in the element
+! integer :: ibelm_gll_xmin(3,NGLLY,NGLLZ,nspec2D_xmin),ibelm_gll_xmax(3,NGLLY,NGLLZ,nspec2D_xmax), &
+! ibelm_gll_ymin(3,NGLLX,NGLLZ,nspec2D_ymin),ibelm_gll_ymax(3,NGLLX,NGLLZ,nspec2D_ymax), &
+! ibelm_gll_bottom(3,NGLLY,NGLLY,nspec2D_bottom),ibelm_gll_top(3,NGLLY,NGLLY,nspec2D_top)
+
+! integer, dimension(2,NSPEC2DMAX_YMIN_YMAX_ext) :: nimin,nimax,nkmin_eta
+! integer, dimension(2,NSPEC2DMAX_XMIN_XMAX_ext) :: njmin,njmax,nkmin_xi
- weight=jacobian2D_xmax(j,k,ispec2D)*wgllwgll_yz(j,k)
-
- accel(1,iglob)=accel(1,iglob) - tx*weight
- accel(2,iglob)=accel(2,iglob) - ty*weight
- accel(3,iglob)=accel(3,iglob) - tz*weight
-
- enddo
- enddo
- end if
- enddo
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: veloc
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vp,rho_vs
-! ymin
- do ispec2D=1,nspec2D_ymin
-
- ispec=ibelm_ymin(ispec2D)
-
- if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
-
- ! exclude elements that are not on absorbing edges
- if(nkmin_eta(1,ispec2D) == 0 .or. nimin(1,ispec2D) == 0) cycle
-
- j=1
- do k=nkmin_eta(1,ispec2D),NGLLZ
- do i=nimin(1,ispec2D),nimax(1,ispec2D)
- iglob=ibool(i,j,k,ispec)
-
- vx=veloc(1,iglob)
- vy=veloc(2,iglob)
- vz=veloc(3,iglob)
-
- nx=normal_ymin(1,i,k,ispec2D)
- ny=normal_ymin(2,i,k,ispec2D)
- nz=normal_ymin(3,i,k,ispec2D)
-
- vn=vx*nx+vy*ny+vz*nz
-
- tx=rho_vp(i,j,k,ispec)*vn*nx+rho_vs(i,j,k,ispec)*(vx-vn*nx)
- ty=rho_vp(i,j,k,ispec)*vn*ny+rho_vs(i,j,k,ispec)*(vy-vn*ny)
- tz=rho_vp(i,j,k,ispec)*vn*nz+rho_vs(i,j,k,ispec)*(vz-vn*nz)
+! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmin) :: jacobian2D_xmin
+! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmax) :: jacobian2D_xmax
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymin) :: jacobian2D_ymin
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymax) :: jacobian2D_ymax
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM) :: jacobian2D_bottom
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_top) :: jacobian2D_top
+!
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmin) :: normal_xmin
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmax) :: normal_xmax
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_ymin) :: normal_ymin
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_ymax) :: normal_ymax
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM) :: normal_bottom
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_top) :: normal_top
- weight=jacobian2D_ymin(i,k,ispec2D)*wgllwgll_xz(i,k)
-
- accel(1,iglob)=accel(1,iglob) - tx*weight
- accel(2,iglob)=accel(2,iglob) - ty*weight
- accel(3,iglob)=accel(3,iglob) - tz*weight
-
- enddo
- enddo
- endif
- enddo
+ integer :: num_absorbing_boundary_faces
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_normal
+ real(kind=CUSTOM_REAL), dimension(NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_jacobian2D
+ integer, dimension(3,NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_ijk
+ integer, dimension(num_absorbing_boundary_faces) :: absorbing_boundary_ispec
-! ymax
- do ispec2D=1,nspec2D_ymax
-
- ispec=ibelm_ymax(ispec2D)
- if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+! local parameters
+ real(kind=CUSTOM_REAL) vx,vy,vz,nx,ny,nz,tx,ty,tz,vn,jacobianw !weight,jacobianl
+ integer :: ispec,iglob,i,j,k,iface,igll
+ !integer :: num_gll !,igll_i,igll_j,ispec2D
+
- ! exclude elements that are not on absorbing edges
- if(nkmin_eta(2,ispec2D) == 0 .or. nimin(2,ispec2D) == 0) cycle
+! absorbs absorbing-boundary surface using Stacey condition (Clayton & Enquist)
+ do iface=1,num_absorbing_boundary_faces
- j=NGLLY
- do k=nkmin_eta(2,ispec2D),NGLLZ
- do i=nimin(2,ispec2D),nimax(2,ispec2D)
- iglob=ibool(i,j,k,ispec)
-
- vx=veloc(1,iglob)
- vy=veloc(2,iglob)
- vz=veloc(3,iglob)
-
- nx=normal_ymax(1,i,k,ispec2D)
- ny=normal_ymax(2,i,k,ispec2D)
- nz=normal_ymax(3,i,k,ispec2D)
+ ispec = absorbing_boundary_ispec(iface)
- vn=vx*nx+vy*ny+vz*nz
-
- tx=rho_vp(i,j,k,ispec)*vn*nx+rho_vs(i,j,k,ispec)*(vx-vn*nx)
- ty=rho_vp(i,j,k,ispec)*vn*ny+rho_vs(i,j,k,ispec)*(vy-vn*ny)
- tz=rho_vp(i,j,k,ispec)*vn*nz+rho_vs(i,j,k,ispec)*(vz-vn*nz)
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
- weight=jacobian2D_ymax(i,k,ispec2D)*wgllwgll_xz(i,k)
-
- accel(1,iglob)=accel(1,iglob) - tx*weight
- accel(2,iglob)=accel(2,iglob) - ty*weight
- accel(3,iglob)=accel(3,iglob) - tz*weight
-
- enddo
- enddo
- endif
- enddo
+ ! reference gll points on boundary face
+ do igll = 1,NGLLSQUARE
- ! bottom (zmin)
- do ispec2D=1,NSPEC2D_BOTTOM
+ ! gets local indices for GLL point
+ i = absorbing_boundary_ijk(1,igll,iface)
+ j = absorbing_boundary_ijk(2,igll,iface)
+ k = absorbing_boundary_ijk(3,igll,iface)
+
+ ! gets velocity
+ iglob=ibool(i,j,k,ispec)
+ vx=veloc(1,iglob)
+ vy=veloc(2,iglob)
+ vz=veloc(3,iglob)
+
+ ! gets associated normal
+ nx = absorbing_boundary_normal(1,igll,iface)
+ ny = absorbing_boundary_normal(2,igll,iface)
+ nz = absorbing_boundary_normal(3,igll,iface)
+
+ ! velocity component in normal direction (normal points out of element)
+ vn = vx*nx + vy*ny + vz*nz
+
+ ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
+ tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
+ ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
+ tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
+
+ ! gets associated, weighted jacobian
+ jacobianw = absorbing_boundary_jacobian2D(igll,iface)
- ispec=ibelm_bottom(ispec2D)
-
- if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+ ! adds stacey term (weak form)
+ accel(1,iglob) = accel(1,iglob) - tx*jacobianw
+ accel(2,iglob) = accel(2,iglob) - ty*jacobianw
+ accel(3,iglob) = accel(3,iglob) - tz*jacobianw
- k=1
- do j=1,NGLLY
- do i=1,NGLLX
-
- iglob=ibool(i,j,k,ispec)
-
- vx=veloc(1,iglob)
- vy=veloc(2,iglob)
- vz=veloc(3,iglob)
+ enddo
+
+ endif
+ enddo
+!
+!! old way: assumes box model with absorbing-boundary faces oriented with x,y,z planes
+!! xmin
+! do ispec2D=1,nspec2D_xmin
+!
+! ispec=ibelm_xmin(ispec2D)
+!
+! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+!
+!! old regular mesh
+!! ! exclude elements that are not on absorbing edges
+!! if(nkmin_xi(1,ispec2D) == 0 .or. njmin(1,ispec2D) == 0) cycle
+!!
+!! i=1
+!! do k=nkmin_xi(1,ispec2D),NGLLZ
+!! do j=njmin(1,ispec2D),njmax(1,ispec2D)
+!
+!! new way, unregular element orientation
+! ! reference gll points on boundary face
+! do igll_j = 1,NGLLZ
+! do igll_i = 1,NGLLY
+! ! gets local indices for GLL point
+! i = ibelm_gll_xmin(1,igll_i,igll_j,ispec2D)
+! j = ibelm_gll_xmin(2,igll_i,igll_j,ispec2D)
+! k = ibelm_gll_xmin(3,igll_i,igll_j,ispec2D)
+!
+! ! gets velocity
+! iglob=ibool(i,j,k,ispec)
+! vx=veloc(1,iglob)
+! vy=veloc(2,iglob)
+! vz=veloc(3,iglob)
+!
+! ! gets associated normal
+! nx = normal_xmin(1,igll_i,igll_j,ispec2D)
+! ny = normal_xmin(2,igll_i,igll_j,ispec2D)
+! nz = normal_xmin(3,igll_i,igll_j,ispec2D)
+! ! nx = normal_xmin(1,j,k,ispec2D)
+! ! ny = normal_xmin(2,j,k,ispec2D)
+! ! nz = normal_xmin(3,j,k,ispec2D)
+!
+! ! velocity component in normal direction (normal points out of element)
+! vn = vx*nx + vy*ny + vz*nz
+!
+! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
+! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
+! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
+! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
+!
+! ! gets associated jacobian and 2D weights
+! jacobianl = jacobian2D_xmin(igll_i,igll_j,ispec2D)
+! weight = jacobianl*wgllwgll_yz(igll_i,igll_j)
+!
+! ! adds stacey term (weak form)
+! accel(1,iglob) = accel(1,iglob) - tx*weight
+! accel(2,iglob) = accel(2,iglob) - ty*weight
+! accel(3,iglob) = accel(3,iglob) - tz*weight
+!
+! enddo
+! enddo
+! end if
+! enddo
+!
+!! xmax
+! do ispec2D=1,nspec2D_xmax
+!
+! ispec=ibelm_xmax(ispec2D)
+!
+! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+!
+! ! reference gll points on boundary face
+! do igll_j = 1,NGLLZ
+! do igll_i = 1,NGLLY
+! ! gets local indices for GLL point
+! i = ibelm_gll_xmax(1,igll_i,igll_j,ispec2D)
+! j = ibelm_gll_xmax(2,igll_i,igll_j,ispec2D)
+! k = ibelm_gll_xmax(3,igll_i,igll_j,ispec2D)
+!
+! ! gets velocity
+! iglob=ibool(i,j,k,ispec)
+! vx=veloc(1,iglob)
+! vy=veloc(2,iglob)
+! vz=veloc(3,iglob)
+!
+! ! gets associated normal
+! nx = normal_xmax(1,igll_i,igll_j,ispec2D)
+! ny = normal_xmax(2,igll_i,igll_j,ispec2D)
+! nz = normal_xmax(3,igll_i,igll_j,ispec2D)
+!
+! ! velocity component in normal direction (normal points out of element)
+! vn = vx*nx + vy*ny + vz*nz
+!
+! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
+! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
+! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
+! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
+!
+! ! gets associated jacobian and 2D weights
+! jacobianl = jacobian2D_xmax(igll_i,igll_j,ispec2D)
+! weight = jacobianl*wgllwgll_yz(igll_i,igll_j)
+!
+! ! adds stacey term (weak form)
+! accel(1,iglob) = accel(1,iglob) - tx*weight
+! accel(2,iglob) = accel(2,iglob) - ty*weight
+! accel(3,iglob) = accel(3,iglob) - tz*weight
+!
+! enddo
+! enddo
+! end if
+! enddo
+!
+!! ymin
+! do ispec2D=1,nspec2D_ymin
+!
+! ispec=ibelm_ymin(ispec2D)
+!
+! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+!
+! ! reference gll points on boundary face
+! do igll_j = 1,NGLLZ
+! do igll_i = 1,NGLLX
+! ! gets local indices for GLL point
+! i = ibelm_gll_ymin(1,igll_i,igll_j,ispec2D)
+! j = ibelm_gll_ymin(2,igll_i,igll_j,ispec2D)
+! k = ibelm_gll_ymin(3,igll_i,igll_j,ispec2D)
+!
+! ! gets velocity
+! iglob=ibool(i,j,k,ispec)
+! vx=veloc(1,iglob)
+! vy=veloc(2,iglob)
+! vz=veloc(3,iglob)
+!
+! ! gets associated normal
+! nx = normal_ymin(1,igll_i,igll_j,ispec2D)
+! ny = normal_ymin(2,igll_i,igll_j,ispec2D)
+! nz = normal_ymin(3,igll_i,igll_j,ispec2D)
+!
+! ! velocity component in normal direction (normal points out of element)
+! vn = vx*nx + vy*ny + vz*nz
+!
+! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
+! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
+! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
+! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
+!
+! ! gets associated jacobian and 2D weights
+! jacobianl = jacobian2D_ymin(igll_i,igll_j,ispec2D)
+! weight = jacobianl*wgllwgll_xz(igll_i,igll_j)
+!
+! ! adds stacey term (weak form)
+! accel(1,iglob) = accel(1,iglob) - tx*weight
+! accel(2,iglob) = accel(2,iglob) - ty*weight
+! accel(3,iglob) = accel(3,iglob) - tz*weight
+!
+! enddo
+! enddo
+!
+! endif
+! enddo
+!
+!! ymax
+! do ispec2D=1,nspec2D_ymax
+!
+! ispec=ibelm_ymax(ispec2D)
+!
+! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+!
+! ! reference gll points on boundary face
+! do igll_j = 1,NGLLZ
+! do igll_i = 1,NGLLX
+! ! gets local indices for GLL point
+! i = ibelm_gll_ymax(1,igll_i,igll_j,ispec2D)
+! j = ibelm_gll_ymax(2,igll_i,igll_j,ispec2D)
+! k = ibelm_gll_ymax(3,igll_i,igll_j,ispec2D)
+!
+! ! gets velocity
+! iglob=ibool(i,j,k,ispec)
+! vx=veloc(1,iglob)
+! vy=veloc(2,iglob)
+! vz=veloc(3,iglob)
+!
+! ! gets associated normal
+! nx = normal_ymax(1,igll_i,igll_j,ispec2D)
+! ny = normal_ymax(2,igll_i,igll_j,ispec2D)
+! nz = normal_ymax(3,igll_i,igll_j,ispec2D)
+!
+! ! velocity component in normal direction (normal points out of element)
+! vn = vx*nx + vy*ny + vz*nz
+!
+! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
+! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
+! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
+! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
+!
+! ! gets associated jacobian and 2D weights
+! jacobianl = jacobian2D_ymax(igll_i,igll_j,ispec2D)
+! weight = jacobianl*wgllwgll_xz(igll_i,igll_j)
+!
+! ! adds stacey term (weak form)
+! accel(1,iglob) = accel(1,iglob) - tx*weight
+! accel(2,iglob) = accel(2,iglob) - ty*weight
+! accel(3,iglob) = accel(3,iglob) - tz*weight
+! enddo
+! enddo
+!
+! endif
+! enddo
+!
+!! bottom (zmin)
+! do ispec2D=1,NSPEC2D_BOTTOM
+!
+! ispec=ibelm_bottom(ispec2D)
+!
+! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+!
+! ! reference gll points on boundary face
+! do igll_j = 1,NGLLY
+! do igll_i = 1,NGLLX
+! ! gets local indices for GLL point
+! i = ibelm_gll_bottom(1,igll_i,igll_j,ispec2D)
+! j = ibelm_gll_bottom(2,igll_i,igll_j,ispec2D)
+! k = ibelm_gll_bottom(3,igll_i,igll_j,ispec2D)
+!
+! ! gets velocity
+! iglob=ibool(i,j,k,ispec)
+! vx=veloc(1,iglob)
+! vy=veloc(2,iglob)
+! vz=veloc(3,iglob)
+!
+! ! gets associated normal
+! nx = normal_bottom(1,igll_i,igll_j,ispec2D)
+! ny = normal_bottom(2,igll_i,igll_j,ispec2D)
+! nz = normal_bottom(3,igll_i,igll_j,ispec2D)
+!
+! ! velocity component in normal direction (normal points out of element)
+! vn = vx*nx + vy*ny + vz*nz
+!
+! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
+! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
+! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
+! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
+!
+! ! gets associated jacobian and 2D weights
+! jacobianl = jacobian2D_bottom(igll_i,igll_j,ispec2D)
+! weight = jacobianl*wgllwgll_xy(igll_i,igll_j)
+!
+! ! adds stacey term (weak form)
+! accel(1,iglob) = accel(1,iglob) - tx*weight
+! accel(2,iglob) = accel(2,iglob) - ty*weight
+! accel(3,iglob) = accel(3,iglob) - tz*weight
+!
+! enddo
+! enddo
+!
+! endif
+! enddo
+!
+!! absorbing at top surface - no free-surface?
+! if( ABSORB_TOP_SURFACE ) then
+! do ispec2D=1,NSPEC2D_TOP
+!
+! ispec=ibelm_top(ispec2D)
+!
+! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+!
+! ! reference gll points on boundary face
+! do igll_j = 1,NGLLY
+! do igll_i = 1,NGLLX
+! ! gets local indices for GLL point
+! i = ibelm_gll_top(1,igll_i,igll_j,ispec2D)
+! j = ibelm_gll_top(2,igll_i,igll_j,ispec2D)
+! k = ibelm_gll_top(3,igll_i,igll_j,ispec2D)
+!
+! ! gets velocity
+! iglob=ibool(i,j,k,ispec)
+! vx=veloc(1,iglob)
+! vy=veloc(2,iglob)
+! vz=veloc(3,iglob)
+!
+! ! gets associated normal
+! nx = normal_top(1,igll_i,igll_j,ispec2D)
+! ny = normal_top(2,igll_i,igll_j,ispec2D)
+! nz = normal_top(3,igll_i,igll_j,ispec2D)
+!
+! ! velocity component in normal direction (normal points out of element)
+! vn = vx*nx + vy*ny + vz*nz
+!
+! ! stacey term: velocity vector component * vp * rho in normal direction + vs * rho component tangential to it
+! tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(vx-vn*nx)
+! ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(vy-vn*ny)
+! tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(vz-vn*nz)
+!
+! ! gets associated jacobian and 2D weights
+! jacobianl = jacobian2D_top(igll_i,igll_j,ispec2D)
+! weight = jacobianl*wgllwgll_xy(igll_i,igll_j)
+!
+! ! adds stacey term (weak form)
+! accel(1,iglob) = accel(1,iglob) - tx*weight
+! accel(2,iglob) = accel(2,iglob) - ty*weight
+! accel(3,iglob) = accel(3,iglob) - tz*weight
+!
+! enddo
+! enddo
+!
+! endif
+! enddo
+! endif
+
+end subroutine compute_forces_add_elastic_absorbing_boundaries
- nx=normal_bottom(1,i,j,ispec2D)
- ny=normal_bottom(2,i,j,ispec2D)
- nz=normal_bottom(3,i,j,ispec2D)
+!
+!-------------------------------------------------------------------------------------------------
+!
- vn=vx*nx+vy*ny+vz*nz
+subroutine compute_forces_add_source_term( NSPEC_AB,NGLOB_AB,accel, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
+ xi_source,eta_source,gamma_source,nu_source, &
+ hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays )
- tx=rho_vp(i,j,k,ispec)*vn*nx+rho_vs(i,j,k,ispec)*(vx-vn*nx)
- ty=rho_vp(i,j,k,ispec)*vn*ny+rho_vs(i,j,k,ispec)*(vy-vn*ny)
- tz=rho_vp(i,j,k,ispec)*vn*nz+rho_vs(i,j,k,ispec)*(vz-vn*nz)
+ implicit none
- weight=jacobian2D_bottom(i,j,ispec2D)*wgllwgll_xy(i,j)
+ include "constants.h"
- accel(1,iglob)=accel(1,iglob) - tx*weight
- accel(2,iglob)=accel(2,iglob) - ty*weight
- accel(3,iglob)=accel(3,iglob) - tz*weight
+ integer :: NSPEC_AB,NGLOB_AB
- enddo
- enddo
- endif
- enddo
-
- endif ! end of Stacey conditions
+! displacement and acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: accel
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
-! adding source
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+! source
+ integer :: NSOURCES,myrank,it
+ integer, dimension(NSOURCES) :: islice_selected_source,ispec_selected_source
+ double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
+ double precision, dimension(3,3,NSOURCES) :: nu_source
+ double precision, dimension(NSOURCES) :: hdur,hdur_gaussian,t_cmt
+ double precision :: dt
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrays
+
+ double precision, external :: comp_source_time_function
+
+! local parameters
+ double precision :: t0,f0
+ double precision :: stf
+ real(kind=CUSTOM_REAL) stf_used
+ integer :: isource,iglob,i,j,k
+
do isource = 1,NSOURCES
! add the source (only if this proc carries the source)
@@ -783,131 +1152,131 @@
enddo ! NSOURCES
-end subroutine compute_forces_with_Deville
+end subroutine compute_forces_add_source_term
!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! subroutines adapted from Deville, Fischer and Mund, High-order methods
-! for incompressible fluid flow, Cambridge University Press (2002),
-! pages 386 and 389 and Figure 8.3.1
-
- subroutine old_mxm_m1_m2_5points(A,B1,B2,B3,C1,C2,C3)
-
- implicit none
-
- include "constants.h"
-
- real(kind=4), dimension(m1,NGLLX) :: A
- real(kind=4), dimension(NGLLX,m2) :: B1,B2,B3
- real(kind=4), dimension(m1,m2) :: C1,C2,C3
-
- integer :: i,j
-
- do j=1,m2
- do i=1,m1
-
- C1(i,j) = A(i,1)*B1(1,j) + &
- A(i,2)*B1(2,j) + &
- A(i,3)*B1(3,j) + &
- A(i,4)*B1(4,j) + &
- A(i,5)*B1(5,j)
-
- C2(i,j) = A(i,1)*B2(1,j) + &
- A(i,2)*B2(2,j) + &
- A(i,3)*B2(3,j) + &
- A(i,4)*B2(4,j) + &
- A(i,5)*B2(5,j)
-
- C3(i,j) = A(i,1)*B3(1,j) + &
- A(i,2)*B3(2,j) + &
- A(i,3)*B3(3,j) + &
- A(i,4)*B3(4,j) + &
- A(i,5)*B3(5,j)
-
- enddo
- enddo
-
- end subroutine old_mxm_m1_m2_5points
-
-!---------
-
- subroutine old_mxm_m1_m1_5points(A1,A2,A3,B,C1,C2,C3)
-
- implicit none
-
- include "constants.h"
-
- real(kind=4), dimension(m1,NGLLX) :: A1,A2,A3
- real(kind=4), dimension(NGLLX,m1) :: B
- real(kind=4), dimension(m1,m1) :: C1,C2,C3
-
- integer :: i,j
-
- do j=1,m1
- do i=1,m1
-
- C1(i,j) = A1(i,1)*B(1,j) + &
- A1(i,2)*B(2,j) + &
- A1(i,3)*B(3,j) + &
- A1(i,4)*B(4,j) + &
- A1(i,5)*B(5,j)
-
- C2(i,j) = A2(i,1)*B(1,j) + &
- A2(i,2)*B(2,j) + &
- A2(i,3)*B(3,j) + &
- A2(i,4)*B(4,j) + &
- A2(i,5)*B(5,j)
-
- C3(i,j) = A3(i,1)*B(1,j) + &
- A3(i,2)*B(2,j) + &
- A3(i,3)*B(3,j) + &
- A3(i,4)*B(4,j) + &
- A3(i,5)*B(5,j)
-
- enddo
- enddo
-
- end subroutine old_mxm_m1_m1_5points
-
-!---------
-
- subroutine old_mxm_m2_m1_5points(A1,A2,A3,B,C1,C2,C3)
-
- implicit none
-
- include "constants.h"
-
- real(kind=4), dimension(m2,NGLLX) :: A1,A2,A3
- real(kind=4), dimension(NGLLX,m1) :: B
- real(kind=4), dimension(m2,m1) :: C1,C2,C3
-
- integer :: i,j
-
- do j=1,m1
- do i=1,m2
-
- C1(i,j) = A1(i,1)*B(1,j) + &
- A1(i,2)*B(2,j) + &
- A1(i,3)*B(3,j) + &
- A1(i,4)*B(4,j) + &
- A1(i,5)*B(5,j)
-
- C2(i,j) = A2(i,1)*B(1,j) + &
- A2(i,2)*B(2,j) + &
- A2(i,3)*B(3,j) + &
- A2(i,4)*B(4,j) + &
- A2(i,5)*B(5,j)
-
- C3(i,j) = A3(i,1)*B(1,j) + &
- A3(i,2)*B(2,j) + &
- A3(i,3)*B(3,j) + &
- A3(i,4)*B(4,j) + &
- A3(i,5)*B(5,j)
-
- enddo
- enddo
-
- end subroutine old_mxm_m2_m1_5points
-
+!
+!! subroutines adapted from Deville, Fischer and Mund, High-order methods
+!! for incompressible fluid flow, Cambridge University Press (2002),
+!! pages 386 and 389 and Figure 8.3.1
+!
+! subroutine old_mxm_m1_m2_5points(A,B1,B2,B3,C1,C2,C3)
+!
+! implicit none
+!
+! include "constants.h"
+!
+! real(kind=4), dimension(m1,NGLLX) :: A
+! real(kind=4), dimension(NGLLX,m2) :: B1,B2,B3
+! real(kind=4), dimension(m1,m2) :: C1,C2,C3
+!
+! integer :: i,j
+!
+! do j=1,m2
+! do i=1,m1
+!
+! C1(i,j) = A(i,1)*B1(1,j) + &
+! A(i,2)*B1(2,j) + &
+! A(i,3)*B1(3,j) + &
+! A(i,4)*B1(4,j) + &
+! A(i,5)*B1(5,j)
+!
+! C2(i,j) = A(i,1)*B2(1,j) + &
+! A(i,2)*B2(2,j) + &
+! A(i,3)*B2(3,j) + &
+! A(i,4)*B2(4,j) + &
+! A(i,5)*B2(5,j)
+!
+! C3(i,j) = A(i,1)*B3(1,j) + &
+! A(i,2)*B3(2,j) + &
+! A(i,3)*B3(3,j) + &
+! A(i,4)*B3(4,j) + &
+! A(i,5)*B3(5,j)
+!
+! enddo
+! enddo
+!
+! end subroutine old_mxm_m1_m2_5points
+!
+!!---------
+!
+! subroutine old_mxm_m1_m1_5points(A1,A2,A3,B,C1,C2,C3)
+!
+! implicit none
+!
+! include "constants.h"
+!
+! real(kind=4), dimension(m1,NGLLX) :: A1,A2,A3
+! real(kind=4), dimension(NGLLX,m1) :: B
+! real(kind=4), dimension(m1,m1) :: C1,C2,C3
+!
+! integer :: i,j
+!
+! do j=1,m1
+! do i=1,m1
+!
+! C1(i,j) = A1(i,1)*B(1,j) + &
+! A1(i,2)*B(2,j) + &
+! A1(i,3)*B(3,j) + &
+! A1(i,4)*B(4,j) + &
+! A1(i,5)*B(5,j)
+!
+! C2(i,j) = A2(i,1)*B(1,j) + &
+! A2(i,2)*B(2,j) + &
+! A2(i,3)*B(3,j) + &
+! A2(i,4)*B(4,j) + &
+! A2(i,5)*B(5,j)
+!
+! C3(i,j) = A3(i,1)*B(1,j) + &
+! A3(i,2)*B(2,j) + &
+! A3(i,3)*B(3,j) + &
+! A3(i,4)*B(4,j) + &
+! A3(i,5)*B(5,j)
+!
+! enddo
+! enddo
+!
+! end subroutine old_mxm_m1_m1_5points
+!
+!!---------
+!
+! subroutine old_mxm_m2_m1_5points(A1,A2,A3,B,C1,C2,C3)
+!
+! implicit none
+!
+! include "constants.h"
+!
+! real(kind=4), dimension(m2,NGLLX) :: A1,A2,A3
+! real(kind=4), dimension(NGLLX,m1) :: B
+! real(kind=4), dimension(m2,m1) :: C1,C2,C3
+!
+! integer :: i,j
+!
+! do j=1,m1
+! do i=1,m2
+!
+! C1(i,j) = A1(i,1)*B(1,j) + &
+! A1(i,2)*B(2,j) + &
+! A1(i,3)*B(3,j) + &
+! A1(i,4)*B(4,j) + &
+! A1(i,5)*B(5,j)
+!
+! C2(i,j) = A2(i,1)*B(1,j) + &
+! A2(i,2)*B(2,j) + &
+! A2(i,3)*B(3,j) + &
+! A2(i,4)*B(4,j) + &
+! A2(i,5)*B(5,j)
+!
+! C3(i,j) = A3(i,1)*B(1,j) + &
+! A3(i,2)*B(2,j) + &
+! A3(i,3)*B(3,j) + &
+! A3(i,4)*B(4,j) + &
+! A3(i,5)*B(5,j)
+!
+! enddo
+! enddo
+!
+! end subroutine old_mxm_m2_m1_5points
+!
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/constants.h.in
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/constants.h.in 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/constants.h.in 2009-10-20 02:18:56 UTC (rev 15850)
@@ -56,6 +56,9 @@
integer, parameter :: NGLLY = NGLLX
integer, parameter :: NGLLZ = NGLLX
+! number of points per surface element
+ integer, parameter :: NGLLSQUARE = NGLLX * NGLLY
+
! for optimized routines by Deville et al. (2002)
integer, parameter :: m1 = NGLLX, m2 = NGLLX * NGLLY
@@ -85,6 +88,15 @@
! was found by trial and error
double precision, parameter :: SOURCE_DECAY_MIMIC_TRIANGLE = 1.628d0
+! decide if master process writes all the seismograms or if all processes do it in parallel
+ logical, parameter :: WRITE_SEISMOGRAMS_BY_MASTER = .false.
+
+! use directory OUTPUT_FILES/ for seismogram output
+ logical,parameter :: USE_OUTPUT_FILES_PATH = .true.
+
+! absorb top surface ( defined in mesh as 'free_surface_file' )
+ logical,parameter :: ABSORB_FREE_SURFACE = .false.
+
! ---------------------------------------------------------------------------------------
! LQY -- Following 3 variables stays here temporarily,
! we need to move them to Par_file at a proper time
@@ -105,8 +117,6 @@
! nlegoff -- Variables that should be read/computed elsewhere.
! Temporarily declared here.
!------------------------------------------------------
-! whether or not an external mesh is used (provided by CUBIT for example)
- logical, parameter :: USE_EXTERNAL_MESH = .true.
! no lagrange interpolation on seismograms (we take the value on one NGLL point)
logical, parameter :: FASTER_RECEIVERS_POINTS_ONLY = .false.
@@ -268,4 +278,8 @@
! double precision, parameter :: ORIG_Y_BASEMENT = 3655000.
! double precision, parameter :: SPACING_X_BASEMENT = 1000.
! double precision, parameter :: SPACING_Y_BASEMENT = 1000.
+!
+! SPECFEM3D_SESAME needs external mesh from now on...
+! whether or not an external mesh is used (provided by CUBIT for example)
+! logical, parameter :: USE_EXTERNAL_MESH = .true.
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/create_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/create_header_file.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/create_header_file.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -38,8 +38,8 @@
! parameters to be computed based upon parameters above read from file
integer NPROC
- integer NSPEC_AB, &
- NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,NGLOB_AB
+ integer NSPEC_AB, NGLOB_AB
+ ! NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,
double precision DT,HDUR_MOVIE
@@ -73,7 +73,7 @@
! create include file for the solver
call save_header_file(NSPEC_AB,NGLOB_AB,NPROC, &
ATTENUATION,ANISOTROPY,NSTEP,DT, &
- NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,SIMULATION_TYPE,0.d0)
+ SIMULATION_TYPE,0.d0)
print *
print *,'edit file OUTPUT_FILES/values_from_mesher.h to see some statistics about the mesh'
print *
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/create_movie_shakemap_AVS_DX_GMT.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/create_movie_shakemap_AVS_DX_GMT.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/create_movie_shakemap_AVS_DX_GMT.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -37,9 +37,6 @@
! number of points in each AVS or OpenDX quadrangular cell for movies
integer, parameter :: NGNOD2D_AVS_DX = 4
-! number of points per surface element
- integer, parameter :: NGLLSQUARE = NGLLX * NGLLY
-
! threshold in percent of the maximum below which we cut the amplitude
logical, parameter :: APPLY_THRESHOLD = .true.
real(kind=CUSTOM_REAL), parameter :: THRESHOLD = 1._CUSTOM_REAL / 100._CUSTOM_REAL
@@ -66,6 +63,7 @@
! for sorting routine
integer npointot,ilocnum,nglob,i,j,ielm,ieoff,ispecloc
+! integer k
integer, dimension(:), allocatable :: iglob,loc,ireorder
logical, dimension(:), allocatable :: ifseg,mask_point
double precision, dimension(:), allocatable :: xp,yp,zp,xp_save,yp_save,zp_save,field_display
@@ -76,44 +74,69 @@
store_val_ux,store_val_uy,store_val_uz
! parameters read from parameter file
- integer NER_SEDIM,NER_BASEMENT_SEDIM,NER_16_BASEMENT, &
- NER_MOHO_16,NER_BOTTOM_MOHO,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE,SIMULATION_TYPE
+! integer NER_SEDIM,NER_BASEMENT_SEDIM,NER_16_BASEMENT, &
+! NER_MOHO_16,NER_BOTTOM_MOHO,NEX_XI,NEX_ETA
+
+ integer NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE,SIMULATION_TYPE
integer NSOURCES
logical MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
- USE_HIGHRES_FOR_MOVIES,SUPPRESS_UTM_PROJECTION,USE_REGULAR_MESH
+ USE_HIGHRES_FOR_MOVIES,SUPPRESS_UTM_PROJECTION
+! logical USE_REGULAR_MESH
integer NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
- double precision UTM_X_MIN,UTM_X_MAX,UTM_Y_MIN,UTM_Y_MAX,Z_DEPTH_BLOCK
- double precision DT,LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN,LONGITUDE_MAX,HDUR_MOVIE
- double precision THICKNESS_TAPER_BLOCK_HR,THICKNESS_TAPER_BLOCK_MR,VP_MIN_GOCAD,VP_VS_RATIO_GOCAD_TOP,VP_VS_RATIO_GOCAD_BOTTOM
+! double precision UTM_X_MIN,UTM_X_MAX,UTM_Y_MIN,UTM_Y_MAX,Z_DEPTH_BLOCK
+ double precision DT
+! double precision LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN,LONGITUDE_MAX
+ double precision HDUR_MOVIE
+! double precision THICKNESS_TAPER_BLOCK_HR,THICKNESS_TAPER_BLOCK_MR,&
+! VP_MIN_GOCAD,VP_VS_RATIO_GOCAD_TOP,VP_VS_RATIO_GOCAD_BOTTOM
- logical HARVARD_3D_GOCAD_MODEL,TOPOGRAPHY,ATTENUATION,USE_OLSEN_ATTENUATION, &
- OCEANS,IMPOSE_MINIMUM_VP_GOCAD,HAUKSSON_REGIONAL_MODEL, &
- BASEMENT_MAP,MOHO_MAP_LUPEI,ABSORBING_CONDITIONS,SAVE_FORWARD
+! logical HARVARD_3D_GOCAD_MODEL,
+ logical TOPOGRAPHY,ATTENUATION,USE_OLSEN_ATTENUATION, &
+ OCEANS
+! logical IMPOSE_MINIMUM_VP_GOCAD,HAUKSSON_REGIONAL_MODEL, &
+! BASEMENT_MAP,MOHO_MAP_LUPEI,
+ logical ABSORBING_CONDITIONS,SAVE_FORWARD
logical ANISOTROPY,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION
- character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL
+ character(len=150) OUTPUT_FILES,LOCAL_PATH
+! character(len=150) MODEL
! parameters deduced from parameters read from file
- integer NPROC,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
- integer NER
+ integer NPROC
+! integer NEX_PER_PROC_XI,NEX_PER_PROC_ETA
+! integer NER
- integer NSPEC_AB,NSPEC2D_A_XI,NSPEC2D_B_XI, &
- NSPEC2D_A_ETA,NSPEC2D_B_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,NGLOB_AB
+! integer NSPEC_AB
+! integer NSPEC2D_A_XI,NSPEC2D_B_XI, &
+! NSPEC2D_A_ETA,NSPEC2D_B_ETA
+! integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
+! NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+! NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX
+! integer NGLOB_AB
+!--------------------------------------------
!!!! NL NL for external meshes
+!--------------------------------------------
+ ! muting source region
real(kind=CUSTOM_REAL), parameter :: RADIUS_TO_MUTE = 1000._CUSTOM_REAL
logical, parameter :: MUTE_SOURCE = .true.
real(kind=CUSTOM_REAL), parameter :: X_SOURCE_EXT_MESH = -9023.021484375
real(kind=CUSTOM_REAL), parameter :: Y_SOURCE_EXT_MESH = 6123.611328125
real(kind=CUSTOM_REAL), parameter :: Z_SOURCE_EXT_MESH = 17.96331405639648
- integer, parameter :: NSPEC_SURFACE_EXT_MESH = 15808*4
+ ! movie arrays (store_val_x_all_external_mesh) size
+! integer, parameter :: NSPEC_SURFACE_EXT_MESH = 15808*4
+
+ ! total number of spectral elements at surface
+ integer, parameter :: NSPEC_SURFACE_EXT_MESH = 7650 ! movie: nfaces_surface_glob_ext_mesh
+
+ ! order of points representing the 2D square element
+ integer,dimension(NGNOD2D_AVS_DX),parameter :: iorder = (/1,3,2,4/)
+ integer,dimension(NGNOD2D_AVS_DX),parameter :: iorder2 = (/1,3,4,2/)
+
+!--------------------------------------------
!!!! NL NL
! ************** PROGRAM STARTS HERE **************
@@ -127,28 +150,41 @@
print *
! read the parameter file
- call read_parameter_file(LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN,LONGITUDE_MAX, &
- UTM_X_MIN,UTM_X_MAX,UTM_Y_MIN,UTM_Y_MAX,Z_DEPTH_BLOCK, &
- NER_SEDIM,NER_BASEMENT_SEDIM,NER_16_BASEMENT,NER_MOHO_16,NER_BOTTOM_MOHO, &
- NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE,DT, &
- ATTENUATION,USE_OLSEN_ATTENUATION,HARVARD_3D_GOCAD_MODEL,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
- THICKNESS_TAPER_BLOCK_HR,THICKNESS_TAPER_BLOCK_MR,VP_MIN_GOCAD,VP_VS_RATIO_GOCAD_TOP,VP_VS_RATIO_GOCAD_BOTTOM, &
- OCEANS,IMPOSE_MINIMUM_VP_GOCAD,HAUKSSON_REGIONAL_MODEL,ANISOTROPY, &
- BASEMENT_MAP,MOHO_MAP_LUPEI,ABSORBING_CONDITIONS, &
+ !call read_parameter_file(LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN,LONGITUDE_MAX, &
+ ! UTM_X_MIN,UTM_X_MAX,UTM_Y_MIN,UTM_Y_MAX,Z_DEPTH_BLOCK, &
+ ! NER_SEDIM,NER_BASEMENT_SEDIM,NER_16_BASEMENT,NER_MOHO_16,NER_BOTTOM_MOHO, &
+ ! NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE,DT, &
+ ! ATTENUATION,USE_OLSEN_ATTENUATION,HARVARD_3D_GOCAD_MODEL,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
+ ! THICKNESS_TAPER_BLOCK_HR,THICKNESS_TAPER_BLOCK_MR,VP_MIN_GOCAD,VP_VS_RATIO_GOCAD_TOP,VP_VS_RATIO_GOCAD_BOTTOM, &
+ ! OCEANS,IMPOSE_MINIMUM_VP_GOCAD,HAUKSSON_REGIONAL_MODEL,ANISOTROPY, &
+ ! BASEMENT_MAP,MOHO_MAP_LUPEI,ABSORBING_CONDITIONS, &
+ ! MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ ! NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
+ ! SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
+ ! NTSTEP_BETWEEN_OUTPUT_INFO,SUPPRESS_UTM_PROJECTION,MODEL,USE_REGULAR_MESH,SIMULATION_TYPE,SAVE_FORWARD)
+
+ call read_parameter_file( &
+ NPROC,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ ATTENUATION,USE_OLSEN_ATTENUATION,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
+ OCEANS,ANISOTROPY,ABSORBING_CONDITIONS, &
MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
- NTSTEP_BETWEEN_OUTPUT_INFO,SUPPRESS_UTM_PROJECTION,MODEL,USE_REGULAR_MESH,SIMULATION_TYPE,SAVE_FORWARD)
+ NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
+
! compute other parameters based upon values read
- call compute_parameters(NER,NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA, &
- NPROC,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NER_BOTTOM_MOHO,NER_MOHO_16,NER_16_BASEMENT,NER_BASEMENT_SEDIM,NER_SEDIM, &
- NSPEC_AB,NSPEC2D_A_XI,NSPEC2D_B_XI, &
- NSPEC2D_A_ETA,NSPEC2D_B_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,NGLOB_AB,USE_REGULAR_MESH)
-
+! if( .not. USE_EXTERNAL_MESH ) then
+! call compute_parameters(NER,NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA, &
+! NPROC,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+! NER_BOTTOM_MOHO,NER_MOHO_16,NER_16_BASEMENT,NER_BASEMENT_SEDIM,NER_SEDIM, &
+! NSPEC_AB,NSPEC2D_A_XI,NSPEC2D_B_XI, &
+! NSPEC2D_A_ETA,NSPEC2D_B_ETA, &
+! NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+! NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,NGLOB_AB,USE_REGULAR_MESH)
+! endif
+
! get the base pathname for output files
call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
@@ -164,6 +200,7 @@
print *
NPROC = 1
+
if(USE_HIGHRES_FOR_MOVIES) then
ilocnum = NSPEC_SURFACE_EXT_MESH*NGLLSQUARE
else
@@ -243,6 +280,7 @@
endif
iscaling_shake = 0
+
if(plot_shaking_map) then
print *
print *,'norm to display in shaking map:'
@@ -250,13 +288,16 @@
print *
read(5,*) inorm
if(inorm < 1 .or. inorm > 3) stop 'incorrect value of inorm'
-
print *
print *,'apply non-linear scaling to shaking map:'
print *,'1=non-linear 2=no scaling'
print *
read(5,*) iscaling_shake
if(iscaling_shake < 1 .or. iscaling_shake > 2) stop 'incorrect value of iscaling_shake'
+ else
+ print *
+ print *,'movie data:'
+ print *,' norm of velocity vector will be displayed'
endif
! define the total number of elements at the surface
@@ -371,17 +412,17 @@
display(i,j) = 0.
else
- if(inorm == 1) then
- display(i,j) = vectorx
- else if(inorm == 2) then
- display(i,j) = vectory
- else
- display(i,j) = vectorz
+ if(inorm == 1) then
+ display(i,j) = vectorx
+ else if(inorm == 2) then
+ display(i,j) = vectory
+ else
+ display(i,j) = vectorz
+ endif
endif
+ else
+ display(i,j) = sqrt(vectorz**2+vectory**2+vectorx**2)
endif
- else
- display(i,j) = sqrt(vectorz**2+vectory**2+vectorx**2)
- endif
enddo
enddo
@@ -394,22 +435,39 @@
do i = 1,NGLLX-1
ieoff = NGNOD2D_AVS_DX*(ielm+(i-1)+(j-1)*(NGLLX-1))
do ilocnum = 1,NGNOD2D_AVS_DX
+! do k = 1,NGNOD2D_AVS_DX
+
if(ilocnum == 1) then
xp(ieoff+ilocnum) = dble(x(i,j))
yp(ieoff+ilocnum) = dble(y(i,j))
zp(ieoff+ilocnum) = dble(z(i,j))
field_display(ieoff+ilocnum) = dble(display(i,j))
elseif(ilocnum == 2) then
+
+! accounts for different ordering of square points
+ xp(ieoff+ilocnum) = dble(x(i+1,j+1))
+ yp(ieoff+ilocnum) = dble(y(i+1,j+1))
+ zp(ieoff+ilocnum) = dble(z(i+1,j+1))
+ field_display(ieoff+ilocnum) = dble(display(i+1,j+1))
+
+! xp(ieoff+ilocnum) = dble(x(i+1,j))
+! yp(ieoff+ilocnum) = dble(y(i+1,j))
+! zp(ieoff+ilocnum) = dble(z(i+1,j))
+! field_display(ieoff+ilocnum) = dble(display(i+1,j))
+
+ elseif(ilocnum == 3) then
+
+! accounts for different ordering of square points
xp(ieoff+ilocnum) = dble(x(i+1,j))
yp(ieoff+ilocnum) = dble(y(i+1,j))
zp(ieoff+ilocnum) = dble(z(i+1,j))
field_display(ieoff+ilocnum) = dble(display(i+1,j))
- elseif(ilocnum == 3) then
- xp(ieoff+ilocnum) = dble(x(i+1,j+1))
- yp(ieoff+ilocnum) = dble(y(i+1,j+1))
- zp(ieoff+ilocnum) = dble(z(i+1,j+1))
- field_display(ieoff+ilocnum) = dble(display(i+1,j+1))
+
+! xp(ieoff+ilocnum) = dble(x(i+1,j+1))
+! yp(ieoff+ilocnum) = dble(y(i+1,j+1))
+! zp(ieoff+ilocnum) = dble(z(i+1,j+1))
+! field_display(ieoff+ilocnum) = dble(display(i+1,j+1))
else
xp(ieoff+ilocnum) = dble(x(i,j+1))
yp(ieoff+ilocnum) = dble(y(i,j+1))
@@ -418,6 +476,14 @@
endif
enddo
+
+ !if( j==1 .and. ispec==1) then
+ !print*,'p1',xp(ieoff+1),yp(ieoff+1),zp(ieoff+1)
+ !print*,'p2',xp(ieoff+2),yp(ieoff+2),zp(ieoff+2)
+ !print*,'p3',xp(ieoff+3),yp(ieoff+3),zp(ieoff+3)
+ !print*,'p4',xp(ieoff+4),yp(ieoff+4),zp(ieoff+4)
+ !endif
+
enddo
enddo
@@ -427,8 +493,11 @@
ieoff = NGNOD2D_AVS_DX*(ispec-1)
! four points for each element
- do ilocnum = 1,NGNOD2D_AVS_DX
+ do i = 1,NGNOD2D_AVS_DX
+ ! accounts for different ordering of square points
+ ilocnum = iorder(i)
+
ipoin = ipoin + 1
xcoord = store_val_x(ipoin,iproc)
@@ -439,6 +508,7 @@
vectory = store_val_uy(ipoin,iproc)
vectorz = store_val_uz(ipoin,iproc)
+
xp(ilocnum+ieoff) = dble(xcoord)
yp(ilocnum+ieoff) = dble(ycoord)
zp(ilocnum+ieoff) = dble(zcoord)
@@ -448,25 +518,23 @@
! for shaking map, norm of U stored in ux, V in uy and A in uz
if(plot_shaking_map) then
!!!! NL NL mute value near source
- if ( (sqrt(((dble(xcoord) - (X_SOURCE_EXT_MESH))**2 + &
+ if ( (sqrt(((dble(xcoord) - (X_SOURCE_EXT_MESH))**2 + &
(dble(ycoord) - (Y_SOURCE_EXT_MESH))**2 + &
(dble(zcoord) - (Z_SOURCE_EXT_MESH))**2)) < RADIUS_TO_MUTE) &
.and. MUTE_SOURCE) then
-
field_display(ilocnum+ieoff) = 0.
+ else
+ if(inorm == 1) then
+ field_display(ilocnum+ieoff) = dble(vectorx)
+ else if(inorm == 2) then
+ field_display(ilocnum+ieoff) = dble(vectory)
else
-
-
- if(inorm == 1) then
- field_display(ilocnum+ieoff) = dble(vectorx)
- else if(inorm == 2) then
- field_display(ilocnum+ieoff) = dble(vectory)
- else
- field_display(ilocnum+ieoff) = dble(vectorz)
+ field_display(ilocnum+ieoff) = dble(vectorz)
+ endif
endif
- endif
else
- field_display(ilocnum+ieoff) =sqrt(vectorz**2+vectory**2+vectorx**2)
+ ! takes norm of velocity vector
+ field_display(ilocnum+ieoff) =sqrt(vectorz**2+vectory**2+vectorx**2)
endif
enddo
@@ -509,14 +577,14 @@
if(plot_shaking_map) then
! compute min and max of data value to normalize
- min_field_current = minval(field_display(:))
- max_field_current = maxval(field_display(:))
+ min_field_current = minval(field_display(:))
+ max_field_current = maxval(field_display(:))
! print minimum and maximum amplitude in current snapshot
- print *
- print *,'minimum amplitude in current snapshot after removal = ',min_field_current
- print *,'maximum amplitude in current snapshot after removal = ',max_field_current
- print *
+ print *
+ print *,'minimum amplitude in current snapshot after removal = ',min_field_current
+ print *,'maximum amplitude in current snapshot after removal = ',max_field_current
+ print *
endif
@@ -530,34 +598,34 @@
! this assumption works only for fields that can be negative
! would not work for norm of vector for instance
! (we would lose half of the color palette if no negative values)
- max_absol = max(abs(min_field_current),abs(max_field_current))
- min_field_current = - max_absol
- max_field_current = + max_absol
+ max_absol = max(abs(min_field_current),abs(max_field_current))
+ min_field_current = - max_absol
+ max_field_current = + max_absol
! normalize field to [0:1]
- field_display(:) = (field_display(:) - min_field_current) / (max_field_current - min_field_current)
+ field_display(:) = (field_display(:) - min_field_current) / (max_field_current - min_field_current)
! rescale to [-1,1]
- field_display(:) = 2.*field_display(:) - 1.
+ field_display(:) = 2.*field_display(:) - 1.
! apply threshold to normalized field
- if(APPLY_THRESHOLD) &
- where(abs(field_display(:)) <= THRESHOLD) field_display = 0.
+ if(APPLY_THRESHOLD) &
+ where(abs(field_display(:)) <= THRESHOLD) field_display = 0.
! apply non linear scaling to normalized field if needed
- if(NONLINEAR_SCALING) then
- where(field_display(:) >= 0.)
- field_display = field_display ** POWER_SCALING
- elsewhere
- field_display = - abs(field_display) ** POWER_SCALING
- endwhere
- endif
+ if(NONLINEAR_SCALING) then
+ where(field_display(:) >= 0.)
+ field_display = field_display ** POWER_SCALING
+ elsewhere
+ field_display = - abs(field_display) ** POWER_SCALING
+ endwhere
+ endif
! map back to [0,1]
- field_display(:) = (field_display(:) + 1.) / 2.
+ field_display(:) = (field_display(:) + 1.) / 2.
! map field to [0:255] for AVS color scale
- field_display(:) = 255. * field_display(:)
+ field_display(:) = 255. * field_display(:)
! apply scaling only if selected for shaking map
@@ -565,25 +633,25 @@
else if(NONLINEAR_SCALING .and. iscaling_shake == 1) then
! normalize field to [0:1]
- field_display(:) = field_display(:) / max_field_current
+ field_display(:) = field_display(:) / max_field_current
! apply non linear scaling to normalized field
- field_display = field_display ** POWER_SCALING
+ field_display = field_display ** POWER_SCALING
! map field to [0:255] for AVS color scale
- field_display(:) = 255. * field_display(:)
+ field_display(:) = 255. * field_display(:)
endif
!--- ****** create AVS file using sorted list ******
if(.not. plot_shaking_map) then
- if(inumber == 1) then
- ivalue = iframe
- else
- ivalue = it
+ if(inumber == 1) then
+ ivalue = iframe
+ else
+ ivalue = it
+ endif
endif
- endif
! create file name and open file
if(plot_shaking_map) then
@@ -634,7 +702,7 @@
if(USE_OPENDX) then
write(11,*) xp_save(ilocnum+ieoff),yp_save(ilocnum+ieoff),zp_save(ilocnum+ieoff)
else if(USE_AVS) then
- write(11,*) ireorder(ibool_number),xp_save(ilocnum+ieoff), &
+ write(11,'(i,3f)') ireorder(ibool_number),xp_save(ilocnum+ieoff), &
yp_save(ilocnum+ieoff),zp_save(ilocnum+ieoff)
endif
endif
@@ -663,53 +731,53 @@
endif
enddo
- if(USE_OPENDX) then
- write(11,*) 'attribute "element type" string "quads"'
- write(11,*) 'attribute "ref" string "positions"'
- write(11,*) 'object 3 class array type float rank 0 items ',nglob,' data follows'
- else
+ if(USE_OPENDX) then
+ write(11,*) 'attribute "element type" string "quads"'
+ write(11,*) 'attribute "ref" string "positions"'
+ write(11,*) 'object 3 class array type float rank 0 items ',nglob,' data follows'
+ else
! dummy text for labels
- write(11,*) '1 1'
- write(11,*) 'a, b'
- endif
+ write(11,*) '1 1'
+ write(11,*) 'a, b'
+ endif
! output data values
- mask_point = .false.
+ mask_point = .false.
! output point data
- do ispec=1,nspectot_AVS_max
- ieoff = NGNOD2D_AVS_DX*(ispec-1)
+ do ispec=1,nspectot_AVS_max
+ ieoff = NGNOD2D_AVS_DX*(ispec-1)
! four points for each element
- do ilocnum = 1,NGNOD2D_AVS_DX
- ibool_number = iglob(ilocnum+ieoff)
- if(.not. mask_point(ibool_number)) then
- if(USE_OPENDX) then
- if(plot_shaking_map) then
- write(11,*) sngl(field_display(ilocnum+ieoff))
+ do ilocnum = 1,NGNOD2D_AVS_DX
+ ibool_number = iglob(ilocnum+ieoff)
+ if(.not. mask_point(ibool_number)) then
+ if(USE_OPENDX) then
+ if(plot_shaking_map) then
+ write(11,*) sngl(field_display(ilocnum+ieoff))
+ else
+ write(11,"(f7.2)") field_display(ilocnum+ieoff)
+ endif
else
- write(11,"(f7.2)") field_display(ilocnum+ieoff)
+ if(plot_shaking_map) then
+ write(11,*) ireorder(ibool_number),field_display(ilocnum+ieoff)
+ else
+ write(11,"(i10,1x,f7.2)") ireorder(ibool_number),field_display(ilocnum+ieoff)
+ endif
endif
- else
- if(plot_shaking_map) then
- write(11,*) ireorder(ibool_number),field_display(ilocnum+ieoff)
- else
- write(11,"(i10,1x,f7.2)") ireorder(ibool_number),field_display(ilocnum+ieoff)
- endif
endif
- endif
- mask_point(ibool_number) = .true.
+ mask_point(ibool_number) = .true.
+ enddo
enddo
- enddo
! define OpenDX field
- if(USE_OPENDX) then
- write(11,*) 'attribute "dep" string "positions"'
- write(11,*) 'object "irregular positions irregular connections" class field'
- write(11,*) 'component "positions" value 1'
- write(11,*) 'component "connections" value 2'
- write(11,*) 'component "data" value 3'
- write(11,*) 'end'
- endif
+ if(USE_OPENDX) then
+ write(11,*) 'attribute "dep" string "positions"'
+ write(11,*) 'object "irregular positions irregular connections" class field'
+ write(11,*) 'component "positions" value 1'
+ write(11,*) 'component "connections" value 2'
+ write(11,*) 'component "data" value 3'
+ write(11,*) 'end'
+ endif
! end of test for GMT format
endif
@@ -718,7 +786,7 @@
! end of loop and test on all the time steps for all the movie images
endif
- enddo
+ enddo ! it
print *
print *,'done creating movie or shaking map'
@@ -769,6 +837,9 @@
include "constants.h"
+! number of points in each AVS or OpenDX quadrangular cell for movies
+ integer, parameter :: NGNOD2D_AVS_DX = 4
+
! geometry tolerance parameter to calculate number of independent grid points
! small value for double precision and to avoid sensitivity to roundoff
double precision SMALLVALTOL
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -25,16 +25,21 @@
subroutine create_regions_mesh_ext_mesh(ibool, &
- xstore,ystore,zstore,nspec,npointot,myrank,LOCAL_PATH, &
- nnodes_ext_mesh,nelmnts_ext_mesh, &
- nodes_coords_ext_mesh, elmnts_ext_mesh, max_static_memory_size, mat_ext_mesh, materials_ext_mesh, &
- nmat_ext_mesh, undef_mat_prop, nundefMat_ext_mesh, ninterface_ext_mesh, max_interface_size_ext_mesh, &
- my_neighbours_ext_mesh, my_nelmnts_neighbours_ext_mesh, my_interfaces_ext_mesh, &
- ibool_interfaces_ext_mesh, nibool_interfaces_ext_mesh, &
- nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, nspec2D_ymax, NSPEC2D_BOTTOM, NSPEC2D_TOP,&
- NSPEC2DMAX_XMIN_XMAX, NSPEC2DMAX_YMIN_YMAX, &
- ibelm_xmin, ibelm_xmax, ibelm_ymin, ibelm_ymax, ibelm_bottom, ibelm_top, &
- SAVE_MESH_FILES,nglob)
+ xstore,ystore,zstore,nspec,npointot,myrank,LOCAL_PATH, &
+ nnodes_ext_mesh,nelmnts_ext_mesh, &
+ nodes_coords_ext_mesh, elmnts_ext_mesh, &
+ max_static_memory_size, mat_ext_mesh, materials_ext_mesh, &
+ nmat_ext_mesh, undef_mat_prop, nundefMat_ext_mesh, &
+ ninterface_ext_mesh, max_interface_size_ext_mesh, &
+ my_neighbours_ext_mesh, my_nelmnts_neighbours_ext_mesh, &
+ my_interfaces_ext_mesh, &
+ ibool_interfaces_ext_mesh, nibool_interfaces_ext_mesh, &
+ nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, nspec2D_ymax, &
+ NSPEC2D_BOTTOM, NSPEC2D_TOP,&
+ ibelm_xmin, ibelm_xmax, ibelm_ymin, ibelm_ymax, ibelm_bottom, ibelm_top, &
+ nodes_ibelm_xmin,nodes_ibelm_xmax,nodes_ibelm_ymin,nodes_ibelm_ymax,&
+ nodes_ibelm_bottom,nodes_ibelm_top, &
+ SAVE_MESH_FILES,nglob)
! create the different regions of the mesh
@@ -81,29 +86,34 @@
! absorbing boundaries
integer :: nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, nspec2D_ymax, NSPEC2D_BOTTOM, NSPEC2D_TOP
- integer :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
+! integer :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
integer, dimension(nspec2D_xmin) :: ibelm_xmin
integer, dimension(nspec2D_xmax) :: ibelm_xmax
integer, dimension(nspec2D_ymin) :: ibelm_ymin
integer, dimension(nspec2D_ymax) :: ibelm_ymax
integer, dimension(NSPEC2D_BOTTOM) :: ibelm_bottom
integer, dimension(NSPEC2D_TOP) :: ibelm_top
+ ! node indices of boundary faces
+ integer, dimension(4,nspec2D_xmin) :: nodes_ibelm_xmin
+ integer, dimension(4,nspec2D_xmax) :: nodes_ibelm_xmax
+ integer, dimension(4,nspec2D_ymin) :: nodes_ibelm_ymin
+ integer, dimension(4,nspec2D_ymax) :: nodes_ibelm_ymax
+ integer, dimension(4,NSPEC2D_BOTTOM) :: nodes_ibelm_bottom
+ integer, dimension(4,NSPEC2D_TOP) :: nodes_ibelm_top
logical :: SAVE_MESH_FILES
integer :: nglob
-!-------------------------------------------------------------------------------------------------
+
! local parameters
!-----------------------
- integer, dimension(:,:), allocatable :: nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta
- integer :: ispec2D,iflag,flag_below,flag_above
-
! for MPI buffers
- integer, dimension(:), allocatable :: reorder_interface_ext_mesh,ind_ext_mesh,ninseg_ext_mesh,iwork_ext_mesh
- integer, dimension(:), allocatable :: nibool_interfaces_ext_mesh_true
+! integer, dimension(:), allocatable :: reorder_interface_ext_mesh,ind_ext_mesh,ninseg_ext_mesh,iwork_ext_mesh
+! integer, dimension(:), allocatable :: nibool_interfaces_ext_mesh_true
!integer, dimension(:,:), allocatable :: ibool_interfaces_ext_mesh_dummy
- integer, dimension(:), allocatable :: ibool_interface_ext_mesh_dummy
- double precision, dimension(:), allocatable :: work_ext_mesh
+! integer, dimension(:), allocatable :: ibool_interface_ext_mesh_dummy
+! double precision, dimension(:), allocatable :: work_ext_mesh
+
real(kind=CUSTOM_REAL), dimension(:), allocatable :: xstore_dummy
real(kind=CUSTOM_REAL), dimension(:), allocatable :: ystore_dummy
real(kind=CUSTOM_REAL), dimension(:), allocatable :: zstore_dummy
@@ -120,66 +130,78 @@
! static memory size needed by the solver
double precision :: static_memory_size
-! the jacobian
- real(kind=CUSTOM_REAL) :: jacobianl
-
! arrays with mesh parameters
real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: xixstore,xiystore,xizstore, &
etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore,jacobianstore
! for model density
real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rhostore,kappastore,mustore,vpstore,vsstore
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass
! attenuation
integer, dimension(:,:,:,:), allocatable :: iflag_attenuation_store
-! check area and volume of the final mesh
- double precision :: weight
+! 2D shape functions and their derivatives, weights
+ double precision, dimension(:,:,:), allocatable :: shape2D_x,shape2D_y,shape2D_bottom,shape2D_top
+ double precision, dimension(:,:,:,:), allocatable :: dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top
+ double precision, dimension(:,:), allocatable :: wgllwgll_xy,wgllwgll_xz,wgllwgll_yz
+! absorbing boundaries
+! pll
+! logical, dimension(:,:),allocatable :: iboun
+! real(kind=CUSTOM_REAL), dimension(:,:,:),allocatable :: xcoord_iboun,ycoord_iboun,zcoord_iboun
+! 2-D jacobians and normals
+! real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: &
+! jacobian2D_xmin,jacobian2D_xmax, &
+! jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_top
+
+! real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+! normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_top
+
+! ! local indices i,j,k of all GLL points on xmin boundary in the element
+! integer,dimension(:,:,:,:),allocatable :: ibelm_gll_xmin,ibelm_gll_xmax, &
+! ibelm_gll_ymin,ibelm_gll_ymax, &
+! ibelm_gll_bottom,ibelm_gll_top
+! integer, dimension(:,:), allocatable :: nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta
+
+! absorbing boundary arrays (for all boundaries) - keeps all infos, allowing for irregular surfaces
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: absorbing_boundary_normal
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: absorbing_boundary_jacobian2D
+ integer, dimension(:,:,:), allocatable :: absorbing_boundary_ijk
+ integer, dimension(:), allocatable :: absorbing_boundary_ispec
+ integer :: num_absorbing_boundary_faces
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_vp,rho_vs
+
! variables for creating array ibool (some arrays also used for AVS or DX files)
- integer, dimension(:), allocatable :: iglob,locval
- logical, dimension(:), allocatable :: ifseg
- double precision, dimension(:), allocatable :: xp,yp,zp
+! integer, dimension(:), allocatable :: locval !,iglob
+! logical, dimension(:), allocatable :: ifseg
+! double precision, dimension(:), allocatable :: xp,yp,zp
- integer :: ieoff,ilocnum,ier,iinterface
+! integer :: ilocnum,ier,iinterface !,ieoff
+ integer, dimension(:), allocatable :: elem_flag
+ integer :: ier
+ integer :: i,j,k,ispec,iglobnum
+! integer :: ispec2D
-! mass matrix
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass
-
! name of the database file
character(len=150) prname
+ character(len=150) prname_file
- integer :: i,j,k,ia,ispec,iglobnum
-
! mask to sort ibool
- integer, dimension(:), allocatable :: mask_ibool
- integer, dimension(:,:,:,:), allocatable :: copy_ibool_ori
- integer :: inumber
-
-! pll
- integer :: iundef
- logical, dimension(6,nspec) :: iboun
-
-! 2D shape functions and their derivatives
- double precision, dimension(:,:,:), allocatable :: shape2D_x,shape2D_y,shape2D_bottom,shape2D_top
- double precision, dimension(:,:,:,:), allocatable :: dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top
-
-
- ! 2-D jacobians and normals
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: &
- jacobian2D_xmin,jacobian2D_xmax, &
- jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom,jacobian2D_top
+! integer, dimension(:), allocatable :: mask_ibool
+! integer, dimension(:,:,:,:), allocatable :: copy_ibool_ori
+! integer :: inumber
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
- normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top
-
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_vp,rho_vs
-
! memory test
- logical,dimension(:),allocatable :: test_mem
+! logical,dimension(:),allocatable :: test_mem
- character(len=150) prname_file
+! for vtk output
+! integer,dimension(:),allocatable :: itest_flag
! For Piero Basini :
! integer :: doubling_value_found_for_Piero
@@ -221,25 +243,19 @@
endif
! tests memory availability (including some small buffer of 10*1024 byte)
- allocate( test_mem(int(max_static_memory_size)+10*1024),stat=ier)
- if(ier /= 0) then
- write(IMAIN,*) 'error: try to increase the available process stack size by'
- write(IMAIN,*) ' ulimit -s **** '
- call exit_MPI(myrank,'not enough memory to allocate arrays')
- endif
- test_mem(:) = .true.
- deallocate( test_mem, stat=ier)
- if(ier /= 0) call exit_MPI(myrank,'error to allocate arrays')
- call sync_all()
+! allocate( test_mem(int(max_static_memory_size)+10*1024),stat=ier)
+! if(ier /= 0) then
+! write(IMAIN,*) 'error: try to increase the available process stack size by'
+! write(IMAIN,*) ' ulimit -s **** '
+! call exit_MPI(myrank,'not enough memory to allocate arrays')
+! endif
+! test_mem(:) = .true.
+! deallocate( test_mem, stat=ier)
+! if(ier /= 0) call exit_MPI(myrank,'error to allocate arrays')
+! call sync_all()
-! allocates arrays for Stacey boundaries
- allocate( nimin(2,NSPEC2DMAX_YMIN_YMAX),nimax(2,NSPEC2DMAX_YMIN_YMAX), &
- njmin(2,NSPEC2DMAX_XMIN_XMAX),njmax(2,NSPEC2DMAX_XMIN_XMAX), &
- nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX),nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX),stat=ier)
- if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
allocate( xelm(NGNOD),yelm(NGNOD),zelm(NGNOD),stat=ier)
- if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
allocate( iflag_attenuation_store(NGLLX,NGLLY,NGLLZ,nspec),stat=ier)
if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
@@ -254,43 +270,345 @@
allocate(wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ))
! 3D shape functions and their derivatives
- allocate(shape3D(NGNOD,NGLLX,NGLLY,NGLLZ),dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ),stat=ier)
- if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+ allocate(shape3D(NGNOD,NGLLX,NGLLY,NGLLZ), &
+ dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ),stat=ier)
! pll 2D shape functions and their derivatives
- allocate(shape2D_x(NGNOD2D,NGLLY,NGLLZ),shape2D_y(NGNOD2D,NGLLX,NGLLZ), &
- shape2D_bottom(NGNOD2D,NGLLX,NGLLY),shape2D_top(NGNOD2D,NGLLX,NGLLY), &
- dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ),dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ), &
- dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY),dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY),stat=ier)
+ allocate(shape2D_x(NGNOD2D,NGLLY,NGLLZ), &
+ shape2D_y(NGNOD2D,NGLLX,NGLLZ), &
+ shape2D_bottom(NGNOD2D,NGLLX,NGLLY), &
+ shape2D_top(NGNOD2D,NGLLX,NGLLY), stat=ier)
+
+ allocate(dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ), &
+ dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ), &
+ dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY), &
+ dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY),stat=ier)
+
+ allocate(wgllwgll_xy(NGLLX,NGLLY), &
+ wgllwgll_xz(NGLLX,NGLLZ), &
+ wgllwgll_yz(NGLLY,NGLLZ),stat=ier)
if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
! pll Stacey
- allocate(rho_vp(NGLLX,NGLLY,NGLLZ,nspec),rho_vs(NGLLX,NGLLY,NGLLZ,nspec),stat=ier)
+ allocate(rho_vp(NGLLX,NGLLY,NGLLZ,nspec), &
+ rho_vs(NGLLX,NGLLY,NGLLZ,nspec),stat=ier)
if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
! array with model density
- allocate(rhostore(NGLLX,NGLLY,NGLLZ,nspec),kappastore(NGLLX,NGLLY,NGLLZ,nspec),mustore(NGLLX,NGLLY,NGLLZ,nspec), &
- vpstore(NGLLX,NGLLY,NGLLZ,nspec),vsstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) !pll
+ allocate(rhostore(NGLLX,NGLLY,NGLLZ,nspec), &
+ kappastore(NGLLX,NGLLY,NGLLZ,nspec), &
+ mustore(NGLLX,NGLLY,NGLLZ,nspec), &
+ vpstore(NGLLX,NGLLY,NGLLZ,nspec), &
+ vsstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier) !pll
if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
! arrays with mesh parameters
- allocate(xixstore(NGLLX,NGLLY,NGLLZ,nspec),xiystore(NGLLX,NGLLY,NGLLZ,nspec),xizstore(NGLLX,NGLLY,NGLLZ,nspec), &
- etaxstore(NGLLX,NGLLY,NGLLZ,nspec),etaystore(NGLLX,NGLLY,NGLLZ,nspec),etazstore(NGLLX,NGLLY,NGLLZ,nspec), &
- gammaxstore(NGLLX,NGLLY,NGLLZ,nspec),gammaystore(NGLLX,NGLLY,NGLLZ,nspec),gammazstore(NGLLX,NGLLY,NGLLZ,nspec), &
+ allocate(xixstore(NGLLX,NGLLY,NGLLZ,nspec), &
+ xiystore(NGLLX,NGLLY,NGLLZ,nspec), &
+ xizstore(NGLLX,NGLLY,NGLLZ,nspec), &
+ etaxstore(NGLLX,NGLLY,NGLLZ,nspec), &
+ etaystore(NGLLX,NGLLY,NGLLZ,nspec), &
+ etazstore(NGLLX,NGLLY,NGLLZ,nspec), &
+ gammaxstore(NGLLX,NGLLY,NGLLZ,nspec), &
+ gammaystore(NGLLX,NGLLY,NGLLZ,nspec), &
+ gammazstore(NGLLX,NGLLY,NGLLZ,nspec), &
jacobianstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier)
if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
-! pll 2-D jacobians and normals
- allocate(jacobian2D_xmin(NGLLY,NGLLZ,nspec2D_xmin),jacobian2D_xmax(NGLLY,NGLLZ,nspec2D_xmax), &
- jacobian2D_ymin(NGLLX,NGLLZ,nspec2D_ymin),jacobian2D_ymax(NGLLX,NGLLZ,nspec2D_ymax), &
- jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM),jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP),stat=ier)
+! allocates arrays for Stacey boundaries
+! allocate( nimin(2,NSPEC2DMAX_YMIN_YMAX),nimax(2,NSPEC2DMAX_YMIN_YMAX), &
+! njmin(2,NSPEC2DMAX_XMIN_XMAX),njmax(2,NSPEC2DMAX_XMIN_XMAX), &
+! nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX),nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX),stat=ier)
+! if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+
+! ! local indices i,j,k of all GLL points on xmin boundary in the element
+! allocate(ibelm_gll_xmin(3,NGLLY,NGLLZ,nspec2D_xmin),ibelm_gll_xmax(3,NGLLY,NGLLZ,nspec2D_xmax), &
+! ibelm_gll_ymin(3,NGLLX,NGLLZ,nspec2D_ymin),ibelm_gll_ymax(3,NGLLX,NGLLZ,nspec2D_ymax), &
+! ibelm_gll_bottom(3,NGLLY,NGLLY,nspec2D_bottom),ibelm_gll_top(3,NGLLY,NGLLY,nspec2D_top),stat=ier)
+! if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+
+! ! pll 2-D jacobians and normals
+! allocate(jacobian2D_xmin(NGLLY,NGLLZ,nspec2D_xmin),jacobian2D_xmax(NGLLY,NGLLZ,nspec2D_xmax), &
+! jacobian2D_ymin(NGLLX,NGLLZ,nspec2D_ymin),jacobian2D_ymax(NGLLX,NGLLZ,nspec2D_ymax), &
+! jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM),jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP),stat=ier)
+! if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+
+! allocate(normal_xmin(NDIM,NGLLY,NGLLZ,nspec2D_xmin),normal_xmax(NDIM,NGLLY,NGLLZ,nspec2D_xmax), &
+! normal_ymin(NDIM,NGLLX,NGLLZ,nspec2D_ymin),normal_ymax(NDIM,NGLLX,NGLLZ,nspec2D_ymax), &
+! normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM),normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP),stat=ier)
+! if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+
+! free surface
+ allocate(jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP),&
+ normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP),stat=ier)
if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
- allocate(normal_xmin(NDIM,NGLLY,NGLLZ,nspec2D_xmin),normal_xmax(NDIM,NGLLY,NGLLZ,nspec2D_xmax), &
- normal_ymin(NDIM,NGLLX,NGLLZ,nspec2D_ymin),normal_ymax(NDIM,NGLLX,NGLLZ,nspec2D_ymax), &
- normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM),normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP),stat=ier)
+! absorbing boundary
+ ! absorbing faces
+ num_absorbing_boundary_faces = nspec2D_xmin + nspec2D_xmax + nspec2D_ymin + nspec2D_ymax + nspec2D_bottom
+ ! free surface also absorbs
+ if( ABSORB_FREE_SURFACE ) num_absorbing_boundary_faces = num_absorbing_boundary_faces + nspec2D_top
+
+ ! allocates arrays to store info for each face (assumes NGLLX=NGLLY=NGLLZ)
+ allocate( absorbing_boundary_ispec(num_absorbing_boundary_faces), &
+ absorbing_boundary_ijk(3,NGLLSQUARE,num_absorbing_boundary_faces), &
+ absorbing_boundary_jacobian2D(NGLLSQUARE,num_absorbing_boundary_faces), &
+ absorbing_boundary_normal(NDIM,NGLLSQUARE,num_absorbing_boundary_faces),stat=ier)
if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+
+! fills location and weights for Gauss-Lobatto-Legendre points, shape and derivations,
+! returns jacobianstore,xixstore,...gammazstore
+! and GLL-point locations in xstore,ystore,zstore
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...setting up jacobian '
+ endif
+
+ call create_regions_mesh_ext_mesh_setup_jacobian(xigll,yigll,zigll,wxgll,wygll,wzgll, &
+ myrank,shape3D,dershape3D,shape2D_x,shape2D_y,shape2D_bottom,shape2D_top, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ xstore,ystore,zstore,nspec,xelm,yelm,zelm, &
+ nodes_coords_ext_mesh,nnodes_ext_mesh,elmnts_ext_mesh,nelmnts_ext_mesh, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore, &
+ jacobianstore)
+
+! sets material velocities
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...determining kappa and mu parameters'
+ endif
+
+ call create_regions_mesh_ext_mesh_determine_kappamu(nspec,mat_ext_mesh,nelmnts_ext_mesh,&
+ materials_ext_mesh,nmat_ext_mesh,&
+ undef_mat_prop,nundefMat_ext_mesh,&
+ rhostore,kappastore,mustore,vpstore,vsstore,&
+ iflag_attenuation_store,rho_vp,rho_vs)
+
+! creates ibool index array for projection from local to global points
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...indexing global points'
+ endif
+
+ call create_regions_mesh_ext_mesh_setup_global_indexing(ibool, &
+ xstore,ystore,zstore,nspec,nglob,npointot, &
+ nnodes_ext_mesh,nodes_coords_ext_mesh,myrank)
+
+! unique global point locations
+ allocate(xstore_dummy(nglob), &
+ ystore_dummy(nglob), &
+ zstore_dummy(nglob),stat=ier)
+ if(ier /= 0) stop 'error in allocate'
+ do ispec = 1, nspec
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglobnum = ibool(i,j,k,ispec)
+ xstore_dummy(iglobnum) = xstore(i,j,k,ispec)
+ ystore_dummy(iglobnum) = ystore(i,j,k,ispec)
+ zstore_dummy(iglobnum) = zstore(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+! creating mass matrix (will be fully assembled with MPI in the solver)
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...creating mass matrix '
+ endif
+
+ allocate(rmass(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+
+ call create_regions_mesh_ext_mesh_create_mass_matrix(nglob,rmass,&
+ nspec,wxgll,wygll,wzgll,ibool,jacobianstore,rhostore)
+
+! sets up absorbing/free surface boundaries
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...setting up absorbing boundaries '
+ endif
+
+ call create_regions_mesh_ext_mesh_setup_absorbing_bound(myrank,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ nodes_coords_ext_mesh,nnodes_ext_mesh, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+ nodes_ibelm_xmin,nodes_ibelm_xmax,nodes_ibelm_ymin,nodes_ibelm_ymax, &
+ nodes_ibelm_bottom,nodes_ibelm_top, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,nspec2D_bottom,nspec2D_top, &
+ normal_top,jacobian2D_top, &
+ absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
+ absorbing_boundary_ijk,absorbing_boundary_ispec, &
+ num_absorbing_boundary_faces)
+
+! sets up MPI interfaces between partitions
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...preparing MPI interfaces '
+ endif
+
+ call create_regions_mesh_ext_mesh_prepare_MPI_interfaces(nglob,nspec,ibool, &
+ nelmnts_ext_mesh,elmnts_ext_mesh, &
+ my_nelmnts_neighbours_ext_mesh, my_interfaces_ext_mesh, &
+ ibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh, &
+ ninterface_ext_mesh,max_interface_size_ext_mesh, &
+ xstore_dummy,ystore_dummy,zstore_dummy)
+
+! saves the binary files
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...saving databases'
+ endif
+
+ call create_name_database(prname,myrank,LOCAL_PATH)
+ call save_arrays_solver_ext_mesh(nspec,nglob, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore, &
+ jacobianstore, rho_vp,rho_vs,iflag_attenuation_store, &
+ kappastore,mustore,rmass,ibool, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ NSPEC2D_TOP,ibelm_top,normal_top,jacobian2D_top, &
+ absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
+ absorbing_boundary_ijk,absorbing_boundary_ispec, &
+ num_absorbing_boundary_faces, &
+ ninterface_ext_mesh,my_neighbours_ext_mesh,nibool_interfaces_ext_mesh, &
+ max_interface_size_ext_mesh,ibool_interfaces_ext_mesh, &
+ prname,SAVE_MESH_FILES)
+
+! computes the approximate amount of static memory needed to run the solver
+ call memory_eval(nspec,nglob,maxval(nibool_interfaces_ext_mesh),ninterface_ext_mesh,static_memory_size)
+ call max_all_dp(static_memory_size, max_static_memory_size)
+
+
+! checks the mesh, stability and resolved period
+ call sync_all()
+ call check_mesh_resolution(myrank,nspec,nglob,ibool,&
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ kappastore,mustore,rho_vp,rho_vs, &
+ -1.0d0 )
+
+! VTK file output
+ if( SAVE_MESH_FILES ) then
+ ! saves material flag assigned for each spectral element into a vtk file
+ prname_file = prname(1:len_trim(prname))//'material_flag'
+ allocate(elem_flag(nspec))
+ elem_flag(:) = mat_ext_mesh(1,:)
+ call save_arrays_solver_ext_mesh_elem_vtk(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ elem_flag,prname_file)
+ deallocate(elem_flag)
+
+ ! saves attenuation flag assigned on each gll point into a vtk file
+ prname_file = prname(1:len_trim(prname))//'attenuation_flag'
+ call save_arrays_solver_ext_mesh_glldata_vtk(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ iflag_attenuation_store,prname_file)
+
+ !daniel
+ !plotting abs boundaries
+ ! allocate(itest_flag(nspec))
+ ! itest_flag(:) = 0
+ ! do ispec=1,nspec
+ ! if( iboun(1,ispec) ) itest_flag(ispec) = 1
+ ! enddo
+ ! prname_file = prname(1:len_trim(prname))//'iboundary1_flag'
+ ! call save_arrays_solver_ext_mesh_elem_vtk(nspec,nglob, &
+ ! xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ ! itest_flag,prname_file)
+ ! deallocate(itest_flag)
+ endif
+
+! AVS/DX file output
+! create AVS or DX mesh data for the slice, edges and faces
+! if(SAVE_MESH_FILES) then
+! check: no idoubling
+! call write_AVS_DX_global_data(myrank,prname,nspec,ibool,idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
+! call write_AVS_DX_mesh_quality_data(prname,nspec,xstore,ystore,zstore, &
+! kappastore,mustore,rhostore)
+! check: no iMPIcut_xi,iMPIcut_eta,idoubling
+! call write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, &
+! idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
+! check: no idoubling
+! call write_AVS_DX_surface_data(myrank,prname,nspec,iboun,ibool, &
+! idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
+! endif
+
+! cleanup
+ deallocate(xixstore,xiystore,xizstore,&
+ etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore)
+ deallocate(jacobianstore,iflag_attenuation_store)
+ deallocate(xstore_dummy,ystore_dummy,zstore_dummy)
+ deallocate(kappastore,mustore,rho_vp,rho_vs)
+
+ end subroutine create_regions_mesh_ext_mesh
+
+!
+!----
+!
+
+subroutine create_regions_mesh_ext_mesh_setup_jacobian(xigll,yigll,zigll,wxgll,wygll,wzgll, &
+ myrank,shape3D,dershape3D,shape2D_x,shape2D_y,shape2D_bottom,shape2D_top, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ xstore,ystore,zstore,nspec,xelm,yelm,zelm, &
+ nodes_coords_ext_mesh,nnodes_ext_mesh,elmnts_ext_mesh,nelmnts_ext_mesh, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore,&
+ jacobianstore)
+
+ implicit none
+
+ include 'constants.h'
+
+! number of spectral elements in each block
+ integer :: nspec
+
+! Gauss-Lobatto-Legendre points and weights of integration
+ double precision :: xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ),wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ)
+
+! 3D shape functions and their derivatives
+ double precision :: shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
+ double precision :: dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ)
+
+! 2D shape functions and their derivatives
+ double precision :: shape2D_x(NGNOD2D,NGLLY,NGLLZ),shape2D_y(NGNOD2D,NGLLX,NGLLZ),&
+ shape2D_bottom(NGNOD2D,NGLLX,NGLLY),shape2D_top(NGNOD2D,NGLLX,NGLLY)
+ double precision :: dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ),dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ),&
+ dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY),dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY)
+
+ double precision, dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ double precision, dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ double precision, dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
+
+ double precision,dimension(NGNOD) :: xelm,yelm,zelm
+
+! data from the external mesh
+ integer :: nnodes_ext_mesh,nelmnts_ext_mesh
+ double precision, dimension(NDIM,nnodes_ext_mesh) :: nodes_coords_ext_mesh
+ integer, dimension(ESIZE,nelmnts_ext_mesh) :: elmnts_ext_mesh
+
+! arrays with mesh parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ jacobianstore
+
+! proc numbers for MPI
+ integer :: myrank
+
+ integer :: ispec,ia,i,j,k
+
+! integer :: ielm
+! logical :: inorder
+
! set up coordinates of the Gauss-Lobatto-Legendre points
call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
@@ -310,20 +628,24 @@
call get_shape2D(myrank,shape2D_bottom,dershape2D_bottom,xigll,yigll,NGLLX,NGLLY)
call get_shape2D(myrank,shape2D_top,dershape2D_top,xigll,yigll,NGLLX,NGLLY)
-! allocate memory for arrays
- allocate(iglob(npointot), &
- locval(npointot), &
- ifseg(npointot), &
- xp(npointot),yp(npointot),zp(npointot),stat=ier)
- if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+! 2D weights
+ do j=1,NGLLY
+ do i=1,NGLLX
+ wgllwgll_xy(i,j) = wxgll(i)*wygll(j)
+ enddo
+ enddo
+ do k=1,NGLLZ
+ do i=1,NGLLX
+ wgllwgll_xz(i,k) = wxgll(i)*wzgll(k)
+ enddo
+ enddo
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ wgllwgll_yz(j,k) = wygll(j)*wzgll(k)
+ enddo
+ enddo
-!---
-
- call sync_all()
- if( myrank == 0) then
- write(IMAIN,*) ' ...calculating jacobian '
- endif
-
+! point locations
xstore(:,:,:,:) = 0.d0
ystore(:,:,:,:) = 0.d0
zstore(:,:,:,:) = 0.d0
@@ -336,14 +658,246 @@
zelm(ia) = nodes_coords_ext_mesh(3,elmnts_ext_mesh(ia,ispec))
enddo
+
+!daniel
+! ! do we have to test CUBIT order - or will 3D jacobian be defined?
+!
+! ! bottom - top?
+! ! point 1 (0,0,0) vs point 5 (0,0,1)
+! inorder = .true.
+! if( nodes_coords(3,elmnts(1,num_elmnt)) > nodes_coords(3,elmnts(5,num_elmnt)) ) then
+! print*,num_elmnt,'z1-5 :',nodes_coords(3,elmnts(1,num_elmnt)),nodes_coords(3,elmnts(5,num_elmnt))
+! inorder = .false.
+! endif
+! if( inorder .eqv. .false. ) then
+! ielm = elmnts(1,num_elmnt)
+! elmnts(1,num_elmnt) = elmnts(5,num_elmnt)
+! elmnts(5,num_elmnt) = ielm
+!
+! ! assumes to switch the others as well
+! ielm = elmnts(2,num_elmnt)
+! elmnts(2,num_elmnt) = elmnts(6,num_elmnt)
+! elmnts(6,num_elmnt) = ielm
+!
+! ielm = elmnts(3,num_elmnt)
+! elmnts(3,num_elmnt) = elmnts(7,num_elmnt)
+! elmnts(7,num_elmnt) = ielm
+!
+! ielm = elmnts(4,num_elmnt)
+! elmnts(4,num_elmnt) = elmnts(8,num_elmnt)
+! elmnts(8,num_elmnt) = ielm
+!
+! endif
+! ! makes sure bottom - top is o.k.
+! ! point 2 (0,1,0) vs point 6 (0,1,1)
+! inorder = .true.
+! if( nodes_coords(3,elmnts(2,num_elmnt)) > nodes_coords(3,elmnts(6,num_elmnt)) ) then
+! print*,num_elmnt,'z2-6 :',nodes_coords(3,elmnts(2,num_elmnt)),nodes_coords(3,elmnts(6,num_elmnt))
+! inorder = .false.
+! endif
+! if( inorder .eqv. .false. ) then
+! ielm = elmnts(2,num_elmnt)
+! elmnts(2,num_elmnt) = elmnts(6,num_elmnt)
+! elmnts(6,num_elmnt) = ielm
+! endif
+!
+! ! point 3 (1,1,0) vs point 7 (1,1,1)
+! inorder = .true.
+! if( nodes_coords(3,elmnts(3,num_elmnt)) > nodes_coords(3,elmnts(7,num_elmnt)) ) then
+! print*,num_elmnt,'z3-7 :',nodes_coords(3,elmnts(3,num_elmnt)),nodes_coords(3,elmnts(7,num_elmnt))
+! inorder = .false.
+! endif
+! if( inorder .eqv. .false. ) then
+! ielm = elmnts(3,num_elmnt)
+! elmnts(3,num_elmnt) = elmnts(7,num_elmnt)
+! elmnts(7,num_elmnt) = ielm
+! endif
+!
+! ! point 4 (1,0,0) vs point 8 (1,0,1)
+! inorder = .true.
+! if( nodes_coords(3,elmnts(4,num_elmnt)) > nodes_coords(3,elmnts(8,num_elmnt)) ) then
+! print*,num_elmnt,'z4-8 :',nodes_coords(3,elmnts(4,num_elmnt)),nodes_coords(3,elmnts(8,num_elmnt))
+! inorder = .false.
+! endif
+! if( inorder .eqv. .false. ) then
+! ielm = elmnts(4,num_elmnt)
+! elmnts(4,num_elmnt) = elmnts(8,num_elmnt)
+! elmnts(8,num_elmnt) = ielm
+! endif
+!
+! ! clock-wise order?
+! ! point 1 (0,0,0) vs point 3 (1,1,0)
+! inorder = .true.
+! if( nodes_coords(1,elmnts(1,num_elmnt)) > nodes_coords(1,elmnts(3,num_elmnt)) ) then
+! print*,num_elmnt,'x1-3 :',nodes_coords(1,elmnts(1,num_elmnt)),nodes_coords(1,elmnts(3,num_elmnt))
+! inorder = .false.
+! endif
+! if( nodes_coords(2,elmnts(1,num_elmnt)) > nodes_coords(2,elmnts(3,num_elmnt)) ) then
+! print*,num_elmnt,'y1-3 :',nodes_coords(2,elmnts(1,num_elmnt)),nodes_coords(2,elmnts(3,num_elmnt))
+! inorder = .false.
+! endif
+! if( inorder .eqv. .false. ) then
+! ielm = elmnts(1,num_elmnt)
+! elmnts(1,num_elmnt) = elmnts(3,num_elmnt)
+! elmnts(3,num_elmnt) = ielm
+! endif
+!
+! ! point 2 (0,1,0) vs point 4 (1,0,0)
+! inorder = .true.
+! if( nodes_coords(1,elmnts(2,num_elmnt)) > nodes_coords(1,elmnts(4,num_elmnt)) ) then
+! print*,num_elmnt,'x2-4 :',nodes_coords(1,elmnts(2,num_elmnt)),nodes_coords(1,elmnts(4,num_elmnt))
+! inorder = .false.
+! endif
+! if( nodes_coords(2,elmnts(2,num_elmnt)) < nodes_coords(2,elmnts(4,num_elmnt)) ) then
+! print*,num_elmnt,'y2-4 :',nodes_coords(2,elmnts(2,num_elmnt)),nodes_coords(2,elmnts(4,num_elmnt))
+! inorder = .false.
+! endif
+! if( inorder .eqv. .false. ) then
+! ielm = elmnts(2,num_elmnt)
+! elmnts(2,num_elmnt) = elmnts(4,num_elmnt)
+! elmnts(4,num_elmnt) = ielm
+! endif
+!
+! ! point 5 (0,0,1) vs point 7 (1,1,1)
+! inorder = .true.
+! if( nodes_coords(1,elmnts(5,num_elmnt)) > nodes_coords(1,elmnts(7,num_elmnt)) ) then
+! print*,num_elmnt,'x5-7 :',nodes_coords(1,elmnts(5,num_elmnt)),nodes_coords(1,elmnts(7,num_elmnt))
+! inorder = .false.
+! endif
+! if( nodes_coords(2,elmnts(5,num_elmnt)) > nodes_coords(2,elmnts(7,num_elmnt)) ) then
+! print*,num_elmnt,'y5-7 :',nodes_coords(2,elmnts(5,num_elmnt)),nodes_coords(2,elmnts(7,num_elmnt))
+! inorder = .false.
+! endif
+! if( inorder .eqv. .false. ) then
+! ielm = elmnts(5,num_elmnt)
+! elmnts(5,num_elmnt) = elmnts(7,num_elmnt)
+! elmnts(7,num_elmnt) = ielm
+! endif
+!
+! ! point 6 (0,1,1) vs point 8 (1,0,1)
+! inorder = .true.
+! if( nodes_coords(1,elmnts(6,num_elmnt)) > nodes_coords(1,elmnts(8,num_elmnt)) ) then
+! print*,num_elmnt,'x6-8 :',nodes_coords(1,elmnts(6,num_elmnt)),nodes_coords(1,elmnts(8,num_elmnt))
+! inorder = .false.
+! endif
+! if( nodes_coords(2,elmnts(6,num_elmnt)) < nodes_coords(2,elmnts(8,num_elmnt)) ) then
+! print*,num_elmnt,'y6-8 :',nodes_coords(2,elmnts(6,num_elmnt)),nodes_coords(2,elmnts(8,num_elmnt))
+! inorder = .false.
+! endif
+! if( inorder .eqv. .false. ) then
+! ielm = elmnts(6,num_elmnt)
+! elmnts(6,num_elmnt) = elmnts(8,num_elmnt)
+! elmnts(8,num_elmnt) = ielm
+! endif
+!
+! or
+! if( .false. ) then
+! ! trys to order points in increasing z direction first, then y and x
+! inorder = .false.
+! do while (inorder .eqv. .false.)
+! inorder = .true.
+! do i=1,8
+! ! If z needs to be swapped, do so
+! if (nodes_coords(3,elmnts(i,num_elmnt)) > nodes_coords(3,elmnts(i+1,num_elmnt)) )then
+! i_temp = elmnts(i,num_elmnt)
+! elmnts(i,num_elmnt) = elmnts(i+1,num_elmnt)
+! elmnts(i+1,num_elmnt) = i_temp
+! inorder = .false.
+! exit
+! endif
+! ! Check Equilivant Points and swap those on Y
+! if (nodes_coords(3,elmnts(i,num_elmnt)) == nodes_coords(3,elmnts(i+1,num_elmnt))) then
+! if (nodes_coords(2,elmnts(i,num_elmnt)) > nodes_coords(2,elmnts(i+1,num_elmnt)) ) then
+! i_temp = elmnts(i,num_elmnt)
+! elmnts(i,num_elmnt) = elmnts(i+1,num_elmnt)
+! elmnts(i+1,num_elmnt) = i_temp
+! inorder = .false.
+! exit
+! endif
+! endif
+! ! Check Equilivant Points and swap those on X
+! if (nodes_coords(3,elmnts(i,num_elmnt)) == nodes_coords(3,elmnts(i+1,num_elmnt))) then
+! if (nodes_coords(2,elmnts(i,num_elmnt)) == nodes_coords(2,elmnts(i+1,num_elmnt)) ) then
+! if (nodes_coords(1,elmnts(i,num_elmnt)) > nodes_coords(1,elmnts(i+1,num_elmnt)) )then
+! i_temp = elmnts(i,num_elmnt)
+! elmnts(i,num_elmnt) = elmnts(i+1,num_elmnt)
+! elmnts(i+1,num_elmnt) = i_temp
+! inorder = .false.
+! exit
+! endif
+! endif
+! endif
+! enddo
+! enddo
+! ! respect anti-clockwise ordering bottom face
+! i_temp = elmnts(3,num_elmnt)
+! elmnts(3,num_elmnt) = elmnts(4,num_elmnt)
+! elmnts(4,num_elmnt) = i_temp
+! ! respect anti-clockwise ordering top face
+! i_temp = elmnts(7,num_elmnt)
+! elmnts(7,num_elmnt) = elmnts(8,num_elmnt)
+! elmnts(8,num_elmnt) = i_temp
+! if( nodes_coords(1,elmnts(1,num_elmnt)) > nodes_coords(1,elmnts(2,num_elmnt)) ) then
+! print*,'elem:',num_elmnt
+! stop 'error sorting x'
+! endif
+! if( nodes_coords(2,elmnts(1,num_elmnt)) > nodes_coords(2,elmnts(4,num_elmnt)) ) then
+! print*,'elem:',num_elmnt
+! stop 'error sorting y'
+! endif
+! if( nodes_coords(3,elmnts(1,num_elmnt)) > nodes_coords(3,elmnts(5,num_elmnt)) ) then
+! print*,'elem:',num_elmnt
+! stop 'error sorting z'
+! endif
+! endif
+
call calc_jacobian(myrank,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore,jacobianstore, &
- xstore,ystore,zstore, &
- xelm,yelm,zelm,shape3D,dershape3D,ispec,nspec)
+ etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore,jacobianstore, &
+ xstore,ystore,zstore, &
+ xelm,yelm,zelm,shape3D,dershape3D,ispec,nspec)
enddo
+end subroutine create_regions_mesh_ext_mesh_setup_jacobian
+
+!
+!----
+!
+
+subroutine create_regions_mesh_ext_mesh_determine_kappamu(nspec,mat_ext_mesh,nelmnts_ext_mesh,&
+ materials_ext_mesh,nmat_ext_mesh,&
+ undef_mat_prop,nundefMat_ext_mesh,&
+ rhostore,kappastore,mustore,vpstore,vsstore,&
+ iflag_attenuation_store,rho_vp,rho_vs)
+
+ implicit none
+
+ include 'constants.h'
+
+! number of spectral elements in each block
+ integer :: nspec
+
+! external mesh
+ integer :: nelmnts_ext_mesh
+ integer :: nmat_ext_mesh,nundefMat_ext_mesh
+
+ integer, dimension(2,nelmnts_ext_mesh) :: mat_ext_mesh
+ double precision, dimension(5,nmat_ext_mesh) :: materials_ext_mesh
+ character (len=30), dimension(5,nundefMat_ext_mesh):: undef_mat_prop
+
+! for model density
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rhostore, &
+ kappastore,mustore,vpstore,vsstore
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rho_vp,rho_vs
+
+! attenuation
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: iflag_attenuation_store
+
+! local parameters
+ integer :: ispec,i,j,k,iundef
+ integer :: iflag,flag_below,flag_above
+
! ! Piero, read bedrock file
! allocate(ibedrock(NX_TOPO_ANT,NY_TOPO_ANT))
! if(myrank == 0) then
@@ -355,13 +909,7 @@
! ! broadcast the information read on the master to the nodes
! ! call MPI_BCAST(ibedrock,NX_TOPO_ANT*NY_TOPO_ANT,MPI_REAL,0,MPI_COMM_WORLD,ier)
! call bcast_all_cr(ibedrock,NX_TOPO_ANT*NY_TOPO_ANT)
-
- call sync_all()
- if( myrank == 0) then
- write(IMAIN,*) ' ...determining kappa and mu parameters'
- endif
-
-
+
! kappastore and mustore
do ispec = 1, nspec
do k = 1, NGLLZ
@@ -381,6 +929,8 @@
! iflag_attenuation_store(i,j,k,ispec) = 2
!endif
else if (mat_ext_mesh(2,ispec) == 1) then
+ stop 'material: interface not implemented yet'
+
do iundef = 1,nundefMat_ext_mesh
if(trim(undef_mat_prop(2,iundef)) == 'interface') then
read(undef_mat_prop(4,iundef),'(1i3)') flag_below
@@ -388,6 +938,7 @@
endif
enddo
!call interface(iflag,flag_below,flag_above,ispec,nspec,i,j,k,xstore,ystore,zstore,ibedrock)
+ iflag = 1
rhostore(i,j,k,ispec) = materials_ext_mesh(1,iflag)
vpstore(i,j,k,ispec) = materials_ext_mesh(2,iflag)
vsstore(i,j,k,ispec) = materials_ext_mesh(3,iflag)
@@ -399,13 +950,15 @@
! iflag_attenuation_store(i,j,k,ispec) = 2
! endif
else
+ stop 'material: tomography not implemented yet'
! call tomography()
end if
- kappastore(i,j,k,ispec) = rhostore(i,j,k,ispec)*(vpstore(i,j,k,ispec)*vpstore(i,j,k,ispec) - &
- 4.d0*vsstore(i,j,k,ispec)*vsstore(i,j,k,ispec)/3.d0)
- mustore(i,j,k,ispec) = rhostore(i,j,k,ispec)*vsstore(i,j,k,ispec)*&
- vsstore(i,j,k,ispec)
+ kappastore(i,j,k,ispec) = rhostore(i,j,k,ispec)* &
+ ( vpstore(i,j,k,ispec)*vpstore(i,j,k,ispec) &
+ - FOUR_THIRDS*vsstore(i,j,k,ispec)*vsstore(i,j,k,ispec) )
+
+ mustore(i,j,k,ispec) = rhostore(i,j,k,ispec)*vsstore(i,j,k,ispec)*vsstore(i,j,k,ispec)
! Stacey, a completer par la suite
rho_vp(i,j,k,ispec) = rhostore(i,j,k,ispec)*vpstore(i,j,k,ispec)
@@ -418,7 +971,6 @@
!print*,myrank,'ispec:',ispec,'rho:',rhostore(1,1,1,ispec),'vp:',vpstore(1,1,1,ispec),'vs:',vsstore(1,1,1,ispec)
enddo
-
! !! DK DK store the position of the six stations to be able to
! !! DK DK exclude circles around each station to make sure they are on the bedrock
! !! DK DK and not in the ice
@@ -475,7 +1027,8 @@
! do i = 1, NGLLX
-! if(idoubling(ispec) == IFLAG_ONE_LAYER_TOPOGRAPHY .or. idoubling(ispec) == IFLAG_BEDROCK_down_to_14km) then
+! if(idoubling(ispec) == IFLAG_ONE_LAYER_TOPOGRAPHY .or. &
+! idoubling(ispec) == IFLAG_BEDROCK_down_to_14km) then
! ! since we have suppressed UTM projection for Piero Basini, UTMx is the same as long
! ! and UTMy is the same as lat
@@ -578,13 +1131,59 @@
! ! kappastore(i,j,k,ispec) = materials_ext_mesh(1,mat_ext_mesh(ispec))* &
! ! (materials_ext_mesh(2,mat_ext_mesh(ispec))*materials_ext_mesh(2,mat_ext_mesh(ispec)) - &
! ! 4.d0*materials_ext_mesh(3,mat_ext_mesh(ispec))*materials_ext_mesh(3,mat_ext_mesh(ispec))/3.d0)
-! ! mustore(i,j,k,ispec) = materials_ext_mesh(1,mat_ext_mesh(ispec))*materials_ext_mesh(3,mat_ext_mesh(ispec))*&
+! ! mustore(i,j,k,ispec) = materials_ext_mesh(1,mat_ext_mesh(ispec))* &
+! materials_ext_mesh(3,mat_ext_mesh(ispec))*&
! ! x materials_ext_mesh(3,mat_ext_mesh(ispec))
! enddo
! enddo
! enddo
! enddo
+end subroutine create_regions_mesh_ext_mesh_determine_kappamu
+
+!
+!----
+!
+
+subroutine create_regions_mesh_ext_mesh_setup_global_indexing(ibool, &
+ xstore,ystore,zstore,nspec,nglob,npointot, &
+ nnodes_ext_mesh,nodes_coords_ext_mesh,myrank)
+
+! creates global indexing array ibool
+
+ implicit none
+
+ include "constants.h"
+
+! number of spectral elements in each block
+ integer :: nspec,nglob,npointot,myrank
+
+! arrays with the mesh
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
+
+! data from the external mesh
+ integer :: nnodes_ext_mesh
+ double precision, dimension(NDIM,nnodes_ext_mesh) :: nodes_coords_ext_mesh
+
+! local parameters
+! variables for creating array ibool
+ double precision, dimension(:), allocatable :: xp,yp,zp
+ integer, dimension(:), allocatable :: locval
+ logical, dimension(:), allocatable :: ifseg
+
+ integer :: ieoff,ilocnum,ier
+ integer :: i,j,k,ispec
+
+! allocate memory for arrays
+ allocate(locval(npointot), &
+ ifseg(npointot), &
+ xp(npointot), &
+ yp(npointot), &
+ zp(npointot),stat=ier)
+ if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+
+! creates temporary global point arrays
locval = 0
ifseg = .false.
xp = 0.d0
@@ -592,87 +1191,70 @@
zp = 0.d0
do ispec=1,nspec
- ieoff = NGLLX * NGLLY * NGLLZ * (ispec-1)
- ilocnum = 0
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- ilocnum = ilocnum + 1
- xp(ilocnum+ieoff) = xstore(i,j,k,ispec)
- yp(ilocnum+ieoff) = ystore(i,j,k,ispec)
- zp(ilocnum+ieoff) = zstore(i,j,k,ispec)
+ ieoff = NGLLX * NGLLY * NGLLZ * (ispec-1)
+ ilocnum = 0
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ilocnum = ilocnum + 1
+ xp(ilocnum+ieoff) = xstore(i,j,k,ispec)
+ yp(ilocnum+ieoff) = ystore(i,j,k,ispec)
+ zp(ilocnum+ieoff) = zstore(i,j,k,ispec)
+ enddo
enddo
enddo
enddo
- enddo
+! gets ibool indexing from local (GLL points) to global points
call get_global(nspec,xp,yp,zp,ibool,locval,ifseg,nglob,npointot, &
minval(nodes_coords_ext_mesh(1,:)),maxval(nodes_coords_ext_mesh(1,:)))
+!- we can create a new indirect addressing to reduce cache misses
+ call get_global_indirect_addressing(nspec,nglob,ibool)
+
+!cleanup
deallocate(xp,stat=ier); if(ier /= 0) stop 'error in deallocate'
deallocate(yp,stat=ier); if(ier /= 0) stop 'error in deallocate'
deallocate(zp,stat=ier); if(ier /= 0) stop 'error in deallocate'
deallocate(locval,stat=ier); if(ier /= 0) stop 'error in deallocate'
deallocate(ifseg,stat=ier); if(ier /= 0) stop 'error in deallocate'
+end subroutine create_regions_mesh_ext_mesh_setup_global_indexing
+
!
-!- we can create a new indirect addressing to reduce cache misses
+!----
!
- allocate(copy_ibool_ori(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate'
- allocate(mask_ibool(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
- mask_ibool(:) = -1
- copy_ibool_ori(:,:,:,:) = ibool(:,:,:,:)
+subroutine create_regions_mesh_ext_mesh_create_mass_matrix(nglob,rmass,&
+ nspec,wxgll,wygll,wzgll,ibool,jacobianstore,rhostore)
- inumber = 0
- do ispec=1,nspec
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- if(mask_ibool(copy_ibool_ori(i,j,k,ispec)) == -1) then
-! create a new point
- inumber = inumber + 1
- ibool(i,j,k,ispec) = inumber
- mask_ibool(copy_ibool_ori(i,j,k,ispec)) = inumber
- else
-! use an existing point created previously
- ibool(i,j,k,ispec) = mask_ibool(copy_ibool_ori(i,j,k,ispec))
- endif
- enddo
- enddo
- enddo
- enddo
+! returns precomputed mass matrix in rmass array
- deallocate(copy_ibool_ori,stat=ier); if(ier /= 0) stop 'error in deallocate'
- deallocate(mask_ibool,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ implicit none
- call sync_all()
- if( myrank == 0) then
- write(IMAIN,*) ' ...coordinating points'
- endif
+ include 'constants.h'
- allocate(xstore_dummy(nglob),ystore_dummy(nglob),zstore_dummy(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
-
- do ispec = 1, nspec
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- iglobnum = ibool(i,j,k,ispec)
- xstore_dummy(iglobnum) = xstore(i,j,k,ispec)
- ystore_dummy(iglobnum) = ystore(i,j,k,ispec)
- zstore_dummy(iglobnum) = zstore(i,j,k,ispec)
- enddo
- enddo
- enddo
- enddo
+! number of spectral elements in each block
+ integer :: nglob,nspec
-! creating mass matrix (will be fully assembled with MPI in the solver)
- call sync_all()
- if( myrank == 0) then
- write(IMAIN,*) ' ...creating mass matrix '
- endif
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(nglob) :: rmass
- allocate(rmass(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+! Gauss-Lobatto-Legendre weights of integration
+ double precision :: wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ)
+
+! arrays with the mesh
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+! arrays with mesh parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: jacobianstore,rhostore
+
+! local parameters
+ double precision :: weight
+ real(kind=CUSTOM_REAL) :: jacobianl
+ integer :: ispec,i,j,k,iglobnum
+
+! creates mass matrix
rmass(:) = 0._CUSTOM_REAL
do ispec=1,nspec
@@ -697,675 +1279,699 @@
enddo
enddo
- call sync_all()
- if( myrank == 0) then
- write(IMAIN,*) ' ...setting boundaries '
- endif
-
- iboun(:,:) = .false.
- do ispec2D = 1, nspec2D_xmin
- iboun(1,ibelm_xmin(ispec2D)) = .true.
- end do
- do ispec2D = 1, nspec2D_xmax
- iboun(2,ibelm_xmax(ispec2D)) = .true.
- end do
- do ispec2D = 1, nspec2D_ymin
- iboun(3,ibelm_ymin(ispec2D)) = .true.
- end do
- do ispec2D = 1, nspec2D_ymax
- iboun(4,ibelm_ymax(ispec2D)) = .true.
- end do
- do ispec2D = 1, NSPEC2D_BOTTOM
- iboun(5,ibelm_bottom(ispec2D)) = .true.
- end do
- do ispec2D = 1, NSPEC2D_TOP
- iboun(6,ibelm_top(ispec2D)) = .true.
- end do
- call get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, &
- dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
- jacobian2D_xmin,jacobian2D_xmax, &
- jacobian2D_ymin,jacobian2D_ymax, &
- jacobian2D_bottom,jacobian2D_top, &
- normal_xmin,normal_xmax, &
- normal_ymin,normal_ymax, &
- normal_bottom,normal_top, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX)
+end subroutine create_regions_mesh_ext_mesh_create_mass_matrix
- call prepare_assemble_MPI (nelmnts_ext_mesh,ibool, &
- elmnts_ext_mesh, ESIZE, &
- nglob, &
- ninterface_ext_mesh, max_interface_size_ext_mesh, &
- my_nelmnts_neighbours_ext_mesh, my_interfaces_ext_mesh, &
- ibool_interfaces_ext_mesh, &
- nibool_interfaces_ext_mesh &
- )
+!
+!----
+!
- ! Stacey put back
- call get_absorb_ext_mesh(myrank,iboun,nspec, &
- nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM)
+subroutine create_regions_mesh_ext_mesh_setup_absorbing_bound(myrank,nspec,nglob,&
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ nodes_coords_ext_mesh,nnodes_ext_mesh, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+ nodes_ibelm_xmin,nodes_ibelm_xmax,nodes_ibelm_ymin,nodes_ibelm_ymax, &
+ nodes_ibelm_bottom,nodes_ibelm_top, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,nspec2D_bottom,nspec2D_top, &
+ normal_top,jacobian2D_top, &
+ absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
+ absorbing_boundary_ijk,absorbing_boundary_ispec, &
+ num_absorbing_boundary_faces)
+! determines absorbing boundaries/free-surface, 2D jacobians, face normals for Stacey conditions
+ implicit none
-! create AVS or DX mesh data for the slice, edges and faces
-! if(SAVE_MESH_FILES) then
-! check: no idoubling
-! call write_AVS_DX_global_data(myrank,prname,nspec,ibool,idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
-! call write_AVS_DX_mesh_quality_data(prname,nspec,xstore,ystore,zstore, &
-! kappastore,mustore,rhostore)
-! check: no iMPIcut_xi,iMPIcut_eta,idoubling
-! call write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, &
-! idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
-! check: no idoubling
-! call write_AVS_DX_surface_data(myrank,prname,nspec,iboun,ibool, &
-! idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
-! endif
+ include "constants.h"
+! number of spectral elements in each block
+ integer :: myrank,nspec,nglob
+! arrays with the mesh
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+! double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
+! global point locations
+ real(kind=CUSTOM_REAL) :: xstore_dummy(nglob),ystore_dummy(nglob),zstore_dummy(nglob)
-! sort ibool comm buffers lexicographically
- allocate(nibool_interfaces_ext_mesh_true(ninterface_ext_mesh))
+! 2D shape functions derivatives and weights
+ double precision :: dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ),dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ), &
+ dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY),dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY)
+ double precision, dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ double precision, dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ double precision, dimension(NGLLY,NGLLZ) :: wgllwgll_yz
- do iinterface = 1, ninterface_ext_mesh
+! data from the external mesh
+ integer :: nnodes_ext_mesh !,nelmnts_ext_mesh
+ double precision, dimension(NDIM,nnodes_ext_mesh) :: nodes_coords_ext_mesh
+! integer, dimension(ESIZE,nelmnts_ext_mesh) :: elmnts_ext_mesh
- allocate(xp(nibool_interfaces_ext_mesh(iinterface)))
- allocate(yp(nibool_interfaces_ext_mesh(iinterface)))
- allocate(zp(nibool_interfaces_ext_mesh(iinterface)))
- allocate(locval(nibool_interfaces_ext_mesh(iinterface)))
- allocate(ifseg(nibool_interfaces_ext_mesh(iinterface)))
- allocate(reorder_interface_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
- allocate(ibool_interface_ext_mesh_dummy(nibool_interfaces_ext_mesh(iinterface)))
- allocate(ind_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
- allocate(ninseg_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
- allocate(iwork_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
- allocate(work_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
+! absorbing boundaries
+ integer :: nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, nspec2D_ymax, NSPEC2D_BOTTOM, NSPEC2D_TOP
+ ! element indices containing a boundary
+ integer, dimension(nspec2D_xmin) :: ibelm_xmin
+ integer, dimension(nspec2D_xmax) :: ibelm_xmax
+ integer, dimension(nspec2D_ymin) :: ibelm_ymin
+ integer, dimension(nspec2D_ymax) :: ibelm_ymax
+ integer, dimension(NSPEC2D_BOTTOM) :: ibelm_bottom
+ integer, dimension(NSPEC2D_TOP) :: ibelm_top
- do ilocnum = 1, nibool_interfaces_ext_mesh(iinterface)
- xp(ilocnum) = xstore_dummy(ibool_interfaces_ext_mesh(ilocnum,iinterface))
- yp(ilocnum) = ystore_dummy(ibool_interfaces_ext_mesh(ilocnum,iinterface))
- zp(ilocnum) = zstore_dummy(ibool_interfaces_ext_mesh(ilocnum,iinterface))
- enddo
+ ! corner node indices of boundary faces coming from CUBIT
+ integer, dimension(4,nspec2D_xmin) :: nodes_ibelm_xmin
+ integer, dimension(4,nspec2D_xmax) :: nodes_ibelm_xmax
+ integer, dimension(4,nspec2D_ymin) :: nodes_ibelm_ymin
+ integer, dimension(4,nspec2D_ymax) :: nodes_ibelm_ymax
+ integer, dimension(4,NSPEC2D_BOTTOM) :: nodes_ibelm_bottom
+ integer, dimension(4,NSPEC2D_TOP) :: nodes_ibelm_top
- call sort_array_coordinates(nibool_interfaces_ext_mesh(iinterface),xp,yp,zp, &
- ibool_interfaces_ext_mesh(1:nibool_interfaces_ext_mesh(iinterface),iinterface), &
- reorder_interface_ext_mesh,locval,ifseg,nibool_interfaces_ext_mesh_true(iinterface), &
- ind_ext_mesh,ninseg_ext_mesh,iwork_ext_mesh,work_ext_mesh)
+ ! local indices i,j,k of all GLL points on an absorbing boundary in the element,
+ ! defines all gll points located on the absorbing surfaces
+! integer :: ibelm_gll_xmin(3,NGLLY,NGLLZ,nspec2D_xmin),ibelm_gll_xmax(3,NGLLY,NGLLZ,nspec2D_xmax), &
+! ibelm_gll_ymin(3,NGLLX,NGLLZ,nspec2D_ymin),ibelm_gll_ymax(3,NGLLX,NGLLZ,nspec2D_ymax), &
+! ibelm_gll_bottom(3,NGLLY,NGLLY,nspec2D_bottom),ibelm_gll_top(3,NGLLY,NGLLY,nspec2D_top)
- deallocate(xp)
- deallocate(yp)
- deallocate(zp)
- deallocate(locval)
- deallocate(ifseg)
- deallocate(reorder_interface_ext_mesh)
- deallocate(ibool_interface_ext_mesh_dummy)
- deallocate(ind_ext_mesh)
- deallocate(ninseg_ext_mesh)
- deallocate(iwork_ext_mesh)
- deallocate(work_ext_mesh)
+! overlap indices for elements at corners and edges with more than one aborbing boundary face
+! integer :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
+! integer :: nimin(2,NSPEC2DMAX_YMIN_YMAX),nimax(2,NSPEC2DMAX_YMIN_YMAX), &
+! njmin(2,NSPEC2DMAX_XMIN_XMAX),njmax(2,NSPEC2DMAX_XMIN_XMAX), &
+! nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX),nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX)
- enddo
+ ! 2-D jacobians and normals
+! real(kind=CUSTOM_REAL) :: jacobian2D_xmin(NGLLY,NGLLZ,nspec2D_xmin),&
+! jacobian2D_xmax(NGLLY,NGLLZ,nspec2D_xmax), &
+! jacobian2D_ymin(NGLLX,NGLLZ,nspec2D_ymin), &
+! jacobian2D_ymax(NGLLX,NGLLZ,nspec2D_ymax),&
+! jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM),&
+ real(kind=CUSTOM_REAL):: jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP)
- call sync_all()
- if( myrank == 0) then
- write(IMAIN,*) ' ...saving databases'
- endif
+! absorbing boundary arrays (for all boundaries) - keeps all infos, allowing for irregular surfaces
+ integer :: num_absorbing_boundary_faces
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_normal
+ real(kind=CUSTOM_REAL), dimension(NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_jacobian2D
+ integer, dimension(3,NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_ijk
+ integer, dimension(num_absorbing_boundary_faces) :: absorbing_boundary_ispec
+
+ ! normals for all GLL points on boundaries
+! real(kind=CUSTOM_REAL) :: normal_xmin(NDIM,NGLLY,NGLLZ,nspec2D_xmin),&
+! normal_xmax(NDIM,NGLLY,NGLLZ,nspec2D_xmax), &
+! normal_ymin(NDIM,NGLLX,NGLLZ,nspec2D_ymin), &
+! normal_ymax(NDIM,NGLLX,NGLLZ,nspec2D_ymax), &
+! normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM),
+ real(kind=CUSTOM_REAL) :: normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP)
+
+! local parameters
+! pll
+ logical, dimension(:,:),allocatable :: iboun
-! save the binary files
- call create_name_database(prname,myrank,LOCAL_PATH)
- call save_arrays_solver_ext_mesh(nspec,nglob, &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
- jacobianstore, rho_vp,rho_vs,iflag_attenuation_store, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
- kappastore,mustore,rmass,ibool,xstore_dummy,ystore_dummy,zstore_dummy, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
- normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top, &
- jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom,jacobian2D_top,&
- ninterface_ext_mesh,my_neighbours_ext_mesh,nibool_interfaces_ext_mesh, &
- max_interface_size_ext_mesh,ibool_interfaces_ext_mesh, &
- prname,SAVE_MESH_FILES)
+ ! (assumes NGLLX=NGLLY=NGLLZ)
+ real(kind=CUSTOM_REAL) :: jacobian2D_face(NGLLX,NGLLY)
+ real(kind=CUSTOM_REAL) :: normal_face(NDIM,NGLLX,NGLLY)
+ integer:: ijk_face(3,NGLLX,NGLLY)
+
+ ! corner locations for faces
+ real(kind=CUSTOM_REAL), dimension(:,:,:),allocatable :: xcoord_iboun,ycoord_iboun,zcoord_iboun
+
+ ! face corner locations
+ real(kind=CUSTOM_REAL),dimension(NGNOD2D) :: xcoord,ycoord,zcoord
+ integer :: ispec,ispec2D,icorner,ier,iabs,iface,igll,i,j
+
+! allocate temporary flag array
+ allocate(iboun(6,nspec), &
+ xcoord_iboun(NGNOD2D,6,nspec), &
+ ycoord_iboun(NGNOD2D,6,nspec), &
+ zcoord_iboun(NGNOD2D,6,nspec),stat=ier)
+ if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+
+! sets flag in array iboun for elements with an absorbing boundary faces
+ iboun(:,:) = .false.
- if( SAVE_MESH_FILES ) then
- ! saves material flag in vtk file
- prname_file = prname(1:len_trim(prname))//'material_flag'
- call save_arrays_solver_ext_mesh_material_vtk(nspec,nglob, &
- xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
- mat_ext_mesh,prname_file)
+! abs face counter
+ iabs = 0
+
+ ! xmin
+ do ispec2D = 1, nspec2D_xmin
+ ! sets element
+ ispec = ibelm_xmin(ispec2D)
+
+ !if(myrank == 0 ) print*,'xmin:',ispec2D,ispec
+
+ ! looks for i,j,k indices of GLL points on boundary face
+ ! determines element face by given CUBIT corners
+ do icorner=1,NGNOD2D
+ xcoord(icorner) = nodes_coords_ext_mesh(1,nodes_ibelm_xmin(icorner,ispec2D))
+ ycoord(icorner) = nodes_coords_ext_mesh(2,nodes_ibelm_xmin(icorner,ispec2D))
+ zcoord(icorner) = nodes_coords_ext_mesh(3,nodes_ibelm_xmin(icorner,ispec2D))
+ !print*,'corner look:',icorner,xcoord(icorner),ycoord(icorner),zcoord(icorner)
+ enddo
+
+ ! sets face id of reference element associated with this face
+ call get_element_face_id(ispec,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ iface)
- ! saves attenuation flag in vtk file
- prname_file = prname(1:len_trim(prname))//'attenuation_flag'
- call save_arrays_solver_ext_mesh_glldata_vtk(nspec,nglob, &
- xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
- iflag_attenuation_store,prname_file)
+ iboun(iface,ispec) = .true.
- endif
+ ! ijk indices of GLL points for face id
+ call get_element_face_gll_indices(iface,ijk_face,NGLLX,NGLLZ)
+
+ ! weighted jacobian and normal
+ call get_jacobian_boundary_face(myrank,nspec, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob,&
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,&
+ ispec,iface,jacobian2D_face,normal_face,NGLLX,NGLLZ)
- deallocate(xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore)
- deallocate(jacobianstore,iflag_attenuation_store)
- deallocate(normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top)
-
-! compute the approximate amount of static memory needed to run the solver
- call memory_eval(nspec,nglob,maxval(nibool_interfaces_ext_mesh),ninterface_ext_mesh,static_memory_size)
- call max_all_dp(static_memory_size, max_static_memory_size)
+ ! normal convention: points away from element
+ ! switch normal direction if necessary
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ call get_element_face_normal(ispec,iface,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ normal_face(:,i,j) )
+ enddo
+ enddo
+ !daniel
+ ! checks: layered halfspace normals
+ ! for boundary on xmin, outward direction must be (-1,0,0)
+ !if( myrank == 0 ) then
+ !if( abs(normal_face(1,1,1) + 1.0 ) > 0.1 ) then
+ ! print*,'error normal xmin',myrank,ispec
+ ! print*,sngl(normal_face(:,1,1))
+ ! stop
+ !endif
+ !if( abs(xstore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec)) - 0.0) > 0.1 ) &
+ ! print*,'error element xmin:',ispec,xstore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec))
+ !endif
+
+ ! sets face infos
+ iabs = iabs + 1
+ absorbing_boundary_ispec(iabs) = ispec
+
+ ! gll points -- assuming NGLLX = NGLLY = NGLLZ
+ igll = 0
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ igll = igll+1
+ absorbing_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ absorbing_boundary_jacobian2D(igll,iabs) = jacobian2D_face(i,j)
+ absorbing_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
+ enddo
+ enddo
-! check the mesh, stability and resolved period
- call check_mesh_resolution(myrank,nspec,nglob,ibool,xstore_dummy,ystore_dummy,zstore_dummy, &
- kappastore,mustore,rho_vp,rho_vs, &
- -1.0d0 )
+ enddo ! nspec2D_xmin
+
+ ! xmax
+ do ispec2D = 1, nspec2D_xmax
+ ! sets element
+ ispec = ibelm_xmax(ispec2D)
+
+ ! looks for i,j,k indices of GLL points on boundary face
+ ! determines element face by given CUBIT corners
+ do icorner=1,NGNOD2D
+ xcoord(icorner) = nodes_coords_ext_mesh(1,nodes_ibelm_xmax(icorner,ispec2D))
+ ycoord(icorner) = nodes_coords_ext_mesh(2,nodes_ibelm_xmax(icorner,ispec2D))
+ zcoord(icorner) = nodes_coords_ext_mesh(3,nodes_ibelm_xmax(icorner,ispec2D))
+ enddo
+
+ ! sets face id of reference element associated with this face
+ call get_element_face_id(ispec,xcoord,ycoord,zcoord,&
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ iface )
+ iboun(iface,ispec) = .true.
+
+ ! ijk indices of GLL points on face
+ call get_element_face_gll_indices(iface,ijk_face,NGLLX,NGLLZ)
+
+ ! weighted jacobian and normal
+ call get_jacobian_boundary_face(myrank,nspec, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob,&
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,&
+ ispec,iface,jacobian2D_face,normal_face,NGLLX,NGLLZ)
+ ! normal convention: points away from element
+ ! switch normal direction if necessary
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ call get_element_face_normal(ispec,iface,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ normal_face(:,i,j) )
+ enddo
+ enddo
- deallocate(xstore_dummy,ystore_dummy,zstore_dummy)
- deallocate(kappastore,mustore,rho_vp,rho_vs)
+ !daniel
+ ! checks: layered halfspace normals
+ ! for boundary on xmin, outward direction must be (1,0,0)
+ !if( abs(normal_face(1,1,1) - 1.0 ) > 0.1 ) then
+ ! print*,'error normal xmax',myrank,ispec
+ ! print*,sngl(normal_face(:,1,1))
+ !endif
+ !if( abs(xstore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec)) - 134000.0) > 0.1 ) &
+ ! print*,'error element xmax:',ispec,xstore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec))
- end subroutine create_regions_mesh_ext_mesh
+ ! sets face infos
+ iabs = iabs + 1
+ absorbing_boundary_ispec(iabs) = ispec
+
+ ! gll points -- assuming NGLLX = NGLLY = NGLLZ
+ igll = 0
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ igll = igll+1
+ absorbing_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ absorbing_boundary_jacobian2D(igll,iabs) = jacobian2D_face(i,j)
+ absorbing_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
+ enddo
+ enddo
+
+ enddo
+ ! ymin
+ do ispec2D = 1, nspec2D_ymin
+ ! sets element
+ ispec = ibelm_ymin(ispec2D)
+
+ ! looks for i,j,k indices of GLL points on boundary face
+ ! determines element face by given CUBIT corners
+ do icorner=1,NGNOD2D
+ xcoord(icorner) = nodes_coords_ext_mesh(1,nodes_ibelm_ymin(icorner,ispec2D))
+ ycoord(icorner) = nodes_coords_ext_mesh(2,nodes_ibelm_ymin(icorner,ispec2D))
+ zcoord(icorner) = nodes_coords_ext_mesh(3,nodes_ibelm_ymin(icorner,ispec2D))
+ enddo
+
+ ! sets face id of reference element associated with this face
+ call get_element_face_id(ispec,xcoord,ycoord,zcoord,&
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ iface )
+ iboun(iface,ispec) = .true.
+
+ ! ijk indices of GLL points on face
+ call get_element_face_gll_indices(iface,ijk_face,NGLLY,NGLLZ)
-!
-!----
-!
+ ! weighted jacobian and normal
+ call get_jacobian_boundary_face(myrank,nspec, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob,&
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,&
+ ispec,iface,jacobian2D_face,normal_face,NGLLY,NGLLZ)
-subroutine prepare_assemble_MPI (nelmnts,ibool, &
- knods, ngnode, &
- npoin, &
- ninterface, max_interface_size, &
- my_nelmnts_neighbours, my_interfaces, &
- ibool_interfaces_asteroid, &
- nibool_interfaces_asteroid &
- )
+ ! normal convention: points away from element
+ ! switch normal direction if necessary
+ do j=1,NGLLZ
+ do i=1,NGLLY
+ call get_element_face_normal(ispec,iface,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ normal_face(:,i,j) )
+ enddo
+ enddo
- implicit none
+ !daniel
+ ! checks: layered halfspace normals
+ ! for boundary on xmin, outward direction must be (0,-1,0)
+ !if( abs(normal_face(2,1,1) + 1.0 ) > 0.1 ) then
+ ! print*,'error normal ymin',myrank,ispec
+ ! print*,sngl(normal_face(:,1,1))
+ !endif
+ !if( abs(ystore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec)) - 0.0) > 0.1 ) &
+ ! print*,'error element ymin:',ispec,ystore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec))
- include 'constants.h'
+ ! sets face infos
+ iabs = iabs + 1
+ absorbing_boundary_ispec(iabs) = ispec
+
+ ! gll points -- assuming NGLLX = NGLLY = NGLLZ
+ igll = 0
+ do j=1,NGLLZ
+ do i=1,NGLLY
+ igll = igll+1
+ absorbing_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ absorbing_boundary_jacobian2D(igll,iabs) = jacobian2D_face(i,j)
+ absorbing_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
+ enddo
+ enddo
+
+ enddo
- integer, intent(in) :: nelmnts, npoin, ngnode
- integer, dimension(ngnode,nelmnts), intent(in) :: knods
- integer, dimension(NGLLX,NGLLY,NGLLZ,nelmnts), intent(in) :: ibool
+ ! ymax
+ do ispec2D = 1, nspec2D_ymax
+ ! sets element
+ ispec = ibelm_ymax(ispec2D)
+
+ ! looks for i,j,k indices of GLL points on boundary face
+ ! determines element face by given CUBIT corners
+ do icorner=1,NGNOD2D
+ xcoord(icorner) = nodes_coords_ext_mesh(1,nodes_ibelm_ymax(icorner,ispec2D))
+ ycoord(icorner) = nodes_coords_ext_mesh(2,nodes_ibelm_ymax(icorner,ispec2D))
+ zcoord(icorner) = nodes_coords_ext_mesh(3,nodes_ibelm_ymax(icorner,ispec2D))
+ enddo
+
+ ! sets face id of reference element associated with this face
+ call get_element_face_id(ispec,xcoord,ycoord,zcoord,&
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ iface )
+ iboun(iface,ispec) = .true.
+
+ ! ijk indices of GLL points on face
+ call get_element_face_gll_indices(iface,ijk_face,NGLLY,NGLLZ)
- integer :: ninterface
- integer :: max_interface_size
- integer, dimension(ninterface) :: my_nelmnts_neighbours
- integer, dimension(6,max_interface_size,ninterface) :: my_interfaces
- integer, dimension(NGLLX*NGLLX*max_interface_size,ninterface) :: &
- ibool_interfaces_asteroid
- integer, dimension(ninterface) :: &
- nibool_interfaces_asteroid
+ ! weighted jacobian and normal
+ call get_jacobian_boundary_face(myrank,nspec, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ ispec,iface,jacobian2D_face,normal_face,NGLLY,NGLLZ)
- integer :: num_interface
- integer :: ispec_interface
+ ! normal convention: points away from element
+ ! switch normal direction if necessary
+ do j=1,NGLLZ
+ do i=1,NGLLY
+ call get_element_face_normal(ispec,iface,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ normal_face(:,i,j) )
+ enddo
+ enddo
- logical, dimension(:),allocatable :: mask_ibool_asteroid
+ !daniel
+ ! checks: layered halfspace normals
+ ! for boundary on xmin, outward direction must be (0,1,0)
+ !if( abs(normal_face(2,1,1) - 1.0 ) > 0.1 ) then
+ ! print*,'error normal ymax',myrank,ispec
+ ! print*,sngl(normal_face(:,1,1))
+ !endif
+ !if( abs(ystore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec)) - 134000.0) > 0.1 ) &
+ ! print*,'error element ymax:',ispec,ystore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec))
- integer :: ixmin, ixmax
- integer :: iymin, iymax
- integer :: izmin, izmax
- integer, dimension(ngnode) :: n
- integer :: e1, e2, e3, e4
- integer :: type
- integer :: ispec
+ ! sets face infos
+ iabs = iabs + 1
+ absorbing_boundary_ispec(iabs) = ispec
+
+ ! gll points -- assuming NGLLX = NGLLY = NGLLZ
+ igll = 0
+ do j=1,NGLLY
+ do i=1,NGLLX
+ igll = igll+1
+ absorbing_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ absorbing_boundary_jacobian2D(igll,iabs) = jacobian2D_face(i,j)
+ absorbing_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
+ enddo
+ enddo
+
+ enddo
+
+ ! bottom
+ do ispec2D = 1, NSPEC2D_BOTTOM
+ ! sets element
+ ispec = ibelm_bottom(ispec2D)
+
+ ! looks for i,j,k indices of GLL points on boundary face
+ ! determines element face by given CUBIT corners
+ do icorner=1,NGNOD2D
+ xcoord(icorner) = nodes_coords_ext_mesh(1,nodes_ibelm_bottom(icorner,ispec2D))
+ ycoord(icorner) = nodes_coords_ext_mesh(2,nodes_ibelm_bottom(icorner,ispec2D))
+ zcoord(icorner) = nodes_coords_ext_mesh(3,nodes_ibelm_bottom(icorner,ispec2D))
+ enddo
+
+ ! sets face id of reference element associated with this face
+ call get_element_face_id(ispec,xcoord,ycoord,zcoord,&
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ iface )
+ iboun(iface,ispec) = .true.
+
+ ! ijk indices of GLL points on face
+ call get_element_face_gll_indices(iface,ijk_face,NGLLX,NGLLY)
+
+ ! weighted jacobian and normal
+ call get_jacobian_boundary_face(myrank,nspec, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ ispec,iface,jacobian2D_face,normal_face,NGLLX,NGLLY)
- integer :: k
- integer :: npoin_interface_asteroid
+ ! normal convention: points away from element
+ ! switch normal direction if necessary
+ do j=1,NGLLY
+ do i=1,NGLLX
+ call get_element_face_normal(ispec,iface,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ normal_face(:,i,j) )
+ enddo
+ enddo
- integer :: ix,iy,iz,ier
+ !daniel
+ ! checks: layered halfspace normals
+ ! for boundary on xmin, outward direction must be (0,0,-1)
+ !if( abs(normal_face(3,1,1) + 1.0 ) > 0.1 ) then
+ ! print*,'error normal bottom',myrank,ispec
+ ! print*,sngl(normal_face(:,1,1))
+ !endif
+ !if( abs(zstore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec)) + 60000.0) > 0.1 ) &
+ ! print*,'error element bottom:',ispec,zstore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec))
- allocate( mask_ibool_asteroid(npoin), stat=ier); if( ier /= 0) stop 'error allocating array'
+ ! sets face infos
+ iabs = iabs + 1
+ absorbing_boundary_ispec(iabs) = ispec
+
+ ! gll points -- assuming NGLLX = NGLLY = NGLLZ
+ igll = 0
+ do j=1,NGLLY
+ do i=1,NGLLX
+ igll = igll+1
+ absorbing_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ absorbing_boundary_jacobian2D(igll,iabs) = jacobian2D_face(i,j)
+ absorbing_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
+ enddo
+ enddo
+
+ enddo
+
+ ! top
+ do ispec2D = 1, NSPEC2D_TOP
+ ! sets element
+ ispec = ibelm_top(ispec2D)
+
+ ! looks for i,j,k indices of GLL points on boundary face
+ ! determines element face by given CUBIT corners
+ do icorner=1,NGNOD2D
+ xcoord(icorner) = nodes_coords_ext_mesh(1,nodes_ibelm_top(icorner,ispec2D))
+ ycoord(icorner) = nodes_coords_ext_mesh(2,nodes_ibelm_top(icorner,ispec2D))
+ zcoord(icorner) = nodes_coords_ext_mesh(3,nodes_ibelm_top(icorner,ispec2D))
+ enddo
+
+ ! sets face id of reference element associated with this face
+ call get_element_face_id(ispec,xcoord,ycoord,zcoord,&
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ iface )
+ iboun(iface,ispec) = .true.
+
+ ! ijk indices of GLL points on face
+ call get_element_face_gll_indices(iface,ijk_face,NGLLX,NGLLY)
- ibool_interfaces_asteroid(:,:) = 0
- nibool_interfaces_asteroid(:) = 0
+ ! weighted jacobian and normal
+ call get_jacobian_boundary_face(myrank,nspec, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ ispec,iface,jacobian2D_face,normal_face,NGLLX,NGLLY)
- do num_interface = 1, ninterface
- npoin_interface_asteroid = 0
- mask_ibool_asteroid(:) = .false.
+ ! normal convention: points away from element
+ ! switch normal direction if necessary
+ do j=1,NGLLY
+ do i=1,NGLLX
+ call get_element_face_normal(ispec,iface,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ normal_face(:,i,j) )
+ enddo
+ enddo
- do ispec_interface = 1, my_nelmnts_neighbours(num_interface)
- ispec = my_interfaces(1,ispec_interface,num_interface)
- type = my_interfaces(2,ispec_interface,num_interface)
- do k = 1, ngnode
- n(k) = knods(k,ispec)
- end do
- e1 = my_interfaces(3,ispec_interface,num_interface)
- e2 = my_interfaces(4,ispec_interface,num_interface)
- e3 = my_interfaces(5,ispec_interface,num_interface)
- e4 = my_interfaces(6,ispec_interface,num_interface)
- call get_edge(ngnode, n, type, e1, e2, e3, e4, ixmin, ixmax, iymin, iymax, izmin, izmax)
+ !daniel
+ ! checks: layered halfspace normals
+ ! for boundary on xmin, outward direction must be (0,0,1)
+ !if( abs(normal_face(3,1,1) - 1.0 ) > 0.1 ) then
+ ! print*,'error normal top',myrank,ispec
+ ! print*,sngl(normal_face(:,1,1))
+ !endif
+ !if( abs(zstore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec)) - 0.0) > 0.1 ) &
+ ! print*,'error element top:',ispec,zstore_dummy(ibool(ijk_face(1,2,2),ijk_face(2,2,2),ijk_face(3,2,2),ispec))
- do iz = min(izmin,izmax), max(izmin,izmax)
- do iy = min(iymin,iymax), max(iymin,iymax)
- do ix = min(ixmin,ixmax), max(ixmin,ixmax)
+ ! store for free surface
+ jacobian2D_top(:,:,ispec2D) = jacobian2D_face(:,:)
+ normal_top(:,:,:,ispec2D) = normal_face(:,:,:)
- if(.not. mask_ibool_asteroid(ibool(ix,iy,iz,ispec))) then
- mask_ibool_asteroid(ibool(ix,iy,iz,ispec)) = .true.
- npoin_interface_asteroid = npoin_interface_asteroid + 1
- ibool_interfaces_asteroid(npoin_interface_asteroid,num_interface)=&
- ibool(ix,iy,iz,ispec)
- end if
- end do
- end do
- end do
+ ! store for absorbing boundaries
+ if( ABSORB_FREE_SURFACE ) then
+ ! sets face infos
+ iabs = iabs + 1
+ absorbing_boundary_ispec(iabs) = ispec
+
+ ! gll points -- assuming NGLLX = NGLLY = NGLLZ
+ igll = 0
+ do j=1,NGLLY
+ do i=1,NGLLX
+ igll = igll+1
+ absorbing_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ absorbing_boundary_jacobian2D(igll,iabs) = jacobian2D_face(i,j)
+ absorbing_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
+ enddo
+ enddo
+ endif
+ enddo
+
+ if( iabs /= num_absorbing_boundary_faces ) then
+ print*,'error number of absorbing faces:',iabs,num_absorbing_boundary_faces
+ stop 'error number of absorbing faces'
+ endif
- end do
- nibool_interfaces_asteroid(num_interface) = npoin_interface_asteroid
+ call sum_all_i(num_absorbing_boundary_faces,iabs)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' absorbing boundary:'
+ write(IMAIN,*) ' total number of faces = ',iabs
+ if( ABSORB_FREE_SURFACE ) then
+ write(IMAIN,*) 'absorbing boundary includes free surface'
+ endif
+ endif
+!obsolete...
+! calculates 2D jacobians and normals for each GLL point on face
+! call get_jacobian_boundaries(myrank,iboun,nspec, &
+! xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob,&
+! dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,&
+! ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+! xcoord_iboun,ycoord_iboun,zcoord_iboun, &
+! nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+! jacobian2D_xmin,jacobian2D_xmax, &
+! jacobian2D_ymin,jacobian2D_ymax, &
+! jacobian2D_bottom,jacobian2D_top, &
+! normal_xmin,normal_xmax, &
+! normal_ymin,normal_ymax, &
+! normal_bottom,normal_top, &
+! NSPEC2D_BOTTOM,NSPEC2D_TOP)
+! obsolete... arrays not used anymore...
+! Stacey put back
+! call get_absorb_ext_mesh(myrank,iboun,nspec, &
+! nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
+! NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM)
- end do
+end subroutine create_regions_mesh_ext_mesh_setup_absorbing_bound
- deallocate( mask_ibool_asteroid )
-
-end subroutine prepare_assemble_MPI
-
!
!----
!
-subroutine get_edge ( ngnode, n, type, e1, e2, e3, e4, ixmin, ixmax, iymin, iymax, izmin, izmax )
+subroutine create_regions_mesh_ext_mesh_prepare_MPI_interfaces(nglob,nspec,ibool, &
+ nelmnts_ext_mesh,elmnts_ext_mesh, &
+ my_nelmnts_neighbours_ext_mesh, my_interfaces_ext_mesh, &
+ ibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh, &
+ ninterface_ext_mesh,max_interface_size_ext_mesh, &
+ xstore_dummy,ystore_dummy,zstore_dummy)
+! sets up the MPI interface for communication between partitions
+
implicit none
include "constants.h"
- integer, intent(in) :: ngnode
- integer, dimension(ngnode), intent(in) :: n
- integer, intent(in) :: type, e1, e2, e3, e4
- integer, intent(out) :: ixmin, ixmax, iymin, iymax, izmin, izmax
+ integer :: nglob,nspec
- integer, dimension(4) :: en
- integer :: valence, i
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+ integer :: nelmnts_ext_mesh
+ integer, dimension(ESIZE,nelmnts_ext_mesh) :: elmnts_ext_mesh
+
+ integer :: ninterface_ext_mesh,max_interface_size_ext_mesh
+
+ integer, dimension(ninterface_ext_mesh) :: my_nelmnts_neighbours_ext_mesh
+ integer, dimension(6,max_interface_size_ext_mesh,ninterface_ext_mesh) :: my_interfaces_ext_mesh
+
+ integer, dimension(ninterface_ext_mesh) :: nibool_interfaces_ext_mesh
+ integer, dimension(NGLLX*NGLLX*max_interface_size_ext_mesh,ninterface_ext_mesh) :: ibool_interfaces_ext_mesh
+
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
+
+!local parameters
+ double precision, dimension(:), allocatable :: xp,yp,zp
+ double precision, dimension(:), allocatable :: work_ext_mesh
- if ( type == 1 ) then
- if ( e1 == n(1) ) then
- ixmin = 1
- ixmax = 1
- iymin = 1
- iymax = 1
- izmin = 1
- izmax = 1
- end if
- if ( e1 == n(2) ) then
- ixmin = NGLLX
- ixmax = NGLLX
- iymin = 1
- iymax = 1
- izmin = 1
- izmax = 1
- end if
- if ( e1 == n(3) ) then
- ixmin = NGLLX
- ixmax = NGLLX
- iymin = NGLLY
- iymax = NGLLY
- izmin = 1
- izmax = 1
- end if
- if ( e1 == n(4) ) then
- ixmin = 1
- ixmax = 1
- iymin = NGLLY
- iymax = NGLLY
- izmin = 1
- izmax = 1
- end if
- if ( e1 == n(5) ) then
- ixmin = 1
- ixmax = 1
- iymin = 1
- iymax = 1
- izmin = NGLLZ
- izmax = NGLLZ
- end if
- if ( e1 == n(6) ) then
- ixmin = NGLLX
- ixmax = NGLLX
- iymin = 1
- iymax = 1
- izmin = NGLLZ
- izmax = NGLLZ
- end if
- if ( e1 == n(7) ) then
- ixmin = NGLLX
- ixmax = NGLLX
- iymin = NGLLY
- iymax = NGLLY
- izmin = NGLLZ
- izmax = NGLLZ
- end if
- if ( e1 == n(8) ) then
- ixmin = 1
- ixmax = 1
- iymin = NGLLY
- iymax = NGLLY
- izmin = NGLLZ
- izmax = NGLLZ
- end if
- else
- if ( type == 2 ) then
- if ( e1 == n(1) ) then
- ixmin = 1
- iymin = 1
- izmin = 1
- if ( e2 == n(2) ) then
- ixmax = NGLLX
- iymax = 1
- izmax = 1
- end if
- if ( e2 == n(4) ) then
- ixmax = 1
- iymax = NGLLY
- izmax = 1
- end if
- if ( e2 == n(5) ) then
- ixmax = 1
- iymax = 1
- izmax = NGLLZ
- end if
- end if
- if ( e1 == n(2) ) then
- ixmin = NGLLX
- iymin = 1
- izmin = 1
- if ( e2 == n(3) ) then
- ixmax = NGLLX
- iymax = NGLLY
- izmax = 1
- end if
- if ( e2 == n(1) ) then
- ixmax = 1
- iymax = 1
- izmax = 1
- end if
- if ( e2 == n(6) ) then
- ixmax = NGLLX
- iymax = 1
- izmax = NGLLZ
- end if
+ integer, dimension(:), allocatable :: locval !,iglob
+ integer, dimension(:), allocatable :: nibool_interfaces_ext_mesh_true
- end if
- if ( e1 == n(3) ) then
- ixmin = NGLLX
- iymin = NGLLY
- izmin = 1
- if ( e2 == n(4) ) then
- ixmax = 1
- iymax = NGLLY
- izmax = 1
- end if
- if ( e2 == n(2) ) then
- ixmax = NGLLX
- iymax = 1
- izmax = 1
- end if
- if ( e2 == n(7) ) then
- ixmax = NGLLX
- iymax = NGLLY
- izmax = NGLLZ
- end if
- end if
- if ( e1 == n(4) ) then
- ixmin = 1
- iymin = NGLLY
- izmin = 1
- if ( e2 == n(1) ) then
- ixmax = 1
- iymax = 1
- izmax = 1
- end if
- if ( e2 == n(3) ) then
- ixmax = NGLLX
- iymax = NGLLY
- izmax = 1
- end if
- if ( e2 == n(8) ) then
- ixmax = 1
- iymax = NGLLY
- izmax = NGLLZ
- end if
- end if
- if ( e1 == n(5) ) then
- ixmin = 1
- iymin = 1
- izmin = NGLLZ
- if ( e2 == n(1) ) then
- ixmax = 1
- iymax = 1
- izmax = 1
- end if
- if ( e2 == n(6) ) then
- ixmax = NGLLX
- iymax = 1
- izmax = NGLLZ
- end if
- if ( e2 == n(8) ) then
- ixmax = 1
- iymax = NGLLY
- izmax = NGLLZ
- end if
- end if
- if ( e1 == n(6) ) then
- ixmin = NGLLX
- iymin = 1
- izmin = NGLLZ
- if ( e2 == n(2) ) then
- ixmax = NGLLX
- iymax = 1
- izmax = 1
- end if
- if ( e2 == n(7) ) then
- ixmax = NGLLX
- iymax = NGLLY
- izmax = NGLLZ
- end if
- if ( e2 == n(5) ) then
- ixmax = 1
- iymax = 1
- izmax = NGLLZ
- end if
- end if
- if ( e1 == n(7) ) then
- ixmin = NGLLX
- iymin = NGLLY
- izmin = NGLLZ
- if ( e2 == n(3) ) then
- ixmax = NGLLX
- iymax = NGLLY
- izmax = 1
- end if
- if ( e2 == n(8) ) then
- ixmax = 1
- iymax = NGLLY
- izmax = NGLLZ
- end if
- if ( e2 == n(6) ) then
- ixmax = NGLLX
- iymax = 1
- izmax = NGLLZ
- end if
- end if
- if ( e1 == n(8) ) then
- ixmin = 1
- iymin = NGLLY
- izmin = NGLLZ
- if ( e2 == n(4) ) then
- ixmax = 1
- iymax = NGLLY
- izmax = 1
- end if
- if ( e2 == n(5) ) then
- ixmax = 1
- iymax = 1
- izmax = NGLLZ
- end if
- if ( e2 == n(7) ) then
- ixmax = NGLLX
- iymax = NGLLY
- izmax = NGLLZ
- end if
- end if
+! for MPI buffers
+ integer, dimension(:), allocatable :: reorder_interface_ext_mesh,ind_ext_mesh,ninseg_ext_mesh,iwork_ext_mesh
+ integer, dimension(:), allocatable :: ibool_interface_ext_mesh_dummy
- else
- if (type == 4) then
- en(1) = e1
- en(2) = e2
- en(3) = e3
- en(4) = e4
+ logical, dimension(:), allocatable :: ifseg
- valence = 0
- do i = 1, 4
- if ( en(i) == n(1)) then
- valence = valence+1
- endif
- if ( en(i) == n(2)) then
- valence = valence+1
- endif
- if ( en(i) == n(3)) then
- valence = valence+1
- endif
- if ( en(i) == n(4)) then
- valence = valence+1
- endif
- enddo
- if ( valence == 4 ) then
- ixmin = 1
- iymin = 1
- izmin = 1
- ixmax = NGLLX
- iymax = NGLLY
- izmax = 1
- endif
+ integer :: iinterface,ilocnum
+
- valence = 0
- do i = 1, 4
- if ( en(i) == n(1)) then
- valence = valence+1
- endif
- if ( en(i) == n(2)) then
- valence = valence+1
- endif
- if ( en(i) == n(5)) then
- valence = valence+1
- endif
- if ( en(i) == n(6)) then
- valence = valence+1
- endif
- enddo
- if ( valence == 4 ) then
- ixmin = 1
- iymin = 1
- izmin = 1
- ixmax = NGLLX
- iymax = 1
- izmax = NGLLZ
- endif
+! get global indices for MPI interfaces between different partitions
+ call prepare_assemble_MPI (nelmnts_ext_mesh,ibool, &
+ elmnts_ext_mesh, ESIZE, &
+ nglob, &
+ ninterface_ext_mesh, max_interface_size_ext_mesh, &
+ my_nelmnts_neighbours_ext_mesh, my_interfaces_ext_mesh, &
+ ibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh &
+ )
- valence = 0
- do i = 1, 4
- if ( en(i) == n(2)) then
- valence = valence+1
- endif
- if ( en(i) == n(3)) then
- valence = valence+1
- endif
- if ( en(i) == n(6)) then
- valence = valence+1
- endif
- if ( en(i) == n(7)) then
- valence = valence+1
- endif
- enddo
- if ( valence == 4 ) then
- ixmin = NGLLX
- iymin = 1
- izmin = 1
- ixmax = NGLLX
- iymax = NGLLZ
- izmax = NGLLZ
- endif
+ allocate(nibool_interfaces_ext_mesh_true(ninterface_ext_mesh))
- valence = 0
- do i = 1, 4
- if ( en(i) == n(3)) then
- valence = valence+1
- endif
- if ( en(i) == n(4)) then
- valence = valence+1
- endif
- if ( en(i) == n(7)) then
- valence = valence+1
- endif
- if ( en(i) == n(8)) then
- valence = valence+1
- endif
- enddo
- if ( valence == 4 ) then
- ixmin = 1
- iymin = NGLLY
- izmin = 1
- ixmax = NGLLX
- iymax = NGLLY
- izmax = NGLLZ
- endif
+! sort ibool comm buffers lexicographically
+ do iinterface = 1, ninterface_ext_mesh
- valence = 0
- do i = 1, 4
- if ( en(i) == n(1)) then
- valence = valence+1
- endif
- if ( en(i) == n(4)) then
- valence = valence+1
- endif
- if ( en(i) == n(5)) then
- valence = valence+1
- endif
- if ( en(i) == n(8)) then
- valence = valence+1
- endif
- enddo
- if ( valence == 4 ) then
- ixmin = 1
- iymin = 1
- izmin = 1
- ixmax = 1
- iymax = NGLLY
- izmax = NGLLZ
- endif
+ allocate(xp(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(yp(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(zp(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(locval(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(ifseg(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(reorder_interface_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(ibool_interface_ext_mesh_dummy(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(ind_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(ninseg_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(iwork_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
+ allocate(work_ext_mesh(nibool_interfaces_ext_mesh(iinterface)))
- valence = 0
- do i = 1, 4
- if ( en(i) == n(5)) then
- valence = valence+1
- endif
- if ( en(i) == n(6)) then
- valence = valence+1
- endif
- if ( en(i) == n(7)) then
- valence = valence+1
- endif
- if ( en(i) == n(8)) then
- valence = valence+1
- endif
- enddo
- if ( valence == 4 ) then
- ixmin = 1
- iymin = 1
- izmin = NGLLZ
- ixmax = NGLLX
- iymax = NGLLY
- izmax = NGLLZ
- endif
+ do ilocnum = 1, nibool_interfaces_ext_mesh(iinterface)
+ xp(ilocnum) = xstore_dummy(ibool_interfaces_ext_mesh(ilocnum,iinterface))
+ yp(ilocnum) = ystore_dummy(ibool_interfaces_ext_mesh(ilocnum,iinterface))
+ zp(ilocnum) = zstore_dummy(ibool_interfaces_ext_mesh(ilocnum,iinterface))
+ enddo
- else
- stop 'ERROR get_edge'
- endif
+ call sort_array_coordinates(nibool_interfaces_ext_mesh(iinterface),xp,yp,zp, &
+ ibool_interfaces_ext_mesh(1:nibool_interfaces_ext_mesh(iinterface),iinterface), &
+ reorder_interface_ext_mesh,locval,ifseg,nibool_interfaces_ext_mesh_true(iinterface), &
+ ind_ext_mesh,ninseg_ext_mesh,iwork_ext_mesh,work_ext_mesh)
- end if
- end if
+ deallocate(xp)
+ deallocate(yp)
+ deallocate(zp)
+ deallocate(locval)
+ deallocate(ifseg)
+ deallocate(reorder_interface_ext_mesh)
+ deallocate(ibool_interface_ext_mesh_dummy)
+ deallocate(ind_ext_mesh)
+ deallocate(ninseg_ext_mesh)
+ deallocate(iwork_ext_mesh)
+ deallocate(work_ext_mesh)
-end subroutine get_edge
+ enddo
+end subroutine create_regions_mesh_ext_mesh_prepare_MPI_interfaces
-
!pll
! subroutine interface(iflag,flag_below,flag_above,ispec,nspec,i,j,k,xstore,ystore,zstore,ibedrock)
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -64,6 +64,7 @@
integer :: count_def_mat,count_undef_mat,imat
character (len=30), dimension(:,:), allocatable :: undef_mat_prop
+
! sets number of nodes per element
ngnod = esize
@@ -80,22 +81,32 @@
print*, 'total number of nodes: '
print*, ' nnodes = ', nnodes
-! reads mesh elements connectivity
+! reads mesh elements indexing
+!(CUBIT calls this the connectivity, guess in the sense that it connects with the points index in
+! the global coordinate file "nodes_coords_file"; it doesn't tell you which point is connected with others)
open(unit=98, file='./OUTPUT_FILES/mesh_file', status='old', form='formatted')
read(98,*) nspec
allocate(elmnts(esize,nspec))
do ispec = 1, nspec
! format: # element_id #id_node1 ... #id_node8
- ! note: be aware of the different node ordering between mesh_file and spectral elements array elmnts(:,:);
- ! spectral elements starts ordering first at the bottom of the element, anticlock-wise, i.e.
+
+ ! note: be aware that here we can have different node ordering for a cube element;
+ ! the ordering from Cubit files might not be consistent for multiple volumes, or uneven, unstructured grids
+ !
+ ! guess here it assumes that spectral elements ordering is like first at the bottom of the element, anticlock-wise, i.e.
! point 1 = (0,0,0), point 2 = (0,1,0), point 3 = (1,1,0), point 4 = (1,0,0)
! then top (positive z-direction) of element
- ! point 1 = (0,0,1), point 2 = (0,1,1), point 3 = (1,1,1), point 4 = (1,0,1)
+ ! point 5 = (0,0,1), point 6 = (0,1,1), point 7 = (1,1,1), point 8 = (1,0,1)
read(98,*) num_elmnt, elmnts(5,num_elmnt), elmnts(1,num_elmnt),elmnts(4,num_elmnt), elmnts(8,num_elmnt), &
elmnts(6,num_elmnt), elmnts(2,num_elmnt), elmnts(3,num_elmnt), elmnts(7,num_elmnt)
+
+ ! read(98,*) num_elmnt, elmnts(1,num_elmnt), elmnts(2,num_elmnt),elmnts(3,num_elmnt), elmnts(4,num_elmnt), &
+ ! elmnts(5,num_elmnt), elmnts(6,num_elmnt), elmnts(7,num_elmnt), elmnts(8,num_elmnt)
+
if((num_elmnt > nspec) .or. (num_elmnt < 1) ) stop "ERROR : Invalid mesh file."
-
- !outputs info for each element for check of ordering
+
+
+ !outputs info for each element to see ordering
!print*,'ispec: ',ispec
!print*,' ',num_elmnt, elmnts(5,num_elmnt), elmnts(1,num_elmnt),elmnts(4,num_elmnt), elmnts(8,num_elmnt), &
! elmnts(6,num_elmnt), elmnts(2,num_elmnt), elmnts(3,num_elmnt), elmnts(7,num_elmnt)
@@ -105,6 +116,7 @@
! nodes_coords(1,elmnts(i,num_elmnt)),nodes_coords(2,elmnts(i,num_elmnt)),nodes_coords(3,elmnts(i,num_elmnt))
!enddo
!print*
+
end do
close(98)
print*, 'total number of spectral elements:'
@@ -120,7 +132,9 @@
if((num_mat > nspec) .or. (num_mat < 1) ) stop "ERROR : Invalid mat file."
end do
close(98)
-!must be changed, if mat(1,i) < 0 1 == interface , 2 == tomography
+
+! TODO:
+! must be changed, if mat(1,i) < 0 1 == interface , 2 == tomography
mat(2,:) = 1
! reads material definitions
@@ -176,7 +190,11 @@
allocate(nodes_ibelm_xmin(4,nspec2D_xmin))
do ispec2D = 1,nspec2D_xmin
! format: #id_(element containing the face) #id_node1_face .. #id_node4_face
- ! note: ordering starts on top, rear, then bottom, rear, bottom, front, and finally top, front i.e.:
+ ! note: ordering for CUBIT seems such that the normal of the face points outward of the element the face belongs to;
+ ! in other words, nodes are in increasing order such that when looking from within the element outwards,
+ ! they are ordered clockwise
+ !
+ ! doesn't necessarily have to start on top-rear, then bottom-rear, bottom-front, and finally top-front i.e.:
! point 1 = (0,1,1), point 2 = (0,1,0), point 3 = (0,0,0), point 4 = (0,0,1)
read(98,*) ibelm_xmin(ispec2D), nodes_ibelm_xmin(1,ispec2D), nodes_ibelm_xmin(2,ispec2D), &
nodes_ibelm_xmin(3,ispec2D), nodes_ibelm_xmin(4,ispec2D)
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -34,7 +34,7 @@
allocate(ispec_is_surface_external_mesh(NSPEC_AB))
allocate(iglob_is_surface_external_mesh(NGLOB_AB))
- if (.not. RECVS_CAN_BE_BURIED_EXT_MESH) then
+ if (.not. RECVS_CAN_BE_BURIED_EXT_MESH .or. EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP) then
valence_external_mesh(:) = 0
ispec_is_surface_external_mesh(:) = .false.
iglob_is_surface_external_mesh(:) = .false.
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -60,11 +60,11 @@
endif
if(ABSORBING_CONDITIONS .and. (SIMULATION_TYPE == 3 .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- if (nspec2D_xmin > 0) close(31)
- if (nspec2D_xmax > 0) close(32)
- if (nspec2D_ymin > 0) close(33)
- if (nspec2D_ymax > 0) close(34)
- if (NSPEC2D_BOTTOM > 0) close(35)
+ !if (nspec2D_xmin > 0) close(31)
+ !if (nspec2D_xmax > 0) close(32)
+ !if (nspec2D_ymin > 0) close(33)
+ !if (nspec2D_ymax > 0) close(34)
+ !if (NSPEC2D_BOTTOM > 0) close(35)
endif
if (nrec_local > 0) then
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/generate_databases.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -25,13 +25,6 @@
!
! United States and French Government Sponsorship Acknowledged.
!
-
- subroutine generate_databases
-
- implicit none
-
- include "constants.h"
-
!=============================================================================!
! !
! generate_databases produces a spectral element grid !
@@ -187,12 +180,19 @@
!
! MPI v. 1.0 Dimitri Komatitsch, Caltech, May 2002: first MPI version based on global code
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ module generate_databases_par
+
+ implicit none
+
+ include "constants.h"
+
! number of spectral elements in each block
integer nspec,npointot
-! auxiliary variables to generate the mesh
-! integer ix,iy
-
! parameters needed to store the radii of the grid points
! integer, dimension(:), allocatable :: idoubling
integer, dimension(:,:,:,:), allocatable :: ibool
@@ -239,10 +239,12 @@
double precision :: max_static_memory_size,max_static_memory_size_request
! this for all the regions
- integer NSPEC_AB,NGLOB_AB, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX
+ integer NSPEC_AB,NGLOB_AB
+
+ integer NSPEC2D_BOTTOM,NSPEC2D_TOP
+
+! integer NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX, &
+! NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
double precision min_elevation,max_elevation
double precision min_elevation_all,max_elevation_all
@@ -278,9 +280,13 @@
integer, dimension(:,:), allocatable :: mat_ext_mesh
! pll
- double precision, dimension(:,:), allocatable :: materials_ext_mesh
+ double precision, dimension(:,:), allocatable :: materials_ext_mesh
integer, dimension(:), allocatable :: ibelm_xmin,ibelm_xmax, ibelm_ymin, ibelm_ymax, ibelm_bottom, ibelm_top
- integer :: ispec2D, boundary_number
+ integer, dimension(:,:), allocatable :: nodes_ibelm_xmin,nodes_ibelm_xmax, &
+ nodes_ibelm_ymin, nodes_ibelm_ymax, nodes_ibelm_bottom, nodes_ibelm_top
+
+
+ integer :: ispec2D, boundary_number,j
integer :: nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, nspec2D_ymax, nspec2D_bottom_ext, nspec2D_top_ext
character (len=30), dimension(:,:), allocatable :: undef_mat_prop
@@ -291,8 +297,19 @@
integer :: nglob,nglob_total,nspec_total
-! ************** PROGRAM STARTS HERE **************
+! auxiliary variables to generate the mesh
+! integer ix,iy
+
+ end module
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine generate_databases
+
+ use generate_databases_par
+
! sizeprocs returns number of processes started (should be equal to NPROC).
! myrank is the rank of each process, between 0 and NPROC-1.
! as usual in MPI, process 0 is in charge of coordinating everything
@@ -329,10 +346,153 @@
SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
+! checks user input parameters for mesher to run
+ call generate_databases_check_parameters()
+
+! reads topography and bathymetry file
+ call generate_databases_read_topography()
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '**************************'
+ write(IMAIN,*) 'creating mesh in the model'
+ write(IMAIN,*) '**************************'
+ write(IMAIN,*)
+ endif
+
+! reads Databases files
+ call generate_databases_read_partition_files()
+
+! external mesh creation
+ call generate_databases_setup_mesh()
+
+!--- print number of points and elements in the mesh
+ call sum_all_i(NGLOB_AB,nglob_total)
+ call sum_all_i(NSPEC_AB,nspec_total)
+ call sync_all()
+ if(myrank == 0) then
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'Repartition of elements:'
+ write(IMAIN,*) '-----------------------'
+ write(IMAIN,*)
+ write(IMAIN,*) 'total number of elements in each slice: ',NSPEC_AB
+ write(IMAIN,*) 'total number of points in each slice: ',NGLOB_AB
+ write(IMAIN,*)
+ write(IMAIN,*) 'total number of elements in entire mesh: ',nspec_total ! NSPEC_AB*NPROC
+ write(IMAIN,*) 'total number of points in entire mesh: ',nglob_total !NGLOB_AB*NPROC
+ write(IMAIN,*) 'total number of DOFs in entire mesh: ',nglob_total*NDIM !NGLOB_AB*NPROC*NDIM
+ write(IMAIN,*)
+ write(IMAIN,*) 'total number of time steps in the solver will be: ',NSTEP
+ write(IMAIN,*)
+
+ ! write information about precision used for floating-point operations
+ if(CUSTOM_REAL == SIZE_REAL) then
+ write(IMAIN,*) 'using single precision for the calculations'
+ else
+ write(IMAIN,*) 'using double precision for the calculations'
+ endif
+ write(IMAIN,*)
+ write(IMAIN,*) 'smallest and largest possible floating-point numbers are: ',tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
+ write(IMAIN,*)
+
+ ! copy number of elements and points in an include file for the solver
+ call save_header_file(NSPEC_AB,NGLOB_AB,NPROC, &
+ ATTENUATION,ANISOTROPY,NSTEP,DT, &
+ SIMULATION_TYPE,max_static_memory_size)
+
+! call get_value_string(rec_filename, 'solver.STATIONS', 'DATA/STATIONS')
+! call get_value_string(filtered_rec_filename, 'solver.STATIONS_FILTERED', 'DATA/STATIONS_FILTERED')
+
+! get total number of stations
+! open(unit=IIN,file=rec_filename,iostat=ios,status='old',action='read')
+! nrec = 0
+! do while(ios == 0)
+! read(IIN,"(a)",iostat=ios) dummystring
+! if(ios == 0) nrec = nrec + 1
+! enddo
+! close(IIN)
+
+! filter list of stations, only retain stations that are in the model
+! nrec_filtered = 0
+! open(unit=IIN,file=rec_filename,status='old',action='read')
+! do irec = 1,nrec
+! read(IIN,*) station_name,network_name,stlat,stlon,stele,stbur
+! if((stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) &
+! .or. USE_EXTERNAL_MESH) &
+! nrec_filtered = nrec_filtered + 1
+! enddo
+! close(IIN)
+
+! write(IMAIN,*)
+! write(IMAIN,*) 'there are ',nrec,' stations in file ', trim(rec_filename)
+! write(IMAIN,*) 'saving ',nrec_filtered,' stations inside the model in file ', trim(filtered_rec_filename)
+! write(IMAIN,*) 'excluding ',nrec - nrec_filtered,' stations located outside the model'
+! write(IMAIN,*)
+
+! if(nrec_filtered < 1) call exit_MPI(myrank,'need at least one station in the model')
+
+! if(nrec < 1) call exit_MPI(myrank,'need at least one station in the model')
+
+! open(unit=IIN,file=rec_filename,status='old',action='read')
+! open(unit=IOUT,file=filtered_rec_filename,status='unknown')
+
+! do irec = 1,nrec
+! read(IIN,*) station_name,network_name,stlat,stlon,stele,stbur
+! if((stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) &
+! .or. USE_EXTERNAL_MESH) &
+! write(IOUT,*) station_name(1:len_trim(station_name)),' ',network_name(1:len_trim(network_name)),' ', &
+! sngl(stlat),' ',sngl(stlon), ' ', sngl(stele), ' ', sngl(stbur)
+! enddo
+
+! close(IIN)
+! close(IOUT)
+
+ endif ! end of section executed by main process only
+
+! elapsed time since beginning of mesh generation
+ if(myrank == 0) then
+ tCPU = wtime() - time_start
+ write(IMAIN,*)
+ write(IMAIN,*) 'Elapsed time for mesh generation and buffer creation in seconds = ',tCPU
+ write(IMAIN,*) 'End of mesh generation'
+ write(IMAIN,*)
+ endif
+
+! close main output file
+ if(myrank == 0) then
+ write(IMAIN,*) 'done'
+ write(IMAIN,*)
+ close(IMAIN)
+ endif
+
+! synchronize all the processes to make sure everybody has finished
+ call sync_all()
+
+ end subroutine generate_databases
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine generate_databases_check_parameters
+
+! checks user input parameters
+
+ use generate_databases_par
+
if (sizeprocs == 1 .and. (NPROC_XI /= 1 .or. NPROC_ETA /= 1)) then
stop 'must have NPROC_XI = NPROC_ETA = 1 for a serial run'
endif
+! there would be a problem with absorbing boundaries for different NGLLX,NGLLY,NGLLZ values
+! just to be sure for now..
+ if( ABSORBING_CONDITIONS ) then
+ if( NGLLX /= NGLLY .and. NGLLY /= NGLLZ ) &
+ stop 'must have NGLLX = NGLLY = NGLLZ for external meshes'
+ endif
+
! info about external mesh simulation
! nlegoff -- should be put in compute_parameters and read_parameter_file for clarity
! chris -- once the steps in decompose_mesh_SCOTCH are integrated into generate_database.f90,
@@ -373,7 +533,8 @@
endif
! check that reals are either 4 or 8 bytes
- if(CUSTOM_REAL /= SIZE_REAL .and. CUSTOM_REAL /= SIZE_DOUBLE) call exit_MPI(myrank,'wrong size of CUSTOM_REAL for reals')
+ if(CUSTOM_REAL /= SIZE_REAL .and. CUSTOM_REAL /= SIZE_DOUBLE) &
+ call exit_MPI(myrank,'wrong size of CUSTOM_REAL for reals')
if(NGNOD /= 8) call exit_MPI(myrank,'number of control nodes must be 8')
if(NGNOD2D /= 4) call exit_MPI(myrank,'elements with 8 points should have NGNOD2D = 4')
@@ -421,7 +582,18 @@
endif
-! read topography and bathymetry file
+ end subroutine generate_databases_check_parameters
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine generate_databases_read_topography
+
+! reads in topography files
+
+ use generate_databases_par
+
if(TOPOGRAPHY .or. OCEANS) then
! for Southern California
@@ -457,16 +629,20 @@
! close(55)
! endif
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) '**************************'
- write(IMAIN,*) 'creating mesh in the model'
- write(IMAIN,*) '**************************'
- write(IMAIN,*)
- endif
+ end subroutine generate_databases_read_topography
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+ subroutine generate_databases_read_partition_files
+
+! reads in proc***_Databases files
+
+ use generate_databases_par
+
! read databases about external mesh simulation
-
+! global node coordinates
call create_name_database(prname,myrank,LOCAL_PATH)
open(unit=IIN,file=prname(1:len_trim(prname))//'Database',status='old',action='read',form='formatted',iostat=ier)
if( ier /= 0 ) then
@@ -477,7 +653,8 @@
read(IIN,*) nnodes_ext_mesh
allocate(nodes_coords_ext_mesh(NDIM,nnodes_ext_mesh))
do inode = 1, nnodes_ext_mesh
- read(IIN,*) dummy_node, nodes_coords_ext_mesh(1,inode), nodes_coords_ext_mesh(2,inode), nodes_coords_ext_mesh(3,inode)
+ read(IIN,*) dummy_node, nodes_coords_ext_mesh(1,inode), nodes_coords_ext_mesh(2,inode), &
+ nodes_coords_ext_mesh(3,inode)
enddo
@@ -511,7 +688,7 @@
endif
call sync_all()
-
+! element indexing
read(IIN,*) nelmnts_ext_mesh
allocate(elmnts_ext_mesh(esize,nelmnts_ext_mesh))
allocate(mat_ext_mesh(2,nelmnts_ext_mesh))
@@ -541,39 +718,41 @@
if(boundary_number /= 5) stop "Error : invalid database file"
read(IIN,*) boundary_number ,nspec2D_top_ext
if(boundary_number /= 6) stop "Error : invalid database file"
- NSPEC2DMAX_XMIN_XMAX = max(nspec2D_xmin,nspec2D_xmax)
- NSPEC2DMAX_YMIN_YMAX = max(nspec2D_ymin,nspec2D_ymax)
+
NSPEC2D_BOTTOM = nspec2D_bottom_ext
NSPEC2D_TOP = nspec2D_top_ext
- allocate(ibelm_xmin(nspec2D_xmin))
+! NSPEC2DMAX_XMIN_XMAX = max(nspec2D_xmin,nspec2D_xmax)
+! NSPEC2DMAX_YMIN_YMAX = max(nspec2D_ymin,nspec2D_ymax)
+
+ allocate(ibelm_xmin(nspec2D_xmin),nodes_ibelm_xmin(4,nspec2D_xmin))
do ispec2D = 1,nspec2D_xmin
- read(IIN,*) ibelm_xmin(ispec2D)
+ read(IIN,*) ibelm_xmin(ispec2D),(nodes_ibelm_xmin(j,ispec2D),j=1,4)
end do
- allocate(ibelm_xmax(nspec2D_xmax))
+ allocate(ibelm_xmax(nspec2D_xmax),nodes_ibelm_xmax(4,nspec2D_xmax))
do ispec2D = 1,nspec2D_xmax
- read(IIN,*) ibelm_xmax(ispec2D)
+ read(IIN,*) ibelm_xmax(ispec2D),(nodes_ibelm_xmax(j,ispec2D),j=1,4)
end do
- allocate(ibelm_ymin(nspec2D_ymin))
+ allocate(ibelm_ymin(nspec2D_ymin),nodes_ibelm_ymin(4,nspec2D_ymin))
do ispec2D = 1,nspec2D_ymin
- read(IIN,*) ibelm_ymin(ispec2D)
+ read(IIN,*) ibelm_ymin(ispec2D),(nodes_ibelm_ymin(j,ispec2D),j=1,4)
end do
- allocate(ibelm_ymax(nspec2D_ymax))
+ allocate(ibelm_ymax(nspec2D_ymax),nodes_ibelm_ymax(4,nspec2D_ymax))
do ispec2D = 1,nspec2D_ymax
- read(IIN,*) ibelm_ymax(ispec2D)
+ read(IIN,*) ibelm_ymax(ispec2D),(nodes_ibelm_ymax(j,ispec2D),j=1,4)
end do
- allocate(ibelm_bottom(nspec2D_bottom_ext))
+ allocate(ibelm_bottom(nspec2D_bottom_ext),nodes_ibelm_bottom(4,nspec2D_bottom_ext))
do ispec2D = 1,nspec2D_bottom_ext
- read(IIN,*) ibelm_bottom(ispec2D)
+ read(IIN,*) ibelm_bottom(ispec2D),(nodes_ibelm_bottom(j,ispec2D),j=1,4)
end do
- allocate(ibelm_top(nspec2D_top_ext))
+ allocate(ibelm_top(nspec2D_top_ext),nodes_ibelm_top(4,nspec2D_top_ext))
do ispec2D = 1,nspec2D_top_ext
- read(IIN,*) ibelm_top(ispec2D)
+ read(IIN,*) ibelm_top(ispec2D),(nodes_ibelm_top(j,ispec2D),j=1,4)
end do
if(myrank == 0) then
@@ -581,10 +760,11 @@
write(IMAIN,*) ' xmin,xmax: ',nspec2D_xmin,nspec2D_xmax
write(IMAIN,*) ' ymin,ymax: ',nspec2D_ymin,nspec2D_ymax
write(IMAIN,*) ' bottom,top: ',nspec2D_bottom_ext,nspec2D_top_ext
- write(IMAIN,*) ' xmin_xmax,ymin_ymax: ',NSPEC2DMAX_XMIN_XMAX, NSPEC2DMAX_YMIN_YMAX
+ !write(IMAIN,*) ' xmin_xmax,ymin_ymax: ',NSPEC2DMAX_XMIN_XMAX, NSPEC2DMAX_YMIN_YMAX
endif
call sync_all()
+! MPI interfaces between different partitions
read(IIN,*) ninterface_ext_mesh, max_interface_size_ext_mesh
allocate(my_neighbours_ext_mesh(ninterface_ext_mesh))
allocate(my_nelmnts_neighbours_ext_mesh(ninterface_ext_mesh))
@@ -602,75 +782,71 @@
close(IIN)
if(myrank == 0) then
- write(IMAIN,*) ' partition interfaces: ',ninterface_ext_mesh
+ write(IMAIN,*) ' number of MPI partition interfaces: ',ninterface_ext_mesh
endif
call sync_all()
+
+ end subroutine generate_databases_read_partition_files
+!
+!-------------------------------------------------------------------------------------------------
+!
+ subroutine generate_databases_setup_mesh
+
+! mesh creation for static solver
+
+ use generate_databases_par
+
! assign theoretical number of elements
nspec = NSPEC_AB
! compute maximum number of points
npointot = nspec * NGLLCUBE
-! make sure everybody is synchronized
- call sync_all()
-
! use dynamic allocation to allocate memory for arrays
! allocate(idoubling(nspec))
allocate(ibool(NGLLX,NGLLY,NGLLZ,nspec))
allocate(xstore(NGLLX,NGLLY,NGLLZ,nspec))
allocate(ystore(NGLLX,NGLLY,NGLLZ,nspec))
- allocate(zstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier)
-
-! exit if there is not enough memory to allocate all the arrays
+ allocate(zstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier)
if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
-! memory usage, in generate_database() routine so far
- max_static_memory_size = NGLLX*NGLLY*NGLLZ*nspec*4 + 3*NGLLX*NGLLY*NGLLZ*nspec*8 &
- + NDIM*nnodes_ext_mesh*8 + ESIZE*nelmnts_ext_mesh*4 + 2*nelmnts_ext_mesh*4 &
- + 5*nmat_ext_mesh*8 + 3*ninterface_ext_mesh + 6*max_interface_size_ext_mesh*ninterface_ext_mesh*4 &
- + NGLLX*NGLLX*max_interface_size_ext_mesh*ninterface_ext_mesh*4 &
- + nspec2D_xmin*4 + nspec2D_xmax*4 + nspec2D_ymin*4 + nspec2D_ymax*4 + nspec2D_bottom*4 + nspec2D_top*4
+ call memory_eval_mesher(myrank,nspec,npointot,nnodes_ext_mesh,&
+ nelmnts_ext_mesh,nmat_ext_mesh,ninterface_ext_mesh, &
+ max_interface_size_ext_mesh,nspec2D_xmin,nspec2D_xmax,&
+ nspec2D_ymin,nspec2D_ymax,nspec2D_bottom,nspec2D_top,&
+ max_static_memory_size_request)
+
+ max_static_memory_size = max_static_memory_size_request
-! memory usage, in create_regions_mesh_ext_mesh() routine requested approximately
- max_static_memory_size_request = 2*2*nspec2dmax_ymin_ymax*4 + 2*2*nspec2dmax_xmin_xmax*4 &
- + 3*NGNOD*8 + NGLLX*NGLLY*NGLLZ*nspec*4 + 6*nspec*1 + 6*NGLLX*8 &
- + NGNOD*NGLLX*NGLLY*NGLLZ*8 + NDIM*NGNOD*NGLLX*NGLLY*NGLLZ*8 &
- + 4*NGNOD2D*NGLLY*NGLLZ*8 + 4*NDIM2D*NGNOD2D*NGLLX*NGLLY*8 &
- + 17*NGLLX*NGLLY*NGLLY*nspec*CUSTOM_REAL &
- + (1+NDIM)*NGLLY*NGLLZ*nspec2D_xmin*CUSTOM_REAL + (1+NDIM)*NGLLY*NGLLZ*nspec2D_xmax*CUSTOM_REAL &
- + (1+NDIM)*NGLLX*NGLLZ*nspec2D_ymin*CUSTOM_REAL + (1+NDIM)*NGLLX*NGLLZ*nspec2D_ymax*CUSTOM_REAL &
- + (1+NDIM)*NGLLX*NGLLY*NSPEC2D_BOTTOM*CUSTOM_REAL + (1+NDIM)*NGLLX*NGLLY*NSPEC2D_TOP*CUSTOM_REAL &
- + 2*npointot*4 + npointot + 3*npointot*8
-
+! make sure everybody is synchronized
call sync_all()
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) ' minimum memory used so far : ',max_static_memory_size / 1024. / 1024.,&
- 'MB per process'
- write(IMAIN,*) ' minimum total memory requested : ',(max_static_memory_size+max_static_memory_size_request)/1024./1024.,&
- 'MB per process'
- write(IMAIN,*)
- endif
- max_static_memory_size = max_static_memory_size_request
-! create all the regions of the mesh
+! main working routine to create all the regions of the mesh
if(myrank == 0) then
write(IMAIN,*) 'create regions: '
endif
+
call create_regions_mesh_ext_mesh(ibool, &
- xstore, ystore, zstore, nspec, npointot, myrank, LOCAL_PATH, &
- nnodes_ext_mesh, nelmnts_ext_mesh, &
- nodes_coords_ext_mesh, elmnts_ext_mesh, max_static_memory_size, mat_ext_mesh, materials_ext_mesh, &
- nmat_ext_mesh, undef_mat_prop, nundefMat_ext_mesh, ninterface_ext_mesh, max_interface_size_ext_mesh, &
- my_neighbours_ext_mesh, my_nelmnts_neighbours_ext_mesh, my_interfaces_ext_mesh, &
- ibool_interfaces_ext_mesh, nibool_interfaces_ext_mesh, &
- nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, nspec2D_ymax, NSPEC2D_BOTTOM, NSPEC2D_TOP,&
- NSPEC2DMAX_XMIN_XMAX, NSPEC2DMAX_YMIN_YMAX, &
- ibelm_xmin, ibelm_xmax, ibelm_ymin, ibelm_ymax, ibelm_bottom, ibelm_top, &
- SAVE_MESH_FILES,nglob)
+ xstore, ystore, zstore, nspec, npointot, myrank, LOCAL_PATH, &
+ nnodes_ext_mesh, nelmnts_ext_mesh, &
+ nodes_coords_ext_mesh, elmnts_ext_mesh, &
+ max_static_memory_size, mat_ext_mesh, materials_ext_mesh, &
+ nmat_ext_mesh, undef_mat_prop, nundefMat_ext_mesh, &
+ ninterface_ext_mesh, max_interface_size_ext_mesh, &
+ my_neighbours_ext_mesh, my_nelmnts_neighbours_ext_mesh, &
+ my_interfaces_ext_mesh, &
+ ibool_interfaces_ext_mesh, nibool_interfaces_ext_mesh, &
+ nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, nspec2D_ymax, &
+ NSPEC2D_BOTTOM, NSPEC2D_TOP,&
+ ibelm_xmin, ibelm_xmax, ibelm_ymin, ibelm_ymax, ibelm_bottom, ibelm_top, &
+ nodes_ibelm_xmin,nodes_ibelm_xmax,nodes_ibelm_ymin,nodes_ibelm_ymax, &
+ nodes_ibelm_bottom,nodes_ibelm_top, &
+ SAVE_MESH_FILES,nglob)
+ call sync_all()
+
! defines global number of nodes in model
NGLOB_AB = nglob
@@ -693,109 +869,4 @@
! make sure everybody is synchronized
call sync_all()
-
-!--- print number of points and elements in the mesh
- call sum_all_i(NGLOB_AB,nglob_total)
- call sum_all_i(NSPEC_AB,nspec_total)
-
- if(myrank == 0) then
-
- write(IMAIN,*)
- write(IMAIN,*) 'Repartition of elements:'
- write(IMAIN,*) '-----------------------'
- write(IMAIN,*)
- write(IMAIN,*) 'total number of elements in each slice: ',NSPEC_AB
- write(IMAIN,*) 'total number of points in each slice: ',NGLOB_AB
- write(IMAIN,*)
- write(IMAIN,*) 'total number of elements in entire mesh: ',nspec_total ! NSPEC_AB*NPROC
- write(IMAIN,*) 'total number of points in entire mesh: ',nglob_total !NGLOB_AB*NPROC
- write(IMAIN,*) 'total number of DOFs in entire mesh: ',nglob_total*NDIM !NGLOB_AB*NPROC*NDIM
- write(IMAIN,*)
- write(IMAIN,*) 'total number of time steps in the solver will be: ',NSTEP
- write(IMAIN,*)
-
-! write information about precision used for floating-point operations
- if(CUSTOM_REAL == SIZE_REAL) then
- write(IMAIN,*) 'using single precision for the calculations'
- else
- write(IMAIN,*) 'using double precision for the calculations'
- endif
- write(IMAIN,*)
- write(IMAIN,*) 'smallest and largest possible floating-point numbers are: ',tiny(1._CUSTOM_REAL),huge(1._CUSTOM_REAL)
- write(IMAIN,*)
-
-! copy number of elements and points in an include file for the solver
- call save_header_file(NSPEC_AB,NGLOB_AB,NPROC, &
- ATTENUATION,ANISOTROPY,NSTEP,DT, &
- NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,SIMULATION_TYPE,max_static_memory_size)
-
-! call get_value_string(rec_filename, 'solver.STATIONS', 'DATA/STATIONS')
-! call get_value_string(filtered_rec_filename, 'solver.STATIONS_FILTERED', 'DATA/STATIONS_FILTERED')
-
-! get total number of stations
-! open(unit=IIN,file=rec_filename,iostat=ios,status='old',action='read')
-! nrec = 0
-! do while(ios == 0)
-! read(IIN,"(a)",iostat=ios) dummystring
-! if(ios == 0) nrec = nrec + 1
-! enddo
-! close(IIN)
-
-! filter list of stations, only retain stations that are in the model
-! nrec_filtered = 0
-! open(unit=IIN,file=rec_filename,status='old',action='read')
-! do irec = 1,nrec
-! read(IIN,*) station_name,network_name,stlat,stlon,stele,stbur
-! if((stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) &
-! .or. USE_EXTERNAL_MESH) &
-! nrec_filtered = nrec_filtered + 1
-! enddo
-! close(IIN)
-
-! write(IMAIN,*)
-! write(IMAIN,*) 'there are ',nrec,' stations in file ', trim(rec_filename)
-! write(IMAIN,*) 'saving ',nrec_filtered,' stations inside the model in file ', trim(filtered_rec_filename)
-! write(IMAIN,*) 'excluding ',nrec - nrec_filtered,' stations located outside the model'
-! write(IMAIN,*)
-
-! if(nrec_filtered < 1) call exit_MPI(myrank,'need at least one station in the model')
-
-! if(nrec < 1) call exit_MPI(myrank,'need at least one station in the model')
-
-! open(unit=IIN,file=rec_filename,status='old',action='read')
-! open(unit=IOUT,file=filtered_rec_filename,status='unknown')
-
-! do irec = 1,nrec
-! read(IIN,*) station_name,network_name,stlat,stlon,stele,stbur
-! if((stlat >= LATITUDE_MIN .and. stlat <= LATITUDE_MAX .and. stlon >= LONGITUDE_MIN .and. stlon <= LONGITUDE_MAX) &
-! .or. USE_EXTERNAL_MESH) &
-! write(IOUT,*) station_name(1:len_trim(station_name)),' ',network_name(1:len_trim(network_name)),' ', &
-! sngl(stlat),' ',sngl(stlon), ' ', sngl(stele), ' ', sngl(stbur)
-! enddo
-
-! close(IIN)
-! close(IOUT)
-
- endif ! end of section executed by main process only
-
-! elapsed time since beginning of mesh generation
- if(myrank == 0) then
- tCPU = wtime() - time_start
- write(IMAIN,*)
- write(IMAIN,*) 'Elapsed time for mesh generation and buffer creation in seconds = ',tCPU
- write(IMAIN,*) 'End of mesh generation'
- write(IMAIN,*)
- endif
-
-! close main output file
- if(myrank == 0) then
- write(IMAIN,*) 'done'
- write(IMAIN,*)
- close(IMAIN)
- endif
-
-! synchronize all the processes to make sure everybody has finished
- call sync_all()
-
- end subroutine generate_databases
-
+ end subroutine generate_databases_setup_mesh
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/get_absorb.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/get_absorb.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/get_absorb.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -157,8 +157,10 @@
end subroutine get_absorb
+!
+!-------------------------------------------------------------------------------------------------
+!
-
subroutine get_absorb_ext_mesh(myrank,iboun,nspec, &
nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM)
Added: seismo/3D/SPECFEM3D_SESAME/trunk/get_element_face.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/get_element_face.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/get_element_face.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -0,0 +1,427 @@
+!
+!----
+!
+
+subroutine get_element_face_id(ispec,xcoord,ycoord,zcoord,&
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ iface_id )
+
+! returns iface_id of face in reference element, determined by corner locations xcoord/ycoord/zcoord;
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: ispec,nspec,nglob,iface_id
+
+! face corner locations
+ real(kind=CUSTOM_REAL),dimension(NGNOD2D) :: xcoord,ycoord,zcoord
+
+! index array
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+! global point locations
+ real(kind=CUSTOM_REAL) :: xstore_dummy(nglob),ystore_dummy(nglob),zstore_dummy(nglob)
+
+! local parameters
+ real(kind=CUSTOM_REAL),dimension(NGNOD2D) :: xcoord_face,ycoord_face,zcoord_face
+ real(kind=CUSTOM_REAL) :: midpoint_faces(NDIM,6),midpoint(NDIM),midpoint_distances(6)
+
+! corners indices of reference cube faces
+ ! xmin
+ integer,dimension(3,4),parameter :: iface1_corner_ijk = &
+ (/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ /)
+ ! xmax
+ integer,dimension(3,4),parameter :: iface2_corner_ijk = &
+ (/ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /)
+ ! ymin
+ integer,dimension(3,4),parameter :: iface3_corner_ijk = &
+ (/ 1,1,1, 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,1,1 /)
+ ! ymax
+ integer,dimension(3,4),parameter :: iface4_corner_ijk = &
+ (/ 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /)
+ ! bottom
+ integer,dimension(3,4),parameter :: iface5_corner_ijk = &
+ (/ 1,1,1, 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,1,1 /)
+ ! top
+ integer,dimension(3,4),parameter :: iface6_corner_ijk = &
+ (/ 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /)
+ ! all faces
+ integer,dimension(3,4,6),parameter :: iface_all_corner_ijk = &
+ (/ iface1_corner_ijk,iface2_corner_ijk, &
+ iface3_corner_ijk,iface4_corner_ijk, &
+ iface5_corner_ijk,iface6_corner_ijk /)
+
+! face orientation
+ !real(kind=CUSTOM_REAL) :: face_n(3),face_ntmp(3),tmp
+ integer :: ifa,icorner,i,j,k,iglob,iloc(1)
+
+! initializes
+ iface_id = -1
+
+! gets face midpoint by its corners
+ midpoint(:) = 0.0
+ do icorner=1,NGNOD2D
+ midpoint(1) = midpoint(1) + xcoord(icorner)
+ midpoint(2) = midpoint(2) + ycoord(icorner)
+ midpoint(3) = midpoint(3) + zcoord(icorner)
+ enddo
+ midpoint(:) = midpoint(:) / 4.0
+
+ ! checks: this holds only for planar face
+ !if( midpoint(1) /= (xcoord(1)+xcoord(3))/2.0 .or. midpoint(1) /= (xcoord(2)+xcoord(4))/2.0 ) then
+ ! print*,'error midpoint x:',midpoint(1),(xcoord(1)+xcoord(3))/2.0,(xcoord(2)+xcoord(4))/2.0
+ !endif
+ !if( midpoint(2) /= (ycoord(1)+ycoord(3))/2.0 .or. midpoint(2) /= (ycoord(2)+ycoord(4))/2.0 ) then
+ ! print*,'error midpoint y:',midpoint(1),(ycoord(1)+ycoord(3))/2.0,(ycoord(2)+ycoord(4))/2.0
+ !endif
+ !if( midpoint(3) /= (zcoord(1)+zcoord(3))/2.0 .or. midpoint(3) /= (zcoord(2)+zcoord(4))/2.0 ) then
+ ! print*,'error midpoint z:',midpoint(1),(zcoord(1)+zcoord(3))/2.0,(zcoord(2)+zcoord(4))/2.0
+ !endif
+
+! determines element face by minimum distance of midpoints
+ midpoint_faces(:,:) = 0.0
+ do ifa=1,6
+ ! face corners
+ do icorner = 1,NGNOD2D
+ i = iface_all_corner_ijk(1,icorner,ifa)
+ j = iface_all_corner_ijk(2,icorner,ifa)
+ k = iface_all_corner_ijk(3,icorner,ifa)
+ !print*,'corner:',i,j,k,ispec
+
+ ! coordinates
+ iglob = ibool(i,j,k,ispec)
+ xcoord_face(icorner) = xstore_dummy(iglob)
+ ycoord_face(icorner) = ystore_dummy(iglob)
+ zcoord_face(icorner) = zstore_dummy(iglob)
+
+ ! face midpoint coordinates
+ midpoint_faces(1,ifa) = midpoint_faces(1,ifa) + xcoord_face(icorner)
+ midpoint_faces(2,ifa) = midpoint_faces(2,ifa) + ycoord_face(icorner)
+ midpoint_faces(3,ifa) = midpoint_faces(3,ifa) + zcoord_face(icorner)
+ enddo
+ midpoint_faces(:,ifa) = midpoint_faces(:,ifa) / 4.0
+
+ ! distance
+ midpoint_distances(ifa) = (midpoint(1)-midpoint_faces(1,ifa))**2 &
+ + (midpoint(2)-midpoint_faces(2,ifa))**2 &
+ + (midpoint(3)-midpoint_faces(3,ifa))**2
+ enddo
+
+! gets closest point, which determines face
+ iloc = minloc(midpoint_distances)
+
+ ! checks that found midpoint is close enough
+ !print*,'face:', midpoint_distances(iloc(1))
+ if( midpoint_distances(iloc(1)) > 1.e-5 * &
+ ( (xcoord(1)-xcoord(2))**2 &
+ + (ycoord(1)-ycoord(2))**2 &
+ + (zcoord(1)-zcoord(2))**2 ) ) then
+ print*,'error element face midpoint distance:',midpoint_distances(iloc(1)),(xcoord(1)-xcoord(2))**2
+ ! corner locations
+ do icorner=1,NGNOD2D
+ i = iface_all_corner_ijk(1,icorner,iloc(1))
+ j = iface_all_corner_ijk(2,icorner,iloc(1))
+ k = iface_all_corner_ijk(3,icorner,iloc(1))
+ iglob = ibool(i,j,k,ispec)
+ print*,'error corner:',icorner,'xyz:',sngl(xstore_dummy(iglob)),&
+ sngl(ystore_dummy(iglob)),sngl(zstore_dummy(iglob))
+ enddo
+ ! stop
+ stop 'error element face midpoint'
+ else
+ iface_id = iloc(1)
+
+ !print*,'face:',iface_id
+ !do icorner=1,NGNOD2D
+ ! i = iface_all_corner_ijk(1,icorner,iloc(1))
+ ! j = iface_all_corner_ijk(2,icorner,iloc(1))
+ ! k = iface_all_corner_ijk(3,icorner,iloc(1))
+ ! iglob = ibool(i,j,k,ispec)
+ ! print*,'corner:',icorner,'xyz:',sngl(xstore_dummy(iglob)), &
+ ! sngl(ystore_dummy(iglob)),sngl(zstore_dummy(iglob))
+ !enddo
+
+ endif
+
+end subroutine get_element_face_id
+
+!
+!----
+!
+
+subroutine get_element_face_gll_indices(iface,ijk_face,NGLLA,NGLLB )
+
+! returns local indices in ijk_face for specified face
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: iface !,nspec,nglob
+
+! gll point indices i,j,k for face, format corresponds to ijk_face(1,*) = i, ijk_face(2,*) = j, ijk_face(3,*) = k
+ integer :: NGLLA,NGLLB
+ integer,dimension(3,NGLLA,NGLLB) :: ijk_face
+
+! integer :: icorner,i,j,k,iglob,iloc(1)
+ integer :: i,j,k
+ integer :: ngll,i_gll,j_gll,k_gll
+
+! sets i,j,k indices of GLL points on boundary face
+ ngll = 0
+ select case( iface )
+
+ ! reference xmin face
+ case(1)
+ if( NGLLA /= NGLLY .or. NGLLB /= NGLLZ ) stop 'error absorbing face 1 indexing'
+ i_gll = 1
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ ngll = ngll + 1
+ ijk_face(1,j,k) = i_gll
+ ijk_face(2,j,k) = j
+ ijk_face(3,j,k) = k
+ enddo
+ enddo
+
+ ! reference xmax face
+ case(2)
+ if( NGLLA /= NGLLY .or. NGLLB /= NGLLZ ) stop 'error absorbing face 2 indexing'
+ i_gll = NGLLX
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ ngll = ngll + 1
+ ijk_face(1,j,k) = i_gll
+ ijk_face(2,j,k) = j
+ ijk_face(3,j,k) = k
+ enddo
+ enddo
+
+ ! reference ymin face
+ case(3)
+ if( NGLLA /= NGLLX .or. NGLLB /= NGLLZ ) stop 'error absorbing face 3 indexing'
+ j_gll = 1
+ do k=1,NGLLZ
+ do i=1,NGLLX
+ ngll = ngll + 1
+ ijk_face(1,i,k) = i
+ ijk_face(2,i,k) = j_gll
+ ijk_face(3,i,k) = k
+ enddo
+ enddo
+
+ ! reference ymax face
+ case(4)
+ if( NGLLA /= NGLLX .or. NGLLB /= NGLLZ ) stop 'error absorbing face 4 indexing'
+ j_gll = NGLLY
+ do k=1,NGLLZ
+ do i=1,NGLLX
+ ngll = ngll + 1
+ ijk_face(1,i,k) = i
+ ijk_face(2,i,k) = j_gll
+ ijk_face(3,i,k) = k
+ enddo
+ enddo
+
+ ! reference bottom face
+ case(5)
+ if( NGLLA /= NGLLX .or. NGLLB /= NGLLY ) stop 'error absorbing face 5 indexing'
+ k_gll = 1
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ngll = ngll + 1
+ ijk_face(1,i,j) = i
+ ijk_face(2,i,j) = j
+ ijk_face(3,i,j) = k_gll
+ enddo
+ enddo
+
+ ! reference bottom face
+ case(6)
+ if( NGLLA /= NGLLX .or. NGLLB /= NGLLY ) stop 'error absorbing face 6 indexing'
+ k_gll = NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ngll = ngll + 1
+ ijk_face(1,i,j) = i
+ ijk_face(2,i,j) = j
+ ijk_face(3,i,j) = k_gll
+ enddo
+ enddo
+
+ case default
+ stop 'error element face not found'
+
+ end select
+
+ ! checks number of gll points set on face
+ if( ngll /= NGLLA*NGLLB ) then
+ print*,'error element face ngll:',ngll,NGLLA,NGLLB
+ stop 'error element face ngll'
+ endif
+!
+!! corner locations
+! do icorner=1,NGNOD2D
+! i = iface_all_corner_ijk(1,icorner,iface)
+! j = iface_all_corner_ijk(2,icorner,iface)
+! k = iface_all_corner_ijk(3,icorner,iface)
+! iglob = ibool(i,j,k,ispec)
+! xcoord_iboun(icorner) = xstore_dummy(iglob)
+! ycoord_iboun(icorner) = ystore_dummy(iglob)
+! zcoord_iboun(icorner) = zstore_dummy(iglob)
+! ! looks at values
+! !print*,'corner:',icorner,'xyz:',sngl(xcoord_iboun(icorner)),sngl(ycoord_iboun(icorner)),sngl(zcoord_iboun(icorner))
+! enddo
+!
+!! determines initial orientation given by three corners of the face
+! ! (CUBIT orders corners such that normal points outwards of element)
+! ! cross-product of vectors from corner 1 to corner 2 and from corner 1 to corner 3
+! face_n(1) = (ycoord(2)-ycoord(1))*(zcoord(3)-zcoord(1)) - (zcoord(2)-zcoord(1))*(ycoord(3)-ycoord(1))
+! face_n(2) = - (xcoord(2)-xcoord(1))*(zcoord(3)-zcoord(1)) + (zcoord(2)-zcoord(1))*(xcoord(3)-xcoord(1))
+! face_n(3) = (xcoord(2)-xcoord(1))*(ycoord(3)-ycoord(1)) - (ycoord(2)-ycoord(1))*(xcoord(3)-xcoord(1))
+! face_n(:) = face_n(:)/(sqrt( face_n(1)**2 + face_n(2)**2 + face_n(3)**2) )
+!
+!! checks that this normal direction is outwards of element:
+! ! takes additional corner out of face plane and determines scalarproduct to normal
+! select case( iface )
+! case(1) ! opposite to xmin face
+! iglob = ibool(NGLLX,1,1,ispec)
+! case(2) ! opposite to xmax face
+! iglob = ibool(1,1,1,ispec)
+! case(3) ! opposite to ymin face
+! iglob = ibool(1,NGLLY,1,ispec)
+! case(4) ! opposite to ymax face
+! iglob = ibool(1,1,1,ispec)
+! case(5) ! opposite to bottom
+! iglob = ibool(1,1,NGLLZ,ispec)
+! case(6) ! opposite to top
+! iglob = ibool(1,1,1,ispec)
+! end select
+! ! vector from corner 1 to this opposite one
+! xcoord(4) = xstore_dummy(iglob) - xcoord(1)
+! ycoord(4) = ystore_dummy(iglob) - ycoord(1)
+! zcoord(4) = zstore_dummy(iglob) - zcoord(1)
+!
+! ! scalarproduct
+! tmp = xcoord(4)*face_n(1) + ycoord(4)*face_n(2) + zcoord(4)*face_n(3)
+!
+! ! makes sure normal points outwards, that is points away from this additional corner and scalarproduct is negative
+! if( tmp > 0.0 ) then
+! face_n(:) = - face_n(:)
+! endif
+! !print*,'face ',iface,'scalarproduct:',tmp
+!
+!! determines orientation of gll corner locations and sets it such that normal points outwards
+! ! cross-product
+! face_ntmp(1) = (ycoord_iboun(2)-ycoord_iboun(1))*(zcoord_iboun(3)-zcoord_iboun(1)) &
+! - (zcoord_iboun(2)-zcoord_iboun(1))*(ycoord_iboun(3)-ycoord_iboun(1))
+! face_ntmp(2) = - (xcoord_iboun(2)-xcoord_iboun(1))*(zcoord_iboun(3)-zcoord_iboun(1)) &
+! + (zcoord_iboun(2)-zcoord_iboun(1))*(xcoord_iboun(3)-xcoord_iboun(1))
+! face_ntmp(3) = (xcoord_iboun(2)-xcoord_iboun(1))*(ycoord_iboun(3)-ycoord_iboun(1))&
+! - (ycoord_iboun(2)-ycoord_iboun(1))*(xcoord_iboun(3)-xcoord_iboun(1))
+! face_ntmp(:) = face_ntmp(:)/(sqrt( face_ntmp(1)**2 + face_ntmp(2)**2 + face_ntmp(3)**2) )
+! if( abs( (face_n(1)-face_ntmp(1))**2+(face_n(2)-face_ntmp(2))**2+(face_n(3)-face_ntmp(3))**2) > 0.1 ) then
+! !print*,'error orientation face 1:',ispec,face_n(:)
+! !swap corners 2 and 4 ( switches clockwise / anti-clockwise )
+! tmp = xcoord_iboun(2)
+! xcoord_iboun(2) = xcoord_iboun(4)
+! xcoord_iboun(4) = tmp
+! tmp = ycoord_iboun(2)
+! ycoord_iboun(2) = ycoord_iboun(4)
+! ycoord_iboun(4) = tmp
+! tmp = zcoord_iboun(2)
+! zcoord_iboun(2) = zcoord_iboun(4)
+! zcoord_iboun(4) = tmp
+! endif
+
+end subroutine get_element_face_gll_indices
+
+!
+!----
+!
+
+subroutine get_element_face_normal(ispec,iface,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ normal)
+
+! only changes direction of normal to point outwards of element
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: ispec,iface,nspec,nglob
+
+! face corner locations
+ real(kind=CUSTOM_REAL),dimension(NGNOD2D) :: xcoord,ycoord,zcoord
+
+! index array
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+! global point locations
+ real(kind=CUSTOM_REAL) :: xstore_dummy(nglob),ystore_dummy(nglob),zstore_dummy(nglob)
+
+! face normal
+ real(kind=CUSTOM_REAL),dimension(NDIM) :: normal
+
+! local parameters
+ real(kind=CUSTOM_REAL) :: face_n(3),tmp,v_tmp(3)
+ integer :: iglob
+
+! determines initial orientation given by three corners on the face
+ ! cross-product of vectors from corner 1 to corner 2 and from corner 1 to corner 3
+ face_n(1) = (ycoord(2)-ycoord(1))*(zcoord(3)-zcoord(1)) - (zcoord(2)-zcoord(1))*(ycoord(3)-ycoord(1))
+ face_n(2) = - (xcoord(2)-xcoord(1))*(zcoord(3)-zcoord(1)) + (zcoord(2)-zcoord(1))*(xcoord(3)-xcoord(1))
+ face_n(3) = (xcoord(2)-xcoord(1))*(ycoord(3)-ycoord(1)) - (ycoord(2)-ycoord(1))*(xcoord(3)-xcoord(1))
+ tmp = sqrt( face_n(1)**2 + face_n(2)**2 + face_n(3)**2 )
+ if( abs(tmp) < TINYVAL ) then
+ print*,'error get face normal: length',tmp
+ print*,'normal:',face_n(:)
+ stop 'error get element face normal'
+ endif
+ face_n(:) = face_n(:)/tmp
+
+! checks that this normal direction is outwards of element:
+ ! takes additional corner out of face plane and determines scalarproduct to normal
+ select case( iface )
+ case(1) ! opposite to xmin face
+ iglob = ibool(NGLLX,1,1,ispec)
+ case(2) ! opposite to xmax face
+ iglob = ibool(1,1,1,ispec)
+ case(3) ! opposite to ymin face
+ iglob = ibool(1,NGLLY,1,ispec)
+ case(4) ! opposite to ymax face
+ iglob = ibool(1,1,1,ispec)
+ case(5) ! opposite to bottom
+ iglob = ibool(1,1,NGLLZ,ispec)
+ case(6) ! opposite to top
+ iglob = ibool(1,1,1,ispec)
+ end select
+ ! vector from corner 1 to this opposite one
+ v_tmp(1) = xstore_dummy(iglob) - xcoord(1)
+ v_tmp(2) = ystore_dummy(iglob) - ycoord(1)
+ v_tmp(3) = zstore_dummy(iglob) - zcoord(1)
+
+ ! scalarproduct
+ tmp = v_tmp(1)*face_n(1) + v_tmp(2)*face_n(2) + v_tmp(3)*face_n(3)
+
+ ! makes sure normal points outwards, that is points away from this additional corner and scalarproduct is negative
+ if( tmp > 0.0 ) then
+ face_n(:) = - face_n(:)
+ endif
+
+! determines orientation normal and flips direction such that normal points outwards
+ tmp = face_n(1)*normal(1) + face_n(2)*normal(2) + face_n(3)*normal(3)
+ if( tmp < 0.0 ) then
+ !print*,'element face normal: orientation ',ispec,iface,tmp
+ !print*,'face normal: ',face_n(:)
+ !print*,' normal: ',normal(:)
+ !swap
+ normal(:) = - normal(:)
+ endif
+ !print*,'face ',iface,'scalarproduct:',tmp
+
+end subroutine get_element_face_normal
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/get_global.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/get_global.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/get_global.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -87,46 +87,46 @@
do j=1,NDIM
! sort within each segment
- ioff=1
- do iseg=1,nseg
+ ioff=1
+ do iseg=1,nseg
+ if(j == 1) then
+ call rank(xp(ioff),ind,ninseg(iseg))
+ else if(j == 2) then
+ call rank(yp(ioff),ind,ninseg(iseg))
+ else
+ call rank(zp(ioff),ind,ninseg(iseg))
+ endif
+ call swap_all(loc(ioff),xp(ioff),yp(ioff),zp(ioff),iwork,work,ind,ninseg(iseg))
+ ioff=ioff+ninseg(iseg)
+ enddo
+
+! check for jumps in current coordinate
+! compare the coordinates of the points within a small tolerance
if(j == 1) then
- call rank(xp(ioff),ind,ninseg(iseg))
+ do i=2,npointot
+ if(dabs(xp(i)-xp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
+ enddo
else if(j == 2) then
- call rank(yp(ioff),ind,ninseg(iseg))
+ do i=2,npointot
+ if(dabs(yp(i)-yp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
+ enddo
else
- call rank(zp(ioff),ind,ninseg(iseg))
+ do i=2,npointot
+ if(dabs(zp(i)-zp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
+ enddo
endif
- call swap_all(loc(ioff),xp(ioff),yp(ioff),zp(ioff),iwork,work,ind,ninseg(iseg))
- ioff=ioff+ninseg(iseg)
- enddo
-! check for jumps in current coordinate
-! compare the coordinates of the points within a small tolerance
- if(j == 1) then
- do i=2,npointot
- if(dabs(xp(i)-xp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
+! count up number of different segments
+ nseg=0
+ do i=1,npointot
+ if(ifseg(i)) then
+ nseg=nseg+1
+ ninseg(nseg)=1
+ else
+ ninseg(nseg)=ninseg(nseg)+1
+ endif
enddo
- else if(j == 2) then
- do i=2,npointot
- if(dabs(yp(i)-yp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
- enddo
- else
- do i=2,npointot
- if(dabs(zp(i)-zp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
- enddo
- endif
-
-! count up number of different segments
- nseg=0
- do i=1,npointot
- if(ifseg(i)) then
- nseg=nseg+1
- ninseg(nseg)=1
- else
- ninseg(nseg)=ninseg(nseg)+1
- endif
enddo
- enddo
! assign global node numbers (now sorted lexicographically)
ig=0
@@ -242,5 +242,59 @@
C(i)=W(ind(i))
enddo
- end subroutine swap_all
+end subroutine swap_all
+! ------------------------------------------------------------------
+
+
+ subroutine get_global_indirect_addressing(nspec,nglob,ibool)
+
+!
+!- we can create a new indirect addressing to reduce cache misses
+! (put into this subroutine but compiler keeps on complaining that it can't vectorize loops...)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nspec,nglob
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+! mask to sort ibool
+ integer, dimension(:), allocatable :: mask_ibool
+ integer, dimension(:,:,:,:), allocatable :: copy_ibool_ori
+
+ integer :: inumber,i,j,k,ispec,ier
+
+! copies original array
+ allocate(copy_ibool_ori(NGLLX,NGLLY,NGLLZ,nspec),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(mask_ibool(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+
+ mask_ibool(:) = -1
+ copy_ibool_ori(:,:,:,:) = ibool(:,:,:,:)
+
+! reduces misses
+ inumber = 0
+ do ispec=1,nspec
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if(mask_ibool(copy_ibool_ori(i,j,k,ispec)) == -1) then
+! create a new point
+ inumber = inumber + 1
+ ibool(i,j,k,ispec) = inumber
+ mask_ibool(copy_ibool_ori(i,j,k,ispec)) = inumber
+ else
+! use an existing point created previously
+ ibool(i,j,k,ispec) = mask_ibool(copy_ibool_ori(i,j,k,ispec))
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+! cleanup
+ deallocate(copy_ibool_ori,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(mask_ibool,stat=ier); if(ier /= 0) stop 'error in deallocate'
+
+end subroutine get_global_indirect_addressing
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/get_jacobian_boundaries.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/get_jacobian_boundaries.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/get_jacobian_boundaries.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -23,267 +23,197 @@
!
!=====================================================================
- subroutine get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, &
- dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
- jacobian2D_xmin,jacobian2D_xmax, &
- jacobian2D_ymin,jacobian2D_ymax, &
- jacobian2D_bottom,jacobian2D_top, &
- normal_xmin,normal_xmax, &
- normal_ymin,normal_ymax, &
- normal_bottom,normal_top, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX)
+
+ subroutine get_jacobian_boundary_face(myrank,nspec, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob,&
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,&
+ ispec,iface,jacobian2D_face,normal_face,NGLLA,NGLLB)
+! returns jacobian2D_face and normal_face (pointing outwards of element)
+
implicit none
include "constants.h"
- integer nspec,myrank
- integer NSPEC2D_BOTTOM,NSPEC2D_TOP,NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
+ integer nspec,myrank,nglob
- integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
- integer ibelm_xmin(NSPEC2DMAX_XMIN_XMAX),ibelm_xmax(NSPEC2DMAX_XMIN_XMAX)
- integer ibelm_ymin(NSPEC2DMAX_YMIN_YMAX),ibelm_ymax(NSPEC2DMAX_YMIN_YMAX)
- integer ibelm_bottom(NSPEC2D_BOTTOM),ibelm_top(NSPEC2D_TOP)
+! arrays with the mesh
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ real(kind=CUSTOM_REAL) :: xstore_dummy(nglob),ystore_dummy(nglob),zstore_dummy(nglob)
+
+! double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+! double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+! double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! absorbing boundaries
+ integer :: iface,ispec,NGLLA,NGLLB
+ real(kind=CUSTOM_REAL) jacobian2D_face(NGLLA,NGLLB)
+ real(kind=CUSTOM_REAL) normal_face(NDIM,NGLLA,NGLLB)
- logical iboun(6,nspec)
-
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- real(kind=CUSTOM_REAL) jacobian2D_xmin(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- real(kind=CUSTOM_REAL) jacobian2D_xmax(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- real(kind=CUSTOM_REAL) jacobian2D_ymin(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- real(kind=CUSTOM_REAL) jacobian2D_ymax(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- real(kind=CUSTOM_REAL) jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM)
- real(kind=CUSTOM_REAL) jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP)
-
- real(kind=CUSTOM_REAL) normal_xmin(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- real(kind=CUSTOM_REAL) normal_xmax(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- real(kind=CUSTOM_REAL) normal_ymin(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- real(kind=CUSTOM_REAL) normal_ymax(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- real(kind=CUSTOM_REAL) normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM)
- real(kind=CUSTOM_REAL) normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP)
-
double precision dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ)
double precision dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ)
double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY)
double precision dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY)
-! global element numbering
- integer ispec
+ double precision, dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ double precision, dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ double precision, dimension(NGLLY,NGLLZ) :: wgllwgll_yz
-! counters to keep track of number of elements on each of the boundaries
- integer ispecb1,ispecb2,ispecb3,ispecb4,ispecb5,ispecb6
-
double precision xelm(NGNOD2D),yelm(NGNOD2D),zelm(NGNOD2D)
+! element numbering
+! integer i,j
+
! check that the parameter file is correct
if(NGNOD /= 8) call exit_MPI(myrank,'elements should have 8 control nodes')
if(NGNOD2D /= 4) call exit_MPI(myrank,'surface elements should have 4 control nodes')
- ispecb1 = 0
- ispecb2 = 0
- ispecb3 = 0
- ispecb4 = 0
- ispecb5 = 0
- ispecb6 = 0
+ select case ( iface )
+ ! on reference face: xmin
+ case(1)
+ xelm(1)=xstore_dummy( ibool(1,1,1,ispec) )
+ yelm(1)=ystore_dummy( ibool(1,1,1,ispec) )
+ zelm(1)=zstore_dummy( ibool(1,1,1,ispec) )
+ xelm(2)=xstore_dummy( ibool(1,NGLLY,1,ispec) )
+ yelm(2)=ystore_dummy( ibool(1,NGLLY,1,ispec) )
+ zelm(2)=zstore_dummy( ibool(1,NGLLY,1,ispec) )
+ xelm(3)=xstore_dummy( ibool(1,NGLLY,NGLLZ,ispec) )
+ yelm(3)=ystore_dummy( ibool(1,NGLLY,NGLLZ,ispec) )
+ zelm(3)=zstore_dummy( ibool(1,NGLLY,NGLLZ,ispec) )
+ xelm(4)=xstore_dummy( ibool(1,1,NGLLZ,ispec) )
+ yelm(4)=ystore_dummy( ibool(1,1,NGLLZ,ispec) )
+ zelm(4)=zstore_dummy( ibool(1,1,NGLLZ,ispec) )
- do ispec=1,nspec
-
-! determine if the element falls on a boundary
-
-! on boundary: xmin
-
- if(iboun(1,ispec)) then
-
- ispecb1=ispecb1+1
- ibelm_xmin(ispecb1)=ispec
-
-! specify the 4 nodes for the 2-D boundary element
- xelm(1)=xstore(1,1,1,ispec)
- yelm(1)=ystore(1,1,1,ispec)
- zelm(1)=zstore(1,1,1,ispec)
- xelm(2)=xstore(1,NGLLY,1,ispec)
- yelm(2)=ystore(1,NGLLY,1,ispec)
- zelm(2)=zstore(1,NGLLY,1,ispec)
- xelm(3)=xstore(1,NGLLY,NGLLZ,ispec)
- yelm(3)=ystore(1,NGLLY,NGLLZ,ispec)
- zelm(3)=zstore(1,NGLLY,NGLLZ,ispec)
- xelm(4)=xstore(1,1,NGLLZ,ispec)
- yelm(4)=ystore(1,1,NGLLZ,ispec)
- zelm(4)=zstore(1,1,NGLLZ,ispec)
-
- call compute_jacobian_2D(myrank,ispecb1,xelm,yelm,zelm,dershape2D_x, &
- jacobian2D_xmin,normal_xmin,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
-
- endif
-
+ call compute_jacobian_2D_face(myrank,xelm,yelm,zelm, &
+ dershape2D_x,wgllwgll_yz, &
+ jacobian2D_face,normal_face,NGLLY,NGLLZ)
+
! on boundary: xmax
+ case(2)
+ xelm(1)=xstore_dummy( ibool(NGLLX,1,1,ispec) )
+ yelm(1)=ystore_dummy( ibool(NGLLX,1,1,ispec) )
+ zelm(1)=zstore_dummy( ibool(NGLLX,1,1,ispec) )
+ xelm(2)=xstore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+ yelm(2)=ystore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+ zelm(2)=zstore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+ xelm(3)=xstore_dummy( ibool(NGLLX,NGLLY,NGLLZ,ispec) )
+ yelm(3)=ystore_dummy( ibool(NGLLX,NGLLY,NGLLZ,ispec) )
+ zelm(3)=zstore_dummy( ibool(NGLLX,NGLLY,NGLLZ,ispec) )
+ xelm(4)=xstore_dummy( ibool(NGLLX,1,NGLLZ,ispec) )
+ yelm(4)=ystore_dummy( ibool(NGLLX,1,NGLLZ,ispec) )
+ zelm(4)=zstore_dummy( ibool(NGLLX,1,NGLLZ,ispec) )
- if(iboun(2,ispec)) then
+ call compute_jacobian_2D_face(myrank,xelm,yelm,zelm, &
+ dershape2D_x,wgllwgll_yz, &
+ jacobian2D_face,normal_face,NGLLY,NGLLZ)
- ispecb2=ispecb2+1
- ibelm_xmax(ispecb2)=ispec
-
-! specify the 4 nodes for the 2-D boundary element
- xelm(1)=xstore(NGLLX,1,1,ispec)
- yelm(1)=ystore(NGLLX,1,1,ispec)
- zelm(1)=zstore(NGLLX,1,1,ispec)
- xelm(2)=xstore(NGLLX,NGLLY,1,ispec)
- yelm(2)=ystore(NGLLX,NGLLY,1,ispec)
- zelm(2)=zstore(NGLLX,NGLLY,1,ispec)
- xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
- yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
- zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
- xelm(4)=xstore(NGLLX,1,NGLLZ,ispec)
- yelm(4)=ystore(NGLLX,1,NGLLZ,ispec)
- zelm(4)=zstore(NGLLX,1,NGLLZ,ispec)
-
- call compute_jacobian_2D(myrank,ispecb2,xelm,yelm,zelm,dershape2D_x, &
- jacobian2D_xmax,normal_xmax,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
-
- endif
-
! on boundary: ymin
+ case(3)
+ xelm(1)=xstore_dummy( ibool(1,1,1,ispec) )
+ yelm(1)=ystore_dummy( ibool(1,1,1,ispec) )
+ zelm(1)=zstore_dummy( ibool(1,1,1,ispec) )
+ xelm(2)=xstore_dummy( ibool(NGLLX,1,1,ispec) )
+ yelm(2)=ystore_dummy( ibool(NGLLX,1,1,ispec) )
+ zelm(2)=zstore_dummy( ibool(NGLLX,1,1,ispec) )
+ xelm(3)=xstore_dummy( ibool(NGLLX,1,NGLLZ,ispec) )
+ yelm(3)=ystore_dummy( ibool(NGLLX,1,NGLLZ,ispec) )
+ zelm(3)=zstore_dummy( ibool(NGLLX,1,NGLLZ,ispec) )
+ xelm(4)=xstore_dummy( ibool(1,1,NGLLZ,ispec) )
+ yelm(4)=ystore_dummy( ibool(1,1,NGLLZ,ispec) )
+ zelm(4)=zstore_dummy( ibool(1,1,NGLLZ,ispec) )
- if(iboun(3,ispec)) then
+ call compute_jacobian_2D_face(myrank,xelm,yelm,zelm, &
+ dershape2D_y,wgllwgll_xz, &
+ jacobian2D_face,normal_face,NGLLX,NGLLZ)
- ispecb3=ispecb3+1
- ibelm_ymin(ispecb3)=ispec
-
-! specify the 4 nodes for the 2-D boundary element
- xelm(1)=xstore(1,1,1,ispec)
- yelm(1)=ystore(1,1,1,ispec)
- zelm(1)=zstore(1,1,1,ispec)
- xelm(2)=xstore(NGLLX,1,1,ispec)
- yelm(2)=ystore(NGLLX,1,1,ispec)
- zelm(2)=zstore(NGLLX,1,1,ispec)
- xelm(3)=xstore(NGLLX,1,NGLLZ,ispec)
- yelm(3)=ystore(NGLLX,1,NGLLZ,ispec)
- zelm(3)=zstore(NGLLX,1,NGLLZ,ispec)
- xelm(4)=xstore(1,1,NGLLZ,ispec)
- yelm(4)=ystore(1,1,NGLLZ,ispec)
- zelm(4)=zstore(1,1,NGLLZ,ispec)
-
- call compute_jacobian_2D(myrank,ispecb3,xelm,yelm,zelm,dershape2D_y, &
- jacobian2D_ymin,normal_ymin,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
-
- endif
-
! on boundary: ymax
+ case(4)
+ xelm(1)=xstore_dummy( ibool(1,NGLLY,1,ispec) )
+ yelm(1)=ystore_dummy( ibool(1,NGLLY,1,ispec) )
+ zelm(1)=zstore_dummy( ibool(1,NGLLY,1,ispec) )
+ xelm(2)=xstore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+ yelm(2)=ystore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+ zelm(2)=zstore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+ xelm(3)=xstore_dummy( ibool(NGLLX,NGLLY,NGLLZ,ispec) )
+ yelm(3)=ystore_dummy( ibool(NGLLX,NGLLY,NGLLZ,ispec) )
+ zelm(3)=zstore_dummy( ibool(NGLLX,NGLLY,NGLLZ,ispec) )
+ xelm(4)=xstore_dummy( ibool(1,NGLLY,NGLLZ,ispec) )
+ yelm(4)=ystore_dummy( ibool(1,NGLLY,NGLLZ,ispec) )
+ zelm(4)=zstore_dummy( ibool(1,NGLLY,NGLLZ,ispec) )
- if(iboun(4,ispec)) then
+ call compute_jacobian_2D_face(myrank,xelm,yelm,zelm, &
+ dershape2D_y, wgllwgll_xz, &
+ jacobian2D_face,normal_face,NGLLX,NGLLZ)
+
- ispecb4=ispecb4+1
- ibelm_ymax(ispecb4)=ispec
-
-! specify the 4 nodes for the 2-D boundary element
- xelm(1)=xstore(1,NGLLY,1,ispec)
- yelm(1)=ystore(1,NGLLY,1,ispec)
- zelm(1)=zstore(1,NGLLY,1,ispec)
- xelm(2)=xstore(NGLLX,NGLLY,1,ispec)
- yelm(2)=ystore(NGLLX,NGLLY,1,ispec)
- zelm(2)=zstore(NGLLX,NGLLY,1,ispec)
- xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
- yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
- zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
- xelm(4)=xstore(1,NGLLY,NGLLZ,ispec)
- yelm(4)=ystore(1,NGLLY,NGLLZ,ispec)
- zelm(4)=zstore(1,NGLLY,NGLLZ,ispec)
-
- call compute_jacobian_2D(myrank,ispecb4,xelm,yelm,zelm,dershape2D_y, &
- jacobian2D_ymax,normal_ymax,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
-
- endif
-
! on boundary: bottom
+ case(5)
+ xelm(1)=xstore_dummy( ibool(1,1,1,ispec) )
+ yelm(1)=ystore_dummy( ibool(1,1,1,ispec) )
+ zelm(1)=zstore_dummy( ibool(1,1,1,ispec) )
+ xelm(2)=xstore_dummy( ibool(NGLLX,1,1,ispec) )
+ yelm(2)=ystore_dummy( ibool(NGLLX,1,1,ispec) )
+ zelm(2)=zstore_dummy( ibool(NGLLX,1,1,ispec) )
+ xelm(3)=xstore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+ yelm(3)=ystore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+ zelm(3)=zstore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+ xelm(4)=xstore_dummy( ibool(1,NGLLY,1,ispec) )
+ yelm(4)=ystore_dummy( ibool(1,NGLLY,1,ispec) )
+ zelm(4)=zstore_dummy( ibool(1,NGLLY,1,ispec) )
+
+ call compute_jacobian_2D_face(myrank,xelm,yelm,zelm,&
+ dershape2D_bottom,wgllwgll_xy, &
+ jacobian2D_face,normal_face,NGLLX,NGLLY)
- if(iboun(5,ispec)) then
-
- ispecb5=ispecb5+1
- ibelm_bottom(ispecb5)=ispec
-
- xelm(1)=xstore(1,1,1,ispec)
- yelm(1)=ystore(1,1,1,ispec)
- zelm(1)=zstore(1,1,1,ispec)
- xelm(2)=xstore(NGLLX,1,1,ispec)
- yelm(2)=ystore(NGLLX,1,1,ispec)
- zelm(2)=zstore(NGLLX,1,1,ispec)
- xelm(3)=xstore(NGLLX,NGLLY,1,ispec)
- yelm(3)=ystore(NGLLX,NGLLY,1,ispec)
- zelm(3)=zstore(NGLLX,NGLLY,1,ispec)
- xelm(4)=xstore(1,NGLLY,1,ispec)
- yelm(4)=ystore(1,NGLLY,1,ispec)
- zelm(4)=zstore(1,NGLLY,1,ispec)
-
- call compute_jacobian_2D(myrank,ispecb5,xelm,yelm,zelm,dershape2D_bottom, &
- jacobian2D_bottom,normal_bottom,NGLLX,NGLLY,NSPEC2D_BOTTOM)
-
- endif
-
! on boundary: top
+ case(6)
+ xelm(1)=xstore_dummy( ibool(1,1,NGLLZ,ispec) )
+ yelm(1)=ystore_dummy( ibool(1,1,NGLLZ,ispec) )
+ zelm(1)=zstore_dummy( ibool(1,1,NGLLZ,ispec) )
+ xelm(2)=xstore_dummy( ibool(NGLLX,1,NGLLZ,ispec) )
+ yelm(2)=ystore_dummy( ibool(NGLLX,1,NGLLZ,ispec) )
+ zelm(2)=zstore_dummy( ibool(NGLLX,1,NGLLZ,ispec) )
+ xelm(3)=xstore_dummy( ibool(NGLLX,NGLLY,NGLLZ,ispec) )
+ yelm(3)=ystore_dummy( ibool(NGLLX,NGLLY,NGLLZ,ispec) )
+ zelm(3)=zstore_dummy( ibool(NGLLX,NGLLY,NGLLZ,ispec) )
+ xelm(4)=xstore_dummy( ibool(1,NGLLY,NGLLZ,ispec) )
+ yelm(4)=ystore_dummy( ibool(1,NGLLY,NGLLZ,ispec) )
+ zelm(4)=zstore_dummy( ibool(1,NGLLY,NGLLZ,ispec) )
- if(iboun(6,ispec)) then
+ call compute_jacobian_2D_face(myrank,xelm,yelm,zelm,&
+ dershape2D_top, wgllwgll_xy, &
+ jacobian2D_face,normal_face,NGLLX,NGLLY)
+
+ case default
+ stop 'error 2D jacobian'
+ end select
+
+ end subroutine get_jacobian_boundary_face
+
- ispecb6=ispecb6+1
- ibelm_top(ispecb6)=ispec
-
- xelm(1)=xstore(1,1,NGLLZ,ispec)
- yelm(1)=ystore(1,1,NGLLZ,ispec)
- zelm(1)=zstore(1,1,NGLLZ,ispec)
- xelm(2)=xstore(NGLLX,1,NGLLZ,ispec)
- yelm(2)=ystore(NGLLX,1,NGLLZ,ispec)
- zelm(2)=zstore(NGLLX,1,NGLLZ,ispec)
- xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
- yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
- zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
- xelm(4)=xstore(1,NGLLY,NGLLZ,ispec)
- yelm(4)=ystore(1,NGLLY,NGLLZ,ispec)
- zelm(4)=zstore(1,NGLLY,NGLLZ,ispec)
-
- call compute_jacobian_2D(myrank,ispecb6,xelm,yelm,zelm,dershape2D_top, &
- jacobian2D_top,normal_top,NGLLX,NGLLY,NSPEC2D_TOP)
-
- endif
-
- enddo
-
-! check theoretical value of elements at the bottom
- if(ispecb5 /= NSPEC2D_BOTTOM) call exit_MPI(myrank,'ispecb5 should equal NSPEC2D_BOTTOM')
-
-! check theoretical value of elements at the top
- if(ispecb6 /= NSPEC2D_TOP) then
- call exit_MPI(myrank,'ispecb6 should equal NSPEC2D_TOP')
- endif
- nspec2D_xmin = ispecb1
- nspec2D_xmax = ispecb2
- nspec2D_ymin = ispecb3
- nspec2D_ymax = ispecb4
-
- end subroutine get_jacobian_boundaries
-
! -------------------------------------------------------
- subroutine compute_jacobian_2D(myrank,ispecb,xelm,yelm,zelm,dershape2D,jacobian2D,normal,NGLLA,NGLLB,NSPEC2DMAX_AB)
+ subroutine compute_jacobian_2D_face(myrank,xelm,yelm,zelm, &
+ dershape2D,wgllwgll, &
+ jacobian2D_face,normal_face,NGLLA,NGLLB)
implicit none
include "constants.h"
! generic routine that accepts any polynomial degree in each direction
+! returns 2D jacobian and normal for this face only
- integer ispecb,NGLLA,NGLLB,NSPEC2DMAX_AB,myrank
+ integer NGLLA,NGLLB,myrank
double precision xelm(NGNOD2D),yelm(NGNOD2D),zelm(NGNOD2D)
double precision dershape2D(NDIM2D,NGNOD2D,NGLLA,NGLLB)
+ double precision wgllwgll(NGLLA,NGLLB)
+
+ real(kind=CUSTOM_REAL) jacobian2D_face(NGLLA,NGLLB)
+ real(kind=CUSTOM_REAL) normal_face(NDIM,NGLLA,NGLLB)
- real(kind=CUSTOM_REAL) jacobian2D(NGLLA,NGLLB,NSPEC2DMAX_AB)
- real(kind=CUSTOM_REAL) normal(3,NGLLA,NGLLB,NSPEC2DMAX_AB)
-
integer i,j,ia
double precision xxi,xeta,yxi,yeta,zxi,zeta
double precision unx,uny,unz,jacobian
@@ -313,23 +243,857 @@
jacobian=dsqrt(unx**2+uny**2+unz**2)
if(jacobian == ZERO) call exit_MPI(myrank,'2D Jacobian undefined')
-! normalize normal vector and store surface jacobian
+! normalize normal vector and store weighted surface jacobian
! distinguish if single or double precision for reals
if(CUSTOM_REAL == SIZE_REAL) then
- jacobian2D(i,j,ispecb)=sngl(jacobian)
- normal(1,i,j,ispecb)=sngl(unx/jacobian)
- normal(2,i,j,ispecb)=sngl(uny/jacobian)
- normal(3,i,j,ispecb)=sngl(unz/jacobian)
+ jacobian2D_face(i,j) = sngl(jacobian * wgllwgll(i,j) )
+ normal_face(1,i,j)=sngl(unx/jacobian)
+ normal_face(2,i,j)=sngl(uny/jacobian)
+ normal_face(3,i,j)=sngl(unz/jacobian)
else
- jacobian2D(i,j,ispecb)=jacobian
- normal(1,i,j,ispecb)=unx/jacobian
- normal(2,i,j,ispecb)=uny/jacobian
- normal(3,i,j,ispecb)=unz/jacobian
+ jacobian2D_face(i,j) = jacobian * wgllwgll(i,j)
+ normal_face(1,i,j)=unx/jacobian
+ normal_face(2,i,j)=uny/jacobian
+ normal_face(3,i,j)=unz/jacobian
endif
enddo
enddo
- end subroutine compute_jacobian_2D
+ end subroutine compute_jacobian_2D_face
+
+
+! This subroutine recompute the 3D jacobian for one element
+! based upon 125 GLL points
+! Hejun Zhu OCT16,2009
+! input: myrank,
+! xstore,ystore,zstore ----- input position
+! xigll,yigll,zigll ----- gll points position
+! ispec,nspec ----- element number
+! ACTUALLY_STORE_ARRAYS ------ save array or not
+
+! output: xixstore,xiystore,xizstore,
+! etaxstore,etaystore,etazstore,
+! gammaxstore,gammaystore,gammazstore ------ parameters used for calculating jacobian
+
+
+ subroutine recalc_jacobian_gll2D(myrank,xstore,ystore,zstore, &
+ xigll,yigll,wgllwgll,NGLLA,NGLLB, &
+ ispec,nspec,jacobian2D_face,normal_face)
+
+ implicit none
+
+ include "constants.h"
+
+ ! input parameter
+ integer::myrank,ispec,nspec
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
+
+ integer :: NGLLA,NGLLB
+ double precision, dimension(NGLLA):: xigll
+ double precision, dimension(NGLLB):: yigll
+ double precision:: wgllwgll(NGLLA,NGLLB)
+
+ real(kind=CUSTOM_REAL) jacobian2D_face(NGLLA,NGLLB)
+ real(kind=CUSTOM_REAL) normal_face(NDIM,NGLLA,NGLLB)
+
+ ! other parameters for this subroutine
+ integer:: i,j,k,i1,j1,k1
+ double precision:: xxi,xeta,yxi,yeta,zxi,zeta
+ double precision:: xi,eta
+ double precision,dimension(NGLLA):: hxir,hpxir
+ double precision,dimension(NGLLB):: hetar,hpetar
+ double precision:: hlagrange,hlagrange_xi,hlagrange_eta
+ double precision:: jacobian
+ double precision:: unx,uny,unz
+
+
+
+ ! test parameters which can be deleted
+ double precision:: xmesh,ymesh,zmesh
+ double precision:: sumshape,sumdershapexi,sumdershapeeta
+
+ ! first go over all gll points on face
+ k=1
+ do j=1,NGLLB
+ do i=1,NGLLA
+
+ xxi = 0.0
+ xeta = 0.0
+ yxi = 0.0
+ yeta = 0.0
+ zxi = 0.0
+ zeta = 0.0
+
+ xi = xigll(i)
+ eta = yigll(j)
+
+ ! calculate lagrange polynomial and its derivative
+ call lagrange_any(xi,NGLLA,xigll,hxir,hpxir)
+ call lagrange_any(eta,NGLLB,yigll,hetar,hpetar)
+
+ ! test parameters
+ sumshape = 0.0
+ sumdershapexi = 0.0
+ sumdershapeeta = 0.0
+ xmesh = 0.0
+ ymesh = 0.0
+ zmesh = 0.0
+
+ k1=1
+ do j1 = 1,NGLLB
+ do i1 = 1,NGLLA
+ hlagrange = hxir(i1)*hetar(j1)
+ hlagrange_xi = hpxir(i1)*hetar(j1)
+ hlagrange_eta = hxir(i1)*hpetar(j1)
+
+
+ xxi = xxi + xstore(i1,j1,k1,ispec)*hlagrange_xi
+ xeta = xeta + xstore(i1,j1,k1,ispec)*hlagrange_eta
+
+ yxi = yxi + ystore(i1,j1,k1,ispec)*hlagrange_xi
+ yeta = yeta + ystore(i1,j1,k1,ispec)*hlagrange_eta
+
+ zxi = zxi + zstore(i1,j1,k1,ispec)*hlagrange_xi
+ zeta = zeta + zstore(i1,j1,k1,ispec)*hlagrange_eta
+
+ ! test the lagrange polynomial and its derivate
+ xmesh = xmesh + xstore(i1,j1,k1,ispec)*hlagrange
+ ymesh = ymesh + ystore(i1,j1,k1,ispec)*hlagrange
+ zmesh = zmesh + zstore(i1,j1,k1,ispec)*hlagrange
+ sumshape = sumshape + hlagrange
+ sumdershapexi = sumdershapexi + hlagrange_xi
+ sumdershapeeta = sumdershapeeta + hlagrange_eta
+
+ end do
+ end do
+
+ ! Check the lagrange polynomial and its derivative
+ if (xmesh /=xstore(i,j,k,ispec).or.ymesh/=ystore(i,j,k,ispec).or.zmesh/=zstore(i,j,k,ispec)) then
+ call exit_MPI(myrank,'new mesh positions are wrong in recalc_jacobian_gall3D.f90')
+ end if
+ if(abs(sumshape-one) > TINYVAL) then
+ call exit_MPI(myrank,'error shape functions in recalc_jacobian_gll3D.f90')
+ end if
+ if(abs(sumdershapexi) > TINYVAL) then
+ call exit_MPI(myrank,'error derivative xi shape functions in recalc_jacobian_gll3D.f90')
+ end if
+ if(abs(sumdershapeeta) > TINYVAL) then
+ call exit_MPI(myrank,'error derivative eta shape functions in recalc_jacobian_gll3D.f90')
+ end if
+
+! calculate the unnormalized normal to the boundary
+ unx=yxi*zeta-yeta*zxi
+ uny=zxi*xeta-zeta*xxi
+ unz=xxi*yeta-xeta*yxi
+ jacobian=dsqrt(unx**2+uny**2+unz**2)
+ if(jacobian <= ZERO) call exit_MPI(myrank,'2D Jacobian undefined')
+
+! normalize normal vector and store weighted surface jacobian
+
+! distinguish if single or double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ jacobian2D_face(i,j) = sngl(jacobian * wgllwgll(i,j) )
+ normal_face(1,i,j)=sngl(unx/jacobian)
+ normal_face(2,i,j)=sngl(uny/jacobian)
+ normal_face(3,i,j)=sngl(unz/jacobian)
+ else
+ jacobian2D_face(i,j) = jacobian * wgllwgll(i,j)
+ normal_face(1,i,j)=unx/jacobian
+ normal_face(2,i,j)=uny/jacobian
+ normal_face(3,i,j)=unz/jacobian
+ endif
+
+ enddo
+ enddo
+
+ end subroutine recalc_jacobian_gll2D
+
+!
+!------------------------------------------------------------------------------------------------
+!
+!
+! subroutine get_jacobian_boundaries(myrank,iboun,nspec, &
+! xstore_dummy,ystore_dummy,zstore_dummy,ibool,nglob,&
+! dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+! wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,&
+! ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+! xcoord_iboun,ycoord_iboun,zcoord_iboun, &
+! nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+! jacobian2D_xmin,jacobian2D_xmax, &
+! jacobian2D_ymin,jacobian2D_ymax, &
+! jacobian2D_bottom,jacobian2D_top, &
+! normal_xmin,normal_xmax, &
+! normal_ymin,normal_ymax, &
+! normal_bottom,normal_top, &
+! NSPEC2D_BOTTOM,NSPEC2D_TOP)
+!
+! implicit none
+!
+! include "constants.h"
+!
+! integer nspec,myrank,nglob
+!
+!! arrays with the mesh
+! integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+! real(kind=CUSTOM_REAL) :: xstore_dummy(nglob),ystore_dummy(nglob),zstore_dummy(nglob)
+!
+!
+!! absorbing boundaries
+!! (careful with array bounds, no need for NSPEC2DMAX_XMIN_XMAX & NSPEC2DMAX_YMIN_YMAX anymore)
+! integer :: nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, nspec2D_ymax, NSPEC2D_BOTTOM, NSPEC2D_TOP
+! integer, dimension(nspec2D_xmin) :: ibelm_xmin
+! integer, dimension(nspec2D_xmax) :: ibelm_xmax
+! integer, dimension(nspec2D_ymin) :: ibelm_ymin
+! integer, dimension(nspec2D_ymax) :: ibelm_ymax
+! integer, dimension(NSPEC2D_BOTTOM) :: ibelm_bottom
+! integer, dimension(NSPEC2D_TOP) :: ibelm_top
+!
+! logical iboun(6,nspec)
+! real(kind=CUSTOM_REAL), dimension(NGNOD2D,6,nspec) :: xcoord_iboun,ycoord_iboun,zcoord_iboun
+!
+!! double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+!! double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+!! double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+!
+! real(kind=CUSTOM_REAL) jacobian2D_xmin(NGLLY,NGLLZ,NSPEC2D_xmin)
+! real(kind=CUSTOM_REAL) jacobian2D_xmax(NGLLY,NGLLZ,NSPEC2D_xmax)
+! real(kind=CUSTOM_REAL) jacobian2D_ymin(NGLLX,NGLLZ,NSPEC2D_ymin)
+! real(kind=CUSTOM_REAL) jacobian2D_ymax(NGLLX,NGLLZ,NSPEC2D_ymax)
+! real(kind=CUSTOM_REAL) jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM)
+! real(kind=CUSTOM_REAL) jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP)
+!
+! real(kind=CUSTOM_REAL) normal_xmin(NDIM,NGLLY,NGLLZ,NSPEC2D_xmin)
+! real(kind=CUSTOM_REAL) normal_xmax(NDIM,NGLLY,NGLLZ,NSPEC2D_xmax)
+! real(kind=CUSTOM_REAL) normal_ymin(NDIM,NGLLX,NGLLZ,NSPEC2D_ymin)
+! real(kind=CUSTOM_REAL) normal_ymax(NDIM,NGLLX,NGLLZ,NSPEC2D_ymax)
+! real(kind=CUSTOM_REAL) normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM)
+! real(kind=CUSTOM_REAL) normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP)
+!
+! double precision dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ)
+! double precision dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ)
+! double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY)
+! double precision dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY)
+!
+! double precision, dimension(NGLLX,NGLLY) :: wgllwgll_xy
+! double precision, dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+! double precision, dimension(NGLLY,NGLLZ) :: wgllwgll_yz
+!
+! double precision xelm(NGNOD2D),yelm(NGNOD2D),zelm(NGNOD2D)
+!
+!! element numbering
+! integer ispec,i,j
+!
+!! counters to keep track of number of elements on each of the boundaries
+! integer ispecb1,ispecb2,ispecb3,ispecb4,ispecb5,ispecb6
+!
+!
+!! check that the parameter file is correct
+! if(NGNOD /= 8) call exit_MPI(myrank,'elements should have 8 control nodes')
+! if(NGNOD2D /= 4) call exit_MPI(myrank,'surface elements should have 4 control nodes')
+!
+! ispecb1 = 0
+! ispecb2 = 0
+! ispecb3 = 0
+! ispecb4 = 0
+! ispecb5 = 0
+! ispecb6 = 0
+!
+! do ispec=1,nspec
+!
+!! determine if the element falls on a boundary
+!
+!! on boundary: xmin
+!
+! if(iboun(1,ispec)) then
+!
+! ispecb1=ispecb1+1
+! ibelm_xmin(ispecb1)=ispec
+!
+!! specify the 4 nodes for the 2-D boundary element
+!! i.e. face (0,0,0),(0,1,0),(0,1,1),(0,0,1)
+!
+!! careful: these points may not be on the xmin face for unstructured grids
+!! xelm(1)=xstore(1,1,1,ispec)
+!! yelm(1)=ystore(1,1,1,ispec)
+!! zelm(1)=zstore(1,1,1,ispec)
+!! xelm(2)=xstore(1,NGLLY,1,ispec)
+!! yelm(2)=ystore(1,NGLLY,1,ispec)
+!! zelm(2)=zstore(1,NGLLY,1,ispec)
+!! xelm(3)=xstore(1,NGLLY,NGLLZ,ispec)
+!! yelm(3)=ystore(1,NGLLY,NGLLZ,ispec)
+!! zelm(3)=zstore(1,NGLLY,NGLLZ,ispec)
+!! xelm(4)=xstore(1,1,NGLLZ,ispec)
+!! yelm(4)=ystore(1,1,NGLLZ,ispec)
+!! zelm(4)=zstore(1,1,NGLLZ,ispec)
+!
+! xelm(1)=xstore_dummy( ibool(1,1,1,ispec) )
+! yelm(1)=ystore_dummy( ibool(1,1,1,ispec) )
+! zelm(1)=zstore_dummy( ibool(1,1,1,ispec) )
+! xelm(2)=xstore_dummy( ibool(1,NGLLY,1,ispec) )
+! yelm(2)=ystore_dummy( ibool(1,NGLLY,1,ispec) )
+! zelm(2)=zstore_dummy( ibool(1,NGLLY,1,ispec) )
+! xelm(3)=xstore_dummy( ibool(1,NGLLY,NGLLZ,ispec) )
+! yelm(3)=ystore_dummy( ibool(1,NGLLY,NGLLZ,ispec) )
+! zelm(3)=zstore_dummy( ibool(1,NGLLY,NGLLZ,ispec) )
+! xelm(4)=xstore_dummy( ibool(1,1,NGLLZ,ispec) )
+! yelm(4)=ystore_dummy( ibool(1,1,NGLLZ,ispec) )
+! zelm(4)=zstore_dummy( ibool(1,1,NGLLZ,ispec) )
+!
+!! takes coordinates from boundary faces
+!! do i=1,NGNOD2D
+!! xelm(i) = xcoord_iboun(i,1,ispec)
+!! yelm(i) = ycoord_iboun(i,1,ispec)
+!! zelm(i) = zcoord_iboun(i,1,ispec)
+!! enddo
+!
+! !daniel
+! ! checks points for layered_halfspace model:
+! ! xmin = zero, xmax = 134000.0, etc...
+! !if( myrank == 0 ) then
+! ! ! print*,'xmin: ',xelm(4),yelm(4),zelm(4)
+! ! if( abs(xelm(1) - 0.0) > 0.1) print*,'error xmin:',ispec,ispecb1,xelm(1),yelm(1),zelm(1)
+! ! if( abs(xelm(2) - 0.0) > 0.1) print*,'error xmin:',ispec,ispecb1,xelm(2),yelm(2),zelm(2)
+! ! if( abs(xelm(3) - 0.0) > 0.1) print*,'error xmin:',ispec,ispecb1,xelm(3),yelm(3),zelm(3)
+! ! if( abs(xelm(4) - 0.0) > 0.1) print*,'error xmin:',ispec,ispecb1,xelm(4),yelm(4),zelm(4)
+! !endif
+!
+! call compute_jacobian_2D(myrank,ispecb1,xelm,yelm,zelm, &
+! dershape2D_x,wgllwgll_yz, &
+! jacobian2D_xmin,normal_xmin,NGLLY,NGLLZ,NSPEC2D_xmin)
+!
+! ! normal convention: points away from element
+! ! switches normal direction if necessary
+! do i=1,NGLLY
+! do j=1,NGLLZ
+! call get_element_face_normal(ispecb1, 1, xelm,yelm,zelm, &
+! ibool,nspec,nglob, &
+! xstore_dummy,ystore_dummy,zstore_dummy, &
+! normal_xmin(:,i,j,ispecb1) )
+! enddo
+! enddo
+!
+! !daniel
+! ! checks: layered halfspace
+! ! checks normal:
+! ! for boundary on xmin, outward direction must be (-1,0,0)
+! !if( myrank == 0 ) then
+! !i=1; j=1
+! !do i=1,NGLLY
+! ! do j=1,NGLLZ
+! ! if( abs(normal_xmin(1,i,j,ispecb1) + 1.0 ) > 0.1 ) then
+! ! print*,'error normal xmin',myrank,ispecb1
+! ! print*,sngl(normal_xmin(:,i,j,ispecb1))
+! ! !stop
+! ! endif
+! ! enddo
+! !enddo
+! ! print*,'normal xmin 1:',sngl(normal_xmin(:,1,1,ispecb1)),'jac',sngl(jacobian2D_xmin(1,1,ispecb1))
+! ! print*,'normal xmin 2:',sngl(normal_xmin(:,2,2,ispecb1)),'jac',sngl(jacobian2D_xmin(2,2,ispecb1))
+! ! print*,'normal xmin 3:',sngl(normal_xmin(:,3,3,ispecb1)),'jac',sngl(jacobian2D_xmin(3,3,ispecb1))
+! !endif
+!
+! endif
+!
+!! on boundary: xmax
+!
+! if(iboun(2,ispec)) then
+!
+! ispecb2=ispecb2+1
+! ibelm_xmax(ispecb2)=ispec
+!
+!! careful...
+!! specify the 4 nodes for the 2-D boundary element
+!! xelm(1)=xstore(NGLLX,1,1,ispec)
+!! yelm(1)=ystore(NGLLX,1,1,ispec)
+!! zelm(1)=zstore(NGLLX,1,1,ispec)
+!! xelm(2)=xstore(NGLLX,NGLLY,1,ispec)
+!! yelm(2)=ystore(NGLLX,NGLLY,1,ispec)
+!! zelm(2)=zstore(NGLLX,NGLLY,1,ispec)
+!! xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
+!! yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
+!! zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
+!! xelm(4)=xstore(NGLLX,1,NGLLZ,ispec)
+!! yelm(4)=ystore(NGLLX,1,NGLLZ,ispec)
+!! zelm(4)=zstore(NGLLX,1,NGLLZ,ispec)
+!
+! xelm(1)=xstore_dummy( ibool(NGLLX,1,1,ispec) )
+! yelm(1)=ystore_dummy( ibool(NGLLX,1,1,ispec) )
+! zelm(1)=zstore_dummy( ibool(NGLLX,1,1,ispec) )
+! xelm(2)=xstore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+! yelm(2)=ystore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+! zelm(2)=zstore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+! xelm(3)=xstore_dummy( ibool(NGLLX,NGLLY,NGLLZ,ispec) )
+! yelm(3)=ystore_dummy( ibool(NGLLX,NGLLY,NGLLZ,ispec) )
+! zelm(3)=zstore_dummy( ibool(NGLLX,NGLLY,NGLLZ,ispec) )
+! xelm(4)=xstore_dummy( ibool(NGLLX,1,NGLLZ,ispec) )
+! yelm(4)=ystore_dummy( ibool(NGLLX,1,NGLLZ,ispec) )
+! zelm(4)=zstore_dummy( ibool(NGLLX,1,NGLLZ,ispec) )
+!
+!! takes coordinates from boundary faces
+!! do i=1,NGNOD2D
+!! xelm(i) = xcoord_iboun(i,2,ispec)
+!! yelm(i) = ycoord_iboun(i,2,ispec)
+!! zelm(i) = zcoord_iboun(i,2,ispec)
+!! enddo
+!
+! !daniel
+! ! checks: for halfspace model
+! !if( myrank == 0 ) then
+! ! ! print*,'xmax: ',xelm(4),yelm(4),zelm(4)
+! ! if( abs(xelm(4) - 134000.0) > 0.1) print*,'error xmax:',myrank,ispec,ispecb2,xelm(4)
+! !endif
+!
+! call compute_jacobian_2D(myrank,ispecb2,xelm,yelm,zelm, &
+! dershape2D_x,wgllwgll_yz, &
+! jacobian2D_xmax,normal_xmax,NGLLY,NGLLZ,NSPEC2D_xmax)
+!
+! ! normal convention: points away from element
+! ! switch normal direction if necessary
+! do i=1,NGLLY
+! do j=1,NGLLZ
+! call get_element_face_normal(ispecb2, 2, xelm,yelm,zelm, &
+! ibool,nspec,nglob, &
+! xstore_dummy,ystore_dummy,zstore_dummy, &
+! normal_xmax(:,i,j,ispecb2) )
+! enddo
+! enddo
+!
+! !daniel
+! ! checks: layered halfspace
+! ! checks normal:
+! ! for boundary on xmax, outward direction must be (1,0,0)
+! !if( myrank == 0 ) then
+! ! do i=1,NGLLY
+! ! do j=1,NGLLZ
+! i=1; j=1
+! if( abs(normal_xmax(1,i,j,ispecb2) - 1.0 ) > 0.1 ) then
+! print*,'error normal xmax',myrank,ispecb2
+! print*,sngl(normal_xmax(:,i,j,ispecb2))
+! !stop
+! endif
+! ! enddo
+! ! enddo
+! ! print*,'normal xmax 1:',sngl(normal_xmax(:,1,1,ispecb2)),'jac',sngl(jacobian2D_xmax(1,1,ispecb2))
+! ! print*,'normal xmax 2:',sngl(normal_xmax(:,2,2,ispecb2)),'jac',sngl(jacobian2D_xmax(2,2,ispecb2))
+! ! print*,'normal xmax 3:',sngl(normal_xmax(:,3,3,ispecb2)),'jac',sngl(jacobian2D_xmax(3,3,ispecb2))
+! !endif
+!
+! endif
+!
+!! on boundary: ymin
+!
+! if(iboun(3,ispec)) then
+!
+! ispecb3=ispecb3+1
+! ibelm_ymin(ispecb3)=ispec
+!
+!! careful...
+!! specify the 4 nodes for the 2-D boundary element
+!! xelm(1)=xstore(1,1,1,ispec)
+!! yelm(1)=ystore(1,1,1,ispec)
+!! zelm(1)=zstore(1,1,1,ispec)
+!! xelm(2)=xstore(NGLLX,1,1,ispec)
+!! yelm(2)=ystore(NGLLX,1,1,ispec)
+!! zelm(2)=zstore(NGLLX,1,1,ispec)
+!! xelm(3)=xstore(NGLLX,1,NGLLZ,ispec)
+!! yelm(3)=ystore(NGLLX,1,NGLLZ,ispec)
+!! zelm(3)=zstore(NGLLX,1,NGLLZ,ispec)
+!! xelm(4)=xstore(1,1,NGLLZ,ispec)
+!! yelm(4)=ystore(1,1,NGLLZ,ispec)
+!! zelm(4)=zstore(1,1,NGLLZ,ispec)
+!
+! xelm(1)=xstore_dummy( ibool(1,1,1,ispec) )
+! yelm(1)=ystore_dummy( ibool(1,1,1,ispec) )
+! zelm(1)=zstore_dummy( ibool(1,1,1,ispec) )
+! xelm(2)=xstore_dummy( ibool(NGLLX,1,1,ispec) )
+! yelm(2)=ystore_dummy( ibool(NGLLX,1,1,ispec) )
+! zelm(2)=zstore_dummy( ibool(NGLLX,1,1,ispec) )
+! xelm(3)=xstore_dummy( ibool(NGLLX,1,NGLLZ,ispec) )
+! yelm(3)=ystore_dummy( ibool(NGLLX,1,NGLLZ,ispec) )
+! zelm(3)=zstore_dummy( ibool(NGLLX,1,NGLLZ,ispec) )
+! xelm(4)=xstore_dummy( ibool(1,1,NGLLZ,ispec) )
+! yelm(4)=ystore_dummy( ibool(1,1,NGLLZ,ispec) )
+! zelm(4)=zstore_dummy( ibool(1,1,NGLLZ,ispec) )
+!
+!! takes coordinates from boundary faces
+!! do i=1,NGNOD2D
+!! xelm(i) = xcoord_iboun(i,3,ispec)
+!! yelm(i) = ycoord_iboun(i,3,ispec)
+!! zelm(i) = zcoord_iboun(i,3,ispec)
+!! enddo
+!
+! !daniel
+! ! checks: for layered halfspace
+! !if( myrank == 0 ) then
+! ! ! print*,'ymin: ',xelm(4),yelm(4),zelm(4)
+! ! if( abs(yelm(4) - 0.0) > 0.1) print*,'error ymin:',myrank,ispec,ispecb3,yelm(4)
+! !endif
+!
+! call compute_jacobian_2D(myrank,ispecb3,xelm,yelm,zelm, &
+! dershape2D_y,wgllwgll_xz, &
+! jacobian2D_ymin,normal_ymin,NGLLX,NGLLZ,NSPEC2D_ymin)
+!
+! ! normal convention: points away from element
+! ! switch normal direction if necessary
+! do i=1,NGLLX
+! do j=1,NGLLZ
+! call get_element_face_normal(ispecb3, 3, xelm,yelm,zelm, &
+! ibool,nspec,nglob, &
+! xstore_dummy,ystore_dummy,zstore_dummy, &
+! normal_ymin(:,i,j,ispecb3) )
+! enddo
+! enddo
+!
+! !daniel
+! ! checks: layered halfspace
+! ! checks normal:
+! ! for boundary on ymin, outward direction must be (0,-1,0)
+! !if( myrank == 0 ) then
+! ! do i=1,NGLLX
+! ! do j=1,NGLLZ
+! !i=1; j=1
+! ! if( abs(normal_ymin(2,i,j,ispecb3) + 1.0 ) > 0.1 ) then
+! ! print*,'error normal ymin',myrank,ispecb3
+! ! print*,sngl(normal_ymin(:,i,j,ispecb3))
+! ! !stop
+! ! endif
+! ! enddo
+! ! enddo
+! ! print*,'normal ymin 1:',sngl(normal_ymin(:,1,1,ispecb3)),'jac',sngl(jacobian2D_ymin(1,1,ispecb3))
+! ! print*,'normal ymin 2:',sngl(normal_ymin(:,2,2,ispecb3)),'jac',sngl(jacobian2D_ymin(2,2,ispecb3))
+! ! print*,'normal ymin 3:',sngl(normal_ymin(:,3,3,ispecb3)),'jac',sngl(jacobian2D_ymin(3,3,ispecb3))
+! !endif
+!
+! endif
+!
+!! on boundary: ymax
+!
+! if(iboun(4,ispec)) then
+!
+! ispecb4=ispecb4+1
+! ibelm_ymax(ispecb4)=ispec
+!
+!!careful...
+!! specify the 4 nodes for the 2-D boundary element
+!! xelm(1)=xstore(1,NGLLY,1,ispec)
+!! yelm(1)=ystore(1,NGLLY,1,ispec)
+!! zelm(1)=zstore(1,NGLLY,1,ispec)
+!! xelm(2)=xstore(NGLLX,NGLLY,1,ispec)
+!! yelm(2)=ystore(NGLLX,NGLLY,1,ispec)
+!! zelm(2)=zstore(NGLLX,NGLLY,1,ispec)
+!! xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
+!! yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
+!! zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
+!! xelm(4)=xstore(1,NGLLY,NGLLZ,ispec)
+!! yelm(4)=ystore(1,NGLLY,NGLLZ,ispec)
+!! zelm(4)=zstore(1,NGLLY,NGLLZ,ispec)
+!
+! xelm(1)=xstore_dummy( ibool(1,NGLLY,1,ispec) )
+! yelm(1)=ystore_dummy( ibool(1,NGLLY,1,ispec) )
+! zelm(1)=zstore_dummy( ibool(1,NGLLY,1,ispec) )
+! xelm(2)=xstore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+! yelm(2)=ystore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+! zelm(2)=zstore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+! xelm(3)=xstore_dummy( ibool(NGLLX,NGLLY,NGLLZ,ispec) )
+! yelm(3)=ystore_dummy( ibool(NGLLX,NGLLY,NGLLZ,ispec) )
+! zelm(3)=zstore_dummy( ibool(NGLLX,NGLLY,NGLLZ,ispec) )
+! xelm(4)=xstore_dummy( ibool(1,NGLLY,NGLLZ,ispec) )
+! yelm(4)=ystore_dummy( ibool(1,NGLLY,NGLLZ,ispec) )
+! zelm(4)=zstore_dummy( ibool(1,NGLLY,NGLLZ,ispec) )
+!
+!! takes coordinates from boundary faces
+!! do i=1,NGNOD2D
+!! xelm(i) = xcoord_iboun(i,4,ispec)
+!! yelm(i) = ycoord_iboun(i,4,ispec)
+!! zelm(i) = zcoord_iboun(i,4,ispec)
+!! enddo
+!
+! !daniel
+! ! checks: for layered halfspace
+! !if( myrank == 0 ) then
+! ! !print*,'ymax: ',xelm(4),yelm(4),zelm(4)
+! ! if( abs(yelm(4) -134000.0) > 0.1 ) print*,'error ymax:',myrank,ispec,ispecb4,yelm(4)
+! !endif
+!
+! call compute_jacobian_2D(myrank,ispecb4,xelm,yelm,zelm, &
+! dershape2D_y, wgllwgll_xz, &
+! jacobian2D_ymax,normal_ymax,NGLLX,NGLLZ,NSPEC2D_ymax)
+!
+! ! normal convention: points away from element
+! ! switch normal direction if necessary
+! do i=1,NGLLX
+! do j=1,NGLLZ
+! call get_element_face_normal(ispecb4, 4, xelm,yelm,zelm, &
+! ibool,nspec,nglob, &
+! xstore_dummy,ystore_dummy,zstore_dummy, &
+! normal_ymax(:,i,j,ispecb4) )
+! enddo
+! enddo
+!
+! !daniel
+! ! checks: layered halfspace
+! ! checks normal:
+! ! for boundary on ymax, outward direction must be (0,1,0)
+! !if( myrank == 0 ) then
+! ! do i=1,NGLLX
+! ! do j=1,NGLLZ
+! i=1; j=1
+! if( abs(normal_ymax(2,i,j,ispecb4) - 1.0 ) > 0.1 ) then
+! print*,'error normal ymax',myrank,ispecb4
+! print*,sngl(normal_ymax(:,i,j,ispecb4))
+! !stop
+! endif
+! ! enddo
+! ! enddo
+! ! print*,'normal ymax 1:',sngl(normal_ymax(:,1,1,ispecb4)),'jac',sngl(jacobian2D_ymax(1,1,ispecb4))
+! ! print*,'normal ymax 2:',sngl(normal_ymax(:,2,2,ispecb4)),'jac',sngl(jacobian2D_ymax(2,2,ispecb4))
+! ! print*,'normal ymax 3:',sngl(normal_ymax(:,3,3,ispecb4)),'jac',sngl(jacobian2D_ymax(3,3,ispecb4))
+! !endif
+!
+! endif
+!
+!! on boundary: bottom
+!
+! if(iboun(5,ispec)) then
+!
+! ispecb5=ispecb5+1
+! ibelm_bottom(ispecb5)=ispec
+!
+!! careful...
+!! for bottom, this might be actually working... when mesh is oriented along z direction...
+!! xelm(1)=xstore(1,1,1,ispec)
+!! yelm(1)=ystore(1,1,1,ispec)
+!! zelm(1)=zstore(1,1,1,ispec)
+!! xelm(2)=xstore(NGLLX,1,1,ispec)
+!! yelm(2)=ystore(NGLLX,1,1,ispec)
+!! zelm(2)=zstore(NGLLX,1,1,ispec)
+!! xelm(3)=xstore(NGLLX,NGLLY,1,ispec)
+!! yelm(3)=ystore(NGLLX,NGLLY,1,ispec)
+!! zelm(3)=zstore(NGLLX,NGLLY,1,ispec)
+!! xelm(4)=xstore(1,NGLLY,1,ispec)
+!! yelm(4)=ystore(1,NGLLY,1,ispec)
+!! zelm(4)=zstore(1,NGLLY,1,ispec)
+!
+! xelm(1)=xstore_dummy( ibool(1,1,1,ispec) )
+! yelm(1)=ystore_dummy( ibool(1,1,1,ispec) )
+! zelm(1)=zstore_dummy( ibool(1,1,1,ispec) )
+! xelm(2)=xstore_dummy( ibool(NGLLX,1,1,ispec) )
+! yelm(2)=ystore_dummy( ibool(NGLLX,1,1,ispec) )
+! zelm(2)=zstore_dummy( ibool(NGLLX,1,1,ispec) )
+! xelm(3)=xstore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+! yelm(3)=ystore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+! zelm(3)=zstore_dummy( ibool(NGLLX,NGLLY,1,ispec) )
+! xelm(4)=xstore_dummy( ibool(1,NGLLY,1,ispec) )
+! yelm(4)=ystore_dummy( ibool(1,NGLLY,1,ispec) )
+! zelm(4)=zstore_dummy( ibool(1,NGLLY,1,ispec) )
+!
+!
+!! takes coordinates from boundary faces
+!! do i=1,NGNOD2D
+!! xelm(i) = xcoord_iboun(i,5,ispec)
+!! yelm(i) = ycoord_iboun(i,5,ispec)
+!! zelm(i) = zcoord_iboun(i,5,ispec)
+!! enddo
+!
+! !daniel
+! ! checks: layered halfspace
+! !if( myrank == 0 ) then
+! ! !print*,'bottom: ',xelm(4),yelm(4),zelm(4)
+! ! if( abs(zelm(4) + 60000.0) > 0.1) print*,'error bottom:',myrank,ispec,ispecb5,zelm(4)
+! !endif
+!
+! call compute_jacobian_2D(myrank,ispecb5,xelm,yelm,zelm,&
+! dershape2D_bottom,wgllwgll_xy, &
+! jacobian2D_bottom,normal_bottom,NGLLX,NGLLY,NSPEC2D_BOTTOM)
+!
+! ! normal convention: points away from element
+! ! switch normal direction if necessary
+! do i=1,NGLLX
+! do j=1,NGLLY
+! call get_element_face_normal(ispecb5, 5, xelm,yelm,zelm, &
+! ibool,nspec,nglob, &
+! xstore_dummy,ystore_dummy,zstore_dummy, &
+! normal_bottom(:,i,j,ispecb5) )
+! enddo
+! enddo
+!
+! !daniel
+! ! checks: layered halfspace
+! ! checks normal:
+! ! for boundary on bottom, outward direction must be (0,0,-1)
+! !if( myrank == 0 ) then
+! ! do i=1,NGLLX
+! ! do j=1,NGLLY
+! i=1; j=1
+! if( abs(normal_bottom(3,i,j,ispecb5) + 1.0 ) > 0.1 ) then
+! print*,'error normal bottom',myrank,ispecb5
+! print*,sngl(normal_bottom(:,i,j,ispecb5))
+! !stop
+! endif
+! ! enddo
+! ! enddo
+! ! print*,'normal bottom 1:',sngl(normal_bottom(:,1,1,ispecb5)),'jac',sngl(jacobian2D_bottom(1,1,ispecb5))
+! ! print*,'normal bottom 2:',sngl(normal_bottom(:,2,2,ispecb5)),'jac',sngl(jacobian2D_bottom(2,2,ispecb5))
+! ! print*,'normal bottom 3:',sngl(normal_bottom(:,3,3,ispecb5)),'jac',sngl(jacobian2D_bottom(3,3,ispecb5))
+! !endif
+!
+! endif
+!
+!! on boundary: top
+!
+! if(iboun(6,ispec)) then
+!
+! ispecb6=ispecb6+1
+! ibelm_top(ispecb6)=ispec
+!
+!! careful...
+!! for top, this might be working as well ... when mesh is oriented along z direction...
+!! xelm(1)=xstore(1,1,NGLLZ,ispec)
+!! yelm(1)=ystore(1,1,NGLLZ,ispec)
+!! zelm(1)=zstore(1,1,NGLLZ,ispec)
+!! xelm(2)=xstore(NGLLX,1,NGLLZ,ispec)
+!! yelm(2)=ystore(NGLLX,1,NGLLZ,ispec)
+!! zelm(2)=zstore(NGLLX,1,NGLLZ,ispec)
+!! xelm(3)=xstore(NGLLX,NGLLY,NGLLZ,ispec)
+!! yelm(3)=ystore(NGLLX,NGLLY,NGLLZ,ispec)
+!! zelm(3)=zstore(NGLLX,NGLLY,NGLLZ,ispec)
+!! xelm(4)=xstore(1,NGLLY,NGLLZ,ispec)
+!! yelm(4)=ystore(1,NGLLY,NGLLZ,ispec)
+!! zelm(4)=zstore(1,NGLLY,NGLLZ,ispec)
+!
+!
+!! takes coordinates from boundary faces
+!! do i=1,NGNOD2D
+!! xelm(i) = xcoord_iboun(i,6,ispec)
+!! yelm(i) = ycoord_iboun(i,6,ispec)
+!! zelm(i) = zcoord_iboun(i,6,ispec)
+!! enddo
+!
+! !daniel
+! ! checks: layered halfspace
+! !if( myrank == 0 ) then
+! ! !print*,'top: ',xelm(4),yelm(4),zelm(4)
+! !if( abs(zelm(4) - 0.0) > 0.1 ) print*,'error top:',myrank,ispec,ispecb6,zelm(4)
+! !endif
+!
+! call compute_jacobian_2D(myrank,ispecb6,xelm,yelm,zelm,&
+! dershape2D_top, wgllwgll_xy, &
+! jacobian2D_top,normal_top,NGLLX,NGLLY,NSPEC2D_TOP)
+!
+! ! normal convention: points away from element
+! ! switch normal direction if necessary
+! do i=1,NGLLX
+! do j=1,NGLLY
+! call get_element_face_normal(ispecb6, 6, xelm,yelm,zelm, &
+! ibool,nspec,nglob, &
+! xstore_dummy,ystore_dummy,zstore_dummy, &
+! normal_top(:,i,j,ispecb6) )
+! enddo
+! enddo
+!
+! !daniel
+! ! checks: layered halfspace
+! ! checks normal:
+! ! for boundary on top, outward direction must be (0,0,1)
+! !if( myrank == 0 ) then
+! ! do i=1,NGLLX
+! ! do j=1,NGLLY
+! i=1; j=1
+! if( abs(normal_top(3,i,j,ispecb6) - 1.0 ) > 0.1 ) then
+! print*,'error normal top',myrank,ispecb6
+! print*,sngl(normal_top(:,i,j,ispecb6))
+! stop
+! endif
+! ! enddo
+! ! enddo
+! !endif
+!
+! endif
+!
+! enddo
+!
+!! check theoretical value of elements
+!! if(ispecb1 /= NSPEC2D_xmin) call exit_MPI(myrank,'ispecb1 should equal NSPEC2D_xmin')
+!! if(ispecb2 /= NSPEC2D_xmax) call exit_MPI(myrank,'ispecb2 should equal NSPEC2D_xmax')
+!! if(ispecb3 /= NSPEC2D_ymin) call exit_MPI(myrank,'ispecb3 should equal NSPEC2D_ymin')
+!! if(ispecb4 /= NSPEC2D_ymax) call exit_MPI(myrank,'ispecb4 should equal NSPEC2D_ymax')
+!! if(ispecb5 /= NSPEC2D_BOTTOM) call exit_MPI(myrank,'ispecb5 should equal NSPEC2D_BOTTOM')
+!! if(ispecb6 /= NSPEC2D_TOP) call exit_MPI(myrank,'ispecb6 should equal NSPEC2D_TOP')
+!
+! end subroutine get_jacobian_boundaries
+!
+!! -------------------------------------------------------
+!
+! subroutine compute_jacobian_2D(myrank,ispecb,xelm,yelm,zelm, &
+! dershape2D,wgllwgll, &
+! jacobian2D,normal, &
+! NGLLA,NGLLB,NSPEC2DMAX_AB)
+!
+! implicit none
+!
+! include "constants.h"
+!
+!! generic routine that accepts any polynomial degree in each direction
+!
+! integer ispecb,NGLLA,NGLLB,NSPEC2DMAX_AB,myrank
+!
+! double precision xelm(NGNOD2D),yelm(NGNOD2D),zelm(NGNOD2D)
+! double precision dershape2D(NDIM2D,NGNOD2D,NGLLA,NGLLB)
+! double precision wgllwgll
+!
+! real(kind=CUSTOM_REAL) jacobian2D(NGLLA,NGLLB,NSPEC2DMAX_AB)
+! real(kind=CUSTOM_REAL) normal(3,NGLLA,NGLLB,NSPEC2DMAX_AB)
+!
+! integer i,j,ia
+! double precision xxi,xeta,yxi,yeta,zxi,zeta
+! double precision unx,uny,unz,jacobian
+!
+! do j=1,NGLLB
+! do i=1,NGLLA
+!
+! xxi=ZERO
+! xeta=ZERO
+! yxi=ZERO
+! yeta=ZERO
+! zxi=ZERO
+! zeta=ZERO
+! do ia=1,NGNOD2D
+! xxi=xxi+dershape2D(1,ia,i,j)*xelm(ia)
+! xeta=xeta+dershape2D(2,ia,i,j)*xelm(ia)
+! yxi=yxi+dershape2D(1,ia,i,j)*yelm(ia)
+! yeta=yeta+dershape2D(2,ia,i,j)*yelm(ia)
+! zxi=zxi+dershape2D(1,ia,i,j)*zelm(ia)
+! zeta=zeta+dershape2D(2,ia,i,j)*zelm(ia)
+! enddo
+!
+!! calculate the unnormalized normal to the boundary
+! unx=yxi*zeta-yeta*zxi
+! uny=zxi*xeta-zeta*xxi
+! unz=xxi*yeta-xeta*yxi
+! jacobian=dsqrt(unx**2+uny**2+unz**2)
+! if(jacobian == ZERO) call exit_MPI(myrank,'2D Jacobian undefined')
+!
+!! normalize normal vector and store weighted surface jacobian
+!
+!! distinguish if single or double precision for reals
+! if(CUSTOM_REAL == SIZE_REAL) then
+! jacobian2D(i,j,ispecb) = sngl(jacobian * wgllwgll(i,j) )
+! normal(1,i,j,ispecb)=sngl(unx/jacobian)
+! normal(2,i,j,ispecb)=sngl(uny/jacobian)
+! normal(3,i,j,ispecb)=sngl(unz/jacobian)
+! else
+! jacobian2D(i,j,ispecb) = jacobian * wgllwgll(i,j)
+! normal(1,i,j,ispecb)=unx/jacobian
+! normal(2,i,j,ispecb)=uny/jacobian
+! normal(3,i,j,ispecb)=unz/jacobian
+! endif
+!
+! enddo
+! enddo
+!
+! end subroutine compute_jacobian_2D
+!
+
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -70,9 +70,22 @@
call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
! check that optimized routines from Deville et al. (2002) can be used
- if(NGLLX /= 5 .or. NGLLY /= 5 .or. NGLLZ /= 5) &
- stop 'optimized routines from Deville et al. (2002) such as mxm_m1_m2_5points can only be used if NGLL = 5'
+ if( USE_DEVILLE_PRODUCTS) then
+ if(NGLLX /= 5 .or. NGLLY /= 5 .or. NGLLZ /= 5) &
+ stop 'optimized routines from Deville et al. (2002) such as mxm_m1_m2_5points can only be used if NGLL = 5'
+ endif
+
+! absorbing surfaces
+ if( ABSORBING_CONDITIONS ) then
+ if( .not. USE_DEVILLE_PRODUCTS ) stop 'ABSORPTION only implemented for USE_DEVILLE_PRODUCTS routine'
+ ! for arbitrary orientation of elements, which face belongs to xmin... -
+ ! does it makes sense to have different NGLLX,NGLLY,NGLLZ?
+ ! there is a problem with absorbing boundaries for faces with different NGLLX,NGLLY,NGLLZ values
+ ! just to be sure for now..
+ if( NGLLX /= NGLLY .and. NGLLY /= NGLLZ ) &
+ stop 'must have NGLLX = NGLLY = NGLLZ'
+ endif
! chris: DT_ext_mesh & NSTE_ext_mesh were in constants.h, I suppressed it, now it is Par_file & read in
! read_parameters_file.f90
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -88,18 +88,20 @@
! update acceleration
! shared points between processors only
if(USE_DEVILLE_PRODUCTS) then
- call compute_forces_with_Deville(NSPEC_AB,NGLOB_AB,ATTENUATION,displ,accel,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh,.false., &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,xi_source,eta_source,gamma_source,nu_source, &
- hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
- one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
- epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz,iflag_attenuation_store,ABSORBING_CONDITIONS, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom, &
- nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
- veloc,rho_vp,rho_vs,jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom, &
- normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom)
+ call compute_forces_with_Deville( .false. ,NSPEC_AB,NGLOB_AB,ATTENUATION,displ,accel,&
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh, &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source, &
+ xi_source,eta_source,gamma_source,nu_source, &
+ hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
+ one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz,iflag_attenuation_store,&
+ ABSORBING_CONDITIONS, &
+ absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
+ absorbing_boundary_ijk,absorbing_boundary_ispec, &
+ num_absorbing_boundary_faces, &
+ veloc,rho_vp,rho_vs)
else
call compute_forces_no_Deville(NSPEC_AB,NGLOB_AB,displ,accel,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
@@ -117,18 +119,20 @@
! update acceleration
! points inside processor's partition only
if(USE_DEVILLE_PRODUCTS) then
- call compute_forces_with_Deville(NSPEC_AB,NGLOB_AB,ATTENUATION,displ,accel,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh,.true., &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,xi_source,eta_source,gamma_source,nu_source, &
- hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
- one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
- epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz,iflag_attenuation_store,ABSORBING_CONDITIONS, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom, &
- nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
- veloc,rho_vp,rho_vs,jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom, &
- normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom)
+ call compute_forces_with_Deville( .true., NSPEC_AB,NGLOB_AB,ATTENUATION,displ,accel,&
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh, &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source, &
+ xi_source,eta_source,gamma_source,nu_source, &
+ hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
+ one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,NSPEC_ATTENUATION_AB,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz,iflag_attenuation_store,&
+ ABSORBING_CONDITIONS, &
+ absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
+ absorbing_boundary_ijk,absorbing_boundary_ispec, &
+ num_absorbing_boundary_faces, &
+ veloc,rho_vp,rho_vs)
else
call compute_forces_no_Deville(NSPEC_AB,NGLOB_AB,displ,accel,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
@@ -190,12 +194,12 @@
! shakemap creation
if (EXTERNAL_MESH_CREATE_SHAKEMAP) then
- call setup_movie_meshes_create_shakemap()
+ call iterate_time_create_shakemap_ext_mesh()
endif
! movie file creation
if(EXTERNAL_MESH_MOVIE_SURFACE .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
- call setup_movie_meshes_create_movie_surface()
+ call iterate_time_create_movie_surface_ext_mesh()
endif
! save MOVIE on the SURFACE
@@ -333,7 +337,6 @@
subroutine iterate_time_ocean_load()
use specfem_par
-
! initialize the updates
updated_dof_ocean_load(:) = .false.
@@ -636,7 +639,7 @@
! creation of shapemap file
- subroutine iterate_time_create_shakemap()
+ subroutine iterate_time_create_shakemap_ext_mesh()
use specfem_par
@@ -811,7 +814,7 @@
endif
endif
- end subroutine iterate_time_create_shakemap
+ end subroutine iterate_time_create_shakemap_ext_mesh
!================================================================
@@ -819,7 +822,7 @@
! creation of moviedata files
- subroutine iterate_time_create_movie_surface()
+ subroutine iterate_time_create_movie_surface_ext_mesh()
use specfem_par
! get coordinates of surface mesh and surface displacement
@@ -913,7 +916,7 @@
close(IOUT)
endif
- end subroutine iterate_time_create_movie_surface
+ end subroutine iterate_time_create_movie_surface_ext_mesh
!=====================================================================
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/locate_source.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/locate_source.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/locate_source.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -109,6 +109,9 @@
final_distance_source_all,x_found_source_all,y_found_source_all,z_found_source_all
double precision, dimension(3,3,NGATHER_SOURCES,0:NPROC-1) :: nu_source_all
+ double precision, dimension(:), allocatable :: tmp_local
+ double precision, dimension(:,:),allocatable :: tmp_all_local
+
double precision hdur(NSOURCES), hdur_gaussian(NSOURCES), t0
double precision, dimension(NSOURCES) :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
@@ -123,6 +126,9 @@
double precision, dimension(NSOURCES) :: x_found_source,y_found_source,z_found_source
double precision distmin
+ integer, dimension(:), allocatable :: tmp_i_local
+ integer, dimension(:,:),allocatable :: tmp_i_all_local
+
! for surface locating and normal computing with external mesh
integer :: pt0_ix,pt0_iy,pt0_iz,pt1_ix,pt1_iy,pt1_iz,pt2_ix,pt2_iy,pt2_iz
real(kind=CUSTOM_REAL), dimension(3) :: u_vector,v_vector,w_vector
@@ -170,45 +176,45 @@
! Mtp = -Mxy
! get the moment tensor
- Mzz(isource) = + moment_tensor(1,isource)
- Mxx(isource) = + moment_tensor(3,isource)
- Myy(isource) = + moment_tensor(2,isource)
- Mxz(isource) = + moment_tensor(5,isource)
- Myz(isource) = - moment_tensor(4,isource)
- Mxy(isource) = - moment_tensor(6,isource)
+ Mzz(isource) = + moment_tensor(1,isource)
+ Mxx(isource) = + moment_tensor(3,isource)
+ Myy(isource) = + moment_tensor(2,isource)
+ Mxz(isource) = + moment_tensor(5,isource)
+ Myz(isource) = - moment_tensor(4,isource)
+ Mxy(isource) = - moment_tensor(6,isource)
- call utm_geo(long(isource),lat(isource),utm_x_source(isource),utm_y_source(isource), &
+ call utm_geo(long(isource),lat(isource),utm_x_source(isource),utm_y_source(isource), &
UTM_PROJECTION_ZONE,ILONGLAT2UTM,.true.)
! orientation consistent with the UTM projection
! East
- nu_source(1,1,isource) = 1.d0
- nu_source(1,2,isource) = 0.d0
- nu_source(1,3,isource) = 0.d0
+ nu_source(1,1,isource) = 1.d0
+ nu_source(1,2,isource) = 0.d0
+ nu_source(1,3,isource) = 0.d0
! North
- nu_source(2,1,isource) = 0.d0
- nu_source(2,2,isource) = 1.d0
- nu_source(2,3,isource) = 0.d0
+ nu_source(2,1,isource) = 0.d0
+ nu_source(2,2,isource) = 1.d0
+ nu_source(2,3,isource) = 0.d0
! Vertical
- nu_source(3,1,isource) = 0.d0
- nu_source(3,2,isource) = 0.d0
- nu_source(3,3,isource) = 1.d0
+ nu_source(3,1,isource) = 0.d0
+ nu_source(3,2,isource) = 0.d0
+ nu_source(3,3,isource) = 1.d0
- x_target_source = utm_x_source(isource)
- y_target_source = utm_y_source(isource)
- z_target_source = depth(isource)
- if (myrank == 0) write(IOVTK,*) x_target_source, y_target_source, z_target_source
+ x_target_source = utm_x_source(isource)
+ y_target_source = utm_y_source(isource)
+ z_target_source = depth(isource)
+ if (myrank == 0) write(IOVTK,*) x_target_source, y_target_source, z_target_source
! set distance to huge initial value
- distmin = HUGEVAL
+ distmin = HUGEVAL
- ispec_selected_source(isource) = 0
+ ispec_selected_source(isource) = 0
- do ispec=1,NSPEC_AB
+ do ispec=1,NSPEC_AB
! define the interval in which we look for points
@@ -235,7 +241,7 @@
kmax = NGLLZ - 1
endif
- do k = kmin,kmax
+ do k = kmin,kmax
do j = jmin,jmax
do i = imin,imax
@@ -251,156 +257,156 @@
dist=dsqrt((x_target_source-dble(xstore(iglob)))**2 &
+(y_target_source-dble(ystore(iglob)))**2 &
+(z_target_source-dble(zstore(iglob)))**2)
- if(dist < distmin) then
- distmin=dist
- ispec_selected_source(isource)=ispec
- ix_initial_guess_source = i
- iy_initial_guess_source = j
- iz_initial_guess_source = k
+ if(dist < distmin) then
+ distmin=dist
+ ispec_selected_source(isource)=ispec
+ ix_initial_guess_source = i
+ iy_initial_guess_source = j
+ iz_initial_guess_source = k
! store xi,eta,gamma and x,y,z of point found
- xi_source(isource) = dble(ix_initial_guess_source)
- eta_source(isource) = dble(iy_initial_guess_source)
- gamma_source(isource) = dble(iz_initial_guess_source)
- x_found_source(isource) = xstore(iglob)
- y_found_source(isource) = ystore(iglob)
- z_found_source(isource) = zstore(iglob)
+ xi_source(isource) = dble(ix_initial_guess_source)
+ eta_source(isource) = dble(iy_initial_guess_source)
+ gamma_source(isource) = dble(iz_initial_guess_source)
+ x_found_source(isource) = xstore(iglob)
+ y_found_source(isource) = ystore(iglob)
+ z_found_source(isource) = zstore(iglob)
! compute final distance between asked and found (converted to km)
- final_distance_source(isource) = dsqrt((x_target_source-x_found_source(isource))**2 + &
- (y_target_source-y_found_source(isource))**2 + (z_target_source-z_found_source(isource))**2)
+ final_distance_source(isource) = dsqrt((x_target_source-x_found_source(isource))**2 + &
+ (y_target_source-y_found_source(isource))**2 + (z_target_source-z_found_source(isource))**2)
- endif
+ endif
+ enddo
+ enddo
enddo
- enddo
- enddo
! end of loop on all the elements in current slice
- enddo
+ enddo
- if (ispec_selected_source(isource) == 0) then
- final_distance_source(isource) = HUGEVAL
- endif
+ if (ispec_selected_source(isource) == 0) then
+ final_distance_source(isource) = HUGEVAL
+ endif
! get normal to the face of the hexaedra if receiver is on the surface
- if ((.not. SOURCES_CAN_BE_BURIED_EXT_MESH) .and. &
+ if ((.not. SOURCES_CAN_BE_BURIED_EXT_MESH) .and. &
.not. (ispec_selected_source(isource) == 0)) then
- pt0_ix = -1
- pt0_iy = -1
- pt0_iz = -1
- pt1_ix = -1
- pt1_iy = -1
- pt1_iz = -1
- pt2_ix = -1
- pt2_iy = -1
- pt2_iz = -1
+ pt0_ix = -1
+ pt0_iy = -1
+ pt0_iz = -1
+ pt1_ix = -1
+ pt1_iy = -1
+ pt1_iz = -1
+ pt2_ix = -1
+ pt2_iy = -1
+ pt2_iz = -1
! we get two vectors of the face (three points) to compute the normal
- if (xi_source(isource) == 1 .and. &
+ if (xi_source(isource) == 1 .and. &
iglob_is_surface_external_mesh(ibool(1,2,2,ispec_selected_source(isource)))) then
- pt0_ix = 1
- pt0_iy = NGLLY
- pt0_iz = 1
- pt1_ix = 1
- pt1_iy = 1
- pt1_iz = 1
- pt2_ix = 1
- pt2_iy = NGLLY
- pt2_iz = NGLLZ
- endif
- if (xi_source(isource) == NGLLX .and. &
+ pt0_ix = 1
+ pt0_iy = NGLLY
+ pt0_iz = 1
+ pt1_ix = 1
+ pt1_iy = 1
+ pt1_iz = 1
+ pt2_ix = 1
+ pt2_iy = NGLLY
+ pt2_iz = NGLLZ
+ endif
+ if (xi_source(isource) == NGLLX .and. &
iglob_is_surface_external_mesh(ibool(NGLLX,2,2,ispec_selected_source(isource)))) then
- pt0_ix = NGLLX
- pt0_iy = 1
- pt0_iz = 1
- pt1_ix = NGLLX
- pt1_iy = NGLLY
- pt1_iz = 1
- pt2_ix = NGLLX
- pt2_iy = 1
- pt2_iz = NGLLZ
- endif
- if (eta_source(isource) == 1 .and. &
+ pt0_ix = NGLLX
+ pt0_iy = 1
+ pt0_iz = 1
+ pt1_ix = NGLLX
+ pt1_iy = NGLLY
+ pt1_iz = 1
+ pt2_ix = NGLLX
+ pt2_iy = 1
+ pt2_iz = NGLLZ
+ endif
+ if (eta_source(isource) == 1 .and. &
iglob_is_surface_external_mesh(ibool(2,1,2,ispec_selected_source(isource)))) then
- pt0_ix = 1
- pt0_iy = 1
- pt0_iz = 1
- pt1_ix = NGLLX
- pt1_iy = 1
- pt1_iz = 1
- pt2_ix = 1
- pt2_iy = 1
- pt2_iz = NGLLZ
- endif
- if (eta_source(isource) == NGLLY .and. &
+ pt0_ix = 1
+ pt0_iy = 1
+ pt0_iz = 1
+ pt1_ix = NGLLX
+ pt1_iy = 1
+ pt1_iz = 1
+ pt2_ix = 1
+ pt2_iy = 1
+ pt2_iz = NGLLZ
+ endif
+ if (eta_source(isource) == NGLLY .and. &
iglob_is_surface_external_mesh(ibool(2,NGLLY,2,ispec_selected_source(isource)))) then
- pt0_ix = NGLLX
- pt0_iy = NGLLY
- pt0_iz = 1
- pt1_ix = 1
- pt1_iy = NGLLY
- pt1_iz = 1
- pt2_ix = NGLLX
- pt2_iy = NGLLY
- pt2_iz = NGLLZ
- endif
- if (gamma_source(isource) == 1 .and. &
+ pt0_ix = NGLLX
+ pt0_iy = NGLLY
+ pt0_iz = 1
+ pt1_ix = 1
+ pt1_iy = NGLLY
+ pt1_iz = 1
+ pt2_ix = NGLLX
+ pt2_iy = NGLLY
+ pt2_iz = NGLLZ
+ endif
+ if (gamma_source(isource) == 1 .and. &
iglob_is_surface_external_mesh(ibool(2,2,1,ispec_selected_source(isource)))) then
- pt0_ix = NGLLX
- pt0_iy = 1
- pt0_iz = 1
- pt1_ix = 1
- pt1_iy = 1
- pt1_iz = 1
- pt2_ix = NGLLX
- pt2_iy = NGLLY
- pt2_iz = 1
- endif
- if (gamma_source(isource) == NGLLZ .and. &
+ pt0_ix = NGLLX
+ pt0_iy = 1
+ pt0_iz = 1
+ pt1_ix = 1
+ pt1_iy = 1
+ pt1_iz = 1
+ pt2_ix = NGLLX
+ pt2_iy = NGLLY
+ pt2_iz = 1
+ endif
+ if (gamma_source(isource) == NGLLZ .and. &
iglob_is_surface_external_mesh(ibool(2,2,NGLLZ,ispec_selected_source(isource)))) then
- pt0_ix = 1
- pt0_iy = 1
- pt0_iz = NGLLZ
- pt1_ix = NGLLX
- pt1_iy = 1
- pt1_iz = NGLLZ
- pt2_ix = 1
- pt2_iy = NGLLY
- pt2_iz = NGLLZ
- endif
+ pt0_ix = 1
+ pt0_iy = 1
+ pt0_iz = NGLLZ
+ pt1_ix = NGLLX
+ pt1_iy = 1
+ pt1_iz = NGLLZ
+ pt2_ix = 1
+ pt2_iy = NGLLY
+ pt2_iz = NGLLZ
+ endif
- if (pt0_ix<0 .or.pt0_iy<0 .or. pt0_iz<0 .or. &
+ if (pt0_ix<0 .or.pt0_iy<0 .or. pt0_iz<0 .or. &
pt1_ix<0 .or. pt1_iy<0 .or. pt1_iz<0 .or. &
pt2_ix<0 .or. pt2_iy<0 .or. pt2_iz<0) then
- stop 'error in computing normal for sources.'
- endif
+ stop 'error in computing normal for sources.'
+ endif
- u_vector(1) = xstore(ibool(pt1_ix,pt1_iy,pt1_iz,ispec_selected_source(isource))) &
+ u_vector(1) = xstore(ibool(pt1_ix,pt1_iy,pt1_iz,ispec_selected_source(isource))) &
- xstore(ibool(pt0_ix,pt0_iy,pt0_iz,ispec_selected_source(isource)))
- u_vector(2) = ystore(ibool(pt1_ix,pt1_iy,pt1_iz,ispec_selected_source(isource))) &
+ u_vector(2) = ystore(ibool(pt1_ix,pt1_iy,pt1_iz,ispec_selected_source(isource))) &
- ystore(ibool(pt0_ix,pt0_iy,pt0_iz,ispec_selected_source(isource)))
- u_vector(3) = zstore(ibool(pt1_ix,pt1_iy,pt1_iz,ispec_selected_source(isource))) &
+ u_vector(3) = zstore(ibool(pt1_ix,pt1_iy,pt1_iz,ispec_selected_source(isource))) &
- zstore(ibool(pt0_ix,pt0_iy,pt0_iz,ispec_selected_source(isource)))
- v_vector(1) = xstore(ibool(pt2_ix,pt2_iy,pt2_iz,ispec_selected_source(isource))) &
+ v_vector(1) = xstore(ibool(pt2_ix,pt2_iy,pt2_iz,ispec_selected_source(isource))) &
- xstore(ibool(pt0_ix,pt0_iy,pt0_iz,ispec_selected_source(isource)))
- v_vector(2) = ystore(ibool(pt2_ix,pt2_iy,pt2_iz,ispec_selected_source(isource))) &
+ v_vector(2) = ystore(ibool(pt2_ix,pt2_iy,pt2_iz,ispec_selected_source(isource))) &
- ystore(ibool(pt0_ix,pt0_iy,pt0_iz,ispec_selected_source(isource)))
- v_vector(3) = zstore(ibool(pt2_ix,pt2_iy,pt2_iz,ispec_selected_source(isource))) &
+ v_vector(3) = zstore(ibool(pt2_ix,pt2_iy,pt2_iz,ispec_selected_source(isource))) &
- zstore(ibool(pt0_ix,pt0_iy,pt0_iz,ispec_selected_source(isource)))
! cross product
- w_vector(1) = u_vector(2)*v_vector(3) - u_vector(3)*v_vector(2)
- w_vector(2) = u_vector(3)*v_vector(1) - u_vector(1)*v_vector(3)
- w_vector(3) = u_vector(1)*v_vector(2) - u_vector(2)*v_vector(1)
+ w_vector(1) = u_vector(2)*v_vector(3) - u_vector(3)*v_vector(2)
+ w_vector(2) = u_vector(3)*v_vector(1) - u_vector(1)*v_vector(3)
+ w_vector(3) = u_vector(1)*v_vector(2) - u_vector(2)*v_vector(1)
! normalize vector w
- w_vector(:) = w_vector(:)/sqrt(w_vector(1)**2+w_vector(2)**2+w_vector(3)**2)
+ w_vector(:) = w_vector(:)/sqrt(w_vector(1)**2+w_vector(2)**2+w_vector(3)**2)
! build the two other vectors for a direct base: we normalize u, and v=w^u
- u_vector(:) = u_vector(:)/sqrt(u_vector(1)**2+u_vector(2)**2+u_vector(3)**2)
- v_vector(1) = w_vector(2)*u_vector(3) - w_vector(3)*u_vector(2)
- v_vector(2) = w_vector(3)*u_vector(1) - w_vector(1)*u_vector(3)
- v_vector(3) = w_vector(1)*u_vector(2) - w_vector(2)*u_vector(1)
+ u_vector(:) = u_vector(:)/sqrt(u_vector(1)**2+u_vector(2)**2+u_vector(3)**2)
+ v_vector(1) = w_vector(2)*u_vector(3) - w_vector(3)*u_vector(2)
+ v_vector(2) = w_vector(3)*u_vector(1) - w_vector(1)*u_vector(3)
+ v_vector(3) = w_vector(1)*u_vector(2) - w_vector(2)*u_vector(1)
! build rotation matrice nu for seismograms
! East (u)
@@ -418,110 +424,110 @@
nu_source(3,2,isource) = v_vector(3)
nu_source(3,3,isource) = w_vector(3)
- endif ! of if (.not. RECEIVERS_CAN_BE_BURIED_EXT_MESH)
+ endif ! of if (.not. RECEIVERS_CAN_BE_BURIED_EXT_MESH)
! *******************************************
! find the best (xi,eta,gamma) for the source
! *******************************************
- if(.not. USE_FORCE_POINT_SOURCE) then
+ if(.not. USE_FORCE_POINT_SOURCE) then
! use initial guess in xi, eta and gamma
- xi = xigll(ix_initial_guess_source)
- eta = yigll(iy_initial_guess_source)
- gamma = zigll(iz_initial_guess_source)
+ xi = xigll(ix_initial_guess_source)
+ eta = yigll(iy_initial_guess_source)
+ gamma = zigll(iz_initial_guess_source)
! define coordinates of the control points of the element
- do ia=1,NGNOD
+ do ia=1,NGNOD
- if(iaddx(ia) == 0) then
- iax = 1
- else if(iaddx(ia) == 1) then
- iax = (NGLLX+1)/2
- else if(iaddx(ia) == 2) then
- iax = NGLLX
- else
- call exit_MPI(myrank,'incorrect value of iaddx')
- endif
+ if(iaddx(ia) == 0) then
+ iax = 1
+ else if(iaddx(ia) == 1) then
+ iax = (NGLLX+1)/2
+ else if(iaddx(ia) == 2) then
+ iax = NGLLX
+ else
+ call exit_MPI(myrank,'incorrect value of iaddx')
+ endif
- if(iaddy(ia) == 0) then
- iay = 1
- else if(iaddy(ia) == 1) then
- iay = (NGLLY+1)/2
- else if(iaddy(ia) == 2) then
- iay = NGLLY
- else
- call exit_MPI(myrank,'incorrect value of iaddy')
- endif
+ if(iaddy(ia) == 0) then
+ iay = 1
+ else if(iaddy(ia) == 1) then
+ iay = (NGLLY+1)/2
+ else if(iaddy(ia) == 2) then
+ iay = NGLLY
+ else
+ call exit_MPI(myrank,'incorrect value of iaddy')
+ endif
- if(iaddz(ia) == 0) then
- iaz = 1
- else if(iaddz(ia) == 1) then
- iaz = (NGLLZ+1)/2
- else if(iaddz(ia) == 2) then
- iaz = NGLLZ
- else
- call exit_MPI(myrank,'incorrect value of iaddz')
- endif
+ if(iaddz(ia) == 0) then
+ iaz = 1
+ else if(iaddz(ia) == 1) then
+ iaz = (NGLLZ+1)/2
+ else if(iaddz(ia) == 2) then
+ iaz = NGLLZ
+ else
+ call exit_MPI(myrank,'incorrect value of iaddz')
+ endif
- iglob = ibool(iax,iay,iaz,ispec_selected_source(isource))
- xelm(ia) = dble(xstore(iglob))
- yelm(ia) = dble(ystore(iglob))
- zelm(ia) = dble(zstore(iglob))
+ iglob = ibool(iax,iay,iaz,ispec_selected_source(isource))
+ xelm(ia) = dble(xstore(iglob))
+ yelm(ia) = dble(ystore(iglob))
+ zelm(ia) = dble(zstore(iglob))
- enddo
+ enddo
! iterate to solve the non linear system
- do iter_loop = 1,NUM_ITER
+ do iter_loop = 1,NUM_ITER
! recompute jacobian for the new point
- call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
+ call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
! compute distance to target location
- dx = - (x - x_target_source)
- dy = - (y - y_target_source)
- dz = - (z - z_target_source)
+ dx = - (x - x_target_source)
+ dy = - (y - y_target_source)
+ dz = - (z - z_target_source)
! compute increments
- dxi = xix*dx + xiy*dy + xiz*dz
- deta = etax*dx + etay*dy + etaz*dz
- dgamma = gammax*dx + gammay*dy + gammaz*dz
+ dxi = xix*dx + xiy*dy + xiz*dz
+ deta = etax*dx + etay*dy + etaz*dz
+ dgamma = gammax*dx + gammay*dy + gammaz*dz
! update values
- xi = xi + dxi
- eta = eta + deta
- gamma = gamma + dgamma
+ xi = xi + dxi
+ eta = eta + deta
+ gamma = gamma + dgamma
! impose that we stay in that element
! (useful if user gives a source outside the mesh for instance)
- if (xi > 1.d0) xi = 1.d0
- if (xi < -1.d0) xi = -1.d0
- if (eta > 1.d0) eta = 1.d0
- if (eta < -1.d0) eta = -1.d0
- if (gamma > 1.d0) gamma = 1.d0
- if (gamma < -1.d0) gamma = -1.d0
+ if (xi > 1.d0) xi = 1.d0
+ if (xi < -1.d0) xi = -1.d0
+ if (eta > 1.d0) eta = 1.d0
+ if (eta < -1.d0) eta = -1.d0
+ if (gamma > 1.d0) gamma = 1.d0
+ if (gamma < -1.d0) gamma = -1.d0
- enddo
+ enddo
! compute final coordinates of point found
- call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
+ call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
! store xi,eta,gamma and x,y,z of point found
- xi_source(isource) = xi
- eta_source(isource) = eta
- gamma_source(isource) = gamma
- x_found_source(isource) = x
- y_found_source(isource) = y
- z_found_source(isource) = z
+ xi_source(isource) = xi
+ eta_source(isource) = eta
+ gamma_source(isource) = gamma
+ x_found_source(isource) = x
+ y_found_source(isource) = y
+ z_found_source(isource) = z
! compute final distance between asked and found (converted to km)
- final_distance_source(isource) = dsqrt((x_target_source-x_found_source(isource))**2 + &
- (y_target_source-y_found_source(isource))**2 + (z_target_source-z_found_source(isource))**2)
+ final_distance_source(isource) = dsqrt((x_target_source-x_found_source(isource))**2 + &
+ (y_target_source-y_found_source(isource))**2 + (z_target_source-z_found_source(isource))**2)
- endif ! of if (.not. USE_FORCE_POINT_SOURCE)
+ endif ! of if (.not. USE_FORCE_POINT_SOURCE)
! end of loop on all the sources
enddo
@@ -536,150 +542,195 @@
ispec_selected_source_all(:,:) = -1
- call gather_all_i(ispec_selected_source(ns:ne),ng,ispec_selected_source_all(1:ng,:),ng,NPROC)
+ ! avoids warnings about temporary creations of arrays for function call by compiler
+ allocate(tmp_i_local(ng),tmp_i_all_local(ng,0:NPROC-1))
+ !call gather_all_i(ispec_selected_source(ns:ne),ng,ispec_selected_source_all(1:ng,:),ng,NPROC)
+ tmp_i_local(:) = ispec_selected_source(ns:ne)
+ call gather_all_i(tmp_i_local,ng,tmp_i_all_local,ng,NPROC)
+ ispec_selected_source_all(1:ng,:) = tmp_i_all_local(:,:)
+ deallocate(tmp_i_local,tmp_i_all_local)
+
+ ! avoids warnings about temporary creations of arrays for function call by compiler
+ allocate(tmp_local(ng),tmp_all_local(ng,0:NPROC-1))
+
+ !call gather_all_dp(xi_source(ns:ne),ng,xi_source_all(1:ng,:),ng,NPROC)
+ tmp_local(:) = xi_source(ns:ne)
+ call gather_all_dp(tmp_local,ng,tmp_all_local,ng,NPROC)
+ xi_source_all(1:ng,:) = tmp_all_local(:,:)
+
+ !call gather_all_dp(eta_source(ns:ne),ng,eta_source_all(1:ng,:),ng,NPROC)
+ tmp_local(:) = eta_source(ns:ne)
+ call gather_all_dp(tmp_local,ng,tmp_all_local,ng,NPROC)
+ eta_source_all(1:ng,:) = tmp_all_local(:,:)
+
+ !call gather_all_dp(gamma_source(ns:ne),ng,gamma_source_all(1:ng,:),ng,NPROC)
+ tmp_local(:) = gamma_source(ns:ne)
+ call gather_all_dp(tmp_local,ng,tmp_all_local,ng,NPROC)
+ gamma_source_all(1:ng,:) = tmp_all_local(:,:)
+
+ !call gather_all_dp(final_distance_source(ns:ne),ng,final_distance_source_all(1:ng,:),ng,NPROC)
+ tmp_local(:) = final_distance_source(ns:ne)
+ call gather_all_dp(tmp_local,ng,tmp_all_local,ng,NPROC)
+ final_distance_source_all(1:ng,:) = tmp_all_local(:,:)
- call gather_all_dp(xi_source(ns:ne),ng,xi_source_all(1:ng,:),ng,NPROC)
- call gather_all_dp(eta_source(ns:ne),ng,eta_source_all(1:ng,:),ng,NPROC)
- call gather_all_dp(gamma_source(ns:ne),ng,gamma_source_all(1:ng,:),ng,NPROC)
- call gather_all_dp(final_distance_source(ns:ne),ng,final_distance_source_all(1:ng,:),ng,NPROC)
- call gather_all_dp(x_found_source(ns:ne),ng,x_found_source_all(1:ng,:),ng,NPROC)
- call gather_all_dp(y_found_source(ns:ne),ng,y_found_source_all(1:ng,:),ng,NPROC)
- call gather_all_dp(z_found_source(ns:ne),ng,z_found_source_all(1:ng,:),ng,NPROC)
- call gather_all_dp(nu_source(:,:,ns:ne),3*3*ng,nu_source_all(:,:,1:ng,:),3*3*ng,NPROC)
+ !call gather_all_dp(x_found_source(ns:ne),ng,x_found_source_all(1:ng,:),ng,NPROC)
+ tmp_local(:) = x_found_source(ns:ne)
+ call gather_all_dp(tmp_local,ng,tmp_all_local,ng,NPROC)
+ x_found_source_all(1:ng,:) = tmp_all_local(:,:)
+ !call gather_all_dp(y_found_source(ns:ne),ng,y_found_source_all(1:ng,:),ng,NPROC)
+ tmp_local(:) = y_found_source(ns:ne)
+ call gather_all_dp(tmp_local,ng,tmp_all_local,ng,NPROC)
+ y_found_source_all(1:ng,:) = tmp_all_local(:,:)
+
+ !call gather_all_dp(z_found_source(ns:ne),ng,z_found_source_all(1:ng,:),ng,NPROC)
+ tmp_local(:) = z_found_source(ns:ne)
+ call gather_all_dp(tmp_local,ng,tmp_all_local,ng,NPROC)
+ z_found_source_all(1:ng,:) = tmp_all_local(:,:)
+
+ !call gather_all_dp(nu_source(:,:,ns:ne),3*3*ng,nu_source_all(:,:,1:ng,:),3*3*ng,NPROC)
+ do i=1,3
+ do j=1,3
+ tmp_local(:) = nu_source(i,j,ns:ne)
+ call gather_all_dp(tmp_local,ng,tmp_all_local,ng,NPROC)
+ nu_source_all(i,j,1:ng,:) = tmp_all_local(:,:)
+ enddo
+ enddo
+ deallocate(tmp_local,tmp_all_local)
+
! this is executed by main process only
- if(myrank == 0) then
+ if(myrank == 0) then
! check that the gather operation went well
- if(any(ispec_selected_source_all(1:ng,:) == -1)) call exit_MPI(myrank,'gather operation failed for source')
+ if(any(ispec_selected_source_all(1:ng,:) == -1)) call exit_MPI(myrank,'gather operation failed for source')
! loop on all the sources
- do is = 1,ng
- isource = ns + is - 1
+ do is = 1,ng
+ isource = ns + is - 1
! loop on all the results to determine the best slice
- distmin = HUGEVAL
- do iprocloop = 0,NPROC-1
- if(final_distance_source_all(is,iprocloop) < distmin) then
- distmin = final_distance_source_all(is,iprocloop)
- islice_selected_source(isource) = iprocloop
- ispec_selected_source(isource) = ispec_selected_source_all(is,iprocloop)
- xi_source(isource) = xi_source_all(is,iprocloop)
- eta_source(isource) = eta_source_all(is,iprocloop)
- gamma_source(isource) = gamma_source_all(is,iprocloop)
- x_found_source(isource) = x_found_source_all(is,iprocloop)
- y_found_source(isource) = y_found_source_all(is,iprocloop)
- z_found_source(isource) = z_found_source_all(is,iprocloop)
- nu_source(:,:,isource) = nu_source_all(:,:,isource,iprocloop)
- endif
- enddo
- final_distance_source(isource) = distmin
+ distmin = HUGEVAL
+ do iprocloop = 0,NPROC-1
+ if(final_distance_source_all(is,iprocloop) < distmin) then
+ distmin = final_distance_source_all(is,iprocloop)
+ islice_selected_source(isource) = iprocloop
+ ispec_selected_source(isource) = ispec_selected_source_all(is,iprocloop)
+ xi_source(isource) = xi_source_all(is,iprocloop)
+ eta_source(isource) = eta_source_all(is,iprocloop)
+ gamma_source(isource) = gamma_source_all(is,iprocloop)
+ x_found_source(isource) = x_found_source_all(is,iprocloop)
+ y_found_source(isource) = y_found_source_all(is,iprocloop)
+ z_found_source(isource) = z_found_source_all(is,iprocloop)
+ nu_source(:,:,isource) = nu_source_all(:,:,isource,iprocloop)
+ endif
+ enddo
+ final_distance_source(isource) = distmin
+ enddo
+ endif !myrank
enddo
- endif
- enddo
if (myrank == 0) then
- do isource = 1,NSOURCES
+ do isource = 1,NSOURCES
- if(SHOW_DETAILS_LOCATE_SOURCE .or. NSOURCES == 1) then
+ if(SHOW_DETAILS_LOCATE_SOURCE .or. NSOURCES == 1) then
- write(IMAIN,*)
- write(IMAIN,*) '*************************************'
- write(IMAIN,*) ' locating source ',isource
- write(IMAIN,*) '*************************************'
- write(IMAIN,*)
- write(IMAIN,*) 'source located in slice ',islice_selected_source(isource)
- write(IMAIN,*) ' in element ',ispec_selected_source(isource)
- write(IMAIN,*)
- if(USE_FORCE_POINT_SOURCE) then
- write(IMAIN,*) ' xi coordinate of source in that element: ',nint(xi_source(isource))
- write(IMAIN,*) ' eta coordinate of source in that element: ',nint(eta_source(isource))
- write(IMAIN,*) 'gamma coordinate of source in that element: ',nint(gamma_source(isource))
- write(IMAIN,*) 'nu1 = ',nu_source(1,:,isource)
- write(IMAIN,*) 'nu2 = ',nu_source(2,:,isource)
- write(IMAIN,*) 'nu3 = ',nu_source(3,:,isource)
- write(IMAIN,*) 'at (x,y,z) coordinates = ',x_found_source(isource),y_found_source(isource),z_found_source(isource)
- else
- write(IMAIN,*) ' xi coordinate of source in that element: ',xi_source(isource)
- write(IMAIN,*) ' eta coordinate of source in that element: ',eta_source(isource)
- write(IMAIN,*) 'gamma coordinate of source in that element: ',gamma_source(isource)
- endif
+ write(IMAIN,*)
+ write(IMAIN,*) '*************************************'
+ write(IMAIN,*) ' locating source ',isource
+ write(IMAIN,*) '*************************************'
+ write(IMAIN,*)
+ write(IMAIN,*) 'source located in slice ',islice_selected_source(isource)
+ write(IMAIN,*) ' in element ',ispec_selected_source(isource)
+ write(IMAIN,*)
+ if(USE_FORCE_POINT_SOURCE) then
+ write(IMAIN,*) ' xi coordinate of source in that element: ',nint(xi_source(isource))
+ write(IMAIN,*) ' eta coordinate of source in that element: ',nint(eta_source(isource))
+ write(IMAIN,*) 'gamma coordinate of source in that element: ',nint(gamma_source(isource))
+ write(IMAIN,*) 'nu1 = ',nu_source(1,:,isource)
+ write(IMAIN,*) 'nu2 = ',nu_source(2,:,isource)
+ write(IMAIN,*) 'nu3 = ',nu_source(3,:,isource)
+ write(IMAIN,*) 'at (x,y,z) coordinates = ',x_found_source(isource),y_found_source(isource),z_found_source(isource)
+ else
+ write(IMAIN,*) ' xi coordinate of source in that element: ',xi_source(isource)
+ write(IMAIN,*) ' eta coordinate of source in that element: ',eta_source(isource)
+ write(IMAIN,*) 'gamma coordinate of source in that element: ',gamma_source(isource)
+ endif
! add message if source is a Heaviside
- if(hdur(isource) < 5.*DT) then
- write(IMAIN,*)
- write(IMAIN,*) 'Source time function is a Heaviside, convolve later'
- write(IMAIN,*)
- endif
+ if(hdur(isource) < 5.*DT) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Source time function is a Heaviside, convolve later'
+ write(IMAIN,*)
+ endif
- write(IMAIN,*)
- write(IMAIN,*) ' half duration: ',hdur(isource),' seconds'
- write(IMAIN,*) ' time shift: ',t_cmt(isource),' seconds'
+ write(IMAIN,*)
+ write(IMAIN,*) ' half duration: ',hdur(isource),' seconds'
+ write(IMAIN,*) ' time shift: ',t_cmt(isource),' seconds'
- write(IMAIN,*)
- write(IMAIN,*) 'original (requested) position of the source:'
- write(IMAIN,*)
- write(IMAIN,*) ' latitude: ',lat(isource)
- write(IMAIN,*) ' longitude: ',long(isource)
- write(IMAIN,*)
- write(IMAIN,*) ' UTM x: ',utm_x_source(isource)
- write(IMAIN,*) ' UTM y: ',utm_y_source(isource)
- write(IMAIN,*) ' depth: ',depth(isource),' km'
- if(TOPOGRAPHY) write(IMAIN,*) 'topo elevation: ',elevation(isource),' m'
+ write(IMAIN,*)
+ write(IMAIN,*) 'original (requested) position of the source:'
+ write(IMAIN,*)
+ write(IMAIN,*) ' latitude: ',lat(isource)
+ write(IMAIN,*) ' longitude: ',long(isource)
+ write(IMAIN,*)
+ write(IMAIN,*) ' UTM x: ',utm_x_source(isource)
+ write(IMAIN,*) ' UTM y: ',utm_y_source(isource)
+ write(IMAIN,*) ' depth: ',depth(isource),' km'
+ if(TOPOGRAPHY) write(IMAIN,*) 'topo elevation: ',elevation(isource),' m'
- write(IMAIN,*)
- write(IMAIN,*) 'position of the source that will be used:'
- write(IMAIN,*)
- write(IMAIN,*) ' UTM x: ',x_found_source(isource)
- write(IMAIN,*) ' UTM y: ',y_found_source(isource)
- write(IMAIN,*) ' depth: ',dabs(z_found_source(isource) - elevation(isource))/1000.,' km'
- write(IMAIN,*)
+ write(IMAIN,*)
+ write(IMAIN,*) 'position of the source that will be used:'
+ write(IMAIN,*)
+ write(IMAIN,*) ' UTM x: ',x_found_source(isource)
+ write(IMAIN,*) ' UTM y: ',y_found_source(isource)
+ write(IMAIN,*) ' depth: ',dabs(z_found_source(isource) - elevation(isource))/1000.,' km'
+ write(IMAIN,*)
! display error in location estimate
- write(IMAIN,*) 'error in location of the source: ',sngl(final_distance_source(isource)),' m'
+ write(IMAIN,*) 'error in location of the source: ',sngl(final_distance_source(isource)),' m'
! add warning if estimate is poor
! (usually means source outside the mesh given by the user)
- if(final_distance_source(isource) > 3000.d0) then
- write(IMAIN,*)
- write(IMAIN,*) '*****************************************************'
- write(IMAIN,*) '*****************************************************'
- write(IMAIN,*) '***** WARNING: source location estimate is poor *****'
- write(IMAIN,*) '*****************************************************'
- write(IMAIN,*) '*****************************************************'
- endif
+ if(final_distance_source(isource) > 3000.d0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '*****************************************************'
+ write(IMAIN,*) '*****************************************************'
+ write(IMAIN,*) '***** WARNING: source location estimate is poor *****'
+ write(IMAIN,*) '*****************************************************'
+ write(IMAIN,*) '*****************************************************'
+ endif
- endif ! end of detailed output to locate source
+ endif ! end of detailed output to locate source
- if(PRINT_SOURCE_TIME_FUNCTION) then
+ if(PRINT_SOURCE_TIME_FUNCTION) then
- write(IMAIN,*)
- write(IMAIN,*) 'printing the source-time function'
+ write(IMAIN,*)
+ write(IMAIN,*) 'printing the source-time function'
! print the source-time function
- if(NSOURCES == 1) then
- plot_file = '/plot_source_time_function.txt'
- else
- if(isource < 10) then
- write(plot_file,"('/plot_source_time_function',i1,'.txt')") isource
- else
- write(plot_file,"('/plot_source_time_function',i2,'.txt')") isource
- endif
- endif
- open(unit=27,file=trim(OUTPUT_FILES)//plot_file,status='unknown')
+ if(NSOURCES == 1) then
+ plot_file = '/plot_source_time_function.txt'
+ else
+ if(isource < 10) then
+ write(plot_file,"('/plot_source_time_function',i1,'.txt')") isource
+ else
+ write(plot_file,"('/plot_source_time_function',i2,'.txt')") isource
+ endif
+ endif
+ open(unit=27,file=trim(OUTPUT_FILES)//plot_file,status='unknown')
- do it=1,NSTEP
- time_source = dble(it-1)*DT
- write(27,*) sngl(time_source-t0),sngl(comp_source_time_function(time_source-t0-t_cmt(isource),hdur_gaussian(isource)))
- enddo
- close(27)
+ do it=1,NSTEP
+ time_source = dble(it-1)*DT
+ write(27,*) sngl(time_source-t0),sngl(comp_source_time_function(time_source-t0-t_cmt(isource),hdur_gaussian(isource)))
+ enddo
+ close(27)
- endif
+ endif
! end of loop on all the sources
- enddo
+ enddo
! display maximum error in location estimate
write(IMAIN,*)
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/memory_eval.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/memory_eval.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/memory_eval.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -87,5 +87,53 @@
end subroutine memory_eval
+!
+!-------------------------------------------------------------------------------------------------
+!
+! compute the approximate amount of static memory needed to run the mesher
+ subroutine memory_eval_mesher(myrank,nspec,npointot,nnodes_ext_mesh,nelmnts_ext_mesh,nmat_ext_mesh,ninterface_ext_mesh, &
+ max_interface_size_ext_mesh,nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,nspec2D_bottom,nspec2D_top,&
+ static_memory_size_request)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: myrank,nspec,npointot,nnodes_ext_mesh,nelmnts_ext_mesh,nmat_ext_mesh,ninterface_ext_mesh, &
+ max_interface_size_ext_mesh,nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,nspec2D_bottom,nspec2D_top
+
+ integer :: static_memory_size_request
+
+ integer :: static_memory_size
+
+! memory usage, in generate_database() routine so far
+ static_memory_size = NGLLX*NGLLY*NGLLZ*nspec*4 + 3*NGLLX*NGLLY*NGLLZ*nspec*8 &
+ + NDIM*nnodes_ext_mesh*8 + ESIZE*nelmnts_ext_mesh*4 + 2*nelmnts_ext_mesh*4 &
+ + 5*nmat_ext_mesh*8 + 3*ninterface_ext_mesh + 6*max_interface_size_ext_mesh*ninterface_ext_mesh*4 &
+ + NGLLX*NGLLX*max_interface_size_ext_mesh*ninterface_ext_mesh*4 &
+ + nspec2D_xmin*20 + nspec2D_xmax*20 + nspec2D_ymin*20 + nspec2D_ymax*20 + nspec2D_bottom*20 + nspec2D_top*20
+
+! memory usage, in create_regions_mesh_ext_mesh() routine requested approximately
+ static_memory_size_request = &
+ + 3*NGNOD*8 + NGLLX*NGLLY*NGLLZ*nspec*4 + 6*nspec*1 + 6*NGLLX*8 &
+ + NGNOD*NGLLX*NGLLY*NGLLZ*8 + NDIM*NGNOD*NGLLX*NGLLY*NGLLZ*8 &
+ + 4*NGNOD2D*NGLLY*NGLLZ*8 + 4*NDIM2D*NGNOD2D*NGLLX*NGLLY*8 &
+ + 17*NGLLX*NGLLY*NGLLY*nspec*CUSTOM_REAL &
+ + (1+NDIM)*NGLLY*NGLLZ*nspec2D_xmin*CUSTOM_REAL + (1+NDIM)*NGLLY*NGLLZ*nspec2D_xmax*CUSTOM_REAL &
+ + (1+NDIM)*NGLLX*NGLLZ*nspec2D_ymin*CUSTOM_REAL + (1+NDIM)*NGLLX*NGLLZ*nspec2D_ymax*CUSTOM_REAL &
+ + (1+NDIM)*NGLLX*NGLLY*NSPEC2D_BOTTOM*CUSTOM_REAL + (1+NDIM)*NGLLX*NGLLY*NSPEC2D_TOP*CUSTOM_REAL &
+ + 2*npointot*4 + npointot + 3*npointot*8
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' minimum memory used so far : ',static_memory_size / 1024. / 1024.,&
+ 'MB per process'
+ write(IMAIN,*) ' minimum total memory requested : ',(static_memory_size+static_memory_size_request)/1024./1024.,&
+ 'MB per process'
+ write(IMAIN,*)
+ endif
+
+
+ end subroutine memory_eval_mesher
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/parallel.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/parallel.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/parallel.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -584,7 +584,6 @@
integer recvcount, dest, recvtag, req
integer, dimension(recvcount) :: recvbuf
-
integer ier
call MPI_IRECV(recvbuf(1),recvcount,MPI_INTEGER,dest,recvtag, &
@@ -592,10 +591,95 @@
end subroutine irecv_i
+
!
!----
!
+ subroutine recv_i(recvbuf, recvcount, dest, recvtag )
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer recvbuf,recvcount,dest,recvtag
+ integer req(MPI_STATUS_SIZE)
+ integer ier
+
+ call MPI_RECV(recvbuf,recvcount,MPI_INTEGER,dest,recvtag,MPI_COMM_WORLD,req,ier)
+
+ end subroutine recv_i
+
+!
+!----
+!
+
+ subroutine recvv_cr(recvbuf, recvcount, dest, recvtag )
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer recvcount,dest,recvtag
+ real(kind=CUSTOM_REAL),dimension(recvcount) :: recvbuf
+ integer req(MPI_STATUS_SIZE)
+ integer ier
+
+ call MPI_RECV(recvbuf,recvcount,CUSTOM_MPI_TYPE,dest,recvtag,MPI_COMM_WORLD,req,ier)
+
+
+ end subroutine recvv_cr
+
+
+!
+!----
+!
+
+ subroutine send_i(sendbuf, sendcount, dest, sendtag)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer sendbuf,sendcount,dest,sendtag
+ integer ier
+
+ call MPI_SEND(sendbuf,sendcount,MPI_INTEGER,dest,sendtag,MPI_COMM_WORLD,ier)
+
+ end subroutine send_i
+
+
+!
+!----
+!
+
+ subroutine sendv_cr(sendbuf, sendcount, dest, sendtag)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer sendcount,dest,sendtag
+ real(kind=CUSTOM_REAL),dimension(sendcount) :: sendbuf
+ integer ier
+
+ call MPI_SEND(sendbuf,sendcount,CUSTOM_MPI_TYPE,dest,sendtag,MPI_COMM_WORLD,ier)
+
+ end subroutine sendv_cr
+!
+!----
+!
+
subroutine wait_req(req)
implicit none
Added: seismo/3D/SPECFEM3D_SESAME/trunk/prepare_assemble_MPI.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/prepare_assemble_MPI.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/prepare_assemble_MPI.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -0,0 +1,529 @@
+!=====================================================================
+!
+! S p e c f e m 3 D V e r s i o n 1 . 4
+! ---------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2006
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+
+ subroutine prepare_assemble_MPI (nelmnts,ibool, &
+ knods, ngnode, &
+ npoin, &
+ ninterface, max_interface_size, &
+ my_nelmnts_neighbours, my_interfaces, &
+ ibool_interfaces_asteroid, &
+ nibool_interfaces_asteroid &
+ )
+
+! returns ibool_interfaces_asteroid with the global indices (as defined in ibool) &
+! returns nibool_interfaces_asteroid with the number of points in ibool_interfaces_asteroid
+! for all points on the (surface) interface defined by knods, ninterface,my_nelmnts_neighbours and my_interfaces
+
+ implicit none
+
+ include 'constants.h'
+
+ integer, intent(in) :: nelmnts, npoin, ngnode
+ integer, dimension(ngnode,nelmnts), intent(in) :: knods
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nelmnts), intent(in) :: ibool
+
+ integer :: ninterface
+ integer :: max_interface_size
+ integer, dimension(ninterface) :: my_nelmnts_neighbours
+ integer, dimension(6,max_interface_size,ninterface) :: my_interfaces
+ integer, dimension(NGLLX*NGLLX*max_interface_size,ninterface) :: &
+ ibool_interfaces_asteroid
+ integer, dimension(ninterface) :: &
+ nibool_interfaces_asteroid
+
+ integer :: num_interface
+ integer :: ispec_interface
+
+ logical, dimension(:),allocatable :: mask_ibool_asteroid
+
+ integer :: ixmin, ixmax
+ integer :: iymin, iymax
+ integer :: izmin, izmax
+ integer, dimension(ngnode) :: n
+ integer :: e1, e2, e3, e4
+ integer :: type
+ integer :: ispec
+
+ integer :: k
+ integer :: npoin_interface_asteroid
+
+ integer :: ix,iy,iz,ier
+
+ allocate( mask_ibool_asteroid(npoin), stat=ier); if( ier /= 0) stop 'error allocating array'
+
+ ibool_interfaces_asteroid(:,:) = 0
+ nibool_interfaces_asteroid(:) = 0
+
+ do num_interface = 1, ninterface
+ npoin_interface_asteroid = 0
+ mask_ibool_asteroid(:) = .false.
+
+ do ispec_interface = 1, my_nelmnts_neighbours(num_interface)
+ ! element with an interface
+ ispec = my_interfaces(1,ispec_interface,num_interface)
+ ! type of interface
+ type = my_interfaces(2,ispec_interface,num_interface)
+ ! nodes of face/edge
+ do k = 1, ngnode
+ n(k) = knods(k,ispec)
+ end do
+ e1 = my_interfaces(3,ispec_interface,num_interface)
+ e2 = my_interfaces(4,ispec_interface,num_interface)
+ e3 = my_interfaces(5,ispec_interface,num_interface)
+ e4 = my_interfaces(6,ispec_interface,num_interface)
+ call get_edge(ngnode, n, type, e1, e2, e3, e4, ixmin, ixmax, iymin, iymax, izmin, izmax)
+
+ do iz = min(izmin,izmax), max(izmin,izmax)
+ do iy = min(iymin,iymax), max(iymin,iymax)
+ do ix = min(ixmin,ixmax), max(ixmin,ixmax)
+
+ if(.not. mask_ibool_asteroid(ibool(ix,iy,iz,ispec))) then
+ mask_ibool_asteroid(ibool(ix,iy,iz,ispec)) = .true.
+ npoin_interface_asteroid = npoin_interface_asteroid + 1
+ ibool_interfaces_asteroid(npoin_interface_asteroid,num_interface)=&
+ ibool(ix,iy,iz,ispec)
+ end if
+ end do
+ end do
+ end do
+
+ end do
+ nibool_interfaces_asteroid(num_interface) = npoin_interface_asteroid
+
+
+ end do
+
+ deallocate( mask_ibool_asteroid )
+
+end subroutine prepare_assemble_MPI
+
+!
+!----
+!
+
+subroutine get_edge ( ngnode, n, type, e1, e2, e3, e4, ixmin, ixmax, iymin, iymax, izmin, izmax )
+
+ implicit none
+
+ include "constants.h"
+
+ integer, intent(in) :: ngnode
+ integer, dimension(ngnode), intent(in) :: n
+ integer, intent(in) :: type, e1, e2, e3, e4
+ integer, intent(out) :: ixmin, ixmax, iymin, iymax, izmin, izmax
+
+ integer, dimension(4) :: en
+ integer :: valence, i
+
+ if ( type == 1 ) then
+ if ( e1 == n(1) ) then
+ ixmin = 1
+ ixmax = 1
+ iymin = 1
+ iymax = 1
+ izmin = 1
+ izmax = 1
+ end if
+ if ( e1 == n(2) ) then
+ ixmin = NGLLX
+ ixmax = NGLLX
+ iymin = 1
+ iymax = 1
+ izmin = 1
+ izmax = 1
+ end if
+ if ( e1 == n(3) ) then
+ ixmin = NGLLX
+ ixmax = NGLLX
+ iymin = NGLLY
+ iymax = NGLLY
+ izmin = 1
+ izmax = 1
+ end if
+ if ( e1 == n(4) ) then
+ ixmin = 1
+ ixmax = 1
+ iymin = NGLLY
+ iymax = NGLLY
+ izmin = 1
+ izmax = 1
+ end if
+ if ( e1 == n(5) ) then
+ ixmin = 1
+ ixmax = 1
+ iymin = 1
+ iymax = 1
+ izmin = NGLLZ
+ izmax = NGLLZ
+ end if
+ if ( e1 == n(6) ) then
+ ixmin = NGLLX
+ ixmax = NGLLX
+ iymin = 1
+ iymax = 1
+ izmin = NGLLZ
+ izmax = NGLLZ
+ end if
+ if ( e1 == n(7) ) then
+ ixmin = NGLLX
+ ixmax = NGLLX
+ iymin = NGLLY
+ iymax = NGLLY
+ izmin = NGLLZ
+ izmax = NGLLZ
+ end if
+ if ( e1 == n(8) ) then
+ ixmin = 1
+ ixmax = 1
+ iymin = NGLLY
+ iymax = NGLLY
+ izmin = NGLLZ
+ izmax = NGLLZ
+ end if
+ else
+ if ( type == 2 ) then
+ if ( e1 == n(1) ) then
+ ixmin = 1
+ iymin = 1
+ izmin = 1
+ if ( e2 == n(2) ) then
+ ixmax = NGLLX
+ iymax = 1
+ izmax = 1
+ end if
+ if ( e2 == n(4) ) then
+ ixmax = 1
+ iymax = NGLLY
+ izmax = 1
+ end if
+ if ( e2 == n(5) ) then
+ ixmax = 1
+ iymax = 1
+ izmax = NGLLZ
+ end if
+ end if
+ if ( e1 == n(2) ) then
+ ixmin = NGLLX
+ iymin = 1
+ izmin = 1
+ if ( e2 == n(3) ) then
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = 1
+ end if
+ if ( e2 == n(1) ) then
+ ixmax = 1
+ iymax = 1
+ izmax = 1
+ end if
+ if ( e2 == n(6) ) then
+ ixmax = NGLLX
+ iymax = 1
+ izmax = NGLLZ
+ end if
+
+ end if
+ if ( e1 == n(3) ) then
+ ixmin = NGLLX
+ iymin = NGLLY
+ izmin = 1
+ if ( e2 == n(4) ) then
+ ixmax = 1
+ iymax = NGLLY
+ izmax = 1
+ end if
+ if ( e2 == n(2) ) then
+ ixmax = NGLLX
+ iymax = 1
+ izmax = 1
+ end if
+ if ( e2 == n(7) ) then
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = NGLLZ
+ end if
+ end if
+ if ( e1 == n(4) ) then
+ ixmin = 1
+ iymin = NGLLY
+ izmin = 1
+ if ( e2 == n(1) ) then
+ ixmax = 1
+ iymax = 1
+ izmax = 1
+ end if
+ if ( e2 == n(3) ) then
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = 1
+ end if
+ if ( e2 == n(8) ) then
+ ixmax = 1
+ iymax = NGLLY
+ izmax = NGLLZ
+ end if
+ end if
+ if ( e1 == n(5) ) then
+ ixmin = 1
+ iymin = 1
+ izmin = NGLLZ
+ if ( e2 == n(1) ) then
+ ixmax = 1
+ iymax = 1
+ izmax = 1
+ end if
+ if ( e2 == n(6) ) then
+ ixmax = NGLLX
+ iymax = 1
+ izmax = NGLLZ
+ end if
+ if ( e2 == n(8) ) then
+ ixmax = 1
+ iymax = NGLLY
+ izmax = NGLLZ
+ end if
+ end if
+ if ( e1 == n(6) ) then
+ ixmin = NGLLX
+ iymin = 1
+ izmin = NGLLZ
+ if ( e2 == n(2) ) then
+ ixmax = NGLLX
+ iymax = 1
+ izmax = 1
+ end if
+ if ( e2 == n(7) ) then
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = NGLLZ
+ end if
+ if ( e2 == n(5) ) then
+ ixmax = 1
+ iymax = 1
+ izmax = NGLLZ
+ end if
+ end if
+ if ( e1 == n(7) ) then
+ ixmin = NGLLX
+ iymin = NGLLY
+ izmin = NGLLZ
+ if ( e2 == n(3) ) then
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = 1
+ end if
+ if ( e2 == n(8) ) then
+ ixmax = 1
+ iymax = NGLLY
+ izmax = NGLLZ
+ end if
+ if ( e2 == n(6) ) then
+ ixmax = NGLLX
+ iymax = 1
+ izmax = NGLLZ
+ end if
+ end if
+ if ( e1 == n(8) ) then
+ ixmin = 1
+ iymin = NGLLY
+ izmin = NGLLZ
+ if ( e2 == n(4) ) then
+ ixmax = 1
+ iymax = NGLLY
+ izmax = 1
+ end if
+ if ( e2 == n(5) ) then
+ ixmax = 1
+ iymax = 1
+ izmax = NGLLZ
+ end if
+ if ( e2 == n(7) ) then
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = NGLLZ
+ end if
+ end if
+
+ else
+ if (type == 4) then
+ en(1) = e1
+ en(2) = e2
+ en(3) = e3
+ en(4) = e4
+
+ valence = 0
+ do i = 1, 4
+ if ( en(i) == n(1)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(2)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(3)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(4)) then
+ valence = valence+1
+ endif
+ enddo
+ if ( valence == 4 ) then
+ ixmin = 1
+ iymin = 1
+ izmin = 1
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = 1
+ endif
+
+ valence = 0
+ do i = 1, 4
+ if ( en(i) == n(1)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(2)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(5)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(6)) then
+ valence = valence+1
+ endif
+ enddo
+ if ( valence == 4 ) then
+ ixmin = 1
+ iymin = 1
+ izmin = 1
+ ixmax = NGLLX
+ iymax = 1
+ izmax = NGLLZ
+ endif
+
+ valence = 0
+ do i = 1, 4
+ if ( en(i) == n(2)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(3)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(6)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(7)) then
+ valence = valence+1
+ endif
+ enddo
+ if ( valence == 4 ) then
+ ixmin = NGLLX
+ iymin = 1
+ izmin = 1
+ ixmax = NGLLX
+ iymax = NGLLZ
+ izmax = NGLLZ
+ endif
+
+ valence = 0
+ do i = 1, 4
+ if ( en(i) == n(3)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(4)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(7)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(8)) then
+ valence = valence+1
+ endif
+ enddo
+ if ( valence == 4 ) then
+ ixmin = 1
+ iymin = NGLLY
+ izmin = 1
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = NGLLZ
+ endif
+
+ valence = 0
+ do i = 1, 4
+ if ( en(i) == n(1)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(4)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(5)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(8)) then
+ valence = valence+1
+ endif
+ enddo
+ if ( valence == 4 ) then
+ ixmin = 1
+ iymin = 1
+ izmin = 1
+ ixmax = 1
+ iymax = NGLLY
+ izmax = NGLLZ
+ endif
+
+ valence = 0
+ do i = 1, 4
+ if ( en(i) == n(5)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(6)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(7)) then
+ valence = valence+1
+ endif
+ if ( en(i) == n(8)) then
+ valence = valence+1
+ endif
+ enddo
+ if ( valence == 4 ) then
+ ixmin = 1
+ iymin = 1
+ izmin = NGLLZ
+ ixmax = NGLLX
+ iymax = NGLLY
+ izmax = NGLLZ
+ endif
+
+ else
+ stop 'ERROR get_edge'
+ endif
+
+ end if
+ end if
+
+end subroutine get_edge
+
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -32,7 +32,6 @@
! start reading the databasesa
! info about external mesh simulation
-! nlegoff -- should be put in read_arrays_solver and read_arrays_buffer_solver for clarity
call create_name_database(prname,myrank,LOCAL_PATH)
open(unit=27,file=prname(1:len_trim(prname))//'external_mesh.bin',status='old',action='read',form='unformatted')
read(27) NSPEC_AB
@@ -65,16 +64,16 @@
endif
endif
- read(27) NSPEC2DMAX_XMIN_XMAX_ext
- read(27) NSPEC2DMAX_YMIN_YMAX_ext
- allocate(nimin(2,NSPEC2DMAX_YMIN_YMAX_ext),nimax(2,NSPEC2DMAX_YMIN_YMAX_ext),nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX_ext))
- allocate(njmin(2,NSPEC2DMAX_XMIN_XMAX_ext),njmax(2,NSPEC2DMAX_XMIN_XMAX_ext),nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX_ext))
- read(27) nimin
- read(27) nimax
- read(27) njmin
- read(27) njmax
- read(27) nkmin_xi
- read(27) nkmin_eta
+! read(27) NSPEC2DMAX_XMIN_XMAX_ext
+! read(27) NSPEC2DMAX_YMIN_YMAX_ext
+! allocate(nimin(2,NSPEC2DMAX_YMIN_YMAX_ext),nimax(2,NSPEC2DMAX_YMIN_YMAX_ext),nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX_ext))
+! allocate(njmin(2,NSPEC2DMAX_XMIN_XMAX_ext),njmax(2,NSPEC2DMAX_XMIN_XMAX_ext),nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX_ext))
+! read(27) nimin
+! read(27) nimax
+! read(27) njmin
+! read(27) njmax
+! read(27) nkmin_xi
+! read(27) nkmin_eta
!end pll
read(27) kappastore
@@ -85,51 +84,89 @@
read(27) ystore
read(27) zstore
+! absorbing boundaries
!pll
- read(27) nspec2D_xmin
- read(27) nspec2D_xmax
- read(27) nspec2D_ymin
- read(27) nspec2D_ymax
- read(27) NSPEC2D_BOTTOM
+! read(27) nspec2D_xmin
+! read(27) nspec2D_xmax
+! read(27) nspec2D_ymin
+! read(27) nspec2D_ymax
+! read(27) NSPEC2D_BOTTOM
+! read(27) NSPEC2D_TOP
+! allocate(ibelm_xmin(nspec2D_xmin))
+! allocate(ibelm_xmax(nspec2D_xmax))
+! allocate(ibelm_ymin(nspec2D_ymin))
+! allocate(ibelm_ymax(nspec2D_ymax))
+! allocate(ibelm_bottom(NSPEC2D_BOTTOM))
+! allocate(ibelm_top(NSPEC2D_TOP))
+!
+! allocate(ibelm_gll_xmin(3,NGLLY,NGLLZ,nspec2D_xmin))
+! allocate(ibelm_gll_xmax(3,NGLLY,NGLLZ,nspec2D_xmax))
+! allocate(ibelm_gll_ymin(3,NGLLX,NGLLZ,nspec2D_ymin))
+! allocate(ibelm_gll_ymax(3,NGLLX,NGLLZ,nspec2D_ymax))
+! allocate(ibelm_gll_bottom(3,NGLLY,NGLLY,nspec2D_bottom))
+! allocate(ibelm_gll_top(3,NGLLY,NGLLY,nspec2D_top))
+!
+! allocate(jacobian2D_xmin(NGLLY,NGLLZ,nspec2D_xmin))
+! allocate(jacobian2D_xmax(NGLLY,NGLLZ,nspec2D_xmax))
+! allocate(jacobian2D_ymin(NGLLX,NGLLZ,nspec2D_ymin))
+! allocate(jacobian2D_ymax(NGLLX,NGLLZ,nspec2D_ymax))
+! allocate(jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM))
+! allocate(jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP))
+!
+! allocate(normal_xmin(NDIM,NGLLY,NGLLZ,nspec2D_xmin))
+! allocate(normal_xmax(NDIM,NGLLY,NGLLZ,nspec2D_xmax))
+! allocate(normal_ymin(NDIM,NGLLX,NGLLZ,nspec2D_ymin))
+! allocate(normal_ymax(NDIM,NGLLX,NGLLZ,nspec2D_ymax))
+! allocate(normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM))
+! allocate(normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP))
+! read(27) ibelm_xmin
+! read(27) ibelm_xmax
+! read(27) ibelm_ymin
+! read(27) ibelm_ymax
+! read(27) ibelm_bottom
+! read(27) ibelm_top
+!
+! read(27) ibelm_gll_xmin
+! read(27) ibelm_gll_xmax
+! read(27) ibelm_gll_ymin
+! read(27) ibelm_gll_ymax
+! read(27) ibelm_gll_bottom
+! read(27) ibelm_gll_top
+!
+! read(27) normal_xmin
+! read(27) normal_xmax
+! read(27) normal_ymin
+! read(27) normal_ymax
+! read(27) normal_bottom
+! read(27) normal_top
+! read(27) jacobian2D_xmin
+! read(27) jacobian2D_xmax
+! read(27) jacobian2D_ymin
+! read(27) jacobian2D_ymax
+! read(27) jacobian2D_bottom
+! read(27) jacobian2D_top
+! !end pll
+
+ read(27) num_absorbing_boundary_faces
+ allocate(absorbing_boundary_ispec(num_absorbing_boundary_faces))
+ allocate(absorbing_boundary_ijk(3,NGLLSQUARE,num_absorbing_boundary_faces))
+ allocate(absorbing_boundary_jacobian2D(NGLLSQUARE,num_absorbing_boundary_faces))
+ allocate(absorbing_boundary_normal(NDIM,NGLLSQUARE,num_absorbing_boundary_faces))
+ read(27) absorbing_boundary_ispec
+ read(27) absorbing_boundary_ijk
+ read(27) absorbing_boundary_jacobian2D
+ read(27) absorbing_boundary_normal
+
+! free surface
read(27) NSPEC2D_TOP
- allocate(ibelm_xmin(nspec2D_xmin))
- allocate(ibelm_xmax(nspec2D_xmax))
- allocate(ibelm_ymin(nspec2D_ymin))
- allocate(ibelm_ymax(nspec2D_ymax))
- allocate(ibelm_bottom(NSPEC2D_BOTTOM))
allocate(ibelm_top(NSPEC2D_TOP))
- allocate(jacobian2D_xmin(NGLLY,NGLLZ,nspec2D_xmin))
- allocate(jacobian2D_xmax(NGLLY,NGLLZ,nspec2D_xmax))
- allocate(jacobian2D_ymin(NGLLX,NGLLZ,nspec2D_ymin))
- allocate(jacobian2D_ymax(NGLLX,NGLLZ,nspec2D_ymax))
- allocate(jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM))
allocate(jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP))
- allocate(normal_xmin(NDIM,NGLLY,NGLLZ,nspec2D_xmin))
- allocate(normal_xmax(NDIM,NGLLY,NGLLZ,nspec2D_xmax))
- allocate(normal_ymin(NDIM,NGLLX,NGLLZ,nspec2D_ymin))
- allocate(normal_ymax(NDIM,NGLLX,NGLLZ,nspec2D_ymax))
- allocate(normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM))
allocate(normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP))
- read(27) ibelm_xmin
- read(27) ibelm_xmax
- read(27) ibelm_ymin
- read(27) ibelm_ymax
- read(27) ibelm_bottom
read(27) ibelm_top
- read(27) normal_xmin
- read(27) normal_xmax
- read(27) normal_ymin
- read(27) normal_ymax
- read(27) normal_bottom
+ read(27) jacobian2D_top
read(27) normal_top
- read(27) jacobian2D_xmin
- read(27) jacobian2D_xmax
- read(27) jacobian2D_ymin
- read(27) jacobian2D_ymax
- read(27) jacobian2D_bottom
- read(27) jacobian2D_top
- !end pll
-
+
+! MPI interfaces
read(27) ninterfaces_ext_mesh
read(27) max_nibool_interfaces_ext_mesh
allocate(my_neighbours_ext_mesh(ninterfaces_ext_mesh))
@@ -171,7 +208,6 @@
enddo
enddo
-!daniel
! counts inner and outer elements
! nspec_inner = 0
! nspec_outer = 0
@@ -183,7 +219,7 @@
! endif
! enddo
-! stores indices of inner and outer elements for faster compute_forces_with_Deville routine
+! stores indices of inner and outer elements for faster(?) compute_forces_with_Deville routine
! if( nspec_inner > 0 ) allocate( spec_inner(nspec_inner))
! if( nspec_outer > 0 ) allocate( spec_outer(nspec_outer))
! nspec_inner = 0
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/save_arrays_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/save_arrays_solver.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/save_arrays_solver.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -23,470 +23,19 @@
!
!=====================================================================
- subroutine save_arrays_solver(flag_sediments,not_fully_in_bedrock,rho_vp,rho_vs,prname,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore,jacobianstore, &
- xstore,ystore,zstore,kappastore,mustore, &
- ANISOTROPY, &
- c11store,c12store,c13store,c14store,c15store,c16store, &
- c22store,c23store,c24store,c25store,c26store,c33store,c34store,c35store,c36store, &
- c44store,c45store,c46store,c55store,c56store,c66store, &
- ibool,idoubling,rmass,rmass_ocean_load,npointot_oceans, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
- normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top, &
- jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax, &
- jacobian2D_bottom,jacobian2D_top, &
- iMPIcut_xi,iMPIcut_eta,nspec,nglob, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP,OCEANS)
- implicit none
+! for external mesh
- include "constants.h"
-
- integer nspec,nglob
- integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP
- integer npointot_oceans
-
- logical OCEANS
- logical ANISOTROPY
-
-! arrays with jacobian matrix
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore,jacobianstore
-
-! arrays with mesh parameters
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- real(kind=CUSTOM_REAL) kappastore(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) mustore(NGLLX,NGLLY,NGLLZ,nspec)
-
- real(kind=CUSTOM_REAL) c11store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c12store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c13store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c14store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c15store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c16store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c22store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c23store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c24store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c25store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c26store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c33store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c34store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c35store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c36store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c44store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c45store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c46store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c55store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c56store(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) c66store(NGLLX,NGLLY,NGLLZ,nspec)
-
-! Stacey
- real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec)
- real(kind=CUSTOM_REAL) rho_vs(NGLLX,NGLLY,NGLLZ,nspec)
-
-! flag indicating whether point is in the sediments
- logical flag_sediments(NGLLX,NGLLY,NGLLZ,nspec)
- logical not_fully_in_bedrock(nspec)
-
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
-! doubling mesh flag
- integer idoubling(nspec)
-
-! mass matrix
- real(kind=CUSTOM_REAL) rmass(nglob)
-
-! additional ocean load mass matrix
- real(kind=CUSTOM_REAL) rmass_ocean_load(npointot_oceans)
-
-! boundary parameters locator
- integer ibelm_xmin(NSPEC2DMAX_XMIN_XMAX),ibelm_xmax(NSPEC2DMAX_XMIN_XMAX)
- integer ibelm_ymin(NSPEC2DMAX_YMIN_YMAX),ibelm_ymax(NSPEC2DMAX_YMIN_YMAX)
- integer ibelm_bottom(NSPEC2D_BOTTOM),ibelm_top(NSPEC2D_TOP)
-
-! normals
- real(kind=CUSTOM_REAL) normal_xmin(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- real(kind=CUSTOM_REAL) normal_xmax(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- real(kind=CUSTOM_REAL) normal_ymin(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- real(kind=CUSTOM_REAL) normal_ymax(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- real(kind=CUSTOM_REAL) normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM)
- real(kind=CUSTOM_REAL) normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP)
-
-! jacobian on 2D edges
- real(kind=CUSTOM_REAL) jacobian2D_xmin(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- real(kind=CUSTOM_REAL) jacobian2D_xmax(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
- real(kind=CUSTOM_REAL) jacobian2D_ymin(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- real(kind=CUSTOM_REAL) jacobian2D_ymax(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
- real(kind=CUSTOM_REAL) jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM)
- real(kind=CUSTOM_REAL) jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP)
-
-! number of elements on the boundaries
- integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
-
-! MPI cut-planes parameters along xi and along eta
- logical iMPIcut_xi(2,nspec),iMPIcut_eta(2,nspec)
-
- integer i,j,k,ispec,iglob
-
-! processor identification
- character(len=150) prname
-
-! xix
- open(unit=27,file=prname(1:len_trim(prname))//'xix.bin',status='unknown',form='unformatted')
- write(27) xixstore
- close(27)
-
-! xiy
- open(unit=27,file=prname(1:len_trim(prname))//'xiy.bin',status='unknown',form='unformatted')
- write(27) xiystore
- close(27)
-
-! xiz
- open(unit=27,file=prname(1:len_trim(prname))//'xiz.bin',status='unknown',form='unformatted')
- write(27) xizstore
- close(27)
-
-! etax
- open(unit=27,file=prname(1:len_trim(prname))//'etax.bin',status='unknown',form='unformatted')
- write(27) etaxstore
- close(27)
-
-! etay
- open(unit=27,file=prname(1:len_trim(prname))//'etay.bin',status='unknown',form='unformatted')
- write(27) etaystore
- close(27)
-
-! etaz
- open(unit=27,file=prname(1:len_trim(prname))//'etaz.bin',status='unknown',form='unformatted')
- write(27) etazstore
- close(27)
-
-! gammax
- open(unit=27,file=prname(1:len_trim(prname))//'gammax.bin',status='unknown',form='unformatted')
- write(27) gammaxstore
- close(27)
-
-! gammay
- open(unit=27,file=prname(1:len_trim(prname))//'gammay.bin',status='unknown',form='unformatted')
- write(27) gammaystore
- close(27)
-
-! gammaz
- open(unit=27,file=prname(1:len_trim(prname))//'gammaz.bin',status='unknown',form='unformatted')
- write(27) gammazstore
- close(27)
-
-! jacobian
- open(unit=27,file=prname(1:len_trim(prname))//'jacobian.bin',status='unknown',form='unformatted')
- write(27) jacobianstore
- close(27)
-
-! flag_sediments
- open(unit=27,file=prname(1:len_trim(prname))//'flag_sediments.bin',status='unknown',form='unformatted')
- write(27) flag_sediments
- close(27)
-
-! not_fully_in_bedrock
- open(unit=27,file=prname(1:len_trim(prname))//'not_fully_in_bedrock.bin',status='unknown',form='unformatted')
- write(27) not_fully_in_bedrock
- close(27)
-
-! rho_vs
-! Stacey
-! rho_vp
- open(unit=27,file=prname(1:len_trim(prname))//'rho_vp.bin',status='unknown',form='unformatted')
- write(27) rho_vp
- close(27)
-
-! rho_vs
- open(unit=27,file=prname(1:len_trim(prname))//'rho_vs.bin',status='unknown',form='unformatted')
- write(27) rho_vs
- close(27)
-
-!!$! vp (for checking the mesh and model)
-!!$ open(unit=27,file=prname(1:len_trim(prname))//'vp.bin',status='unknown',form='unformatted')
-!!$ write(27) (FOUR_THIRDS * mustore + kappastore) / rho_vp
-!!$ close(27)
-!!$
-!!$! vs (for checking the mesh and model)
-!!$ open(unit=27,file=prname(1:len_trim(prname))//'vs.bin',status='unknown',form='unformatted')
-!!$ write(27) mustore / rho_vs
-!!$ close(27)
-
-! kappa
- open(unit=27,file=prname(1:len_trim(prname))//'kappa.bin',status='unknown',form='unformatted')
- write(27) kappastore
- close(27)
-
-! mu
- open(unit=27,file=prname(1:len_trim(prname))//'mu.bin',status='unknown',form='unformatted')
- write(27) mustore
- close(27)
-
-! ibool
- open(unit=27,file=prname(1:len_trim(prname))//'ibool.bin',status='unknown',form='unformatted')
- write(27) ibool
- close(27)
-
-! doubling
- open(unit=27,file=prname(1:len_trim(prname))//'idoubling.bin',status='unknown',form='unformatted')
- write(27) idoubling
- close(27)
-
-! mass matrix
- open(unit=27,file=prname(1:len_trim(prname))//'rmass.bin',status='unknown',form='unformatted')
- write(27) rmass
- close(27)
-
-! For anisotropy
- if(ANISOTROPY) then
- ! c11
- open(unit=27,file=prname(1:len_trim(prname))//'c11.bin',status='unknown',form='unformatted')
- write(27) c11store
- close(27)
-
- ! c12
- open(unit=27,file=prname(1:len_trim(prname))//'c12.bin',status='unknown',form='unformatted')
- write(27) c12store
- close(27)
-
- ! c13
- open(unit=27,file=prname(1:len_trim(prname))//'c13.bin',status='unknown',form='unformatted')
- write(27) c13store
- close(27)
-
- ! c14
- open(unit=27,file=prname(1:len_trim(prname))//'c14.bin',status='unknown',form='unformatted')
- write(27) c14store
- close(27)
-
- ! c15
- open(unit=27,file=prname(1:len_trim(prname))//'c15.bin',status='unknown',form='unformatted')
- write(27) c15store
- close(27)
-
- ! c16
- open(unit=27,file=prname(1:len_trim(prname))//'c16.bin',status='unknown',form='unformatted')
- write(27) c16store
- close(27)
-
- ! c22
- open(unit=27,file=prname(1:len_trim(prname))//'c22.bin',status='unknown',form='unformatted')
- write(27) c22store
- close(27)
-
- ! c23
- open(unit=27,file=prname(1:len_trim(prname))//'c23.bin',status='unknown',form='unformatted')
- write(27) c23store
- close(27)
-
- ! c24
- open(unit=27,file=prname(1:len_trim(prname))//'c24.bin',status='unknown',form='unformatted')
- write(27) c24store
- close(27)
-
- ! c25
- open(unit=27,file=prname(1:len_trim(prname))//'c25.bin',status='unknown',form='unformatted')
- write(27) c25store
- close(27)
-
- ! c26
- open(unit=27,file=prname(1:len_trim(prname))//'c26.bin',status='unknown',form='unformatted')
- write(27) c26store
- close(27)
-
- ! c33
- open(unit=27,file=prname(1:len_trim(prname))//'c33.bin',status='unknown',form='unformatted')
- write(27) c33store
- close(27)
-
- ! c34
- open(unit=27,file=prname(1:len_trim(prname))//'c34.bin',status='unknown',form='unformatted')
- write(27) c34store
- close(27)
-
- ! c35
- open(unit=27,file=prname(1:len_trim(prname))//'c35.bin',status='unknown',form='unformatted')
- write(27) c35store
- close(27)
-
- ! c36
- open(unit=27,file=prname(1:len_trim(prname))//'c36.bin',status='unknown',form='unformatted')
- write(27) c36store
- close(27)
-
- ! c44
- open(unit=27,file=prname(1:len_trim(prname))//'c44.bin',status='unknown',form='unformatted')
- write(27) c44store
- close(27)
-
- ! c45
- open(unit=27,file=prname(1:len_trim(prname))//'c45.bin',status='unknown',form='unformatted')
- write(27) c45store
- close(27)
-
- ! c46
- open(unit=27,file=prname(1:len_trim(prname))//'c46.bin',status='unknown',form='unformatted')
- write(27) c46store
- close(27)
-
- ! c55
- open(unit=27,file=prname(1:len_trim(prname))//'c55.bin',status='unknown',form='unformatted')
- write(27) c55store
- close(27)
-
- ! c56
- open(unit=27,file=prname(1:len_trim(prname))//'c56.bin',status='unknown',form='unformatted')
- write(27) c56store
- close(27)
-
- ! c66
- open(unit=27,file=prname(1:len_trim(prname))//'c66.bin',status='unknown',form='unformatted')
- write(27) c66store
- close(27)
-
- endif
-
-! additional ocean load mass matrix if oceans
- if(OCEANS) then
- open(unit=27,file=prname(1:len_trim(prname))//'rmass_ocean_load.bin',status='unknown',form='unformatted')
- write(27) rmass_ocean_load
- close(27)
- endif
-
-! boundary parameters
- open(unit=27,file=prname(1:len_trim(prname))//'ibelm.bin',status='unknown',form='unformatted')
- write(27) ibelm_xmin
- write(27) ibelm_xmax
- write(27) ibelm_ymin
- write(27) ibelm_ymax
- write(27) ibelm_bottom
- write(27) ibelm_top
- close(27)
-
- open(unit=27,file=prname(1:len_trim(prname))//'normal.bin',status='unknown',form='unformatted')
- write(27) normal_xmin
- write(27) normal_xmax
- write(27) normal_ymin
- write(27) normal_ymax
- write(27) normal_bottom
- write(27) normal_top
- close(27)
-
- open(unit=27,file=prname(1:len_trim(prname))//'jacobian2D.bin',status='unknown',form='unformatted')
- write(27) jacobian2D_xmin
- write(27) jacobian2D_xmax
- write(27) jacobian2D_ymin
- write(27) jacobian2D_ymax
- write(27) jacobian2D_bottom
- write(27) jacobian2D_top
- close(27)
-
- open(unit=27,file=prname(1:len_trim(prname))//'nspec2D.bin',status='unknown',form='unformatted')
- write(27) nspec2D_xmin
- write(27) nspec2D_xmax
- write(27) nspec2D_ymin
- write(27) nspec2D_ymax
- close(27)
-
-! MPI cut-planes parameters along xi and along eta
- open(unit=27,file=prname(1:len_trim(prname))//'iMPIcut_xi.bin',status='unknown',form='unformatted')
- write(27) iMPIcut_xi
- close(27)
-
- open(unit=27,file=prname(1:len_trim(prname))//'iMPIcut_eta.bin',status='unknown',form='unformatted')
- write(27) iMPIcut_eta
- close(27)
-
-! mesh arrays used in the solver to locate source and receivers
-! use rmass for temporary storage to perform conversion, since already saved
-
-!--- x coordinate
- rmass(:) = 0._CUSTOM_REAL
- do ispec = 1,nspec
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- iglob = ibool(i,j,k,ispec)
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- rmass(iglob) = sngl(xstore(i,j,k,ispec))
- else
- rmass(iglob) = xstore(i,j,k,ispec)
- endif
- enddo
- enddo
- enddo
- enddo
- open(unit=27,file=prname(1:len_trim(prname))//'x.bin',status='unknown',form='unformatted')
- write(27) rmass
- close(27)
-
-!--- y coordinate
- rmass(:) = 0._CUSTOM_REAL
- do ispec = 1,nspec
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- iglob = ibool(i,j,k,ispec)
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- rmass(iglob) = sngl(ystore(i,j,k,ispec))
- else
- rmass(iglob) = ystore(i,j,k,ispec)
- endif
- enddo
- enddo
- enddo
- enddo
- open(unit=27,file=prname(1:len_trim(prname))//'y.bin',status='unknown',form='unformatted')
- write(27) rmass
- close(27)
-
-!--- z coordinate
- rmass(:) = 0._CUSTOM_REAL
- do ispec = 1,nspec
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- iglob = ibool(i,j,k,ispec)
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- rmass(iglob) = sngl(zstore(i,j,k,ispec))
- else
- rmass(iglob) = zstore(i,j,k,ispec)
- endif
- enddo
- enddo
- enddo
- enddo
- open(unit=27,file=prname(1:len_trim(prname))//'z.bin',status='unknown',form='unformatted')
- write(27) rmass
- close(27)
-
- end subroutine save_arrays_solver
-
-!=============================================================
-
-! external mesh routine
-
subroutine save_arrays_solver_ext_mesh(nspec,nglob, &
xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
jacobianstore, rho_vp,rho_vs,iflag_attenuation_store, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
kappastore,mustore,rmass,ibool,xstore_dummy,ystore_dummy,zstore_dummy, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
- normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top, &
- jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom,jacobian2D_top,&
+ NSPEC2D_TOP,ibelm_top,normal_top,jacobian2D_top, &
+ absorbing_boundary_normal,absorbing_boundary_jacobian2D, &
+ absorbing_boundary_ijk,absorbing_boundary_ispec, &
+ num_absorbing_boundary_faces, &
ninterface_ext_mesh,my_neighbours_ext_mesh,nibool_interfaces_ext_mesh, &
- max_interface_size_ext_mesh,ibool_interfaces_ext_mesh, &
+ max_interface_size_ext_mesh,ibool_interfaces_ext_mesh, &
prname,SAVE_MESH_FILES)
@@ -495,53 +44,67 @@
include "constants.h"
integer :: nspec,nglob
-
+
+! jacobian
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xixstore,xiystore,xizstore, &
etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore,jacobianstore
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rho_vp,rho_vs
+! attenuation
integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: iflag_attenuation_store
- integer :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
- integer, dimension(2,NSPEC2DMAX_YMIN_YMAX) :: nimin,nimax,nkmin_eta
- integer, dimension(2,NSPEC2DMAX_XMIN_XMAX) :: njmin,njmax,nkmin_xi
-
-
+! material
real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: kappastore,mustore
real(kind=CUSTOM_REAL), dimension(nglob) :: rmass
+! mesh coordinates
integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
- integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2D_TOP
- integer, dimension(nspec2D_xmin) :: ibelm_xmin
- integer, dimension(nspec2D_xmax) :: ibelm_xmax
- integer, dimension(nspec2D_ymin) :: ibelm_ymin
- integer, dimension(nspec2D_ymax) :: ibelm_ymax
- integer, dimension(NSPEC2D_BOTTOM) :: ibelm_bottom
+! absorbing boundaries
+! integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM
+ integer :: NSPEC2D_TOP
+! integer, dimension(nspec2D_xmin) :: ibelm_xmin
+! integer, dimension(nspec2D_xmax) :: ibelm_xmax
+! integer, dimension(nspec2D_ymin) :: ibelm_ymin
+! integer, dimension(nspec2D_ymax) :: ibelm_ymax
+! integer, dimension(NSPEC2D_BOTTOM) :: ibelm_bottom
integer, dimension(NSPEC2D_TOP) :: ibelm_top
+! integer :: ibelm_gll_xmin(3,NGLLY,NGLLZ,nspec2D_xmin),ibelm_gll_xmax(3,NGLLY,NGLLZ,nspec2D_xmax), &
+! ibelm_gll_ymin(3,NGLLX,NGLLZ,nspec2D_ymin),ibelm_gll_ymax(3,NGLLX,NGLLZ,nspec2D_ymax), &
+! ibelm_gll_bottom(3,NGLLY,NGLLY,nspec2D_bottom),ibelm_gll_top(3,NGLLY,NGLLY,nspec2D_top)
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmin) :: normal_xmin
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmax) :: normal_xmax
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,nspec2D_ymin) :: normal_ymin
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,nspec2D_ymax) :: normal_ymax
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM) :: normal_bottom
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP) :: normal_top
+! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmin) :: jacobian2D_xmin
+! real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmax) :: jacobian2D_xmax
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymin) :: jacobian2D_ymin
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymax) :: jacobian2D_ymax
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,nspec2D_bottom) :: jacobian2D_bottom
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,nspec2D_top) :: jacobian2D_top
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmin) :: normal_xmin
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLY,NGLLZ,nspec2D_xmax) :: normal_xmax
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,nspec2D_ymin) :: normal_ymin
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLZ,nspec2D_ymax) :: normal_ymax
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM) :: normal_bottom
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP) :: normal_top
+ integer :: num_absorbing_boundary_faces
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_normal
+ real(kind=CUSTOM_REAL), dimension(NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_jacobian2D
+ integer, dimension(3,NGLLSQUARE,num_absorbing_boundary_faces) :: absorbing_boundary_ijk
+ integer, dimension(num_absorbing_boundary_faces) :: absorbing_boundary_ispec
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmin) :: jacobian2D_xmin
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ,nspec2D_xmax) :: jacobian2D_xmax
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymin) :: jacobian2D_ymin
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ,nspec2D_ymax) :: jacobian2D_ymax
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,nspec2D_bottom) :: jacobian2D_bottom
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,nspec2D_top) :: jacobian2D_top
+! integer :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
+! integer, dimension(2,NSPEC2DMAX_YMIN_YMAX) :: nimin,nimax,nkmin_eta
+! integer, dimension(2,NSPEC2DMAX_XMIN_XMAX) :: njmin,njmax,nkmin_xi
+
+! MPI interfaces
integer :: ninterface_ext_mesh
integer, dimension(ninterface_ext_mesh) :: my_neighbours_ext_mesh
integer, dimension(ninterface_ext_mesh) :: nibool_interfaces_ext_mesh
-
integer :: max_interface_size_ext_mesh
integer, dimension(NGLLX*NGLLX*max_interface_size_ext_mesh,ninterface_ext_mesh) :: ibool_interfaces_ext_mesh
+! file name
character(len=150) prname
logical :: SAVE_MESH_FILES
@@ -551,7 +114,7 @@
integer, dimension(:,:), allocatable :: ibool_interfaces_ext_mesh_dummy
integer :: ier,i
-! saves mesh file
+! saves mesh file proc***_external_mesh.bin
open(unit=IOUT,file=prname(1:len_trim(prname))//'external_mesh.bin',status='unknown',action='write',form='unformatted',iostat=ier)
if( ier /= 0 ) stop 'error opening database proc######_external_mesh.bin'
@@ -573,14 +136,15 @@
write(IOUT) rho_vp
write(IOUT) rho_vs
write(IOUT) iflag_attenuation_store
- write(IOUT) NSPEC2DMAX_XMIN_XMAX
- write(IOUT) NSPEC2DMAX_YMIN_YMAX
- write(IOUT) nimin
- write(IOUT) nimax
- write(IOUT) njmin
- write(IOUT) njmax
- write(IOUT) nkmin_xi
- write(IOUT) nkmin_eta
+
+! write(IOUT) NSPEC2DMAX_XMIN_XMAX
+! write(IOUT) NSPEC2DMAX_YMIN_YMAX
+! write(IOUT) nimin
+! write(IOUT) nimax
+! write(IOUT) njmin
+! write(IOUT) njmax
+! write(IOUT) nkmin_xi
+! write(IOUT) nkmin_eta
!end pll
write(IOUT) kappastore
@@ -593,37 +157,55 @@
write(IOUT) ystore_dummy
write(IOUT) zstore_dummy
-! boundary parameters
- write(IOUT) nspec2D_xmin
- write(IOUT) nspec2D_xmax
- write(IOUT) nspec2D_ymin
- write(IOUT) nspec2D_ymax
- write(IOUT) NSPEC2D_BOTTOM
- write(IOUT) NSPEC2D_TOP
+! absorbing boundary parameters
+! write(IOUT) nspec2D_xmin
+! write(IOUT) nspec2D_xmax
+! write(IOUT) nspec2D_ymin
+! write(IOUT) nspec2D_ymax
+! write(IOUT) NSPEC2D_BOTTOM
+! write(IOUT) NSPEC2D_TOP
+!
+! write(IOUT) ibelm_xmin
+! write(IOUT) ibelm_xmax
+! write(IOUT) ibelm_ymin
+! write(IOUT) ibelm_ymax
+! write(IOUT) ibelm_bottom
+! write(IOUT) ibelm_top
+!
+! write(IOUT) ibelm_gll_xmin
+! write(IOUT) ibelm_gll_xmax
+! write(IOUT) ibelm_gll_ymin
+! write(IOUT) ibelm_gll_ymax
+! write(IOUT) ibelm_gll_bottom
+! write(IOUT) ibelm_gll_top
+!
+! write(IOUT) normal_xmin
+! write(IOUT) normal_xmax
+! write(IOUT) normal_ymin
+! write(IOUT) normal_ymax
+! write(IOUT) normal_bottom
+! write(IOUT) normal_top
+!
+! write(IOUT) jacobian2D_xmin
+! write(IOUT) jacobian2D_xmax
+! write(IOUT) jacobian2D_ymin
+! write(IOUT) jacobian2D_ymax
+! write(IOUT) jacobian2D_bottom
+! write(IOUT) jacobian2D_top
- write(IOUT) ibelm_xmin
- write(IOUT) ibelm_xmax
- write(IOUT) ibelm_ymin
- write(IOUT) ibelm_ymax
- write(IOUT) ibelm_bottom
+ write(IOUT) num_absorbing_boundary_faces
+ write(IOUT) absorbing_boundary_ispec
+ write(IOUT) absorbing_boundary_ijk
+ write(IOUT) absorbing_boundary_jacobian2D
+ write(IOUT) absorbing_boundary_normal
+
+! free surface
+ write(IOUT) NSPEC2D_TOP
write(IOUT) ibelm_top
-
- write(IOUT) normal_xmin
- write(IOUT) normal_xmax
- write(IOUT) normal_ymin
- write(IOUT) normal_ymax
- write(IOUT) normal_bottom
+ write(IOUT) jacobian2D_top
write(IOUT) normal_top
- write(IOUT) jacobian2D_xmin
- write(IOUT) jacobian2D_xmax
- write(IOUT) jacobian2D_ymin
- write(IOUT) jacobian2D_ymax
- write(IOUT) jacobian2D_bottom
- write(IOUT) jacobian2D_top
-
-! end boundary parameters
-
+!MPI interfaces
write(IOUT) ninterface_ext_mesh
write(IOUT) maxval(nibool_interfaces_ext_mesh)
write(IOUT) my_neighbours_ext_mesh
@@ -641,8 +223,9 @@
deallocate(ibool_interfaces_ext_mesh_dummy,stat=ier); if( ier /= 0 ) stop 'error deallocating array'
+
+! mesh arrays used for example in combine_vol_data.f90
if( SAVE_MESH_FILES ) then
-! mesh arrays used in combine_vol_data.f90
!--- x coordinate
open(unit=27,file=prname(1:len_trim(prname))//'x.bin',status='unknown',form='unformatted')
write(27) xstore_dummy
@@ -696,11 +279,11 @@
!=============================================================
-! external mesh routine for saving vtk file holding material flag for each element
+! external mesh routine for saving vtk file holding integer flag for each element
- subroutine save_arrays_solver_ext_mesh_material_vtk(nspec,nglob, &
+ subroutine save_arrays_solver_ext_mesh_elem_vtk(nspec,nglob, &
xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
- mat_ext_mesh,prname_file)
+ elem_flag,prname_file)
implicit none
@@ -708,16 +291,19 @@
include "constants.h"
integer :: nspec,nglob
-
+
+! global coordinates
integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
- integer, dimension(2,nspec) :: mat_ext_mesh
+! element flag array
+ integer, dimension(nspec) :: elem_flag
integer :: ispec,i
+! file name
character(len=150) prname_file
- ! write source and receiver VTK files for Paraview
+! write source and receiver VTK files for Paraview
write(IMAIN,*) ' vtk file: ',prname_file(1:len_trim(prname_file))//'.vtk'
open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
@@ -745,25 +331,21 @@
write(IOVTK,*) ""
write(IOVTK,'(a,i)') "CELL_DATA ",nspec
- write(IOVTK,'(a)') "SCALARS material_flag integer"
+ write(IOVTK,'(a)') "SCALARS elem_flag integer"
write(IOVTK,'(a)') "LOOKUP_TABLE default"
do ispec = 1,nspec
- if (mat_ext_mesh(1,ispec) > 0) then
- write(IOVTK,*) mat_ext_mesh(1,ispec)
- else
- write(IOVTK,*) mat_ext_mesh(2,ispec)
- endif
+ write(IOVTK,*) elem_flag(ispec)
enddo
write(IOVTK,*) ""
close(IOVTK)
- end subroutine save_arrays_solver_ext_mesh_material_vtk
+ end subroutine save_arrays_solver_ext_mesh_elem_vtk
!=============================================================
-! external mesh routine for saving vtk files
+! external mesh routine for saving vtk files for values on all gll points
subroutine save_arrays_solver_ext_mesh_glldata_vtk(nspec,nglob, &
xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
@@ -775,19 +357,23 @@
integer :: nspec,nglob
+! global coordinates
integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
+! gll data values array
integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: gll_data
+! masking arrays (takes first data value assigned on a global point, ignores any data values later on for the same global point)
real, dimension(:),allocatable :: flag_val
logical, dimension(:),allocatable :: mask_ibool
+! file name
+ character(len=150) prname_file
+
integer :: ispec,i,j,k,ier,iglob
- character(len=150) prname_file
-
- ! write source and receiver VTK files for Paraview
+! write source and receiver VTK files for Paraview
write(IMAIN,*) ' vtk file: ',prname_file(1:len_trim(prname_file))//'.vtk'
open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
@@ -845,5 +431,461 @@
end subroutine save_arrays_solver_ext_mesh_glldata_vtk
+
+!=============================================================
+!
+!! old way
+!! regular mesh
+!
+! subroutine save_arrays_solver(flag_sediments,not_fully_in_bedrock,rho_vp,rho_vs,prname,xixstore,xiystore,xizstore, &
+! etaxstore,etaystore,etazstore, &
+! gammaxstore,gammaystore,gammazstore,jacobianstore, &
+! xstore,ystore,zstore,kappastore,mustore, &
+! ANISOTROPY, &
+! c11store,c12store,c13store,c14store,c15store,c16store, &
+! c22store,c23store,c24store,c25store,c26store,c33store,c34store,c35store,c36store, &
+! c44store,c45store,c46store,c55store,c56store,c66store, &
+! ibool,idoubling,rmass,rmass_ocean_load,npointot_oceans, &
+! ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+! nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+! normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top, &
+! jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax, &
+! jacobian2D_bottom,jacobian2D_top, &
+! iMPIcut_xi,iMPIcut_eta,nspec,nglob, &
+! NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP,OCEANS)
+!
+! implicit none
+!
+! include "constants.h"
+!
+! integer nspec,nglob
+! integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP
+! integer npointot_oceans
+!
+! logical OCEANS
+! logical ANISOTROPY
+!
+!! arrays with jacobian matrix
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
+! xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
+! gammaxstore,gammaystore,gammazstore,jacobianstore
+!
+!! arrays with mesh parameters
+! double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+! double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+! double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+!
+! real(kind=CUSTOM_REAL) kappastore(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) mustore(NGLLX,NGLLY,NGLLZ,nspec)
+!
+! real(kind=CUSTOM_REAL) c11store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c12store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c13store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c14store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c15store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c16store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c22store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c23store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c24store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c25store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c26store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c33store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c34store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c35store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c36store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c44store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c45store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c46store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c55store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c56store(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) c66store(NGLLX,NGLLY,NGLLZ,nspec)
+!
+!! Stacey
+! real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,nspec)
+! real(kind=CUSTOM_REAL) rho_vs(NGLLX,NGLLY,NGLLZ,nspec)
+!
+!! flag indicating whether point is in the sediments
+! logical flag_sediments(NGLLX,NGLLY,NGLLZ,nspec)
+! logical not_fully_in_bedrock(nspec)
+!
+! integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+!
+!! doubling mesh flag
+! integer idoubling(nspec)
+!
+!! mass matrix
+! real(kind=CUSTOM_REAL) rmass(nglob)
+!
+!! additional ocean load mass matrix
+! real(kind=CUSTOM_REAL) rmass_ocean_load(npointot_oceans)
+!
+!! boundary parameters locator
+! integer ibelm_xmin(NSPEC2DMAX_XMIN_XMAX),ibelm_xmax(NSPEC2DMAX_XMIN_XMAX)
+! integer ibelm_ymin(NSPEC2DMAX_YMIN_YMAX),ibelm_ymax(NSPEC2DMAX_YMIN_YMAX)
+! integer ibelm_bottom(NSPEC2D_BOTTOM),ibelm_top(NSPEC2D_TOP)
+!
+!! normals
+! real(kind=CUSTOM_REAL) normal_xmin(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+! real(kind=CUSTOM_REAL) normal_xmax(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+! real(kind=CUSTOM_REAL) normal_ymin(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+! real(kind=CUSTOM_REAL) normal_ymax(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+! real(kind=CUSTOM_REAL) normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM)
+! real(kind=CUSTOM_REAL) normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP)
+!
+!! jacobian on 2D edges
+! real(kind=CUSTOM_REAL) jacobian2D_xmin(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+! real(kind=CUSTOM_REAL) jacobian2D_xmax(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX)
+! real(kind=CUSTOM_REAL) jacobian2D_ymin(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+! real(kind=CUSTOM_REAL) jacobian2D_ymax(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX)
+! real(kind=CUSTOM_REAL) jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM)
+! real(kind=CUSTOM_REAL) jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP)
+!
+!! number of elements on the boundaries
+! integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
+!
+!! MPI cut-planes parameters along xi and along eta
+! logical iMPIcut_xi(2,nspec),iMPIcut_eta(2,nspec)
+!
+! integer i,j,k,ispec,iglob
+!
+!! processor identification
+! character(len=150) prname
+!
+!! xix
+! open(unit=27,file=prname(1:len_trim(prname))//'xix.bin',status='unknown',form='unformatted')
+! write(27) xixstore
+! close(27)
+!
+!! xiy
+! open(unit=27,file=prname(1:len_trim(prname))//'xiy.bin',status='unknown',form='unformatted')
+! write(27) xiystore
+! close(27)
+!
+!! xiz
+! open(unit=27,file=prname(1:len_trim(prname))//'xiz.bin',status='unknown',form='unformatted')
+! write(27) xizstore
+! close(27)
+!
+!! etax
+! open(unit=27,file=prname(1:len_trim(prname))//'etax.bin',status='unknown',form='unformatted')
+! write(27) etaxstore
+! close(27)
+!
+!! etay
+! open(unit=27,file=prname(1:len_trim(prname))//'etay.bin',status='unknown',form='unformatted')
+! write(27) etaystore
+! close(27)
+!
+!! etaz
+! open(unit=27,file=prname(1:len_trim(prname))//'etaz.bin',status='unknown',form='unformatted')
+! write(27) etazstore
+! close(27)
+!
+!! gammax
+! open(unit=27,file=prname(1:len_trim(prname))//'gammax.bin',status='unknown',form='unformatted')
+! write(27) gammaxstore
+! close(27)
+!
+!! gammay
+! open(unit=27,file=prname(1:len_trim(prname))//'gammay.bin',status='unknown',form='unformatted')
+! write(27) gammaystore
+! close(27)
+!
+!! gammaz
+! open(unit=27,file=prname(1:len_trim(prname))//'gammaz.bin',status='unknown',form='unformatted')
+! write(27) gammazstore
+! close(27)
+!
+!! jacobian
+! open(unit=27,file=prname(1:len_trim(prname))//'jacobian.bin',status='unknown',form='unformatted')
+! write(27) jacobianstore
+! close(27)
+!
+!! flag_sediments
+! open(unit=27,file=prname(1:len_trim(prname))//'flag_sediments.bin',status='unknown',form='unformatted')
+! write(27) flag_sediments
+! close(27)
+!
+!! not_fully_in_bedrock
+! open(unit=27,file=prname(1:len_trim(prname))//'not_fully_in_bedrock.bin',status='unknown',form='unformatted')
+! write(27) not_fully_in_bedrock
+! close(27)
+!
+!! rho_vs
+!! Stacey
+!! rho_vp
+! open(unit=27,file=prname(1:len_trim(prname))//'rho_vp.bin',status='unknown',form='unformatted')
+! write(27) rho_vp
+! close(27)
+!
+!! rho_vs
+! open(unit=27,file=prname(1:len_trim(prname))//'rho_vs.bin',status='unknown',form='unformatted')
+! write(27) rho_vs
+! close(27)
+!
+!!!$! vp (for checking the mesh and model)
+!!!$ open(unit=27,file=prname(1:len_trim(prname))//'vp.bin',status='unknown',form='unformatted')
+!!!$ write(27) (FOUR_THIRDS * mustore + kappastore) / rho_vp
+!!!$ close(27)
+!!!$
+!!!$! vs (for checking the mesh and model)
+!!!$ open(unit=27,file=prname(1:len_trim(prname))//'vs.bin',status='unknown',form='unformatted')
+!!!$ write(27) mustore / rho_vs
+!!!$ close(27)
+!
+!! kappa
+! open(unit=27,file=prname(1:len_trim(prname))//'kappa.bin',status='unknown',form='unformatted')
+! write(27) kappastore
+! close(27)
+!
+!! mu
+! open(unit=27,file=prname(1:len_trim(prname))//'mu.bin',status='unknown',form='unformatted')
+! write(27) mustore
+! close(27)
+!
+!! ibool
+! open(unit=27,file=prname(1:len_trim(prname))//'ibool.bin',status='unknown',form='unformatted')
+! write(27) ibool
+! close(27)
+!
+!! doubling
+! open(unit=27,file=prname(1:len_trim(prname))//'idoubling.bin',status='unknown',form='unformatted')
+! write(27) idoubling
+! close(27)
+!
+!! mass matrix
+! open(unit=27,file=prname(1:len_trim(prname))//'rmass.bin',status='unknown',form='unformatted')
+! write(27) rmass
+! close(27)
+!
+!! For anisotropy
+! if(ANISOTROPY) then
+! ! c11
+! open(unit=27,file=prname(1:len_trim(prname))//'c11.bin',status='unknown',form='unformatted')
+! write(27) c11store
+! close(27)
+!
+! ! c12
+! open(unit=27,file=prname(1:len_trim(prname))//'c12.bin',status='unknown',form='unformatted')
+! write(27) c12store
+! close(27)
+!
+! ! c13
+! open(unit=27,file=prname(1:len_trim(prname))//'c13.bin',status='unknown',form='unformatted')
+! write(27) c13store
+! close(27)
+!
+! ! c14
+! open(unit=27,file=prname(1:len_trim(prname))//'c14.bin',status='unknown',form='unformatted')
+! write(27) c14store
+! close(27)
+!
+! ! c15
+! open(unit=27,file=prname(1:len_trim(prname))//'c15.bin',status='unknown',form='unformatted')
+! write(27) c15store
+! close(27)
+!
+! ! c16
+! open(unit=27,file=prname(1:len_trim(prname))//'c16.bin',status='unknown',form='unformatted')
+! write(27) c16store
+! close(27)
+!
+! ! c22
+! open(unit=27,file=prname(1:len_trim(prname))//'c22.bin',status='unknown',form='unformatted')
+! write(27) c22store
+! close(27)
+!
+! ! c23
+! open(unit=27,file=prname(1:len_trim(prname))//'c23.bin',status='unknown',form='unformatted')
+! write(27) c23store
+! close(27)
+!
+! ! c24
+! open(unit=27,file=prname(1:len_trim(prname))//'c24.bin',status='unknown',form='unformatted')
+! write(27) c24store
+! close(27)
+!
+! ! c25
+! open(unit=27,file=prname(1:len_trim(prname))//'c25.bin',status='unknown',form='unformatted')
+! write(27) c25store
+! close(27)
+!
+! ! c26
+! open(unit=27,file=prname(1:len_trim(prname))//'c26.bin',status='unknown',form='unformatted')
+! write(27) c26store
+! close(27)
+!
+! ! c33
+! open(unit=27,file=prname(1:len_trim(prname))//'c33.bin',status='unknown',form='unformatted')
+! write(27) c33store
+! close(27)
+!
+! ! c34
+! open(unit=27,file=prname(1:len_trim(prname))//'c34.bin',status='unknown',form='unformatted')
+! write(27) c34store
+! close(27)
+!
+! ! c35
+! open(unit=27,file=prname(1:len_trim(prname))//'c35.bin',status='unknown',form='unformatted')
+! write(27) c35store
+! close(27)
+!
+! ! c36
+! open(unit=27,file=prname(1:len_trim(prname))//'c36.bin',status='unknown',form='unformatted')
+! write(27) c36store
+! close(27)
+!
+! ! c44
+! open(unit=27,file=prname(1:len_trim(prname))//'c44.bin',status='unknown',form='unformatted')
+! write(27) c44store
+! close(27)
+!
+! ! c45
+! open(unit=27,file=prname(1:len_trim(prname))//'c45.bin',status='unknown',form='unformatted')
+! write(27) c45store
+! close(27)
+!
+! ! c46
+! open(unit=27,file=prname(1:len_trim(prname))//'c46.bin',status='unknown',form='unformatted')
+! write(27) c46store
+! close(27)
+!
+! ! c55
+! open(unit=27,file=prname(1:len_trim(prname))//'c55.bin',status='unknown',form='unformatted')
+! write(27) c55store
+! close(27)
+!
+! ! c56
+! open(unit=27,file=prname(1:len_trim(prname))//'c56.bin',status='unknown',form='unformatted')
+! write(27) c56store
+! close(27)
+!
+! ! c66
+! open(unit=27,file=prname(1:len_trim(prname))//'c66.bin',status='unknown',form='unformatted')
+! write(27) c66store
+! close(27)
+!
+! endif
+!
+!! additional ocean load mass matrix if oceans
+! if(OCEANS) then
+! open(unit=27,file=prname(1:len_trim(prname))//'rmass_ocean_load.bin',status='unknown',form='unformatted')
+! write(27) rmass_ocean_load
+! close(27)
+! endif
+!
+!! boundary parameters
+! open(unit=27,file=prname(1:len_trim(prname))//'ibelm.bin',status='unknown',form='unformatted')
+! write(27) ibelm_xmin
+! write(27) ibelm_xmax
+! write(27) ibelm_ymin
+! write(27) ibelm_ymax
+! write(27) ibelm_bottom
+! write(27) ibelm_top
+! close(27)
+!
+! open(unit=27,file=prname(1:len_trim(prname))//'normal.bin',status='unknown',form='unformatted')
+! write(27) normal_xmin
+! write(27) normal_xmax
+! write(27) normal_ymin
+! write(27) normal_ymax
+! write(27) normal_bottom
+! write(27) normal_top
+! close(27)
+!
+! open(unit=27,file=prname(1:len_trim(prname))//'jacobian2D.bin',status='unknown',form='unformatted')
+! write(27) jacobian2D_xmin
+! write(27) jacobian2D_xmax
+! write(27) jacobian2D_ymin
+! write(27) jacobian2D_ymax
+! write(27) jacobian2D_bottom
+! write(27) jacobian2D_top
+! close(27)
+!
+! open(unit=27,file=prname(1:len_trim(prname))//'nspec2D.bin',status='unknown',form='unformatted')
+! write(27) nspec2D_xmin
+! write(27) nspec2D_xmax
+! write(27) nspec2D_ymin
+! write(27) nspec2D_ymax
+! close(27)
+!
+!! MPI cut-planes parameters along xi and along eta
+! open(unit=27,file=prname(1:len_trim(prname))//'iMPIcut_xi.bin',status='unknown',form='unformatted')
+! write(27) iMPIcut_xi
+! close(27)
+!
+! open(unit=27,file=prname(1:len_trim(prname))//'iMPIcut_eta.bin',status='unknown',form='unformatted')
+! write(27) iMPIcut_eta
+! close(27)
+!
+!! mesh arrays used in the solver to locate source and receivers
+!! use rmass for temporary storage to perform conversion, since already saved
+!
+!!--- x coordinate
+! rmass(:) = 0._CUSTOM_REAL
+! do ispec = 1,nspec
+! do k = 1,NGLLZ
+! do j = 1,NGLLY
+! do i = 1,NGLLX
+! iglob = ibool(i,j,k,ispec)
+!! distinguish between single and double precision for reals
+! if(CUSTOM_REAL == SIZE_REAL) then
+! rmass(iglob) = sngl(xstore(i,j,k,ispec))
+! else
+! rmass(iglob) = xstore(i,j,k,ispec)
+! endif
+! enddo
+! enddo
+! enddo
+! enddo
+! open(unit=27,file=prname(1:len_trim(prname))//'x.bin',status='unknown',form='unformatted')
+! write(27) rmass
+! close(27)
+!
+!!--- y coordinate
+! rmass(:) = 0._CUSTOM_REAL
+! do ispec = 1,nspec
+! do k = 1,NGLLZ
+! do j = 1,NGLLY
+! do i = 1,NGLLX
+! iglob = ibool(i,j,k,ispec)
+!! distinguish between single and double precision for reals
+! if(CUSTOM_REAL == SIZE_REAL) then
+! rmass(iglob) = sngl(ystore(i,j,k,ispec))
+! else
+! rmass(iglob) = ystore(i,j,k,ispec)
+! endif
+! enddo
+! enddo
+! enddo
+! enddo
+! open(unit=27,file=prname(1:len_trim(prname))//'y.bin',status='unknown',form='unformatted')
+! write(27) rmass
+! close(27)
+!
+!!--- z coordinate
+! rmass(:) = 0._CUSTOM_REAL
+! do ispec = 1,nspec
+! do k = 1,NGLLZ
+! do j = 1,NGLLY
+! do i = 1,NGLLX
+! iglob = ibool(i,j,k,ispec)
+!! distinguish between single and double precision for reals
+! if(CUSTOM_REAL == SIZE_REAL) then
+! rmass(iglob) = sngl(zstore(i,j,k,ispec))
+! else
+! rmass(iglob) = zstore(i,j,k,ispec)
+! endif
+! enddo
+! enddo
+! enddo
+! enddo
+! open(unit=27,file=prname(1:len_trim(prname))//'z.bin',status='unknown',form='unformatted')
+! write(27) rmass
+! close(27)
+!
+! end subroutine save_arrays_solver
+!
+!!=============================================================
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/save_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/save_header_file.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/save_header_file.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -27,18 +27,17 @@
subroutine save_header_file(NSPEC_AB,NGLOB_AB,NPROC, &
ATTENUATION,ANISOTROPY,NSTEP,DT, &
- NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,SIMULATION_TYPE,static_memory_size)
+ SIMULATION_TYPE,static_memory_size)
implicit none
include "constants.h"
! number of points per surface element
- integer, parameter :: NGLLSQUARE = NGLLX * NGLLY
integer, parameter :: NGLLSQUARE_NDIM = NGLLSQUARE * NDIM
- integer NSPEC_AB,NGLOB_AB,NPROC,NSTEP, &
- NPOIN2DMAX_XY,NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,SIMULATION_TYPE
+ integer NSPEC_AB,NGLOB_AB,NPROC,NSTEP,SIMULATION_TYPE
+ ! NPOIN2DMAX_XY,NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,
logical ATTENUATION,ANISOTROPY
@@ -52,7 +51,7 @@
call get_value_string(HEADER_FILE, 'solver.HEADER_FILE', 'OUTPUT_FILES/values_from_mesher.h')
! define maximum size for message buffers
- NPOIN2DMAX_XY = max(NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX)
+ !NPOIN2DMAX_XY = max(NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX)
open(unit=IOUT,file=HEADER_FILE,status='unknown')
write(IOUT,*)
@@ -98,6 +97,7 @@
! write(IOUT,*) '! total elements per AB slice = ',NSPEC_AB
! write(IOUT,*) '! total points per AB slice = ',NGLOB_AB
+ write(IOUT,*) '! not valid for external mesh files: total points per AB slice = ',NGLOB_AB
write(IOUT,*) '! total elements per AB slice = (will be read in external file)'
write(IOUT,*) '! total points per AB slice = (will be read in external file)'
write(IOUT,*) '!'
@@ -132,6 +132,7 @@
write(IOUT,*) '! integer, parameter :: NSPEC_ATTENUATION = ', 1
! write(IOUT,*) '! logical, parameter :: ATTENUATION_VAL = .false.'
endif
+
write(IOUT,*)
! anisotropy
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/serial.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/serial.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/serial.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -123,6 +123,26 @@
!----
!
+ subroutine gatherv_all_cr(sendbuf, sendcnt, recvbuf, recvcount, recvoffset,recvcounttot, NPROC)
+
+ implicit none
+
+ include "constants.h"
+
+ integer sendcnt,recvcounttot,NPROC
+ integer, dimension(NPROC) :: recvcount,recvoffset
+ real(kind=CUSTOM_REAL), dimension(sendcnt) :: sendbuf
+ real(kind=CUSTOM_REAL), dimension(recvcounttot) :: recvbuf
+
+ recvbuf(:) = sendbuf(:)
+
+ end subroutine gatherv_all_cr
+
+!
+!----
+!
+
+
subroutine init()
end subroutine init
@@ -206,8 +226,6 @@
end subroutine max_all_cr
-
-
!
!----
!
@@ -224,13 +242,37 @@
end subroutine min_all_cr
+!
+!----
+!
+ subroutine max_all_i(sendbuf, recvbuf)
+ implicit none
+ integer :: sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine max_all_i
+
!
!----
!
+ subroutine min_all_i(sendbuf, recvbuf)
+ implicit none
+ integer:: sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine min_all_i
+
+!
+!----
+!
+
+
subroutine sum_all_dp(sendbuf, recvbuf)
implicit none
@@ -281,3 +323,137 @@
integer function proc_null()
proc_null = 0
end function proc_null
+
+!
+!----
+!
+
+ subroutine issend_cr(sendbuf, sendcount, dest, sendtag, req)
+
+ implicit none
+
+ integer sendcount, dest, sendtag, req
+ real(kind=CUSTOM_REAL), dimension(sendcount) :: sendbuf
+
+ stop 'issend_cr not implemented for serial code'
+
+ end subroutine issend_cr
+
+!
+!----
+!
+
+ subroutine irecv_cr(recvbuf, recvcount, dest, recvtag, req)
+
+ implicit none
+
+
+ integer recvcount, dest, recvtag, req
+ real(kind=CUSTOM_REAL), dimension(recvcount) :: recvbuf
+
+ stop 'irecv_cr not implemented for serial code'
+
+ end subroutine irecv_cr
+
+!
+!----
+!
+
+ subroutine issend_i(sendbuf, sendcount, dest, sendtag, req)
+
+ implicit none
+
+ integer sendcount, dest, sendtag, req
+ integer, dimension(sendcount) :: sendbuf
+
+ stop 'issend_i not implemented for serial code'
+
+ end subroutine issend_i
+
+!
+!----
+!
+
+ subroutine irecv_i(recvbuf, recvcount, dest, recvtag, req)
+
+ implicit none
+
+ integer recvcount, dest, recvtag, req
+ integer, dimension(recvcount) :: recvbuf
+
+ stop 'irecv_i not implemented for serial code'
+
+ end subroutine irecv_i
+
+
+!
+!----
+!
+
+ subroutine recv_i(recvbuf, recvcount, dest, recvtag )
+
+ implicit none
+
+ integer recvbuf,recvcount,dest,recvtag
+
+ stop 'recv_i not implemented for serial code'
+
+ end subroutine recv_i
+
+!
+!----
+!
+
+ subroutine recvv_cr(recvbuf, recvcount, dest, recvtag )
+
+ implicit none
+
+ integer recvcount,dest,recvtag
+ real(kind=CUSTOM_REAL),dimension(recvcount) :: recvbuf
+
+ stop 'recvv_cr not implemented for serial code'
+
+ end subroutine recvv_cr
+
+
+!
+!----
+!
+
+ subroutine send_i(sendbuf, sendcount, dest, sendtag)
+
+ implicit none
+
+ integer sendbuf,sendcount,dest,sendtag
+
+ stop 'send_i not implemented for serial code'
+
+ end subroutine send_i
+
+
+!
+!----
+!
+
+ subroutine sendv_cr(sendbuf, sendcount, dest, sendtag)
+
+ implicit none
+
+ integer sendcount,dest,sendtag
+ real(kind=CUSTOM_REAL),dimension(sendcount) :: sendbuf
+
+ stop 'sendv_cr not implemented for serial code'
+
+ end subroutine sendv_cr
+!
+!----
+!
+
+ subroutine wait_req(req)
+
+ implicit none
+
+ integer :: req
+
+ end subroutine wait_req
+
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -244,9 +244,10 @@
endif
enddo ! NSPEC_AB
- if (myrank == 0) then
- print *, nfaces_perproc_surface_ext_mesh
- print *, nfaces_surface_glob_ext_mesh
+ if (myrank == 0) then
+ write(IMAIN,*) 'movie: nfaces_surface_external_mesh = ',nfaces_surface_external_mesh
+ write(IMAIN,*) 'movie: nfaces_perproc_surface_ext_mesh = ',nfaces_perproc_surface_ext_mesh
+ write(IMAIN,*) 'movie: nfaces_surface_glob_ext_mesh = ',nfaces_surface_glob_ext_mesh
endif
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -72,19 +72,38 @@
character(len=100) topo_file
integer, dimension(:,:), allocatable :: itopo_bathy
- integer :: NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext
- integer, dimension(:), allocatable :: ibelm_xmin,ibelm_xmax
- integer, dimension(:), allocatable :: ibelm_ymin,ibelm_ymax
- integer, dimension(:), allocatable :: ibelm_bottom
+! absorbing boundaries
+! integer, dimension(:), allocatable :: ibelm_xmin,ibelm_xmax
+! integer, dimension(:), allocatable :: ibelm_ymin,ibelm_ymax
+! integer, dimension(:), allocatable :: ibelm_bottom
+! integer, dimension(:), allocatable :: ibelm_top
+!! integer :: NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext
+! ! local indices i,j,k of all GLL points on xmin boundary in the element
+! integer,dimension(:,:,:,:),allocatable :: ibelm_gll_xmin,ibelm_gll_xmax, &
+! ibelm_gll_ymin,ibelm_gll_ymax, &
+! ibelm_gll_bottom,ibelm_gll_top
+! real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_xmin,jacobian2D_xmax
+! real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_ymin,jacobian2D_ymax
+! real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_bottom
+! real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_top
+! real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_xmin,normal_xmax
+! real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_ymin,normal_ymax
+! real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_bottom
+! real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_top
+
+! absorbing boundary arrays (for all boundaries) - keeps all infos, allowing for irregular surfaces
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: absorbing_boundary_normal
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: absorbing_boundary_jacobian2D
+ integer, dimension(:,:,:), allocatable :: absorbing_boundary_ijk
+ integer, dimension(:), allocatable :: absorbing_boundary_ispec
+ integer :: num_absorbing_boundary_faces
+
+! free surface
+ integer :: nspec2D_top,ispec2D
integer, dimension(:), allocatable :: ibelm_top
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_xmin,jacobian2D_xmax
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_ymin,jacobian2D_ymax
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_bottom
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_top
real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_top
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_xmin,normal_xmax
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_ymin,normal_ymax
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_bottom
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_top
+ real(kind=CUSTOM_REAL) :: nx,ny,nz
!! DK DK array not created yet for CUBIT
! integer, dimension(NSPEC2D_TOP_VAL) :: ibelm_top
@@ -281,17 +300,19 @@
! parameters deduced from parameters read from file
integer NPROC
- integer NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC_AB, NGLOB_AB
+ !integer :: NSPEC2D_BOTTOM
+ !integer :: NSPEC2D_TOP
+
+ integer :: NSPEC_AB, NGLOB_AB
! names of the data files for all the processors in MPI
character(len=150) outputname
! Stacey conditions put back
- integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,ispec2D
- real(kind=CUSTOM_REAL) nx,ny,nz
- integer, dimension(:,:),allocatable :: nimin,nimax,nkmin_eta
- integer, dimension(:,:),allocatable :: njmin,njmax,nkmin_xi
+ !integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,ispec2D
+ !real(kind=CUSTOM_REAL) nx,ny,nz
+ !integer, dimension(:,:),allocatable :: nimin,nimax,nkmin_eta
+ !integer, dimension(:,:),allocatable :: njmin,njmax,nkmin_xi
! to save movie frames
integer ipoin, nmovie_points, iloc, iorderi(NGNOD2D), iorderj(NGNOD2D)
@@ -352,7 +373,6 @@
logical, dimension(:), allocatable :: iglob_is_inner_ext_mesh
integer :: iinterface
-!daniel
! integer, dimension(:),allocatable :: spec_inner, spec_outer
! integer :: nspec_inner,nspec_outer
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/write_seismograms.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/write_seismograms.f90 2009-10-19 19:59:18 UTC (rev 15849)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/write_seismograms.f90 2009-10-20 02:18:56 UTC (rev 15850)
@@ -49,6 +49,11 @@
character(len=1) component
character(len=150) sisname,clean_LOCAL_PATH,final_LOCAL_PATH
+! parameters for master collects seismograms
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: one_seismogram
+ integer :: nrec_local_received,NPROCTOT,total_seismos,receiver,sender
+ integer :: iproc,ier
+
! save displacement, velocity or acceleration
if(istore == 1) then
component = 'd'
@@ -60,75 +65,219 @@
call exit_MPI(myrank,'wrong component to save for seismograms')
endif
- do irec_local = 1,nrec_local
+! all the processes write their local seismograms themselves
+ if( .not. WRITE_SEISMOGRAMS_BY_MASTER ) then
+ do irec_local = 1,nrec_local
+
! get global number of that receiver
- irec = number_receiver_global(irec_local)
+ irec = number_receiver_global(irec_local)
! save three components of displacement vector
- irecord = 1
+ irecord = 1
- do iorientation = 1,NDIM
+ do iorientation = 1,NDIM
- if(iorientation == 1) then
- chn = 'BHE'
- else if(iorientation == 2) then
- chn = 'BHN'
- else if(iorientation == 3) then
- chn = 'BHZ'
- else
- call exit_MPI(myrank,'incorrect channel value')
- endif
+ if(iorientation == 1) then
+ chn = 'BHE'
+ else if(iorientation == 2) then
+ chn = 'BHN'
+ else if(iorientation == 3) then
+ chn = 'BHZ'
+ else
+ call exit_MPI(myrank,'incorrect channel value')
+ endif
! create the name of the seismogram file for each slice
! file name includes the name of the station, the network and the component
- length_station_name = len_trim(station_name(irec))
- length_network_name = len_trim(network_name(irec))
+ length_station_name = len_trim(station_name(irec))
+ length_network_name = len_trim(network_name(irec))
! check that length conforms to standard
- if(length_station_name < 1 .or. length_station_name > MAX_LENGTH_STATION_NAME) &
+ if(length_station_name < 1 .or. length_station_name > MAX_LENGTH_STATION_NAME) &
call exit_MPI(myrank,'wrong length of station name')
- if(length_network_name < 1 .or. length_network_name > MAX_LENGTH_NETWORK_NAME) &
+ if(length_network_name < 1 .or. length_network_name > MAX_LENGTH_NETWORK_NAME) &
call exit_MPI(myrank,'wrong length of network name')
- write(sisname,"(a,'.',a,'.',a3,'.sem',a1)") station_name(irec)(1:length_station_name),&
+ write(sisname,"(a,'.',a,'.',a3,'.sem',a1)") station_name(irec)(1:length_station_name),&
network_name(irec)(1:length_network_name),chn,component
+! directory to store seismograms
+ if( USE_OUTPUT_FILES_PATH ) then
+ final_LOCAL_PATH = 'OUTPUT_FILES'//'/'
+ else
! suppress white spaces if any
- clean_LOCAL_PATH = adjustl(LOCAL_PATH)
-
+ clean_LOCAL_PATH = adjustl(LOCAL_PATH)
! create full final local path
- final_LOCAL_PATH = clean_LOCAL_PATH(1:len_trim(clean_LOCAL_PATH)) // '/'
-
+ final_LOCAL_PATH = clean_LOCAL_PATH(1:len_trim(clean_LOCAL_PATH)) // '/'
+ endif
+
+
! save seismograms in text format with no subsampling.
! Because we do not subsample the output, this can result in large files
! if the simulation uses many time steps. However, subsampling the output
! here would result in a loss of accuracy when one later convolves
! the results with the source time function
- open(unit=IOUT,file=final_LOCAL_PATH(1:len_trim(final_LOCAL_PATH))//sisname(1:len_trim(sisname)),status='unknown')
+ open(unit=IOUT,file=final_LOCAL_PATH(1:len_trim(final_LOCAL_PATH))//sisname(1:len_trim(sisname)),status='unknown')
! make sure we never write more than the maximum number of time steps
! subtract half duration of the source to make sure travel time is correct
- do isample = 1,min(it,NSTEP)
- if(irecord == 1) then
+ do isample = 1,min(it,NSTEP)
+ if(irecord == 1) then
! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- write(IOUT,*) sngl(dble(isample-1)*DT - hdur),' ',seismograms(iorientation,irec_local,isample)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ write(IOUT,*) sngl(dble(isample-1)*DT - hdur),' ',seismograms(iorientation,irec_local,isample)
+ else
+ write(IOUT,*) dble(isample-1)*DT - hdur,' ',seismograms(iorientation,irec_local,isample)
+ endif
else
- write(IOUT,*) dble(isample-1)*DT - hdur,' ',seismograms(iorientation,irec_local,isample)
+ call exit_MPI(myrank,'incorrect record label')
endif
+ enddo
+
+ close(IOUT)
+
+ enddo ! NDIM
+
+ enddo ! nrec_local
+
+! now only the master process does the writing of seismograms and
+! collects the data from all other processes
+ else ! WRITE_SEISMOGRAMS_BY_MASTER
+
+ allocate(one_seismogram(NDIM,NSTEP),stat=ier)
+ if(ier /= 0) stop 'error while allocating one temporary seismogram'
+
+
+ if(myrank == 0) then ! on the master, gather all the seismograms
+
+ total_seismos = 0
+
+ ! loop on all the slices
+ call world_size(NPROCTOT)
+ do iproc = 0,NPROCTOT-1
+
+ ! receive except from proc 0, which is me and therefore I already have this value
+ sender = iproc
+ if(iproc /= 0) then
+ call recv_i(nrec_local_received,1,sender,itag)
+ if(nrec_local_received < 0) call exit_MPI(myrank,'error while receiving local number of receivers')
else
- call exit_MPI(myrank,'incorrect record label')
+ nrec_local_received = nrec_local
endif
- enddo
+
+ if (nrec_local_received > 0) then
+ do irec_local = 1,nrec_local_received
+ ! receive except from proc 0, which is myself and therefore I already have these values
+ if(iproc == 0) then
+ ! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+ one_seismogram(:,:) = seismograms(:,irec_local,:)
+ else
+ call recv_i(irec,1,sender,itag)
+ if(irec < 1 .or. irec > nrec) call exit_MPI(myrank,'error while receiving global receiver number')
+
+ call recvv_cr(one_seismogram,NDIM*NSTEP,sender,itag)
+ endif
- close(IOUT)
+ total_seismos = total_seismos + 1
- enddo
+! save three components of displacement vector
+ irecord = 1
- enddo
+ do iorientation = 1,NDIM
+ if(iorientation == 1) then
+ chn = 'BHE'
+ else if(iorientation == 2) then
+ chn = 'BHN'
+ else if(iorientation == 3) then
+ chn = 'BHZ'
+ else
+ call exit_MPI(myrank,'incorrect channel value')
+ endif
+
+! create the name of the seismogram file for each slice
+! file name includes the name of the station, the network and the component
+ length_station_name = len_trim(station_name(irec))
+ length_network_name = len_trim(network_name(irec))
+
+! check that length conforms to standard
+ if(length_station_name < 1 .or. length_station_name > MAX_LENGTH_STATION_NAME) &
+ call exit_MPI(myrank,'wrong length of station name')
+
+ if(length_network_name < 1 .or. length_network_name > MAX_LENGTH_NETWORK_NAME) &
+ call exit_MPI(myrank,'wrong length of network name')
+
+ write(sisname,"(a,'.',a,'.',a3,'.sem',a1)") station_name(irec)(1:length_station_name),&
+ network_name(irec)(1:length_network_name),chn,component
+
+! directory to store seismograms
+ if( USE_OUTPUT_FILES_PATH ) then
+ final_LOCAL_PATH = 'OUTPUT_FILES'//'/'
+ else
+! suppress white spaces if any
+ clean_LOCAL_PATH = adjustl(LOCAL_PATH)
+! create full final local path
+ final_LOCAL_PATH = clean_LOCAL_PATH(1:len_trim(clean_LOCAL_PATH)) // '/'
+ endif
+
+! save seismograms in text format with no subsampling.
+! Because we do not subsample the output, this can result in large files
+! if the simulation uses many time steps. However, subsampling the output
+! here would result in a loss of accuracy when one later convolves
+! the results with the source time function
+ open(unit=IOUT,file=final_LOCAL_PATH(1:len_trim(final_LOCAL_PATH))//sisname(1:len_trim(sisname)),status='unknown')
+
+! make sure we never write more than the maximum number of time steps
+! subtract half duration of the source to make sure travel time is correct
+ do isample = 1,min(it,NSTEP)
+ if(irecord == 1) then
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ write(IOUT,*) sngl(dble(isample-1)*DT - hdur),' ',one_seismogram(iorientation,isample)
+ else
+ write(IOUT,*) dble(isample-1)*DT - hdur,' ',one_seismogram(iorientation,isample)
+ endif
+ else
+ call exit_MPI(myrank,'incorrect record label')
+ endif
+ enddo
+
+ close(IOUT)
+
+ enddo ! NDIM
+ enddo ! nrec_local_received
+ endif ! if(nrec_local_received > 0 )
+ enddo ! NPROCTOT-1
+
+ write(IMAIN,*) 'Component: .sem'//component
+ write(IMAIN,*) ' total number of receivers saved is ',total_seismos,' out of ',nrec
+ write(IMAIN,*)
+
+ if(total_seismos /= nrec) call exit_MPI(myrank,'incorrect total number of receivers saved')
+
+ else ! on the nodes, send the seismograms to the master
+ receiver = 0
+ call send_i(nrec_local,1,receiver,itag)
+ if (nrec_local > 0) then
+ do irec_local = 1,nrec_local
+ ! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+ call send_i(irec,1,receiver,itag)
+
+ ! sends seismogram of that receiver
+ one_seismogram(:,:) = seismograms(:,irec_local,:)
+ call sendv_cr(one_seismogram,NDIM*NSTEP,receiver,itag)
+ enddo
+ endif
+ endif ! myrank
+
+ deallocate(one_seismogram)
+
+ endif ! WRITE_SEISMOGRAMS_BY_MASTER
+
end subroutine write_seismograms
!=====================================================================
More information about the CIG-COMMITS
mailing list