[cig-commits] r18316 - in seismo/3D/FAULT_SOURCE/branches/new_fault_db: . decompose_mesh_SCOTCH src src/devel
percygalvez at geodynamics.org
percygalvez at geodynamics.org
Wed May 4 14:26:06 PDT 2011
Author: percygalvez
Date: 2011-05-04 14:26:06 -0700 (Wed, 04 May 2011)
New Revision: 18316
Added:
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/PML_init.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/aniso_model.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/ascii_2_sep.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/assemble_MPI_scalar.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/assemble_MPI_vector.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/calc_jacobian.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/check_buffers_2D.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/check_mesh_resolution.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/combine_AVS_DX.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/combine_surf_data.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/combine_vol_data.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/comp_source_time_function.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_add_sources_acoustic.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_add_sources_elastic.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_arrays_source.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_boundary_kernel.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_coupling_acoustic_el.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_coupling_elastic_ac.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_acoustic.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_acoustic_PML.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_acoustic_pot.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_elastic.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_elastic_Dev.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_elastic_noDev.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_gradient.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_interpolated_dva.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_parameters.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_rho_estimate.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_stacey_acoustic.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_stacey_elastic.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/convolve_source_timefunction.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_header_file.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_mass_matrices.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_movie_shakemap_AVS_DX_GMT.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_name_database.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_regions_mesh.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_regions_mesh_ext_par.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_regions_mesh_par.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_serial_name_database.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/define_derivation_matrices.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/define_subregions.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/define_subregions_heuristic.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/detect_mesh_surfaces.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/detect_surface.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/devel/
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/devel/fault_solver.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/devel/fault_solver_kinematic.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/exit_mpi.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/fault_ibool.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/fault_object.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/fault_solver.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/fault_solver_kinematic.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/finalize_simulation.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/generate_databases.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_MPI.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_MPI_cutplanes_eta.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_MPI_cutplanes_xi.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_absorb.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_absorbing_boundary.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_attenuation_model.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_cmt.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_coupling_domain1_domain2.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_coupling_surfaces.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_element_face.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_flags_boundaries.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_global.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_jacobian_boundaries.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_model.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_shape2D.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_shape3D.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_value_parameters.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/gll_library.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/hauksson_model.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/hex_nodes.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/initialize_simulation.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/interpolate_gocad_block_HR.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/interpolate_gocad_block_MR.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/iterate_time.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/lagrange_poly.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/locate_receivers.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/locate_source.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/memory_eval.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/mesh_vertical.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/model_aniso.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/model_external_values.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/model_interface_bedrock.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/model_tomography.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/netlib_specfun_erf.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/numbering.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/parallel.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/param_reader.c
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/prepare_assemble_MPI.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/prepare_timerun.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/program_create_header_file.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/program_generate_databases.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/program_specfem3D.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_arrays_buffers_solver.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_arrays_solver.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_mesh_databases.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_moho_map.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_parameter_file.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_topo_bathy_file.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_topography_bathymetry.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_value_parameters.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/recompute_jacobian.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/salton_trough_gocad.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/save_adjoint_kernels.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/save_arrays_solver.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/save_header_file.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/save_moho_arrays.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/serial.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/setup_GLL_points.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/setup_movie_meshes.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/setup_sources_receivers.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/socal_model.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/sort_array_coordinates.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/specfem3D.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/specfem3D_par.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/utm_geo.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_AVS_DX_global_data.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_AVS_DX_global_faces_data.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_AVS_DX_surface_data.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_PNM_GIF_data.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_VTK_data.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_c_binary.c
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_movie_output.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_seismograms.f90
Modified:
seismo/3D/FAULT_SOURCE/branches/new_fault_db/decompose_mesh_SCOTCH/Makefile
seismo/3D/FAULT_SOURCE/branches/new_fault_db/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90
seismo/3D/FAULT_SOURCE/branches/new_fault_db/decompose_mesh_SCOTCH/fault_scotch.f90
Log:
new database updated
Modified: seismo/3D/FAULT_SOURCE/branches/new_fault_db/decompose_mesh_SCOTCH/Makefile
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/decompose_mesh_SCOTCH/Makefile 2011-05-04 20:33:56 UTC (rev 18315)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/decompose_mesh_SCOTCH/Makefile 2011-05-04 21:26:06 UTC (rev 18316)
@@ -6,13 +6,14 @@
F90 = gfortran # use -Wall
## modify to match your library paths
-SCOTCH_LIBS = -L/SCOTCH_LIB_PATH -lscotch -lscotcherr
+SCOTCH_LIBS = -L/home/galvez/scotch/scotch_5.1/lib/ -lscotch -lscotcherr
#(SCOTCH library address .Change it in case
#your SCOTH is install in another address)
#############################################################
-LIBS = part_decompose_mesh_SCOTCH.o \
+LIBS = fault_scotch.o\
+ part_decompose_mesh_SCOTCH.o \
decompose_mesh_SCOTCH.o \
program_decompose_mesh_SCOTCH.o
@@ -22,6 +23,8 @@
xdecompose_mesh_SCOTCH: $(LIBS)
${F90} -o xdecompose_mesh_SCOTCH $(LIBS) $(SCOTCH_LIBS)
+fault_scotch.o : fault_scotch.f90
+ ${F90} -c fault_scotch.f90
part_decompose_mesh_SCOTCH.o: part_decompose_mesh_SCOTCH.f90
${F90} -c part_decompose_mesh_SCOTCH.f90
Modified: seismo/3D/FAULT_SOURCE/branches/new_fault_db/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90 2011-05-04 20:33:56 UTC (rev 18315)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/decompose_mesh_SCOTCH/decompose_mesh_SCOTCH.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -390,12 +390,18 @@
! Percy & JPA
- ! -----------------------------------
+ ! ------------------------------------------------------------
! Reading fault elements
- ! ----------------------------------
+ ! -------------------------------------------------------------
call read_fault_files()
-
+ !--------------------------------------------------------------
+ ! close_fault_crack
+ !--------------------------------------------------------------
+
+ call close_faults(nodes_coords,elmnts,nspec,nnodes,esize)
+
+
end subroutine read_mesh_files
!----------------------------------------------------------------------------------------------
@@ -544,7 +550,7 @@
! FAULT : output part(0) : contains all fault elements
! : fault_ispec1,fault_ispec2 (fault elements side1 and side2)
! : fault_iface1,fault_iface2 (fault faces side2 and side2)
- call fault_collecting_elements(nspec,nnodes,elmnts, &
+ call fault_collect_elements(nspec,nnodes,elmnts, &
sup_neighbour,esize,nsize,nparts,part)
! re-partitioning puts moho-surface coupled elements into same partition
@@ -576,12 +582,7 @@
! count_def_mat, mat_prop(3,:), mat(1,:), nparts)
- !------------------------------------------------
- ! close_fault_crack
- !------------------------------------------------
- call close_faults(nodes_coords,elmnts,nspec,nnodes,esize)
-
end subroutine scotch_partitioning
@@ -635,11 +636,6 @@
glob2loc_elmnts, glob2loc_nodes_nparts, &
glob2loc_nodes_parts, glob2loc_nodes, part, mat, ngnod, 1)
-! FAULT : get number of fault spectral elements procxxxx_..._fault
- call write_partion_fault_database(16, ipart, nspec, elmnts, &
- glob2loc_elmnts,part,1)
-
-
! writes out node coordinate locations
write(15,*) nnodes_loc
@@ -659,8 +655,8 @@
! FAULT : Writting out procxxxx_..._fault
- call write_partion_fault_database(16, ipart, nspec, elmnts, &
- glob2loc_elmnts,part, 2)
+ call write_partion_fault_database(16, ipart, nspec, &
+ glob2loc_elmnts,part)
! writes out absorbing/free-surface boundaries
Modified: seismo/3D/FAULT_SOURCE/branches/new_fault_db/decompose_mesh_SCOTCH/fault_scotch.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/decompose_mesh_SCOTCH/fault_scotch.f90 2011-05-04 20:33:56 UTC (rev 18315)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/decompose_mesh_SCOTCH/fault_scotch.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -1,39 +1,48 @@
- module fault_scotch
+module fault_scotch
implicit none
- type(bc_fault)
- private
- integer :: nspec
- integer, dimension(:), pointer :: ispec1, ispec2, iface1, iface2
- end type
+ private
+
+ type fault_type
+ private
+ integer :: nspec
+ integer, dimension(:), pointer :: ispec1, ispec2, iface1, iface2
+ end type fault_type
- type(bc_fault), allocatable, save :: faults(:)
+ type(fault_type), allocatable, save :: faults(:)
- integer :: nspec_fault_side1, nspec_fault_side2, nspec_fault
+ ! PRESICION
+ integer, parameter :: SIZE_REAL = 4 ! single precision
+ integer, parameter :: SIZE_DOUBLE = 8 ! double precision
+ integer, parameter :: CUSTOM_REAL = SIZE_REAL
+ integer, parameter :: short = SELECTED_INT_KIND(4), long = SELECTED_INT_KIND(18)
+
+ real(kind=CUSTOM_REAL), parameter :: FAULT_GAP_TOLERANCE = 1e-2_CUSTOM_REAL
- integer , dimension(:),allocatable :: ispec1 ,ispec2, iface1, iface2
+ public :: read_fault_files, fault_collect_elements, close_faults
- public read_fault_files,fault_collecting_elements
-
-
- CONTAINS
+CONTAINS
!==========================================================================================
Subroutine read_fault_files
- integer :: nbfaults ,iflt
+ integer :: nbfaults, iflt, ier
- open(1,file='../DATA/FAULT/Par_file_faults.in',status='old',action='read',iostat=ier)
- if (ier==0) then
- read(1,*) nbfaults
- allocate(faults(nbfaults))
- do iflt = 1 , nbfaults
- call read_single_fault_file(faults(iflt),iflt)
- enddo
- else
- print*, 'Par_file.in has not been found'
- endif
- close(1)
+ open(101,file='../DATA/FAULT/Par_file_faults.in',status='old',action='read',iostat=ier)
+ if (ier==0) then
+ read(101,*) nbfaults
+ else
+ print *, 'Par_file.in not found: assume no faults'
+ endif
+ close(101)
+
+ if (nbfaults>0) then
+ allocate(faults(nbfaults))
+ do iflt = 1 , nbfaults
+ call read_single_fault_file(faults(iflt),iflt)
+ enddo
+ endif
+
end subroutine read_fault_files
@@ -42,156 +51,201 @@
Subroutine read_single_fault_file(bcfault,ifault)
! INPUTS :
- type(bc_fault),intent(inout) :: bcfault
+ type(fault_type), intent(inout) :: bcfault
- integer,intent(in) :: ifault
- character(len=10) :: NTchar
+ integer,intent(in) :: ifault
+ character(len=5) :: NTchar
+ integer :: i,j
-
- write(NTchar,1) ifault
- NTchar = adjustl(NTchar)
-1 format(I5)
+ write(NTchar,'(I5)') ifault
+ NTchar = adjustl(NTchar)
- open(1,file='../DATA/FAULT/fault_nodes'//NTCHAR//'.dat',status='old',action='read',iostat=ier)
- if( ier == 0 ) then
- read(1,*) bcfault%nspec
- allocate(bcfault%ispec1(bcfault%nspec))
- allocate(bcfault%ispec2(bcfault%nspec))
- allocate(bcfault%iface1(bcfault%nspec))
- allocate(bcfault%iface2(bcfault%nspec))
- do j=1,bcfault%nspec
- read(1,*) bcfault%ispec1(j),bcfault%ispec2(j),bcfault%iface1(j),bcfault%iface2(j)
- enddo
- else
- write(6,*) 'fault_nodes.dat does not exit , no fault detected in the domain'
- endif
- close(1)
+ open(101,file='../DATA/FAULT/fault_elements_'//NTCHAR//'.dat', &
+ status='old',action='read',iostat=ier)
+
+ if( ier == 0 ) then
+ read(101,*) bcfault%nspec
+ allocate(bcfault%ispec1(bcfault%nspec))
+ allocate(bcfault%ispec2(bcfault%nspec))
+ allocate(bcfault%iface1(bcfault%nspec))
+ allocate(bcfault%iface2(bcfault%nspec))
+ do j=1,bcfault%nspec
+ read(101,*) bcfault%ispec1(j),bcfault%ispec2(j),bcfault%iface1(j),bcfault%iface2(j)
+ enddo
+ else
+ write(6,*) 'Fatal error: file ../DATA/FAULT/fault_elements_'//NTCHAR//'.dat not found'
+ write(6,*) 'Abort'
+ stop
+ endif
+ close(101)
end Subroutine read_single_fault_file
+! ---------------------------------------------------------------------------------------------------
+!
+
+ subroutine close_faults(nodes_coords,elmnts,nelmnts,nnodes,esize)
+
+ integer ,intent(in) :: nnodes, esize, nelmnts
+ integer, dimension(3,nnodes), intent(in) :: nodes_coords
+ integer, dimension(esize,nelmnts), intent(in) :: elmnts
+
+ integer :: iflt
+
+ do iflt=1,size(faults)
+ call close_fault_single(faults(iflt)%ispec1,faults(iflt)%ispec2, &
+ elmnts,nodes_coords,nnodes,esize,nelmnts)
+ enddo
+
+ end subroutine close_faults
+
+! ---------------------------------------------------------------------------------------------------
+ subroutine close_fault_single(ispec1,ispec2,elmnts,nodes_coords,nnodes,esize,nelmnts)
+
+ integer ,intent(in) :: nnodes, esize, nelmnts
+ integer, dimension(esize,nelmnts), intent(in) :: elmnts
+ integer , dimension(:), intent(in) :: ispec1,ispec2
+ real(kind=CUSTOM_REAL),dimension(3,nnodes),target, intent(inout) :: nodes_coords
+
+ real(kind=CUSTOM_REAL), dimension(3),pointer :: xyz_1 =>null(),xyz_2=>null()
+ real(kind=CUSTOM_REAL), dimension(3) :: xyz
+
+ real(kind=CUSTOM_REAL) :: dist
+ integer :: iglob1, iglob2, i, j, k1, k2
+ logical :: found_it
+
+ do i = 1,size(ispec2)
+ do k2=1,esize
+
+ iglob2 = elmnts(k2,ispec2(i))
+ found_it = .false.
+ xyz_2 => nodes_coords(:,iglob2)
+
+ do j = 1,size(ispec1)
+ do k1=1,esize
+
+ iglob1 = elmnts(k1,ispec1(j))
+ xyz_1 => nodes_coords(:,iglob1)
+
+ xyz = xyz_2-xyz_1
+ dist = xyz(1)*xyz(1) + xyz(2)*xyz(2) + xyz(3)*xyz(3)
+ dist = sqrt(dist)
+
+ if (dist <= FAULT_GAP_TOLERANCE) then
+ xyz = (xyz_1 + xyz_2)*0.5_CUSTOM_REAL
+ nodes_coords(:,iglob2) = xyz
+ nodes_coords(:,iglob1) = xyz
+ found_it = .true.
+ cycle
+ endif
+
+ enddo
+ if (found_it) cycle
+ enddo
+
+ enddo
+ enddo
+
+ end subroutine close_fault_single
+
+! ---------------------------------------------------------------------------------------------------
+
!--------------------------------------------------
! Repartitioning : two coupled faultside1/side2 elements are transfered to the same partition
!--------------------------------------------------
- Subroutine fault_collecting_elements(nelmnts,nnodes,elmnts,sup_neighbour,esize,nsize,nproc,part)
+ Subroutine fault_collect_elements(nelmnts,nnodes,elmnts, &
+ sup_neighbour,esize,nsize,nproc,part)
! INPUTS
- integer(long),intent(in) :: nelmnts,nsize,esize
+ integer(long),intent(in) :: nelmnts,nsize
integer(long),intent(in) :: sup_neighbour
integer, dimension(0:esize*nelmnts-1),intent(in) :: elmnts
- integer, intent(in) :: nnodes, nproc
+ integer, intent(in) :: nnodes, nproc, esize
! OUTPUTS :
integer, dimension(0:nelmnts-1),intent(inout) :: part
! VARIABLES:
- logical , dimension(nelmnts) :: is_faultside1=.false., &
- is_faultside2=.false. ! ISPEC1 , ISPEC2.
- integer :: nbfaults,iflt
+ logical, dimension(nelmnts) :: is_on_fault
+ integer :: iflt
- do iflt=1,nbfaults
- is_faultside1 = .false.
- is_faultside2 = .false.
- is_faultside1(faults(iflt)%ispec1) = .true.
- is_faultside2(faults(iflt)%ispec2) = .true.
- call faultside1_faultside2_repartitioning (nelmnts, nnodes, elmnts, sup_neighbour, nsize, &
- nproc, part,is_faultside1,is_faultside2)
+ is_on_fault = .false.
+ do iflt=1,size(faults)
+ is_on_fault(faults(iflt)%ispec1) = .true.
+ is_on_fault(faults(iflt)%ispec2) = .true.
end do
+ call fault_repartition (nelmnts, nnodes, elmnts, sup_neighbour, nsize, &
+ nproc, part, is_on_fault,esize)
- end Subroutine fault_collecting_elements
+ end Subroutine fault_collect_elements
! ---------------------------------------------------------------------------------------------------
-! JPA: we are doing the same steps for side 1 and 2
-! we don' need separate isfault1 isfault2. A single isfault is sufficient
-! To do: reaplce isfault1 and isfault2 by a single isfault
- Subroutine faultside1_faultside2_repartitioning (nelmnts, nnodes, elmnts, sup_neighbour, nsize, &
- nproc, part,is_faultside1,is_faultside2)
+ Subroutine fault_repartition (nelmnts, nnodes, elmnts, sup_neighbour, nsize, &
+ nproc, part, is_on_fault, esize)
+
! INDIVIDUAL FAULT REPARTITION
-! part : iproc number of processor partionated. It will altered patching fault elements into the same partion.
+! part : iproc number of processor partioned. It will altered patching fault elements into the same partion.
! Part, once is altered , will be input for write_partition_database.
!INPUTS
- integer(long),intent(in) :: nelmnts
- integer, intent(in) :: nnodes, nproc
- integer(long), intent(in) :: sup_neighbour,nsize
- logical , dimension(nelmnts), intent(in) :: is_faultside1, &
- is_faultside2 ! ISPEC1 , ISPEC2.
+ integer(long),intent(in) :: nelmnts
+ integer, intent(in) :: nnodes, nproc, esize
+ integer, dimension(0:esize*nelmnts-1), intent(in) :: elmnts
+ integer(long), intent(in) :: sup_neighbour,nsize
+ logical , dimension(nelmnts), intent(in) :: is_on_fault
!OUTPUTS :
- integer, dimension(0:nelmnts-1),intent(inout) :: part
+ integer, dimension(0:nelmnts-1), intent(inout) :: part
!LOCAL VARIABLES :
- integer, dimension(0:esize*nelmnts-1) :: elmnts
- integer :: nfaces_coupled
- integer, dimension(0:nelmnts) :: xadj
- integer, dimension(0:sup_neighbour*nelmnts-1) :: adjncy
- integer, dimension(0:nnodes-1) :: nnodes_elmnts
- integer, dimension(0:nsize*nnodes-1) :: nodes_elmnts
- integer :: max_neighbour
+ integer, dimension(0:nelmnts) :: xadj
+ integer, dimension(0:sup_neighbour*nelmnts-1) :: adjncy
+ integer, dimension(0:nnodes-1) :: nnodes_elmnts
+ integer, dimension(0:nsize*nnodes-1) :: nodes_elmnts
+ integer :: max_neighbour
!SHILDING
- integer :: i,j, iface,iface_coarse,ier,ipart,nproc_null
- integer :: el, el_adj,el_coarse
- logical :: is_repartitioned
- integer, dimension(:), allocatable :: elem_proc_null
+ integer :: i,j, ipart,nproc_null
+ integer :: el, el_1, el_2, k1, k2
+ logical :: is_repartitioned
+ integer, dimension(:), allocatable :: elem_proc_null
+ ! downloading processor 0
+ nproc_null = count( part == 0 )
-! downloading processor 0
- nproc_null = 0
- do i = 1,nelmnts
- ! searching for proc = 0 elements
- if ( part(i) == 0 ) then
- nproc_null = nproc_null +1
- end if
- end do
+ print*, 'Elements proc = 0 redistributed in [{nproc}- nproc0] :'
+ print*, nproc_null
- print*, 'Elements proc = 0 redistributed in [{nproc}- nproc0] :'
- print*, nproc_null
+ allocate(elem_proc_null(nproc_null))
- allocate(elem_proc_null(nproc_null))
+ ! Filling up proc = 0 elements
+ nproc_null = 0
+ do i = 1,nelmnts
+ if ( part(i) == 0 ) then
+ nproc_null = nproc_null + 1
+ elem_proc_null(nproc_null) = i
+ end if
+ end do
+ ! Redistributing proc-0 elements on the rest of processors
+ !jpa: why do this? does it always help balancing ?
+ !pgb: Yes, bulk elements in processor 0 are taken out and redistributed.
+ !pgb: leaving more space for fault elements.
+ ipart=0
+ do i = 1, nproc_null
+ if ( ipart == nproc ) ipart = 0
+ ipart = ipart +1
+ part(elem_proc_null(i)) = ipart
+ end do
- nproc_null = 0
- do i = 1,nelmnts
- ! Filling up proc = 0 elements
- if ( part(i) == 0 ) then
- nproc_null = nproc_null +1
- elem_proc_null(nproc_null) = i
- end if
- end do
-
- ! Redistributing proc-0 elements on the rest of processors
- ipart=0
- do i = 1, size(elem_proc_null)
- if ( ipart == nproc ) ipart = 0
- ipart = ipart +1
- part(elem_proc_null(i)) = ipart
- end do
-
-
! Percy , This is needed to get adjacent element by common face.
call mesh2dual_ncommonnodes(nelmnts, nnodes, nsize, sup_neighbour, &
elmnts, xadj, adjncy, nnodes_elmnts, &
nodes_elmnts, max_neighbour, 4)
- ! counts coupled elements
-
- nfaces_coupled = 0
- do el = 0, nelmnts-1
- if ( is_faultside1(el+1) ) then
- do el_adj = xadj(el), xadj(el+1) - 1
- if ( is_faultside2((adjncy(el_adj)+1)) ) then
- nfaces_coupled = nfaces_coupled + 1
- endif
- enddo
- endif
- enddo
-
- print*, 'number of fault elements coupled :'
- print*, nfaces_coupled
-
! coupled elements
! ---------------
! Allocating neighbours with shared fault faces.
@@ -205,221 +259,88 @@
! 1 1 2 2
! 1 2
- ! Allocating elements with double shield coarsing.
+ ! Allocating elements with double shield layer
+ print *, "Fault shield double-layer"
+ do el = 0, nelmnts-1
+ if ( is_on_fault(el+1) ) then
+ part(el) = 0
+ do k1 = xadj(el), xadj(el+1) - 1
+ el_1 = adjncy(k1)
+ part(el_1) = 0
+ do k2 = xadj(el_1), xadj(el_1+1) - 1
+ el_2 = adjncy(k2)
+ part(el_2) = 0
+ enddo
+ enddo
+ endif
+ enddo
+ end subroutine fault_repartition
-! Finding ispec_nodes1, ispec_nodes2.
-
-! ispec1_nodes = elmnts(:,ispec1)
-! ispec2_nodes = elmnts(:,ispec2)
-
-
- do el = 0, nelmnts-1
- if ( is_faultside1(el+1) ) then
-! side1 = el + 1
-! ispec1_side1 = ispec1(side1)
-
- do el_adj = xadj(el), xadj(el+1) - 1
- if (is_faultside2(adjncy(el_adj)+1)) then
- part(el) = 0
-! side2 = adjncy(el_adj) + 1
-! ispec_side2 = ispec2(side2)
-
-
-
- do iface = xadj(el), xadj(el+1)-1
- part(adjncy(iface)) = 0
- el_coarse = adjncy(iface)
- do iface_coarse = xadj(el_coarse),xadj(el_coarse+1)-1
- part(adjncy(iface_coarse)) = 0
- enddo
- enddo
- endif
- enddo
- endif
- enddo
-
- do el = 0, nelmnts-1
- if ( is_faultside2(el+1)) then
- do el_adj = xadj(el), xadj(el+1) - 1
- if (is_faultside1(adjncy(el_adj)+1)) then
- part(el) = 0
- do iface = xadj(el),xadj(el+1)-1
- part(adjncy(iface)) = 0
- el_coarse = adjncy(iface)
- do iface_coarse = xadj(el_coarse),xadj(el_coarse+1)-1
- part(adjncy(iface_coarse)) = 0
- enddo
- enddo
- endif
- enddo
- endif
- enddo
- print*, "FAULT SHIELD DOUBLE-COARSE"
-
-
- end subroutine faultside1_faultside2_repartitioning
-
! ---------------------------------------------------------------------------------------------------
+! write one block for each fault
- subroutine write_fault_partition_database(IIN_database, iproc, nelmnts, elmnts, &
- glob2loc_elmnts, part, num_phase,esize)
+ subroutine write_fault_partition_database(IIN_database, iproc, nelmnts, &
+ glob2loc_elmnts, part)
! include './constants_decompose_mesh_SCOTCH.h'
- integer, intent(in) :: IIN_database
- integer, intent(in) :: num_phase, iproc, esize
- integer(long), intent(in) :: nelmnts
- integer, dimension(0:esize*nelmnts-1), intent(in) :: elmnts
- integer, dimension(0:nelmnts-1), intent(in) :: part,glob2loc_elmnts
+ integer, intent(in) :: IIN_database
+ integer, intent(in) :: iproc,nelmnts
+ integer, dimension(0:nelmnts-1), intent(in) :: part,glob2loc_elmnts
- integer :: i,iflt,ispec_fault
- integer :: nspec_fault_side1,nspec_fault_side2,nspec_fault
+ integer, dimension(:), allocatable :: ispec1, ispec2, iface1, iface2
+ integer :: i,iflt,ispec_fault
+ integer :: nspec_fault_side1,nspec_fault_side2,nspec_fault
+ integer :: k1,k2
- if ( num_phase == 1 ) then
- ! counts number of fault elements in this partition
- nspec_fault = 0
- nspec_fault_side1 = 0
- nspec_fault_side2 = 0
- do iflt=1,size(faults)
- do i = 1,size(faults(iflt)%ispec1)
- if ( part(faults(iflt)%ispec1(i)-1) == iproc ) then
- nspec_fault_side1 = nspec_fault_side1 + 1
-
- endif
- enddo
- enddo
- do iflt=1,size(faults)
- do i = 1,size(faults(iflt)%ispec2)
- if ( part(faults(iflt)%ispec2(i)-1) == iproc ) then
- nspec_fault_side2 = nspec_fault_side2 + 1
- endif
- enddo
- enddo
- print* , 'ispec1 :'
- print* , nspec_fault_side1
- print* , 'ispec2 :'
- print* , nspec_fault_side2
-
- if (nspec_fault_side1 == nspec_fault_side2) then
- nspec_fault = nspec_fault_side1
- else
- stop 'Number of fault elements on iproc do not conside'
- end if
- allocate(ispec1(nspec_fault))
- allocate(iface1(nspec_fault))
- ispec_fault = 0
- do iflt=1,size(faults)
- do i = 1,size(faults(iflt)%ispec1)
- if ( part(faults(iflt)%ispec1(i)-1) == iproc ) then
- ispec_fault = ispec_fault + 1
- ispec1(ispec_fault)=glob2loc_elmnts(faults(iflt)%ispec1(i))
- iface1(ispec_fault)=faults(iflt)%iface1(i)
-
- endif
- enddo
- enddo
- allocate(ispec2(nspec_fault))
- allocate(iface2(nspec_fault))
- ispec_fault = 0
- do iflt=1,size(faults)
- do i = 1,size(faults(iflt)%ispec2)
- if ( part(faults(iflt)%ispec2(i)-1) == iproc ) then
- ispec_fault = ispec_fault + 1
- ispec2(ispec_fault)=glob2loc_elmnts(faults(iflt)%ispec2(i))
- iface2(ispec_fault)=faults(iflt)%iface2(i)
- endif
- enddo
- enddo
+ do iflt=1,size(faults)
+
+ ! check number of fault elements in this partition
+ nspec_fault_side1 = count( part(faults(iflt)%ispec1-1) == iproc )
+ nspec_fault_side2 = count( part(faults(iflt)%ispec2-1) == iproc )
+ print *, 'Fault # ',iflt
+ print *, ' ispec1 : ', nspec_fault_side1
+ print *, ' ispec2 : ', nspec_fault_side2
+ if (nspec_fault_side1 /= nspec_fault_side2) then
+ print *, 'Fatal error: Number of fault elements on ',iproc,' do not coincide. Abort.'
+ stop
+ end if
+ nspec_fault = nspec_fault_side1
- else
-
- ! Writes ispec1 , ispec2 , iface1 , iface2
write(IIN_database,*) nspec_fault
- do i = 1,nspec_fault
- write(IIN_database,*) ispec1(i), ispec2(i), iface1(i), iface2(i)
- enddo
- endif
+ if (nspec_fault==0) cycle
- end subroutine write_fault_partition_database
+ allocate(ispec1(nspec_fault))
+ allocate(iface1(nspec_fault))
+ allocate(ispec2(nspec_fault))
+ allocate(iface2(nspec_fault))
+ k1 = 0
+ k2 = 0
+ do i = 1,faults(iflt)%nspec
+ if ( part(faults(iflt)%ispec1(i)-1) == iproc ) then
+ k1 = k1 + 1
+ ispec1(k1)=glob2loc_elmnts(faults(iflt)%ispec1(i))
+ iface1(k1)=faults(iflt)%iface1(i)
+ endif
+ if ( part(faults(iflt)%ispec2(i)-1) == iproc ) then
+ k2 = k2 + 1
+ ispec2(k2)=glob2loc_elmnts(faults(iflt)%ispec2(i))
+ iface2(k2)=faults(iflt)%iface2(i)
+ endif
+ enddo
-! ---------------------------------------------------------------------------------------------------
-!
+ ! Writes ispec1 , ispec2 , iface1 , iface2
+ do i = 1,nspec_fault
+ write(IIN_database,*) ispec1(i), ispec2(i), iface1(i), iface2(i)
+ enddo
+ ! NOTE: the solver does not need ispec1 and ispec2 to be facing each other across the fault
+ deallocate(ispec1,ispec2,iface1,iface2)
- subroutine close_faults(nodes_coords,elmnts,nelmnts,nnodes,esize)
-
- integer ,intent(in) :: nnodes, esize, nelmnts
- integer, dimension(0:esize*nelmnts-1), intent(in) :: elmnts
+ enddo
- integer, dimension(3,nnodes), intent(in) :: nodes_coords
-
+ end subroutine write_fault_partition_database
- do iflt=1,size(faults)
- call close_fault_single(faults(iflt)%ispec1,faults(iflt)%ispec2, &
- elmnts,nodes_coords,nnodes,esize,nelmnts)
- enddo
- end subroutine close_faults
-! ---------------------------------------------------------------------------------------------------
- subroutine close_fault_single(ispec1,ispec2,elmnts,nodes_coords,nnodes,esize,nelmnts)
-
- integer ,intent(in) :: nnodes, esize, nelmnts
- integer, dimension(0:esize*nelmnts-1), intent(in) :: elmnts
- integer , dimension(:), intent(in) :: ispec1,ispec2
-
- real(kind=CUSTOM_REAL),dimension(3,nnodes),intent(inout) :: nodes_coords
-
- real(kind=CUSTOM_REAL) :: l,x,y,z,d
- integer :: iglob1, iglob2, i, j, k1, k2
-
- logical :: found_it
-
- l = 1e-3_CUSTOM_REAL
-
- do i = 1,size(ispec2)
- do k2=1,esize
-
- iglob2 = elmnts(k2,ispec2(i))
- found_it = .false.
-
- do j = 1,size(ispec1)
- do k1=1,esize
-
- iglob1 = elmnts(k1,ispec1(j))
-
- d = (nodes_coords(1,iglob2)-nodes_coords(1,iglob1))**2 + &
- (nodes_coords(2,iglob2)-nodes_coords(2,iglob1))**2 + &
- (nodes_coords(3,iglob2)-nodes_coords(3,iglob1))**2
- d = sqrt(d)
-
- if (d <= l) then
-
- x = (nodes_coords(1,iglob2) + nodes_coords(1,iglob1))/2_CUSTOM_REAL
- y = (nodes_coords(2,iglob2) + nodes_coords(2,iglob1))/2_CUSTOM_REAL
- z = (nodes_coords(3,iglob2) + nodes_coords(3,iglob1))/2_CUSTOM_REAL
-
- nodes_coords(1,iglob2) = x
- nodes_coords(2,iglob2) = y
- nodes_coords(3,iglob2) = z
-
- nodes_coords(1,iglob1) = x
- nodes_coords(2,iglob1) = y
- nodes_coords(3,iglob1) = z
-
- found_it = .true.
- cycle
- endif
-
- enddo
- if (found_it) cycle
- enddo
-
- enddo
- enddo
-
- end subroutine close_faults
-
-! ---------------------------------------------------------------------------------------------------
-
end module fault_scotch
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/PML_init.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/PML_init.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/PML_init.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,1232 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+module PML_par
+
+ use constants,only: CUSTOM_REAL
+
+ !--------------------------------------------------------------------
+ ! USER PARAMETERS
+
+ ! damping profile coefficients:
+ ! R: theoretical reflection coefficient after discretization
+ real(kind=CUSTOM_REAL),parameter:: PML_damp_R = 1.e-3
+
+ ! number of element layers for PML region
+ ! default is 2 element layers
+ integer :: PML_LAYERS = 2
+
+ ! additional absorbing, Sommerfeld (^Stacey) condition at the boundaries
+ logical,parameter:: PML_USE_SOMMERFELD = .false.
+
+ !--------------------------------------------------------------------
+
+ real(kind=CUSTOM_REAL):: PML_width
+ real(kind=CUSTOM_REAL):: PML_width_min,PML_width_max
+
+ ! PML element type flag
+ integer,dimension(:),allocatable :: ispec_is_PML_inum
+
+ ! PML global points
+ integer,dimension(:),allocatable :: iglob_is_PML
+
+ ! PML spectral elements
+ integer,dimension(:),allocatable :: PML_ispec
+ integer :: num_PML_ispec
+
+ ! PML normal for each PML spectral element
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable :: PML_normal
+ ! PML damping coefficients d & dprime
+ real(kind=CUSTOM_REAL),dimension(:,:,:,:),allocatable :: PML_damping_d,PML_damping_dprime
+
+ !real(kind=CUSTOM_REAL),dimension(:),allocatable :: PML_damping_d_global
+
+ ! PML interface
+ integer,dimension(:),allocatable :: iglob_is_PML_interface
+
+ ! mask ibool needed for time marching
+ logical,dimension(:),allocatable :: PML_mask_ibool
+
+ ! PML damping flag
+ logical:: PML = .false.
+
+end module PML_par
+
+!--------
+
+module PML_par_acoustic
+
+ ! potentials split into 4 terms plus temporary potential:
+ ! chi = chi1 + chi2 + chi3 + chi4
+ ! temporary: chi2_t = (\partial_t + d ) chi2
+
+ use constants,only: CUSTOM_REAL
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ chi1,chi2,chi2_t,chi3,chi4
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
+
+end module PML_par_acoustic
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_damping_profile_l(d,x,vp,delta)
+
+! calculates damping coefficient value d for a given
+! x: distance x and
+! vp: p-velocity alpha
+! delta: PML width
+!
+! returns: d damping coefficients
+ use PML_par,only: CUSTOM_REAL,PML_damp_R
+ implicit none
+ real(kind=CUSTOM_REAL),intent(out):: d
+ real(kind=CUSTOM_REAL),intent(in):: x,vp,delta
+
+ ! damping profile coefficients:
+ ! d : damping function of (x)
+ ! vp: P-velocity
+ ! delta: width of PML layer
+ ! R: theoretical reflection coefficient after discretization
+
+ ! damping profile function: d = f(x)
+ ! Komatitsch & Tromp, 2003: eq. 24 page 150
+ d = 3.0*vp/(2.0*delta)*log(1.0/PML_damp_R)*x*x/(delta*delta)
+
+end subroutine PML_damping_profile_l
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_initialize()
+
+ use specfem_par,only: NGLOB_AB,NSPEC_AB,myrank, &
+ ibool,xstore,ystore,zstore,&
+ model_speed_max,hdur
+ use PML_par
+ use PML_par_acoustic
+ use constants,only: FIX_UNDERFLOW_PROBLEM,VERYSMALLVAL,IMAIN,&
+ NGLLX,NGLLY,NGLLZ,TINYVAL
+ use specfem_par_acoustic,only: ACOUSTIC_SIMULATION
+ implicit none
+
+ ! local parameters
+ real(kind=CUSTOM_REAL):: d,dprime,d_glob,dprime_glob
+ real(kind=CUSTOM_REAL) :: dominant_wavelength,hdur_max
+ integer :: count,ilayer,sign
+
+ ! sets flag
+ PML = .true.
+
+ ! user output
+ if( myrank == 0 ) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'incorporating PML '
+ write(IMAIN,*)
+ endif
+
+ ! PML element type array: 1 = face, 2 = edge, 3 = corner
+ allocate(ispec_is_PML_inum(NSPEC_AB))
+ num_PML_ispec = 0
+
+ ! PML interface points between PML and "regular" region
+ allocate(iglob_is_PML_interface(NGLOB_AB))
+ iglob_is_PML_interface(:) = 0
+
+ ! PML global points
+ allocate(iglob_is_PML(NGLOB_AB))
+ iglob_is_PML(:) = 0
+
+ ! PML ibool mask
+ allocate(PML_mask_ibool(NGLOB_AB))
+ PML_mask_ibool(:) = .false.
+
+ ! determines dominant wavelength based on maximum model speed
+ ! and source half time duration
+ hdur_max = maxval(hdur(:))
+ if( hdur_max > 0.0 ) then
+ dominant_wavelength = model_speed_max * 2.0 * hdur_max
+ else
+ dominant_wavelength = 0._CUSTOM_REAL
+ endif
+
+ ! for multiple PML element layers
+ ilayer = 0
+ do while( ilayer < PML_LAYERS )
+ ilayer = ilayer + 1
+
+ if( ilayer == 1 ) then
+ ! sets ispec occurrences for first element layer in PML region based on absorbing boundary elements
+ call PML_set_firstlayer()
+ else
+ ! adds an additional element layer based on adjacent elements on PML interface points
+ call PML_add_layer()
+ endif
+
+ ! update global interface points of PML region to "regular" domain
+ call PML_determine_interfacePoints()
+
+ ! optional? update PML width according to dominant wavelength
+ !call PML_get_width()
+ ! checks with wavelength criteria
+ !if( dominant_wavelength > 0.0 ) then
+ ! if( PML_width > dominant_wavelength/2.0 ) then
+ ! PML_LAYERS = ilayer
+ ! exit
+ ! else
+ ! PML_LAYERS = ilayer + 1
+ ! endif
+ !endif
+ enddo
+
+ ! checks PML normals at edges and corners,
+ ! tries to gather elements at edges & corners
+ do ilayer=1,PML_LAYERS-1
+ call PML_update_normals(ilayer)
+ enddo
+
+ ! updates statistics global PML width
+ call PML_get_width()
+
+ ! pre-calculates damping profiles on PML points
+ ! damping coefficients
+ call PML_set_local_dampingcoeff()
+
+ ! pre-calculates derivatives of damping coefficients
+ call PML_determine_dprime()
+
+ ! wavefield array initialization
+ allocate(chi1(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi2(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi2_t(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi3(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi4(NGLLX,NGLLY,NGLLZ,num_PML_ispec))
+ allocate(chi1_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi2_t_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi3_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi4_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec))
+ allocate(chi1_dot_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi2_t_dot_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi3_dot_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec),&
+ chi4_dot_dot(NGLLX,NGLLY,NGLLZ,num_PML_ispec))
+
+ ! potentials
+ chi1 = 0._CUSTOM_REAL
+ chi2 = 0._CUSTOM_REAL
+ chi2_t = 0._CUSTOM_REAL
+ chi3 = 0._CUSTOM_REAL
+ chi4 = 0._CUSTOM_REAL
+
+ ! "velocity" potential
+ chi1_dot = 0._CUSTOM_REAL
+ chi2_t_dot = 0._CUSTOM_REAL
+ chi3_dot = 0._CUSTOM_REAL
+ chi4_dot = 0._CUSTOM_REAL
+
+ ! "acceleration"/pressure potential
+ chi1_dot_dot = 0._CUSTOM_REAL
+ chi2_t_dot_dot = 0._CUSTOM_REAL
+ chi3_dot_dot = 0._CUSTOM_REAL
+ chi4_dot_dot = 0._CUSTOM_REAL
+ if(FIX_UNDERFLOW_PROBLEM) then
+ chi1_dot_dot = VERYSMALLVAL
+ chi2_t_dot_dot = VERYSMALLVAL
+ chi3_dot_dot = VERYSMALLVAL
+ chi4_dot_dot = VERYSMALLVAL
+ endif
+
+ ! statistics user output
+ d = maxval(abs(PML_damping_d(:,:,:,:)))
+ if( d > TINYVAL ) then
+ sign = maxval(PML_damping_d(:,:,:,:)) / maxval(abs(PML_damping_d(:,:,:,:)))
+ else
+ sign = 1.0
+ endif
+ dprime = maxval(abs(PML_damping_dprime(:,:,:,:)))
+ call max_all_cr(d,d_glob)
+ call max_all_cr(dprime,dprime_glob)
+ call sum_all_i(num_PML_ispec,count)
+ if( myrank == 0 ) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'PML region: '
+ write(IMAIN,*) ' total spectral elements:',count
+ write(IMAIN,*) ' number of layers : ',PML_LAYERS
+ write(IMAIN,*) ' dominant wavelength max: ',dominant_wavelength
+ write(IMAIN,*) ' width min / max:',PML_width_min,PML_width_max
+ write(IMAIN,*) ' reflection coefficient:',PML_damp_R
+ write(IMAIN,*) ' maximum d : ',sign*d_glob
+ write(IMAIN,*) ' maximum dprime : ',sign*dprime_glob
+ write(IMAIN,*)
+ endif
+
+ ! VTK file output
+ call PML_output_VTKs()
+
+end subroutine PML_initialize
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_set_firstlayer()
+
+! sets ispec occurrences for first element layer in PML region based on absorbing boundary elements
+
+ use PML_par
+ use specfem_par,only: NSPEC_AB,NGLOB_AB, &
+ abs_boundary_ispec,abs_boundary_normal,num_abs_boundary_faces,&
+ abs_boundary_ijk,ibool,myrank
+ use constants,only: NDIM,TINYVAL,NGNOD,NGLLX,NGLLY,NGLLZ,NGLLSQUARE
+ implicit none
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable:: temp_ispec_pml_normal
+ integer,dimension(:),allocatable:: temp_is_pml_elem
+ integer:: iface,count,new_elemts,ispec,icorner,igll,iglobf
+ integer:: i,j,k,iglobcount,iglobcorners(NGNOD)
+ integer,dimension(3,NGNOD),parameter :: ielem_corner_ijk = &
+ reshape((/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ, &
+ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),(/3,NGNOD/))
+ ! temporary arrays
+ allocate(temp_is_pml_elem(NSPEC_AB))
+ allocate(temp_ispec_pml_normal(NDIM,NSPEC_AB))
+
+ temp_is_pml_elem(:) = 0
+ temp_ispec_pml_normal(:,:) = 0._CUSTOM_REAL
+
+ count = 0
+ do iface=1,num_abs_boundary_faces
+ ! gets spectral elements with boundary face
+ ispec = abs_boundary_ispec(iface)
+
+ ! counts new PML elements
+ if( temp_is_pml_elem(ispec) == 0 ) count = count + 1
+
+ ! counts number of occurrences
+ ! 1 : element with 1 face to regular one,
+ ! 2 : element with 2 faces (elements at edges)
+ ! 3 : element with 3 faces (elements at corners)
+ temp_is_pml_elem(ispec) = temp_is_pml_elem(ispec) + 1
+
+ ! adds contribution to element normal
+ temp_ispec_pml_normal(:,ispec) = temp_ispec_pml_normal(:,ispec) + abs_boundary_normal(:,1,iface)
+ enddo
+ new_elemts = count
+
+ ! doubling layers might have elements with only an edge on the absorbing surface
+ ! poses problems if not accounted for
+ count = 0
+ do ispec = 1,NSPEC_AB
+ ! only elements not recognized so far
+ if( temp_is_pml_elem(ispec) > 0 ) cycle
+
+ ! stores global indices of element corners
+ do icorner=1,NGNOD
+ i = ielem_corner_ijk(1,icorner)
+ j = ielem_corner_ijk(2,icorner)
+ k = ielem_corner_ijk(3,icorner)
+ iglobcorners(icorner) = ibool(i,j,k,ispec)
+ enddo
+
+ ! checks if element has an edge (two corner points) on a absorbing boundary
+ ! (refers mainly to elements in doubling layers)
+ do iface=1,num_abs_boundary_faces
+ ! checks if already encountered this element
+ if( abs_boundary_ispec(iface) == ispec ) exit
+
+ ! loops over face points
+ iglobcount = 0
+ do igll=1,NGLLSQUARE
+ i = abs_boundary_ijk(1,igll,iface)
+ j = abs_boundary_ijk(2,igll,iface)
+ k = abs_boundary_ijk(3,igll,iface)
+ iglobf = ibool(i,j,k,abs_boundary_ispec(iface))
+ ! checks with corners
+ do icorner=1,NGNOD
+ if( iglobcorners(icorner) == iglobf ) iglobcount = iglobcount + 1
+ enddo
+ enddo
+
+ ! adds as pml element
+ if( iglobcount >= 2 ) then
+ ! counter
+ if( temp_is_pml_elem(ispec) == 0 ) count = count + 1
+ temp_is_pml_elem(ispec) = temp_is_pml_elem(ispec) + 1
+ ! updates normal
+ temp_ispec_pml_normal(:,ispec) = temp_ispec_pml_normal(:,ispec) &
+ + abs_boundary_normal(:,1,iface)
+ exit
+ endif
+ enddo ! iface
+
+ enddo
+ new_elemts = new_elemts + count
+
+ ! stores PML element indices and resulting normal
+ call PML_set_elements(temp_is_pml_elem,temp_ispec_pml_normal,new_elemts)
+
+ deallocate( temp_is_pml_elem)
+ deallocate( temp_ispec_pml_normal)
+
+end subroutine PML_set_firstlayer
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_set_elements(temp_is_pml_elem,temp_ispec_pml_normal,new_elemts)
+
+! adds new elements to PML region
+
+ use PML_par
+ use specfem_par,only: NSPEC_AB,myrank
+ use constants,only: NDIM,TINYVAL
+ implicit none
+
+ integer:: temp_is_pml_elem(NSPEC_AB)
+ real(kind=CUSTOM_REAL):: temp_ispec_pml_normal(NDIM,NSPEC_AB)
+ integer:: new_elemts
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: length
+ integer :: ispec,ispecPML
+
+ ! sets new element type flags
+ ispec_is_PML_inum(:) = temp_is_pml_elem(:)
+
+ ! sets new number of elements
+ num_PML_ispec = new_elemts
+
+ ! re-allocates arrays
+ if( allocated(PML_normal) ) deallocate(PML_normal)
+ if( allocated(PML_ispec) ) deallocate(PML_ispec)
+ allocate(PML_ispec(num_PML_ispec))
+ allocate(PML_normal(NDIM,num_PML_ispec))
+
+ ! stores PML elements flags and normals
+ ispecPML = 0
+ do ispec=1,NSPEC_AB
+ if( ispec_is_PML_inum(ispec) > 0 ) then
+ ! stores indices
+ ispecPML = ispecPML+1
+ PML_ispec(ispecPML) = ispec
+
+ ! gets resulting element normal
+ PML_normal(:,ispecPML) = temp_ispec_pml_normal(:,ispec)
+
+ ! normalizes normal
+ length = sqrt( PML_normal(1,ispecPML)**2 &
+ + PML_normal(2,ispecPML)**2 &
+ + PML_normal(3,ispecPML)**2 )
+ if( length < TINYVAL ) then
+ print*,'error set elements: normal length:',length
+ print*,'elem:',ispec,ispecPML
+ print*,'num_pml_ispec:',num_PML_ispec
+ call exit_mpi(myrank,'error PML normal length')
+ else
+ ! normalizes normal
+ PML_normal(:,ispecPML) = PML_normal(:,ispecPML)/length
+ endif
+ endif
+ enddo
+ if( ispecPML /= num_PML_ispec) call exit_mpi(myrank,'PML add layer count error')
+
+end subroutine PML_set_elements
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_determine_interfacePoints()
+
+! finds global interface points of PML region to "regular" domain
+
+ use specfem_par,only: ibool,myrank,NGLOB_AB,NSPEC_AB, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh,NPROC
+ use PML_par
+ use PML_par_acoustic
+ use constants,only: NGLLX,NGLLY,NGLLZ
+ use specfem_par_acoustic,only: ispec_is_acoustic,ACOUSTIC_SIMULATION
+ implicit none
+
+ ! local parameters
+ integer,dimension(:),allocatable:: temp_regulardomain
+ integer:: i,j,k,ispec,iglob
+
+ ! PML interface points array
+ iglob_is_PML_interface(:) = 0
+
+ ! temporary arrays
+ allocate(temp_regulardomain(NGLOB_AB))
+ temp_regulardomain(:) = 0
+
+ ! global PML points
+ iglob_is_PML(:) = 0
+
+ ! sets flags on PML and regular domain points
+ do ispec=1,NSPEC_AB
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ ! sets flag for PML/regular domain
+ if( ispec_is_PML_inum(ispec) > 0 ) then
+ ! global points
+ iglob_is_PML(iglob) = iglob_is_PML(iglob) + 1
+ else
+ ! not a PML point
+ temp_regulardomain(iglob) = temp_regulardomain(iglob) + 1
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ! assemble on MPI interfaces
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,NGLOB_AB,iglob_is_PML, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh)
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,NGLOB_AB,temp_regulardomain, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh)
+
+ ! stores interface points
+ do ispec=1,NSPEC_AB
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ ! checks if it belongs to both, PML and regular domain
+ if( temp_regulardomain(iglob) > 0 .and. iglob_is_PML(iglob) > 0 ) then
+ ! increases flag on global point
+ iglob_is_PML_interface(iglob) = iglob_is_PML_interface(iglob) + 1
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+ deallocate(temp_regulardomain)
+
+end subroutine PML_determine_interfacePoints
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+subroutine PML_get_width()
+
+! calculates PML width for statistics
+
+ use specfem_par,only: abs_boundary_ispec,abs_boundary_normal,abs_boundary_ijk,&
+ num_abs_boundary_faces,&
+ ibool,xstore,ystore,zstore,myrank, &
+ NGLOB_AB
+ use PML_par
+ use constants,only: NGLLSQUARE,TINYVAL,HUGEVAL
+ implicit none
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: length,width
+ integer:: i,j,k,ispec,iglob,iface,igll,iglobf
+
+ ! determines global PML width
+ ! loops over domain surface
+ width = HUGEVAL
+ do iface=1,num_abs_boundary_faces
+
+ ispec = abs_boundary_ispec(iface)
+
+ ! avoids taking corner or edge elements for width
+ if( ispec_is_PML_inum(ispec) > 1 ) cycle
+
+ ! determines smallest distance to interface points
+ do iglob=1,NGLOB_AB
+ if( iglob_is_PML_interface(iglob) > 0 ) then
+ ! loops over face points
+ do igll=1,NGLLSQUARE
+ i = abs_boundary_ijk(1,igll,iface)
+ j = abs_boundary_ijk(2,igll,iface)
+ k = abs_boundary_ijk(3,igll,iface)
+
+ ! takes distance between two points
+ iglobf = ibool(i,j,k,ispec)
+ length = sqrt((xstore(iglobf)-xstore(iglob))**2 &
+ + (ystore(iglobf)-ystore(iglob))**2 &
+ + (zstore(iglobf)-zstore(iglob))**2 )
+
+ ! checks length
+ if( length < TINYVAL ) then
+ print*,'PML:',myrank,'length:',length
+ print*,' ijk:',i,j,k,ispec,'face:',iface,'iglob:',iglobf
+ print*,' ijk xyz:',xstore(iglobf),ystore(iglobf),zstore(iglobf)
+ print*,' iglob interface',iglob
+ print*,' iglob xyz:',xstore(iglob),ystore(iglob),zstore(iglob)
+ call exit_mpi(myrank,'PML length zero error')
+ endif
+
+ ! updates minimum width
+ if( length < width ) width = length
+
+ enddo
+ endif
+ enddo
+ enddo
+
+ ! determines maximum width on all MPI processes
+ ! all process gets overall maximum
+ call max_all_all_cr(width,PML_width_max)
+ call min_all_all_cr(width,PML_width_min)
+
+ ! sets PML width
+ if( PML_width_min > TINYVAL ) then
+ PML_width = PML_width_min
+ else
+ PML_width = PML_width_max
+ endif
+
+ ! checks
+ if( PML_width < TINYVAL ) call exit_mpi(myrank,'PML width error: width too small')
+
+end subroutine PML_get_width
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_set_local_dampingcoeff()
+
+! calculates damping profiles on PML points
+
+ use specfem_par,only: ibool,xstore,ystore,zstore,myrank, &
+ kappastore,mustore,NGLOB_AB,&
+ abs_boundary_ispec,abs_boundary_ijk,num_abs_boundary_faces
+ use specfem_par_acoustic,only: ACOUSTIC_SIMULATION,rhostore
+ use specfem_par_elastic,only: ELASTIC_SIMULATION,rho_vp
+ use PML_par
+ use constants,only: NGLLX,NGLLY,NGLLZ,HUGEVAL,FOUR_THIRDS,NGLLSQUARE,TINYVAL
+ implicit none
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: length
+ real(kind=CUSTOM_REAL) :: dist,vp
+ real(kind=CUSTOM_REAL) :: d
+ real(kind=CUSTOM_REAL) :: width
+
+ integer:: i,j,k,ispec,iglob,ispecPML,iglobf
+ integer:: ispecB,igll,iface
+
+ ! stores damping coefficient
+ allocate( PML_damping_d(NGLLX,NGLLY,NGLLZ,num_PML_ispec))
+ PML_damping_d(:,:,:,:) = 0._CUSTOM_REAL
+
+ ! loops over all PML elements
+ do ispecPML=1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! determines smallest distance to interface points
+ ! and determines smallest distance to absorbing boundary points
+ ! (note: MPI partitioning not considered here yet; might be a problem)
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! global index
+ iglobf = ibool(i,j,k,ispec)
+
+ ! ensures that PML interface points have zero damping coefficients
+ if( iglob_is_PML_interface(iglobf) > 0 ) then
+ PML_damping_d(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ cycle
+ endif
+
+ ! distance to PML interface points
+ dist = HUGEVAL
+ do iglob=1,NGLOB_AB
+ if( iglob_is_PML_interface(iglob) > 0 ) then
+ ! distance to interface
+ length = (xstore(iglobf)-xstore(iglob))**2 &
+ + (ystore(iglobf)-ystore(iglob))**2 &
+ + (zstore(iglobf)-zstore(iglob))**2
+ if( length < dist ) dist = length
+ endif
+ enddo !iglob
+ !dist = distances(i,j,k)
+ if( dist >= HUGEVAL ) then
+ dist = PML_width_max
+ else
+ dist = sqrt( dist )
+ endif
+
+ ! distance to boundary points
+ width = HUGEVAL
+ do iface=1,num_abs_boundary_faces
+ ispecB = abs_boundary_ispec(iface)
+ do igll=1,NGLLSQUARE
+ iglob = ibool(abs_boundary_ijk(1,igll,iface),&
+ abs_boundary_ijk(2,igll,iface),&
+ abs_boundary_ijk(3,igll,iface),ispecB)
+ ! distance to boundary
+ length = (xstore(iglobf)-xstore(iglob))**2 &
+ + (ystore(iglobf)-ystore(iglob))**2 &
+ + (zstore(iglobf)-zstore(iglob))**2
+ if( length < width ) width = length
+ enddo
+ enddo ! iface
+ ! apparent width of PML for this point
+ if( width >= HUGEVAL ) then
+ width = PML_width_max
+ else
+ width = sqrt( width ) + dist
+ endif
+
+ ! checks width
+ if( width < TINYVAL ) then
+ print*,'error: pml width ',width
+ print*,'ijk:',ispec,i,j,k
+ print*,'xyz:',xstore(ibool(i,j,k,ispec)),ystore(ibool(i,j,k,ispec)),zstore(ibool(i,j,k,ispec))
+ print*,'dist:',dist
+ print*,'pml min/max:',PML_width_max,PML_width_min
+ call exit_mpi(myrank,'PML error getting width')
+ endif
+
+ ! P-velocity
+ if( ACOUSTIC_SIMULATION ) then
+ vp = sqrt( kappastore(i,j,k,ispec)/rhostore(i,j,k,ispec) )
+ else if( ELASTIC_SIMULATION ) then
+ vp = (FOUR_THIRDS * mustore(i,j,k,ispec) + kappastore(i,j,k,ispec)) &
+ / rho_vp(i,j,k,ispec)
+ else
+ call exit_mpi(myrank,'PML error getting vp')
+ endif
+
+ ! gets damping coefficient
+ call PML_damping_profile_l(d,dist,vp,width)
+
+ ! stores d & dprime for this element's GLL points
+ PML_damping_d(i,j,k,ispecPML) = d
+
+ enddo
+ enddo
+ enddo
+ enddo !ispecPML
+
+end subroutine PML_set_local_dampingcoeff
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_determine_dprime()
+
+! calculates derivatives dprime of damping coefficients on GLL points
+
+ use PML_par
+ use PML_par_acoustic
+ use constants,only: NGLLX,NGLLY,NGLLZ
+ use specfem_par,only: xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,&
+ hprime_xx,hprime_yy,hprime_zz
+ implicit none
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLZ,NGLLZ) :: dprime_elem
+ real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl
+ real(kind=CUSTOM_REAL) :: nx,ny,nz
+ real(kind=CUSTOM_REAL) :: d_dx,d_dy,d_dz,tempd_dx,tempd_dy,tempd_dz
+ integer :: ispec,i,j,k,l,ispecPML
+
+ ! dprime derivatives
+ allocate( PML_damping_dprime(NGLLX,NGLLY,NGLLZ,num_PML_ispec))
+ PML_damping_dprime(:,:,:,:) = 0._CUSTOM_REAL
+
+ ! loops over all PML elements
+ do ispecPML=1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! PML normal
+ nx = PML_normal(1,ispecPML)
+ ny = PML_normal(2,ispecPML)
+ nz = PML_normal(3,ispecPML)
+
+ ! calculates terms:
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! derivative along x, y, z
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the loops because NGLLX == NGLLY == NGLLZ
+ tempd_dx = 0._CUSTOM_REAL
+ tempd_dy = 0._CUSTOM_REAL
+ tempd_dz = 0._CUSTOM_REAL
+ do l = 1,NGLLX
+ tempd_dx = tempd_dx + PML_damping_d(l,j,k,ispecPML)*hprime_xx(i,l)
+ tempd_dy = tempd_dy + PML_damping_d(i,l,k,ispecPML)*hprime_yy(j,l)
+ tempd_dz = tempd_dz + PML_damping_d(i,j,l,ispecPML)*hprime_zz(k,l)
+ enddo
+
+ ! get derivatives of potential 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)
+
+ ! derivatives dprime
+ d_dx = xixl*tempd_dx + etaxl*tempd_dy + gammaxl*tempd_dz
+ d_dy = xiyl*tempd_dx + etayl*tempd_dy + gammayl*tempd_dz
+ d_dz = xizl*tempd_dx + etazl*tempd_dy + gammazl*tempd_dz
+ dprime_elem(i,j,k) = d_dx*nx + d_dy*ny + d_dz*nz
+
+ enddo
+ enddo
+ enddo
+
+ ! stores dprime coefficients
+ PML_damping_dprime(:,:,:,ispecPML) = dprime_elem(:,:,:)
+
+ enddo
+
+end subroutine PML_determine_dprime
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_add_layer()
+
+! adds an element layer to the PML region
+
+ use PML_par
+ use specfem_par,only: NSPEC_AB,NGLOB_AB, &
+ abs_boundary_ispec,abs_boundary_normal,num_abs_boundary_faces,&
+ ibool,myrank,&
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh,NPROC
+ use constants,only: NDIM,TINYVAL,NGLLX,NGLLY,NGLLZ,NGNOD2D
+ implicit none
+
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable:: iglob_pml_normal
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable:: ispec_pml_normal
+ integer,dimension(:),allocatable:: is_pml_elem
+ integer:: i,j,k,iglob,count,ispecPML,ispec,new_elemts
+ integer :: iface,icorner,ipmlcorners
+
+ integer,dimension(3,4),parameter :: iface1_corner_ijk = &
+ reshape((/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ /),(/3,4/)) ! xmin
+ integer,dimension(3,4),parameter :: iface2_corner_ijk = &
+ reshape((/ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),(/3,4/)) ! xmax
+ integer,dimension(3,4),parameter :: iface3_corner_ijk = &
+ reshape((/ 1,1,1, 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,1,1 /),(/3,4/)) ! ymin
+ integer,dimension(3,4),parameter :: iface4_corner_ijk = &
+ reshape((/ 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! ymax
+ integer,dimension(3,4),parameter :: iface5_corner_ijk = &
+ reshape((/ 1,1,1, 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,1,1 /),(/3,4/)) ! bottom
+ integer,dimension(3,4),parameter :: iface6_corner_ijk = &
+ reshape((/ 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! top
+ integer,dimension(3,4,6),parameter :: iface_all_corner_ijk = &
+ reshape((/ iface1_corner_ijk,iface2_corner_ijk, &
+ iface3_corner_ijk,iface4_corner_ijk, &
+ iface5_corner_ijk,iface6_corner_ijk /),(/3,4,6/)) ! all faces
+ ! midpoint indices for each face (xmin,xmax,ymin,ymax,zmin,zmax)
+ integer,dimension(3,6),parameter :: iface_all_midpointijk = &
+ reshape( (/ 1,2,2, NGLLX,2,2, 2,1,2, 2,NGLLY,2, 2,2,1, 2,2,NGLLZ /),(/3,6/))
+ logical :: is_done
+
+ ! temporary arrays
+ allocate(is_pml_elem(NSPEC_AB))
+ allocate(iglob_pml_normal(NDIM,NGLOB_AB))
+ allocate(ispec_pml_normal(NDIM,NSPEC_AB))
+
+ iglob_pml_normal(:,:) = 0._CUSTOM_REAL
+ ispec_pml_normal(:,:) = 0._CUSTOM_REAL
+
+ ! sets pml normals on PML interface, global points
+ do ispecPML=1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+ ! checks
+ if( ispec_is_PML_inum(ispec) < 1 ) call exit_mpi(myrank,'PML error add ispec layer')
+
+ ! starts from first layer elements
+ ! stores normal information on temporary global points
+ if( ispec_is_PML_inum(ispec) >= 1 ) then
+ ! stores PML normal on interface points
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ if( iglob_is_PML_interface(iglob) > 0 ) then
+ iglob_pml_normal(:,iglob) = iglob_pml_normal(:,iglob) + PML_normal(:,ispecPML)
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+
+ enddo
+
+ ! assembles with other MPI processes
+ call assemble_MPI_vector_ext_mesh(NPROC,NGLOB_AB,iglob_pml_normal, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+
+ ! adds new elements sharing PML interface
+ count = 0
+ is_pml_elem(:) = 0
+ do ispec=1,NSPEC_AB
+
+ ! checks if we already have this element set as pml element in first layer
+ is_done = .false.
+ do ispecPML=1,num_PML_ispec
+ if( PML_ispec(ispecPML) == ispec ) then
+ ! adds as pml element
+ if(is_pml_elem(ispec) == 0) count = count + 1
+ ! copies normal
+ ispec_pml_normal(:,ispec) = PML_normal(:,ispecPML)
+ ! copies element type flag
+ is_pml_elem(ispec) = ispec_is_PML_inum(ispec)
+
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) cycle
+
+ ! loops over element faces
+ do iface=1,6
+ ipmlcorners = 0
+ 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)
+ if( iglob_is_PML_interface(iglob) > 0 ) ipmlcorners = ipmlcorners + 1
+ enddo
+
+ ! face is pml interface
+ if( ipmlcorners == NGNOD2D ) then
+ ! counts new pml elements
+ if(is_pml_elem(ispec) == 0) count = count + 1
+
+ ! increments flag
+ is_pml_elem(ispec) = is_pml_elem(ispec) + 1
+
+ ! sets normal
+ ! reference midpoint on face
+ i = iface_all_midpointijk(1,iface)
+ j = iface_all_midpointijk(2,iface)
+ k = iface_all_midpointijk(3,iface)
+ iglob = ibool(i,j,k,ispec)
+ if( iglob_is_PML_interface(iglob) < 1 ) call exit_mpi(myrank,'PML error midpoint interface')
+
+ ! checks new normal
+ if( sqrt(iglob_pml_normal(1,iglob)**2+iglob_pml_normal(2,iglob)**2 &
+ +iglob_pml_normal(3,iglob)**2) < TINYVAL ) then
+ print*,'error add layer: normal length zero: iglob',iglob
+ print*,'face ',iface,ipmlcorners
+ print*,'ijk ispec',i,j,k,ispec
+ call exit_mpi(myrank,'PML add layer has new normal length error')
+ endif
+
+ ! adds contribution to normal
+ ispec_pml_normal(:,ispec) = ispec_pml_normal(:,ispec) + iglob_pml_normal(:,iglob)
+ endif
+
+ enddo ! iface
+ enddo ! ispec
+ new_elemts = count
+
+ ! adds new pml elements to PML region
+ call PML_set_elements(is_pml_elem,ispec_pml_normal,new_elemts)
+
+end subroutine PML_add_layer
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_update_normals(ilayer)
+
+! updates normal's directions for elements in PML region
+
+ use PML_par
+ use specfem_par,only: NSPEC_AB,NGLOB_AB, &
+ ibool,myrank,&
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh,NPROC
+ use constants,only: NGNOD2D,NGLLX,NGLLY,NGLLZ
+ implicit none
+ integer :: ilayer
+
+ ! local parameters
+ integer:: iglob,ispecPML,ispec
+ integer :: iface,icorner
+ integer :: ipmlcorners,ipmledges,ipmlsngl
+ integer :: ipmlcorners_tot,ipmledges_tot,ipmlsngl_tot
+
+ integer,dimension(3,4),parameter :: iface1_corner_ijk = &
+ reshape((/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ /),(/3,4/)) ! xmin
+ integer,dimension(3,4),parameter :: iface2_corner_ijk = &
+ reshape((/ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),(/3,4/)) ! xmax
+ integer,dimension(3,4),parameter :: iface3_corner_ijk = &
+ reshape((/ 1,1,1, 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,1,1 /),(/3,4/)) ! ymin
+ integer,dimension(3,4),parameter :: iface4_corner_ijk = &
+ reshape((/ 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! ymax
+ integer,dimension(3,4),parameter :: iface5_corner_ijk = &
+ reshape((/ 1,1,1, 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,1,1 /),(/3,4/)) ! bottom
+ integer,dimension(3,4),parameter :: iface6_corner_ijk = &
+ reshape((/ 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! top
+ integer,dimension(3,4,6),parameter :: iface_all_corner_ijk = &
+ reshape((/ iface1_corner_ijk,iface2_corner_ijk, &
+ iface3_corner_ijk,iface4_corner_ijk, &
+ iface5_corner_ijk,iface6_corner_ijk /),(/3,4,6/)) ! all faces
+ integer:: ispecngb,iadj,ipmlinterface
+ integer :: ispecPMLngb_corner,ispecPMLngb_edge,ispecPMLngb_sngl
+ integer,dimension(:),allocatable :: iglob_nadj,ispec_is_PML_inum_org
+ integer,dimension(:,:,:),allocatable :: iglob_adj
+
+
+ ! checks normals for elements adjacent to edge/corner elements
+ ! assigns element information to each global point
+ ! (note: mpi partitioning/interface between elements not considered yet)
+ allocate(iglob_nadj(NGLOB_AB),iglob_adj(2,32,NGLOB_AB))
+ iglob_nadj(:) = 0
+ iglob_adj(:,:,:) = 0
+ do ispecPML=1,num_PML_ispec
+ ispec = PML_ispec(ispecPML)
+ ! sets element corners
+ do iface=1,2
+ do icorner=1,NGNOD2D
+ iglob = ibool(iface_all_corner_ijk(1,icorner,iface),&
+ iface_all_corner_ijk(2,icorner,iface),&
+ iface_all_corner_ijk(3,icorner,iface),ispec)
+ ! number of occurrences
+ iglob_nadj(iglob) = iglob_nadj(iglob) + 1
+ ! first parameter is assigned element id ispec
+ iglob_adj(1,iglob_nadj(iglob),iglob) = ispec
+ ! second parameter is corresponding pml element id ispecPML
+ iglob_adj(2,iglob_nadj(iglob),iglob) = ispecPML
+ enddo
+ enddo
+ enddo
+ if( maxval(iglob_nadj(:)) > 32 ) then
+ print*,'info neighbors:',myrank
+ print*,'max number of adjacents:',maxval(iglob_nadj(:)),maxloc(iglob_nadj(:))
+ call exit_mpi(myrank,'error iglob number of adj')
+ endif
+
+ ! finds neighbors based on common nodes and changes type and normal accordingly
+ ! for edges and corners
+ allocate(ispec_is_PML_inum_org(NSPEC_AB))
+ ispec_is_PML_inum_org(:) = ispec_is_PML_inum(:)
+ do ispecPML=1,num_PML_ispec
+ ispec = PML_ispec(ispecPML)
+
+ ! only non-corner elements
+ if( ispec_is_PML_inum_org(ispec) <= 2 ) then
+ ipmlsngl_tot = 0
+ ipmlcorners_tot = 0
+ ipmledges_tot = 0
+ ipmlinterface = 0
+ ! loops over element corners
+ do iface=1,2
+ ! checks corner neighbors
+ do icorner=1,NGNOD2D
+ iglob = ibool(iface_all_corner_ijk(1,icorner,iface),&
+ iface_all_corner_ijk(2,icorner,iface),&
+ iface_all_corner_ijk(3,icorner,iface),ispec)
+ ! adjacent elements
+ ipmlsngl = 0
+ ipmlcorners = 0
+ ipmledges = 0
+ do iadj=1,iglob_nadj(iglob)
+ ispecngb = iglob_adj(1,iadj,iglob)
+ if( ispecngb /= ispec ) then
+ ! counts single normal neighbors
+ if( ispec_is_PML_inum_org(ispecngb) == 1 ) then
+ ipmlsngl = ipmlsngl + 1
+ ispecPMLngb_sngl = iglob_adj(2,iadj,iglob)
+ endif
+ ! counts corner neighbors
+ if( ispec_is_PML_inum_org(ispecngb) == 3 ) then
+ ipmlcorners = ipmlcorners + 1
+ ispecPMLngb_corner = iglob_adj(2,iadj,iglob)
+ endif
+ ! counts edge neighbors
+ if( ispec_is_PML_inum_org(ispecngb) == 2 ) then
+ ipmledges = ipmledges + 1
+ ispecPMLngb_edge = iglob_adj(2,iadj,iglob)
+ endif
+ endif
+ enddo
+ if( ipmlsngl > 0 ) ipmlsngl_tot = ipmlsngl_tot + 1
+ if( ipmlcorners > 0 ) ipmlcorners_tot = ipmlcorners_tot + 1
+ if( ipmledges > 0 ) ipmledges_tot = ipmledges_tot + 1
+
+ ! interface points
+ if( iglob_is_PML_interface(iglob) > 0 ) ipmlinterface = ipmlinterface + 1
+
+ enddo !icorner
+ enddo
+
+ ! elements inside PML
+ if( ipmlinterface < 4 ) then
+
+ ! shares two faces with edge elements, so it becomes an edge element too
+ if( ispec_is_PML_inum_org(ispec) == 1 ) then
+ if( ipmledges_tot >= 6 ) then
+ ispec_is_PML_inum(ispec) = 2
+ PML_normal(:,ispecPML) = PML_normal(:,ispecPMLngb_edge)
+ endif
+ if( ipmlcorners_tot >= 5 ) then
+ ispec_is_PML_inum(ispec) = 3
+ PML_normal(:,ispecPML) = PML_normal(:,ispecPMLngb_corner)
+ endif
+ else if( ispec_is_PML_inum_org(ispec) == 2 ) then
+
+ ! shares at least a face and a face edge with a corner element,
+ ! so it becomes a corner element too
+ if( ipmlcorners_tot >= 5 ) then
+ ispec_is_PML_inum(ispec) = 3
+ PML_normal(:,ispecPML) = PML_normal(:,ispecPMLngb_corner)
+ endif
+ endif
+ endif
+ ! avoid elements between two edges and next to corner to become edge elements
+ if( ispec_is_PML_inum(ispec) == 2 .and. ilayer > 1 ) then
+ if( ipmlsngl_tot == 8 .and. ipmlcorners_tot == 2 ) then
+ ispec_is_PML_inum(ispec) = 1
+ PML_normal(:,ispecPML) = PML_normal(:,ispecPMLngb_sngl)
+ endif
+ endif
+
+ endif
+ enddo
+ deallocate(iglob_adj,iglob_nadj)
+ deallocate(ispec_is_PML_inum_org)
+
+end subroutine PML_update_normals
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_output_VTKs()
+
+! outputs informations about PML elements
+
+ use PML_par
+ use specfem_par,only: NGLOB_AB,NSPEC_AB,myrank, &
+ prname,ibool,xstore,ystore,zstore
+ use constants,only: NGLLX,NGLLY,NGLLZ,IMAIN
+ implicit none
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable:: ispec_normal
+ real(kind=CUSTOM_REAL),dimension(:,:,:,:),allocatable:: temp_gllvalues
+ integer,dimension(:),allocatable :: temp_iglob
+ integer :: count,iglob,ispecPML,ispec
+ character(len=256) :: vtkfilename
+
+ ! element type flags
+ if( .false. ) then
+ vtkfilename = prname(1:len_trim(prname))//'PML_ispec_inum'
+ call write_VTK_data_elem_i(NSPEC_AB,NGLOB_AB,xstore,ystore,zstore,ibool,&
+ ispec_is_PML_inum,vtkfilename)
+ endif
+
+ ! interface points
+ if( .false. ) then
+ ! puts global points in a temporary array for plotting
+ count = 0
+ do iglob=1,NGLOB_AB
+ if( iglob_is_PML_interface(iglob) > 0 ) then
+ count = count+1
+ endif
+ enddo
+ allocate(temp_iglob(count))
+ count = 0
+ do iglob=1,NGLOB_AB
+ if( iglob_is_PML_interface(iglob) > 0 ) then
+ count = count+1
+ temp_iglob(count) = iglob
+ endif
+ enddo
+ vtkfilename = prname(1:len_trim(prname))//'PML_interface_points'
+ call write_VTK_data_points(NGLOB_AB,xstore,ystore,zstore, &
+ temp_iglob,count,vtkfilename)
+ deallocate(temp_iglob)
+ endif
+
+ ! pml normals
+ if( .false. ) then
+ allocate(ispec_normal(3,NSPEC_AB) )
+ ispec_normal(:,:) = 0._CUSTOM_REAL
+ do ispecPML=1,num_PML_ispec
+ ispec = PML_ispec(ispecPML)
+ ispec_normal(:,ispec) = PML_normal(:,ispecPML)
+ enddo
+ vtkfilename = prname(1:len_trim(prname))//'PML_normals'
+ call write_VTK_data_elem_vectors(NSPEC_AB,NGLOB_AB,xstore,ystore,zstore,ibool, &
+ ispec_normal,vtkfilename)
+ deallocate(ispec_normal)
+ endif
+
+ ! pml damping coefficients
+ if( .false. ) then
+ allocate(temp_gllvalues(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ temp_gllvalues = 0._CUSTOM_REAL
+ do ispecPML=1,num_PML_ispec
+ ispec = PML_ispec(ispecPML)
+ temp_gllvalues(:,:,:,ispec) = PML_damping_d(:,:,:,ispecPML)
+ enddo
+ vtkfilename = prname(1:len_trim(prname))//'PML_damping_d'
+ call write_VTK_data_gll_cr(NSPEC_AB,NGLOB_AB, &
+ xstore,ystore,zstore,ibool, &
+ temp_gllvalues,vtkfilename)
+ deallocate(temp_gllvalues)
+ endif ! VTK file output
+
+ if(myrank == 0) write(IMAIN,*)
+
+end subroutine PML_output_VTKs
\ No newline at end of file
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/aniso_model.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/aniso_model.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/aniso_model.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,300 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+!=====================================================================
+! 07/09/04 Last changed by Min Chen
+! Users need to modify this subroutine to implement their own
+! anisotropic models.
+!=====================================================================
+
+ subroutine aniso_model(iflag_aniso,rho,vp,vs,c11,c12,c13,c14,c15,c16, &
+ c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66)
+
+ implicit none
+
+ include "constants.h"
+
+! see for example:
+!
+! M. Chen & J. Tromp, 2006. Theoretical & numerical investigations
+! of global and regional seismic wave propagation in weakly anisotropic earth models,
+! GJI, 168, 1130-1152.
+
+!------------------------------------------------------------------------------
+! for anisotropy simulations in a halfspace model
+
+! only related to body waves
+! one-zeta term
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_CS1p_A = 0.2_CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_CS1sv_A = 0._CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_CS1sh_N = 0._CUSTOM_REAL
+! three-zeta term
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_CS3_L = 0._CUSTOM_REAL
+
+! Relative to Love wave
+! four-zeta term
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_N = 0._CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_E_N = 0._CUSTOM_REAL
+
+! Relative to Rayleigh wave
+! two-zeta term
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_A = 0._CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_C = 0._CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_F = 0._CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_H_F = 0._CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_B_A = 0._CUSTOM_REAL
+
+! Relative to both Love wave and Rayleigh wave
+! two-zeta term
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_L = 0._CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_G_L = 0._CUSTOM_REAL
+
+!------------------------------------------------------------------------------
+
+ !integer idoubling
+ integer iflag_aniso
+
+ !real(kind=CUSTOM_REAL) zmesh
+ real(kind=CUSTOM_REAL) rho,vp,vs
+ real(kind=CUSTOM_REAL) c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,c33,c34,c35,c36, &
+ c44,c45,c46,c55,c56,c66
+
+! local parameters
+ real(kind=CUSTOM_REAL) vpv,vph,vsv,vsh,eta_aniso
+ real(kind=CUSTOM_REAL) aa,cc,nn,ll,ff
+ real(kind=CUSTOM_REAL) A,C,F,AL,AN,Bc,Bs,Gc,Gs,Hc,Hs,Ec,Es,C1p,C1sv,C1sh,C3,S1p,S1sv,S1sh,S3
+ real(kind=CUSTOM_REAL) d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26,d33,d34,d35,d36, &
+ d44,d45,d46,d55,d56,d66
+
+! assumes vp,vs given in m/s, rho in kg/m**3
+ vph = vp
+ vpv = vp
+ vsh = vs
+ vsv = vs
+ eta_aniso = 1.0_CUSTOM_REAL
+
+
+! for definition, see for example:
+!
+! Dziewonski & Anderson, 1981. Preliminary reference earth model, PEPI, 25, 297-356.
+! page 305:
+ aa = rho*vph*vph
+ cc = rho*vpv*vpv
+ nn = rho*vsh*vsh
+ ll = rho*vsv*vsv
+ ff = eta_aniso*(aa - 2.*ll)
+
+! Add anisotropic perturbation
+
+! notation: see Chen & Tromp, 2006, appendix A, page 1151
+!
+! zeta-independant terms:
+! A = \delta A
+! C = \delta C
+! AN = \delta N
+! AL = \delta L
+! F = \delta F
+!
+! zeta-dependant terms:
+! C1p = J_c
+! C1sv = K_c
+! C1sh = M_c
+! S1p = J_s
+! S1sv = K_s
+! S1sh = M_s
+!
+! two-zeta dependant terms:
+! Gc = G_c
+! Gs = G_s
+! Bc = B_c
+! Bs = B_s
+! Hc = H_c
+! Hs = H_s
+!
+! three-zeta dependant terms:
+! C3 = D_c
+! S3 = D_s
+!
+! four-zeta dependant terms:
+! Ec = E_c
+! Es = E_s
+
+! no anisotropic perturbation
+ if( iflag_aniso <= 0 ) then
+ ! zeta-independant
+ A = aa
+ C = cc
+ AN = nn
+ AL = ll
+ F = ff
+
+ ! zeta-dependant terms
+ C1p = 0._CUSTOM_REAL
+ C1sv = 0._CUSTOM_REAL
+ C1sh = 0._CUSTOM_REAL
+ S1p = 0._CUSTOM_REAL
+ S1sv = 0._CUSTOM_REAL
+ S1sh = 0._CUSTOM_REAL
+
+ ! two-zeta dependant terms
+ Gc = 0._CUSTOM_REAL
+ Gs = 0._CUSTOM_REAL
+
+ Bc = 0._CUSTOM_REAL
+ Bs = 0._CUSTOM_REAL
+
+ Hc = 0._CUSTOM_REAL
+ Hs = 0._CUSTOM_REAL
+
+ ! three-zeta dependant terms
+ C3 = 0._CUSTOM_REAL
+ S3 = 0._CUSTOM_REAL
+
+ ! four-zeta dependant terms
+ Ec = 0._CUSTOM_REAL
+ Es = 0._CUSTOM_REAL
+ endif
+
+! perturbation model 1
+ if( iflag_aniso == IANISOTROPY_MODEL1 ) then
+ ! zeta-independant
+ A = aa*(1.0_CUSTOM_REAL + FACTOR_A)
+ C = cc*(1.0_CUSTOM_REAL + FACTOR_C)
+ AN = nn*(1.0_CUSTOM_REAL + FACTOR_N)
+ AL = ll*(1.0_CUSTOM_REAL + FACTOR_L)
+ F = ff*(1.0_CUSTOM_REAL + FACTOR_F)
+
+ ! zeta-dependant terms
+ C1p = FACTOR_CS1p_A*aa
+ C1sv = FACTOR_CS1sv_A*aa
+ C1sh = FACTOR_CS1sh_N*nn
+ S1p = 0._CUSTOM_REAL
+ S1sv = 0._CUSTOM_REAL
+ S1sh = 0._CUSTOM_REAL
+
+ ! two-zeta dependant terms
+ Gc = FACTOR_G_L*ll
+ Bc = FACTOR_B_A*aa
+ Hc = FACTOR_H_F*ff
+ Gs = 0._CUSTOM_REAL
+ Bs = 0._CUSTOM_REAL
+ Hs = 0._CUSTOM_REAL
+
+ ! three-zeta dependant terms
+ C3 = FACTOR_CS3_L*ll
+ S3 = 0._CUSTOM_REAL
+
+ ! four-zeta dependant terms
+ Ec = FACTOR_E_N*nn
+ Es = 0._CUSTOM_REAL
+ endif
+
+! perturbation model 2
+ if( iflag_aniso == IANISOTROPY_MODEL2 ) then
+ ! zeta-independant
+ A = aa*(1.0_CUSTOM_REAL + FACTOR_A + 0.1)
+ C = cc*(1.0_CUSTOM_REAL + FACTOR_C + 0.1)
+ AN = nn*(1.0_CUSTOM_REAL + FACTOR_N + 0.1)
+ AL = ll*(1.0_CUSTOM_REAL + FACTOR_L + 0.1)
+ F = ff*(1.0_CUSTOM_REAL + FACTOR_F + 0.1)
+
+ ! zeta-dependant terms
+ C1p = FACTOR_CS1p_A*aa
+ C1sv = FACTOR_CS1sv_A*aa
+ C1sh = FACTOR_CS1sh_N*nn
+ S1p = 0._CUSTOM_REAL
+ S1sv = 0._CUSTOM_REAL
+ S1sh = 0._CUSTOM_REAL
+
+ ! two-zeta dependant terms
+ Gc = FACTOR_G_L*ll
+ Bc = FACTOR_B_A*aa
+ Hc = FACTOR_H_F*ff
+ Gs = 0._CUSTOM_REAL
+ Bs = 0._CUSTOM_REAL
+ Hs = 0._CUSTOM_REAL
+
+ ! three-zeta dependant terms
+ C3 = FACTOR_CS3_L*ll
+ S3 = 0._CUSTOM_REAL
+
+ ! four-zeta dependant terms
+ Ec = FACTOR_E_N*nn
+ Es = 0._CUSTOM_REAL
+ endif
+
+
+! The mapping from the elastic coefficients to the elastic tensor elements
+! in the local Cartesian coordinate system (classical geographic) used in the
+! global code (1---South, 2---East, 3---up)
+! Always keep the following part when you modify this subroutine
+ d11 = A + Ec + Bc
+ d12 = A - 2.*AN - Ec
+ d13 = F + Hc
+ d14 = S3 + 2.*S1sh + 2.*S1p
+ d15 = 2.*C1p + C3
+ d16 = -Bs/2. - Es
+ d22 = A + Ec - Bc
+ d23 = F - Hc
+ d24 = 2.*S1p - S3
+ d25 = 2.*C1p - 2.*C1sh - C3
+ d26 = -Bs/2. + Es
+ d33 = C
+ d34 = 2.*(S1p - S1sv)
+ d35 = 2.*(C1p - C1sv)
+ d36 = -Hs
+ d44 = AL - Gc
+ d45 = -Gs
+ d46 = C1sh - C3
+ d55 = AL + Gc
+ d56 = S3 - S1sh
+ d66 = AN - Ec
+
+! The mapping to the global Cartesian coordinate system used in the code
+! (1---East, 2---North, 3---up)
+ c11 = d22
+ c12 = d12
+ c13 = d23
+ c14 = - d25
+ c15 = d24
+ c16 = - d26
+ c22 = d11
+ c23 = d13
+ c24 = - d15
+ c25 = d14
+ c26 = - d16
+ c33 = d33
+ c34 = - d35
+ c35 = d34
+ c36 = - d36
+ c44 = d55
+ c45 = - d45
+ c46 = d56
+ c55 = d44
+ c56 = - d46
+ c66 = d66
+
+ end subroutine aniso_model
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/ascii_2_sep.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/ascii_2_sep.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/ascii_2_sep.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,41 @@
+
+ program ascii_2_sep
+
+! to convert ASCII seismograms to SEP binary format
+
+ implicit none
+
+! Parameters to be defined to set the dimension of the arrays:
+! - nr = maximum number of receivers.
+! - ntime = maximum number of points of each seismogram.
+ integer, parameter :: nr = 101
+ integer, parameter :: ntime = 512
+
+ real(kind=4), dimension(ntime,nr) :: sy
+
+ integer :: it,ir,i
+
+! read seismogram component in ASCII text format
+ print *,'Reading seismograms in text format'
+
+ open(unit=11,file='U_file.txt',status='unknown')
+ do ir=1,nr
+ do it=1,ntime
+ read(11,*) sy(it,ir)
+
+! invert sign of vertical component if needed depending on the reference frame convention
+! sy(it,ir) = - sy(it,ir)
+
+ enddo
+ enddo
+ close(11)
+
+! write seismogram component in binary SEP format
+ print *,'Saving seismograms in SEP format'
+
+ open(unit=11,file='U_file.sep',status='unknown',access='direct',recl=ntime*nr*4)
+ write(11,rec=1) (sy(i,1),i=1,ntime*nr)
+ close(11)
+
+ end program ascii_2_sep
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/assemble_MPI_scalar.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/assemble_MPI_scalar.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/assemble_MPI_scalar.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,340 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+!----
+!---- assemble the contributions between slices using non-blocking MPI
+!----
+
+ subroutine assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,array_val, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+! subroutine assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,array_val, &
+! buffer_send_scalar_ext_mesh,buffer_recv_scalar_ext_mesh, &
+! num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+! nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+! my_neighbours_ext_mesh, &
+! request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
+
+ implicit none
+
+ include "constants.h"
+
+! array to assemble
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: array_val
+
+ integer :: NPROC
+ integer :: NGLOB_AB
+
+
+ integer :: num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh,my_neighbours_ext_mesh
+ integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
+
+! real(kind=CUSTOM_REAL), dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: &
+! buffer_send_scalar_ext_mesh,buffer_recv_scalar_ext_mesh
+! integer, dimension(num_interfaces_ext_mesh) :: request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh
+
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_scalar_ext_mesh
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_scalar_ext_mesh
+ integer, dimension(:), allocatable :: request_send_scalar_ext_mesh
+ integer, dimension(:), allocatable :: request_recv_scalar_ext_mesh
+
+
+ integer ipoin,iinterface
+
+! here we have to assemble all the contributions between partitions using MPI
+
+! assemble only if more than one partition
+ if(NPROC > 1) then
+
+ allocate(buffer_send_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(buffer_recv_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(request_send_scalar_ext_mesh(num_interfaces_ext_mesh))
+ allocate(request_recv_scalar_ext_mesh(num_interfaces_ext_mesh))
+
+ ! partition border copy into the buffer
+ do iinterface = 1, num_interfaces_ext_mesh
+ do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
+ buffer_send_scalar_ext_mesh(ipoin,iinterface) = array_val(ibool_interfaces_ext_mesh(ipoin,iinterface))
+ enddo
+ enddo
+
+ ! send messages
+ do iinterface = 1, num_interfaces_ext_mesh
+ call issend_cr(buffer_send_scalar_ext_mesh(1:nibool_interfaces_ext_mesh(iinterface),iinterface), &
+ nibool_interfaces_ext_mesh(iinterface), &
+ my_neighbours_ext_mesh(iinterface), &
+ itag, &
+ request_send_scalar_ext_mesh(iinterface) &
+ )
+ call irecv_cr(buffer_recv_scalar_ext_mesh(1:nibool_interfaces_ext_mesh(iinterface),iinterface), &
+ nibool_interfaces_ext_mesh(iinterface), &
+ my_neighbours_ext_mesh(iinterface), &
+ itag, &
+ request_recv_scalar_ext_mesh(iinterface) &
+ )
+ enddo
+
+ ! wait for communications completion
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_recv_scalar_ext_mesh(iinterface))
+ enddo
+
+ ! adding contributions of neighbours
+ do iinterface = 1, num_interfaces_ext_mesh
+ do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
+ array_val(ibool_interfaces_ext_mesh(ipoin,iinterface)) = &
+ array_val(ibool_interfaces_ext_mesh(ipoin,iinterface)) + buffer_recv_scalar_ext_mesh(ipoin,iinterface)
+ enddo
+ enddo
+
+ ! wait for communications completion (send)
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_send_scalar_ext_mesh(iinterface))
+ enddo
+
+ deallocate(buffer_send_scalar_ext_mesh)
+ deallocate(buffer_recv_scalar_ext_mesh)
+ deallocate(request_send_scalar_ext_mesh)
+ deallocate(request_recv_scalar_ext_mesh)
+
+ endif
+
+ end subroutine assemble_MPI_scalar_ext_mesh
+
+!
+!----
+!
+
+ subroutine assemble_MPI_scalar_i_ext_mesh(NPROC,NGLOB_AB,array_val, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+ implicit none
+
+ include "constants.h"
+
+! array to assemble
+ integer, dimension(NGLOB_AB) :: array_val
+
+ integer :: NPROC
+ integer :: NGLOB_AB
+
+ integer :: num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh,my_neighbours_ext_mesh
+ integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
+
+ integer, dimension(:,:), allocatable :: buffer_send_scalar_ext_mesh
+ integer, dimension(:,:), allocatable :: buffer_recv_scalar_ext_mesh
+ integer, dimension(:), allocatable :: request_send_scalar_ext_mesh
+ integer, dimension(:), allocatable :: request_recv_scalar_ext_mesh
+
+ integer :: ipoin,iinterface
+
+! here we have to assemble all the contributions between partitions using MPI
+
+! assemble only if more than one partition
+ if(NPROC > 1) then
+
+ allocate(buffer_send_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(buffer_recv_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(request_send_scalar_ext_mesh(num_interfaces_ext_mesh))
+ allocate(request_recv_scalar_ext_mesh(num_interfaces_ext_mesh))
+
+ ! partition border copy into the buffer
+ do iinterface = 1, num_interfaces_ext_mesh
+ do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
+ buffer_send_scalar_ext_mesh(ipoin,iinterface) = array_val(ibool_interfaces_ext_mesh(ipoin,iinterface))
+ enddo
+ enddo
+
+ ! send messages
+ do iinterface = 1, num_interfaces_ext_mesh
+ call issend_i(buffer_send_scalar_ext_mesh(1:nibool_interfaces_ext_mesh(iinterface),iinterface), &
+ nibool_interfaces_ext_mesh(iinterface), &
+ my_neighbours_ext_mesh(iinterface), &
+ itag, &
+ request_send_scalar_ext_mesh(iinterface) &
+ )
+ call irecv_i(buffer_recv_scalar_ext_mesh(1:nibool_interfaces_ext_mesh(iinterface),iinterface), &
+ nibool_interfaces_ext_mesh(iinterface), &
+ my_neighbours_ext_mesh(iinterface), &
+ itag, &
+ request_recv_scalar_ext_mesh(iinterface) &
+ )
+ enddo
+
+ ! wait for communications completion
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_recv_scalar_ext_mesh(iinterface))
+ enddo
+
+ ! adding contributions of neighbours
+ do iinterface = 1, num_interfaces_ext_mesh
+ do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
+ array_val(ibool_interfaces_ext_mesh(ipoin,iinterface)) = &
+ array_val(ibool_interfaces_ext_mesh(ipoin,iinterface)) + buffer_recv_scalar_ext_mesh(ipoin,iinterface)
+ enddo
+ enddo
+
+ ! wait for communications completion (send)
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_send_scalar_ext_mesh(iinterface))
+ enddo
+
+ deallocate(buffer_send_scalar_ext_mesh)
+ deallocate(buffer_recv_scalar_ext_mesh)
+ deallocate(request_send_scalar_ext_mesh)
+ deallocate(request_recv_scalar_ext_mesh)
+
+ endif
+
+ end subroutine assemble_MPI_scalar_i_ext_mesh
+
+!
+!----
+!
+
+ subroutine assemble_MPI_scalar_ext_mesh_s(NPROC,NGLOB_AB,array_val, &
+ buffer_send_scalar_ext_mesh,buffer_recv_scalar_ext_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh, &
+ request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
+
+! non-blocking MPI send
+
+ implicit none
+
+ include "constants.h"
+
+! array to send
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: array_val
+
+ integer :: NPROC
+ integer :: NGLOB_AB
+
+ real(kind=CUSTOM_REAL), dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: &
+ buffer_send_scalar_ext_mesh,buffer_recv_scalar_ext_mesh
+
+ integer :: num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh,my_neighbours_ext_mesh
+ integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh
+
+ integer ipoin,iinterface
+
+! sends only if more than one partition
+ if(NPROC > 1) then
+
+ ! partition border copy into the buffer
+ do iinterface = 1, num_interfaces_ext_mesh
+ do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
+ buffer_send_scalar_ext_mesh(ipoin,iinterface) = array_val(ibool_interfaces_ext_mesh(ipoin,iinterface))
+ enddo
+ enddo
+
+ ! send messages
+ do iinterface = 1, num_interfaces_ext_mesh
+ call issend_cr(buffer_send_scalar_ext_mesh(1:nibool_interfaces_ext_mesh(iinterface),iinterface), &
+ nibool_interfaces_ext_mesh(iinterface), &
+ my_neighbours_ext_mesh(iinterface), &
+ itag, &
+ request_send_scalar_ext_mesh(iinterface) &
+ )
+ call irecv_cr(buffer_recv_scalar_ext_mesh(1:nibool_interfaces_ext_mesh(iinterface),iinterface), &
+ nibool_interfaces_ext_mesh(iinterface), &
+ my_neighbours_ext_mesh(iinterface), &
+ itag, &
+ request_recv_scalar_ext_mesh(iinterface) &
+ )
+
+ enddo
+
+ endif
+
+ end subroutine assemble_MPI_scalar_ext_mesh_s
+
+!
+!----
+!
+
+ subroutine assemble_MPI_scalar_ext_mesh_w(NPROC,NGLOB_AB,array_val, &
+ buffer_recv_scalar_ext_mesh,num_interfaces_ext_mesh, &
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
+
+! waits for send/receiver to be completed and assembles contributions
+
+ implicit none
+
+ include "constants.h"
+
+! array to assemble
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: array_val
+
+ integer :: NPROC
+ integer :: NGLOB_AB
+
+ real(kind=CUSTOM_REAL), dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: &
+ buffer_recv_scalar_ext_mesh
+
+ integer :: num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh
+ integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh
+
+ integer ipoin,iinterface
+
+! assemble only if more than one partition
+ if(NPROC > 1) then
+
+ ! wait for communications completion
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_recv_scalar_ext_mesh(iinterface))
+ enddo
+
+ ! adding contributions of neighbours
+ do iinterface = 1, num_interfaces_ext_mesh
+ do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
+ array_val(ibool_interfaces_ext_mesh(ipoin,iinterface)) = &
+ array_val(ibool_interfaces_ext_mesh(ipoin,iinterface)) + buffer_recv_scalar_ext_mesh(ipoin,iinterface)
+ enddo
+ enddo
+
+ ! wait for communications completion (send)
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_send_scalar_ext_mesh(iinterface))
+ enddo
+
+ endif
+
+ end subroutine assemble_MPI_scalar_ext_mesh_w
+
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/assemble_MPI_vector.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/assemble_MPI_vector.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/assemble_MPI_vector.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,246 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+!----
+!---- assemble the contributions between slices using non-blocking MPI
+!----
+
+ subroutine assemble_MPI_vector_ext_mesh(NPROC,NGLOB_AB,array_val, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+ implicit none
+
+ include "constants.h"
+
+! array to assemble
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: array_val
+
+ integer :: NPROC
+ integer :: NGLOB_AB
+
+ integer :: num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh,my_neighbours_ext_mesh
+ integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
+
+ ! local parameters
+
+ ! send/receive temporary buffers
+ !real(kind=CUSTOM_REAL), dimension(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: &
+ ! buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: buffer_send_vector_ext_mesh
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: buffer_recv_vector_ext_mesh
+
+ ! requests
+ !integer, dimension(num_interfaces_ext_mesh) :: request_send_vector_ext_mesh,request_recv_vector_ext_mesh
+ integer, dimension(:), allocatable :: request_send_vector_ext_mesh
+ integer, dimension(:), allocatable :: request_recv_vector_ext_mesh
+
+ integer ipoin,iinterface
+
+
+! here we have to assemble all the contributions between partitions using MPI
+
+! assemble only if more than one partition
+ if(NPROC > 1) then
+
+ allocate(buffer_send_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(buffer_recv_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(request_send_vector_ext_mesh(num_interfaces_ext_mesh))
+ allocate(request_recv_vector_ext_mesh(num_interfaces_ext_mesh))
+
+ ! partition border copy into the buffer
+ do iinterface = 1, num_interfaces_ext_mesh
+ do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
+ buffer_send_vector_ext_mesh(:,ipoin,iinterface) = array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface))
+ enddo
+ enddo
+
+ ! send messages
+ do iinterface = 1, num_interfaces_ext_mesh
+ call issend_cr(buffer_send_vector_ext_mesh(1,1,iinterface), &
+ NDIM*nibool_interfaces_ext_mesh(iinterface), &
+ my_neighbours_ext_mesh(iinterface), &
+ itag, &
+ request_send_vector_ext_mesh(iinterface) &
+ )
+ call irecv_cr(buffer_recv_vector_ext_mesh(1,1,iinterface), &
+ NDIM*nibool_interfaces_ext_mesh(iinterface), &
+ my_neighbours_ext_mesh(iinterface), &
+ itag, &
+ request_recv_vector_ext_mesh(iinterface) &
+ )
+ enddo
+
+ ! wait for communications completion (recv)
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_recv_vector_ext_mesh(iinterface))
+ enddo
+
+ ! adding contributions of neighbours
+ do iinterface = 1, num_interfaces_ext_mesh
+ do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
+ array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface)) = &
+ array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface)) + buffer_recv_vector_ext_mesh(:,ipoin,iinterface)
+ enddo
+ enddo
+
+ ! wait for communications completion (send)
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_send_vector_ext_mesh(iinterface))
+ enddo
+
+ deallocate(buffer_send_vector_ext_mesh)
+ deallocate(buffer_recv_vector_ext_mesh)
+ deallocate(request_send_vector_ext_mesh)
+ deallocate(request_recv_vector_ext_mesh)
+
+ endif
+
+ end subroutine assemble_MPI_vector_ext_mesh
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine assemble_MPI_vector_ext_mesh_s(NPROC,NGLOB_AB,array_val, &
+ buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,my_neighbours_ext_mesh, &
+ request_send_vector_ext_mesh,request_recv_vector_ext_mesh &
+ )
+
+! sends data
+
+ implicit none
+
+ include "constants.h"
+
+! array to assemble
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: array_val
+
+ integer :: NPROC
+ integer :: NGLOB_AB
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: &
+ buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh
+
+ integer :: num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh,my_neighbours_ext_mesh
+ integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: request_send_vector_ext_mesh,request_recv_vector_ext_mesh
+
+ integer ipoin,iinterface
+
+! here we have to assemble all the contributions between partitions using MPI
+
+! assemble only if more than one partition
+ if(NPROC > 1) then
+
+! partition border copy into the buffer
+ do iinterface = 1, num_interfaces_ext_mesh
+ do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
+ buffer_send_vector_ext_mesh(:,ipoin,iinterface) = array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface))
+ enddo
+ enddo
+
+! send messages
+ do iinterface = 1, num_interfaces_ext_mesh
+ call issend_cr(buffer_send_vector_ext_mesh(1,1,iinterface), &
+ NDIM*nibool_interfaces_ext_mesh(iinterface), &
+ my_neighbours_ext_mesh(iinterface), &
+ itag, &
+ request_send_vector_ext_mesh(iinterface) &
+ )
+ call irecv_cr(buffer_recv_vector_ext_mesh(1,1,iinterface), &
+ NDIM*nibool_interfaces_ext_mesh(iinterface), &
+ my_neighbours_ext_mesh(iinterface), &
+ itag, &
+ request_recv_vector_ext_mesh(iinterface) &
+ )
+ enddo
+
+ endif
+
+ end subroutine assemble_MPI_vector_ext_mesh_s
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine assemble_MPI_vector_ext_mesh_w(NPROC,NGLOB_AB,array_val, &
+ buffer_recv_vector_ext_mesh,num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ request_send_vector_ext_mesh,request_recv_vector_ext_mesh)
+
+! waits for data to receive and assembles
+
+ implicit none
+
+ include "constants.h"
+
+! array to assemble
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: array_val
+
+ integer :: NPROC
+ integer :: NGLOB_AB
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: &
+ buffer_recv_vector_ext_mesh
+
+ integer :: num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh
+ integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: request_send_vector_ext_mesh,request_recv_vector_ext_mesh
+
+ integer ipoin,iinterface
+
+! here we have to assemble all the contributions between partitions using MPI
+
+! assemble only if more than one partition
+ if(NPROC > 1) then
+
+! wait for communications completion (recv)
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_recv_vector_ext_mesh(iinterface))
+ enddo
+
+! adding contributions of neighbours
+ do iinterface = 1, num_interfaces_ext_mesh
+ do ipoin = 1, nibool_interfaces_ext_mesh(iinterface)
+ array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface)) = &
+ array_val(:,ibool_interfaces_ext_mesh(ipoin,iinterface)) + buffer_recv_vector_ext_mesh(:,ipoin,iinterface)
+ enddo
+ enddo
+
+! wait for communications completion (send)
+ do iinterface = 1, num_interfaces_ext_mesh
+ call wait_req(request_send_vector_ext_mesh(iinterface))
+ enddo
+
+ endif
+
+ end subroutine assemble_MPI_vector_ext_mesh_w
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/calc_jacobian.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/calc_jacobian.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/calc_jacobian.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,360 @@
+!=====================================================================
+!
+! 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 calc_jacobian(myrank,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore,jacobianstore, &
+ xstore,ystore,zstore, &
+ xelm,yelm,zelm,shape3D,dershape3D,ispec,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer ispec,nspec,myrank
+
+ double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
+ double precision dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ)
+
+ double precision, dimension(NGNOD) :: xelm,yelm,zelm
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore,jacobianstore
+
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
+
+ integer i,j,k,ia
+ double precision xxi,xeta,xgamma,yxi,yeta,ygamma,zxi,zeta,zgamma
+ double precision xmesh,ymesh,zmesh
+ double precision xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+ double precision jacobian
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ xxi = ZERO
+ xeta = ZERO
+ xgamma = ZERO
+ yxi = ZERO
+ yeta = ZERO
+ ygamma = ZERO
+ zxi = ZERO
+ zeta = ZERO
+ zgamma = ZERO
+ xmesh = ZERO
+ ymesh = ZERO
+ zmesh = ZERO
+
+ do ia=1,NGNOD
+ xxi = xxi + dershape3D(1,ia,i,j,k)*xelm(ia)
+ xeta = xeta + dershape3D(2,ia,i,j,k)*xelm(ia)
+ xgamma = xgamma + dershape3D(3,ia,i,j,k)*xelm(ia)
+ yxi = yxi + dershape3D(1,ia,i,j,k)*yelm(ia)
+ yeta = yeta + dershape3D(2,ia,i,j,k)*yelm(ia)
+ ygamma = ygamma + dershape3D(3,ia,i,j,k)*yelm(ia)
+ zxi = zxi + dershape3D(1,ia,i,j,k)*zelm(ia)
+ zeta = zeta + dershape3D(2,ia,i,j,k)*zelm(ia)
+ zgamma = zgamma + dershape3D(3,ia,i,j,k)*zelm(ia)
+ xmesh = xmesh + shape3D(ia,i,j,k)*xelm(ia)
+ ymesh = ymesh + shape3D(ia,i,j,k)*yelm(ia)
+ zmesh = zmesh + shape3D(ia,i,j,k)*zelm(ia)
+ enddo
+
+ jacobian = xxi*(yeta*zgamma-ygamma*zeta) - &
+ xeta*(yxi*zgamma-ygamma*zxi) + &
+ xgamma*(yxi*zeta-yeta*zxi)
+! can ignore negative jacobian in mesher if needed when debugging code
+ if(jacobian <= ZERO) call exit_MPI(myrank,'3D Jacobian undefined')
+
+! 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))
+! save the derivatives and the jacobian
+! distinguish between single and double precision for reals
+ 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
+
+ xstore(i,j,k,ispec) = xmesh
+ ystore(i,j,k,ispec) = ymesh
+ zstore(i,j,k,ispec) = zmesh
+
+ enddo
+ enddo
+ enddo
+
+ 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
+!
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/check_buffers_2D.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/check_buffers_2D.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/check_buffers_2D.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,325 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! code to check that all the internal MPI buffers are okay along xi and eta
+! we compare the coordinates of the points in the buffers
+
+ program check_buffers_2D
+
+ implicit none
+
+ include "constants.h"
+
+ integer ithisproc,iotherproc
+
+ integer ipoin
+
+ integer npoin2d_xi_save,npoin2d_xi_mesher,npoin2d_xi
+ integer npoin2d_eta_save,npoin2d_eta_mesher,npoin2d_eta
+
+! for addressing of the slices
+ integer iproc_xi,iproc_eta,iproc
+ integer iproc_read
+ integer, dimension(:,:), allocatable :: addressing
+
+ double precision diff
+
+! 2-D addressing and buffers for summation between slices
+ integer, dimension(:), allocatable :: iboolleft_xi,iboolright_xi, &
+ iboolleft_eta,iboolright_eta
+
+! coordinates of the points to compare
+ double precision, dimension(:), allocatable :: xleft_xi,yleft_xi,zleft_xi, &
+ xright_xi,yright_xi,zright_xi,xleft_eta,yleft_eta,zleft_eta, &
+ xright_eta,yright_eta,zright_eta
+
+! 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 NSOURCES
+
+ 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
+
+ logical HARVARD_3D_GOCAD_MODEL,ATTENUATION,USE_OLSEN_ATTENUATION, &
+ OCEANS,IMPOSE_MINIMUM_VP_GOCAD,HAUKSSON_REGIONAL_MODEL, &
+ BASEMENT_MAP,MOHO_MAP_LUPEI,ABSORBING_CONDITIONS,SAVE_FORWARD
+ logical ANISOTROPY,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION
+ logical MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ USE_HIGHRES_FOR_MOVIES,SUPPRESS_UTM_PROJECTION,USE_REGULAR_MESH
+ integer NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
+
+ character(len=256) OUTPUT_FILES,LOCAL_PATH,MODEL
+
+! parameters deduced from parameters read from file
+ integer NPROC,NEX_PER_PROC_XI,NEX_PER_PROC_ETA
+ integer NER
+
+! now this is for all the regions
+ 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
+
+! processor identification
+ character(len=256) prname,prname_other
+
+! ************** PROGRAM STARTS HERE **************
+
+ print *
+ print *,'Check all MPI buffers along xi and eta'
+ 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,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)
+
+! 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)
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+ print *
+ print *,'There are ',NPROC,' slices numbered from 0 to ',NPROC-1
+ print *,'There are ',NPROC_XI,' slices along xi'
+ print *,'There are ',NPROC_ETA,' slices along eta'
+ print *
+
+! dynamic memory allocation for arrays
+ allocate(addressing(0:NPROC_XI-1,0:NPROC_ETA-1))
+
+! open file with global slice number addressing
+ print *,'reading slice addressing'
+ open(unit=34,file=trim(OUTPUT_FILES)//'/addressing.txt',status='old',action='read')
+ do iproc = 0,NPROC-1
+ read(34,*) iproc_read,iproc_xi,iproc_eta
+ if(iproc_read /= iproc) stop 'incorrect slice number read'
+ addressing(iproc_xi,iproc_eta) = iproc
+ enddo
+ close(34)
+
+! dynamic memory allocation for arrays
+ allocate(iboolleft_xi(NPOIN2DMAX_XMIN_XMAX))
+ allocate(iboolright_xi(NPOIN2DMAX_XMIN_XMAX))
+ allocate(iboolleft_eta(NPOIN2DMAX_YMIN_YMAX))
+ allocate(iboolright_eta(NPOIN2DMAX_YMIN_YMAX))
+ allocate(xleft_xi(NPOIN2DMAX_XMIN_XMAX))
+ allocate(yleft_xi(NPOIN2DMAX_XMIN_XMAX))
+ allocate(zleft_xi(NPOIN2DMAX_XMIN_XMAX))
+ allocate(xright_xi(NPOIN2DMAX_XMIN_XMAX))
+ allocate(yright_xi(NPOIN2DMAX_XMIN_XMAX))
+ allocate(zright_xi(NPOIN2DMAX_XMIN_XMAX))
+ allocate(xleft_eta(NPOIN2DMAX_YMIN_YMAX))
+ allocate(yleft_eta(NPOIN2DMAX_YMIN_YMAX))
+ allocate(zleft_eta(NPOIN2DMAX_YMIN_YMAX))
+ allocate(xright_eta(NPOIN2DMAX_YMIN_YMAX))
+ allocate(yright_eta(NPOIN2DMAX_YMIN_YMAX))
+ allocate(zright_eta(NPOIN2DMAX_YMIN_YMAX))
+
+! double loop on NPROC_XI and NPROC_ETA
+ do iproc_eta=0,NPROC_ETA-1
+
+ print *,'checking row ',iproc_eta
+
+ do iproc_xi=0,NPROC_XI-2
+
+ print *,'checking slice ixi = ',iproc_xi,' in that row'
+
+ ithisproc = addressing(iproc_xi,iproc_eta)
+ iotherproc = addressing(iproc_xi+1,iproc_eta)
+
+! create the name for the database of the current slide
+ call create_serial_name_database(prname,ithisproc,LOCAL_PATH,NPROC,OUTPUT_FILES)
+ call create_serial_name_database(prname_other,iotherproc,LOCAL_PATH,NPROC,OUTPUT_FILES)
+
+! read 2-D addressing for summation between slices along xi with MPI
+
+! read iboolright_xi of this slice
+ write(*,*) 'reading MPI buffer iboolright_xi slice ',ithisproc
+ open(unit=34,file=prname(1:len_trim(prname))//'iboolright_xi.txt',status='old',action='read')
+ npoin2D_xi = 1
+ 360 continue
+ read(34,*) iboolright_xi(npoin2D_xi), &
+ xright_xi(npoin2D_xi),yright_xi(npoin2D_xi),zright_xi(npoin2D_xi)
+ if(iboolright_xi(npoin2D_xi) > 0) then
+ npoin2D_xi = npoin2D_xi + 1
+ goto 360
+ endif
+ npoin2D_xi = npoin2D_xi - 1
+ write(*,*) 'found ',npoin2D_xi,' points in iboolright_xi slice ',ithisproc
+ read(34,*) npoin2D_xi_mesher
+ if(npoin2D_xi > NPOIN2DMAX_XMIN_XMAX .or. npoin2D_xi /= npoin2D_xi_mesher) then
+ stop 'incorrect iboolright_xi read'
+ endif
+ close(34)
+
+! save to compare to other side
+ npoin2D_xi_save = npoin2D_xi
+
+! read iboolleft_xi of other slice
+ write(*,*) 'reading MPI buffer iboolleft_xi slice ',iotherproc
+ open(unit=34,file=prname_other(1:len_trim(prname_other))//'iboolleft_xi.txt',status='old',action='read')
+ npoin2D_xi = 1
+ 350 continue
+ read(34,*) iboolleft_xi(npoin2D_xi), &
+ xleft_xi(npoin2D_xi),yleft_xi(npoin2D_xi),zleft_xi(npoin2D_xi)
+ if(iboolleft_xi(npoin2D_xi) > 0) then
+ npoin2D_xi = npoin2D_xi + 1
+ goto 350
+ endif
+ npoin2D_xi = npoin2D_xi - 1
+ write(*,*) 'found ',npoin2D_xi,' points in iboolleft_xi slice ',iotherproc
+ read(34,*) npoin2D_xi_mesher
+ if(npoin2D_xi > NPOIN2DMAX_XMIN_XMAX .or. npoin2D_xi /= npoin2D_xi_mesher) then
+ stop 'incorrect iboolleft_xi read'
+ endif
+ close(34)
+
+ if(npoin2D_xi_save == npoin2D_xi) then
+ print *,'okay, same size for both buffers'
+ else
+ stop 'wrong buffer size'
+ endif
+
+! check the coordinates of all the points in the buffer
+! to see if it is correctly sorted
+ do ipoin = 1,npoin2D_xi
+ diff = dmax1(dabs(xleft_xi(ipoin)-xright_xi(ipoin)), &
+ dabs(yleft_xi(ipoin)-yright_xi(ipoin)),dabs(zleft_xi(ipoin)-zright_xi(ipoin)))
+ if(diff > 0.0000001d0) then
+ print *,'different: ',ipoin,iboolleft_xi(ipoin),iboolright_xi(ipoin),diff
+ stop 'error: different'
+ endif
+ enddo
+
+ enddo
+ enddo
+
+
+! double loop on NPROC_XI and NPROC_ETA
+ do iproc_xi=0,NPROC_XI-1
+
+ print *,'checking row ',iproc_xi
+
+ do iproc_eta=0,NPROC_ETA-2
+
+ print *,'checking slice ieta = ',iproc_eta,' in that row'
+
+ ithisproc = addressing(iproc_xi,iproc_eta)
+ iotherproc = addressing(iproc_xi,iproc_eta+1)
+
+! create the name for the database of the current slide
+ call create_serial_name_database(prname,ithisproc,LOCAL_PATH,NPROC,OUTPUT_FILES)
+ call create_serial_name_database(prname_other,iotherproc,LOCAL_PATH,NPROC,OUTPUT_FILES)
+
+! read 2-D addressing for summation between slices along xi with MPI
+
+! read iboolright_eta of this slice
+ write(*,*) 'reading MPI buffer iboolright_eta slice ',ithisproc
+ open(unit=34,file=prname(1:len_trim(prname))//'iboolright_eta.txt',status='old',action='read')
+ npoin2D_eta = 1
+ 460 continue
+ read(34,*) iboolright_eta(npoin2D_eta), &
+ xright_eta(npoin2D_eta),yright_eta(npoin2D_eta),zright_eta(npoin2D_eta)
+ if(iboolright_eta(npoin2D_eta) > 0) then
+ npoin2D_eta = npoin2D_eta + 1
+ goto 460
+ endif
+ npoin2D_eta = npoin2D_eta - 1
+ write(*,*) 'found ',npoin2D_eta,' points in iboolright_eta slice ',ithisproc
+ read(34,*) npoin2D_eta_mesher
+ if(npoin2D_eta > NPOIN2DMAX_YMIN_YMAX .or. npoin2D_eta /= npoin2D_eta_mesher) then
+ stop 'incorrect iboolright_eta read'
+ endif
+ close(34)
+
+! save to compare to other side
+ npoin2D_eta_save = npoin2D_eta
+
+! read iboolleft_eta of other slice
+ write(*,*) 'reading MPI buffer iboolleft_eta slice ',iotherproc
+ open(unit=34,file=prname_other(1:len_trim(prname_other))//'iboolleft_eta.txt',status='old',action='read')
+ npoin2D_eta = 1
+ 450 continue
+ read(34,*) iboolleft_eta(npoin2D_eta), &
+ xleft_eta(npoin2D_eta),yleft_eta(npoin2D_eta),zleft_eta(npoin2D_eta)
+ if(iboolleft_eta(npoin2D_eta) > 0) then
+ npoin2D_eta = npoin2D_eta + 1
+ goto 450
+ endif
+ npoin2D_eta = npoin2D_eta - 1
+ write(*,*) 'found ',npoin2D_eta,' points in iboolleft_eta slice ',iotherproc
+ read(34,*) npoin2D_eta_mesher
+ if(npoin2D_eta > NPOIN2DMAX_YMIN_YMAX .or. npoin2D_eta /= npoin2D_eta_mesher) then
+ stop 'incorrect iboolleft_eta read'
+ endif
+ close(34)
+
+ if(npoin2D_eta_save == npoin2D_eta) then
+ print *,'okay, same size for both buffers'
+ else
+ stop 'wrong buffer size'
+ endif
+
+! check the coordinates of all the points in the buffer
+! to see if it is correctly sorted
+ do ipoin = 1,npoin2D_eta
+ diff = dmax1(dabs(xleft_eta(ipoin)-xright_eta(ipoin)), &
+ dabs(yleft_eta(ipoin)-yright_eta(ipoin)),dabs(zleft_eta(ipoin)-zright_eta(ipoin)))
+ if(diff > 0.0000001d0) then
+ print *,'different: ',ipoin,iboolleft_eta(ipoin),iboolright_eta(ipoin),diff
+ stop 'error: different'
+ endif
+ enddo
+
+ enddo
+ enddo
+
+ print *
+ print *,'done'
+ print *
+
+ end program check_buffers_2D
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/check_mesh_resolution.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/check_mesh_resolution.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/check_mesh_resolution.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,300 @@
+!=====================================================================
+!
+! 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 check_mesh_resolution(myrank,NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore, &
+ kappastore,mustore,rho_vp,rho_vs, &
+ DT, model_speed_max )
+
+! check the mesh, stability and resolved period
+!
+! returns: maximum velocity in model ( model_speed_max )
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: kappastore,mustore,rho_vp,rho_vs
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: xstore,ystore,zstore
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+ double precision :: DT
+ real(kind=CUSTOM_REAL) :: model_speed_max
+
+ ! local parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ):: vp_elem,vs_elem
+ real(kind=CUSTOM_REAL), dimension(1) :: val_min,val_max
+ real(kind=CUSTOM_REAL) :: vpmin,vpmax,vsmin,vsmax,vpmin_glob,vpmax_glob,vsmin_glob,vsmax_glob
+ real(kind=CUSTOM_REAL) :: distance_min,distance_max,distance_min_glob,distance_max_glob,dx !,dy,dz
+ real(kind=CUSTOM_REAL) :: cmax,cmax_glob,pmax,pmax_glob
+ real(kind=CUSTOM_REAL) :: dt_suggested,dt_suggested_glob
+
+ logical:: DT_PRESENT
+
+ integer :: myrank
+ integer :: NSPEC_AB_global_min,NSPEC_AB_global_max,NSPEC_AB_global_sum
+ integer :: NGLOB_AB_global_min,NGLOB_AB_global_max,NGLOB_AB_global_sum
+ integer :: i,j,k,ii,jj,kk,ispec,iglob_a,iglob_b,sizeprocs
+
+! estimation of time step and period resolved
+ real(kind=CUSTOM_REAL),parameter :: COURANT_SUGGESTED = 0.3
+ real(kind=CUSTOM_REAL),parameter :: NELEM_PER_WAVELENGTH = 1.5
+ logical :: has_vs_zero
+
+! initializations
+ if( DT <= 0.0d0) then
+ DT_PRESENT = .false.
+ else
+ DT_PRESENT = .true.
+ endif
+
+ vpmin_glob = HUGEVAL
+ vpmax_glob = -HUGEVAL
+
+ vsmin_glob = HUGEVAL
+ vsmax_glob = -HUGEVAL
+
+ distance_min_glob = HUGEVAL
+ distance_max_glob = -HUGEVAL
+
+ cmax_glob = -HUGEVAL
+ pmax_glob = -HUGEVAL
+
+ dt_suggested_glob = HUGEVAL
+
+ has_vs_zero = .false.
+
+! checks courant number & minimum resolved period for each grid cell
+ do ispec=1,NSPEC_AB
+
+! determines minimum/maximum velocities within this element
+ vpmin = HUGEVAL
+ vpmax = -HUGEVAL
+ vsmin = HUGEVAL
+ vsmax = -HUGEVAL
+ ! vp
+ where( rho_vp(:,:,:,ispec) > TINYVAL )
+ vp_elem(:,:,:) = (FOUR_THIRDS * mustore(:,:,:,ispec) + kappastore(:,:,:,ispec)) / rho_vp(:,:,:,ispec)
+ elsewhere
+ vp_elem(:,:,:) = 0.0
+ endwhere
+ ! vs
+ where( rho_vs(:,:,:,ispec) > TINYVAL )
+ vs_elem(:,:,:) = mustore(:,:,:,ispec) / rho_vs(:,:,:,ispec)
+ elsewhere
+ vs_elem(:,:,:) = 0.0
+ endwhere
+
+ val_min = minval(vp_elem(:,:,:))
+ val_max = maxval(vp_elem(:,:,:))
+
+ vpmin = min(vpmin,val_min(1))
+ vpmax = max(vpmax,val_max(1))
+
+ val_min = minval(vs_elem(:,:,:))
+ val_max = maxval(vs_elem(:,:,:))
+
+ ! ignore fluid regions with Vs = 0
+ if( val_min(1) > 0.0001 ) then
+ vsmin = min(vsmin,val_min(1))
+ else
+ has_vs_zero = .true.
+ endif
+ vsmax = max(vsmax,val_max(1))
+
+ ! min/max for whole cpu partition
+ vpmin_glob = min ( vpmin_glob, vpmin)
+ vpmax_glob = max ( vpmax_glob, vpmax)
+
+ vsmin_glob = min ( vsmin_glob, vsmin)
+ vsmax_glob = max ( vsmax_glob, vsmax)
+
+! compute minimum and maximum distance of GLL points in this grid cell
+ distance_min = HUGEVAL
+ distance_max = -HUGEVAL
+
+ ! loops over all GLL points
+ do k=1,NGLLZ-1
+ do j=1,NGLLY-1
+ do i=1,NGLLX-1
+ iglob_a = ibool(i,j,k,ispec)
+
+ ! loops over nearest neighbor points
+ ! maybe a faster method could be found...
+ do kk=k-1,k+1
+ do jj=j-1,j+1
+ do ii=i-1,i+1
+ if( ii < 1 .or. jj < 1 .or. kk < 1 ) cycle
+ ! distances between points
+ iglob_b = ibool(ii,jj,kk,ispec)
+ if( iglob_a /= iglob_b) then
+ dx = sqrt( ( xstore(iglob_a) - xstore(iglob_b) )**2 &
+ + ( ystore(iglob_a) - ystore(iglob_b) )**2 &
+ + ( zstore(iglob_a) - zstore(iglob_b) )**2 )
+ if( dx < distance_min) distance_min = dx
+ if( dx > distance_max) distance_max = dx
+ endif
+ enddo
+ enddo
+ enddo
+
+ enddo
+ enddo
+ enddo
+
+ distance_min_glob = min( distance_min_glob, distance_min)
+ distance_max_glob = max( distance_max_glob, distance_max)
+
+ ! courant number
+ if( DT_PRESENT ) then
+ cmax = max( vpmax,vsmax ) * DT / distance_min
+ cmax_glob = max(cmax_glob,cmax)
+ endif
+
+ ! suggested timestep
+ dt_suggested = COURANT_SUGGESTED * distance_min / max( vpmax,vsmax )
+ dt_suggested_glob = min( dt_suggested_glob, dt_suggested)
+
+ ! estimation of minimum period resolved
+ pmax = distance_max / min( vpmin,vsmin ) * NELEM_PER_WAVELENGTH
+ pmax_glob = max(pmax_glob,pmax)
+
+ enddo
+
+! determines global min/max values from all cpu partitions
+ if( DT_PRESENT ) then
+ cmax = cmax_glob
+ call max_all_cr(cmax,cmax_glob)
+ endif
+
+ pmax = pmax_glob
+ call min_all_cr(pmax,pmax_glob)
+
+ dt_suggested = dt_suggested_glob
+ call min_all_cr(dt_suggested,dt_suggested_glob)
+
+ vpmin = vpmin_glob
+ vpmax = vpmax_glob
+ call min_all_cr(vpmin,vpmin_glob)
+ call max_all_cr(vpmax,vpmax_glob)
+
+ vsmin = vsmin_glob
+ if( has_vs_zero ) vsmin = 0.0
+
+ vsmax = vsmax_glob
+ call min_all_cr(vsmin,vsmin_glob)
+ call max_all_cr(vsmax,vsmax_glob)
+
+ distance_min = distance_min_glob
+ distance_max = distance_max_glob
+ call min_all_cr(distance_min,distance_min_glob)
+ call max_all_cr(distance_max,distance_max_glob)
+
+
+! checks mesh
+ if( distance_min_glob <= 0.0_CUSTOM_REAL ) then
+ call exit_mpi(myrank,"error: GLL points minimum distance")
+ endif
+ if( distance_max_glob >= HUGEVAL ) then
+ call exit_mpi(myrank,"error: GLL points maximum distance")
+ endif
+ if( vpmin_glob <= 0.0_CUSTOM_REAL ) then
+ call exit_mpi(myrank,"error: vp minimum velocity")
+ endif
+ if( vpmax_glob >= HUGEVAL ) then
+ call exit_mpi(myrank,"error: vp maximum velocity")
+ endif
+ if( vsmin_glob < 0.0_CUSTOM_REAL ) then
+ call exit_mpi(myrank,"error: vs minimum velocity")
+ endif
+ if( vsmax_glob >= HUGEVAL ) then
+ call exit_mpi(myrank,"error: vs maximum velocity")
+ endif
+
+
+!! DK DK May 2009: added this to print the minimum and maximum number of elements
+!! DK DK May 2009: and points in the CUBIT + SCOTCH mesh
+ call min_all_i(NSPEC_AB,NSPEC_AB_global_min)
+ call max_all_i(NSPEC_AB,NSPEC_AB_global_max)
+ call sum_all_i(NSPEC_AB,NSPEC_AB_global_sum)
+
+ call min_all_i(NGLOB_AB,NGLOB_AB_global_min)
+ call max_all_i(NGLOB_AB,NGLOB_AB_global_max)
+ call sum_all_i(NGLOB_AB,NGLOB_AB_global_sum)
+
+ call world_size(sizeprocs)
+
+! outputs infos
+ if ( myrank == 0 ) then
+ write(IMAIN,*)
+ write(IMAIN,*) '********'
+ write(IMAIN,*) 'minimum and maximum number of elements'
+ write(IMAIN,*) 'and points in the CUBIT + SCOTCH mesh:'
+ write(IMAIN,*)
+ write(IMAIN,*) 'NSPEC_AB_global_min = ',NSPEC_AB_global_min
+ write(IMAIN,*) 'NSPEC_AB_global_max = ',NSPEC_AB_global_max
+ !write(IMAIN,*) 'NSPEC_AB_global_mean = ',NSPEC_AB_global_sum / float(sizeprocs)
+ write(IMAIN,*) 'NSPEC_AB_global_sum = ',NSPEC_AB_global_sum
+ write(IMAIN,*)
+ write(IMAIN,*) 'NGLOB_AB_global_min = ',NGLOB_AB_global_min
+ write(IMAIN,*) 'NGLOB_AB_global_max = ',NGLOB_AB_global_max
+ write(IMAIN,*) 'NGLOB_AB_global_sum = ',NGLOB_AB_global_sum
+ write(IMAIN,*)
+ write(IMAIN,*) '********'
+ write(IMAIN,*) 'Model: P velocity min,max = ',vpmin_glob,vpmax_glob
+ write(IMAIN,*) 'Model: S velocity min,max = ',vsmin_glob,vsmax_glob
+ write(IMAIN,*) '********'
+ write(IMAIN,*)
+ write(IMAIN,*) '*********************************************'
+ write(IMAIN,*) '*** Verification of simulation parameters ***'
+ write(IMAIN,*) '*********************************************'
+ write(IMAIN,*)
+ write(IMAIN,*) '*** Max GLL point distance = ',distance_max_glob
+ write(IMAIN,*) '*** Min GLL point distance = ',distance_min_glob
+ write(IMAIN,*) '*** Max/min ratio = ',distance_max_glob/distance_min_glob
+ write(IMAIN,*)
+ write(IMAIN,*) '*** Minimum period resolved = ',pmax_glob
+ write(IMAIN,*) '*** Maximum suggested time step = ',dt_suggested_glob
+ write(IMAIN,*)
+ if( DT_PRESENT ) then
+ write(IMAIN,*) '*** for DT : ',DT
+ write(IMAIN,*) '*** Max stability for wave velocities = ',cmax_glob
+ write(IMAIN,*)
+ endif
+ endif
+
+ ! returns the maximum velocity
+ if( myrank == 0 ) then
+ if( vpmax_glob > vsmax_glob ) then
+ model_speed_max = vpmax_glob
+ else
+ model_speed_max = vsmax_glob
+ endif
+ endif
+ call bcast_all_cr(model_speed_max,1)
+
+
+ end subroutine
+
\ No newline at end of file
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/combine_AVS_DX.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/combine_AVS_DX.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/combine_AVS_DX.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,721 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! combine AVS or DX global data files to check the mesh
+! this is done in postprocessing after running the mesh generator
+! can combine full mesh, edges only or faces only
+
+ program combine_AVS_DX
+
+ implicit none
+
+ include "constants.h"
+
+ integer iproc,nspec,npoin
+ integer ispec
+ integer iglob1,iglob2,iglob3,iglob4
+ integer ipoin,numpoin,iglobpointoffset,ntotpoin,ntotspec
+ integer numelem,iglobelemoffset,idoubling,maxdoubling,iformat,ivalue,icolor
+ integer imaterial,imatprop
+ integer nrec,ir
+ integer ntotpoinAVS_DX,ntotspecAVS_DX
+
+ real random_val
+ integer ival_color
+ integer, dimension(:), allocatable :: random_colors
+
+ double precision xval,yval,zval
+ double precision val_color
+
+! for source location
+ integer yr,jda,ho,mi
+ double precision x_target_source,y_target_source,z_target_source
+ double precision x_source_quad1,y_source_quad1,z_source_quad1
+ double precision x_source_quad2,y_source_quad2,z_source_quad2
+ double precision x_source_quad3,y_source_quad3,z_source_quad3
+ double precision x_source_quad4,y_source_quad4,z_source_quad4
+ double precision sec
+
+ double precision, dimension(:), allocatable :: hdur,t_cmt,lat,long,depth
+ double precision, dimension(:,:), allocatable :: moment_tensor
+
+ logical USE_OPENDX
+
+! for receiver location
+ integer irec,ios
+ double precision, allocatable, dimension(:) :: stlat,stlon,stele,stbur
+ character(len=MAX_LENGTH_STATION_NAME), allocatable, dimension(:) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), allocatable, dimension(:) :: network_name
+ character(len=256) dummystring
+
+ double precision, allocatable, dimension(:) :: x_target,y_target,z_target
+
+! processor identification
+ character(len=256) prname
+
+! small offset for source and receiver line in AVS_DX
+! (small compared to normalized radius of the Earth)
+
+! offset to represent source and receivers for model
+ double precision, parameter :: small_offset = 2000.d0
+
+! 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 NSOURCES
+
+ 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
+
+ logical HARVARD_3D_GOCAD_MODEL,ATTENUATION,USE_OLSEN_ATTENUATION, &
+ OCEANS,IMPOSE_MINIMUM_VP_GOCAD,HAUKSSON_REGIONAL_MODEL, &
+ BASEMENT_MAP,MOHO_MAP_LUPEI,ABSORBING_CONDITIONS,SAVE_FORWARD
+ logical ANISOTROPY,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION
+ logical MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ USE_HIGHRES_FOR_MOVIES,SUPPRESS_UTM_PROJECTION,USE_REGULAR_MESH
+ integer NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
+
+ double precision zscaling
+
+ character(len=256) OUTPUT_FILES,LOCAL_PATH,MODEL,filtered_rec_filename
+
+! parameters deduced from parameters read from file
+ integer NPROC,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 proc_p1,proc_p2
+
+! ************** PROGRAM STARTS HERE **************
+
+! only for old regular meshes!
+
+ print *
+ print *,'Recombining all AVS or DX files for slices'
+ print *
+
+ print *
+ print *,'reading parameter file'
+ 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,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)
+
+ if(.not. SAVE_MESH_FILES) stop 'AVS or DX files were not saved by the mesher'
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+ allocate(hdur(NSOURCES))
+ allocate(t_cmt(NSOURCES))
+ allocate(lat(NSOURCES))
+ allocate(long(NSOURCES))
+ allocate(depth(NSOURCES))
+ allocate(moment_tensor(6,NSOURCES))
+
+ print *,'1 = create files in OpenDX format'
+ print *,'2 = create files in AVS UCD format'
+ print *,'any other value = exit'
+ print *
+ print *,'enter value:'
+ read(5,*) iformat
+ if(iformat<1 .or. iformat>2) stop 'exiting...'
+ if(iformat == 1) then
+ USE_OPENDX = .true.
+ else
+ USE_OPENDX = .false.
+ endif
+
+ print *
+ print *,'1 = edges of all the slices only'
+ print *,'2 = surface of the model only'
+ print *,'any other value = exit'
+ print *
+ print *,'enter value:'
+ read(5,*) ivalue
+ if(ivalue<1 .or. ivalue>2) stop 'exiting...'
+
+! apply scaling to topography if needed
+ if(ivalue == 2) then
+ print *
+ print *,'scaling to apply to Z to amplify topography (1. to do nothing, 0. to get flat surface):'
+ read(5,*) zscaling
+ else
+ zscaling = 1.d0
+ endif
+
+ print *
+ print *,'1 = color by doubling flag'
+ print *,'2 = by slice number'
+ print *,'3 = by elevation of topography (for surface of model only)'
+ print *,'4 = random color to show MPI slices'
+ print *,'any other value=exit'
+ print *
+ print *,'enter value:'
+ read(5,*) icolor
+ if(icolor<1 .or. icolor >4) stop 'exiting...'
+ if(icolor == 3 .and. ivalue /= 2) stop 'color by elevation of topography is for surface of model only'
+
+ print *
+ print *,'1 = material property by doubling flag'
+ print *,'2 = by slice number'
+ print *,'any other value=exit'
+ print *
+ print *,'enter value:'
+ read(5,*) imaterial
+ if(imaterial < 1 .or. imaterial > 2) stop 'exiting...'
+
+! 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)
+
+ print *
+ print *,'There are ',NPROC,' slices numbered from 0 to ',NPROC-1
+ print *
+
+! user can specify a range of processors here, enter 0 and -1 for all procs
+ print *
+ print *,'enter first proc (proc numbers start at 0) = '
+ read(5,*) proc_p1
+ if(proc_p1 < 0) proc_p1 = 0
+ if(proc_p1 > NPROC-1) proc_p1 = NPROC-1
+
+ print *,'enter last proc (enter -1 for all procs) = '
+ read(5,*) proc_p2
+ if(proc_p2 == -1) proc_p2 = NPROC-1
+ if(proc_p2 < 0) proc_p2 = 0
+ if(proc_p2 > NPROC-1) proc_p2 = NPROC-1
+
+! set interval to maximum if user input is not correct
+ if(proc_p1 <= 0) proc_p1 = 0
+ if(proc_p2 < 0) proc_p2 = NPROC - 1
+
+! set total number of points and elements to zero
+ ntotpoin = 0
+ ntotspec = 0
+
+! initialize random colors
+ allocate(random_colors(0:NPROC-1))
+ do iproc=0,NPROC-1
+ call random_number(random_val)
+ ival_color = nint(random_val*NPROC)
+ if(ival_color < 0) ival_color = 0
+ if(ival_color > NPROC-1) ival_color = NPROC-1
+ random_colors(iproc) = ival_color
+ enddo
+
+! loop on the selected range of processors
+ do iproc = proc_p1,proc_p2
+
+ print *,'Reading slice ',iproc
+
+! create the name for the database of the current slide
+ call create_serial_name_database(prname,iproc,LOCAL_PATH,NPROC,OUTPUT_FILES)
+
+ if(ivalue == 1) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='old',action='read')
+ else if(ivalue == 2) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='old',action='read')
+ endif
+
+ read(10,*) npoin
+ print *,'There are ',npoin,' global AVS or DX points in the slice'
+ ntotpoin = ntotpoin + npoin
+ close(10)
+
+ if(ivalue == 1) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='old',action='read')
+ else if(ivalue == 2) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='old',action='read')
+ endif
+
+ read(10,*) nspec
+ print *,'There are ',nspec,' AVS or DX elements in the slice'
+ ntotspec = ntotspec + nspec
+ close(10)
+
+ enddo
+
+ print *
+ print *,'There is a total of ',ntotspec,' elements in all the slices'
+ print *,'There is a total of ',ntotpoin,' points in all the slices'
+ print *
+
+ ntotpoinAVS_DX = ntotpoin
+ ntotspecAVS_DX = ntotspec
+
+! use different name for surface and for slices
+ if(USE_OPENDX) then
+ open(unit=11,file=trim(OUTPUT_FILES)//'/DX_fullmesh.dx',status='unknown')
+ write(11,*) 'object 1 class array type float rank 1 shape 3 items ',ntotpoinAVS_DX,' data follows'
+ else
+ open(unit=11,file=trim(OUTPUT_FILES)//'/AVS_fullmesh.inp',status='unknown')
+ endif
+
+! write AVS or DX header with element data or point data
+ if(.not. USE_OPENDX) then
+ if(ivalue == 2 .and. icolor == 3) then
+ write(11,*) ntotpoinAVS_DX,' ',ntotspecAVS_DX,' 1 0 0'
+ else
+ write(11,*) ntotpoinAVS_DX,' ',ntotspecAVS_DX,' 0 1 0'
+ endif
+ endif
+
+! ************* generate points ******************
+
+! set global point offset to zero
+ iglobpointoffset = 0
+
+! loop on the selected range of processors
+ do iproc=proc_p1,proc_p2
+
+ print *,'Reading slice ',iproc
+
+! create the name for the database of the current slide
+ call create_serial_name_database(prname,iproc,LOCAL_PATH,NPROC,OUTPUT_FILES)
+
+ if(ivalue == 1) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='old',action='read')
+ else if(ivalue == 2) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='old',action='read')
+ endif
+
+ read(10,*) npoin
+ print *,'There are ',npoin,' global AVS or DX points in the slice'
+
+! read local points in this slice and output global AVS or DX points
+ do ipoin=1,npoin
+ read(10,*) numpoin,xval,yval,zval
+ if(numpoin /= ipoin) stop 'incorrect point number'
+! write to AVS or DX global file with correct offset
+ if(USE_OPENDX) then
+ write(11,*) sngl(xval),' ',sngl(yval),' ',sngl(zval*zscaling)
+ else
+!! write(11,*) numpoin + iglobpointoffset,' ',sngl(xval),' ',sngl(yval),' ',sngl(zval*zscaling)
+!! XXX
+ if(zval < 0.) then
+ write(11,*) numpoin + iglobpointoffset,' ',sngl(xval),' ',sngl(yval),' ',sngl(zval*zscaling)
+else
+ write(11,*) numpoin + iglobpointoffset,' ',sngl(xval),' ',sngl(yval),' ',' 0'
+endif
+ endif
+
+ enddo
+
+ iglobpointoffset = iglobpointoffset + npoin
+
+ close(10)
+
+ enddo
+
+! ************* generate elements ******************
+
+! get source information for frequency for number of points per lambda
+ print *,'reading source duration from the CMTSOLUTION file'
+ call get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,NSOURCES)
+
+! set global element and point offsets to zero
+ iglobpointoffset = 0
+ iglobelemoffset = 0
+ maxdoubling = -1
+
+ if(USE_OPENDX) &
+ write(11,*) 'object 2 class array type int rank 1 shape 4 items ',ntotspecAVS_DX,' data follows'
+
+! loop on the selected range of processors
+ do iproc=proc_p1,proc_p2
+
+ print *,'Reading slice ',iproc
+
+! create the name for the database of the current slide
+ call create_serial_name_database(prname,iproc,LOCAL_PATH,NPROC,OUTPUT_FILES)
+
+ if(ivalue == 1) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='old',action='read')
+ open(unit=12,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='old',action='read')
+ else if(ivalue == 2) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='old',action='read')
+ open(unit=12,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='old',action='read')
+ endif
+
+ read(10,*) nspec
+ print *,'There are ',nspec,' AVS or DX elements in the slice'
+
+ read(12,*) npoin
+ print *,'There are ',npoin,' global AVS or DX points in the slice'
+
+! read local elements in this slice and output global AVS or DX elements
+ do ispec=1,nspec
+ read(10,*) numelem,idoubling,iglob1,iglob2,iglob3,iglob4
+ if(numelem /= ispec) stop 'incorrect element number'
+! compute max of the doubling flag
+ maxdoubling = max(maxdoubling,idoubling)
+
+! assign material property (which can be filtered later in AVS_DX)
+ if(imaterial == 1) then
+ imatprop = idoubling
+ else if(imaterial == 2) then
+ imatprop = iproc
+ else
+ stop 'invalid code for material property'
+ endif
+
+! write to AVS or DX global file with correct offset
+
+! quadrangles (2-D)
+ iglob1 = iglob1 + iglobpointoffset
+ iglob2 = iglob2 + iglobpointoffset
+ iglob3 = iglob3 + iglobpointoffset
+ iglob4 = iglob4 + iglobpointoffset
+
+! in the case of OpenDX, node numbers start at zero
+! in the case of AVS, node numbers start at one
+! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS
+ if(USE_OPENDX) then
+ write(11,"(i6,1x,i6,1x,i6,1x,i6)") iglob1-1,iglob4-1,iglob2-1,iglob3-1
+ else
+ write(11,"(i6,1x,i3,' quad ',i6,1x,i6,1x,i6,1x,i6)") numelem + iglobelemoffset,imatprop,iglob1,iglob2,iglob3,iglob4
+ endif
+
+ enddo
+
+ iglobelemoffset = iglobelemoffset + nspec
+ iglobpointoffset = iglobpointoffset + npoin
+
+ close(10)
+ close(12)
+
+ enddo
+
+! ************* generate data values ******************
+
+! output AVS or DX header for data
+ if(USE_OPENDX) then
+ write(11,*) 'attribute "element type" string "quads"'
+ write(11,*) 'attribute "ref" string "positions"'
+ if(ivalue == 2 .and. icolor == 3) then
+ write(11,*) 'object 3 class array type float rank 0 items ',ntotpoinAVS_DX,' data follows'
+ else
+ write(11,*) 'object 3 class array type float rank 0 items ',ntotspecAVS_DX,' data follows'
+ endif
+ else
+ write(11,*) '1 1'
+ write(11,*) 'Zcoord, meters'
+ endif
+
+!!!!
+!!!! ###### element data in most cases
+!!!!
+ if(ivalue /= 2 .or. icolor /= 3) then
+
+! set global element and point offsets to zero
+ iglobelemoffset = 0
+
+! loop on the selected range of processors
+ do iproc=proc_p1,proc_p2
+
+ print *,'Reading slice ',iproc
+
+! create the name for the database of the current slide
+ call create_serial_name_database(prname,iproc,LOCAL_PATH,NPROC,OUTPUT_FILES)
+
+ if(ivalue == 1) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='old',action='read')
+ else if(ivalue == 2) then
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='old',action='read')
+ endif
+
+ read(10,*) nspec
+ print *,'There are ',nspec,' AVS or DX elements in the slice'
+
+! read local elements in this slice and output global AVS or DX elements
+ do ispec=1,nspec
+ read(10,*) numelem,idoubling,iglob1,iglob2,iglob3,iglob4
+ if(numelem /= ispec) stop 'incorrect element number'
+
+! data is either the slice number or the mesh doubling region flag
+ if(icolor == 1) then
+ val_color = dble(idoubling)
+ else if(icolor == 2) then
+ val_color = dble(iproc)
+ else if(icolor == 4) then
+ val_color = dble(random_colors(iproc))
+ else
+ stop 'incorrect coloring code'
+ endif
+
+! write to AVS or DX global file with correct offset
+ if(USE_OPENDX) then
+ write(11,*) sngl(val_color)
+ else
+ write(11,*) numelem + iglobelemoffset,' ',sngl(val_color)
+ endif
+ enddo
+
+ iglobelemoffset = iglobelemoffset + nspec
+
+ close(10)
+
+ enddo
+
+!!!!
+!!!! ###### point data if surface colored according to topography
+!!!!
+ else
+
+! set global point offset to zero
+ iglobpointoffset = 0
+
+! loop on the selected range of processors
+ do iproc=proc_p1,proc_p2
+
+ print *,'Reading slice ',iproc
+
+! create the name for the database of the current slide
+ call create_serial_name_database(prname,iproc,LOCAL_PATH,NPROC,OUTPUT_FILES)
+
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='old',action='read')
+
+ read(10,*) npoin
+ print *,'There are ',npoin,' global AVS or DX points in the slice'
+
+! read local points in this slice and output global AVS or DX points
+ do ipoin=1,npoin
+ read(10,*) numpoin,xval,yval,zval
+ if(numpoin /= ipoin) stop 'incorrect point number'
+! write to AVS or DX global file with correct offset
+ if(USE_OPENDX) then
+ write(11,*) sngl(zval)
+ else
+ write(11,*) numpoin + iglobpointoffset,' ',sngl(zval)
+ endif
+
+ enddo
+
+ iglobpointoffset = iglobpointoffset + npoin
+
+ close(10)
+
+ enddo
+
+ endif ! end test if element data or point data
+
+! define OpenDX field
+ if(USE_OPENDX) then
+ if(ivalue == 2 .and. icolor == 3) then
+ write(11,*) 'attribute "dep" string "positions"'
+ else
+ write(11,*) 'attribute "dep" string "connections"'
+ endif
+ 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
+
+ close(11)
+
+ print *
+ print *,'maximum value of doubling flag in all slices = ',maxdoubling
+ print *
+
+!
+! create an AVS or DX file with the source and the receivers as well
+!
+
+ if(USE_OPENDX) then
+
+ print *
+ print *,'support for source and station file in OpenDX not added yet'
+ print *
+ stop 'warning: only partial support for OpenDX in current version (mesh ok, but no source)'
+
+ else
+
+! get source information
+ print *,'reading position of the source from the CMTSOLUTION file'
+ call get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,NSOURCES)
+
+! the point for the source is put at the surface for clarity (depth ignored)
+! even slightly above to superimpose to real surface
+! also save quadrangle for AVS or DX representation of epicenter
+
+ z_target_source = 2000.
+ z_source_quad1 = 2000.
+ z_source_quad2 = 2000.
+ z_source_quad3 = 2000.
+ z_source_quad4 = 2000.
+
+ call utm_geo(long,lat,x_target_source,y_target_source,UTM_PROJECTION_ZONE,ILONGLAT2UTM,SUPPRESS_UTM_PROJECTION)
+
+ x_source_quad1 = x_target_source
+ y_source_quad1 = y_target_source
+
+ x_source_quad2 = x_target_source + small_offset
+ y_source_quad2 = y_target_source
+
+ x_source_quad3 = x_target_source + small_offset
+ y_source_quad3 = y_target_source + small_offset
+
+ x_source_quad4 = x_target_source
+ y_source_quad4 = y_target_source + small_offset
+
+ ntotpoinAVS_DX = 2
+ ntotspecAVS_DX = 1
+
+ print *
+ print *,'reading position of the receivers from DATA/STATIONS_FILTERED file'
+ call get_value_string(filtered_rec_filename, 'solver.STATIONS_FILTERED', 'DATA/STATIONS_FILTERED')
+
+! get number of stations from receiver file
+ open(unit=11,file=filtered_rec_filename,iostat=ios,status='old',action='read')
+ nrec = 0
+ do while(ios == 0)
+ read(11,"(a)",iostat=ios) dummystring
+ if(ios == 0) nrec = nrec + 1
+ enddo
+ close(11)
+
+ print *,'There are ',nrec,' three-component stations'
+ print *
+ if(nrec < 1) stop 'incorrect number of stations read - need at least one'
+
+ allocate(station_name(nrec))
+ allocate(network_name(nrec))
+ allocate(stlat(nrec))
+ allocate(stlon(nrec))
+ allocate(stele(nrec))
+ allocate(stbur(nrec))
+
+ allocate(x_target(nrec))
+ allocate(y_target(nrec))
+ allocate(z_target(nrec))
+
+! loop on all the stations
+ open(unit=11,file=filtered_rec_filename,status='old',action='read')
+ do irec=1,nrec
+ read(11,*) station_name(irec),network_name(irec),stlat(irec),stlon(irec),stele(irec),stbur(irec)
+
+! points for the receivers are put at the surface for clarity (depth ignored)
+ call utm_geo(stlon(irec),stlat(irec),x_target(irec),y_target(irec),UTM_PROJECTION_ZONE,ILONGLAT2UTM,SUPPRESS_UTM_PROJECTION)
+
+ z_target(irec) = 2000.
+
+ enddo
+
+ close(11)
+
+! duplicate source to have right color normalization in AVS_DX
+ ntotpoinAVS_DX = ntotpoinAVS_DX + 2*nrec + 1
+ ntotspecAVS_DX = ntotspecAVS_DX + nrec + 1
+
+ open(unit=11,file=trim(OUTPUT_FILES)//'/AVS_source_receivers.inp',status='unknown')
+
+! write AVS or DX header with element data
+ write(11,*) ntotpoinAVS_DX,' ',ntotspecAVS_DX,' 0 1 0'
+
+! add source and receivers (small AVS or DX lines)
+ write(11,*) '1 ',sngl(x_target_source),' ',sngl(y_target_source),' ',sngl(z_target_source)
+ write(11,*) '2 ',sngl(x_target_source+small_offset),' ', &
+ sngl(y_target_source+small_offset),' ',sngl(z_target_source+small_offset)
+ write(11,*) '3 ',sngl(x_target_source+small_offset),' ', &
+ sngl(y_target_source+small_offset),' ',sngl(z_target_source+small_offset)
+ do ir=1,nrec
+ write(11,*) 4+2*(ir-1),' ',sngl(x_target(ir)),' ',sngl(y_target(ir)),' ',sngl(z_target(ir))
+ write(11,*) 4+2*(ir-1)+1,' ',sngl(x_target(ir)+small_offset),' ', &
+ sngl(y_target(ir)+small_offset),' ',sngl(z_target(ir)+small_offset)
+ enddo
+
+! add source and receivers (small AVS or DX lines)
+ write(11,*) '1 1 line 1 2'
+ do ir=1,nrec
+ write(11,*) ir+1,' 1 line ',4+2*(ir-1),' ',4+2*(ir-1)+1
+ enddo
+! duplicate source to have right color normalization in AVS_DX
+ write(11,*) ir+1,' 1 line 1 3'
+
+! output AVS or DX header for data
+ write(11,*) '1 1'
+ write(11,*) 'Zcoord, meters'
+
+! add source and receiver data
+ write(11,*) '1 1.'
+ do ir=1,nrec
+ write(11,*) ir+1,' 255.'
+ enddo
+! duplicate source to have right color normalization in AVS_DX
+ write(11,*) ir+1,' 120.'
+
+ close(11)
+
+! create a file with the epicenter only, represented as a quadrangle
+
+ open(unit=11,file=trim(OUTPUT_FILES)//'/AVS_epicenter.inp',status='unknown')
+
+! write AVS or DX header with element data
+ write(11,*) '4 1 0 1 0'
+
+! add source and receivers (small AVS or DX lines)
+ write(11,*) '1 ',sngl(x_source_quad1),' ',sngl(y_source_quad1),' ',sngl(z_source_quad1)
+ write(11,*) '2 ',sngl(x_source_quad2),' ',sngl(y_source_quad2),' ',sngl(z_source_quad2)
+ write(11,*) '3 ',sngl(x_source_quad3),' ',sngl(y_source_quad3),' ',sngl(z_source_quad3)
+ write(11,*) '4 ',sngl(x_source_quad4),' ',sngl(y_source_quad4),' ',sngl(z_source_quad4)
+
+! create a element for the source, some labels and element data
+ write(11,*) '1 1 quad 1 2 3 4'
+ write(11,*) '1 1'
+ write(11,*) 'Zcoord, meters'
+ write(11,*) '1 1.'
+
+ close(11)
+
+ endif
+
+ end program combine_AVS_DX
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/combine_surf_data.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/combine_surf_data.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/combine_surf_data.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,363 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+program combine_surf_data
+
+ ! puts the output of SPECFEM3D in ParaView format.
+ ! see http://www.paraview.org for details
+
+ ! combines the database files on several slices.
+ ! the local database file needs to have been collected onto the frontend (copy_local_database.pl)
+
+ implicit none
+
+ include 'constants.h'
+! include 'OUTPUT_FILES/values_from_mesher.h'
+
+ integer i,j,k,ispec, ios, it
+ integer iproc, proc1, proc2, num_node, node_list(300), nspec, nglob
+ integer np, ne, npp, nee, npoint, nelement, njunk, n1, n2, n3, n4
+ integer ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB)
+ integer numpoin, iglob1, iglob2, iglob3, iglob4, iglob
+ logical mask_ibool(NGLOB_AB)
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: data_3D
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: data_2D
+ real(kind=CUSTOM_REAL),dimension(NGLOB_AB) :: xstore, ystore, zstore
+ real x, y, z
+ real, dimension(:,:,:,:), allocatable :: dat3D
+ real, dimension(:,:,:), allocatable :: dat2D
+ character(len=256) :: sline, arg(8), filename, indir, outdir, prname, surfname
+ character(len=256) :: mesh_file, local_file, local_data_file, local_ibool_file
+ character(len=256) :: local_ibool_surf_file
+ integer :: num_ibool(NGLOB_AB)
+ logical :: HIGH_RESOLUTION_MESH, FILE_ARRAY_IS_3D
+ integer :: ires, nspec_surf, npoint1, npoint2, ispec_surf, inx, iny, idim
+ integer,dimension(:), allocatable :: ibelm_surf
+
+
+ do i = 1, 8
+ call getarg(i,arg(i))
+ if (i < 6 .and. trim(arg(i)) == '') then
+ print *, 'Usage: xcombine_surface start_slice end_slice filename surfacename input_dir output_dir high/low-resolution 3D/2D'
+ print *, ' or xcombine_surface slice_list filename surfacename input_dir output_dir high/low-resolution 3D/2D'
+ print *, ' possible filenames are kappastore(NGLLX,NGLLY,NGLLZ,nspec), alpha_kernel(NGLLX,NGLLY,nspec_surf)'
+ print *, ' possible surface name: moho as in ibelm_moho.bin'
+ print *, ' files have been collected in input_dir, output mesh file goes to output_dir '
+ print *, ' give 0 for low resolution and 1 for high resolution'
+ print *, ' give 0 for 2D and 1 for 3D filenames'
+ stop ' Reenter command line options'
+ endif
+ enddo
+
+ ! get slice list
+ if (trim(arg(8)) == '') then
+ num_node = 0
+ open(unit = 20, file = trim(arg(1)), status = 'unknown',iostat = ios)
+ if (ios /= 0) then
+ print *,'Error opening ',trim(arg(1))
+ stop
+ endif
+ do while ( 1 == 1)
+ read(20,'(a)',iostat=ios) sline
+ if (ios /= 0) exit
+ read(sline,*,iostat=ios) njunk
+ if (ios /= 0) exit
+ num_node = num_node + 1
+ node_list(num_node) = njunk
+ enddo
+ close(20)
+ filename = arg(2)
+ surfname = arg(3)
+ indir= arg(4)
+ outdir = arg(5)
+ read(arg(6),*) ires
+ read(arg(7),*) idim
+ else
+ read(arg(1),*) proc1
+ read(arg(2),*) proc2
+ do iproc = proc1, proc2
+ node_list(iproc - proc1 + 1) = iproc
+ enddo
+ num_node = proc2 - proc1 + 1
+ filename = arg(3)
+ surfname = arg(4)
+ indir = arg(5)
+ outdir = arg(6)
+ read(arg(7),*) ires
+ read(arg(8),*) idim
+ endif
+
+ if (ires == 0) then
+ HIGH_RESOLUTION_MESH = .false.
+ inx = NGLLX-1
+ iny = NGLLY-1
+ else
+ HIGH_RESOLUTION_MESH = .true.
+ inx = 1
+ iny = 1
+ endif
+
+ if (idim == 0) then
+ FILE_ARRAY_IS_3D = .false.
+ else
+ FILE_ARRAY_IS_3D = .true.
+ endif
+
+ print *, 'Slice list: '
+ print *, node_list(1:num_node)
+
+ ! open paraview output mesh file
+ mesh_file = trim(outdir) // '/' // trim(filename)//'.surf'
+ call open_file(trim(mesh_file)//char(0))
+
+ nspec = NSPEC_AB
+ nglob = NGLOB_AB
+
+ np = 0
+
+ ! ======= loop over all slices, write point and scalar information ======
+
+ do it = 1, num_node
+
+ iproc = node_list(it)
+
+ print *, ' '
+ print *, 'Reading slice ', iproc
+ write(prname,'(a,i6.6,a)') trim(indir)//'/proc',iproc,'_'
+
+ ! surface file
+ local_ibool_surf_file = trim(prname) // 'ibelm_' //trim(surfname)// '.bin'
+ open(unit = 28,file = trim(local_ibool_surf_file),status='old', iostat = ios, form='unformatted')
+ if (ios /= 0) then
+ print *,'Error opening ',trim(local_ibool_surf_file)
+ stop
+ endif
+ read(28) nspec_surf
+ read(28) npoint1
+ read(28) npoint2
+
+ if (it == 1) allocate(ibelm_surf(nspec_surf))
+ read(28) ibelm_surf
+ close(28)
+ print *, trim(local_ibool_surf_file)
+
+ if (it == 1) then
+ if (FILE_ARRAY_IS_3D) then
+ allocate(data_3D(NGLLX,NGLLY,NGLLZ,NSPEC_AB),dat3D(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ else
+ allocate(data_2D(NGLLX,NGLLY,nspec_surf),dat2D(NGLLX,NGLLY,nspec_surf))
+ endif
+ endif
+
+ ! data file
+ local_data_file = trim(prname) // trim(filename) // '.bin'
+ open(unit = 27,file = trim(local_data_file),status='old', iostat = ios,form ='unformatted')
+ if (ios /= 0) then
+ print *,'Error opening ',trim(local_data_file)
+ stop
+ endif
+ if (FILE_ARRAY_IS_3D) then
+ read(27) data_3D
+ dat3D = data_3D
+ else
+ read(27) data_2D
+ dat2D = data_2D
+ endif
+ close(27)
+ print *, trim(local_data_file)
+
+ ! ibool file
+ local_ibool_file = trim(prname) // 'ibool' // '.bin'
+ open(unit = 28,file = trim(local_ibool_file),status='old', iostat = ios, form='unformatted')
+ if (ios /= 0) then
+ print *,'Error opening ',trim(local_data_file)
+ stop
+ endif
+ read(28) ibool
+ close(28)
+ print *, trim(local_ibool_file)
+
+
+ mask_ibool(:) = .false.
+ numpoin = 0
+
+ if (it == 1) then
+ if (HIGH_RESOLUTION_MESH) then
+ npoint = npoint2
+ else
+ npoint = npoint1
+ endif
+ npp = npoint * num_node
+ call write_integer(npp)
+ endif
+
+ local_file = trim(prname)//'x.bin'
+ open(unit = 27,file = trim(prname)//'x.bin',status='old', 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', 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', iostat = ios,form ='unformatted')
+ if (ios /= 0) then
+ print *,'Error opening ',trim(local_file)
+ stop
+ endif
+ read(27) zstore
+ close(27)
+
+ do ispec_surf=1,nspec_surf
+ ispec = ibelm_surf(ispec_surf)
+ k = 1
+ do j = 1, NGLLY, iny
+ do i = 1, NGLLX, inx
+ iglob = ibool(i,j,k,ispec)
+ if(.not. mask_ibool(iglob)) then
+ numpoin = numpoin + 1
+ x = xstore(iglob)
+ y = ystore(iglob)
+ z = zstore(iglob)
+ call write_real(x)
+ call write_real(y)
+ call write_real(z)
+ if (FILE_ARRAY_IS_3D) then
+ call write_real(dat3D(i,j,k,ispec))
+ else
+ call write_real(dat2D(i,j,ispec_surf))
+ endif
+ mask_ibool(iglob) = .true.
+ endif
+ enddo ! i
+ enddo ! j
+ enddo !ispec
+
+ if (numpoin /= npoint) stop 'Error: number of points are not consistent'
+ np = np + npoint
+
+ enddo ! all slices for points
+
+ if (np /= npp) stop 'Error: Number of total points are not consistent'
+ print *, 'Total number of points: ', np
+ print *, ' '
+
+
+ ne = 0
+ ! ============ write element information =====================
+ do it = 1, num_node
+
+ iproc = node_list(it)
+
+ print *, 'Reading slice ', iproc
+ write(prname,'(a,i6.6,a)') trim(indir)//'/proc',iproc,'_'
+
+ np = npoint * (it-1)
+
+! surface file
+ local_ibool_surf_file = trim(prname) // 'ibelm_' //trim(surfname)// '.bin'
+ open(unit = 28,file = trim(local_ibool_surf_file),status='old', iostat = ios, form='unformatted')
+ read(28) nspec_surf
+ read(28) njunk
+ read(28) njunk
+ read(28) ibelm_surf
+ close(28)
+
+! ibool file
+ local_ibool_file = trim(prname) // 'ibool' // '.bin'
+ open(unit = 28,file = trim(local_ibool_file),status='old', iostat = ios, form='unformatted')
+ read(28) ibool
+ close(28)
+
+ if (it == 1) then
+ if (HIGH_RESOLUTION_MESH) then
+ nelement = nspec_surf * (NGLLX-1) * (NGLLY-1)
+ else
+ nelement = nspec_surf
+ endif
+ nee = nelement * num_node
+ call write_integer(nee)
+ endif
+
+ numpoin = 0
+ mask_ibool = .false.
+ do ispec_surf=1,nspec_surf
+ ispec = ibelm_surf(ispec_surf)
+ k = 1
+ do j = 1, NGLLY, iny
+ do i = 1, NGLLX, inx
+ iglob = ibool(i,j,k,ispec)
+ if(.not. mask_ibool(iglob)) then
+ numpoin = numpoin + 1
+ num_ibool(iglob) = numpoin
+ mask_ibool(iglob) = .true.
+ endif
+ enddo ! i
+ enddo ! j
+ enddo !ispec
+
+ do ispec_surf = 1, nspec_surf
+ ispec = ibelm_surf(ispec_surf)
+ k = 1
+ do j = 1, NGLLY-1, iny
+ do i = 1, NGLLX-1, inx
+ iglob1 = ibool(i,j,k,ispec)
+ iglob2 = ibool(i+inx,j,k,ispec)
+ iglob3 = ibool(i+inx,j+iny,k,ispec)
+ iglob4 = ibool(i,j+iny,k,ispec)
+
+ n1 = num_ibool(iglob1)+np-1
+ n2 = num_ibool(iglob2)+np-1
+ n3 = num_ibool(iglob3)+np-1
+ n4 = num_ibool(iglob4)+np-1
+
+ call write_integer(n1)
+ call write_integer(n2)
+ call write_integer(n3)
+ call write_integer(n4)
+
+ enddo
+ enddo
+ enddo
+ ne = ne + nelement
+
+ enddo ! num_node
+ if (ne /= nee) stop 'Number of total elements are not consistent'
+ print *, 'Total number of elements: ', ne
+
+ call close_file()
+
+ print *, 'Done writing '//trim(mesh_file)
+
+end program combine_surf_data
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/combine_vol_data.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/combine_vol_data.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/combine_vol_data.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,793 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+ program combine_paraview_data_ext_mesh
+
+! puts the output of SPECFEM3D into '***.mesh' format,
+! which can be converted via mesh2vtu into ParaView format.
+!
+! for Paraview, see http://www.paraview.org for details
+!
+! 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'
+
+ ! data must be of dimension: (NGLLX,NGLLY,NGLLZ,NSPEC_AB)
+ real(kind=CUSTOM_REAL),dimension(:,:,:,:),allocatable :: data
+ ! real array for data
+ real,dimension(:,:,:,:),allocatable :: dat
+
+ ! mesh coordinates
+ real(kind=CUSTOM_REAL),dimension(:),allocatable :: xstore, ystore, zstore
+ integer, dimension(:,:,:,:),allocatable :: ibool
+
+ integer :: NSPEC_AB, NGLOB_AB
+ integer :: numpoin
+ integer :: i, ios, it
+ integer :: iproc, proc1, proc2, num_node, node_list(300)
+ integer :: np, ne, npp, nee, nelement, njunk
+
+ character(len=256) :: sline, arg(6), filename, indir, outdir
+ character(len=256) :: prname, prname_lp
+ character(len=256) :: mesh_file,local_data_file
+ logical :: HIGH_RESOLUTION_MESH
+ integer :: ires
+
+ ! for read_parameter_files
+ double precision :: DT
+ double precision :: HDUR_MOVIE
+ integer :: NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP, &
+ UTM_PROJECTION_ZONE,SIMULATION_TYPE
+ integer :: NSOURCES
+ integer :: NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
+ logical :: MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ USE_HIGHRES_FOR_MOVIES,SUPPRESS_UTM_PROJECTION
+ logical :: ATTENUATION,USE_OLSEN_ATTENUATION, &
+ OCEANS
+ logical :: ABSORBING_CONDITIONS,SAVE_FORWARD
+ logical :: ANISOTROPY,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION
+ character(len=256) LOCAL_PATH
+
+! checks given arguments
+ print *
+ print *,'Recombining ParaView data for slices'
+ print *
+
+ do i = 1, 6
+ call getarg(i,arg(i))
+ if (i < 6 .and. trim(arg(i)) == '') then
+ print *, 'Usage: '
+ print *, ' xcombine_data start_slice end_slice filename input_dir output_dir high/low-resolution'
+ print *, ' or '
+ print *, ' xcombine_data slice_list filename input_dir output_dir high/low-resolution'
+ print *
+ print *, ' possible filenames are '
+ print *, ' rho_vp, rho_vs, kappastore, mustore, alpha_kernel, etc'
+ print *
+ print *, ' that are stored in the local directory as real(kind=CUSTOM_REAL) filename(NGLLX,NGLLY,NGLLZ,NSPEC_AB) '
+ print *, ' in filename.bin'
+ print *
+ print *, ' files have been collected in input_dir, output mesh file goes to output_dir '
+ print *, ' give 0 for low resolution and 1 for high resolution'
+ print *
+ stop ' Reenter command line options'
+ endif
+ enddo
+
+! get slice list
+ if (trim(arg(6)) == '') then
+ num_node = 0
+ open(unit = 20, file = trim(arg(1)), status = 'unknown',iostat = ios)
+ if (ios /= 0) then
+ print *,'Error opening ',trim(arg(1))
+ stop
+ endif
+ do while ( 1 == 1)
+ read(20,'(a)',iostat=ios) sline
+ if (ios /= 0) exit
+ read(sline,*,iostat=ios) njunk
+ if (ios /= 0) exit
+ num_node = num_node + 1
+ node_list(num_node) = njunk
+ enddo
+ close(20)
+ filename = arg(2)
+ indir= arg(3)
+ outdir = arg(4)
+ read(arg(5),*) ires
+ else
+ read(arg(1),*) proc1
+ read(arg(2),*) proc2
+ do iproc = proc1, proc2
+ node_list(iproc - proc1 + 1) = iproc
+ enddo
+ num_node = proc2 - proc1 + 1
+ filename = arg(3)
+ indir = arg(4)
+ outdir = arg(5)
+ read(arg(6),*) ires
+ endif
+
+ if (ires == 0) then
+ HIGH_RESOLUTION_MESH = .false.
+ else
+ HIGH_RESOLUTION_MESH = .true.
+ endif
+
+ ! needs local_path for mesh files
+ call read_parameter_file( NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ ATTENUATION,USE_OLSEN_ATTENUATION,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,SIMULATION_TYPE,SAVE_FORWARD)
+
+ print *, 'Slice list: '
+ print *, node_list(1:num_node)
+
+ ! open paraview output mesh file
+ mesh_file = trim(outdir) // '/' // trim(filename)//'.mesh'
+ call open_file(trim(mesh_file)//char(0))
+
+ ! counts total number of points (all slices)
+ npp = 0
+ nee = 0
+ call cvd_count_totals_ext_mesh(num_node,node_list,LOCAL_PATH,&
+ npp,nee,HIGH_RESOLUTION_MESH)
+
+
+ ! writes point and scalar information
+ ! loops over slices (process partitions)
+ np = 0
+ do it = 1, num_node
+
+ iproc = node_list(it)
+
+ print *, ' '
+ print *, 'Reading slice ', iproc
+
+ ! gets number of elements and global points for this partition
+ write(prname_lp,'(a,i6.6,a)') trim(LOCAL_PATH)//'/proc',iproc,'_'
+ open(unit=27,file=prname_lp(1:len_trim(prname_lp))//'external_mesh.bin',&
+ status='old',action='read',form='unformatted')
+ read(27) NSPEC_AB
+ read(27) NGLOB_AB
+
+ ! ibool file
+ allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ read(27) ibool
+
+ ! global point arrays
+ allocate(xstore(NGLOB_AB),ystore(NGLOB_AB),zstore(NGLOB_AB))
+ read(27) xstore
+ read(27) ystore
+ read(27) zstore
+ close(27)
+
+
+ ! data file
+ write(prname,'(a,i6.6,a)') trim(indir)//'proc',iproc,'_'
+ local_data_file = trim(prname) // trim(filename) // '.bin'
+ open(unit = 28,file = trim(local_data_file),status='old',&
+ action='read', iostat = ios,form ='unformatted')
+ if (ios /= 0) then
+ print *,'Error opening ',trim(local_data_file)
+ stop
+ endif
+ allocate(data(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ read(28) data
+ close(28)
+ print *, trim(local_data_file)
+
+ ! uses conversion to real values
+ allocate(dat(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ if( CUSTOM_REAL == 4 ) then
+ dat = data
+ else
+ dat = sngl(data)
+ endif
+
+
+ ! writes point coordinates and scalar value to mesh file
+ if (.not. HIGH_RESOLUTION_MESH) then
+ ! writes out element corners only
+ call cvd_write_corners(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat, &
+ it,npp,numpoin)
+ else
+ ! high resolution, all GLL points
+ call cvd_write_GLL_points(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat,&
+ it,npp,numpoin)
+ endif
+
+ print*,' points:',np,numpoin
+
+ ! stores total number of points written
+ np = np + numpoin
+
+ ! cleans up memory allocations
+ deallocate(ibool,data,dat,xstore,ystore,zstore)
+
+ enddo ! all slices for points
+
+ if (np /= npp) stop 'Error: Number of total points are not consistent'
+ print *, 'Total number of points: ', np
+ print *, ' '
+
+
+! writes element information
+ ne = 0
+ np = 0
+ do it = 1, num_node
+
+ iproc = node_list(it)
+
+ print *, 'Reading slice ', iproc
+ write(prname_lp,'(a,i6.6,a)') trim(LOCAL_PATH)//'/proc',iproc,'_'
+
+ ! gets number of elements and global points for this partition
+ open(unit=27,file=prname_lp(1:len_trim(prname_lp))//'external_mesh.bin',&
+ status='old',action='read',form='unformatted')
+ read(27) NSPEC_AB
+ read(27) NGLOB_AB
+
+ ! ibool file
+ allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ read(27) ibool
+ close(27)
+
+ ! writes out element corner indices
+ if (.not. HIGH_RESOLUTION_MESH) then
+ ! spectral elements
+ call cvd_write_corner_elements(NSPEC_AB,NGLOB_AB,ibool, &
+ np,nelement,it,nee,numpoin)
+ else
+ ! subdivided spectral elements
+ call cvd_write_GLL_elements(NSPEC_AB,NGLOB_AB,ibool, &
+ np,nelement,it,nee,numpoin)
+ endif
+
+ print*,' elements:',ne,nelement
+ print*,' points : ',np,numpoin
+
+ ne = ne + nelement
+
+ deallocate(ibool)
+
+ enddo ! num_node
+
+ ! checks with total number of elements
+ if (ne /= nee) then
+ print*,'error: number of elements counted:',ne,'total:',nee
+ stop 'Number of total elements are not consistent'
+ endif
+ print *, 'Total number of elements: ', ne
+
+ ! close mesh file
+ call close_file()
+
+ print *, 'Done writing '//trim(mesh_file)
+
+ end program combine_paraview_data_ext_mesh
+
+
+!=============================================================
+
+
+ subroutine cvd_count_totals_ext_mesh(num_node,node_list,LOCAL_PATH,&
+ npp,nee,HIGH_RESOLUTION_MESH)
+
+! counts total number of points and elements for external meshes in given slice list
+! returns: total number of elements (nee) and number of points (npp)
+
+ implicit none
+ include 'constants.h'
+
+ integer,intent(in) :: num_node,node_list(300)
+ character(len=256),intent(in) :: LOCAL_PATH
+ integer,intent(out) :: npp,nee
+ logical,intent(in) :: HIGH_RESOLUTION_MESH
+
+ ! local parameters
+ integer, dimension(:,:,:,:),allocatable :: ibool
+ logical, dimension(:),allocatable :: mask_ibool
+ integer :: NSPEC_AB, NGLOB_AB
+ integer :: it,iproc,npoint,nelement,ios,ispec
+ integer :: iglob1, iglob2, iglob3, iglob4, iglob5, iglob6, iglob7, iglob8
+ character(len=256) :: prname_lp
+
+
+ ! loops over all slices (process partitions)
+ npp = 0
+ nee = 0
+ do it = 1, num_node
+
+ ! gets number of elements and points for this slice
+ iproc = node_list(it)
+ write(prname_lp,'(a,i6.6,a)') trim(LOCAL_PATH)//'/proc',iproc,'_'
+ open(unit=27,file=prname_lp(1:len_trim(prname_lp))//'external_mesh.bin',&
+ status='old',action='read',form='unformatted',iostat=ios)
+ if (ios /= 0) then
+ print *,'Error opening: ',prname_lp(1:len_trim(prname_lp))//'external_mesh.bin'
+ stop
+ endif
+
+ read(27) NSPEC_AB
+ read(27) NGLOB_AB
+ ! gets ibool
+ if( .not. HIGH_RESOLUTION_MESH ) then
+ allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ read(27) ibool
+ endif
+ close(27)
+
+ ! calculates totals
+ if( HIGH_RESOLUTION_MESH ) then
+ ! total number of global points
+ npp = npp + NGLOB_AB
+
+ ! total number of elements
+ ! each spectral elements gets subdivided by GLL points,
+ ! which form (NGLLX-1)*(NGLLY-1)*(NGLLZ-1) sub-elements
+ nelement = NSPEC_AB * (NGLLX-1) * (NGLLY-1) * (NGLLZ-1)
+ nee = nee + nelement
+
+ else
+
+ ! mark element corners (global AVS or DX points)
+ allocate(mask_ibool(NGLOB_AB))
+ mask_ibool = .false.
+ do ispec=1,NSPEC_AB
+ 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)
+ mask_ibool(iglob1) = .true.
+ mask_ibool(iglob2) = .true.
+ mask_ibool(iglob3) = .true.
+ mask_ibool(iglob4) = .true.
+ mask_ibool(iglob5) = .true.
+ mask_ibool(iglob6) = .true.
+ mask_ibool(iglob7) = .true.
+ mask_ibool(iglob8) = .true.
+ enddo
+
+ ! count global number of AVS or DX points
+ npoint = count(mask_ibool(:))
+ npp = npp + npoint
+
+ ! total number of spectral elements
+ nee = nee + NSPEC_AB
+
+ endif ! HIGH_RESOLUTION_MESH
+ enddo
+
+ end subroutine cvd_count_totals_ext_mesh
+
+!=============================================================
+
+
+ subroutine cvd_write_corners(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat,&
+ it,npp,numpoin)
+
+! writes out locations of spectral element corners only
+
+ implicit none
+ include 'constants.h'
+
+ integer,intent(in) :: NSPEC_AB,NGLOB_AB
+ integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB),intent(in) :: ibool
+ real(kind=CUSTOM_REAL),dimension(NGLOB_AB) :: xstore, ystore, zstore
+ real,dimension(NGLLY,NGLLY,NGLLZ,NSPEC_AB),intent(in) :: dat
+ integer:: it
+ integer :: npp,numpoin
+
+ ! local parameters
+ logical,dimension(:),allocatable :: mask_ibool
+ real :: x, y, z
+ integer :: ispec
+ integer :: iglob1, iglob2, iglob3, iglob4, iglob5, iglob6, iglob7, iglob8
+
+ ! writes out total number of points
+ if (it == 1) then
+ call write_integer(npp)
+ endif
+
+ ! writes our corner point locations
+ allocate(mask_ibool(NGLOB_AB))
+ mask_ibool(:) = .false.
+ numpoin = 0
+ do ispec=1,NSPEC_AB
+ 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)
+
+ if(.not. mask_ibool(iglob1)) then
+ numpoin = numpoin + 1
+ x = xstore(iglob1)
+ y = ystore(iglob1)
+ z = zstore(iglob1)
+ call write_real(x)
+ call write_real(y)
+ call write_real(z)
+ call write_real(dat(1,1,1,ispec))
+ mask_ibool(iglob1) = .true.
+ endif
+ if(.not. mask_ibool(iglob2)) then
+ numpoin = numpoin + 1
+ x = xstore(iglob2)
+ y = ystore(iglob2)
+ z = zstore(iglob2)
+ call write_real(x)
+ call write_real(y)
+ call write_real(z)
+ call write_real(dat(NGLLX,1,1,ispec))
+ mask_ibool(iglob2) = .true.
+ endif
+ if(.not. mask_ibool(iglob3)) then
+ numpoin = numpoin + 1
+ x = xstore(iglob3)
+ y = ystore(iglob3)
+ z = zstore(iglob3)
+ call write_real(x)
+ call write_real(y)
+ call write_real(z)
+ call write_real(dat(NGLLX,NGLLY,1,ispec))
+ mask_ibool(iglob3) = .true.
+ endif
+ if(.not. mask_ibool(iglob4)) then
+ numpoin = numpoin + 1
+ x = xstore(iglob4)
+ y = ystore(iglob4)
+ z = zstore(iglob4)
+ call write_real(x)
+ call write_real(y)
+ call write_real(z)
+ call write_real(dat(1,NGLLY,1,ispec))
+ mask_ibool(iglob4) = .true.
+ endif
+ if(.not. mask_ibool(iglob5)) then
+ numpoin = numpoin + 1
+ x = xstore(iglob5)
+ y = ystore(iglob5)
+ z = zstore(iglob5)
+ call write_real(x)
+ call write_real(y)
+ call write_real(z)
+ call write_real(dat(1,1,NGLLZ,ispec))
+ mask_ibool(iglob5) = .true.
+ endif
+ if(.not. mask_ibool(iglob6)) then
+ numpoin = numpoin + 1
+ x = xstore(iglob6)
+ y = ystore(iglob6)
+ z = zstore(iglob6)
+ call write_real(x)
+ call write_real(y)
+ call write_real(z)
+ call write_real(dat(NGLLX,1,NGLLZ,ispec))
+ mask_ibool(iglob6) = .true.
+ endif
+ if(.not. mask_ibool(iglob7)) then
+ numpoin = numpoin + 1
+ x = xstore(iglob7)
+ y = ystore(iglob7)
+ z = zstore(iglob7)
+ call write_real(x)
+ call write_real(y)
+ call write_real(z)
+ call write_real(dat(NGLLX,NGLLY,NGLLZ,ispec))
+ mask_ibool(iglob7) = .true.
+ endif
+ if(.not. mask_ibool(iglob8)) then
+ numpoin = numpoin + 1
+ x = xstore(iglob8)
+ y = ystore(iglob8)
+ z = zstore(iglob8)
+ call write_real(x)
+ call write_real(y)
+ call write_real(z)
+ call write_real(dat(1,NGLLY,NGLLZ,ispec))
+ mask_ibool(iglob8) = .true.
+ endif
+ enddo ! ispec
+
+ end subroutine cvd_write_corners
+
+
+!=============================================================
+
+
+ subroutine cvd_write_GLL_points(NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore,dat,&
+ it,npp,numpoin)
+
+! writes out locations of all GLL points of spectral elements
+
+ implicit none
+ include 'constants.h'
+
+ integer,intent(in) :: NSPEC_AB,NGLOB_AB
+ integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB),intent(in) :: ibool
+ real(kind=CUSTOM_REAL),dimension(NGLOB_AB) :: xstore, ystore, zstore
+ real,dimension(NGLLY,NGLLY,NGLLZ,NSPEC_AB),intent(in) :: dat
+ integer:: it,npp,numpoin
+
+ ! local parameters
+ logical,dimension(:),allocatable :: mask_ibool
+ real :: x, y, z
+ integer :: ispec,i,j,k,iglob
+
+ ! writes out total number of points
+ if (it == 1) then
+ call write_integer(npp)
+ endif
+
+ ! writes out point locations and values
+ allocate(mask_ibool(NGLOB_AB))
+ mask_ibool(:) = .false.
+ numpoin = 0
+ do ispec=1,NSPEC_AB
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+ if(.not. mask_ibool(iglob)) then
+ numpoin = numpoin + 1
+ x = xstore(iglob)
+ y = ystore(iglob)
+ z = zstore(iglob)
+ call write_real(x)
+ call write_real(y)
+ call write_real(z)
+ call write_real(dat(i,j,k,ispec))
+ mask_ibool(iglob) = .true.
+ endif
+ enddo ! i
+ enddo ! j
+ enddo ! k
+ enddo !ispec
+
+ end subroutine cvd_write_GLL_points
+
+!=============================================================
+
+! writes out locations of spectral element corners only
+
+ subroutine cvd_write_corner_elements(NSPEC_AB,NGLOB_AB,ibool,&
+ np,nelement,it,nee,numpoin)
+
+ implicit none
+ include 'constants.h'
+
+ integer,intent(in) :: NSPEC_AB,NGLOB_AB
+ integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB),intent(in) :: ibool
+ integer:: it,nee,np,nelement,numpoin
+
+ ! local parameters
+ logical,dimension(:),allocatable :: mask_ibool
+ integer,dimension(:),allocatable :: num_ibool
+ integer :: ispec
+ integer :: iglob1, iglob2, iglob3, iglob4, iglob5, iglob6, iglob7, iglob8
+ integer :: n1, n2, n3, n4, n5, n6, n7, n8
+
+ ! outputs total number of elements for all slices
+ if (it == 1) then
+ call write_integer(nee)
+ end if
+
+ ! writes out element indices
+ allocate(mask_ibool(NGLOB_AB))
+ allocate(num_ibool(NGLOB_AB))
+ mask_ibool(:) = .false.
+ num_ibool(:) = 0
+ numpoin = 0
+ do ispec=1,NSPEC_AB
+ ! 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)
+
+ ! 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
+
+ ! elements written
+ nelement = NSPEC_AB
+
+ ! updates points written
+ np = np + numpoin
+
+ end subroutine cvd_write_corner_elements
+
+
+!=============================================================
+
+
+ subroutine cvd_write_GLL_elements(NSPEC_AB,NGLOB_AB,ibool, &
+ np,nelement,it,nee,numpoin)
+
+! writes out indices of elements given by GLL points
+
+ implicit none
+ include 'constants.h'
+
+ integer,intent(in):: NSPEC_AB,NGLOB_AB
+ integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB),intent(in) :: ibool
+ integer:: it,nee,np,numpoin,nelement
+
+ ! local parameters
+ logical,dimension(:),allocatable :: mask_ibool
+ integer,dimension(:),allocatable :: num_ibool
+ integer :: ispec,i,j,k
+ integer :: iglob,iglob1, iglob2, iglob3, iglob4, iglob5, iglob6, iglob7, iglob8
+ integer :: n1, n2, n3, n4, n5, n6, n7, n8
+
+ ! outputs total number of elements for all slices
+ if (it == 1) then
+ !nee = nelement * num_node
+ call write_integer(nee)
+ endif
+
+ ! sets numbering num_ibool respecting mask
+ allocate(mask_ibool(NGLOB_AB))
+ allocate(num_ibool(NGLOB_AB))
+ mask_ibool(:) = .false.
+ num_ibool(:) = 0
+ numpoin = 0
+ do ispec=1,NSPEC_AB
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+ if(.not. mask_ibool(iglob)) then
+ numpoin = numpoin + 1
+ num_ibool(iglob) = numpoin
+ mask_ibool(iglob) = .true.
+ endif
+ enddo ! i
+ enddo ! j
+ enddo ! k
+ enddo !ispec
+
+ ! outputs GLL subelement
+ do ispec = 1, NSPEC_AB
+ do k = 1, NGLLZ-1
+ do j = 1, NGLLY-1
+ do i = 1, NGLLX-1
+ iglob1 = ibool(i,j,k,ispec)
+ iglob2 = ibool(i+1,j,k,ispec)
+ iglob3 = ibool(i+1,j+1,k,ispec)
+ iglob4 = ibool(i,j+1,k,ispec)
+ iglob5 = ibool(i,j,k+1,ispec)
+ iglob6 = ibool(i+1,j,k+1,ispec)
+ iglob7 = ibool(i+1,j+1,k+1,ispec)
+ iglob8 = ibool(i,j+1,k+1,ispec)
+ n1 = num_ibool(iglob1)+np-1
+ n2 = num_ibool(iglob2)+np-1
+ n3 = num_ibool(iglob3)+np-1
+ n4 = num_ibool(iglob4)+np-1
+ n5 = num_ibool(iglob5)+np-1
+ n6 = num_ibool(iglob6)+np-1
+ n7 = num_ibool(iglob7)+np-1
+ n8 = num_ibool(iglob8)+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
+ enddo
+ enddo
+ enddo
+ ! elements written
+ nelement = NSPEC_AB * (NGLLX-1) * (NGLLY-1) * (NGLLZ-1)
+
+ ! updates points written
+ np = np + numpoin
+
+ end subroutine cvd_write_GLL_elements
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/comp_source_time_function.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/comp_source_time_function.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/comp_source_time_function.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,89 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+ double precision function comp_source_time_function(t,hdur)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision t,hdur
+
+ double precision, external :: netlib_specfun_erf
+
+ ! quasi Heaviside, small Gaussian moment-rate tensor with hdur
+ comp_source_time_function = 0.5d0*(1.0d0 + netlib_specfun_erf(t/hdur))
+
+ end function comp_source_time_function
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ double precision function comp_source_time_function_gauss(t,hdur)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: t,hdur
+ double precision :: hdur_decay
+ double precision,parameter :: SOURCE_DECAY_STRONG = 2.0d0/SOURCE_DECAY_MIMIC_TRIANGLE
+
+ ! note: hdur given is hdur_gaussian = hdur/SOURCE_DECAY_MIMIC_TRIANGLE
+ ! and SOURCE_DECAY_MIMIC_TRIANGLE ~ 1.68
+ hdur_decay = hdur
+
+ ! this here uses a stronger gaussian decay rate (empirical value) to avoid non-zero onset times;
+ ! however, it should mimik a triangle source time function...
+ !hdur_decay = hdur / SOURCE_DECAY_STRONG
+
+ ! note: a nonzero time to start the simulation with would lead to more high-frequency noise
+ ! due to the (spatial) discretization of the point source on the mesh
+
+ ! gaussian
+ comp_source_time_function_gauss = exp(-(t/hdur_decay)**2)/(sqrt(PI)*hdur_decay)
+
+ end function comp_source_time_function_gauss
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ double precision function comp_source_time_function_rickr(t,f0)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision t,f0
+
+ ! ricker
+ comp_source_time_function_rickr = (1.d0 - 2.d0*PI*PI*f0*f0*t*t ) &
+ * exp( -PI*PI*f0*f0*t*t )
+
+ end function comp_source_time_function_rickr
+
\ No newline at end of file
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_add_sources_acoustic.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_add_sources_acoustic.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_add_sources_acoustic.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,331 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! for acoustic solver
+
+ subroutine compute_add_sources_acoustic(NSPEC_AB,NGLOB_AB,potential_dot_dot_acoustic, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
+ xi_source,eta_source,gamma_source, &
+ hdur,hdur_gaussian,t_cmt,dt,t0, &
+ sourcearrays,kappastore,ispec_is_acoustic,&
+ SIMULATION_TYPE,NSTEP,NGLOB_ADJOINT, &
+ nrec,islice_selected_rec,ispec_selected_rec, &
+ nadj_rec_local,adj_sourcearrays,b_potential_dot_dot_acoustic )
+
+ use specfem_par,only: PRINT_SOURCE_TIME_FUNCTION,stf_used_total
+ implicit none
+
+ include "constants.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! displacement and acceleration
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
+
+! arrays with mesh parameters per slice
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: kappastore
+
+! 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(NSOURCES) :: hdur,hdur_gaussian,t_cmt
+ double precision :: dt,t0
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrays
+
+ double precision, external :: comp_source_time_function,comp_source_time_function_rickr,&
+ comp_source_time_function_gauss
+
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+!adjoint simulations
+ integer:: SIMULATION_TYPE,NSTEP,NGLOB_ADJOINT
+ integer:: nrec
+ integer,dimension(nrec) :: islice_selected_rec,ispec_selected_rec
+ integer:: nadj_rec_local
+ real(kind=CUSTOM_REAL),dimension(nadj_rec_local,NSTEP,NDIM,NGLLX,NGLLY,NGLLZ):: adj_sourcearrays
+ real(kind=CUSTOM_REAL),dimension(NGLOB_ADJOINT):: b_potential_dot_dot_acoustic
+
+! local parameters
+ double precision :: f0
+ double precision :: stf
+ real(kind=CUSTOM_REAL) stf_used,stf_used_total_all,time_source
+ integer :: isource,iglob,ispec,i,j,k
+ integer :: irec_local,irec
+
+! plotting source time function
+ if(PRINT_SOURCE_TIME_FUNCTION .and. .not. phase_is_inner ) then
+ ! initializes total
+ stf_used_total = 0.0_CUSTOM_REAL
+ endif
+
+! forward simulations
+ if (SIMULATION_TYPE == 1) then
+
+ ! adds acoustic sources
+ do isource = 1,NSOURCES
+
+ ! add the source (only if this proc carries the source)
+ if(myrank == islice_selected_source(isource)) then
+
+ ispec = ispec_selected_source(isource)
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_acoustic(ispec) ) then
+
+ if(USE_FORCE_POINT_SOURCE) then
+
+ ! note: for use_force_point_source xi/eta/gamma are in the range [1,NGLL*]
+ iglob = ibool(nint(xi_source(isource)), &
+ nint(eta_source(isource)), &
+ nint(gamma_source(isource)), &
+ ispec)
+
+ f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
+ t0 = 1.2d0/f0
+
+ if (it == 1 .and. myrank == 0) then
+ print *,'using a source of dominant frequency ',f0
+ print *,'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
+ print *,'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
+ endif
+
+ ! gaussian source time function
+ !stf_used = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+ ! we use nu_source(:,3) here because we want a source normal to the surface.
+ ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
+ stf_used = 1.d10 * comp_source_time_function_rickr(dble(it-1)*DT-t0-t_cmt(isource),f0)
+
+ ! beware, for acoustic medium, source is: pressure divided by Kappa of the fluid
+ ! the sign is negative because pressure p = - Chi_dot_dot therefore we need
+ ! to add minus the source to Chi_dot_dot to get plus the source in pressure:
+
+ ! acoustic source for pressure gets divided by kappa
+ ! source contribution
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - stf_used / kappastore(nint(xi_source(isource)), &
+ nint(eta_source(isource)), &
+ nint(gamma_source(isource)),ispec)
+
+ else
+
+ ! gaussian source time
+ stf = comp_source_time_function_gauss(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+ ! quasi-heaviside
+ !stf = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+ ! distinguishes between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ stf_used = sngl(stf)
+ else
+ stf_used = stf
+ endif
+
+ ! beware, for acoustic medium, source is: pressure divided by Kappa of the fluid
+ ! the sign is negative because pressure p = - Chi_dot_dot therefore we need
+ ! to add minus the source to Chi_dot_dot to get plus the source in pressure
+
+ ! add source array
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! adds source contribution
+ ! note: acoustic source for pressure gets divided by kappa
+ iglob = ibool(i,j,k,ispec)
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - sourcearrays(isource,1,i,j,k) * stf_used / kappastore(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+
+ endif ! USE_FORCE_POINT_SOURCE
+
+ stf_used_total = stf_used_total + stf_used
+
+ endif ! ispec_is_elastic
+ endif ! ispec_is_inner
+ endif ! myrank
+
+ enddo ! NSOURCES
+ endif
+
+! NOTE: adjoint sources and backward wavefield timing:
+! idea is to start with the backward field b_potential.. at time (T)
+! and convolve with the adjoint field at time (T-t)
+!
+! backward/reconstructed wavefields:
+! time for b_potential..( it ) corresponds to (NSTEP - it - 1 )*DT - t0 ...
+! since we start with saved wavefields b_potential..( 0 ) = potential..( NSTEP ) which correspond
+! to a time (NSTEP - 1)*DT - t0
+! (see sources for simulation_type 1 and seismograms)
+! now, at the beginning of the time loop, the numerical Newark time scheme updates
+! the wavefields, that is b_potential..( it=1) corresponds now to time (NSTEP -1 - 1)*DT - t0
+!
+! let's define the start time t to (1-1)*DT - t0 = -t0, and the end time T to (NSTEP-1)*DT - t0
+! these are the start and end times of all seismograms
+!
+! adjoint wavefields:
+! since the adjoint source traces were derived from the seismograms,
+! it follows that for the adjoint wavefield, the time equivalent to ( T - t ) uses the time-reversed
+! adjoint source traces which start at -t0 and end at time (NSTEP-1)*DT - t0
+! for it=1: (NSTEP -1 - 1)*DT - t0 for backward wavefields corresponds to time T-1
+! and time (T-1) corresponds now to index (NSTEP -1) in the adjoint source array
+
+! adjoint simulations
+ if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
+
+ if( it < NSTEP ) then
+ ! receivers act as sources
+ irec_local = 0
+ do irec = 1,nrec
+ ! add the source (only if this proc carries the source)
+ if(myrank == islice_selected_rec(irec)) then
+ irec_local = irec_local + 1
+ ! adds source array
+ ispec = ispec_selected_rec(irec)
+ do k = 1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! beware, for acoustic medium, source is: pressure divided by Kappa of the fluid
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - adj_sourcearrays(irec_local,NSTEP-it,1,i,j,k) / kappastore(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ endif
+ enddo ! nrec
+ endif ! it
+ endif
+
+! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ ! adds acoustic sources
+ do isource = 1,NSOURCES
+
+ ! add the source (only if this proc carries the source)
+ if(myrank == islice_selected_source(isource)) then
+
+ ispec = ispec_selected_source(isource)
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_acoustic(ispec) ) then
+
+ if(USE_FORCE_POINT_SOURCE) then
+
+ ! note: for use_force_point_source xi/eta/gamma are in the range [1,NGLL*]
+ iglob = ibool(nint(xi_source(isource)), &
+ nint(eta_source(isource)), &
+ nint(gamma_source(isource)), &
+ ispec)
+
+ f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
+ t0 = 1.2d0/f0
+
+ if (it == 1 .and. myrank == 0) then
+ print *,'using a source of dominant frequency ',f0
+ print *,'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
+ print *,'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
+ endif
+
+ ! gaussian source time function
+ !stf_used = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+ ! we use nu_source(:,3) here because we want a source normal to the surface.
+ ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
+ stf_used = 1.d10 * comp_source_time_function_rickr(dble(NSTEP-it-1)*DT-t0-t_cmt(isource),f0)
+
+ ! beware, for acoustic medium, source is: pressure divided by Kappa of the fluid
+ ! the sign is negative because pressure p = - Chi_dot_dot therefore we need
+ ! to add minus the source to Chi_dot_dot to get plus the source in pressure:
+
+ ! acoustic source for pressure gets divided by kappa
+ ! source contribution
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) &
+ - stf_used / kappastore(nint(xi_source(isource)), &
+ nint(eta_source(isource)), &
+ nint(gamma_source(isource)),ispec)
+
+ else
+
+ ! gaussian source time
+ stf = comp_source_time_function_gauss(dble(NSTEP-it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+ ! distinguishes between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ stf_used = sngl(stf)
+ else
+ stf_used = stf
+ endif
+
+ ! beware, for acoustic medium, source is: pressure divided by Kappa of the fluid
+ ! the sign is negative because pressure p = - Chi_dot_dot therefore we need
+ ! to add minus the source to Chi_dot_dot to get plus the source in pressure
+
+ ! add source array
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! adds source contribution
+ ! note: acoustic source for pressure gets divided by kappa
+ iglob = ibool(i,j,k,ispec)
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) &
+ - sourcearrays(isource,1,i,j,k) * stf_used / kappastore(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+
+ endif ! USE_FORCE_POINT_SOURCE
+
+ stf_used_total = stf_used_total + stf_used
+
+ endif ! ispec_is_elastic
+ endif ! ispec_is_inner
+ endif ! myrank
+
+ enddo ! NSOURCES
+ endif
+
+ ! master prints out source time function to file
+ if(PRINT_SOURCE_TIME_FUNCTION .and. phase_is_inner) then
+ time_source = (it-1)*DT - t0
+ call sum_all_cr(stf_used_total,stf_used_total_all)
+ if( myrank == 0 ) write(IOSTF,*) time_source,stf_used_total_all
+ endif
+
+
+end subroutine compute_add_sources_acoustic
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_add_sources_elastic.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_add_sources_elastic.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_add_sources_elastic.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,290 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! for elastic solver
+
+ subroutine compute_add_sources_elastic( 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,t0,sourcearrays, &
+ ispec_is_elastic,SIMULATION_TYPE,NSTEP,NGLOB_ADJOINT, &
+ nrec,islice_selected_rec,ispec_selected_rec, &
+ nadj_rec_local,adj_sourcearrays,b_accel )
+
+ use specfem_par,only: PRINT_SOURCE_TIME_FUNCTION,stf_used_total
+ implicit none
+
+ include "constants.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! 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
+
+! 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,t0
+ real(kind=CUSTOM_REAL), dimension(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrays
+
+ double precision, external :: comp_source_time_function,comp_source_time_function_rickr
+
+ logical, dimension(NSPEC_AB) :: ispec_is_elastic
+
+!adjoint simulations
+ integer:: SIMULATION_TYPE,NSTEP,NGLOB_ADJOINT
+ integer:: nrec
+ integer,dimension(nrec) :: islice_selected_rec,ispec_selected_rec
+ integer:: nadj_rec_local
+ real(kind=CUSTOM_REAL),dimension(nadj_rec_local,NSTEP,NDIM,NGLLX,NGLLY,NGLLZ):: adj_sourcearrays
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLOB_ADJOINT):: b_accel
+
+! local parameters
+ double precision :: f0
+ double precision :: stf
+ real(kind=CUSTOM_REAL) stf_used,stf_used_total_all,time_source
+ integer :: isource,iglob,i,j,k,ispec
+ integer :: irec_local,irec
+
+! plotting source time function
+ if(PRINT_SOURCE_TIME_FUNCTION .and. .not. phase_is_inner ) then
+ ! initializes total
+ stf_used_total = 0.0_CUSTOM_REAL
+ endif
+
+! forward simulations
+ if (SIMULATION_TYPE == 1) then
+
+ do isource = 1,NSOURCES
+
+ ! add the source (only if this proc carries the source)
+ if(myrank == islice_selected_source(isource)) then
+
+ ispec = ispec_selected_source(isource)
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_elastic(ispec) ) then
+
+ if(USE_FORCE_POINT_SOURCE) then
+
+ ! note: for use_force_point_source xi/eta/gamma are in the range [1,NGLL*]
+ iglob = ibool(nint(xi_source(isource)), &
+ nint(eta_source(isource)), &
+ nint(gamma_source(isource)), &
+ ispec_selected_source(isource))
+
+ f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
+ t0 = 1.2d0/f0
+
+ if (it == 1 .and. myrank == 0) then
+ print *,'using a source of dominant frequency ',f0
+ print *,'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
+ print *,'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
+ endif
+
+ ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
+ stf_used = 1.d10 * comp_source_time_function_rickr(dble(it-1)*DT-t0-t_cmt(isource),f0)
+
+ ! we use nu_source(:,3) here because we want a source normal to the surface.
+ accel(:,iglob) = accel(:,iglob) &
+ + sngl( nu_source(:,3,isource) ) * stf_used
+
+ else
+
+ stf = comp_source_time_function(dble(it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ stf_used = sngl(stf)
+ else
+ stf_used = stf
+ endif
+
+ ! add source array
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ accel(:,iglob) = accel(:,iglob) + sourcearrays(isource,:,i,j,k)*stf_used
+ enddo
+ enddo
+ enddo
+
+ endif ! USE_FORCE_POINT_SOURCE
+
+ stf_used_total = stf_used_total + stf_used
+
+ endif ! ispec_is_elastic
+ endif ! ispec_is_inner
+ endif ! myrank
+
+ enddo ! NSOURCES
+ endif ! forward
+
+! NOTE: adjoint sources and backward wavefield timing:
+! idea is to start with the backward field b_displ,.. at time (T)
+! and convolve with the adjoint field at time (T-t)
+!
+! backward/reconstructed wavefields:
+! time for b_displ( it ) corresponds to (NSTEP - it - 1 )*DT - t0 ...
+! since we start with saved wavefields b_displ( 0 ) = displ( NSTEP ) which correspond
+! to a time (NSTEP - 1)*DT - t0
+! (see sources for simulation_type 1 and seismograms)
+! now, at the beginning of the time loop, the numerical Newark time scheme updates
+! the wavefields, that is b_displ( it=1) corresponds now to time (NSTEP -1 - 1)*DT - t0
+!
+! let's define the start time t to (1-1)*DT - t0 = -t0, and the end time T to (NSTEP-1)*DT - t0
+! these are the start and end times of all seismograms
+!
+! adjoint wavefields:
+! since the adjoint source traces were derived from the seismograms,
+! it follows that for the adjoint wavefield, the time equivalent to ( T - t ) uses the time-reversed
+! adjoint source traces which start at -t0 and end at time (NSTEP-1)*DT - t0
+! for it=1: (NSTEP -1 - 1)*DT - t0 for backward wavefields corresponds to time T-1
+! and time (T-1) corresponds now to index (NSTEP -1) in the adjoint source array
+
+
+! adjoint simulations
+ if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
+
+ if( it < NSTEP ) then
+
+ ! receivers act as sources
+ irec_local = 0
+ do irec = 1,nrec
+ ! add the source (only if this proc carries the source)
+ if(myrank == islice_selected_rec(irec)) then
+ irec_local = irec_local + 1
+ ! adds source array
+ do k = 1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec_selected_rec(irec))
+ accel(:,iglob) = accel(:,iglob) + adj_sourcearrays(irec_local,NSTEP-it,:,i,j,k)
+ enddo
+ enddo
+ enddo
+ endif
+ enddo ! nrec
+
+ endif ! it
+
+ endif !adjoint
+
+! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+
+ ! backward source reconstruction
+ do isource = 1,NSOURCES
+
+ ! add the source (only if this proc carries the source)
+ if(myrank == islice_selected_source(isource)) then
+
+ ispec = ispec_selected_source(isource)
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_elastic(ispec) ) then
+
+ if(USE_FORCE_POINT_SOURCE) then
+
+ ! note: for use_force_point_source xi/eta/gamma are in the range [1,NGLL*]
+ iglob = ibool(nint(xi_source(isource)), &
+ nint(eta_source(isource)), &
+ nint(gamma_source(isource)), &
+ ispec_selected_source(isource))
+
+ f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
+ t0 = 1.2d0/f0
+
+ if (it == 1 .and. myrank == 0) then
+ print *,'using a source of dominant frequency ',f0
+ print *,'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
+ print *,'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
+ endif
+
+ ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
+ stf_used = 1.d10 * comp_source_time_function_rickr(dble(NSTEP-it-1)*DT-t0-t_cmt(isource),f0)
+
+ ! we use nu_source(:,3) here because we want a source normal to the surface.
+ ! note: time step is now at NSTEP-it
+ b_accel(:,iglob) = b_accel(:,iglob) &
+ + sngl( nu_source(:,3,isource) ) * stf_used
+
+
+ else
+
+ ! see note above: time step corresponds now to NSTEP-it-1
+ ! (also compare to it-1 for forward simulation)
+ stf = comp_source_time_function(dble(NSTEP-it-1)*DT-t0-t_cmt(isource),hdur_gaussian(isource))
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ stf_used = sngl(stf)
+ else
+ stf_used = stf
+ endif
+
+ ! add source array
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec_selected_source(isource))
+ b_accel(:,iglob) = b_accel(:,iglob) + sourcearrays(isource,:,i,j,k)*stf_used
+ enddo
+ enddo
+ enddo
+ endif ! USE_FORCE_POINT_SOURCE
+
+ stf_used_total = stf_used_total + stf_used
+
+ endif ! elastic
+ endif ! phase_inner
+ endif ! myrank
+
+ enddo ! NSOURCES
+ endif ! adjoint
+
+ ! master prints out source time function to file
+ if(PRINT_SOURCE_TIME_FUNCTION .and. phase_is_inner) then
+ time_source = (it-1)*DT - t0
+ call sum_all_cr(stf_used_total,stf_used_total_all)
+ if( myrank == 0 ) write(IOSTF,*) time_source,stf_used_total_all
+ endif
+
+
+ end subroutine compute_add_sources_elastic
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_arrays_source.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_arrays_source.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_arrays_source.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,478 @@
+!=====================================================================
+!
+! 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 compute_arrays_source(ispec_selected_source, &
+ xi_source,eta_source,gamma_source,sourcearray, &
+ Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ xigll,yigll,zigll,nspec)
+
+ implicit none
+
+ include "constants.h"
+
+ integer ispec_selected_source
+ integer nspec
+
+ double precision xi_source,eta_source,gamma_source
+ double precision Mxx,Myy,Mzz,Mxy,Mxz,Myz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xix,xiy,xiz,etax,etay,etaz, &
+ gammax,gammay,gammaz
+
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
+
+ double precision xixd,xiyd,xizd,etaxd,etayd,etazd,gammaxd,gammayd,gammazd
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLY) :: yigll
+ double precision, dimension(NGLLZ) :: zigll
+
+! source arrays
+ double precision, dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrayd
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: G11,G12,G13,G21,G22,G23,G31,G32,G33
+ double precision, dimension(NGLLX) :: hxis,hpxis
+ double precision, dimension(NGLLY) :: hetas,hpetas
+ double precision, dimension(NGLLZ) :: hgammas,hpgammas
+
+ integer k,l,m
+
+! calculate G_ij for general source location
+! the source does not necessarily correspond to a Gauss-Lobatto point
+ do m=1,NGLLZ
+ do l=1,NGLLY
+ do k=1,NGLLX
+
+ xixd = dble(xix(k,l,m,ispec_selected_source))
+ xiyd = dble(xiy(k,l,m,ispec_selected_source))
+ xizd = dble(xiz(k,l,m,ispec_selected_source))
+ etaxd = dble(etax(k,l,m,ispec_selected_source))
+ etayd = dble(etay(k,l,m,ispec_selected_source))
+ etazd = dble(etaz(k,l,m,ispec_selected_source))
+ gammaxd = dble(gammax(k,l,m,ispec_selected_source))
+ gammayd = dble(gammay(k,l,m,ispec_selected_source))
+ gammazd = dble(gammaz(k,l,m,ispec_selected_source))
+
+ G11(k,l,m) = Mxx*xixd+Mxy*xiyd+Mxz*xizd
+ G12(k,l,m) = Mxx*etaxd+Mxy*etayd+Mxz*etazd
+ G13(k,l,m) = Mxx*gammaxd+Mxy*gammayd+Mxz*gammazd
+ G21(k,l,m) = Mxy*xixd+Myy*xiyd+Myz*xizd
+ G22(k,l,m) = Mxy*etaxd+Myy*etayd+Myz*etazd
+ G23(k,l,m) = Mxy*gammaxd+Myy*gammayd+Myz*gammazd
+ G31(k,l,m) = Mxz*xixd+Myz*xiyd+Mzz*xizd
+ G32(k,l,m) = Mxz*etaxd+Myz*etayd+Mzz*etazd
+ G33(k,l,m) = Mxz*gammaxd+Myz*gammayd+Mzz*gammazd
+
+ enddo
+ enddo
+ enddo
+
+! compute Lagrange polynomials at the source location
+ call lagrange_any(xi_source,NGLLX,xigll,hxis,hpxis)
+ call lagrange_any(eta_source,NGLLY,yigll,hetas,hpetas)
+ call lagrange_any(gamma_source,NGLLZ,zigll,hgammas,hpgammas)
+
+! calculate source array
+ do m=1,NGLLZ
+ do l=1,NGLLY
+ do k=1,NGLLX
+ call multiply_arrays_source(sourcearrayd,G11,G12,G13,G21,G22,G23, &
+ G31,G32,G33,hxis,hpxis,hetas,hpetas,hgammas,hpgammas,k,l,m)
+ enddo
+ enddo
+ enddo
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ sourcearray(:,:,:,:) = sngl(sourcearrayd(:,:,:,:))
+ else
+ sourcearray(:,:,:,:) = sourcearrayd(:,:,:,:)
+ endif
+
+ end subroutine compute_arrays_source
+
+!================================================================
+
+! we put these multiplications in a separate routine because otherwise
+! some compilers try to unroll the six loops above and take forever to compile
+ subroutine multiply_arrays_source(sourcearrayd,G11,G12,G13,G21,G22,G23, &
+ G31,G32,G33,hxis,hpxis,hetas,hpetas,hgammas,hpgammas,k,l,m)
+
+ implicit none
+
+ include "constants.h"
+
+! source arrays
+ double precision, dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrayd
+ double precision, dimension(NGLLX,NGLLY,NGLLZ) :: G11,G12,G13,G21,G22,G23,G31,G32,G33
+ double precision, dimension(NGLLX) :: hxis,hpxis
+ double precision, dimension(NGLLY) :: hetas,hpetas
+ double precision, dimension(NGLLZ) :: hgammas,hpgammas
+
+ integer k,l,m
+
+ integer ir,it,iv
+
+ sourcearrayd(:,k,l,m) = ZERO
+
+ do iv=1,NGLLZ
+ do it=1,NGLLY
+ do ir=1,NGLLX
+
+ sourcearrayd(1,k,l,m) = sourcearrayd(1,k,l,m) + hxis(ir)*hetas(it)*hgammas(iv) &
+ *(G11(ir,it,iv)*hpxis(k)*hetas(l)*hgammas(m) &
+ +G12(ir,it,iv)*hxis(k)*hpetas(l)*hgammas(m) &
+ +G13(ir,it,iv)*hxis(k)*hetas(l)*hpgammas(m))
+
+ sourcearrayd(2,k,l,m) = sourcearrayd(2,k,l,m) + hxis(ir)*hetas(it)*hgammas(iv) &
+ *(G21(ir,it,iv)*hpxis(k)*hetas(l)*hgammas(m) &
+ +G22(ir,it,iv)*hxis(k)*hpetas(l)*hgammas(m) &
+ +G23(ir,it,iv)*hxis(k)*hetas(l)*hpgammas(m))
+
+ sourcearrayd(3,k,l,m) = sourcearrayd(3,k,l,m) + hxis(ir)*hetas(it)*hgammas(iv) &
+ *(G31(ir,it,iv)*hpxis(k)*hetas(l)*hgammas(m) &
+ +G32(ir,it,iv)*hxis(k)*hpetas(l)*hgammas(m) &
+ +G33(ir,it,iv)*hxis(k)*hetas(l)*hpgammas(m))
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine multiply_arrays_source
+
+!=============================================================================
+
+subroutine compute_arrays_adjoint_source(myrank, adj_source_file, &
+ xi_receiver,eta_receiver,gamma_receiver, adj_sourcearray, &
+ xigll,yigll,zigll,NSTEP)
+
+
+ implicit none
+
+ include 'constants.h'
+
+! input
+ integer myrank, NSTEP
+
+ double precision xi_receiver, eta_receiver, gamma_receiver
+
+ character(len=*) adj_source_file
+
+! output
+ real(kind=CUSTOM_REAL),dimension(NSTEP,NDIM,NGLLX,NGLLY,NGLLZ) :: adj_sourcearray
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLY) :: yigll
+ double precision, dimension(NGLLZ) :: zigll
+
+ double precision :: hxir(NGLLX), hpxir(NGLLX), hetar(NGLLY), hpetar(NGLLY), &
+ hgammar(NGLLZ), hpgammar(NGLLZ)
+
+ real(kind=CUSTOM_REAL) :: adj_src(NSTEP,NDIM)
+
+ integer icomp, itime, i, j, k, ios
+ double precision :: junk
+ character(len=3),dimension(NDIM) :: comp = (/ "BHN", "BHE", "BHZ" /)
+ character(len=256) :: filename
+
+ !adj_sourcearray(:,:,:,:,:) = 0.
+ adj_src = 0._CUSTOM_REAL
+
+ ! loops over components
+ do icomp = 1, NDIM
+
+ filename = 'SEM/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
+ open(unit=IIN,file=trim(filename),status='old',action='read',iostat = ios)
+ if (ios /= 0) cycle ! cycles to next file
+ !if (ios /= 0) call exit_MPI(myrank, ' file '//trim(filename)//'does not exist')
+
+ ! reads in adjoint source trace
+ do itime = 1, NSTEP
+
+ read(IIN,*,iostat=ios) junk, adj_src(itime,icomp)
+ if( ios /= 0 ) &
+ call exit_MPI(myrank, &
+ 'file '//trim(filename)//' has wrong length, please check with your simulation duration')
+ enddo
+ close(IIN)
+
+ enddo
+
+ ! lagrange interpolators for receiver location
+ call lagrange_any(xi_receiver,NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(eta_receiver,NGLLY,yigll,hetar,hpetar)
+ call lagrange_any(gamma_receiver,NGLLZ,zigll,hgammar,hpgammar)
+
+ ! interpolates adjoint source onto GLL points within this element
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ adj_sourcearray(:,:,i,j,k) = hxir(i) * hetar(j) * hgammar(k) * adj_src(:,:)
+ enddo
+ enddo
+ enddo
+
+end subroutine compute_arrays_adjoint_source
+
+
+! =======================================================================
+! compute the integrated derivatives of source parameters (M_jk and X_s)
+
+subroutine compute_adj_source_frechet(displ_s,Mxx,Myy,Mzz,Mxy,Mxz,Myz,eps_s,eps_m_s, &
+ hxir,hetar,hgammar,hpxir,hpetar,hpgammar, hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
+
+ implicit none
+
+ include 'constants.h'
+
+ ! input
+ real(kind=CUSTOM_REAL) :: displ_s(NDIM,NGLLX,NGLLY,NGLLZ)
+ double precision :: Mxx, Myy, Mzz, Mxy, Mxz, Myz
+ ! output
+ real(kind=CUSTOM_REAL) :: eps_s(NDIM,NDIM), eps_m_s(NDIM)
+
+ ! auxilliary
+ double precision :: hxir(NGLLX), hetar(NGLLY), hgammar(NGLLZ), &
+ hpxir(NGLLX),hpetar(NGLLY),hpgammar(NGLLZ)
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+
+! local variables
+ real(kind=CUSTOM_REAL) :: tempx1l,tempx2l,tempx3l, tempy1l,tempy2l,tempy3l, &
+ tempz1l,tempz2l,tempz3l, hp1, hp2, hp3, &
+ xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl, &
+ duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl, &
+ xix_s,xiy_s,xiz_s,etax_s,etay_s,etaz_s,gammax_s,gammay_s,gammaz_s, &
+ hlagrange_xi, hlagrange_eta, hlagrange_gamma, hlagrange
+
+ real(kind=CUSTOM_REAL) :: eps(NDIM,NDIM), eps_array(NDIM,NDIM,NGLLX,NGLLY,NGLLZ), &
+ eps_m_array(NGLLX,NGLLY,NGLLZ)
+
+ integer i,j,k,l
+
+
+! first compute the strain at all the GLL points of the source element
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
+
+ tempy1l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
+
+ tempz1l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ hp1 = hprime_xx(i,l)
+ tempx1l = tempx1l + displ_s(1,l,j,k)*hp1
+ tempy1l = tempy1l + displ_s(2,l,j,k)*hp1
+ tempz1l = tempz1l + displ_s(3,l,j,k)*hp1
+
+ hp2 = hprime_yy(j,l)
+ tempx2l = tempx2l + displ_s(1,i,l,k)*hp2
+ tempy2l = tempy2l + displ_s(2,i,l,k)*hp2
+ tempz2l = tempz2l + displ_s(3,i,l,k)*hp2
+
+ hp3 = hprime_zz(k,l)
+ tempx3l = tempx3l + displ_s(1,i,j,l)*hp3
+ tempy3l = tempy3l + displ_s(2,i,j,l)*hp3
+ tempz3l = tempz3l + displ_s(3,i,j,l)*hp3
+ enddo
+
+! dudx
+ xixl = xix(i,j,k)
+ xiyl = xiy(i,j,k)
+ xizl = xiz(i,j,k)
+ etaxl = etax(i,j,k)
+ etayl = etay(i,j,k)
+ etazl = etaz(i,j,k)
+ gammaxl = gammax(i,j,k)
+ gammayl = gammay(i,j,k)
+ gammazl = gammaz(i,j,k)
+
+ duxdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ duxdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ duxdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+
+ duydxl = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
+ duydyl = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
+ duydzl = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
+
+ duzdxl = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
+ duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
+ duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
+
+! strain eps_jk
+ eps(1,1) = duxdxl
+ eps(1,2) = (duxdyl + duydxl) / 2
+ eps(1,3) = (duxdzl + duzdxl) / 2
+ eps(2,2) = duydyl
+ eps(2,3) = (duydzl + duzdyl) / 2
+ eps(3,3) = duzdzl
+ eps(2,1) = eps(1,2)
+ eps(3,1) = eps(1,3)
+ eps(3,2) = eps(2,3)
+
+ eps_array(:,:,i,j,k) = eps(:,:)
+
+! Mjk eps_jk
+ eps_m_array(i,j,k) = Mxx * eps(1,1) + Myy * eps(2,2) + Mzz * eps(3,3) + &
+ 2 * (Mxy * eps(1,2) + Mxz * eps(1,3) + Myz * eps(2,3))
+
+ enddo
+ enddo
+ enddo
+
+ ! interpolate the strain eps_s(:,:) from eps_array(:,:,i,j,k)
+ eps_s = 0.
+ xix_s = 0.; xiy_s = 0.; xiz_s = 0.
+ etax_s = 0.; etay_s = 0.; etaz_s = 0.
+ gammax_s = 0.; gammay_s = 0.; gammaz_s = 0.
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ hlagrange = hxir(i)*hetar(j)*hgammar(k)
+
+ eps_s(1,1) = eps_s(1,1) + eps_array(1,1,i,j,k)*hlagrange
+ eps_s(1,2) = eps_s(1,2) + eps_array(1,2,i,j,k)*hlagrange
+ eps_s(1,3) = eps_s(1,3) + eps_array(1,3,i,j,k)*hlagrange
+ eps_s(2,2) = eps_s(2,2) + eps_array(2,2,i,j,k)*hlagrange
+ eps_s(2,3) = eps_s(2,3) + eps_array(2,3,i,j,k)*hlagrange
+ eps_s(3,3) = eps_s(3,3) + eps_array(3,3,i,j,k)*hlagrange
+
+ xix_s = xix_s + xix(i,j,k)*hlagrange
+ xiy_s = xiy_s + xiy(i,j,k)*hlagrange
+ xiz_s = xiz_s + xiz(i,j,k)*hlagrange
+ etax_s = etax_s + etax(i,j,k)*hlagrange
+ etay_s = etay_s + etay(i,j,k)*hlagrange
+ etaz_s = etaz_s + etaz(i,j,k)*hlagrange
+ gammax_s = gammax_s + gammax(i,j,k)*hlagrange
+ gammay_s = gammay_s + gammay(i,j,k)*hlagrange
+ gammaz_s = gammaz_s + gammaz(i,j,k)*hlagrange
+
+ enddo
+ enddo
+ enddo
+
+! for completion purpose, not used in specfem3D.f90
+ eps_s(2,1) = eps_s(1,2)
+ eps_s(3,1) = eps_s(1,3)
+ eps_s(3,2) = eps_s(2,3)
+
+! compute the gradient of M_jk * eps_jk, and then interpolate it
+
+ eps_m_s = 0.
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ hlagrange_xi = hpxir(i)*hetar(j)*hgammar(k)
+ hlagrange_eta = hxir(i)*hpetar(j)*hgammar(k)
+ hlagrange_gamma = hxir(i)*hetar(j)*hpgammar(k)
+
+ eps_m_s(1) = eps_m_s(1) + eps_m_array(i,j,k) * (hlagrange_xi * xix_s &
+ + hlagrange_eta * etax_s + hlagrange_gamma * gammax_s)
+ eps_m_s(2) = eps_m_s(2) + eps_m_array(i,j,k) * (hlagrange_xi * xiy_s &
+ + hlagrange_eta * etay_s + hlagrange_gamma * gammay_s)
+ eps_m_s(3) = eps_m_s(3) + eps_m_array(i,j,k) * (hlagrange_xi * xiz_s &
+ + hlagrange_eta * etaz_s + hlagrange_gamma * gammaz_s)
+
+ enddo
+ enddo
+ enddo
+
+end subroutine compute_adj_source_frechet
+
+! =======================================================================
+
+! compute array for acoustic source
+ subroutine compute_arrays_source_acoustic(xi_source,eta_source,gamma_source,&
+ sourcearray,xigll,yigll,zigll,factor_source)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: xi_source,eta_source,gamma_source
+ real(kind=CUSTOM_REAL) :: factor_source
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearray
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll
+ double precision, dimension(NGLLY) :: yigll
+ double precision, dimension(NGLLZ) :: zigll
+
+! local parameters
+! source arrays
+ double precision, dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sourcearrayd
+ double precision, dimension(NGLLX) :: hxis,hpxis
+ double precision, dimension(NGLLY) :: hetas,hpetas
+ double precision, dimension(NGLLZ) :: hgammas,hpgammas
+ integer :: i,j,k
+
+! initializes
+ sourcearray(:,:,:,:) = 0._CUSTOM_REAL
+ sourcearrayd(:,:,:,:) = 0.d0
+
+! computes Lagrange polynomials at the source location
+ call lagrange_any(xi_source,NGLLX,xigll,hxis,hpxis)
+ call lagrange_any(eta_source,NGLLY,yigll,hetas,hpetas)
+ call lagrange_any(gamma_source,NGLLZ,zigll,hgammas,hpgammas)
+
+! calculates source array for interpolated location
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! identical source array components in x,y,z-direction
+ sourcearrayd(:,i,j,k) = hxis(i)*hetas(j)*hgammas(k)*dble(factor_source)
+ enddo
+ enddo
+ enddo
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ sourcearray(:,:,:,:) = sngl(sourcearrayd(:,:,:,:))
+ else
+ sourcearray(:,:,:,:) = sourcearrayd(:,:,:,:)
+ endif
+
+ end subroutine compute_arrays_source_acoustic
+
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_boundary_kernel.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_boundary_kernel.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_boundary_kernel.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,233 @@
+!=====================================================================
+!
+! 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 compute_boundary_kernel()
+
+
+! isotropic topography kernel computation
+! compare with Tromp et al. (2005), eq. (25), or see Liu & Tromp (2008), eq. (65)
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+
+ implicit none
+ ! local parameters
+ real(kind=CUSTOM_REAL):: kernel_moho_top,kernel_moho_bot
+ integer :: i,j,k
+ integer :: ispec2D,igll,jgll
+ integer :: ispec_top,ispec_bot,iglob_top,iglob_bot
+ logical :: is_done
+
+ ! loops over top/bottom elements of moho surface
+ do ispec2D = 1, NSPEC2D_MOHO
+ ispec_top = ibelm_moho_top(ispec2D)
+ ispec_bot = ibelm_moho_bot(ispec2D)
+
+ ! elements on both sides available
+ if( ispec_top > 0 .and. ispec_bot > 0 ) then
+ ! loops over surface
+ do igll=1,NGLLSQUARE
+ i = ijk_moho_top(1,igll,ispec2D)
+ j = ijk_moho_top(2,igll,ispec2D)
+ k = ijk_moho_top(3,igll,ispec2D)
+ iglob_top = ibool(i,j,k,ispec_top)
+
+ ! computes contribution from top element
+ call compute_boundary_kernel_elem( kernel_moho_top, &
+ mustore(i,j,k,ispec_top), &
+ kappastore(i,j,k,ispec_top),rho_vs(i,j,k,ispec_top), &
+ accel(:,iglob_top),b_displ(:,iglob_top), &
+ dsdx_top(:,:,i,j,k,ispec2D),b_dsdx_top(:,:,i,j,k,ispec2D), &
+ normal_moho_top(:,igll,ispec2D) )
+
+ ! finds corresponding global node in bottom element
+ is_done = .false.
+ do jgll = 1,NGLLSQUARE
+ i = ijk_moho_bot(1,jgll,ispec2D)
+ j = ijk_moho_bot(2,jgll,ispec2D)
+ k = ijk_moho_bot(3,jgll,ispec2D)
+ iglob_bot = ibool(i,j,k,ispec_bot)
+
+ if( iglob_bot /= iglob_top ) cycle
+ ! iglob_top == iglob_bot!
+
+ ! computes contribution from bottom element
+ call compute_boundary_kernel_elem( kernel_moho_bot, &
+ mustore(i,j,k,ispec_bot), &
+ kappastore(i,j,k,ispec_bot),rho_vs(i,j,k,ispec_bot), &
+ accel(:,iglob_bot),b_displ(:,iglob_bot), &
+ dsdx_bot(:,:,i,j,k,ispec2D),b_dsdx_bot(:,:,i,j,k,ispec2D), &
+ normal_moho_bot(:,jgll,ispec2D) )
+
+ ! note: kernel point position: indices given by ijk_moho_top(:,igll,ispec2D)
+ moho_kl(igll,ispec2D) = moho_kl(igll,ispec2D) &
+ + (kernel_moho_top - kernel_moho_bot) * deltat
+
+ ! kernel done for this point
+ is_done = .true.
+ enddo
+
+ ! checks
+ if( .not. is_done ) then
+ print*,'error : moho kernel not computed'
+ print*,'ispec:',ispec_top,ispec_bot,iglob_top,i,j,k
+ call exit_mpi(myrank,'error moho kernel computation')
+ endif
+
+ enddo
+
+ ! only one element available
+ ! e.g. free-surface: see Tromp et al. (2005), eq. (28)
+ else if( ispec_bot > 0 .or. ispec_top > 0 ) then
+
+ ! loops over surface
+ do igll=1,NGLLSQUARE
+
+ if( ispec_top > 0 ) then
+ i = ijk_moho_top(1,igll,ispec2D)
+ j = ijk_moho_top(2,igll,ispec2D)
+ k = ijk_moho_top(3,igll,ispec2D)
+ iglob_top = ibool(i,j,k,ispec_top)
+
+ ! computes contribution from top element
+ call compute_boundary_kernel_elem( kernel_moho_top, &
+ mustore(i,j,k,ispec_top), &
+ kappastore(i,j,k,ispec_top),rho_vs(i,j,k,ispec_top), &
+ accel(:,iglob_top),b_displ(:,iglob_top), &
+ dsdx_top(:,:,i,j,k,ispec2D),b_dsdx_top(:,:,i,j,k,ispec2D), &
+ normal_moho_top(:,igll,ispec2D) )
+
+ ! note: kernel point position igll: indices given by ijk_moho_top(:,igll,ispec2D)
+ moho_kl(igll,ispec2D) = moho_kl(igll,ispec2D) + kernel_moho_top * deltat
+
+ else
+ i = ijk_moho_bot(1,igll,ispec2D)
+ j = ijk_moho_bot(2,igll,ispec2D)
+ k = ijk_moho_bot(3,igll,ispec2D)
+ iglob_bot = ibool(i,j,k,ispec_bot)
+
+ ! computes contribution from bottom element
+ call compute_boundary_kernel_elem( kernel_moho_bot, &
+ mustore(i,j,k,ispec_bot), &
+ kappastore(i,j,k,ispec_bot),rho_vs(i,j,k,ispec_bot), &
+ accel(:,iglob_bot),b_displ(:,iglob_bot), &
+ dsdx_bot(:,:,i,j,k,ispec2D),b_dsdx_bot(:,:,i,j,k,ispec2D), &
+ normal_moho_bot(:,igll,ispec2D) )
+
+ ! note: kernel point position igll: indices given by ijk_moho_bot(:,igll,ispec2D)
+ moho_kl(igll,ispec2D) = moho_kl(igll,ispec2D) - kernel_moho_bot * deltat
+
+ endif
+ enddo
+ endif
+ enddo ! ispec2D
+
+
+end subroutine compute_boundary_kernel
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine compute_boundary_kernel_elem(kernel, mul, kappal, rho_vsl, &
+ accel, b_displ, ds, b_ds, norm)
+
+! compute the boundary kernel contribution from one side of the boundary
+! see e.g.: Tromp et al. (2005), eq. (25), or Liu & Tromp (2008), eq. (65)
+
+ implicit none
+ include 'constants.h'
+
+ real(kind=CUSTOM_REAL) kernel, mul, kappal, rho_vsl
+ real(kind=CUSTOM_REAL) :: accel(NDIM), b_displ(NDIM), ds(NDIM,NDIM), b_ds(NDIM,NDIM), norm(NDIM)
+
+ real(kind=CUSTOM_REAL) :: eps3, eps(NDIM,NDIM), epsdev(NDIM,NDIM), normal(NDIM,1)
+ real(kind=CUSTOM_REAL) :: b_eps3, b_eps(NDIM,NDIM), b_epsdev(NDIM,NDIM)
+ real(kind=CUSTOM_REAL) :: temp1(NDIM,NDIM), rhol, kl(1,1), one_matrix(1,1)
+
+
+ normal(:,1) = norm
+ one_matrix(1,1) = ONE
+
+ ! adjoint strain (epsilon) trace
+ eps3 = ds(1,1) + ds(2,2) + ds(3,3)
+
+ ! adjoint strain tensor
+ eps(1,1) = ds(1,1)
+ eps(2,2) = ds(2,2)
+ eps(3,3) = ds(3,3)
+ eps(1,2) = (ds(1,2) + ds(2,1))/2
+ eps(1,3) = (ds(1,3) + ds(3,1))/2
+ eps(2,3) = (ds(2,3) + ds(3,2))/2
+ eps(2,1) = eps(1,2)
+ eps(3,1) = eps(1,3)
+ eps(3,2) = eps(2,3)
+
+ ! adjoint deviatoric strain component
+ epsdev = eps
+ epsdev(1,1) = eps(1,1) - eps3 / 3
+ epsdev(2,2) = eps(2,2) - eps3 / 3
+ epsdev(3,3) = eps(3,3) - eps3 / 3
+
+
+ ! backward/reconstructed-forward strain (epsilon) trace
+ b_eps3 = b_ds(1,1) + b_ds(2,2) + b_ds(3,3)
+
+ ! backward/reconstructed-forward strain tensor
+ b_eps(1,1) = b_ds(1,1)
+ b_eps(2,2) = b_ds(2,2)
+ b_eps(3,3) = b_ds(3,3)
+ b_eps(1,2) = (b_ds(1,2) + b_ds(2,1))/2
+ b_eps(1,3) = (b_ds(1,3) + b_ds(3,1))/2
+ b_eps(2,3) = (b_ds(2,3) + b_ds(3,2))/2
+ b_eps(2,1) = b_eps(1,2)
+ b_eps(3,1) = b_eps(1,3)
+ b_eps(3,2) = b_eps(2,3)
+
+ ! backward/reconstructed-forward deviatoric strain
+ b_epsdev = b_eps
+ b_epsdev(1,1) = b_eps(1,1) - b_eps3 / 3
+ b_epsdev(2,2) = b_eps(2,2) - b_eps3 / 3
+ b_epsdev(3,3) = b_eps(3,3) - b_eps3 / 3
+
+ ! matrix multiplication
+ temp1 = matmul(epsdev,b_epsdev)
+
+ ! density value
+ rhol = rho_vsl ** 2 / mul
+
+ ! isotropic kernel value
+ ! see e.g.: Tromp et al. (2005), eq. (25), or Liu & Tromp 2008, eq. (65)
+ kl = ( rhol * dot_product(accel(:), b_displ(:)) + kappal * eps3 * b_eps3 &
+ + 2 * mul * (temp1(1,1) + temp1(2,2) + temp1(3,3)) ) * one_matrix &
+ - kappal * matmul(transpose(normal),matmul(eps,normal)) * b_eps3 &
+ - kappal * matmul(transpose(normal),matmul(b_eps,normal)) * eps3 &
+ - 2 * mul * matmul(transpose(normal), matmul(matmul(b_epsdev,ds), normal)) &
+ - 2 * mul * matmul(transpose(normal), matmul(matmul(epsdev,b_ds), normal))
+
+ kernel = kl(1,1)
+
+end subroutine compute_boundary_kernel_elem
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_coupling_acoustic_el.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_coupling_acoustic_el.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_coupling_acoustic_el.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,123 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! for acoustic solver
+
+ subroutine compute_coupling_acoustic_el(NSPEC_AB,NGLOB_AB, &
+ ibool,displ,potential_dot_dot_acoustic, &
+ num_coupling_ac_el_faces, &
+ coupling_ac_el_ispec,coupling_ac_el_ijk, &
+ coupling_ac_el_normal, &
+ coupling_ac_el_jacobian2Dw, &
+ ispec_is_inner,phase_is_inner)
+
+! returns the updated pressure array: potential_dot_dot_acoustic
+
+ implicit none
+ include 'constants.h'
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! displacement and pressure
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: displ
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
+
+! global indexing
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! acoustic-elastic coupling surface
+ integer :: num_coupling_ac_el_faces
+ real(kind=CUSTOM_REAL) :: coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces)
+ real(kind=CUSTOM_REAL) :: coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces)
+ integer :: coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces)
+ integer :: coupling_ac_el_ispec(num_coupling_ac_el_faces)
+
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+! local parameters
+ real(kind=CUSTOM_REAL) :: displ_x,displ_y,displ_z,displ_n
+ real(kind=CUSTOM_REAL) :: nx,ny,nz,jacobianw
+
+ integer :: iface,igll,ispec,iglob
+ integer :: i,j,k
+
+! loops on all coupling faces
+ do iface = 1,num_coupling_ac_el_faces
+
+ ! gets corresponding elements
+ ! (note: can be either acoustic or elastic element, no need to specify since
+ ! no material properties are needed for this coupling term)
+ ispec = coupling_ac_el_ispec(iface)
+
+ if( ispec_is_inner(ispec) .eqv. phase_is_inner ) then
+
+ ! loops over common GLL points
+ do igll = 1, NGLLSQUARE
+ i = coupling_ac_el_ijk(1,igll,iface)
+ j = coupling_ac_el_ijk(2,igll,iface)
+ k = coupling_ac_el_ijk(3,igll,iface)
+
+ ! gets global index of this common GLL point
+ ! (note: should be the same as for corresponding i',j',k',ispec_elastic or ispec_acoustic)
+ iglob = ibool(i,j,k,ispec)
+
+ ! elastic displacement on global point
+ displ_x = displ(1,iglob)
+ displ_y = displ(2,iglob)
+ displ_z = displ(3,iglob)
+
+ ! gets associated normal on GLL point
+ ! (note convention: pointing outwards of acoustic element)
+ nx = coupling_ac_el_normal(1,igll,iface)
+ ny = coupling_ac_el_normal(2,igll,iface)
+ nz = coupling_ac_el_normal(3,igll,iface)
+
+ ! calculates displacement component along normal
+ ! (normal points outwards of acoustic element)
+ displ_n = displ_x*nx + displ_y*ny + displ_z*nz
+
+ ! gets associated, weighted jacobian
+ jacobianw = coupling_ac_el_jacobian2Dw(igll,iface)
+
+ ! continuity of pressure and normal displacement on global point
+ !
+ ! note: newark time scheme together with definition of scalar potential:
+ ! pressure = - chi_dot_dot
+ ! requires that this coupling term uses the updated displacement at time step [t+delta_t],
+ ! which is done at the very beginning of the time loop
+ ! (see e.g. Chaljub & Vilotte, Nissen-Meyer thesis...)
+ ! it also means you have to calculate and update this here first before
+ ! calculating the coupling on the elastic side for the acceleration...
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) + jacobianw*displ_n
+
+ enddo ! igll
+
+ endif
+
+ enddo ! iface
+
+end subroutine compute_coupling_acoustic_el
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_coupling_elastic_ac.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_coupling_elastic_ac.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_coupling_elastic_ac.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,121 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! for elastic solver
+
+ subroutine compute_coupling_elastic_ac(NSPEC_AB,NGLOB_AB, &
+ ibool,accel,potential_dot_dot_acoustic, &
+ num_coupling_ac_el_faces, &
+ coupling_ac_el_ispec,coupling_ac_el_ijk, &
+ coupling_ac_el_normal, &
+ coupling_ac_el_jacobian2Dw, &
+ ispec_is_inner,phase_is_inner)
+
+! returns the updated acceleration array: accel
+
+ implicit none
+ include 'constants.h'
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! displacement and pressure
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: accel
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
+
+! global indexing
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! acoustic-elastic coupling surface
+ integer :: num_coupling_ac_el_faces
+ real(kind=CUSTOM_REAL) :: coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces)
+ real(kind=CUSTOM_REAL) :: coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces)
+ integer :: coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces)
+ integer :: coupling_ac_el_ispec(num_coupling_ac_el_faces)
+
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+! local parameters
+ real(kind=CUSTOM_REAL) :: pressure
+ real(kind=CUSTOM_REAL) :: nx,ny,nz,jacobianw
+
+ integer :: iface,igll,ispec,iglob
+ integer :: i,j,k
+
+! loops on all coupling faces
+ do iface = 1,num_coupling_ac_el_faces
+
+ ! gets corresponding spectral element
+ ! (note: can be either acoustic or elastic element, no need to specify since
+ ! no material properties are needed for this coupling term)
+ ispec = coupling_ac_el_ispec(iface)
+
+ if( ispec_is_inner(ispec) .eqv. phase_is_inner ) then
+
+ ! loops over common GLL points
+ do igll = 1, NGLLSQUARE
+ i = coupling_ac_el_ijk(1,igll,iface)
+ j = coupling_ac_el_ijk(2,igll,iface)
+ k = coupling_ac_el_ijk(3,igll,iface)
+
+ ! gets global index of this common GLL point
+ ! (note: should be the same as for corresponding i',j',k',ispec_elastic or ispec_elastic )
+ iglob = ibool(i,j,k,ispec)
+
+ ! acoustic pressure on global point
+ pressure = - potential_dot_dot_acoustic(iglob)
+
+ ! gets associated normal on GLL point
+ ! (note convention: pointing outwards of acoustic element)
+ nx = coupling_ac_el_normal(1,igll,iface)
+ ny = coupling_ac_el_normal(2,igll,iface)
+ nz = coupling_ac_el_normal(3,igll,iface)
+
+ ! gets associated, weighted 2D jacobian
+ ! (note: should be the same for elastic and acoustic element)
+ jacobianw = coupling_ac_el_jacobian2Dw(igll,iface)
+
+ ! continuity of displacement and pressure on global point
+ !
+ ! note: newark time scheme together with definition of scalar potential:
+ ! pressure = - chi_dot_dot
+ ! requires that this coupling term uses the *UPDATED* pressure (chi_dot_dot), i.e.
+ ! pressure at time step [t + delta_t]
+ ! (see e.g. Chaljub & Vilotte, Nissen-Meyer thesis...)
+ ! it means you have to calculate and update the acoustic pressure first before
+ ! calculating this term...
+ accel(1,iglob) = accel(1,iglob) + jacobianw*nx*pressure
+ accel(2,iglob) = accel(2,iglob) + jacobianw*ny*pressure
+ accel(3,iglob) = accel(3,iglob) + jacobianw*nz*pressure
+
+ enddo ! igll
+
+ endif
+
+ enddo ! iface
+
+end subroutine compute_coupling_elastic_ac
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_acoustic.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_acoustic.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_acoustic.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,387 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! acoustic solver
+
+! in case of an acoustic medium, a potential Chi of (density * displacement) is used as in Chaljub and Valette,
+! Geophysical Journal International, vol. 158, p. 131-141 (2004) and *NOT* a velocity potential
+! as in Komatitsch and Tromp, Geophysical Journal International, vol. 150, p. 303-318 (2002).
+!
+! This permits acoustic-elastic coupling based on a non-iterative time scheme.
+! Displacement is then:
+! u = grad(Chi) / rho
+! Velocity is then:
+! v = grad(Chi_dot) / rho
+! (Chi_dot being the time derivative of Chi)
+! and pressure is:
+! p = - Chi_dot_dot
+! (Chi_dot_dot being the time second derivative of Chi).
+!
+! The source in an acoustic element is a pressure source.
+!
+! First-order acoustic-acoustic discontinuities are also handled automatically
+! because pressure is continuous at such an interface, therefore Chi_dot_dot
+! is continuous, therefore Chi is also continuous, which is consistent with
+! the spectral-element basis functions and with the assembling process.
+! This is the reason why a simple displacement potential u = grad(Chi) would
+! not work because it would be discontinuous at such an interface and would
+! therefore not be consistent with the basis functions.
+
+
+subroutine compute_forces_acoustic()
+
+ use specfem_par
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ use specfem_par_poroelastic
+ use PML_par
+ use PML_par_acoustic
+ implicit none
+ ! local parameters
+ integer:: iphase
+ logical:: phase_is_inner
+
+
+! enforces free surface (zeroes potentials at free surface)
+ call acoustic_enforce_free_surface(NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
+ ibool,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces,ispec_is_acoustic)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) &
+ call acoustic_enforce_free_surface(NSPEC_AB,NGLOB_ADJOINT, &
+ b_potential_acoustic,b_potential_dot_acoustic,b_potential_dot_dot_acoustic, &
+ ibool,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces,ispec_is_acoustic)
+
+
+ if(PML) call PML_acoustic_enforce_free_srfc(NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
+ ibool,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces,ispec_is_acoustic, &
+ num_PML_ispec,PML_ispec,&
+ chi1,chi2,chi2_t,chi3,chi4,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi2_t_dot_dot,&
+ chi3_dot_dot,chi4_dot_dot)
+
+! distinguishes two runs: for points on MPI interfaces, and points within the partitions
+ do iphase=1,2
+
+ !first for points on MPI interfaces
+ if( iphase == 1 ) then
+ phase_is_inner = .false.
+ else
+ phase_is_inner = .true.
+ endif
+
+! acoustic pressure term
+ call compute_forces_acoustic_pot( iphase, NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_dot_acoustic, &
+ 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, &
+ rhostore,jacobian,ibool, &
+ num_phase_ispec_acoustic,nspec_inner_acoustic,nspec_outer_acoustic,&
+ phase_ispec_inner_acoustic )
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) &
+ call compute_forces_acoustic_pot( iphase, NSPEC_ADJOINT,NGLOB_ADJOINT, &
+ b_potential_acoustic,b_potential_dot_dot_acoustic, &
+ 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, &
+ rhostore,jacobian,ibool, &
+ num_phase_ispec_acoustic,nspec_inner_acoustic,nspec_outer_acoustic,&
+ phase_ispec_inner_acoustic )
+
+
+ if(PML) then
+ call compute_forces_acoustic_PML(NSPEC_AB,NGLOB_AB, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ rhostore,ispec_is_acoustic,potential_acoustic, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,jacobian,&
+ wxgll,wygll,wzgll,&
+ PML_damping_dprime,num_PML_ispec,&
+ PML_ispec,PML_normal,&
+ chi1_dot_dot,chi2_t_dot_dot,&
+ chi3_dot_dot,chi4_dot_dot)
+
+ ! couples potential_dot_dot with PML interface contributions
+ call PML_acoustic_interface_coupling(phase_is_inner,NSPEC_AB,NGLOB_AB,&
+ potential_dot_dot_acoustic,&
+ ibool,ispec_is_inner,ispec_is_acoustic,&
+ num_PML_ispec,PML_ispec,iglob_is_PML_interface,&
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
+
+ endif ! PML
+
+! absorbing boundaries
+ if(ABSORBING_CONDITIONS) then
+ if( PML .and. PML_USE_SOMMERFELD ) then
+ ! adds a Sommerfeld condition on the domain's absorbing boundaries
+ call PML_acoustic_abs_boundaries(phase_is_inner,NSPEC_AB,NGLOB_AB,&
+ abs_boundary_jacobian2Dw,abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces, &
+ kappastore,ibool,ispec_is_inner, &
+ rhostore,ispec_is_acoustic,&
+ potential_dot_acoustic,potential_dot_dot_acoustic,&
+ num_PML_ispec,PML_ispec,ispec_is_PML_inum,&
+ chi1_dot,chi2_t,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
+ else
+ call compute_stacey_acoustic(NSPEC_AB,NGLOB_AB, &
+ potential_dot_dot_acoustic,potential_dot_acoustic, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ abs_boundary_jacobian2Dw,abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces,rhostore,kappastore,ispec_is_acoustic, &
+ SIMULATION_TYPE,SAVE_FORWARD,NSTEP,it,myrank,NGLOB_ADJOINT, &
+ b_potential_dot_dot_acoustic,b_reclen_potential, &
+ b_absorb_potential,b_num_abs_boundary_faces)
+ endif
+ endif
+
+! elastic coupling
+ if(ELASTIC_SIMULATION ) then
+ call compute_coupling_acoustic_el(NSPEC_AB,NGLOB_AB, &
+ ibool,displ,potential_dot_dot_acoustic, &
+ num_coupling_ac_el_faces, &
+ coupling_ac_el_ispec,coupling_ac_el_ijk, &
+ coupling_ac_el_normal, &
+ coupling_ac_el_jacobian2Dw, &
+ ispec_is_inner,phase_is_inner)
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) &
+ call compute_coupling_acoustic_el(NSPEC_ADJOINT,NGLOB_ADJOINT, &
+ ibool,b_displ,b_potential_dot_dot_acoustic, &
+ num_coupling_ac_el_faces, &
+ coupling_ac_el_ispec,coupling_ac_el_ijk, &
+ coupling_ac_el_normal, &
+ coupling_ac_el_jacobian2Dw, &
+ ispec_is_inner,phase_is_inner)
+ endif
+
+! poroelastic coupling
+! not implemented yet
+ !if(POROELASTIC_SIMULATION ) &
+ ! call compute_coupling_acoustic_poro()
+
+! sources
+ call compute_add_sources_acoustic(NSPEC_AB,NGLOB_AB,potential_dot_dot_acoustic, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,&
+ xi_source,eta_source,gamma_source, &
+ hdur,hdur_gaussian,t_cmt,dt,t0, &
+ sourcearrays,kappastore,ispec_is_acoustic,&
+ SIMULATION_TYPE,NSTEP,NGLOB_ADJOINT, &
+ nrec,islice_selected_rec,ispec_selected_rec, &
+ nadj_rec_local,adj_sourcearrays,b_potential_dot_dot_acoustic )
+
+! assemble all the contributions between slices using MPI
+ if( phase_is_inner .eqv. .false. ) then
+ ! sends potential_dot_dot_acoustic values to corresponding MPI interface neighbors (non-blocking)
+ call assemble_MPI_scalar_ext_mesh_s(NPROC,NGLOB_AB,potential_dot_dot_acoustic, &
+ buffer_send_scalar_ext_mesh,buffer_recv_scalar_ext_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh, &
+ request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) &
+ call assemble_MPI_scalar_ext_mesh_s(NPROC,NGLOB_ADJOINT,b_potential_dot_dot_acoustic, &
+ b_buffer_send_scalar_ext_mesh,b_buffer_recv_scalar_ext_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh, &
+ b_request_send_scalar_ext_mesh,b_request_recv_scalar_ext_mesh)
+ else
+ ! waits for send/receive requests to be completed and assembles values
+ call assemble_MPI_scalar_ext_mesh_w(NPROC,NGLOB_AB,potential_dot_dot_acoustic, &
+ buffer_recv_scalar_ext_mesh,num_interfaces_ext_mesh,&
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh)
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) &
+ call assemble_MPI_scalar_ext_mesh_w(NPROC,NGLOB_ADJOINT,b_potential_dot_dot_acoustic, &
+ b_buffer_recv_scalar_ext_mesh,num_interfaces_ext_mesh,&
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ b_request_send_scalar_ext_mesh,b_request_recv_scalar_ext_mesh)
+
+ endif
+
+
+ enddo
+
+ ! divides pressure with mass matrix
+ potential_dot_dot_acoustic(:) = potential_dot_dot_acoustic(:) * rmass_acoustic(:)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) &
+ b_potential_dot_dot_acoustic(:) = b_potential_dot_dot_acoustic(:) * rmass_acoustic(:)
+
+
+ if(PML) then
+ ! divides local contributions with mass term
+ call PML_acoustic_mass_update(NSPEC_AB,NGLOB_AB,&
+ ispec_is_acoustic,rmass_acoustic,ibool,&
+ num_PML_ispec,PML_ispec,&
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot)
+
+ ! Newark time scheme corrector terms
+ call PML_acoustic_time_corrector(NSPEC_AB,ispec_is_acoustic,deltatover2,&
+ num_PML_ispec,PML_ispec,PML_damping_d,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot)
+ endif
+
+
+! update velocity
+! note: Newark finite-difference time scheme with acoustic domains:
+! (see e.g. Hughes, 1987; Chaljub et al., 2003)
+!
+! chi(t+delta_t) = chi(t) + delta_t chi_dot(t) + 1/2 delta_t**2 chi_dot_dot(t)
+! chi_dot(t+delta_t) = chi_dot(t) + 1/2 delta_t chi_dot_dot(t) + 1/2 DELTA_T CHI_DOT_DOT( T + DELTA_T )
+! chi_dot_dot(t+delta_t) = 1/M_acoustic( -K_acoustic chi(t+delta) + B_acoustic u(t+delta_t) + f(t+delta_t) )
+!
+! where
+! chi, chi_dot, chi_dot_dot are acoustic (fluid) potentials ( dotted with respect to time)
+! u, v, a are displacement,velocity & acceleration
+! M is mass matrix, K stiffness matrix and B boundary term
+! f denotes a source term
+!
+! corrector:
+! updates the chi_dot term which requires chi_dot_dot(t+delta)
+ potential_dot_acoustic(:) = potential_dot_acoustic(:) + deltatover2*potential_dot_dot_acoustic(:)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) &
+ b_potential_dot_acoustic(:) = b_potential_dot_acoustic(:) + deltatover2*b_potential_dot_dot_acoustic(:)
+
+ ! updates potential_dot_acoustic and potential_dot_dot_acoustic inside PML region for plotting seismograms/movies
+ if(PML) call PML_acoustic_update_potentials(NGLOB_AB,NSPEC_AB, &
+ ibool,ispec_is_acoustic, &
+ potential_dot_acoustic,potential_dot_dot_acoustic,&
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh,NPROC,&
+ num_PML_ispec,PML_ispec,iglob_is_PML_interface,&
+ PML_mask_ibool,PML_damping_d,&
+ chi1,chi2,chi2_t,chi3,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
+
+
+! enforces free surface (zeroes potentials at free surface)
+ call acoustic_enforce_free_surface(NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
+ ibool,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces,ispec_is_acoustic)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) &
+ call acoustic_enforce_free_surface(NSPEC_AB,NGLOB_ADJOINT, &
+ b_potential_acoustic,b_potential_dot_acoustic,b_potential_dot_dot_acoustic, &
+ ibool,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces,ispec_is_acoustic)
+
+
+ if(PML) call PML_acoustic_enforce_free_srfc(NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
+ ibool,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces, &
+ ispec_is_acoustic, &
+ num_PML_ispec,PML_ispec,&
+ chi1,chi2,chi2_t,chi3,chi4,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi2_t_dot_dot,&
+ chi3_dot_dot,chi4_dot_dot)
+
+
+end subroutine compute_forces_acoustic
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+subroutine acoustic_enforce_free_surface(NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
+ ibool,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces,ispec_is_acoustic)
+ implicit none
+ include 'constants.h'
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! acoustic potentials
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! free surface
+ integer :: num_free_surface_faces
+ integer :: free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces)
+ integer :: free_surface_ispec(num_free_surface_faces)
+
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+! local parameters
+ integer :: iface,igll,i,j,k,ispec,iglob
+
+! enforce potentials to be zero at surface
+ do iface = 1, num_free_surface_faces
+
+ ispec = free_surface_ispec(iface)
+
+ if( ispec_is_acoustic(ispec) ) then
+
+ do igll = 1, NGLLSQUARE
+ i = free_surface_ijk(1,igll,iface)
+ j = free_surface_ijk(2,igll,iface)
+ k = free_surface_ijk(3,igll,iface)
+ iglob = ibool(i,j,k,ispec)
+
+ ! sets potentials to zero
+ potential_acoustic(iglob) = 0._CUSTOM_REAL
+ potential_dot_acoustic(iglob) = 0._CUSTOM_REAL
+ potential_dot_dot_acoustic(iglob) = 0._CUSTOM_REAL
+ enddo
+ endif
+
+ enddo
+
+end subroutine acoustic_enforce_free_surface
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_acoustic_PML.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_acoustic_PML.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_acoustic_PML.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,1186 @@
+!=====================================================================
+!
+! 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 compute_forces_acoustic_PML(NSPEC_AB,NGLOB_AB, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ rhostore,ispec_is_acoustic,potential_acoustic, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,jacobian,&
+ wxgll,wygll,wzgll,&
+ PML_damping_dprime,num_PML_ispec,&
+ PML_ispec,PML_normal,&
+ chi1_dot_dot,chi2_t_dot_dot,&
+ chi3_dot_dot,chi4_dot_dot)
+
+ use constants,only: NGLLX,NGLLY,NGLLZ,NDIM,TINYVAL_SNGL,CUSTOM_REAL
+ implicit none
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+ ! potential
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_acoustic
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+ ! split-potentials
+ integer :: num_PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ PML_damping_dprime
+ integer,dimension(num_PML_ispec):: PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NDIM,num_PML_ispec):: PML_normal
+
+ ! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rhostore
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,jacobian
+
+ ! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+
+ 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
+
+ double precision, dimension(NGLLX) :: wxgll
+ double precision, dimension(NGLLY) :: wygll
+ double precision, dimension(NGLLZ) :: wzgll
+
+ ! local parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: chi_elem
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: temp1_n,temp2_n,temp3_n
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: temp1_p,temp2_p,temp3_p
+ real(kind=CUSTOM_REAL) :: rho_invl
+ real(kind=CUSTOM_REAL) :: temp1l,temp2l,temp3l
+ real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) :: dpotentialdxl,dpotentialdyl,dpotentialdzl
+ real(kind=CUSTOM_REAL) :: dpotentialdxl_n,dpotentialdyl_n,dpotentialdzl_n
+ real(kind=CUSTOM_REAL) :: dpotentialdxl_p,dpotentialdyl_p,dpotentialdzl_p
+ real(kind=CUSTOM_REAL) :: nx,ny,nz,grad_n,dprime,weights
+ integer :: ispec,iglob,i,j,k,l,ispecPML
+
+ ! loops over all PML elements
+ do ispecPML=1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! checks with MPI interface flag
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ ! only acoustic part
+ if( ispec_is_acoustic(ispec) ) then
+
+ ! gets values for element
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ chi_elem(i,j,k) = potential_acoustic(ibool(i,j,k,ispec))
+ enddo
+ enddo
+ enddo
+ ! checks if anything to do
+ if( maxval( abs( chi_elem ) ) < TINYVAL_SNGL ) cycle
+
+ ! PML normal
+ nx = PML_normal(1,ispecPML)
+ ny = PML_normal(2,ispecPML)
+ nz = PML_normal(3,ispecPML)
+
+ ! calculates terms:
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ ! density (reciproc)
+ rho_invl = 1.0_CUSTOM_REAL / rhostore(i,j,k,ispec)
+
+ ! derivative along x, y, z
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the loops because NGLLX == NGLLY == NGLLZ
+ temp1l = 0._CUSTOM_REAL
+ temp2l = 0._CUSTOM_REAL
+ temp3l = 0._CUSTOM_REAL
+
+ do l = 1,NGLLX
+ temp1l = temp1l + chi_elem(l,j,k)*hprime_xx(i,l)
+ temp2l = temp2l + chi_elem(i,l,k)*hprime_yy(j,l)
+ temp3l = temp3l + chi_elem(i,j,l)*hprime_zz(k,l)
+ enddo
+
+ ! get derivatives of potential 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)
+
+ ! derivatives of potential
+ ! \npartial_i \chi
+ dpotentialdxl = xixl*temp1l + etaxl*temp2l + gammaxl*temp3l
+ dpotentialdyl = xiyl*temp1l + etayl*temp2l + gammayl*temp3l
+ dpotentialdzl = xizl*temp1l + etazl*temp2l + gammazl*temp3l
+
+ ! splits derivatives of potential into normal and parallel components
+ ! dpotential normal to PML plane
+ ! \hat{n} \partial_n \chi
+ grad_n = dpotentialdxl*nx + dpotentialdyl*ny + dpotentialdzl*nz
+ dpotentialdxl_n = nx * grad_n
+ dpotentialdyl_n = ny * grad_n
+ dpotentialdzl_n = nz * grad_n
+
+
+ ! dpotential parallel to plane
+ ! \nabla^{parallel} \chi
+ dpotentialdxl_p = dpotentialdxl - dpotentialdxl_n
+ dpotentialdyl_p = dpotentialdyl - dpotentialdyl_n
+ dpotentialdzl_p = dpotentialdzl - dpotentialdzl_n
+
+ ! normal incidence term: ( 1/rho J \hat{n} \partial_n \chi )
+ ! (note: we can add two weights at this point to save some computations )
+ temp1_n(i,j,k) = rho_invl * jacobianl * dpotentialdxl_n
+ temp2_n(i,j,k) = rho_invl * jacobianl * dpotentialdyl_n
+ temp3_n(i,j,k) = rho_invl * jacobianl * dpotentialdzl_n
+
+ ! parallel incidence 1/rho J \nabla^{parallel} \chi
+ temp1_p(i,j,k) = rho_invl * jacobianl * dpotentialdxl_p
+ temp2_p(i,j,k) = rho_invl * jacobianl * dpotentialdyl_p
+ temp3_p(i,j,k) = rho_invl * jacobianl * dpotentialdzl_p
+ enddo
+ enddo
+ enddo
+
+ ! second double-loop over GLL to compute all the terms
+ do k = 1,NGLLZ
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,k,ispec)
+
+ ! 1. split term:
+ !-----------------
+ ! normal derivative of w dotted with normal dpotential
+ ! ( \hat{n} \nabla_n w ) \cdot ( 1/rho \hat{n} \nabla_n \chi )
+ temp1l = 0._CUSTOM_REAL
+ temp2l = 0._CUSTOM_REAL
+ temp3l = 0._CUSTOM_REAL
+ do l=1,NGLLX
+ ! derivatives
+ xixl = xix(l,j,k,ispec)
+ xiyl = xiy(l,j,k,ispec)
+ xizl = xiz(l,j,k,ispec)
+ ! note: hprimewgll_xx(l,i) = hprime_xx(l,i)*wxgll(l)
+ ! don't confuse order of indices in hprime_xx: they are l and i
+ ! -> lagrangian (hprime) function i evaluated at point xi_{ l }
+ temp1l = temp1l + hprimewgll_xx(l,i) &
+ *(nx*temp1_n(l,j,k)+ny*temp2_n(l,j,k)+nz*temp3_n(l,j,k)) &
+ *(nx*xixl+ny*xiyl+nz*xizl)
+
+ etaxl = etax(i,l,k,ispec)
+ etayl = etay(i,l,k,ispec)
+ etazl = etaz(i,l,k,ispec)
+
+ temp2l = temp2l + hprimewgll_yy(l,j) &
+ *(nx*temp1_n(i,l,k)+ny*temp2_n(i,l,k)+nz*temp3_n(i,l,k)) &
+ *(nx*etaxl+ny*etayl+nz*etazl)
+
+ gammaxl = gammax(i,j,l,ispec)
+ gammayl = gammay(i,j,l,ispec)
+ gammazl = gammaz(i,j,l,ispec)
+
+ temp3l = temp3l + hprimewgll_zz(l,k) &
+ *(nx*temp1_n(i,j,l)+ny*temp2_n(i,j,l)+nz*temp3_n(i,j,l)) &
+ *(nx*gammaxl+ny*gammayl+nz*gammazl)
+ enddo
+ temp1l = temp1l * wgllwgll_yz(j,k)
+ temp2l = temp2l * wgllwgll_xz(i,k)
+ temp3l = temp3l * wgllwgll_xy(i,j)
+
+ chi1_dot_dot(i,j,k,ispecPML) = - (temp1l + temp2l + temp3l)
+
+ ! 2. split term:
+ !-----------------
+ ! dprime times normal w dotted with normal dpotential
+ ! w dprime \hat{n} \cdot ( 1/rho \hat{n} \nabla_n \chi )
+
+ weights = wxgll(i)*wygll(j)*wzgll(k)
+
+ temp1l = nx*temp1_n(i,j,k)*weights
+ temp2l = ny*temp2_n(i,j,k)*weights
+ temp3l = nz*temp3_n(i,j,k)*weights
+
+ dprime = PML_damping_dprime(i,j,k,ispecPML)
+
+ ! contribution has negative sign?
+ chi2_t_dot_dot(i,j,k,ispecPML) = - dprime*(temp1l + temp2l + temp3l )
+
+
+ ! 3. split term:
+ !-----------------
+ ! parallel derivative of w dotted with normal dpotential
+ ! ( \nabla^{parallel} w ) \cdot ( 1/rho \hat{n} \nabla_n \chi )
+ ! and
+ ! normal derivative of w dotted with parallel dpotential
+ ! ( \hat{n} \nabla_n w ) \cdot ( 1/rho \nabla_{parallel} \chi )
+ temp1l = 0._CUSTOM_REAL
+ temp2l = 0._CUSTOM_REAL
+ temp3l = 0._CUSTOM_REAL
+ do l=1,NGLLX
+ ! derivatives
+ xixl = xix(l,j,k,ispec)
+ xiyl = xiy(l,j,k,ispec)
+ xizl = xiz(l,j,k,ispec)
+ etaxl = etax(i,l,k,ispec)
+ etayl = etay(i,l,k,ispec)
+ etazl = etaz(i,l,k,ispec)
+ gammaxl = gammax(i,j,l,ispec)
+ gammayl = gammay(i,j,l,ispec)
+ gammazl = gammaz(i,j,l,ispec)
+
+ ! normal derivative of w dotted with parallel dpotential
+ temp1l = temp1l + hprimewgll_xx(l,i) &
+ *(nx*temp1_p(l,j,k)+ny*temp2_p(l,j,k)+nz*temp3_p(l,j,k)) &
+ *(nx*xixl+ny*xiyl+nz*xizl)
+
+ temp2l = temp2l + hprimewgll_yy(l,j) &
+ *(nx*temp1_p(i,l,k)+ny*temp2_p(i,l,k)+nz*temp3_p(i,l,k)) &
+ *(nx*etaxl+ny*etayl+nz*etazl)
+
+ temp3l = temp3l + hprimewgll_zz(l,k) &
+ *(nx*temp1_p(i,j,l)+ny*temp2_p(i,j,l)+nz*temp3_p(i,j,l)) &
+ *(nx*gammaxl+ny*gammayl+nz*gammazl)
+
+
+ ! parallel derivative of w dotted with normal dpotential
+ temp1l = temp1l + hprimewgll_xx(l,i) &
+ *( (xixl - nx*(nx*xixl+ny*xiyl+nz*xizl))*temp1_n(l,j,k) &
+ +(xiyl - ny*(nx*xixl+ny*xiyl+nz*xizl))*temp2_n(l,j,k) &
+ +(xizl - nz*(nx*xixl+ny*xiyl+nz*xizl))*temp3_n(l,j,k) )
+
+ temp2l = temp2l + hprimewgll_yy(l,j) &
+ *( (etaxl - nx*(nx*etaxl+ny*etayl+nz*etazl))*temp1_n(i,l,k) &
+ +(etayl - ny*(nx*etaxl+ny*etayl+nz*etazl))*temp2_n(i,l,k) &
+ +(etazl - nz*(nx*etaxl+ny*etayl+nz*etazl))*temp3_n(i,l,k) )
+
+ temp3l = temp3l + hprimewgll_zz(l,k) &
+ *( (gammaxl - nx*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp1_n(i,j,l) &
+ +(gammayl - ny*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp2_n(i,j,l) &
+ +(gammazl - nz*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp3_n(i,j,l) )
+ enddo
+ temp1l = temp1l * wgllwgll_yz(j,k)
+ temp2l = temp2l * wgllwgll_xz(i,k)
+ temp3l = temp3l * wgllwgll_xy(i,j)
+
+ chi3_dot_dot(i,j,k,ispecPML) = - (temp1l + temp2l + temp3l)
+
+
+ ! 4. split term:
+ !-----------------
+ ! parallel derivative of w dotted with parallel dpotential
+ ! ( \nabla_{parallel} w ) \cdot ( 1/rho \nabla_{parallel} \chi )
+ temp1l = 0._CUSTOM_REAL
+ temp2l = 0._CUSTOM_REAL
+ temp3l = 0._CUSTOM_REAL
+ do l=1,NGLLX
+ ! derivatives
+ xixl = xix(l,j,k,ispec)
+ xiyl = xiy(l,j,k,ispec)
+ xizl = xiz(l,j,k,ispec)
+ etaxl = etax(i,l,k,ispec)
+ etayl = etay(i,l,k,ispec)
+ etazl = etaz(i,l,k,ispec)
+ gammaxl = gammax(i,j,l,ispec)
+ gammayl = gammay(i,j,l,ispec)
+ gammazl = gammaz(i,j,l,ispec)
+
+ temp1l = temp1l + hprimewgll_xx(l,i) &
+ *( (xixl - nx*(nx*xixl+ny*xiyl+nz*xizl))*temp1_p(l,j,k) &
+ +(xiyl - ny*(nx*xixl+ny*xiyl+nz*xizl))*temp2_p(l,j,k) &
+ +(xizl - nz*(nx*xixl+ny*xiyl+nz*xizl))*temp3_p(l,j,k) )
+
+ temp2l = temp2l + hprimewgll_yy(l,j) &
+ *( (etaxl - nx*(nx*etaxl+ny*etayl+nz*etazl))*temp1_p(i,l,k) &
+ +(etayl - ny*(nx*etaxl+ny*etayl+nz*etazl))*temp2_p(i,l,k) &
+ +(etazl - nz*(nx*etaxl+ny*etayl+nz*etazl))*temp3_p(i,l,k) )
+
+ temp3l = temp3l + hprimewgll_zz(l,k) &
+ *( (gammaxl - nx*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp1_p(i,j,l) &
+ +(gammayl - ny*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp2_p(i,j,l) &
+ +(gammazl - nz*(nx*gammaxl+ny*gammayl+nz*gammazl))*temp3_p(i,j,l) )
+ enddo
+ temp1l = temp1l * wgllwgll_yz(j,k)
+ temp2l = temp2l * wgllwgll_xz(i,k)
+ temp3l = temp3l * wgllwgll_xy(i,j)
+
+ chi4_dot_dot(i,j,k,ispecPML) = - (temp1l + temp2l + temp3l)
+
+ enddo
+ enddo
+ enddo
+
+ ! note: the surface integral expressions would be needed for points on a free surface
+ !
+ ! BUT at the free surface: potentials are set to zero (zero pressure condition),
+ ! thus the additional surface term contributions would be zeored again.
+
+ endif ! ispec_is_acoustic
+ endif ! ispec_is_inner
+ enddo ! num_PML_ispec
+
+end subroutine compute_forces_acoustic_PML
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_acoustic_abs_boundaries(phase_is_inner,NSPEC_AB,NGLOB_AB,&
+ abs_boundary_jacobian2Dw,abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces, &
+ kappastore,ibool,ispec_is_inner, &
+ rhostore,ispec_is_acoustic,&
+ potential_dot_acoustic,potential_dot_dot_acoustic,&
+ num_PML_ispec,PML_ispec,ispec_is_PML_inum,&
+ chi1_dot,chi2_t,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
+
+! absorbs absorbing-boundary surface using Sommerfeld condition (vanishing field in the outer-space)
+
+ use constants,only: NGLLX,NGLLY,NGLLZ,NGLLSQUARE,CUSTOM_REAL
+ implicit none
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+ ! split-potentials
+ integer :: num_PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot,chi2_t,chi2_t_dot,chi3_dot,chi4_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot
+ integer,dimension(num_PML_ispec):: PML_ispec
+ integer,dimension(NSPEC_AB):: ispec_is_PML_inum
+
+ ! potentials
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic,&
+ potential_dot_acoustic
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+ ! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rhostore,kappastore
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+ ! absorbing boundary surface
+ integer :: num_abs_boundary_faces
+ real(kind=CUSTOM_REAL) :: abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ispec(num_abs_boundary_faces)
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: rhol,cpl,jacobianw,temp
+ integer :: ispec,iglob,i,j,k,iface,igll,ispecPML
+
+ ! absorbs absorbing-boundary surface using Sommerfeld condition (vanishing field in the outer-space)
+ do iface=1,num_abs_boundary_faces
+
+ ispec = abs_boundary_ispec(iface)
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_acoustic(ispec) .and. ispec_is_PML_inum(ispec) > 0 ) then
+
+ do ispecPML=1,num_PML_ispec
+
+ if( PML_ispec(ispecPML) == ispec) then
+
+ ! reference gll points on boundary face
+ do igll = 1,NGLLSQUARE
+
+ ! gets local indices for GLL point
+ i = abs_boundary_ijk(1,igll,iface)
+ j = abs_boundary_ijk(2,igll,iface)
+ k = abs_boundary_ijk(3,igll,iface)
+
+ ! gets global index
+ iglob=ibool(i,j,k,ispec)
+
+ ! determines bulk sound speed
+ rhol = rhostore(i,j,k,ispec)
+ cpl = sqrt( kappastore(i,j,k,ispec) / rhol )
+
+ ! gets associated, weighted jacobian
+ jacobianw = abs_boundary_jacobian2Dw(igll,iface)
+
+ temp = jacobianw / cpl / rhol
+
+ ! Sommerfeld condition
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - potential_dot_acoustic(iglob) * jacobianw / cpl / rhol
+ ! split-potentials
+ chi1_dot_dot(i,j,k,ispecPML) = chi1_dot_dot(i,j,k,ispecPML) - chi1_dot(i,j,k,ispecPML) * temp
+ chi3_dot_dot(i,j,k,ispecPML) = chi3_dot_dot(i,j,k,ispecPML) - chi3_dot(i,j,k,ispecPML) * temp
+ chi4_dot_dot(i,j,k,ispecPML) = chi4_dot_dot(i,j,k,ispecPML) - chi4_dot(i,j,k,ispecPML) * temp
+
+ ! chi2 potential?
+ chi2_t_dot(i,j,k,ispecPML) = chi2_t_dot(i,j,k,ispecPML) - chi2_t(i,j,k,ispecPML) * temp
+
+ enddo
+ endif
+ enddo
+ endif ! ispec_is_acoustic
+ endif ! ispec_is_inner
+ enddo ! num_abs_boundary_faces
+
+end subroutine PML_acoustic_abs_boundaries
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_acoustic_interface_coupling(phase_is_inner,NSPEC_AB,NGLOB_AB,&
+ potential_dot_dot_acoustic,&
+ ibool,ispec_is_inner,ispec_is_acoustic,&
+ num_PML_ispec,PML_ispec,iglob_is_PML_interface,&
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
+
+! couples potential_dot_dot with PML interface contributions
+
+ use constants,only: NGLLX,NGLLY,NGLLZ,CUSTOM_REAL
+ implicit none
+
+ integer :: NGLOB_AB,NSPEC_AB
+
+ ! split-potentials
+ integer :: num_PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot
+ integer,dimension(num_PML_ispec):: PML_ispec
+ integer,dimension(NGLOB_AB):: iglob_is_PML_interface
+
+ ! potential
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+ ! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+
+ !local parameters
+ integer :: iglob,ispecPML,i,j,k,ispec
+
+ ! experimental:
+ ! updates with the contribution from potential_dot_dot_acoustic on split potentials and vice versa
+
+ do ispecPML = 1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ if( ispec_is_inner(ispec) .eqv. phase_is_inner ) then
+
+ ! acoustic potentials
+ if( ispec_is_acoustic(ispec) ) then
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! sums contributions to PML potentials on interface points
+ if( iglob_is_PML_interface(iglob) > 0 ) then
+
+ ! this would be the contribution to the potential_dot_dot array
+ ! note: on PML interface, damping coefficient d should to be zero
+ ! as well as dprime (-> no chi2 contribution)
+
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ + chi1_dot_dot(i,j,k,ispecPML) &
+ + chi3_dot_dot(i,j,k,ispecPML) &
+ + chi4_dot_dot(i,j,k,ispecPML)
+
+ endif ! interface iglob
+ enddo
+ enddo
+ enddo
+
+ endif ! ispec_is_acoustic
+ endif ! ispec_is_inner
+ enddo ! ispecPML
+
+
+end subroutine PML_acoustic_interface_coupling
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+subroutine PML_acoustic_mass_update(NSPEC_AB,NGLOB_AB,&
+ ispec_is_acoustic,rmass_acoustic,ibool,&
+ num_PML_ispec,PML_ispec,&
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot)
+
+! updates split-potentials with local mass in PML region
+
+ use constants,only: NGLLX,NGLLY,NGLLZ,CUSTOM_REAL
+ implicit none
+ integer :: NSPEC_AB,NGLOB_AB
+
+ ! split-potentials
+ integer :: num_PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
+ integer,dimension(num_PML_ispec):: PML_ispec
+
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: rmass_acoustic
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+ !local parameters
+ real(kind=CUSTOM_REAL):: mass
+ integer :: ispec,ispecPML,i,j,k,iglob
+
+ ! updates the dot_dot potentials for the PML
+ do ispecPML = 1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! acoustic potentials
+ if( ispec_is_acoustic(ispec) ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! global mass ( sum over elements included)
+ mass = rmass_acoustic(iglob)
+
+ chi1_dot_dot(i,j,k,ispecPML) = chi1_dot_dot(i,j,k,ispecPML) * mass
+ chi2_t_dot_dot(i,j,k,ispecPML) = chi2_t_dot_dot(i,j,k,ispecPML) * mass
+ chi3_dot_dot(i,j,k,ispecPML) = chi3_dot_dot(i,j,k,ispecPML) * mass
+ chi4_dot_dot(i,j,k,ispecPML) = chi4_dot_dot(i,j,k,ispecPML) * mass
+
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+end subroutine PML_acoustic_mass_update
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_acoustic_time_march(NSPEC_AB,NGLOB_AB,ibool,&
+ potential_acoustic,potential_dot_acoustic,&
+ deltat,deltatsqover2,deltatover2,&
+ num_PML_ispec,PML_ispec,PML_damping_d,&
+ chi1,chi2,chi2_t,chi3,chi4,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot,&
+ iglob_is_PML_interface,PML_mask_ibool,&
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh,&
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh,NPROC,&
+ ispec_is_acoustic)
+
+
+! time marching scheme - updates with corrector terms
+!
+! note that the value of d changes according to the distance to the boundary,
+! thus instead of updating the whole arrays chi1(:) this scheme updates every given,single value chi1,...
+
+ use constants,only: NGLLX,NGLLY,NGLLZ,CUSTOM_REAL
+ implicit none
+
+ integer :: NSPEC_AB,NGLOB_AB
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+ ! potentials
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_acoustic
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_acoustic
+
+ real(kind=CUSTOM_REAL):: deltat,deltatsqover2,deltatover2
+
+ ! split-potentials
+ integer :: num_PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1,chi2,chi2_t,chi3,chi4
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ PML_damping_d
+
+ integer,dimension(num_PML_ispec):: PML_ispec
+ integer,dimension(NGLOB_AB) :: iglob_is_PML_interface
+ logical,dimension(NGLOB_AB) :: PML_mask_ibool
+
+ ! MPI communication
+ integer :: NPROC
+ integer :: num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh,my_neighbours_ext_mesh
+ integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
+
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+ !local parameters
+ real(kind=CUSTOM_REAL),dimension(:),allocatable:: contributions,contributions_dot
+ real(kind=CUSTOM_REAL):: d
+ integer :: ispec,ispecPML,i,j,k,iglob
+
+ ! updates local points in PML
+ allocate(contributions_dot(NGLOB_AB))
+ allocate(contributions(NGLOB_AB))
+ contributions_dot(:) = 0._CUSTOM_REAL
+ contributions(:) = 0._CUSTOM_REAL
+
+ do ispecPML = 1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! acoustic potentials
+ if( ispec_is_acoustic(ispec) ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ ! updates split-potential arrays
+ d = PML_damping_d(i,j,k,ispecPML)
+
+ call PML_acoustic_time_march_s(chi1(i,j,k,ispecPML),chi2(i,j,k,ispecPML),&
+ chi2_t(i,j,k,ispecPML),chi3(i,j,k,ispecPML),chi4(i,j,k,ispecPML), &
+ chi1_dot(i,j,k,ispecPML),chi2_t_dot(i,j,k,ispecPML),&
+ chi3_dot(i,j,k,ispecPML),chi4_dot(i,j,k,ispecPML), &
+ chi1_dot_dot(i,j,k,ispecPML),chi2_t_dot_dot(i,j,k,ispecPML),&
+ chi3_dot_dot(i,j,k,ispecPML),chi4_dot_dot(i,j,k,ispecPML), &
+ deltat,deltatsqover2,deltatover2,d)
+
+ ! adds new contributions
+ iglob = ibool(i,j,k,ispec)
+ if( iglob_is_PML_interface(iglob) > 0 ) then
+ ! on interface points, the time marched global potential from the regular domains applies
+ contributions(iglob) = 0._CUSTOM_REAL
+ contributions_dot(iglob) = 0._CUSTOM_REAL
+ else
+ contributions(iglob) = contributions(iglob) &
+ + chi1(i,j,k,ispecPML) &
+ + chi2(i,j,k,ispecPML) &
+ + chi3(i,j,k,ispecPML) &
+ + chi4(i,j,k,ispecPML)
+
+ contributions_dot(iglob) = contributions_dot(iglob) &
+ + chi1_dot(i,j,k,ispecPML) - d*chi1(i,j,k,ispecPML) &
+ + chi2_t(i,j,k,ispecPML) - d*chi2(i,j,k,ispecPML) &
+ + chi3_dot(i,j,k,ispecPML) - d*chi3(i,j,k,ispecPML) &
+ + chi4_dot(i,j,k,ispecPML)
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+ ! assembles contributions from different MPI processes
+ call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,contributions, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh)
+ call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,contributions_dot, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh)
+
+ ! separates contributions from regular domain
+ PML_mask_ibool = .false.
+
+ !do ispec = 1,NSPEC_AB
+ do ispecPML = 1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! acoustic potentials
+ if( ispec_is_acoustic(ispec) ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ if( PML_mask_ibool(iglob) .eqv. .false. ) then
+ ! on interface points, leave contribution from regular domain
+
+ ! inside PML region, split potentials determine the global acoustic potential
+ if( iglob_is_PML_interface(iglob) == 0 ) then
+ potential_acoustic(iglob) = contributions(iglob)
+ potential_dot_acoustic(iglob) = contributions_dot(iglob)
+ endif
+
+ PML_mask_ibool(iglob) = .true.
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+end subroutine PML_acoustic_time_march
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_acoustic_time_march_s(chi1,chi2,chi2_t,chi3,chi4, &
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot, &
+ chi1_dot_dot,chi2_t_dot_dot, &
+ chi3_dot_dot,chi4_dot_dot, &
+ deltat,deltatsqover2,deltatover2,d)
+
+! time marching scheme
+!
+! note that the value of d changes according to the distance to the boundary,
+! thus instead of updating the whole arrays chi1(:) this scheme updates every given,single value chi1,...
+ use constants,only: CUSTOM_REAL
+ implicit none
+ real(kind=CUSTOM_REAL):: chi1,chi2,chi2_t,chi3,chi4
+ real(kind=CUSTOM_REAL):: chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
+ real(kind=CUSTOM_REAL):: chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
+ real(kind=CUSTOM_REAL):: deltat,deltatsqover2,deltatover2,d
+ !local parameters
+ real(kind=CUSTOM_REAL):: fac1,fac2,fac3,fac4
+
+ ! pre-computes some factors
+ fac1 = 1._CUSTOM_REAL/(1.0_CUSTOM_REAL + deltatover2*d)
+ fac2 = 1._CUSTOM_REAL/(d + 1.0_CUSTOM_REAL/deltatover2)
+ fac3 = 1._CUSTOM_REAL/(2.0_CUSTOM_REAL + deltat*d)
+ fac4 = deltatsqover2*d*d - deltat*d
+
+ ! first term: chi1(t+deltat) update
+ chi1 = chi1 + deltat*chi1_dot + deltatsqover2*chi1_dot_dot &
+ + fac4*chi1 - deltat*deltat*d*chi1_dot
+
+ ! chi1_dot predictor
+ chi1_dot = fac1 * chi1_dot - d*fac2 * chi1_dot + fac2 * chi1_dot_dot
+ chi1_dot_dot = 0._CUSTOM_REAL
+
+ ! second term: chi2
+ ! note that it uses chi2_t at time ( t )
+ chi2 = 2.0*fac3 * chi2 - deltat*d*fac3 * chi2 + deltat*fac3 * chi2_t
+
+ ! temporary chi2_t(t+deltat) update
+ chi2_t = chi2_t + deltat*chi2_t_dot + deltatsqover2*chi2_t_dot_dot &
+ + fac4*chi2_t - deltat*deltat*d*chi2_t_dot
+
+ ! chi2 - corrector using updated chi2_t(t+deltat)
+ chi2 = chi2 + deltat*fac3 * chi2_t
+
+ ! temporary chi2_t_dot - predictor
+ chi2_t_dot = fac1 * chi2_t_dot - d*fac2 * chi2_t_dot + fac2 * chi2_t_dot_dot
+ chi2_t_dot_dot = 0._CUSTOM_REAL
+
+ ! third term: chi3 (t+deltat) update
+ chi3 = chi3 + deltat*chi3_dot + deltatsqover2*chi3_dot_dot &
+ + fac4*chi3 - deltatsqover2*d*chi3_dot
+ chi3_dot = chi3_dot + deltatover2*chi3_dot_dot
+ chi3_dot_dot = 0._CUSTOM_REAL
+
+ ! fourth term: chi4 (t+deltat) update
+ chi4 = chi4 + deltat*chi4_dot + deltatsqover2*chi4_dot_dot
+ chi4_dot = chi4_dot + deltatover2*chi4_dot_dot
+ chi4_dot_dot = 0._CUSTOM_REAL
+
+end subroutine PML_acoustic_time_march_s
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_acoustic_time_corrector(NSPEC_AB,ispec_is_acoustic,deltatover2,&
+ num_PML_ispec,PML_ispec,PML_damping_d,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot)
+
+! time marching scheme - updates with corrector terms
+!
+! note that the value of d changes according to the distance to the boundary,
+! thus instead of updating the whole arrays chi1(:) this scheme updates every given,single value chi1,...
+
+ use constants,only: NGLLX,NGLLY,NGLLZ,CUSTOM_REAL
+ implicit none
+
+ ! split-potentials
+ integer :: num_PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: PML_damping_d
+
+ integer,dimension(num_PML_ispec):: PML_ispec
+
+ real(kind=CUSTOM_REAL):: deltatover2
+
+ integer :: NSPEC_AB
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+ !local parameters
+ real(kind=CUSTOM_REAL):: d
+ integer :: ispec,ispecPML,i,j,k
+
+ ! updates "velocity" potentials in PML with corrector terms
+ do ispecPML = 1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! acoustic potentials
+ if( ispec_is_acoustic(ispec) ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ ! time marches chi_dot,.. potentials
+ d = PML_damping_d(i,j,k,ispecPML)
+
+ call PML_acoustic_time_corrector_s(chi1_dot(i,j,k,ispecPML),chi2_t_dot(i,j,k,ispecPML), &
+ chi3_dot(i,j,k,ispecPML),chi4_dot(i,j,k,ispecPML), &
+ chi1_dot_dot(i,j,k,ispecPML),chi2_t_dot_dot(i,j,k,ispecPML), &
+ chi3_dot_dot(i,j,k,ispecPML),chi4_dot_dot(i,j,k,ispecPML), &
+ deltatover2,d)
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+
+end subroutine PML_acoustic_time_corrector
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_acoustic_time_corrector_s(chi1_dot,chi2_t_dot,chi3_dot,chi4_dot, &
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot, &
+ deltatover2,d)
+
+! time marching scheme - updates with corrector terms
+!
+! note that the value of d changes according to the distance to the boundary,
+! thus instead of updating the whole arrays chi1(:) this scheme updates every given,single value chi1,...
+ use constants,only: CUSTOM_REAL
+ implicit none
+ real(kind=CUSTOM_REAL):: chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
+ real(kind=CUSTOM_REAL):: chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
+ real(kind=CUSTOM_REAL):: deltatover2,d
+ real(kind=CUSTOM_REAL):: fac1
+
+ fac1 = 1.0_CUSTOM_REAL/(d + 1.0_CUSTOM_REAL/deltatover2)
+
+ ! first term:
+ chi1_dot = chi1_dot + fac1*chi1_dot_dot
+
+ ! second term:
+ chi2_t_dot = chi2_t_dot + fac1*chi2_t_dot_dot
+
+ ! third term:
+ chi3_dot = chi3_dot + deltatover2*chi3_dot_dot
+
+ ! fourth term:
+ chi4_dot = chi4_dot + deltatover2*chi4_dot_dot
+
+end subroutine PML_acoustic_time_corrector_s
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine PML_acoustic_enforce_free_srfc(NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic, &
+ ibool,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces, &
+ ispec_is_acoustic, &
+ num_PML_ispec,PML_ispec,&
+ chi1,chi2,chi2_t,chi3,chi4,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi2_t_dot_dot,&
+ chi3_dot_dot,chi4_dot_dot)
+
+ use constants,only: NGLLX,NGLLY,NGLLZ,NGLLSQUARE,CUSTOM_REAL
+ implicit none
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+ ! split-potentials
+ integer :: num_PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1,chi2,chi2_t,chi3,chi4
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot
+ integer,dimension(num_PML_ispec):: PML_ispec
+
+ ! acoustic potentials
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: &
+ potential_acoustic,potential_dot_acoustic,potential_dot_dot_acoustic
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+ ! free surface
+ integer :: num_free_surface_faces
+ integer :: free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces)
+ integer :: free_surface_ispec(num_free_surface_faces)
+
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+! local parameters
+ integer :: iface,igll,i,j,k,ispec,iglob,ispecPML
+
+ ! enforce potentials to be zero at surface
+ do iface = 1, num_free_surface_faces
+
+ ispec = free_surface_ispec(iface)
+
+ if( ispec_is_acoustic(ispec) ) then
+
+ do ispecPML=1,num_PML_ispec
+ if( PML_ispec(ispecPML) == ispec ) then
+
+ do igll = 1, NGLLSQUARE
+ i = free_surface_ijk(1,igll,iface)
+ j = free_surface_ijk(2,igll,iface)
+ k = free_surface_ijk(3,igll,iface)
+ iglob = ibool(i,j,k,ispec)
+
+ ! sets potentials to zero
+ potential_acoustic(iglob) = 0._CUSTOM_REAL
+ potential_dot_acoustic(iglob) = 0._CUSTOM_REAL
+ potential_dot_dot_acoustic(iglob) = 0._CUSTOM_REAL
+
+ ! sets PML potentials to zero
+ chi1(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi1_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi1_dot_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
+
+ chi2(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi2_t(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi2_t_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi2_t_dot_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
+
+ chi3(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi3_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi3_dot_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
+
+ chi4(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi4_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ chi4_dot_dot(i,j,k,ispecPML) = 0._CUSTOM_REAL
+ enddo
+ endif
+ enddo
+ endif
+
+ enddo
+
+end subroutine PML_acoustic_enforce_free_srfc
+
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+subroutine PML_acoustic_update_potentials(NGLOB_AB,NSPEC_AB, &
+ ibool,ispec_is_acoustic, &
+ potential_dot_acoustic,potential_dot_dot_acoustic,&
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh,NPROC,&
+ num_PML_ispec,PML_ispec,iglob_is_PML_interface,&
+ PML_mask_ibool,PML_damping_d,&
+ chi1,chi2,chi2_t,chi3,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot)
+
+! updates potential_dot_acoustic and potential_dot_dot_acoustic inside PML region
+
+ use constants,only: NGLLX,NGLLY,NGLLZ,CUSTOM_REAL
+ implicit none
+
+ integer :: NGLOB_AB,NSPEC_AB
+
+ ! split-potentials
+ integer :: num_PML_ispec
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1,chi2,chi2_t,chi3
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ chi1_dot_dot,chi3_dot_dot,chi4_dot_dot
+ real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,num_PML_ispec):: &
+ PML_damping_d
+ integer,dimension(num_PML_ispec):: PML_ispec
+ integer,dimension(NGLOB_AB):: iglob_is_PML_interface
+ logical,dimension(NGLOB_AB):: PML_mask_ibool
+
+
+ ! potentials
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_acoustic
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+ ! MPI communication
+ integer :: NPROC
+ integer :: num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh,my_neighbours_ext_mesh
+ integer, dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
+
+ !local parameters
+ real(kind=CUSTOM_REAL),dimension(:),allocatable :: contributions_dot_dot,contributions_dot
+ real(kind=CUSTOM_REAL):: d
+ integer :: ispec,ispecPML,i,j,k,iglob
+
+ allocate(contributions_dot_dot(NGLOB_AB),contributions_dot(NGLOB_AB))
+ contributions_dot_dot = 0._CUSTOM_REAL
+ contributions_dot = 0._CUSTOM_REAL
+
+ ! updates the potential_dot & potential_dot_dot_acoustic array inside the PML
+ do ispecPML = 1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! acoustic potentials
+ if( ispec_is_acoustic(ispec) ) then
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! for points inside PML region
+ if( iglob_is_PML_interface(iglob) == 0 ) then
+
+ ! damping coefficient
+ d = PML_damping_d(i,j,k,ispecPML)
+
+ ! inside PML region: at this stage, this is only needed for seismogram/plotting output
+ ! afterwards potential_dot_dot, resp. chi1_dot_dot,.. get reset to zero
+
+ ! potential_dot: note that we defined
+ ! chi1_dot = (\partial_t + d) chi1
+ ! chi2_t = (\partial_t + d) chi2
+ ! chi3_dot = (\partial_t + d) chi3
+ ! chi4_dot = \partial_t chi4
+ ! where \partial_t is the time derivative, thus \partial_t (chi1+chi2+chi3+chi4) equals
+ contributions_dot(iglob) = contributions_dot(iglob) &
+ + chi1_dot(i,j,k,ispecPML) - d*chi1(i,j,k,ispecPML) &
+ + chi2_t(i,j,k,ispecPML) - d*chi2(i,j,k,ispecPML) &
+ + chi3_dot(i,j,k,ispecPML) - d*chi3(i,j,k,ispecPML) &
+ + chi4_dot(i,j,k,ispecPML)
+
+ ! potential_dot_dot: note that we defined
+ ! chi1_dot_dot = (\partial_t + d)**2 chi1
+ ! chi2_t_dot = (\partial_t + d)**2 chi2
+ ! chi3_dot = \partial_t (\partial_t + d) chi3
+ ! chi4_dot = \partial_t**2 chi4
+ ! where \partial_t is the time derivative, thus \partial_t**2 (chi1+chi2+chi3+chi4) equals
+ contributions_dot_dot(iglob) = contributions_dot_dot(iglob) &
+ + chi1_dot_dot(i,j,k,ispecPML) - 2.0*d*chi1_dot(i,j,k,ispecPML) + d*d*chi1(i,j,k,ispecPML) &
+ + chi2_t_dot(i,j,k,ispecPML) - 2.0*d*chi2_t(i,j,k,ispecPML) + d*d*chi2(i,j,k,ispecPML) &
+ + chi3_dot_dot(i,j,k,ispecPML) - d*chi3_dot(i,j,k,ispecPML) + d*d*chi3(i,j,k,ispecPML) &
+ + chi4_dot_dot(i,j,k,ispecPML)
+
+ endif
+
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+ ! assembles contributions from different MPI processes
+ call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,contributions_dot, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh)
+ call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,contributions_dot_dot, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh)
+
+ ! updates the potential_dot & potential_dot_dot_acoustic array inside the PML
+ PML_mask_ibool = .false.
+ do ispecPML = 1,num_PML_ispec
+
+ ispec = PML_ispec(ispecPML)
+
+ ! acoustic potentials
+ if( ispec_is_acoustic(ispec) ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ if( PML_mask_ibool(iglob) .eqv. .false. ) then
+ ! for points inside PML region
+ if( iglob_is_PML_interface(iglob) == 0 ) then
+ potential_dot_acoustic(iglob) = contributions_dot(iglob)
+ potential_dot_dot_acoustic(iglob) = contributions_dot(iglob)
+ endif
+ PML_mask_ibool(iglob) = .true.
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+end subroutine PML_acoustic_update_potentials
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_acoustic_pot.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_acoustic_pot.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_acoustic_pot.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,203 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! for acoustic solver
+
+ subroutine compute_forces_acoustic_pot( iphase, NSPEC_AB,NGLOB_AB, &
+ potential_acoustic,potential_dot_dot_acoustic, &
+ 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, &
+ rhostore,jacobian,ibool, &
+ num_phase_ispec_acoustic,nspec_inner_acoustic,nspec_outer_acoustic,&
+ phase_ispec_inner_acoustic )
+
+! computes forces for acoustic elements
+!
+! note that pressure is defined as:
+! p = - Chi_dot_dot
+!
+ use constants,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,TINYVAL_SNGL
+ use PML_par,only:PML,ispec_is_PML_inum
+ implicit none
+ !include "constants.h"
+ integer :: NSPEC_AB,NGLOB_AB
+
+! acoustic potentials
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: &
+ potential_acoustic,potential_dot_dot_acoustic
+
+! 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) :: &
+ rhostore,jacobian
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+
+ 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
+
+! logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+ integer :: iphase
+ integer :: num_phase_ispec_acoustic,nspec_inner_acoustic,nspec_outer_acoustic
+ integer, dimension(num_phase_ispec_acoustic,2) :: phase_ispec_inner_acoustic
+
+! local variables
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: chi_elem
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: temp1,temp2,temp3
+ real(kind=CUSTOM_REAL) temp1l,temp2l,temp3l
+
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ real(kind=CUSTOM_REAL) dpotentialdxl,dpotentialdyl,dpotentialdzl
+ real(kind=CUSTOM_REAL) rho_invl
+
+ integer :: ispec,iglob,i,j,k,l,ispec_p,num_elements
+
+ if( iphase == 1 ) then
+ num_elements = nspec_outer_acoustic
+ else
+ num_elements = nspec_inner_acoustic
+ endif
+
+! loop over spectral elements
+ do ispec_p = 1,num_elements
+
+ !if ( (ispec_is_inner(ispec) .eqv. phase_is_inner) ) then
+
+ ispec = phase_ispec_inner_acoustic(ispec_p,iphase)
+
+ ! only elements outside PML, inside "regular" domain
+ if( PML ) then
+ if( ispec_is_PML_inum(ispec) > 0 ) then
+ cycle
+ endif
+ endif
+
+! if( ispec_is_acoustic(ispec) ) then
+
+ ! gets values for element
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ chi_elem(i,j,k) = potential_acoustic(ibool(i,j,k,ispec))
+ enddo
+ enddo
+ enddo
+ ! would check if anything to do, but might lower accuracy of computation
+ !if( maxval( abs( chi_elem ) ) < TINYVAL_SNGL ) cycle
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ ! density (reciproc)
+ rho_invl = 1.0_CUSTOM_REAL / rhostore(i,j,k,ispec)
+
+ ! derivative along x, y, z
+ ! first double loop over GLL points to compute and store gradients
+ ! we can merge the loops because NGLLX == NGLLY == NGLLZ
+ temp1l = 0._CUSTOM_REAL
+ temp2l = 0._CUSTOM_REAL
+ temp3l = 0._CUSTOM_REAL
+ do l = 1,NGLLX
+ temp1l = temp1l + chi_elem(l,j,k)*hprime_xx(i,l)
+ temp2l = temp2l + chi_elem(i,l,k)*hprime_yy(j,l)
+ temp3l = temp3l + chi_elem(i,j,l)*hprime_zz(k,l)
+ enddo
+
+ ! get derivatives of potential 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)
+
+ ! derivatives of potential
+ dpotentialdxl = xixl*temp1l + etaxl*temp2l + gammaxl*temp3l
+ dpotentialdyl = xiyl*temp1l + etayl*temp2l + gammayl*temp3l
+ dpotentialdzl = xizl*temp1l + etazl*temp2l + gammazl*temp3l
+
+ ! for acoustic medium
+ ! also add GLL integration weights
+ temp1(i,j,k) = rho_invl * wgllwgll_yz(j,k) * jacobianl* &
+ (xixl*dpotentialdxl + xiyl*dpotentialdyl + xizl*dpotentialdzl)
+ temp2(i,j,k) = rho_invl * wgllwgll_xz(i,k) * jacobianl* &
+ (etaxl*dpotentialdxl + etayl*dpotentialdyl + etazl*dpotentialdzl)
+ temp3(i,j,k) = rho_invl * wgllwgll_xy(i,j) * jacobianl* &
+ (gammaxl*dpotentialdxl + gammayl*dpotentialdyl + gammazl*dpotentialdzl)
+ enddo
+ enddo
+ enddo
+
+ ! second double-loop over GLL to compute all the terms
+ do k = 1,NGLLZ
+ do j = 1,NGLLZ
+ do i = 1,NGLLX
+
+ ! along x,y,z direction
+ ! and assemble the contributions
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ
+ temp1l = 0._CUSTOM_REAL
+ temp2l = 0._CUSTOM_REAL
+ temp3l = 0._CUSTOM_REAL
+ do l=1,NGLLX
+ temp1l = temp1l + temp1(l,j,k) * hprimewgll_xx(l,i)
+ temp2l = temp2l + temp2(i,l,k) * hprimewgll_yy(l,j)
+ temp3l = temp3l + temp3(i,j,l) * hprimewgll_zz(l,k)
+ enddo
+
+ ! sum contributions from each element to the global values
+ iglob = ibool(i,j,k,ispec)
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - ( temp1l + temp2l + temp3l )
+
+ enddo
+ enddo
+ enddo
+
+! endif ! end of test if acoustic element
+! endif ! ispec_is_inner
+
+ enddo ! end of loop over all spectral elements
+
+ end subroutine compute_forces_acoustic_pot
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_elastic.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_elastic.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_elastic.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,366 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! elastic solver
+! Percy , Adding damping , 07/02/2011 (Caltech.)
+
+subroutine compute_forces_elastic()
+
+ use specfem_par
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ use specfem_par_poroelastic
+ use fault_solver, only : bc_dynflt_set3d_all,SIMULATION_TYPE_DYN
+ use fault_solver_kinematic, only : bc_kinflt_set_all,SIMULATION_TYPE_KIN
+
+ implicit none
+
+ integer:: iphase
+ logical:: phase_is_inner
+
+! distinguishes two runs: for points on MPI interfaces, and points within the partitions
+ do iphase=1,2
+
+ !first for points on MPI interfaces
+ if( iphase == 1 ) then
+ phase_is_inner = .false.
+ else
+ phase_is_inner = .true.
+ endif
+
+! elastic term
+ if(USE_DEVILLE_PRODUCTS) then
+ call compute_forces_elastic_Dev(iphase, NSPEC_AB,NGLOB_AB,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, &
+ ATTENUATION,USE_OLSEN_ATTENUATION, &
+ 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, &
+ rho_vs,ANISOTROPY,NSPEC_ANISO, &
+ c11store,c12store,c13store,c14store,c15store,c16store,&
+ c22store,c23store,c24store,c25store,c26store,c33store,&
+ c34store,c35store,c36store,c44store,c45store,c46store,&
+ c55store,c56store,c66store, &
+ SIMULATION_TYPE,NGLOB_ADJOINT,NSPEC_ADJOINT, &
+ b_displ,b_accel,kappa_kl,mu_kl,deltat, &
+ NSPEC_BOUN,NSPEC2D_MOHO,NSPEC_ATT_AND_KERNEL,&
+ is_moho_top,is_moho_bot, &
+ dsdx_top,dsdx_bot,b_dsdx_top,b_dsdx_bot, &
+ ispec2D_moho_top,ispec2D_moho_bot, &
+ b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz, &
+ b_epsilondev_xx,b_epsilondev_yy,b_epsilondev_xy, &
+ b_epsilondev_xz,b_epsilondev_yz, &
+ b_alphaval,b_betaval,b_gammaval,&
+ num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic,&
+ phase_ispec_inner_elastic)
+ else
+! FAULT
+! Percy , adding "veloc",Kelvin_voigt_eta input for Damping in compute_forces_elastic_noDev.
+!
+ call compute_forces_elastic_noDev( iphase, NSPEC_AB,NGLOB_AB,displ,veloc,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, &
+ kappastore,mustore,jacobian,ibool, &
+ ATTENUATION,USE_OLSEN_ATTENUATION,&
+ 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,&
+ rho_vs,ANISOTROPY,NSPEC_ANISO, &
+ c11store,c12store,c13store,c14store,c15store,c16store,&
+ c22store,c23store,c24store,c25store,c26store,c33store,&
+ c34store,c35store,c36store,c44store,c45store,c46store,&
+ c55store,c56store,c66store, &
+ SIMULATION_TYPE,NGLOB_ADJOINT,NSPEC_ADJOINT, &
+ b_displ,b_accel,kappa_kl,mu_kl,deltat, &
+ NSPEC_BOUN,NSPEC2D_MOHO,NSPEC_ATT_AND_KERNEL,&
+ is_moho_top,is_moho_bot, &
+ dsdx_top,dsdx_bot,b_dsdx_top,b_dsdx_bot, &
+ ispec2D_moho_top,ispec2D_moho_bot, &
+ b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz, &
+ b_epsilondev_xx,b_epsilondev_yy,b_epsilondev_xy, &
+ b_epsilondev_xz,b_epsilondev_yz, &
+ b_alphaval,b_betaval,b_gammaval,&
+ num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic,&
+ phase_ispec_inner_elastic)
+ endif
+
+! adds elastic absorbing boundary term to acceleration (Stacey conditions)
+ if(ABSORBING_CONDITIONS) &
+ call compute_stacey_elastic(NSPEC_AB,NGLOB_AB,accel, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ abs_boundary_normal,abs_boundary_jacobian2Dw, &
+ abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces, &
+ veloc,rho_vp,rho_vs, &
+ ispec_is_elastic,SIMULATION_TYPE,myrank,SAVE_FORWARD, &
+ NSTEP,it,NGLOB_ADJOINT,b_accel, &
+ b_num_abs_boundary_faces,b_reclen_field,b_absorb_field )
+
+! acoustic coupling
+ if( ACOUSTIC_SIMULATION ) then
+ call compute_coupling_elastic_ac(NSPEC_AB,NGLOB_AB, &
+ ibool,accel,potential_dot_dot_acoustic, &
+ num_coupling_ac_el_faces, &
+ coupling_ac_el_ispec,coupling_ac_el_ijk, &
+ coupling_ac_el_normal, &
+ coupling_ac_el_jacobian2Dw, &
+ ispec_is_inner,phase_is_inner)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) &
+ call compute_coupling_elastic_ac(NSPEC_ADJOINT,NGLOB_ADJOINT, &
+ ibool,b_accel,b_potential_dot_dot_acoustic, &
+ num_coupling_ac_el_faces, &
+ coupling_ac_el_ispec,coupling_ac_el_ijk, &
+ coupling_ac_el_normal, &
+ coupling_ac_el_jacobian2Dw, &
+ ispec_is_inner,phase_is_inner)
+ endif
+
+
+! poroelastic coupling
+! not implemented yet
+! if( POROELASTIC_SIMULATION ) &
+! call compute_coupling_elastic_poro()
+
+! adds source term (single-force/moment-tensor solution)
+ call compute_add_sources_elastic( 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,t0,sourcearrays, &
+ ispec_is_elastic,SIMULATION_TYPE,NSTEP,NGLOB_ADJOINT, &
+ nrec,islice_selected_rec,ispec_selected_rec, &
+ nadj_rec_local,adj_sourcearrays,b_accel )
+
+! assemble all the contributions between slices using MPI
+ if( phase_is_inner .eqv. .false. ) then
+ ! sends accel values to corresponding MPI interface neighbors
+ call assemble_MPI_vector_ext_mesh_s(NPROC,NGLOB_AB,accel, &
+ buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh, &
+ request_send_vector_ext_mesh,request_recv_vector_ext_mesh)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ call assemble_MPI_vector_ext_mesh_s(NPROC,NGLOB_ADJOINT,b_accel, &
+ b_buffer_send_vector_ext_mesh,b_buffer_recv_vector_ext_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh, &
+ b_request_send_vector_ext_mesh,b_request_recv_vector_ext_mesh)
+ endif !adjoint
+
+ else
+ ! waits for send/receive requests to be completed and assembles values
+ call assemble_MPI_vector_ext_mesh_w(NPROC,NGLOB_AB,accel, &
+ buffer_recv_vector_ext_mesh,num_interfaces_ext_mesh,&
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ request_send_vector_ext_mesh,request_recv_vector_ext_mesh)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ call assemble_MPI_vector_ext_mesh_w(NPROC,NGLOB_ADJOINT,b_accel, &
+ b_buffer_recv_vector_ext_mesh,num_interfaces_ext_mesh,&
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ b_request_send_vector_ext_mesh,b_request_recv_vector_ext_mesh)
+ endif !adjoint
+
+ endif
+
+ !! DK DK May 2009: removed this because now each slice of a CUBIT + SCOTCH mesh
+ !! DK DK May 2009: has a different number of spectral elements and therefore
+ !! DK DK May 2009: only the general non-blocking MPI routines assemble_MPI_vector_ext_mesh_s
+ !! DK DK May 2009: and assemble_MPI_vector_ext_mesh_w above can be used.
+ !! DK DK May 2009: For adjoint runs below (SIMULATION_TYPE == 3) they should be used as well.
+
+ enddo
+
+!Percy , Fault boundary term B*tau is added to the assembled forces
+! which at this point are stored in the array 'accel'
+ if (SIMULATION_TYPE_DYN == 1 ) call bc_dynflt_set3d_all(accel,veloc,displ)
+
+ if (SIMULATION_TYPE_KIN == 2 ) call bc_kinflt_set_all(accel,veloc,displ)
+
+! multiplies with inverse of mass matrix (note: rmass has been inverted already)
+ accel(1,:) = accel(1,:)*rmass(:)
+ accel(2,:) = accel(2,:)*rmass(:)
+ accel(3,:) = accel(3,:)*rmass(:)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_accel(1,:) = b_accel(1,:)*rmass(:)
+ b_accel(2,:) = b_accel(2,:)*rmass(:)
+ b_accel(3,:) = b_accel(3,:)*rmass(:)
+ endif !adjoint
+
+
+! updates acceleration with ocean load term
+ if(OCEANS) then
+ call elastic_ocean_load(NSPEC_AB,NGLOB_AB, &
+ ibool,rmass,rmass_ocean_load,accel, &
+ free_surface_normal,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces,SIMULATION_TYPE, &
+ NGLOB_ADJOINT,b_accel)
+ endif
+
+! updates velocities
+! Newark finite-difference time scheme with elastic domains:
+! (see e.g. Hughes, 1987; Chaljub et al., 2003)
+!
+! u(t+delta_t) = u(t) + delta_t v(t) + 1/2 delta_t**2 a(t)
+! v(t+delta_t) = v(t) + 1/2 delta_t a(t) + 1/2 delta_t a(t+delta_t)
+! a(t+delta_t) = 1/M_elastic ( -K_elastic u(t+delta) + B_elastic chi_dot_dot(t+delta_t) + f( t+delta_t) )
+!
+! where
+! u, v, a are displacement,velocity & acceleration
+! M is mass matrix, K stiffness matrix and B boundary term for acoustic/elastic domains
+! f denotes a source term (acoustic/elastic)
+! chi_dot_dot is acoustic (fluid) potential ( dotted twice with respect to time)
+!
+! corrector:
+! updates the velocity term which requires a(t+delta)
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) b_veloc(:,:) = b_veloc(:,:) + b_deltatover2*b_accel(:,:)
+
+
+end subroutine compute_forces_elastic
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine elastic_ocean_load(NSPEC_AB,NGLOB_AB, &
+ ibool,rmass,rmass_ocean_load,accel, &
+ free_surface_normal,free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces,SIMULATION_TYPE, &
+ NGLOB_ADJOINT,b_accel)
+
+! updates acceleration with ocean load term:
+! approximates ocean-bottom continuity of pressure & displacement for longer period waves (> ~20s ),
+! assuming incompressible fluid column above bathymetry ocean bottom
+
+ implicit none
+
+ include 'constants.h'
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLOB_AB),intent(inout) :: accel
+ real(kind=CUSTOM_REAL),dimension(NGLOB_AB),intent(in) :: rmass,rmass_ocean_load
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB),intent(in) :: ibool
+
+ ! free surface
+ integer :: num_free_surface_faces
+ real(kind=CUSTOM_REAL) :: free_surface_normal(NDIM,NGLLSQUARE,num_free_surface_faces)
+ integer :: free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces)
+ integer :: free_surface_ispec(num_free_surface_faces)
+
+ ! adjoint simulations
+ integer :: SIMULATION_TYPE,NGLOB_ADJOINT
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLOB_ADJOINT):: b_accel
+
+! local parameters
+ real(kind=CUSTOM_REAL) :: nx,ny,nz
+ real(kind=CUSTOM_REAL) :: additional_term,force_normal_comp
+ integer :: i,j,k,ispec,iglob
+ integer :: igll,iface
+ logical,dimension(NGLOB_AB) :: updated_dof_ocean_load
+ ! adjoint locals
+ real(kind=CUSTOM_REAL) :: b_additional_term,b_force_normal_comp
+
+ ! initialize the updates
+ updated_dof_ocean_load(:) = .false.
+
+ ! for surface elements exactly at the top of the model (ocean bottom)
+ do iface = 1,num_free_surface_faces
+
+ ispec = free_surface_ispec(iface)
+ do igll = 1, NGLLSQUARE
+ i = free_surface_ijk(1,igll,iface)
+ j = free_surface_ijk(2,igll,iface)
+ k = free_surface_ijk(3,igll,iface)
+
+ ! get global point number
+ iglob = ibool(i,j,k,ispec)
+
+ ! only update once
+ if(.not. updated_dof_ocean_load(iglob)) then
+
+ ! get normal
+ nx = free_surface_normal(1,igll,iface)
+ ny = free_surface_normal(2,igll,iface)
+ nz = free_surface_normal(3,igll,iface)
+
+ ! make updated component of right-hand side
+ ! we divide by rmass() which is 1 / M
+ ! we use the total force which includes the Coriolis term above
+ force_normal_comp = ( accel(1,iglob)*nx + &
+ accel(2,iglob)*ny + &
+ accel(3,iglob)*nz ) / rmass(iglob)
+
+ additional_term = (rmass_ocean_load(iglob) - rmass(iglob)) * force_normal_comp
+
+ accel(1,iglob) = accel(1,iglob) + additional_term * nx
+ accel(2,iglob) = accel(2,iglob) + additional_term * ny
+ accel(3,iglob) = accel(3,iglob) + additional_term * nz
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_force_normal_comp = ( b_accel(1,iglob)*nx + &
+ b_accel(2,iglob)*ny + &
+ b_accel(3,iglob)*nz) / rmass(iglob)
+ b_additional_term = (rmass_ocean_load(iglob) - rmass(iglob)) * b_force_normal_comp
+
+ b_accel(1,iglob) = b_accel(1,iglob) + b_additional_term * nx
+ b_accel(2,iglob) = b_accel(2,iglob) + b_additional_term * ny
+ b_accel(3,iglob) = b_accel(3,iglob) + b_additional_term * nz
+ endif !adjoint
+
+ ! done with this point
+ updated_dof_ocean_load(iglob) = .true.
+
+ endif
+
+ enddo ! igll
+ enddo ! iface
+
+end subroutine elastic_ocean_load
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_elastic_Dev.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_elastic_Dev.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_elastic_Dev.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,1134 @@
+!=====================================================================
+!
+! 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 compute_forces_elastic_Dev( iphase ,NSPEC_AB,NGLOB_AB, &
+ 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, &
+ ATTENUATION,USE_OLSEN_ATTENUATION, &
+ 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, &
+ rho_vs, &
+ ANISOTROPY,NSPEC_ANISO, &
+ c11store,c12store,c13store,c14store,c15store,c16store,&
+ c22store,c23store,c24store,c25store,c26store,c33store,&
+ c34store,c35store,c36store,c44store,c45store,c46store,&
+ c55store,c56store,c66store, &
+ SIMULATION_TYPE,NGLOB_ADJOINT,NSPEC_ADJOINT, &
+ b_displ,b_accel,kappa_kl,mu_kl,deltat, &
+ NSPEC_BOUN,NSPEC2D_MOHO,NSPEC_ATT_AND_KERNEL, &
+ is_moho_top,is_moho_bot, &
+ dsdx_top,dsdx_bot,b_dsdx_top,b_dsdx_bot, &
+ ispec2D_moho_top,ispec2D_moho_bot, &
+ b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz, &
+ b_epsilondev_xx,b_epsilondev_yy,b_epsilondev_xy, &
+ b_epsilondev_xz,b_epsilondev_yz, &
+ b_alphaval,b_betaval,b_gammaval, &
+ num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic,&
+ phase_ispec_inner_elastic)
+
+
+! computes elastic tensor term
+
+ use constants,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,NDIM, &
+ NUM_REGIONS_ATTENUATION,N_SLS,SAVE_MOHO_MESH, &
+ ONE_THIRD,FOUR_THIRDS,m1,m2
+ implicit none
+
+ !include "constants.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,USE_OLSEN_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
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vs
+
+! anisotropy
+ logical :: ANISOTROPY
+ integer :: NSPEC_ANISO
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO) :: &
+ c11store,c12store,c13store,c14store,c15store,c16store, &
+ c22store,c23store,c24store,c25store,c26store,c33store, &
+ c34store,c35store,c36store,c44store,c45store,c46store, &
+ c55store,c56store,c66store
+
+ !logical,dimension(NSPEC_AB) :: ispec_is_elastic
+ integer :: iphase
+ integer :: num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic
+ integer, dimension(num_phase_ispec_elastic,2) :: phase_ispec_inner_elastic
+
+! adjoint simulations
+ integer :: SIMULATION_TYPE
+ integer :: NSPEC_BOUN,NSPEC2D_MOHO,NSPEC_ATT_AND_KERNEL
+ integer :: NGLOB_ADJOINT,NSPEC_ADJOINT
+
+ ! moho kernel
+ real(kind=CUSTOM_REAL),dimension(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO):: &
+ dsdx_top,dsdx_bot,b_dsdx_top,b_dsdx_bot
+ logical,dimension(NSPEC_BOUN) :: is_moho_top,is_moho_bot
+ integer :: ispec2D_moho_top, ispec2D_moho_bot
+
+ ! adjoint memory variables
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL,N_SLS) :: &
+ b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL) :: &
+ b_epsilondev_xx,b_epsilondev_yy,b_epsilondev_xy,b_epsilondev_xz,b_epsilondev_yz
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: b_alphaval,b_betaval,b_gammaval
+
+ ! adjoint wavefields
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_ADJOINT):: b_displ,b_accel
+ ! adjoint kernels
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT) :: &
+ mu_kl, kappa_kl
+ real(kind=CUSTOM_REAL) :: deltat
+
+!adjoint
+
+! 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=CUSTOM_REAL), dimension(NGLLX,m2) :: B1_m1_m2_5points,B2_m1_m2_5points,B3_m1_m2_5points
+ real(kind=CUSTOM_REAL), dimension(m1,m2) :: C1_m1_m2_5points,C2_m1_m2_5points,C3_m1_m2_5points
+ real(kind=CUSTOM_REAL), dimension(m1,m2) :: E1_m1_m2_5points,E2_m1_m2_5points,E3_m1_m2_5points
+
+ equivalence(dummyx_loc,B1_m1_m2_5points)
+ equivalence(dummyy_loc,B2_m1_m2_5points)
+ equivalence(dummyz_loc,B3_m1_m2_5points)
+ equivalence(tempx1,C1_m1_m2_5points)
+ equivalence(tempy1,C2_m1_m2_5points)
+ equivalence(tempz1,C3_m1_m2_5points)
+ equivalence(newtempx1,E1_m1_m2_5points)
+ equivalence(newtempy1,E2_m1_m2_5points)
+ equivalence(newtempz1,E3_m1_m2_5points)
+
+ real(kind=CUSTOM_REAL), dimension(m2,NGLLX) :: &
+ A1_mxm_m2_m1_5points,A2_mxm_m2_m1_5points,A3_mxm_m2_m1_5points
+ real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
+ C1_mxm_m2_m1_5points,C2_mxm_m2_m1_5points,C3_mxm_m2_m1_5points
+ real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
+ E1_mxm_m2_m1_5points,E2_mxm_m2_m1_5points,E3_mxm_m2_m1_5points
+
+ equivalence(dummyx_loc,A1_mxm_m2_m1_5points)
+ equivalence(dummyy_loc,A2_mxm_m2_m1_5points)
+ equivalence(dummyz_loc,A3_mxm_m2_m1_5points)
+ equivalence(tempx3,C1_mxm_m2_m1_5points)
+ equivalence(tempy3,C2_mxm_m2_m1_5points)
+ equivalence(tempz3,C3_mxm_m2_m1_5points)
+ equivalence(newtempx3,E1_mxm_m2_m1_5points)
+ equivalence(newtempy3,E2_mxm_m2_m1_5points)
+ equivalence(newtempz3,E3_mxm_m2_m1_5points)
+
+ ! local attenuation parameters
+ 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) epsilon_trace_over_3
+ real(kind=CUSTOM_REAL) vs_val
+
+ 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
+
+ ! local anisotropy parameters
+ real(kind=CUSTOM_REAL) c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
+ c33,c34,c35,c36,c44,c45,c46,c55,c56,c66
+
+ integer i_SLS,iselected
+
+ integer ispec,iglob,ispec_p,num_elements
+ integer i,j,k
+
+ ! adjoint backward arrays
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: b_dummyx_loc,b_dummyy_loc,b_dummyz_loc, &
+ b_newtempx1,b_newtempx2,b_newtempx3,b_newtempy1,b_newtempy2,b_newtempy3,b_newtempz1,b_newtempz2,b_newtempz3
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ b_tempx1,b_tempx2,b_tempx3,b_tempy1,b_tempy2,b_tempy3,b_tempz1,b_tempz2,b_tempz3
+ ! backward arrays: manually inline the calls to the Deville et al. (2002) routines
+ real(kind=CUSTOM_REAL), dimension(NGLLX,m2) :: b_B1_m1_m2_5points,b_B2_m1_m2_5points,b_B3_m1_m2_5points
+ real(kind=CUSTOM_REAL), dimension(m1,m2) :: b_C1_m1_m2_5points,b_C2_m1_m2_5points,b_C3_m1_m2_5points
+ real(kind=CUSTOM_REAL), dimension(m1,m2) :: b_E1_m1_m2_5points,b_E2_m1_m2_5points,b_E3_m1_m2_5points
+ equivalence(b_dummyx_loc,b_B1_m1_m2_5points)
+ equivalence(b_dummyy_loc,b_B2_m1_m2_5points)
+ equivalence(b_dummyz_loc,b_B3_m1_m2_5points)
+ equivalence(b_tempx1,b_C1_m1_m2_5points)
+ equivalence(b_tempy1,b_C2_m1_m2_5points)
+ equivalence(b_tempz1,b_C3_m1_m2_5points)
+ equivalence(b_newtempx1,b_E1_m1_m2_5points)
+ equivalence(b_newtempy1,b_E2_m1_m2_5points)
+ equivalence(b_newtempz1,b_E3_m1_m2_5points)
+ real(kind=CUSTOM_REAL), dimension(m2,NGLLX) :: &
+ b_A1_mxm_m2_m1_5points,b_A2_mxm_m2_m1_5points,b_A3_mxm_m2_m1_5points
+ real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
+ b_C1_mxm_m2_m1_5points,b_C2_mxm_m2_m1_5points,b_C3_mxm_m2_m1_5points
+ real(kind=CUSTOM_REAL), dimension(m2,m1) :: &
+ b_E1_mxm_m2_m1_5points,b_E2_mxm_m2_m1_5points,b_E3_mxm_m2_m1_5points
+ equivalence(b_dummyx_loc,b_A1_mxm_m2_m1_5points)
+ equivalence(b_dummyy_loc,b_A2_mxm_m2_m1_5points)
+ equivalence(b_dummyz_loc,b_A3_mxm_m2_m1_5points)
+ equivalence(b_tempx3,b_C1_mxm_m2_m1_5points)
+ equivalence(b_tempy3,b_C2_mxm_m2_m1_5points)
+ equivalence(b_tempz3,b_C3_mxm_m2_m1_5points)
+ equivalence(b_newtempx3,b_E1_mxm_m2_m1_5points)
+ equivalence(b_newtempy3,b_E2_mxm_m2_m1_5points)
+ equivalence(b_newtempz3,b_E3_mxm_m2_m1_5points)
+ real(kind=CUSTOM_REAL):: dsxx,dsxy,dsxz,dsyy,dsyz,dszz
+ real(kind=CUSTOM_REAL):: b_duxdxl,b_duxdyl,b_duxdzl,b_duydxl,b_duydyl,b_duydzl,b_duzdxl,b_duzdyl,b_duzdzl
+ real(kind=CUSTOM_REAL):: b_duxdxl_plus_duydyl,b_duxdxl_plus_duzdzl,b_duydyl_plus_duzdzl
+ real(kind=CUSTOM_REAL):: b_duxdyl_plus_duydxl,b_duzdxl_plus_duxdzl,b_duzdyl_plus_duydzl
+ real(kind=CUSTOM_REAL):: b_dsxx,b_dsxy,b_dsxz,b_dsyy,b_dsyz,b_dszz
+ real(kind=CUSTOM_REAL):: b_sigma_xx,b_sigma_yy,b_sigma_zz,b_sigma_xy,b_sigma_xz,b_sigma_yz
+ real(kind=CUSTOM_REAL):: kappa_k, mu_k
+ ! local adjoint attenuation
+ real(kind=CUSTOM_REAL) b_alphaval_loc,b_betaval_loc,b_gammaval_loc,b_Sn,b_Snp1
+ real(kind=CUSTOM_REAL) b_epsilon_trace_over_3
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: b_epsilondev_xx_loc, &
+ b_epsilondev_yy_loc, b_epsilondev_xy_loc, b_epsilondev_xz_loc, b_epsilondev_yz_loc
+ real(kind=CUSTOM_REAL) b_R_xx_val,b_R_yy_val
+ ! adjoint
+
+ if( iphase == 1 ) then
+ num_elements = nspec_outer_elastic
+ else
+ num_elements = nspec_inner_elastic
+ endif
+
+! loops over all elements
+! do ispec = 1,NSPEC_AB
+! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+! if( ispec_is_elastic(ispec) ) then
+
+ do ispec_p = 1,num_elements
+
+ ispec = phase_ispec_inner_elastic(ispec_p,iphase)
+
+ ! adjoint simulations: moho kernel
+ if( SIMULATION_TYPE == 3 .and. SAVE_MOHO_MESH ) then
+ if (is_moho_top(ispec)) then
+ ispec2D_moho_top = ispec2D_moho_top + 1
+ else if (is_moho_bot(ispec)) then
+ ispec2D_moho_bot = ispec2D_moho_bot + 1
+ endif
+ endif ! adjoint
+
+ ! stores displacment values in local array
+ 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)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ b_dummyx_loc(i,j,k) = b_displ(1,iglob)
+ b_dummyy_loc(i,j,k) = b_displ(2,iglob)
+ b_dummyz_loc(i,j,k) = b_displ(3,iglob)
+ endif
+ 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)
+ 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)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ b_C1_m1_m2_5points(i,j) = hprime_xx(i,1)*b_B1_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*b_B1_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*b_B1_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*b_B1_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*b_B1_m1_m2_5points(5,j)
+ b_C2_m1_m2_5points(i,j) = hprime_xx(i,1)*b_B2_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*b_B2_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*b_B2_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*b_B2_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*b_B2_m1_m2_5points(5,j)
+ b_C3_m1_m2_5points(i,j) = hprime_xx(i,1)*b_B3_m1_m2_5points(1,j) + &
+ hprime_xx(i,2)*b_B3_m1_m2_5points(2,j) + &
+ hprime_xx(i,3)*b_B3_m1_m2_5points(3,j) + &
+ hprime_xx(i,4)*b_B3_m1_m2_5points(4,j) + &
+ hprime_xx(i,5)*b_B3_m1_m2_5points(5,j)
+ endif ! adjoint
+
+ 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)
+ 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)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ b_tempx2(i,j,k) = b_dummyx_loc(i,1,k)*hprime_xxT(1,j) + &
+ b_dummyx_loc(i,2,k)*hprime_xxT(2,j) + &
+ b_dummyx_loc(i,3,k)*hprime_xxT(3,j) + &
+ b_dummyx_loc(i,4,k)*hprime_xxT(4,j) + &
+ b_dummyx_loc(i,5,k)*hprime_xxT(5,j)
+ b_tempy2(i,j,k) = b_dummyy_loc(i,1,k)*hprime_xxT(1,j) + &
+ b_dummyy_loc(i,2,k)*hprime_xxT(2,j) + &
+ b_dummyy_loc(i,3,k)*hprime_xxT(3,j) + &
+ b_dummyy_loc(i,4,k)*hprime_xxT(4,j) + &
+ b_dummyy_loc(i,5,k)*hprime_xxT(5,j)
+ b_tempz2(i,j,k) = b_dummyz_loc(i,1,k)*hprime_xxT(1,j) + &
+ b_dummyz_loc(i,2,k)*hprime_xxT(2,j) + &
+ b_dummyz_loc(i,3,k)*hprime_xxT(3,j) + &
+ b_dummyz_loc(i,4,k)*hprime_xxT(4,j) + &
+ b_dummyz_loc(i,5,k)*hprime_xxT(5,j)
+ endif ! adjoint
+ 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)
+ 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)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ b_C1_mxm_m2_m1_5points(i,j) = b_A1_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ b_A1_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ b_A1_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ b_A1_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ b_A1_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ b_C2_mxm_m2_m1_5points(i,j) = b_A2_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ b_A2_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ b_A2_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ b_A2_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ b_A2_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ b_C3_mxm_m2_m1_5points(i,j) = b_A3_mxm_m2_m1_5points(i,1)*hprime_xxT(1,j) + &
+ b_A3_mxm_m2_m1_5points(i,2)*hprime_xxT(2,j) + &
+ b_A3_mxm_m2_m1_5points(i,3)*hprime_xxT(3,j) + &
+ b_A3_mxm_m2_m1_5points(i,4)*hprime_xxT(4,j) + &
+ b_A3_mxm_m2_m1_5points(i,5)*hprime_xxT(5,j)
+ endif ! adjoint
+ enddo
+ enddo
+
+ 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)
+
+ 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)
+
+ 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
+
+ kappal = kappastore(i,j,k,ispec)
+ mul = mustore(i,j,k,ispec)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ ! save strain on the Moho boundary
+ if (SAVE_MOHO_MESH ) then
+ if (is_moho_top(ispec)) then
+ dsdx_top(1,1,i,j,k,ispec2D_moho_top) = duxdxl
+ dsdx_top(1,2,i,j,k,ispec2D_moho_top) = duxdyl
+ dsdx_top(1,3,i,j,k,ispec2D_moho_top) = duxdzl
+ dsdx_top(2,1,i,j,k,ispec2D_moho_top) = duydxl
+ dsdx_top(2,2,i,j,k,ispec2D_moho_top) = duydyl
+ dsdx_top(2,3,i,j,k,ispec2D_moho_top) = duydzl
+ dsdx_top(3,1,i,j,k,ispec2D_moho_top) = duzdxl
+ dsdx_top(3,2,i,j,k,ispec2D_moho_top) = duzdyl
+ dsdx_top(3,3,i,j,k,ispec2D_moho_top) = duzdzl
+ else if (is_moho_bot(ispec)) then
+ dsdx_bot(1,1,i,j,k,ispec2D_moho_bot) = duxdxl
+ dsdx_bot(1,2,i,j,k,ispec2D_moho_bot) = duxdyl
+ dsdx_bot(1,3,i,j,k,ispec2D_moho_bot) = duxdzl
+ dsdx_bot(2,1,i,j,k,ispec2D_moho_bot) = duydxl
+ dsdx_bot(2,2,i,j,k,ispec2D_moho_bot) = duydyl
+ dsdx_bot(2,3,i,j,k,ispec2D_moho_bot) = duydzl
+ dsdx_bot(3,1,i,j,k,ispec2D_moho_bot) = duzdxl
+ dsdx_bot(3,2,i,j,k,ispec2D_moho_bot) = duzdyl
+ dsdx_bot(3,3,i,j,k,ispec2D_moho_bot) = duzdzl
+ endif
+ endif
+
+ dsxx = duxdxl
+ dsxy = 0.5_CUSTOM_REAL * duxdyl_plus_duydxl
+ dsxz = 0.5_CUSTOM_REAL * duzdxl_plus_duxdzl
+ dsyy = duydyl
+ dsyz = 0.5_CUSTOM_REAL * duzdyl_plus_duydzl
+ dszz = duzdzl
+
+ b_duxdxl = xixl*b_tempx1(i,j,k) + etaxl*b_tempx2(i,j,k) + gammaxl*b_tempx3(i,j,k)
+ b_duxdyl = xiyl*b_tempx1(i,j,k) + etayl*b_tempx2(i,j,k) + gammayl*b_tempx3(i,j,k)
+ b_duxdzl = xizl*b_tempx1(i,j,k) + etazl*b_tempx2(i,j,k) + gammazl*b_tempx3(i,j,k)
+ b_duydxl = xixl*b_tempy1(i,j,k) + etaxl*b_tempy2(i,j,k) + gammaxl*b_tempy3(i,j,k)
+ b_duydyl = xiyl*b_tempy1(i,j,k) + etayl*b_tempy2(i,j,k) + gammayl*b_tempy3(i,j,k)
+ b_duydzl = xizl*b_tempy1(i,j,k) + etazl*b_tempy2(i,j,k) + gammazl*b_tempy3(i,j,k)
+ b_duzdxl = xixl*b_tempz1(i,j,k) + etaxl*b_tempz2(i,j,k) + gammaxl*b_tempz3(i,j,k)
+ b_duzdyl = xiyl*b_tempz1(i,j,k) + etayl*b_tempz2(i,j,k) + gammayl*b_tempz3(i,j,k)
+ b_duzdzl = xizl*b_tempz1(i,j,k) + etazl*b_tempz2(i,j,k) + gammazl*b_tempz3(i,j,k)
+
+ b_duxdxl_plus_duydyl = b_duxdxl + b_duydyl
+ b_duxdxl_plus_duzdzl = b_duxdxl + b_duzdzl
+ b_duydyl_plus_duzdzl = b_duydyl + b_duzdzl
+ b_duxdyl_plus_duydxl = b_duxdyl + b_duydxl
+ b_duzdxl_plus_duxdzl = b_duzdxl + b_duxdzl
+ b_duzdyl_plus_duydzl = b_duzdyl + b_duydzl
+
+ b_dsxx = b_duxdxl
+ b_dsxy = 0.5_CUSTOM_REAL * b_duxdyl_plus_duydxl
+ b_dsxz = 0.5_CUSTOM_REAL * b_duzdxl_plus_duxdzl
+ b_dsyy = b_duydyl
+ b_dsyz = 0.5_CUSTOM_REAL * b_duzdyl_plus_duydzl
+ b_dszz = b_duzdzl
+
+ ! isotropic adjoint kernels: bulk (kappa) and shear (mu) kernels
+ kappa_k = (duxdxl + duydyl + duzdzl) * (b_duxdxl + b_duydyl + b_duzdzl)
+ mu_k = dsxx * b_dsxx + dsyy * b_dsyy + dszz * b_dszz + &
+ 2._CUSTOM_REAL * (dsxy * b_dsxy + dsxz * b_dsxz + dsyz * b_dsyz) &
+ - ONE_THIRD * kappa_k
+
+ kappa_kl(i,j,k,ispec) = kappa_kl(i,j,k,ispec) + deltat * kappa_k
+ mu_kl(i,j,k,ispec) = mu_kl(i,j,k,ispec) + 2._CUSTOM_REAL * deltat * mu_k
+
+ if (SAVE_MOHO_MESH) then
+ if (is_moho_top(ispec)) then
+ b_dsdx_top(1,1,i,j,k,ispec2D_moho_top) = b_duxdxl
+ b_dsdx_top(1,2,i,j,k,ispec2D_moho_top) = b_duxdyl
+ b_dsdx_top(1,3,i,j,k,ispec2D_moho_top) = b_duxdzl
+ b_dsdx_top(2,1,i,j,k,ispec2D_moho_top) = b_duydxl
+ b_dsdx_top(2,2,i,j,k,ispec2D_moho_top) = b_duydyl
+ b_dsdx_top(2,3,i,j,k,ispec2D_moho_top) = b_duydzl
+ b_dsdx_top(3,1,i,j,k,ispec2D_moho_top) = b_duzdxl
+ b_dsdx_top(3,2,i,j,k,ispec2D_moho_top) = b_duzdyl
+ b_dsdx_top(3,3,i,j,k,ispec2D_moho_top) = b_duzdzl
+ else if (is_moho_bot(ispec)) then
+ b_dsdx_bot(1,1,i,j,k,ispec2D_moho_bot) = b_duxdxl
+ b_dsdx_bot(1,2,i,j,k,ispec2D_moho_bot) = b_duxdyl
+ b_dsdx_bot(1,3,i,j,k,ispec2D_moho_bot) = b_duxdzl
+ b_dsdx_bot(2,1,i,j,k,ispec2D_moho_bot) = b_duydxl
+ b_dsdx_bot(2,2,i,j,k,ispec2D_moho_bot) = b_duydyl
+ b_dsdx_bot(2,3,i,j,k,ispec2D_moho_bot) = b_duydzl
+ b_dsdx_bot(3,1,i,j,k,ispec2D_moho_bot) = b_duzdxl
+ b_dsdx_bot(3,2,i,j,k,ispec2D_moho_bot) = b_duzdyl
+ b_dsdx_bot(3,3,i,j,k,ispec2D_moho_bot) = b_duzdzl
+ endif
+ endif
+ endif ! adjoint
+
+
+ ! attenuation
+ 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
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_epsilon_trace_over_3 = ONE_THIRD * (b_duxdxl + b_duydyl + b_duzdzl)
+ b_epsilondev_xx_loc(i,j,k) = b_duxdxl - b_epsilon_trace_over_3
+ b_epsilondev_yy_loc(i,j,k) = b_duydyl - b_epsilon_trace_over_3
+ b_epsilondev_xy_loc(i,j,k) = 0.5 * b_duxdyl_plus_duydxl
+ b_epsilondev_xz_loc(i,j,k) = 0.5 * b_duzdxl_plus_duxdzl
+ b_epsilondev_yz_loc(i,j,k) = 0.5 * b_duzdyl_plus_duydzl
+ endif ! adjoint
+
+ ! uses scaling rule similar to Olsen et al. (2003) or mesh flag
+ if(USE_OLSEN_ATTENUATION) then
+ vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
+ call get_attenuation_model_olsen( vs_val, iselected )
+ else
+ ! iflag from (CUBIT) mesh
+ iselected = iflag_attenuation_store(i,j,k,ispec)
+ endif
+
+ ! use unrelaxed parameters if attenuation
+ mul = mul * one_minus_sum_beta(iselected)
+
+ endif
+
+ ! full anisotropic case, stress calculations
+ if(ANISOTROPY) then
+ c11 = c11store(i,j,k,ispec)
+ c12 = c12store(i,j,k,ispec)
+ c13 = c13store(i,j,k,ispec)
+ c14 = c14store(i,j,k,ispec)
+ c15 = c15store(i,j,k,ispec)
+ c16 = c16store(i,j,k,ispec)
+ c22 = c22store(i,j,k,ispec)
+ c23 = c23store(i,j,k,ispec)
+ c24 = c24store(i,j,k,ispec)
+ c25 = c25store(i,j,k,ispec)
+ c26 = c26store(i,j,k,ispec)
+ c33 = c33store(i,j,k,ispec)
+ c34 = c34store(i,j,k,ispec)
+ c35 = c35store(i,j,k,ispec)
+ c36 = c36store(i,j,k,ispec)
+ c44 = c44store(i,j,k,ispec)
+ c45 = c45store(i,j,k,ispec)
+ c46 = c46store(i,j,k,ispec)
+ c55 = c55store(i,j,k,ispec)
+ c56 = c56store(i,j,k,ispec)
+ c66 = c66store(i,j,k,ispec)
+ !if(ATTENUATION .and. not_fully_in_bedrock(ispec)) then
+ ! mul = c44
+ ! c11 = c11 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c12 = c12 - TWO_THIRDS * minus_sum_beta * mul
+ ! c13 = c13 - TWO_THIRDS * minus_sum_beta * mul
+ ! c22 = c22 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c23 = c23 - TWO_THIRDS * minus_sum_beta * mul
+ ! c33 = c33 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c44 = c44 + minus_sum_beta * mul
+ ! c55 = c55 + minus_sum_beta * mul
+ ! c66 = c66 + minus_sum_beta * mul
+ !endif
+
+ sigma_xx = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
+ c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
+ sigma_yy = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
+ c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
+ sigma_zz = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
+ c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
+ sigma_xy = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
+ c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
+ sigma_xz = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
+ c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
+ sigma_yz = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
+ c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_sigma_xx = c11*b_duxdxl + c16*b_duxdyl_plus_duydxl + c12*b_duydyl + &
+ c15*b_duzdxl_plus_duxdzl + c14*b_duzdyl_plus_duydzl + c13*b_duzdzl
+ b_sigma_yy = c12*b_duxdxl + c26*b_duxdyl_plus_duydxl + c22*b_duydyl + &
+ c25*b_duzdxl_plus_duxdzl + c24*b_duzdyl_plus_duydzl + c23*b_duzdzl
+ b_sigma_zz = c13*b_duxdxl + c36*b_duxdyl_plus_duydxl + c23*b_duydyl + &
+ c35*b_duzdxl_plus_duxdzl + c34*b_duzdyl_plus_duydzl + c33*b_duzdzl
+ b_sigma_xy = c16*b_duxdxl + c66*b_duxdyl_plus_duydxl + c26*b_duydyl + &
+ c56*b_duzdxl_plus_duxdzl + c46*b_duzdyl_plus_duydzl + c36*b_duzdzl
+ b_sigma_xz = c15*b_duxdxl + c56*b_duxdyl_plus_duydxl + c25*b_duydyl + &
+ c55*b_duzdxl_plus_duxdzl + c45*b_duzdyl_plus_duydzl + c35*b_duzdzl
+ b_sigma_yz = c14*b_duxdxl + c46*b_duxdyl_plus_duydxl + c24*b_duydyl + &
+ c45*b_duzdxl_plus_duxdzl + c44*b_duzdyl_plus_duydzl + c34*b_duzdzl
+ endif ! adjoint
+ else
+
+ ! isotropic case
+ 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
+
+ sigma_xy = mul*duxdyl_plus_duydxl
+ sigma_xz = mul*duzdxl_plus_duxdzl
+ sigma_yz = mul*duzdyl_plus_duydzl
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_sigma_xx = lambdalplus2mul*b_duxdxl + lambdal*b_duydyl_plus_duzdzl
+ b_sigma_yy = lambdalplus2mul*b_duydyl + lambdal*b_duxdxl_plus_duzdzl
+ b_sigma_zz = lambdalplus2mul*b_duzdzl + lambdal*b_duxdxl_plus_duydyl
+ b_sigma_xy = mul*b_duxdyl_plus_duydxl
+ b_sigma_xz = mul*b_duzdxl_plus_duxdzl
+ b_sigma_yz = mul*b_duzdyl_plus_duydzl
+ endif !adjoint
+
+ endif ! ANISOTROPY
+
+ ! 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)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_R_xx_val = b_R_xx(i,j,k,ispec,i_sls)
+ b_R_yy_val = b_R_yy(i,j,k,ispec,i_sls)
+ b_sigma_xx = b_sigma_xx - b_R_xx_val
+ b_sigma_yy = b_sigma_yy - b_R_yy_val
+ b_sigma_zz = b_sigma_zz + b_R_xx_val + b_R_yy_val
+ b_sigma_xy = b_sigma_xy - b_R_xy(i,j,k,ispec,i_sls)
+ b_sigma_xz = b_sigma_xz - b_R_xz(i,j,k,ispec,i_sls)
+ b_sigma_yz = b_sigma_yz - b_R_yz(i,j,k,ispec,i_sls)
+ endif !adjoint
+ 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)
+
+ 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)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_tempx1(i,j,k) = jacobianl * (b_sigma_xx*xixl + b_sigma_xy*xiyl + b_sigma_xz*xizl)
+ b_tempy1(i,j,k) = jacobianl * (b_sigma_xy*xixl + b_sigma_yy*xiyl + b_sigma_yz*xizl)
+ b_tempz1(i,j,k) = jacobianl * (b_sigma_xz*xixl + b_sigma_yz*xiyl + b_sigma_zz*xizl)
+ b_tempx2(i,j,k) = jacobianl * (b_sigma_xx*etaxl + b_sigma_xy*etayl + b_sigma_xz*etazl)
+ b_tempy2(i,j,k) = jacobianl * (b_sigma_xy*etaxl + b_sigma_yy*etayl + b_sigma_yz*etazl)
+ b_tempz2(i,j,k) = jacobianl * (b_sigma_xz*etaxl + b_sigma_yz*etayl + b_sigma_zz*etazl)
+ b_tempx3(i,j,k) = jacobianl * (b_sigma_xx*gammaxl + b_sigma_xy*gammayl + b_sigma_xz*gammazl)
+ b_tempy3(i,j,k) = jacobianl * (b_sigma_xy*gammaxl + b_sigma_yy*gammayl + b_sigma_yz*gammazl)
+ b_tempz3(i,j,k) = jacobianl * (b_sigma_xz*gammaxl + b_sigma_yz*gammayl + b_sigma_zz*gammazl)
+ endif !adjoint
+
+ 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)
+ 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)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ b_E1_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*b_C1_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*b_C1_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*b_C1_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*b_C1_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*b_C1_m1_m2_5points(5,j)
+ b_E2_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*b_C2_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*b_C2_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*b_C2_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*b_C2_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*b_C2_m1_m2_5points(5,j)
+ b_E3_m1_m2_5points(i,j) = hprimewgll_xxT(i,1)*b_C3_m1_m2_5points(1,j) + &
+ hprimewgll_xxT(i,2)*b_C3_m1_m2_5points(2,j) + &
+ hprimewgll_xxT(i,3)*b_C3_m1_m2_5points(3,j) + &
+ hprimewgll_xxT(i,4)*b_C3_m1_m2_5points(4,j) + &
+ hprimewgll_xxT(i,5)*b_C3_m1_m2_5points(5,j)
+ endif !adjoint
+ 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)
+ 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)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ b_newtempx2(i,j,k) = b_tempx2(i,1,k)*hprimewgll_xx(1,j) + &
+ b_tempx2(i,2,k)*hprimewgll_xx(2,j) + &
+ b_tempx2(i,3,k)*hprimewgll_xx(3,j) + &
+ b_tempx2(i,4,k)*hprimewgll_xx(4,j) + &
+ b_tempx2(i,5,k)*hprimewgll_xx(5,j)
+ b_newtempy2(i,j,k) = b_tempy2(i,1,k)*hprimewgll_xx(1,j) + &
+ b_tempy2(i,2,k)*hprimewgll_xx(2,j) + &
+ b_tempy2(i,3,k)*hprimewgll_xx(3,j) + &
+ b_tempy2(i,4,k)*hprimewgll_xx(4,j) + &
+ b_tempy2(i,5,k)*hprimewgll_xx(5,j)
+ b_newtempz2(i,j,k) = b_tempz2(i,1,k)*hprimewgll_xx(1,j) + &
+ b_tempz2(i,2,k)*hprimewgll_xx(2,j) + &
+ b_tempz2(i,3,k)*hprimewgll_xx(3,j) + &
+ b_tempz2(i,4,k)*hprimewgll_xx(4,j) + &
+ b_tempz2(i,5,k)*hprimewgll_xx(5,j)
+ endif !adjoint
+ 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)
+ 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)
+
+ ! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ b_E1_mxm_m2_m1_5points(i,j) = b_C1_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ b_C1_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ b_C1_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ b_C1_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ b_C1_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ b_E2_mxm_m2_m1_5points(i,j) = b_C2_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ b_C2_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ b_C2_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ b_C2_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ b_C2_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ b_E3_mxm_m2_m1_5points(i,j) = b_C3_mxm_m2_m1_5points(i,1)*hprimewgll_xx(1,j) + &
+ b_C3_mxm_m2_m1_5points(i,2)*hprimewgll_xx(2,j) + &
+ b_C3_mxm_m2_m1_5points(i,3)*hprimewgll_xx(3,j) + &
+ b_C3_mxm_m2_m1_5points(i,4)*hprimewgll_xx(4,j) + &
+ b_C3_mxm_m2_m1_5points(i,5)*hprimewgll_xx(5,j)
+ endif !adjoint
+ enddo
+ enddo
+
+ 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)
+
+ ! 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)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_accel(1,iglob) = b_accel(1,iglob) - fac1*b_newtempx1(i,j,k) - &
+ fac2*b_newtempx2(i,j,k) - fac3*b_newtempx3(i,j,k)
+ b_accel(2,iglob) = b_accel(2,iglob) - fac1*b_newtempy1(i,j,k) - &
+ fac2*b_newtempy2(i,j,k) - fac3*b_newtempy3(i,j,k)
+ b_accel(3,iglob) = b_accel(3,iglob) - fac1*b_newtempz1(i,j,k) - &
+ fac2*b_newtempz2(i,j,k) - fac3*b_newtempz3(i,j,k)
+ endif !adjoint
+
+ ! 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
+ if( USE_OLSEN_ATTENUATION ) then
+ vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
+ call get_attenuation_model_olsen( vs_val, iselected )
+ else
+ iselected = iflag_attenuation_store(i,j,k,ispec)
+ endif
+
+ 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 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 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
+
+ !adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_alphaval_loc = b_alphaval(iselected,i_sls)
+ b_betaval_loc = b_betaval(iselected,i_sls)
+ b_gammaval_loc = b_gammaval(iselected,i_sls)
+ ! term in xx
+ b_Sn = factor_loc * b_epsilondev_xx(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_xx_loc(i,j,k)
+ b_R_xx(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xx(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! term in yy
+ b_Sn = factor_loc * b_epsilondev_yy(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_yy_loc(i,j,k)
+ b_R_yy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yy(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! term in zz not computed since zero trace
+ ! term in xy
+ b_Sn = factor_loc * b_epsilondev_xy(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_xy_loc(i,j,k)
+ b_R_xy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xy(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! term in xz
+ b_Sn = factor_loc * b_epsilondev_xz(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_xz_loc(i,j,k)
+ b_R_xz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xz(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! term in yz
+ b_Sn = factor_loc * b_epsilondev_yz(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_yz_loc(i,j,k)
+ b_R_yz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yz(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ endif !adjoint
+
+ enddo ! end of loop on memory variables
+
+ endif ! end attenuation
+
+ 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(:,:,:)
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_epsilondev_xx(:,:,:,ispec) = b_epsilondev_xx_loc(:,:,:)
+ b_epsilondev_yy(:,:,:,ispec) = b_epsilondev_yy_loc(:,:,:)
+ b_epsilondev_xy(:,:,:,ispec) = b_epsilondev_xy_loc(:,:,:)
+ b_epsilondev_xz(:,:,:,ispec) = b_epsilondev_xz_loc(:,:,:)
+ b_epsilondev_yz(:,:,:,ispec) = b_epsilondev_yz_loc(:,:,:)
+ endif !adjoint
+ endif
+
+! endif ! ispec_is_elastic
+
+! endif ! if (ispec_is_inner(ispec) .eqv. phase_is_inner)
+
+ enddo ! spectral element loop
+
+end subroutine compute_forces_elastic_Dev
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+!
+!! 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
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_elastic_noDev.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_elastic_noDev.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_forces_elastic_noDev.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,885 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+! Fault implementation
+! Adding input : veloc
+! Kelvin_Voigt_eta
+!
+subroutine compute_forces_elastic_noDev(iphase, &
+ NSPEC_AB,NGLOB_AB,displ,veloc,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, &
+ kappastore,mustore,jacobian,ibool,&
+ ATTENUATION,USE_OLSEN_ATTENUATION,&
+ 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,&
+ rho_vs,&
+ ANISOTROPY,NSPEC_ANISO, &
+ c11store,c12store,c13store,c14store,c15store,c16store,&
+ c22store,c23store,c24store,c25store,c26store,c33store,&
+ c34store,c35store,c36store,c44store,c45store,c46store,&
+ c55store,c56store,c66store, &
+ SIMULATION_TYPE,NGLOB_ADJOINT,NSPEC_ADJOINT, &
+ b_displ,b_accel,kappa_kl,mu_kl,deltat, &
+ NSPEC_BOUN,NSPEC2D_MOHO,NSPEC_ATT_AND_KERNEL,&
+ is_moho_top,is_moho_bot, &
+ dsdx_top,dsdx_bot,b_dsdx_top,b_dsdx_bot, &
+ ispec2D_moho_top,ispec2D_moho_bot, &
+ b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz, &
+ b_epsilondev_xx,b_epsilondev_yy,b_epsilondev_xy, &
+ b_epsilondev_xz,b_epsilondev_yz, &
+ b_alphaval,b_betaval,b_gammaval,&
+ num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic,&
+ phase_ispec_inner_elastic)
+
+ use constants,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,NDIM, &
+ NUM_REGIONS_ATTENUATION,N_SLS,SAVE_MOHO_MESH, &
+ ONE_THIRD,FOUR_THIRDS
+!Percy , loading Kelving Voigt term damping .
+ use fault_solver, only : Kelvin_Voigt_eta
+
+ implicit none
+
+ !include "constants.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! displacement and acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: displ,veloc,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,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+ 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,USE_OLSEN_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
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vs
+
+! anisotropy
+ logical :: ANISOTROPY
+ integer :: NSPEC_ANISO
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO) :: &
+ c11store,c12store,c13store,c14store,c15store,c16store, &
+ c22store,c23store,c24store,c25store,c26store,c33store, &
+ c34store,c35store,c36store,c44store,c45store,c46store, &
+ c55store,c56store,c66store
+
+! New dloc = displ + Kelvin Voigt damping*veloc
+ real(kind=CUSTOM_REAL), dimension(3,NGLLX,NGLLY,NGLLZ) :: dloc
+
+! logical,dimension(NSPEC_AB) :: ispec_is_elastic
+ integer :: iphase
+ integer :: num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic
+ integer, dimension(num_phase_ispec_elastic,2) :: phase_ispec_inner_elastic
+
+
+! adjoint simulations
+ integer :: SIMULATION_TYPE
+ integer :: NSPEC_BOUN,NSPEC2D_MOHO,NSPEC_ATT_AND_KERNEL
+ integer :: NGLOB_ADJOINT,NSPEC_ADJOINT
+
+ ! moho kernel
+ real(kind=CUSTOM_REAL),dimension(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO):: &
+ dsdx_top,dsdx_bot,b_dsdx_top,b_dsdx_bot
+ logical,dimension(NSPEC_BOUN) :: is_moho_top,is_moho_bot
+ integer :: ispec2D_moho_top, ispec2D_moho_bot
+
+ ! adjoint memory variables
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL,N_SLS) :: &
+ b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL) :: &
+ b_epsilondev_xx,b_epsilondev_yy,b_epsilondev_xy,b_epsilondev_xz,b_epsilondev_yz
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: b_alphaval,b_betaval,b_gammaval
+
+ ! adjoint wavefields
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_ADJOINT):: b_displ,b_accel
+ ! adjoint kernels
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT) :: &
+ mu_kl, kappa_kl
+ real(kind=CUSTOM_REAL) :: deltat
+
+!adjoint
+
+! local parameters
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
+
+ integer ispec,iglob,ispec_p,num_elements
+ integer i,j,k,l
+
+ 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) hp1,hp2,hp3
+ real(kind=CUSTOM_REAL) fac1,fac2,fac3
+
+ real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
+ real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
+ real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
+
+ real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
+ real(kind=CUSTOM_REAL) kappal
+
+ ! local anisotropy parameters
+ real(kind=CUSTOM_REAL) c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,&
+ c33,c34,c35,c36,c44,c45,c46,c55,c56,c66
+
+ ! local attenuation parameters
+ 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) epsilon_trace_over_3
+ real(kind=CUSTOM_REAL) vs_val
+
+ integer i_SLS,iselected
+
+ ! adjoint backward arrays
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
+ b_tempx1,b_tempx2,b_tempx3,b_tempy1,b_tempy2,b_tempy3,b_tempz1,b_tempz2,b_tempz3
+ real(kind=CUSTOM_REAL):: dsxx,dsxy,dsxz,dsyy,dsyz,dszz
+ real(kind=CUSTOM_REAL):: b_duxdxl,b_duxdyl,b_duxdzl,b_duydxl,b_duydyl,b_duydzl,b_duzdxl,b_duzdyl,b_duzdzl
+ real(kind=CUSTOM_REAL):: b_duxdxl_plus_duydyl,b_duxdxl_plus_duzdzl,b_duydyl_plus_duzdzl
+ real(kind=CUSTOM_REAL):: b_duxdyl_plus_duydxl,b_duzdxl_plus_duxdzl,b_duzdyl_plus_duydzl
+ real(kind=CUSTOM_REAL):: b_dsxx,b_dsxy,b_dsxz,b_dsyy,b_dsyz,b_dszz
+ real(kind=CUSTOM_REAL):: b_sigma_xx,b_sigma_yy,b_sigma_zz,b_sigma_xy,b_sigma_xz,b_sigma_yz
+ real(kind=CUSTOM_REAL):: kappa_k, mu_k
+ real(kind=CUSTOM_REAL) b_tempx1l,b_tempx2l,b_tempx3l
+ real(kind=CUSTOM_REAL) b_tempy1l,b_tempy2l,b_tempy3l
+ real(kind=CUSTOM_REAL) b_tempz1l,b_tempz2l,b_tempz3l
+ ! local adjoint attenuation
+ real(kind=CUSTOM_REAL) b_alphaval_loc,b_betaval_loc,b_gammaval_loc,b_Sn,b_Snp1
+ real(kind=CUSTOM_REAL) b_epsilon_trace_over_3
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: b_epsilondev_xx_loc, &
+ b_epsilondev_yy_loc, b_epsilondev_xy_loc, b_epsilondev_xz_loc, b_epsilondev_yz_loc
+ real(kind=CUSTOM_REAL) b_R_xx_val,b_R_yy_val
+ ! adjoint
+
+ if( iphase == 1 ) then
+ num_elements = nspec_outer_elastic
+ else
+ num_elements = nspec_inner_elastic
+ endif
+
+ do ispec_p = 1,num_elements
+
+! if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+! if( ispec_is_elastic(ispec) ) then
+
+ ispec = phase_ispec_inner_elastic(ispec_p,iphase)
+
+
+ ! adjoint simulations: moho kernel
+ if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
+ if (is_moho_top(ispec)) then
+ ispec2D_moho_top = ispec2D_moho_top + 1
+ else if (is_moho_bot(ispec)) then
+ ispec2D_moho_bot = ispec2D_moho_bot + 1
+ endif
+ endif
+
+! Fault KELVIN_VOIGT_DAMPING implementation.
+!--------- DAMPING ETA*vloc TERM ---------------
+ if (allocated(Kelvin_Voigt_eta)) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ dloc(:,i,j,k) = displ(:,iglob) + Kelvin_Voigt_eta(ispec)*veloc(:,iglob)
+ enddo
+ enddo
+ enddo
+ else
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ dloc(:,i,j,k) = displ(:,iglob)
+ enddo
+ enddo
+ enddo
+ endif
+!---------------- END DAMPING ----------------
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0.
+ tempx2l = 0.
+ tempx3l = 0.
+
+ tempy1l = 0.
+ tempy2l = 0.
+ tempy3l = 0.
+
+ tempz1l = 0.
+ tempz2l = 0.
+ tempz3l = 0.
+
+ if (SIMULATION_TYPE == 3) then
+ b_tempx1l = 0.
+ b_tempx2l = 0.
+ b_tempx3l = 0.
+
+ b_tempy1l = 0.
+ b_tempy2l = 0.
+ b_tempy3l = 0.
+
+ b_tempz1l = 0.
+ b_tempz2l = 0.
+ b_tempz3l = 0.
+ endif
+
+ do l=1,NGLLX
+ hp1 = hprime_xx(i,l)
+ tempx1l = tempx1l + dloc(1,l,j,k)*hp1
+ tempy1l = tempy1l + dloc(2,l,j,k)*hp1
+ tempz1l = tempz1l + dloc(3,l,j,k)*hp1
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ iglob = ibool(l,j,k,ispec)
+ b_tempx1l = b_tempx1l + b_displ(1,iglob)*hp1
+ b_tempy1l = b_tempy1l + b_displ(2,iglob)*hp1
+ b_tempz1l = b_tempz1l + b_displ(3,iglob)*hp1
+ endif ! adjoint
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ hp2 = hprime_yy(j,l)
+ tempx2l = tempx2l + dloc(1,i,l,k)*hp2
+ tempy2l = tempy2l + dloc(2,i,l,k)*hp2
+ tempz2l = tempz2l + dloc(3,i,l,k)*hp2
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ iglob = ibool(i,l,k,ispec)
+ b_tempx2l = b_tempx2l + b_displ(1,iglob)*hp2
+ b_tempy2l = b_tempy2l + b_displ(2,iglob)*hp2
+ b_tempz2l = b_tempz2l + b_displ(3,iglob)*hp2
+ endif ! adjoint
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ hp3 = hprime_zz(k,l)
+ tempx3l = tempx3l + dloc(1,i,j,l)*hp3
+ tempy3l = tempy3l + dloc(2,i,j,l)*hp3
+ tempz3l = tempz3l + dloc(3,i,j,l)*hp3
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ iglob = ibool(i,j,l,ispec)
+ b_tempx3l = b_tempx3l + b_displ(1,iglob)*hp3
+ b_tempy3l = b_tempy3l + b_displ(2,iglob)*hp3
+ b_tempz3l = b_tempz3l + b_displ(3,iglob)*hp3
+ endif ! adjoint
+
+
+ enddo
+
+ ! 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*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ duxdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ duxdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+
+ duydxl = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
+ duydyl = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
+ duydzl = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
+
+ duzdxl = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
+ duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
+ duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
+
+ ! adjoint simulations: save strain on the Moho boundary
+ if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
+ if (is_moho_top(ispec)) then
+ dsdx_top(1,1,i,j,k,ispec2D_moho_top) = duxdxl
+ dsdx_top(1,2,i,j,k,ispec2D_moho_top) = duxdyl
+ dsdx_top(1,3,i,j,k,ispec2D_moho_top) = duxdzl
+ dsdx_top(2,1,i,j,k,ispec2D_moho_top) = duydxl
+ dsdx_top(2,2,i,j,k,ispec2D_moho_top) = duydyl
+ dsdx_top(2,3,i,j,k,ispec2D_moho_top) = duydzl
+ dsdx_top(3,1,i,j,k,ispec2D_moho_top) = duzdxl
+ dsdx_top(3,2,i,j,k,ispec2D_moho_top) = duzdyl
+ dsdx_top(3,3,i,j,k,ispec2D_moho_top) = duzdzl
+ else if (is_moho_bot(ispec)) then
+ dsdx_bot(1,1,i,j,k,ispec2D_moho_bot) = duxdxl
+ dsdx_bot(1,2,i,j,k,ispec2D_moho_bot) = duxdyl
+ dsdx_bot(1,3,i,j,k,ispec2D_moho_bot) = duxdzl
+ dsdx_bot(2,1,i,j,k,ispec2D_moho_bot) = duydxl
+ dsdx_bot(2,2,i,j,k,ispec2D_moho_bot) = duydyl
+ dsdx_bot(2,3,i,j,k,ispec2D_moho_bot) = duydzl
+ dsdx_bot(3,1,i,j,k,ispec2D_moho_bot) = duzdxl
+ dsdx_bot(3,2,i,j,k,ispec2D_moho_bot) = duzdyl
+ dsdx_bot(3,3,i,j,k,ispec2D_moho_bot) = duzdzl
+ endif
+ endif
+
+ ! 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)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ dsxx = duxdxl
+ dsxy = 0.5_CUSTOM_REAL * duxdyl_plus_duydxl
+ dsxz = 0.5_CUSTOM_REAL * duzdxl_plus_duxdzl
+ dsyy = duydyl
+ dsyz = 0.5_CUSTOM_REAL * duzdyl_plus_duydzl
+ dszz = duzdzl
+
+ b_duxdxl = xixl*b_tempx1l + etaxl*b_tempx2l + gammaxl*b_tempx3l
+ b_duxdyl = xiyl*b_tempx1l + etayl*b_tempx2l + gammayl*b_tempx3l
+ b_duxdzl = xizl*b_tempx1l + etazl*b_tempx2l + gammazl*b_tempx3l
+
+ b_duydxl = xixl*b_tempy1l + etaxl*b_tempy2l + gammaxl*b_tempy3l
+ b_duydyl = xiyl*b_tempy1l + etayl*b_tempy2l + gammayl*b_tempy3l
+ b_duydzl = xizl*b_tempy1l + etazl*b_tempy2l + gammazl*b_tempy3l
+
+ b_duzdxl = xixl*b_tempz1l + etaxl*b_tempz2l + gammaxl*b_tempz3l
+ b_duzdyl = xiyl*b_tempz1l + etayl*b_tempz2l + gammayl*b_tempz3l
+ b_duzdzl = xizl*b_tempz1l + etazl*b_tempz2l + gammazl*b_tempz3l
+
+ b_duxdxl_plus_duydyl = b_duxdxl + b_duydyl
+ b_duxdxl_plus_duzdzl = b_duxdxl + b_duzdzl
+ b_duydyl_plus_duzdzl = b_duydyl + b_duzdzl
+ b_duxdyl_plus_duydxl = b_duxdyl + b_duydxl
+ b_duzdxl_plus_duxdzl = b_duzdxl + b_duxdzl
+ b_duzdyl_plus_duydzl = b_duzdyl + b_duydzl
+
+ b_dsxx = b_duxdxl
+ b_dsxy = 0.5_CUSTOM_REAL * b_duxdyl_plus_duydxl
+ b_dsxz = 0.5_CUSTOM_REAL * b_duzdxl_plus_duxdzl
+ b_dsyy = b_duydyl
+ b_dsyz = 0.5_CUSTOM_REAL * b_duzdyl_plus_duydzl
+ b_dszz = b_duzdzl
+
+ ! isotropic adjoint kernels: bulk (kappa) and shear (mu) kernels
+ kappa_k = (duxdxl + duydyl + duzdzl) * (b_duxdxl + b_duydyl + b_duzdzl)
+ mu_k = dsxx * b_dsxx + dsyy * b_dsyy + dszz * b_dszz + &
+ 2._CUSTOM_REAL * (dsxy * b_dsxy + dsxz * b_dsxz + dsyz * b_dsyz) &
+ - ONE_THIRD * kappa_k
+
+ kappa_kl(i,j,k,ispec) = kappa_kl(i,j,k,ispec) + deltat * kappa_k
+ mu_kl(i,j,k,ispec) = mu_kl(i,j,k,ispec) + 2._CUSTOM_REAL * deltat * mu_k
+
+ if (SAVE_MOHO_MESH) then
+ if (is_moho_top(ispec)) then
+ b_dsdx_top(1,1,i,j,k,ispec2D_moho_top) = b_duxdxl
+ b_dsdx_top(1,2,i,j,k,ispec2D_moho_top) = b_duxdyl
+ b_dsdx_top(1,3,i,j,k,ispec2D_moho_top) = b_duxdzl
+ b_dsdx_top(2,1,i,j,k,ispec2D_moho_top) = b_duydxl
+ b_dsdx_top(2,2,i,j,k,ispec2D_moho_top) = b_duydyl
+ b_dsdx_top(2,3,i,j,k,ispec2D_moho_top) = b_duydzl
+ b_dsdx_top(3,1,i,j,k,ispec2D_moho_top) = b_duzdxl
+ b_dsdx_top(3,2,i,j,k,ispec2D_moho_top) = b_duzdyl
+ b_dsdx_top(3,3,i,j,k,ispec2D_moho_top) = b_duzdzl
+ else if (is_moho_bot(ispec)) then
+ b_dsdx_bot(1,1,i,j,k,ispec2D_moho_bot) = b_duxdxl
+ b_dsdx_bot(1,2,i,j,k,ispec2D_moho_bot) = b_duxdyl
+ b_dsdx_bot(1,3,i,j,k,ispec2D_moho_bot) = b_duxdzl
+ b_dsdx_bot(2,1,i,j,k,ispec2D_moho_bot) = b_duydxl
+ b_dsdx_bot(2,2,i,j,k,ispec2D_moho_bot) = b_duydyl
+ b_dsdx_bot(2,3,i,j,k,ispec2D_moho_bot) = b_duydzl
+ b_dsdx_bot(3,1,i,j,k,ispec2D_moho_bot) = b_duzdxl
+ b_dsdx_bot(3,2,i,j,k,ispec2D_moho_bot) = b_duzdyl
+ b_dsdx_bot(3,3,i,j,k,ispec2D_moho_bot) = b_duzdzl
+ endif
+ endif
+ endif ! adjoint
+
+ 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
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_epsilon_trace_over_3 = ONE_THIRD * (b_duxdxl + b_duydyl + b_duzdzl)
+ b_epsilondev_xx_loc(i,j,k) = b_duxdxl - b_epsilon_trace_over_3
+ b_epsilondev_yy_loc(i,j,k) = b_duydyl - b_epsilon_trace_over_3
+ b_epsilondev_xy_loc(i,j,k) = 0.5 * b_duxdyl_plus_duydxl
+ b_epsilondev_xz_loc(i,j,k) = 0.5 * b_duzdxl_plus_duxdzl
+ b_epsilondev_yz_loc(i,j,k) = 0.5 * b_duzdyl_plus_duydzl
+ endif ! adjoint
+
+ ! uses scaling rule similar to Olsen et al. (2003) or mesh flag
+ if(USE_OLSEN_ATTENUATION) then
+ vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
+ call get_attenuation_model_olsen( vs_val, iselected )
+ else
+ ! iflag from (CUBIT) mesh
+ iselected = iflag_attenuation_store(i,j,k,ispec)
+ endif
+
+ ! use unrelaxed parameters if attenuation
+ mul = mul * one_minus_sum_beta(iselected)
+
+ endif
+
+ ! full anisotropic case, stress calculations
+ if(ANISOTROPY) then
+ c11 = c11store(i,j,k,ispec)
+ c12 = c12store(i,j,k,ispec)
+ c13 = c13store(i,j,k,ispec)
+ c14 = c14store(i,j,k,ispec)
+ c15 = c15store(i,j,k,ispec)
+ c16 = c16store(i,j,k,ispec)
+ c22 = c22store(i,j,k,ispec)
+ c23 = c23store(i,j,k,ispec)
+ c24 = c24store(i,j,k,ispec)
+ c25 = c25store(i,j,k,ispec)
+ c26 = c26store(i,j,k,ispec)
+ c33 = c33store(i,j,k,ispec)
+ c34 = c34store(i,j,k,ispec)
+ c35 = c35store(i,j,k,ispec)
+ c36 = c36store(i,j,k,ispec)
+ c44 = c44store(i,j,k,ispec)
+ c45 = c45store(i,j,k,ispec)
+ c46 = c46store(i,j,k,ispec)
+ c55 = c55store(i,j,k,ispec)
+ c56 = c56store(i,j,k,ispec)
+ c66 = c66store(i,j,k,ispec)
+ !if(ATTENUATION .and. not_fully_in_bedrock(ispec)) then
+ ! mul = c44
+ ! c11 = c11 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c12 = c12 - TWO_THIRDS * minus_sum_beta * mul
+ ! c13 = c13 - TWO_THIRDS * minus_sum_beta * mul
+ ! c22 = c22 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c23 = c23 - TWO_THIRDS * minus_sum_beta * mul
+ ! c33 = c33 + FOUR_THIRDS * minus_sum_beta * mul
+ ! c44 = c44 + minus_sum_beta * mul
+ ! c55 = c55 + minus_sum_beta * mul
+ ! c66 = c66 + minus_sum_beta * mul
+ !endif
+
+ sigma_xx = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
+ c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
+ sigma_yy = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
+ c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
+ sigma_zz = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
+ c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
+ sigma_xy = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
+ c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
+ sigma_xz = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
+ c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
+ sigma_yz = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
+ c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_sigma_xx = c11*b_duxdxl + c16*b_duxdyl_plus_duydxl + c12*b_duydyl + &
+ c15*b_duzdxl_plus_duxdzl + c14*b_duzdyl_plus_duydzl + c13*b_duzdzl
+ b_sigma_yy = c12*b_duxdxl + c26*b_duxdyl_plus_duydxl + c22*b_duydyl + &
+ c25*b_duzdxl_plus_duxdzl + c24*b_duzdyl_plus_duydzl + c23*b_duzdzl
+ b_sigma_zz = c13*b_duxdxl + c36*b_duxdyl_plus_duydxl + c23*b_duydyl + &
+ c35*b_duzdxl_plus_duxdzl + c34*b_duzdyl_plus_duydzl + c33*b_duzdzl
+ b_sigma_xy = c16*b_duxdxl + c66*b_duxdyl_plus_duydxl + c26*b_duydyl + &
+ c56*b_duzdxl_plus_duxdzl + c46*b_duzdyl_plus_duydzl + c36*b_duzdzl
+ b_sigma_xz = c15*b_duxdxl + c56*b_duxdyl_plus_duydxl + c25*b_duydyl + &
+ c55*b_duzdxl_plus_duxdzl + c45*b_duzdyl_plus_duydzl + c35*b_duzdzl
+ b_sigma_yz = c14*b_duxdxl + c46*b_duxdyl_plus_duydxl + c24*b_duydyl + &
+ c45*b_duzdxl_plus_duxdzl + c44*b_duzdyl_plus_duydzl + c34*b_duzdzl
+ endif ! adjoint
+ else
+
+ ! isotropic case
+ 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
+
+ sigma_xy = mul*duxdyl_plus_duydxl
+ sigma_xz = mul*duzdxl_plus_duxdzl
+ sigma_yz = mul*duzdyl_plus_duydzl
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_sigma_xx = lambdalplus2mul*b_duxdxl + lambdal*b_duydyl_plus_duzdzl
+ b_sigma_yy = lambdalplus2mul*b_duydyl + lambdal*b_duxdxl_plus_duzdzl
+ b_sigma_zz = lambdalplus2mul*b_duzdzl + lambdal*b_duxdxl_plus_duydyl
+ b_sigma_xy = mul*b_duxdyl_plus_duydxl
+ b_sigma_xz = mul*b_duzdxl_plus_duxdzl
+ b_sigma_yz = mul*b_duzdyl_plus_duydzl
+ endif !adjoint
+
+ endif ! ANISOTROPY
+
+ ! 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)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_R_xx_val = b_R_xx(i,j,k,ispec,i_sls)
+ b_R_yy_val = b_R_yy(i,j,k,ispec,i_sls)
+ b_sigma_xx = b_sigma_xx - b_R_xx_val
+ b_sigma_yy = b_sigma_yy - b_R_yy_val
+ b_sigma_zz = b_sigma_zz + b_R_xx_val + b_R_yy_val
+ b_sigma_xy = b_sigma_xy - b_R_xy(i,j,k,ispec,i_sls)
+ b_sigma_xz = b_sigma_xz - b_R_xz(i,j,k,ispec,i_sls)
+ b_sigma_yz = b_sigma_yz - b_R_yz(i,j,k,ispec,i_sls)
+ endif !adjoint
+ 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)
+
+ 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)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_tempx1(i,j,k) = jacobianl * (b_sigma_xx*xixl + b_sigma_xy*xiyl + b_sigma_xz*xizl)
+ b_tempy1(i,j,k) = jacobianl * (b_sigma_xy*xixl + b_sigma_yy*xiyl + b_sigma_yz*xizl)
+ b_tempz1(i,j,k) = jacobianl * (b_sigma_xz*xixl + b_sigma_yz*xiyl + b_sigma_zz*xizl)
+ b_tempx2(i,j,k) = jacobianl * (b_sigma_xx*etaxl + b_sigma_xy*etayl + b_sigma_xz*etazl)
+ b_tempy2(i,j,k) = jacobianl * (b_sigma_xy*etaxl + b_sigma_yy*etayl + b_sigma_yz*etazl)
+ b_tempz2(i,j,k) = jacobianl * (b_sigma_xz*etaxl + b_sigma_yz*etayl + b_sigma_zz*etazl)
+ b_tempx3(i,j,k) = jacobianl * (b_sigma_xx*gammaxl + b_sigma_xy*gammayl + b_sigma_xz*gammazl)
+ b_tempy3(i,j,k) = jacobianl * (b_sigma_xy*gammaxl + b_sigma_yy*gammayl + b_sigma_yz*gammazl)
+ b_tempz3(i,j,k) = jacobianl * (b_sigma_xz*gammaxl + b_sigma_yz*gammayl + b_sigma_zz*gammazl)
+ endif !adjoint
+
+ enddo
+ enddo
+ enddo
+
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ tempx1l = 0.
+ tempy1l = 0.
+ tempz1l = 0.
+
+ tempx2l = 0.
+ tempy2l = 0.
+ tempz2l = 0.
+
+ tempx3l = 0.
+ tempy3l = 0.
+ tempz3l = 0.
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_tempx1l = 0.
+ b_tempy1l = 0.
+ b_tempz1l = 0.
+ b_tempx2l = 0.
+ b_tempy2l = 0.
+ b_tempz2l = 0.
+ b_tempx3l = 0.
+ b_tempy3l = 0.
+ b_tempz3l = 0.
+ endif !adjoint
+
+ do l=1,NGLLX
+ fac1 = hprimewgll_xx(l,i)
+ tempx1l = tempx1l + tempx1(l,j,k)*fac1
+ tempy1l = tempy1l + tempy1(l,j,k)*fac1
+ tempz1l = tempz1l + tempz1(l,j,k)*fac1
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_tempx1l = b_tempx1l + b_tempx1(l,j,k)*fac1
+ b_tempy1l = b_tempy1l + b_tempy1(l,j,k)*fac1
+ b_tempz1l = b_tempz1l + b_tempz1(l,j,k)*fac1
+ endif
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
+ fac2 = hprimewgll_yy(l,j)
+ tempx2l = tempx2l + tempx2(i,l,k)*fac2
+ tempy2l = tempy2l + tempy2(i,l,k)*fac2
+ tempz2l = tempz2l + tempz2(i,l,k)*fac2
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_tempx2l = b_tempx2l + b_tempx2(i,l,k)*fac2
+ b_tempy2l = b_tempy2l + b_tempy2(i,l,k)*fac2
+ b_tempz2l = b_tempz2l + b_tempz2(i,l,k)*fac2
+ endif
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
+
+ !!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
+ fac3 = hprimewgll_zz(l,k)
+ tempx3l = tempx3l + tempx3(i,j,l)*fac3
+ tempy3l = tempy3l + tempy3(i,j,l)*fac3
+ tempz3l = tempz3l + tempz3(i,j,l)*fac3
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_tempx3l = b_tempx3l + b_tempx3(i,j,l)*fac3
+ b_tempy3l = b_tempy3l + b_tempy3(i,j,l)*fac3
+ b_tempz3l = b_tempz3l + b_tempz3(i,j,l)*fac3
+ endif
+ enddo
+
+ fac1 = wgllwgll_yz(j,k)
+ fac2 = wgllwgll_xz(i,k)
+ fac3 = wgllwgll_xy(i,j)
+
+ ! sum contributions from each element to the global mesh
+
+ iglob = ibool(i,j,k,ispec)
+
+ accel(1,iglob) = accel(1,iglob) - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
+ accel(2,iglob) = accel(2,iglob) - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
+ accel(3,iglob) = accel(3,iglob) - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_accel(1,iglob) = b_accel(1,iglob) - (fac1*b_tempx1l + fac2*b_tempx2l + fac3*b_tempx3l)
+ b_accel(2,iglob) = b_accel(2,iglob) - (fac1*b_tempy1l + fac2*b_tempy2l + fac3*b_tempy3l)
+ b_accel(3,iglob) = b_accel(3,iglob) - (fac1*b_tempz1l + fac2*b_tempz2l + fac3*b_tempz3l)
+ endif !adjoint
+
+ ! 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
+ if( USE_OLSEN_ATTENUATION ) then
+ vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
+ call get_attenuation_model_olsen( vs_val, iselected )
+ else
+ iselected = iflag_attenuation_store(i,j,k,ispec)
+ endif
+
+ 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 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 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
+
+ !adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_alphaval_loc = b_alphaval(iselected,i_sls)
+ b_betaval_loc = b_betaval(iselected,i_sls)
+ b_gammaval_loc = b_gammaval(iselected,i_sls)
+ ! term in xx
+ b_Sn = factor_loc * b_epsilondev_xx(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_xx_loc(i,j,k)
+ b_R_xx(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xx(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! term in yy
+ b_Sn = factor_loc * b_epsilondev_yy(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_yy_loc(i,j,k)
+ b_R_yy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yy(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! term in zz not computed since zero trace
+ ! term in xy
+ b_Sn = factor_loc * b_epsilondev_xy(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_xy_loc(i,j,k)
+ b_R_xy(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xy(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! term in xz
+ b_Sn = factor_loc * b_epsilondev_xz(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_xz_loc(i,j,k)
+ b_R_xz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_xz(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ ! term in yz
+ b_Sn = factor_loc * b_epsilondev_yz(i,j,k,ispec)
+ b_Snp1 = factor_loc * b_epsilondev_yz_loc(i,j,k)
+ b_R_yz(i,j,k,ispec,i_sls) = b_alphaval_loc * b_R_yz(i,j,k,ispec,i_sls) + &
+ b_betaval_loc * b_Sn + b_gammaval_loc * b_Snp1
+ endif !adjoint
+
+ enddo ! end of loop on memory variables
+
+ endif ! end attenuation
+
+
+ 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(:,:,:)
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_epsilondev_xx(:,:,:,ispec) = b_epsilondev_xx_loc(:,:,:)
+ b_epsilondev_yy(:,:,:,ispec) = b_epsilondev_yy_loc(:,:,:)
+ b_epsilondev_xy(:,:,:,ispec) = b_epsilondev_xy_loc(:,:,:)
+ b_epsilondev_xz(:,:,:,ispec) = b_epsilondev_xz_loc(:,:,:)
+ b_epsilondev_yz(:,:,:,ispec) = b_epsilondev_yz_loc(:,:,:)
+ endif !adjoint
+ endif
+! endif ! ispec_is_elastic
+! endif ! if (ispec_is_inner(ispec) .eqv. phase_is_inner)
+
+ enddo ! spectral element loop
+
+! forces in elastic media calculated in compute_forces_elastic...
+!! adding source
+! do isource = 1,NSOURCES
+!
+! if (ispec_is_inner(ispec_selected_source(isource)) .eqv. phase_is_inner) then
+!
+! if(USE_FORCE_POINT_SOURCE) then
+!
+!! add the source (only if this proc carries the source)
+! if(myrank == islice_selected_source(isource)) then
+!
+! iglob = ibool(nint(xi_source(isource)), &
+! nint(eta_source(isource)), &
+! nint(gamma_source(isource)), &
+! ispec_selected_source(isource))
+! f0 = hdur(isource) !! using hdur as a FREQUENCY just to avoid changing CMTSOLUTION file format
+! t0 = 1.2d0/f0
+!
+! if (it == 1 .and. myrank == 0) then
+! print *,'using a source of dominant frequency ',f0
+! print *,'lambda_S at dominant frequency = ',3000./sqrt(3.)/f0
+! print *,'lambda_S at highest significant frequency = ',3000./sqrt(3.)/(2.5*f0)
+! endif
+!
+! ! we use nu_source(:,3) here because we want a source normal to the surface.
+! ! This is the expression of a Ricker; should be changed according maybe to the Par_file.
+! !accel(:,iglob) = accel(:,iglob) + &
+! ! sngl(nu_source(:,3,isource) * 10000000.d0 * (1.d0-2.d0*PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)) * &
+! ! exp(-PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)))
+! accel(:,iglob) = accel(:,iglob) + &
+! sngl(nu_source(:,3,isource) * 1.d10 * (1.d0-2.d0*PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)) * &
+! exp(-PI*PI*f0*f0*(dble(it-1)*DT-t0)*(dble(it-1)*DT-t0)))
+!
+! endif
+! endif
+!
+! endif
+!
+! enddo
+
+end subroutine compute_forces_elastic_noDev
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_gradient.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_gradient.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_gradient.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,115 @@
+!=====================================================================
+!
+! 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 compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ scalar_field, vector_field_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+
+! calculates gradient of given acoustic scalar (potential) field on all GLL points in one, single element
+! note:
+! displacement s = (rho)^{-1} \del \chi
+! velocity v = (rho)^{-1} \del \ddot \chi
+!
+! returns: (1/rho) times gradient vector field (vector_field_element) in specified element
+
+ implicit none
+ include 'constants.h'
+
+ integer,intent(in) :: ispec,NSPEC_AB,NGLOB_AB
+
+ real(kind=CUSTOM_REAL),dimension(NGLOB_AB),intent(in) :: scalar_field
+
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ),intent(out) :: vector_field_element
+
+ 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) :: rhostore
+
+! array with derivatives of Lagrange polynomials
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz
+
+! local parameters
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl
+ real(kind=CUSTOM_REAL) temp1l,temp2l,temp3l
+ real(kind=CUSTOM_REAL) rho_invl
+ integer :: i,j,k,l
+
+! double loop over GLL points to compute and store gradients
+ vector_field_element(:,:,:,:) = 0._CUSTOM_REAL
+
+ do k= 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ ! derivative along x
+ temp1l = ZERO
+ do l = 1,NGLLX
+ temp1l = temp1l + scalar_field(ibool(l,j,k,ispec))*hprime_xx(i,l)
+ enddo
+
+ ! derivative along y
+ temp2l = ZERO
+ do l = 1,NGLLZ
+ temp2l = temp2l + scalar_field(ibool(i,l,k,ispec))*hprime_yy(j,l)
+ enddo
+
+ ! derivative along z
+ temp3l = ZERO
+ do l = 1,NGLLZ
+ temp3l = temp3l + scalar_field(ibool(i,j,l,ispec))*hprime_zz(k,l)
+ enddo
+
+ 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)
+
+ rho_invl = 1.0_CUSTOM_REAL / rhostore(i,j,k,ispec)
+
+ ! derivatives of acoustic scalar potential field on GLL points
+ vector_field_element(1,i,j,k) = (temp1l*xixl + temp2l*etaxl + temp3l*gammaxl) * rho_invl
+ vector_field_element(2,i,j,k) = (temp1l*xiyl + temp2l*etayl + temp3l*gammayl) * rho_invl
+ vector_field_element(3,i,j,k) = (temp1l*xizl + temp2l*etazl + temp3l*gammazl) * rho_invl
+
+ enddo
+ enddo
+ enddo
+
+end subroutine compute_gradient
+
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_interpolated_dva.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_interpolated_dva.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_interpolated_dva.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,211 @@
+!=====================================================================
+!
+! 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 compute_interpolated_dva(displ,veloc,accel,NGLOB_AB, &
+ ispec,NSPEC_AB,ibool, &
+ xi_r,eta_r,gamma_r, &
+ hxir,hetar,hgammar, &
+ dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd)
+
+! returns displacement/velocity/acceleration (dxd,..,vxd,..,axd,.. ) at receiver location
+
+ implicit none
+ include 'constants.h'
+
+ double precision,intent(out) :: dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd
+
+ integer :: ispec
+
+ integer :: NSPEC_AB,NGLOB_AB
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLOB_AB) :: displ,veloc,accel
+ integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB):: ibool
+
+ ! receiver information
+ double precision :: xi_r,eta_r,gamma_r
+ double precision,dimension(NGLLX) :: hxir
+ double precision,dimension(NGLLY) :: hetar
+ double precision,dimension(NGLLZ) :: hgammar
+
+! local parameters
+ double precision :: hlagrange
+ integer :: i,j,k,iglob
+
+! perform the general interpolation using Lagrange polynomials
+ dxd = ZERO
+ dyd = ZERO
+ dzd = ZERO
+ vxd = ZERO
+ vyd = ZERO
+ vzd = ZERO
+ axd = ZERO
+ ayd = ZERO
+ azd = ZERO
+
+! takes closest GLL point only (no interpolation)
+ if(FASTER_RECEIVERS_POINTS_ONLY) then
+
+ iglob = ibool(nint(xi_r),nint(eta_r),nint(gamma_r),ispec)
+
+ ! displacement
+ dxd = dble(displ(1,iglob))
+ dyd = dble(displ(2,iglob))
+ dzd = dble(displ(3,iglob))
+ ! velocity
+ vxd = dble(veloc(1,iglob))
+ vyd = dble(veloc(2,iglob))
+ vzd = dble(veloc(3,iglob))
+ ! acceleration
+ axd = dble(accel(1,iglob))
+ ayd = dble(accel(2,iglob))
+ azd = dble(accel(3,iglob))
+
+ else
+
+! interpolates seismograms at exact receiver locations
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ hlagrange = hxir(i)*hetar(j)*hgammar(k)
+
+ ! displacement
+ dxd = dxd + dble(displ(1,iglob))*hlagrange
+ dyd = dyd + dble(displ(2,iglob))*hlagrange
+ dzd = dzd + dble(displ(3,iglob))*hlagrange
+ ! velocity
+ vxd = vxd + dble(veloc(1,iglob))*hlagrange
+ vyd = vyd + dble(veloc(2,iglob))*hlagrange
+ vzd = vzd + dble(veloc(3,iglob))*hlagrange
+ ! acceleration
+ axd = axd + dble(accel(1,iglob))*hlagrange
+ ayd = ayd + dble(accel(2,iglob))*hlagrange
+ azd = azd + dble(accel(3,iglob))*hlagrange
+
+ enddo
+ enddo
+ enddo
+
+ endif
+
+end subroutine compute_interpolated_dva
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine compute_interpolated_dva_ac(displ_element,veloc_element,&
+ potential_dot_dot_acoustic,NGLOB_AB, &
+ ispec,NSPEC_AB,ibool, &
+ xi_r,eta_r,gamma_r, &
+ hxir,hetar,hgammar, &
+ dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd)
+
+! acoustic elements
+! returns displacement/velocity/acceleration (dxd,..,vxd,..,axd,.. ) at receiver location
+
+ implicit none
+ include 'constants.h'
+
+ double precision,intent(out) :: dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd
+
+ integer :: ispec
+
+ integer :: NSPEC_AB,NGLOB_AB
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: displ_element,veloc_element
+ real(kind=CUSTOM_REAL),dimension(NGLOB_AB) :: potential_dot_dot_acoustic
+
+ integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB):: ibool
+
+ ! receiver information
+ double precision :: xi_r,eta_r,gamma_r
+ double precision,dimension(NGLLX) :: hxir
+ double precision,dimension(NGLLY) :: hetar
+ double precision,dimension(NGLLZ) :: hgammar
+
+! local parameters
+ double precision :: hlagrange
+ integer :: i,j,k,iglob
+
+! perform the general interpolation using Lagrange polynomials
+ dxd = ZERO
+ dyd = ZERO
+ dzd = ZERO
+ vxd = ZERO
+ vyd = ZERO
+ vzd = ZERO
+ axd = ZERO
+ ayd = ZERO
+ azd = ZERO
+
+! takes closest GLL point only (no interpolation)
+ if(FASTER_RECEIVERS_POINTS_ONLY) then
+
+ ! displacement
+ dxd = displ_element(1,nint(xi_r),nint(eta_r),nint(gamma_r))
+ dyd = displ_element(2,nint(xi_r),nint(eta_r),nint(gamma_r))
+ dzd = displ_element(3,nint(xi_r),nint(eta_r),nint(gamma_r))
+ ! velocity
+ vxd = veloc_element(1,nint(xi_r),nint(eta_r),nint(gamma_r))
+ vyd = veloc_element(2,nint(xi_r),nint(eta_r),nint(gamma_r))
+ vzd = veloc_element(3,nint(xi_r),nint(eta_r),nint(gamma_r))
+
+ ! pressure
+ iglob = ibool(nint(xi_r),nint(eta_r),nint(gamma_r),ispec)
+ axd = - potential_dot_dot_acoustic(iglob)
+ ayd = - potential_dot_dot_acoustic(iglob)
+ azd = - potential_dot_dot_acoustic(iglob)
+
+ else
+
+! interpolates seismograms at exact receiver locations
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ hlagrange = hxir(i)*hetar(j)*hgammar(k)
+
+ ! displacement
+ dxd = dxd + hlagrange*displ_element(1,i,j,k)
+ dyd = dyd + hlagrange*displ_element(2,i,j,k)
+ dzd = dzd + hlagrange*displ_element(3,i,j,k)
+ ! velocity
+ vxd = vxd + hlagrange*veloc_element(1,i,j,k)
+ vyd = vxd + hlagrange*veloc_element(2,i,j,k)
+ vzd = vxd + hlagrange*veloc_element(3,i,j,k)
+ ! pressure
+ axd = axd - hlagrange*potential_dot_dot_acoustic(iglob)
+ ayd = ayd - hlagrange*potential_dot_dot_acoustic(iglob)
+ azd = azd - hlagrange*potential_dot_dot_acoustic(iglob)
+
+ enddo
+ enddo
+ enddo
+
+ endif
+
+end subroutine compute_interpolated_dva_ac
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_parameters.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_parameters.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_parameters.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,264 @@
+!=====================================================================
+!
+! 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 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)
+
+ implicit none
+
+ include "constants.h"
+
+! parameters read from parameter file
+ integer NEX_XI,NEX_ETA,NPROC_XI,NPROC_ETA
+ integer NER_BOTTOM_MOHO,NER_MOHO_16,NER_16_BASEMENT,NER_BASEMENT_SEDIM,NER_SEDIM
+
+! parameters to be computed based upon parameters above read from file
+ integer NPROC,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,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 NEX_DOUBLING_SEDIM_XI,NEX_DOUBLING_SEDIM_ETA
+ integer NEX_DOUBLING_SEDIM_PER_PROC_XI,NEX_DOUBLING_SEDIM_PER_PROC_ETA
+ integer NSPEC2D_DOUBLING_A_XI,NSPEC2D_DOUBLING_A_ETA
+ integer NSPEC2D_DOUBLING_B_XI,NSPEC2D_DOUBLING_B_ETA
+ integer NSPEC_DOUBLING_AB
+ integer NUM_DOUBLING_BRICKS
+ integer NUM2D_DOUBLING_BRICKS_XI,NUM2D_DOUBLING_BRICKS_ETA
+ integer nglob_no_doubling_volume,nglob_no_doubling_surface
+ integer nblocks_xi,nblocks_eta
+ integer nglob_surface_typeA,nglob_surface_typeB
+ integer NSPEC1D_RADIAL_BEDROCK,NPOIN1D_RADIAL_BEDROCK
+
+ integer NSPEC_NO_DOUBLING,NSPEC2D_NO_DOUBLING_XI,NSPEC2D_NO_DOUBLING_ETA
+
+ logical USE_REGULAR_MESH
+
+!
+!--- case of a regular mesh
+!
+ if(USE_REGULAR_MESH) then
+
+! total number of spectral elements along radius
+ NER = NER_SEDIM
+
+! number of elements horizontally in each slice (i.e. per processor)
+! these two values MUST be equal in all cases
+ NEX_PER_PROC_XI = NEX_XI / NPROC_XI
+ NEX_PER_PROC_ETA = NEX_ETA / NPROC_ETA
+
+! total number of processors in each of the six chunks
+ NPROC = NPROC_XI * NPROC_ETA
+
+! exact number of spectral elements without doubling layers
+ NSPEC_NO_DOUBLING = NEX_XI*NEX_ETA*NER_SEDIM
+
+! %%%%%%%%%%%%%% surface elements %%%%%%%%%%%%%%%%%%%
+
+! exact number of surface elements for a chunk without doubling layers
+
+ NSPEC2D_NO_DOUBLING_XI = NEX_PER_PROC_XI*NER_SEDIM
+
+ NSPEC2D_NO_DOUBLING_ETA = NEX_PER_PROC_ETA*NER_SEDIM
+
+! exact number of spectral elements
+ NSPEC_AB = NSPEC_NO_DOUBLING / NPROC
+
+! exact number of surface elements for faces A and B along XI and ETA
+ NSPEC2D_A_XI = NSPEC2D_NO_DOUBLING_XI
+ NSPEC2D_B_XI = NSPEC2D_NO_DOUBLING_XI
+ NSPEC2D_A_ETA = NSPEC2D_NO_DOUBLING_ETA
+ NSPEC2D_B_ETA = NSPEC2D_NO_DOUBLING_ETA
+
+! exact number of surface elements on the bottom and top boundaries
+! and theoretical number of spectral elements in radial direction
+
+ NSPEC2D_TOP = NEX_XI*NEX_ETA / NPROC
+ NSPEC2D_BOTTOM = NSPEC2D_TOP
+
+ NSPEC1D_RADIAL_BEDROCK = NER
+
+! face with max number of elements is type B here
+! maximum number of surface elements on vertical boundaries of the slices
+ NSPEC2DMAX_XMIN_XMAX = NSPEC2D_B_ETA
+ NSPEC2DMAX_YMIN_YMAX = NSPEC2D_B_XI
+
+! theoretical number of Gauss-Lobatto points in radial direction
+ NPOIN1D_RADIAL_BEDROCK = NSPEC1D_RADIAL_BEDROCK*(NGLLZ-1)+1
+
+! 2-D addressing and buffers for summation between slices
+! we add one to number of points because of the flag after the last point
+ NPOIN2DMAX_XMIN_XMAX = NSPEC2DMAX_XMIN_XMAX*NGLLY*NGLLZ + 1
+ NPOIN2DMAX_YMIN_YMAX = NSPEC2DMAX_YMIN_YMAX*NGLLX*NGLLZ + 1
+
+! exact number of global points
+ NGLOB_AB = (NEX_PER_PROC_XI*(NGLLX-1)+1) * (NEX_PER_PROC_ETA*(NGLLY-1)+1) * (NER*(NGLLZ-1)+1)
+
+!
+!--- case of a non-regular mesh with mesh doublings
+!
+ else
+
+! total number of spectral elements along radius
+ NER = NER_BOTTOM_MOHO + NER_MOHO_16 + NER_16_BASEMENT + NER_BASEMENT_SEDIM + NER_SEDIM
+
+! number of elements horizontally in each slice (i.e. per processor)
+! these two values MUST be equal in all cases
+ NEX_PER_PROC_XI = NEX_XI / NPROC_XI
+ NEX_PER_PROC_ETA = NEX_ETA / NPROC_ETA
+
+! total number of processors in each of the six chunks
+ NPROC = NPROC_XI * NPROC_ETA
+
+! number of spectral elements at the bottom of the doubling below the moho
+ NEX_DOUBLING_SEDIM_XI=NEX_XI/2
+ NEX_DOUBLING_SEDIM_ETA=NEX_ETA/2
+ NEX_DOUBLING_SEDIM_PER_PROC_XI=NEX_PER_PROC_XI/2
+ NEX_DOUBLING_SEDIM_PER_PROC_ETA=NEX_PER_PROC_ETA/2
+
+! exact number of spectral elements without doubling layers
+ NSPEC_NO_DOUBLING = &
+ (NEX_DOUBLING_SEDIM_XI*NEX_DOUBLING_SEDIM_ETA*(NER_BASEMENT_SEDIM/2-3) &
+ +(NEX_XI/4)*(NEX_ETA/4)*(NER_16_BASEMENT/2-3) &
+ +(NEX_XI/4)*(NEX_ETA/4)*(NER_MOHO_16/2) &
+ +(NEX_XI/4)*(NEX_ETA/4)*(NER_BOTTOM_MOHO/4)) + NEX_XI*NEX_ETA*NER_SEDIM
+
+! exact number of spectral elements in the doubling regions
+
+! number of elementary bricks in the two regions with doubling
+ NUM_DOUBLING_BRICKS = ((NEX_XI/4)*(NEX_ETA/4) &
+ +NEX_DOUBLING_SEDIM_XI*NEX_DOUBLING_SEDIM_ETA)/4
+
+! for type AB, each doubling brick contains 40 elements on 3 levels
+ NSPEC_DOUBLING_AB=40*NUM_DOUBLING_BRICKS
+
+! %%%%%%%%%%%%%% surface elements %%%%%%%%%%%%%%%%%%%
+
+! exact number of surface elements for a chunk without doubling layers
+
+ NSPEC2D_NO_DOUBLING_XI = &
+ NEX_DOUBLING_SEDIM_PER_PROC_XI*(NER_BASEMENT_SEDIM/2-3) &
+ +(NEX_PER_PROC_XI/4)*(NER_16_BASEMENT/2-3) &
+ +(NEX_PER_PROC_XI/4)*(NER_MOHO_16/2) &
+ +(NEX_PER_PROC_XI/4)*(NER_BOTTOM_MOHO/4) + NEX_PER_PROC_XI*NER_SEDIM
+
+ NSPEC2D_NO_DOUBLING_ETA = &
+ NEX_DOUBLING_SEDIM_PER_PROC_ETA*(NER_BASEMENT_SEDIM/2-3) &
+ +(NEX_PER_PROC_ETA/4)*(NER_16_BASEMENT/2-3) &
+ +(NEX_PER_PROC_ETA/4)*(NER_MOHO_16/2) &
+ +(NEX_PER_PROC_ETA/4)*(NER_BOTTOM_MOHO/4) + NEX_PER_PROC_ETA*NER_SEDIM
+
+! exact number of surface elements in the doubling regions
+
+! number of elementary bricks in the two regions with doubling
+ NUM2D_DOUBLING_BRICKS_XI = ((NEX_PER_PROC_XI/4) &
+ +NEX_DOUBLING_SEDIM_PER_PROC_XI)/2
+
+ NUM2D_DOUBLING_BRICKS_ETA = ((NEX_PER_PROC_ETA/4) &
+ +NEX_DOUBLING_SEDIM_PER_PROC_ETA)/2
+
+! for type A, each doubling brick contains 10 elements on 3 levels
+ NSPEC2D_DOUBLING_A_XI=10*NUM2D_DOUBLING_BRICKS_XI
+ NSPEC2D_DOUBLING_A_ETA=10*NUM2D_DOUBLING_BRICKS_ETA
+
+! for type B, each doubling brick contains 12 elements on 3 levels
+ NSPEC2D_DOUBLING_B_XI=12*NUM2D_DOUBLING_BRICKS_XI
+ NSPEC2D_DOUBLING_B_ETA=12*NUM2D_DOUBLING_BRICKS_ETA
+
+! exact number of spectral elements
+ NSPEC_AB = (NSPEC_NO_DOUBLING + NSPEC_DOUBLING_AB) / NPROC
+
+! exact number of surface elements for faces A and B
+! along XI and ETA for doubling region
+ NSPEC2D_A_XI = NSPEC2D_NO_DOUBLING_XI + NSPEC2D_DOUBLING_A_XI
+ NSPEC2D_B_XI = NSPEC2D_NO_DOUBLING_XI + NSPEC2D_DOUBLING_B_XI
+ NSPEC2D_A_ETA = NSPEC2D_NO_DOUBLING_ETA + NSPEC2D_DOUBLING_A_ETA
+ NSPEC2D_B_ETA = NSPEC2D_NO_DOUBLING_ETA + NSPEC2D_DOUBLING_B_ETA
+
+! exact number of surface elements on the bottom and top boundaries
+! and theoretical number of spectral elements in radial direction
+
+ NSPEC2D_TOP = NEX_XI*NEX_ETA / NPROC
+ NSPEC2D_BOTTOM = (NEX_XI/4)*(NEX_ETA/4) / NPROC
+
+ NSPEC1D_RADIAL_BEDROCK = (NER_BASEMENT_SEDIM+NER_16_BASEMENT+NER_MOHO_16)/2 + NER_BOTTOM_MOHO/4
+
+! face with max number of elements is type B here
+! maximum number of surface elements on vertical boundaries of the slices
+ NSPEC2DMAX_XMIN_XMAX = NSPEC2D_B_ETA
+ NSPEC2DMAX_YMIN_YMAX = NSPEC2D_B_XI
+
+! theoretical number of Gauss-Lobatto points in radial direction
+ NPOIN1D_RADIAL_BEDROCK = NSPEC1D_RADIAL_BEDROCK*(NGLLZ-1)+1
+
+! 2-D addressing and buffers for summation between slices
+! we add one to number of points because of the flag after the last point
+ NPOIN2DMAX_XMIN_XMAX = NSPEC2DMAX_XMIN_XMAX*NGLLY*NGLLZ + 1
+ NPOIN2DMAX_YMIN_YMAX = NSPEC2DMAX_YMIN_YMAX*NGLLX*NGLLZ + 1
+
+! exact number of global points
+
+! case of the doubling regions
+! formulas computed using Mathematica for the basic 3D doubling brick
+
+! compute number of points in blocks with no doubling
+! exclude the three surfaces in contact with the doubling regions
+ nglob_no_doubling_volume = (4*(NGLLX-1)+1)*(4*(NGLLX-1)+1)*((NER_BASEMENT_SEDIM/2-3 )*(NGLLX-1)-1) &
+ +(2*(NGLLX-1)+1)*(2*(NGLLX-1)+1)*(((NER_16_BASEMENT/2+NER_MOHO_16/2+NER_BOTTOM_MOHO/4)-3)*(NGLLX-1)+0)
+
+! number of basic blocks in each slice
+ nblocks_xi = NEX_PER_PROC_XI / 8
+ nblocks_eta = NEX_PER_PROC_ETA / 8
+
+ NGLOB_AB = nblocks_xi*nblocks_eta*(200*NGLLX**3 - 484*NGLLX**2 + 392*NGLLX - 106 + nglob_no_doubling_volume)
+
+! same thing for 2D surfaces for the three types of faces
+ nglob_no_doubling_surface = (4*(NGLLX-1)+1)*((NER_BASEMENT_SEDIM/2-3)*(NGLLX-1)-1) &
+ +(2*(NGLLX-1)+1)*(((NER_16_BASEMENT/2+NER_MOHO_16/2+NER_BOTTOM_MOHO/4)-3)*(NGLLX-1)+0)
+
+ nglob_surface_typeA = 30*NGLLX**2 - 45 * NGLLX + 17
+ nglob_surface_typeB = 36*NGLLX**2 - 57 * NGLLX + 23
+
+! final number of points in volume obtained by removing planes counted twice
+ NGLOB_AB = NGLOB_AB &
+ - (nblocks_xi-1)*nblocks_eta*(nglob_surface_typeA + nglob_no_doubling_surface) &
+ - (nblocks_eta-1)*nblocks_xi*(nglob_surface_typeB + nglob_no_doubling_surface) &
+ + (nblocks_eta-1)*(nblocks_xi-1)*NPOIN1D_RADIAL_BEDROCK
+
+! add number of points in the sediments
+ NGLOB_AB = NGLOB_AB + (NEX_PER_PROC_XI*(NGLLX-1)+1) &
+ *(NEX_PER_PROC_ETA*(NGLLY-1)+1)*(NER_SEDIM*(NGLLZ-1)+0)
+
+ endif ! end of section for non-regular mesh with doublings
+
+ end subroutine compute_parameters
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_rho_estimate.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_rho_estimate.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_rho_estimate.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,46 @@
+!=====================================================================
+!
+! 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 compute_rho_estimate(rho,vp)
+
+! compute rho estimate in Gocad block and in Hauksson's model
+! based upon Vp
+
+ implicit none
+
+! include "constants.h"
+ include "constants_gocad.h"
+
+ double precision rho,vp
+
+! scale density - use empirical rule from Christiane
+ rho = 0.33d0 * vp + 1280.d0
+
+! make sure density estimate is reasonable
+ if(rho > DENSITY_MAX) rho = DENSITY_MAX
+ if(rho < DENSITY_MIN) rho = DENSITY_MIN
+
+ end subroutine compute_rho_estimate
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_stacey_acoustic.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_stacey_acoustic.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_stacey_acoustic.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,132 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! for acoustic solver
+
+ subroutine compute_stacey_acoustic(NSPEC_AB,NGLOB_AB, &
+ potential_dot_dot_acoustic,potential_dot_acoustic, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ abs_boundary_jacobian2Dw,abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces,rhostore,kappastore,ispec_is_acoustic,&
+ SIMULATION_TYPE,SAVE_FORWARD,NSTEP,it,myrank,NGLOB_ADJOINT, &
+ b_potential_dot_dot_acoustic,b_reclen_potential, &
+ b_absorb_potential,b_num_abs_boundary_faces)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! potentials
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: potential_dot_dot_acoustic,&
+ potential_dot_acoustic
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rhostore,kappastore
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic
+
+! absorbing boundary surface
+ integer :: num_abs_boundary_faces
+ real(kind=CUSTOM_REAL) :: abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ispec(num_abs_boundary_faces)
+
+! adjoint simulations
+ integer:: SIMULATION_TYPE
+ integer:: NSTEP,it,myrank,NGLOB_ADJOINT
+ integer:: b_num_abs_boundary_faces,b_reclen_potential
+ real(kind=CUSTOM_REAL),dimension(NGLOB_ADJOINT) :: b_potential_dot_dot_acoustic
+ real(kind=CUSTOM_REAL),dimension(NGLLSQUARE,b_num_abs_boundary_faces):: b_absorb_potential
+ logical:: SAVE_FORWARD
+
+! local parameters
+ real(kind=CUSTOM_REAL) :: rhol,cpl,jacobianw
+ integer :: ispec,iglob,i,j,k,iface,igll
+ !adjoint locals
+ integer:: reclen1,reclen2
+
+! adjoint simulations:
+ if (SIMULATION_TYPE == 3 .and. num_abs_boundary_faces > 0) then
+ read(IOABS_AC,rec=NSTEP-it+1) reclen1,b_absorb_potential,reclen2
+ if (reclen1 /= b_reclen_potential .or. reclen1 /= reclen2) &
+ call exit_mpi(myrank,'Error reading absorbing contribution b_absorb_potential')
+ endif !adjoint
+
+! absorbs absorbing-boundary surface using Sommerfeld condition (vanishing field in the outer-space)
+ do iface=1,num_abs_boundary_faces
+
+ ispec = abs_boundary_ispec(iface)
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_acoustic(ispec) ) then
+
+ ! reference gll points on boundary face
+ do igll = 1,NGLLSQUARE
+
+ ! gets local indices for GLL point
+ i = abs_boundary_ijk(1,igll,iface)
+ j = abs_boundary_ijk(2,igll,iface)
+ k = abs_boundary_ijk(3,igll,iface)
+
+ ! gets global index
+ iglob=ibool(i,j,k,ispec)
+
+ ! determines bulk sound speed
+ rhol = rhostore(i,j,k,ispec)
+ cpl = sqrt( kappastore(i,j,k,ispec) / rhol )
+
+ ! gets associated, weighted jacobian
+ jacobianw = abs_boundary_jacobian2Dw(igll,iface)
+
+ ! Sommerfeld condition
+ potential_dot_dot_acoustic(iglob) = potential_dot_dot_acoustic(iglob) &
+ - potential_dot_acoustic(iglob) * jacobianw / cpl / rhol
+
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_potential_dot_dot_acoustic(iglob) = b_potential_dot_dot_acoustic(iglob) &
+ - b_absorb_potential(igll,iface)
+ else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_potential(igll,iface) = potential_dot_acoustic(iglob) * jacobianw / cpl / rhol
+ endif !adjoint
+
+ enddo
+
+ endif ! ispec_is_acoustic
+ endif ! ispec_is_inner
+ enddo ! num_abs_boundary_faces
+
+ ! adjoint simulations: stores absorbed wavefield part
+ if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. num_abs_boundary_faces > 0 ) &
+ write(IOABS_AC,rec=it) b_reclen_potential,b_absorb_potential,b_reclen_potential
+
+ end subroutine compute_stacey_acoustic
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_stacey_elastic.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_stacey_elastic.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/compute_stacey_elastic.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,155 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! for elastic solver
+
+! absorbing boundary term for elastic media (Stacey conditions)
+
+ subroutine compute_stacey_elastic(NSPEC_AB,NGLOB_AB,accel, &
+ ibool,ispec_is_inner,phase_is_inner, &
+ abs_boundary_normal,abs_boundary_jacobian2Dw, &
+ abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces, &
+ veloc,rho_vp,rho_vs, &
+ ispec_is_elastic,SIMULATION_TYPE,myrank,SAVE_FORWARD, &
+ NSTEP,it,NGLOB_ADJOINT,b_accel, &
+ b_num_abs_boundary_faces,b_reclen_field,b_absorb_field)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: NSPEC_AB,NGLOB_AB
+
+! acceleration
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: accel
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! communication overlap
+ logical, dimension(NSPEC_AB) :: ispec_is_inner
+ logical :: phase_is_inner
+
+! Stacey conditions
+ real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: veloc
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: rho_vp,rho_vs
+
+ logical, dimension(NSPEC_AB) :: ispec_is_elastic
+
+! absorbing boundary surface
+ integer :: num_abs_boundary_faces
+ real(kind=CUSTOM_REAL) :: abs_boundary_normal(NDIM,NGLLSQUARE,num_abs_boundary_faces)
+ real(kind=CUSTOM_REAL) :: abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ispec(num_abs_boundary_faces)
+
+! adjoint simulations
+ integer:: SIMULATION_TYPE
+ integer:: NSTEP,it,myrank,NGLOB_ADJOINT
+ integer:: b_num_abs_boundary_faces,b_reclen_field
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLSQUARE,b_num_abs_boundary_faces):: b_absorb_field
+
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLOB_ADJOINT):: b_accel
+ logical:: SAVE_FORWARD
+
+! local parameters
+ real(kind=CUSTOM_REAL) vx,vy,vz,nx,ny,nz,tx,ty,tz,vn,jacobianw
+ integer :: ispec,iglob,i,j,k,iface,igll
+
+ !adjoint locals
+ integer:: reclen1,reclen2
+
+
+! adjoint simulations:
+ if (SIMULATION_TYPE == 3 .and. num_abs_boundary_faces > 0) then
+ read(IOABS,rec=NSTEP-it+1) reclen1,b_absorb_field,reclen2
+ if (reclen1 /= b_reclen_field .or. reclen1 /= reclen2) &
+ call exit_mpi(myrank,'Error reading absorbing contribution b_absorb_field')
+ endif !adjoint
+
+
+! absorbs absorbing-boundary surface using Stacey condition (Clayton & Enquist)
+ do iface=1,num_abs_boundary_faces
+
+ ispec = abs_boundary_ispec(iface)
+
+ if (ispec_is_inner(ispec) .eqv. phase_is_inner) then
+
+ if( ispec_is_elastic(ispec) ) then
+
+ ! reference gll points on boundary face
+ do igll = 1,NGLLSQUARE
+
+ ! gets local indices for GLL point
+ i = abs_boundary_ijk(1,igll,iface)
+ j = abs_boundary_ijk(2,igll,iface)
+ k = abs_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 = abs_boundary_normal(1,igll,iface)
+ ny = abs_boundary_normal(2,igll,iface)
+ nz = abs_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 = abs_boundary_jacobian2Dw(igll,iface)
+
+ ! 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
+
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ b_accel(:,iglob) = b_accel(:,iglob) - b_absorb_field(:,igll,iface)
+ else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ b_absorb_field(1,igll,iface) = tx*jacobianw
+ b_absorb_field(2,igll,iface) = ty*jacobianw
+ b_absorb_field(3,igll,iface) = tz*jacobianw
+ endif !adjoint
+
+ enddo
+ endif ! ispec_is_elastic
+ endif ! ispec_is_inner
+ enddo
+
+ ! adjoint simulations: stores absorbed wavefield part
+ if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. num_abs_boundary_faces > 0 ) &
+ write(IOABS,rec=it) b_reclen_field,b_absorb_field,b_reclen_field
+
+ end subroutine compute_stacey_elastic
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/convolve_source_timefunction.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/convolve_source_timefunction.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/convolve_source_timefunction.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,133 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+ program convolve_source_time_function
+
+!
+! convolve seismograms computed for a Heaviside with given source time function
+!
+
+! we mimic a triangle of half duration equal to half_duration_triangle
+! using a Gaussian having a very close shape, as explained in Figure 4.2
+! of the manual
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: i,j,N_j,number_remove,nlines
+
+ double precision :: alpha,dt,tau_j,source,exponent,t1,t2,displ1,displ2,gamma,height,half_duration_triangle
+
+ logical :: triangle
+
+ double precision, dimension(:), allocatable :: time,sem,sem_fil
+
+! read file with number of lines in input
+ open(unit=33,file='input_convolve_code.txt',status='old',action='read')
+ read(33,*) nlines
+ read(33,*) half_duration_triangle
+ read(33,*) triangle
+ close(33)
+
+! allocate arrays
+ allocate(time(nlines),sem(nlines),sem_fil(nlines))
+
+! read the input seismogram
+ do i = 1,nlines
+ read(5,*) time(i),sem(i)
+ enddo
+
+! define a Gaussian with the right exponent to mimic a triangle of equivalent half duration
+ alpha = SOURCE_DECAY_MIMIC_TRIANGLE/half_duration_triangle
+
+! compute the time step
+ dt = time(2) - time(1)
+
+! number of integers for which the source wavelet is different from zero
+ if(triangle) then
+ N_j = ceiling(half_duration_triangle/dt)
+ else
+ N_j = ceiling(1.5d0*half_duration_triangle/dt)
+ endif
+
+ do i = 1,nlines
+
+ sem_fil(i) = 0.d0
+
+ do j = -N_j,N_j
+
+ if(i > j .and. i-j <= nlines) then
+
+ tau_j = dble(j)*dt
+
+! convolve with a triangle
+ if(triangle) then
+ height = 1.d0 / half_duration_triangle
+ if(abs(tau_j) > half_duration_triangle) then
+ source = 0.d0
+ else if (tau_j < 0.d0) then
+ t1 = - N_j * dt
+ displ1 = 0.d0
+ t2 = 0.d0
+ displ2 = height
+ gamma = (tau_j - t1) / (t2 - t1)
+ source= (1.d0 - gamma) * displ1 + gamma * displ2
+ else
+ t1 = 0.d0
+ displ1 = height
+ t2 = + N_j * dt
+ displ2 = 0.d0
+ gamma = (tau_j - t1) / (t2 - t1)
+ source= (1.d0 - gamma) * displ1 + gamma * displ2
+ endif
+
+ else
+
+! convolve with a Gaussian
+ exponent = alpha**2 * tau_j**2
+ if(exponent < 50.d0) then
+ source = alpha*exp(-exponent)/sqrt(PI)
+ else
+ source = 0.d0
+ endif
+
+ endif
+
+ sem_fil(i) = sem_fil(i) + sem(i-j)*source*dt
+
+ endif
+
+ enddo
+ enddo
+
+! compute number of samples to remove from end of seismograms
+ number_remove = N_j + 1
+ do i=1,nlines - number_remove
+ write(*,*) sngl(time(i)),' ',sngl(sem_fil(i))
+ enddo
+
+ end program convolve_source_time_function
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_header_file.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_header_file.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_header_file.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,90 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! create file OUTPUT_FILES/values_from_mesher.h based upon DATA/Par_file
+! in order to compile the solver with the right array sizes
+
+ subroutine create_header_file
+
+ implicit none
+
+ include "constants.h"
+
+ integer NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE,SIMULATION_TYPE
+ integer NSOURCES
+
+! parameters to be computed based upon parameters above read from file
+ integer NPROC
+
+ integer NSPEC_AB, NGLOB_AB
+ ! NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,
+
+ double precision DT,HDUR_MOVIE
+
+ logical ATTENUATION,USE_OLSEN_ATTENUATION, &
+ OCEANS,ABSORBING_CONDITIONS,SAVE_FORWARD
+ logical ANISOTROPY,SAVE_AVS_DX_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION
+
+ logical MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ USE_HIGHRES_FOR_MOVIES,SUPPRESS_UTM_PROJECTION
+ integer NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
+
+ character(len=256) LOCAL_PATH,HEADER_FILE
+
+! ************** PROGRAM STARTS HERE **************
+
+ call get_value_string(HEADER_FILE, 'solver.HEADER_FILE', 'OUTPUT_FILES/values_from_mesher.h')
+ print *
+ print *,'creating file ', trim(HEADER_FILE), ' to compile solver with correct values'
+
+! read the parameter file
+ call read_parameter_file( NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ ATTENUATION,USE_OLSEN_ATTENUATION,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_AVS_DX_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
+
+! create include file for the solver
+ call save_header_file(NSPEC_AB,NGLOB_AB,NPROC, &
+ ATTENUATION,ANISOTROPY,NSTEP,DT, &
+ SIMULATION_TYPE,0.d0,0)
+ print *
+ print *,'edit file OUTPUT_FILES/values_from_mesher.h to see some statistics about the mesh'
+ print *
+!! DK DK May 2009: removed this because now each slice of a CUBIT + SCOTCH mesh
+!! DK DK May 2009: has a different number of spectral elements and therefore the
+!! DK DK May 2009: value below should be the max() for all the slices
+! print *,'on NEC SX, make sure "loopcnt=" parameter'
+! print *,'in Makefile is greater than max vector length = ',NGLOB_AB
+
+ print *
+ print *,'done'
+ print *
+
+ end subroutine create_header_file
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_mass_matrices.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_mass_matrices.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_mass_matrices.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,265 @@
+!=====================================================================
+!
+! 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 create_mass_matrices(nglob,nspec,ibool)
+
+! returns precomputed mass matrix in rmass array
+
+ use create_regions_mesh_ext_par
+ implicit none
+
+! number of spectral elements in each block
+ integer :: nspec
+ integer :: nglob
+
+! arrays with the mesh global indices
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+! local parameters
+ double precision :: weight
+ real(kind=CUSTOM_REAL) :: jacobianl
+ integer :: ispec,i,j,k,iglob,ier
+
+! allocates memory
+ allocate(rmass(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(rmass_acoustic(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(rmass_solid_poroelastic(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+ allocate(rmass_fluid_poroelastic(nglob),stat=ier); if(ier /= 0) stop 'error in allocate'
+
+! creates mass matrix
+ rmass(:) = 0._CUSTOM_REAL
+ rmass_acoustic(:) = 0._CUSTOM_REAL
+ rmass_solid_poroelastic(:) = 0._CUSTOM_REAL
+ rmass_fluid_poroelastic(:) = 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)
+
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+ jacobianl = jacobianstore(i,j,k,ispec)
+
+! acoustic mass matrix
+ if( ispec_is_acoustic(ispec) ) then
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass_acoustic(iglob) = rmass_acoustic(iglob) + &
+ sngl( dble(jacobianl) * weight / dble(kappastore(i,j,k,ispec)) )
+ else
+ rmass_acoustic(iglob) = rmass_acoustic(iglob) + &
+ jacobianl * weight / kappastore(i,j,k,ispec)
+ endif
+ endif
+
+! elastic mass matrix
+ if( ispec_is_elastic(ispec) ) then
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglob) = rmass(iglob) + &
+ sngl( dble(jacobianl) * weight * dble(rhostore(i,j,k,ispec)) )
+ else
+ rmass(iglob) = rmass(iglob) + &
+ jacobianl * weight * rhostore(i,j,k,ispec)
+ endif
+ endif
+
+! poroelastic mass matrices
+ if( ispec_is_poroelastic(ispec) ) then
+
+ stop 'poroelastic mass matrices not implemented yet'
+
+ !rho_solid = density(1,kmato(ispec))
+ !rho_fluid = density(2,kmato(ispec))
+ !phi = porosity(kmato(ispec))
+ !tort = tortuosity(kmato(ispec))
+ !rho_bar = (1._CUSTOM_REAL-phil)*rhol_s + phil*rhol_f
+ !
+ !if(CUSTOM_REAL == SIZE_REAL) then
+ ! ! for the solid mass matrix
+ ! rmass_solid_poroelastic(iglob) = rmass_solid_poroelastic(iglob) + &
+ ! sngl( dble(jacobianl) * weight * dble(rho_bar - phi*rho_fluid/tort) )
+ !
+ ! ! for the fluid mass matrix
+ ! rmass_fluid_poroelastic(iglob) = rmass_fluid_poroelastic(iglob) + &
+ ! sngl( dble(jacobianl) * weight * dble(rho_bar*rho_fluid*tort - &
+ ! phi*rho_fluid*rho_fluid)/dble(rho_bar*phi) )
+ !else
+ ! rmass_solid_poroelastic(iglob) = rmass_solid_poroelastic(iglob) + &
+ ! jacobianl * weight * (rho_bar - phi*rho_fluid/tort)
+ !
+ ! rmass_fluid_poroelastic(iglob) = rmass_fluid_poroelastic(iglob) + &
+ ! jacobianl * weight * (rho_bar*rho_fluid*tort - &
+ ! phi*rho_fluid*rho_fluid) / (rho_bar*phi)
+ !endif
+ endif
+
+ enddo
+ enddo
+ enddo
+ enddo ! nspec
+
+ end subroutine create_mass_matrices
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine create_mass_matrices_ocean_load(nglob,nspec,ibool,OCEANS,&
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION,NX_TOPO,NY_TOPO, &
+ ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO, &
+ itopo_bathy)
+
+! returns precomputed mass matrix in rmass array
+
+ use create_regions_mesh_ext_par
+ implicit none
+
+! number of spectral elements in each block
+ integer :: nspec
+ integer :: nglob
+
+! arrays with the mesh global indices
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ logical :: OCEANS
+
+! use integer array to store topography values
+ integer :: UTM_PROJECTION_ZONE
+ logical :: SUPPRESS_UTM_PROJECTION
+ integer :: NX_TOPO,NY_TOPO
+ double precision :: ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO
+ integer, dimension(NX_TOPO,NY_TOPO) :: itopo_bathy
+
+
+! local parameters
+ double precision :: weight
+ double precision :: xval,yval,long,lat,elevation
+ double precision :: height_oceans
+ double precision :: long_corner,lat_corner,ratio_xi,ratio_eta
+ integer :: ix_oceans,iy_oceans,iz_oceans,ispec_oceans,ispec2D,igll,iglobnum
+ integer :: icornerlong,icornerlat
+
+! creates ocean load mass matrix
+ if(OCEANS) then
+
+ ! adding ocean load mass matrix at ocean bottom
+ NGLOB_OCEAN = nglob
+ allocate(rmass_ocean_load(NGLOB_OCEAN))
+
+ ! create ocean load mass matrix for degrees of freedom at ocean bottom
+ rmass_ocean_load(:) = 0._CUSTOM_REAL
+
+ ! add contribution of the oceans for surface elements exactly at ocean bottom
+ do ispec2D = 1,num_free_surface_faces
+
+ ispec_oceans = free_surface_ispec(ispec2D)
+
+ ! only adds contribution if top boundary is elastic, no need to add this approximate calculation
+ ! if top is already acoustic/poroelastic
+ if( ispec_is_elastic(ispec_oceans) ) then
+
+ do igll=1,NGLLSQUARE
+ ix_oceans = free_surface_ijk(1,igll,ispec2D)
+ iy_oceans = free_surface_ijk(1,igll,ispec2D)
+ iz_oceans = free_surface_ijk(1,igll,ispec2D)
+
+ iglobnum=ibool(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
+
+ ! compute local height of oceans
+
+ ! get coordinates of current point
+ xval = xstore_dummy(iglobnum)
+ yval = ystore_dummy(iglobnum)
+
+ ! project x and y in UTM back to long/lat since topo file is in long/lat
+ call utm_geo(long,lat,xval,yval,UTM_PROJECTION_ZONE,IUTM2LONGLAT,SUPPRESS_UTM_PROJECTION)
+
+ ! get coordinate of corner in bathy/topo model
+ icornerlong = int((long - ORIG_LONG_TOPO) / DEGREES_PER_CELL_TOPO) + 1
+ icornerlat = int((lat - ORIG_LAT_TOPO) / DEGREES_PER_CELL_TOPO) + 1
+
+ ! avoid edge effects and extend with identical point if outside model
+ if(icornerlong < 1) icornerlong = 1
+ if(icornerlong > NX_TOPO-1) icornerlong = NX_TOPO-1
+ if(icornerlat < 1) icornerlat = 1
+ if(icornerlat > NY_TOPO-1) icornerlat = NY_TOPO-1
+
+ ! compute coordinates of corner
+ long_corner = ORIG_LONG_TOPO + (icornerlong-1)*DEGREES_PER_CELL_TOPO
+ lat_corner = ORIG_LAT_TOPO + (icornerlat-1)*DEGREES_PER_CELL_TOPO
+
+ ! compute ratio for interpolation
+ ratio_xi = (long - long_corner) / DEGREES_PER_CELL_TOPO
+ ratio_eta = (lat - lat_corner) / DEGREES_PER_CELL_TOPO
+
+ ! avoid edge effects
+ if(ratio_xi < 0.) ratio_xi = 0.
+ if(ratio_xi > 1.) ratio_xi = 1.
+ if(ratio_eta < 0.) ratio_eta = 0.
+ if(ratio_eta > 1.) ratio_eta = 1.
+
+ ! interpolate elevation at current point
+ elevation = &
+ itopo_bathy(icornerlong,icornerlat)*(1.-ratio_xi)*(1.-ratio_eta) + &
+ itopo_bathy(icornerlong+1,icornerlat)*ratio_xi*(1.-ratio_eta) + &
+ itopo_bathy(icornerlong+1,icornerlat+1)*ratio_xi*ratio_eta + &
+ itopo_bathy(icornerlong,icornerlat+1)*(1.-ratio_xi)*ratio_eta
+
+ ! suppress positive elevation, which means no oceans
+ if(elevation >= - MINIMUM_THICKNESS_3D_OCEANS) then
+ height_oceans = 0.d0
+ else
+ height_oceans = dabs(elevation)
+ endif
+
+ ! take into account inertia of water column
+ weight = dble( free_surface_jacobian2Dw(igll,ispec2D)) &
+ * dble(RHO_OCEANS) * height_oceans
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + sngl(weight)
+ else
+ rmass_ocean_load(iglobnum) = rmass_ocean_load(iglobnum) + weight
+ endif
+
+ enddo ! igll
+ endif ! ispec_is_elastic
+ enddo ! num_free_surface_faces
+
+ ! add regular mass matrix to ocean load contribution
+ rmass_ocean_load(:) = rmass_ocean_load(:) + rmass(:)
+
+ else
+
+ ! allocate dummy array if no oceans
+ NGLOB_OCEAN = 1
+ allocate(rmass_ocean_load(NGLOB_OCEAN))
+
+ endif
+
+ end subroutine create_mass_matrices_ocean_load
+
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_movie_shakemap_AVS_DX_GMT.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_movie_shakemap_AVS_DX_GMT.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_movie_shakemap_AVS_DX_GMT.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,1010 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+!
+!--- create a movie of vertical component of surface displacement or velocity
+!--- in AVS or OpenDX format
+!
+
+ program create_movie_AVS_DX
+
+ implicit none
+
+ include "constants.h"
+ include "OUTPUT_FILES/surface_from_mesher.h"
+
+!-------------------------------------------------------------------------------------------------
+! user parameters
+! threshold in percent of the maximum below which we cut the amplitude
+ logical, parameter :: APPLY_THRESHOLD = .false.
+ real(kind=CUSTOM_REAL), parameter :: THRESHOLD = 1._CUSTOM_REAL / 100._CUSTOM_REAL
+
+! coefficient of power law used for non linear scaling
+ logical, parameter :: NONLINEAR_SCALING = .false.
+ real(kind=CUSTOM_REAL), parameter :: POWER_SCALING = 0.13_CUSTOM_REAL
+
+!-------------------------------------------------------------------------------------------------
+
+ ! number of points in each AVS or OpenDX quadrangular cell for movies
+ integer, parameter :: NGNOD2D_AVS_DX = 4
+
+ integer it,it1,it2,ivalue,nspectot_AVS_max,ispec
+ integer iformat,nframes,iframe,inumber,inorm,iscaling_shake
+ integer ibool_number,ibool_number1,ibool_number2,ibool_number3,ibool_number4
+
+ logical USE_OPENDX,USE_AVS,plot_shaking_map
+
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: x,y,z,display
+ real(kind=CUSTOM_REAL) xcoord,ycoord,zcoord
+ real(kind=CUSTOM_REAL) vectorx,vectory,vectorz
+
+ double precision min_field_current,max_field_current,max_absol
+
+ character(len=256) outputname
+
+ integer ipoin
+
+ ! for sorting routine
+ integer npointot,ilocnum,nglob,i,j,ielm,ieoff,ispecloc
+ 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
+
+ ! movie files stored by solver
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
+ store_val_x,store_val_y,store_val_z, &
+ store_val_ux,store_val_uy,store_val_uz
+
+ ! parameters read from parameter file
+ integer 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
+ integer NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
+ double precision DT
+ double precision HDUR_MOVIE
+ logical ATTENUATION,USE_OLSEN_ATTENUATION, &
+ OCEANS
+ logical ABSORBING_CONDITIONS,SAVE_FORWARD
+ logical ANISOTROPY,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION
+ character(len=256) OUTPUT_FILES,LOCAL_PATH
+ integer NPROC
+ integer ier
+
+
+!--------------------------------------------
+!!!! 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
+!--------------------------------------------
+!!!! NL NL
+
+ ! order of points representing the 2D square element
+ integer,dimension(NGNOD2D_AVS_DX),parameter :: iorder = (/1,3,2,4/)
+
+
+! ************** PROGRAM STARTS HERE **************
+
+ print *
+ print *,'Recombining all movie frames to create a movie'
+ print *
+
+ print *
+ print *,'reading parameter file'
+ print *
+
+ ! read the parameter file
+ call read_parameter_file(NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ ATTENUATION,USE_OLSEN_ATTENUATION,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,SIMULATION_TYPE,SAVE_FORWARD)
+
+ ! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+ ! only one global array for movie data, but stored for all surfaces defined
+ ! in file 'surface_from_mesher.h'
+ if(USE_HIGHRES_FOR_MOVIES) then
+ ilocnum = NSPEC_SURFACE_EXT_MESH*NGLLSQUARE
+ else
+ ilocnum = NSPEC_SURFACE_EXT_MESH*NGNOD2D_AVS_DX
+ endif
+ print*,' moviedata element surfaces: ',NSPEC_SURFACE_EXT_MESH
+ print*,' moviedata total elements all: ',ilocnum
+ print *
+
+ if(SAVE_DISPLACEMENT) then
+ print *,'Vertical displacement will be shown in movie'
+ else
+ print *,'Vertical velocity will be shown in movie'
+ endif
+ print *
+
+
+ ! user input
+ print *,'1 = create files in OpenDX format'
+ print *,'2 = create files in AVS UCD format'
+ print *,'3 = create files in GMT xyz Ascii long/lat/Uz format'
+ print *,'any other value = exit'
+ print *
+ print *,'enter value:'
+ read(5,*) iformat
+ if(iformat < 1 .or. iformat > 3) stop 'exiting...'
+
+ plot_shaking_map = .false.
+ print *,'movie frames have been saved every ',NTSTEP_BETWEEN_FRAMES,' time steps'
+ print *
+ print *,'enter first time step of movie (e.g. 1, enter -1 for shaking map)'
+ read(5,*) it1
+ if(it1 == 0 ) it1 = 1
+ if(it1 == -1) plot_shaking_map = .true.
+ if(.not. plot_shaking_map) then
+ print *,'enter last time step of movie (e.g. ',NSTEP,')'
+ read(5,*) it2
+ print *
+ print *,'1 = define file names using frame number'
+ print *,'2 = define file names using time step number'
+ print *,'any other value = exit'
+ print *
+ print *,'enter value:'
+ read(5,*) inumber
+ if(inumber<1 .or. inumber>2) stop 'exiting...'
+ print *
+ print *,'looping from ',it1,' to ',it2,' every ',NTSTEP_BETWEEN_FRAMES,' time steps'
+ ! count number of movie frames
+ nframes = 0
+ do it = it1,it2
+ if(mod(it,NTSTEP_BETWEEN_FRAMES) == 0) nframes = nframes + 1
+ enddo
+ else
+ ! only one frame if shaking map
+ nframes = 1
+ it1 = 1
+ it2 = 1
+ endif
+ print *
+ print *,'total number of frames will be ',nframes
+ if(nframes == 0) stop 'null number of frames'
+
+ iscaling_shake = 0
+ if(plot_shaking_map) then
+ print *
+ print *,'norm to display in shaking map:'
+ print *,'1=displacement 2=velocity 3=acceleration'
+ 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 *,'1= norm of velocity 2=velocity x-comp 3=velocity y-comp 4=velocity z-comp'
+ print *
+ read(5,*) inorm
+ if(inorm < 1 .or. inorm > 4) stop 'incorrect value of inorm'
+ endif
+
+! file format flags
+ if(iformat == 1) then
+ USE_OPENDX = .true.
+ USE_AVS = .false.
+ else if(iformat == 2) then
+ USE_OPENDX = .false.
+ USE_AVS = .true.
+ else
+ USE_OPENDX = .false.
+ USE_AVS = .false.
+ endif
+
+ ! define the total number of elements at the surface
+ if(USE_HIGHRES_FOR_MOVIES) then
+ nspectot_AVS_max = NSPEC_SURFACE_EXT_MESH * (NGLLX-1) * (NGLLY-1)
+ else
+ nspectot_AVS_max = NSPEC_SURFACE_EXT_MESH
+ endif
+
+ ! maximum theoretical number of points at the surface
+ npointot = NGNOD2D_AVS_DX * nspectot_AVS_max
+
+ ! allocate arrays for sorting routine
+ allocate(iglob(npointot),loc(npointot))
+ allocate(ifseg(npointot))
+ allocate(xp(npointot),yp(npointot),zp(npointot))
+ allocate(xp_save(npointot),yp_save(npointot),zp_save(npointot))
+ allocate(field_display(npointot))
+ allocate(mask_point(npointot))
+ allocate(ireorder(npointot))
+
+ ! allocates data arrays
+ allocate(store_val_x(ilocnum))
+ allocate(store_val_y(ilocnum))
+ allocate(store_val_z(ilocnum))
+ allocate(store_val_ux(ilocnum))
+ allocate(store_val_uy(ilocnum))
+ allocate(store_val_uz(ilocnum))
+
+ if(USE_HIGHRES_FOR_MOVIES) then
+ allocate(x(NGLLX,NGLLY))
+ allocate(y(NGLLX,NGLLY))
+ allocate(z(NGLLX,NGLLY))
+ allocate(display(NGLLX,NGLLY))
+ endif
+
+ ! user output
+ print *
+ print *,'there are a total of ',nspectot_AVS_max,' elements at the surface'
+ print *
+ print *
+ if(APPLY_THRESHOLD .and. .not. plot_shaking_map) &
+ print *,'Will apply a threshold to amplitude below ',100.*THRESHOLD,' %'
+ if(NONLINEAR_SCALING .and. (.not. plot_shaking_map .or. iscaling_shake == 1)) &
+ print *,'Will apply a non linear scaling with coef ',POWER_SCALING
+
+
+ iframe = 0
+
+! loop on all the time steps in the range entered
+ do it = it1,it2
+
+ ! check if time step corresponds to a movie frame
+ if(mod(it,NTSTEP_BETWEEN_FRAMES) == 0 .or. plot_shaking_map) then
+
+ iframe = iframe + 1
+
+ print *
+ if(plot_shaking_map) then
+ print *,'reading shaking map snapshot'
+ else
+ print *,'reading snapshot time step ',it,' out of ',NSTEP
+ endif
+ print *
+
+ ! read all the elements from the same file
+ if(plot_shaking_map) then
+ write(outputname,"('/shakingdata')")
+ else
+ write(outputname,"('/moviedata',i6.6)") it
+ endif
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//trim(outputname),status='old', &
+ action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error: ',trim(OUTPUT_FILES)//trim(outputname)
+ stop 'error opening moviedata file'
+ endif
+
+ read(IOUT) store_val_x
+ read(IOUT) store_val_y
+ read(IOUT) store_val_z
+ read(IOUT) store_val_ux
+ read(IOUT) store_val_uy
+ read(IOUT) store_val_uz
+ close(IOUT)
+
+ ! clear number of elements kept
+ ispec = 0
+
+ ! reset point number
+ ipoin = 0
+
+ do ispecloc = 1, NSPEC_SURFACE_EXT_MESH
+
+ if(USE_HIGHRES_FOR_MOVIES) then
+ ! assign the OpenDX "elements"
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ipoin = ipoin + 1
+
+ ! x,y,z coordinates
+ xcoord = store_val_x(ipoin)
+ ycoord = store_val_y(ipoin)
+ zcoord = store_val_z(ipoin)
+
+ ! note:
+ ! for shakemaps: ux = norm displacement, uy = norm velocity, uz = norm acceleration
+ ! for movies: ux = velocity x-component, uy = velocity y-component, uz = velocity z-component
+ vectorx = store_val_ux(ipoin)
+ vectory = store_val_uy(ipoin)
+ vectorz = store_val_uz(ipoin)
+
+ x(i,j) = xcoord
+ y(i,j) = ycoord
+ z(i,j) = zcoord
+
+ ! shakemap
+ if(plot_shaking_map) then
+ !!!! NL NL mute value near source
+ if ( (sqrt(((x(i,j) - (X_SOURCE_EXT_MESH))**2 + &
+ (y(i,j) - (Y_SOURCE_EXT_MESH))**2 + &
+ (z(i,j) - (Z_SOURCE_EXT_MESH))**2)) < RADIUS_TO_MUTE) &
+ .and. MUTE_SOURCE) then
+
+ display(i,j) = 0.
+ else
+ ! chooses norm
+ if(inorm == 1) then
+ ! norm displacement
+ display(i,j) = vectorx
+ else if(inorm == 2) then
+ ! norm velocity
+ display(i,j) = vectory
+ else
+ ! norm acceleration
+ display(i,j) = vectorz
+ endif
+ endif
+ else
+ ! movie
+ if(inorm == 1) then
+ ! norm of velocity
+ display(i,j) = sqrt(vectorz**2+vectory**2+vectorx**2)
+ else if( inorm == 2 ) then
+ ! velocity x-component
+ display(i,j) = vectorx
+ else if( inorm == 3 ) then
+ ! velocity y-component
+ display(i,j) = vectory
+ else if( inorm == 4 ) then
+ ! velocity z-component
+ display(i,j) = vectorz
+ endif
+ endif
+
+ enddo
+ enddo
+
+ ! assign the values of the corners of the OpenDX "elements"
+ ispec = ispec + 1
+ ielm = (NGLLX-1)*(NGLLY-1)*(ispec-1)
+
+ do j = 1,NGLLY-1
+ 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))
+
+ ! 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))
+ zp(ieoff+ilocnum) = dble(z(i,j+1))
+ field_display(ieoff+ilocnum) = dble(display(i,j+1))
+ 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
+
+ else
+ ! low-resolution (only spectral element corners)
+ ispec = ispec + 1
+ ieoff = NGNOD2D_AVS_DX*(ispec-1)
+
+ ! four points for each element
+ do i = 1,NGNOD2D_AVS_DX
+
+ ! accounts for different ordering of square points
+ ilocnum = iorder(i)
+
+ ipoin = ipoin + 1
+
+ xcoord = store_val_x(ipoin)
+ ycoord = store_val_y(ipoin)
+ zcoord = store_val_z(ipoin)
+
+ vectorx = store_val_ux(ipoin)
+ vectory = store_val_uy(ipoin)
+ vectorz = store_val_uz(ipoin)
+
+
+ xp(ilocnum+ieoff) = dble(xcoord)
+ yp(ilocnum+ieoff) = dble(ycoord)
+ zp(ilocnum+ieoff) = dble(zcoord)
+
+ ! shakemap
+ if(plot_shaking_map) then
+ !!!! NL NL mute value near source
+ 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
+ ! norm of displacement
+ field_display(ilocnum+ieoff) = dble(vectorx)
+ else if(inorm == 2) then
+ ! norm of velocity
+ field_display(ilocnum+ieoff) = dble(vectory)
+ else
+ ! norm of acceleration
+ field_display(ilocnum+ieoff) = dble(vectorz)
+ endif
+ endif
+ else
+ ! movie
+ if(inorm == 1) then
+ ! norm of velocity
+ field_display(ilocnum+ieoff) = sqrt(vectorz**2+vectory**2+vectorx**2)
+ else if( inorm == 2 ) then
+ ! velocity x-component
+ field_display(ilocnum+ieoff) = vectorx
+ else if( inorm == 3 ) then
+ ! velocity y-component
+ field_display(ilocnum+ieoff) = vectory
+ else
+ ! velocity z-component
+ field_display(ilocnum+ieoff) = vectorz
+ endif
+ ! takes norm of velocity vector
+ !field_display(ilocnum+ieoff) =sqrt(vectorz**2+vectory**2+vectorx**2)
+ endif
+
+ enddo
+ endif ! USE_HIGHRES_FOR_MOVIES
+ enddo ! NSPEC_SURFACE_EXT_MESH
+
+ ! copy coordinate arrays since the sorting routine does not preserve them
+ xp_save(:) = xp(:)
+ yp_save(:) = yp(:)
+ zp_save(:) = zp(:)
+
+ ! sort the list based upon coordinates to get rid of multiples
+ print *,'sorting list of points'
+ call get_global_AVS(nspectot_AVS_max,xp,yp,zp,iglob,loc,ifseg,nglob,npointot, &
+ dble(minval(store_val_x(:))),dble(maxval(store_val_x(:))))
+
+ ! print total number of points found
+ print *
+ print *,'found a total of ',nglob,' points'
+ print *,'initial number of points (with multiples) was ',npointot
+
+
+ ! normalize and scale vector field
+
+ ! compute min and max of data value to normalize
+ 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 = ',min_field_current
+ print *,'maximum amplitude in current snapshot = ',max_field_current
+ print *
+
+ 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(:))
+ ! 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 *
+ endif
+
+ ! apply scaling in all cases for movies
+ if(.not. plot_shaking_map) then
+
+ ! make sure range is always symmetric and center is in zero
+ ! 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
+
+ ! normalize field to [0:1]
+ if( abs(max_field_current - min_field_current) > TINYVAL ) &
+ field_display(:) = (field_display(:) - min_field_current) / (max_field_current - min_field_current)
+
+ ! rescale to [-1,1]
+ field_display(:) = 2.*field_display(:) - 1.
+
+ ! apply threshold to normalized field
+ 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
+
+ ! map back to [0,1]
+ field_display(:) = (field_display(:) + 1.) / 2.
+
+ ! map field to [0:255] for AVS color scale
+ field_display(:) = 255. * field_display(:)
+
+
+ ! apply scaling only if selected for shaking map
+ else if(NONLINEAR_SCALING .and. iscaling_shake == 1) then
+
+ ! normalize field to [0:1]
+ if( abs(max_field_current) > TINYVAL ) &
+ field_display(:) = field_display(:) / max_field_current
+
+ ! apply non linear scaling to normalized field
+ field_display = field_display ** POWER_SCALING
+
+ ! map field to [0:255] for AVS color scale
+ 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
+ endif
+ endif
+
+ ! create file name and open file
+ if(plot_shaking_map) then
+
+ if(USE_OPENDX) then
+ write(outputname,"('/DX_shaking_map.dx')")
+ open(unit=11,file=trim(OUTPUT_FILES)//outputname,status='unknown')
+ write(11,*) 'object 1 class array type float rank 1 shape 3 items ',nglob,' data follows'
+ else if(USE_AVS) then
+ write(outputname,"('/AVS_shaking_map.inp')")
+ open(unit=11,file=trim(OUTPUT_FILES)//outputname,status='unknown')
+ write(11,*) nglob,' ',nspectot_AVS_max,' 1 0 0'
+ else
+ stop 'wrong output format selected'
+ endif
+
+ else
+
+ if(USE_OPENDX) then
+ write(outputname,"('/DX_movie_',i6.6,'.dx')") ivalue
+ open(unit=11,file=trim(OUTPUT_FILES)//outputname,status='unknown')
+ write(11,*) 'object 1 class array type float rank 1 shape 3 items ',nglob,' data follows'
+ else if(USE_AVS) then
+ write(outputname,"('/AVS_movie_',i6.6,'.inp')") ivalue
+ open(unit=11,file=trim(OUTPUT_FILES)//outputname,status='unknown')
+ write(11,*) nglob,' ',nspectot_AVS_max,' 1 0 0'
+ else
+ stop 'wrong output format selected'
+ endif
+
+ endif
+
+
+ if(.false.) then
+ ! GMT format not implemented yet
+ else
+
+ ! output list of points
+ mask_point = .false.
+ ipoin = 0
+ 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
+ ipoin = ipoin + 1
+ ireorder(ibool_number) = ipoin
+ 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,'(i9,3f16.6)') ireorder(ibool_number),xp_save(ilocnum+ieoff), &
+ yp_save(ilocnum+ieoff),zp_save(ilocnum+ieoff)
+ endif
+ endif
+ mask_point(ibool_number) = .true.
+ enddo
+ enddo
+
+ if(USE_OPENDX) &
+ write(11,*) 'object 2 class array type int rank 1 shape 4 items ',nspectot_AVS_max,' data follows'
+
+ ! output list of elements
+ do ispec=1,nspectot_AVS_max
+ ieoff = NGNOD2D_AVS_DX*(ispec-1)
+ ! four points for each element
+ ibool_number1 = iglob(ieoff + 1)
+ ibool_number2 = iglob(ieoff + 2)
+ ibool_number3 = iglob(ieoff + 3)
+ ibool_number4 = iglob(ieoff + 4)
+ if(USE_OPENDX) then
+ ! point order in OpenDX is 1,4,2,3 *not* 1,2,3,4 as in AVS
+ write(11,"(i10,1x,i10,1x,i10,1x,i10)") ireorder(ibool_number1)-1, &
+ ireorder(ibool_number4)-1,ireorder(ibool_number2)-1,ireorder(ibool_number3)-1
+ else
+ write(11,"(i10,' 1 quad ',i10,1x,i10,1x,i10,1x,i10)") ispec,ireorder(ibool_number1), &
+ ireorder(ibool_number4),ireorder(ibool_number2),ireorder(ibool_number3)
+ 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
+ ! dummy text for labels
+ write(11,*) '1 1'
+ write(11,*) 'a, b'
+ endif
+
+ ! output data values
+ mask_point = .false.
+ 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))
+ else
+ write(11,"(f7.2)") field_display(ilocnum+ieoff)
+ 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.
+ 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
+
+ ! end of test for GMT format
+ endif
+
+ close(11)
+
+ ! end of loop and test on all the time steps for all the movie images
+ endif
+ enddo ! it
+
+ print *
+ print *,'done creating movie or shaking map'
+ print *
+ if(USE_OPENDX) print *,'DX files are stored in ', trim(OUTPUT_FILES), '/DX_*.dx'
+ if(USE_AVS) print *,'AVS files are stored in ', trim(OUTPUT_FILES), '/AVS_*.inp'
+
+ print *
+
+
+ deallocate(store_val_x)
+ deallocate(store_val_y)
+ deallocate(store_val_z)
+ deallocate(store_val_ux)
+ deallocate(store_val_uy)
+ deallocate(store_val_uz)
+
+ ! deallocate arrays for sorting routine
+ deallocate(iglob,loc)
+ deallocate(ifseg)
+ deallocate(xp,yp,zp)
+ deallocate(xp_save,yp_save,zp_save)
+ deallocate(field_display)
+ deallocate(mask_point)
+ deallocate(ireorder)
+
+ if(USE_HIGHRES_FOR_MOVIES) then
+ deallocate(x)
+ deallocate(y)
+ deallocate(z)
+ deallocate(display)
+ endif
+
+ end program create_movie_AVS_DX
+
+!
+!=====================================================================
+!
+
+ subroutine get_global_AVS(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot,UTM_X_MIN,UTM_X_MAX)
+
+! this routine MUST be in double precision to avoid sensitivity
+! to roundoff errors in the coordinates of the points
+
+! leave sorting subroutines in same source file to allow for inlining
+
+ implicit none
+
+ 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
+
+ integer npointot
+ integer iglob(npointot),loc(npointot)
+ logical ifseg(npointot)
+ double precision xp(npointot),yp(npointot),zp(npointot)
+ integer nspec,nglob
+
+ integer ispec,i,j
+ integer ieoff,ilocnum,nseg,ioff,iseg,ig
+
+ integer, dimension(:), allocatable :: ind,ninseg,iwork
+ double precision, dimension(:), allocatable :: work
+
+ double precision UTM_X_MIN,UTM_X_MAX
+
+! define geometrical tolerance based upon typical size of the model
+ SMALLVALTOL = 1.d-10 * dabs(UTM_X_MAX - UTM_X_MIN)
+ print *, 'UTM_X_MAX', UTM_X_MAX
+ print *, 'UTM_X_MIN', UTM_X_MIN
+ print *, 'SMALLVALTOL', SMALLVALTOL
+
+! dynamically allocate arrays
+ allocate(ind(npointot))
+ allocate(ninseg(npointot))
+ allocate(iwork(npointot))
+ allocate(work(npointot))
+
+! establish initial pointers
+ do ispec=1,nspec
+ ieoff=NGNOD2D_AVS_DX*(ispec-1)
+ do ilocnum=1,NGNOD2D_AVS_DX
+ loc(ilocnum+ieoff)=ilocnum+ieoff
+ enddo
+ enddo
+
+ ifseg(:)=.false.
+
+ nseg=1
+ ifseg(1)=.true.
+ ninseg(1)=npointot
+
+ do j=1,NDIM
+
+! sort within each segment
+ ioff=1
+ do iseg=1,nseg
+ if(j == 1) then
+ call rank(xp(ioff),ind,ninseg(iseg))
+ else 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
+ do i=2,npointot
+ if(dabs(xp(i)-xp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
+ 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
+ do i=1,npointot
+ if(ifseg(i)) ig=ig+1
+ iglob(loc(i))=ig
+ enddo
+
+ nglob=ig
+
+! deallocate arrays
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iwork)
+ deallocate(work)
+
+ end subroutine get_global_AVS
+
+! -----------------------------------
+
+! sorting routines put in same file to allow for inlining
+
+ subroutine rank(A,IND,N)
+!
+! Use Heap Sort (Numerical Recipes)
+!
+ implicit none
+
+ integer n
+ double precision A(n)
+ integer IND(n)
+
+ integer i,j,l,ir,indx
+ double precision q
+
+ do j=1,n
+ IND(j)=j
+ enddo
+
+ if (n == 1) return
+
+ L=n/2+1
+ ir=n
+ 100 CONTINUE
+ IF (l>1) THEN
+ l=l-1
+ indx=ind(l)
+ q=a(indx)
+ ELSE
+ indx=ind(ir)
+ q=a(indx)
+ ind(ir)=ind(1)
+ ir=ir-1
+ if (ir == 1) then
+ ind(1)=indx
+ return
+ endif
+ ENDIF
+ i=l
+ j=l+l
+ 200 CONTINUE
+ IF (J <= IR) THEN
+ IF (J<IR) THEN
+ IF ( A(IND(j))<A(IND(j+1)) ) j=j+1
+ ENDIF
+ IF (q<A(IND(j))) THEN
+ IND(I)=IND(J)
+ I=J
+ J=J+J
+ ELSE
+ J=IR+1
+ ENDIF
+ goto 200
+ ENDIF
+ IND(I)=INDX
+ goto 100
+ end subroutine rank
+
+! ------------------------------------------------------------------
+
+ subroutine swap_all(IA,A,B,C,IW,W,ind,n)
+!
+! swap arrays IA, A, B and C according to addressing in array IND
+!
+ implicit none
+
+ integer n
+
+ integer IND(n)
+ integer IA(n),IW(n)
+ double precision A(n),B(n),C(n),W(n)
+
+ integer i
+
+ IW(:) = IA(:)
+ W(:) = A(:)
+
+ do i=1,n
+ IA(i)=IW(ind(i))
+ A(i)=W(ind(i))
+ enddo
+
+ W(:) = B(:)
+
+ do i=1,n
+ B(i)=W(ind(i))
+ enddo
+
+ W(:) = C(:)
+
+ do i=1,n
+ C(i)=W(ind(i))
+ enddo
+
+ end subroutine swap_all
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_name_database.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_name_database.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_name_database.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,47 @@
+!=====================================================================
+!
+! 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 create_name_database(prname,iproc,LOCAL_PATH)
+
+! create the name of the database for the mesher and the solver
+
+ implicit none
+
+ integer iproc
+
+! name of the database file
+ character(len=256) prname,procname,LOCAL_PATH,clean_LOCAL_PATH
+
+! create the name for the database of the current slide and region
+ write(procname,"('/proc',i6.6,'_')") iproc
+
+! suppress white spaces if any
+ clean_LOCAL_PATH = adjustl(LOCAL_PATH)
+
+! create full name with path
+ prname = clean_LOCAL_PATH(1:len_trim(clean_LOCAL_PATH)) // procname
+
+ end subroutine create_name_database
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_regions_mesh.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_regions_mesh.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_regions_mesh.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,720 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+! main routine
+
+subroutine create_regions_mesh_ext(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, &
+ num_interfaces_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, &
+ ANISOTROPY,NPROC,OCEANS, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION,NX_TOPO,NY_TOPO, &
+ ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO, &
+ itopo_bathy)
+
+! create the different regions of the mesh
+
+ use create_regions_mesh_ext_par
+ use fault_object, only: fault_read_input, fault_setup, fault_save_arrays_test, fault_save_arrays, &
+ fault_db
+
+ implicit none
+
+! number of spectral elements in each block
+ integer :: nspec
+
+! arrays with the mesh
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
+
+ integer :: npointot
+
+! proc numbers for MPI
+ integer :: myrank
+ integer :: NPROC
+
+ character(len=256) :: LOCAL_PATH
+
+! 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
+
+! static memory size needed by the solver
+ double precision :: max_static_memory_size
+
+ integer, dimension(2,nelmnts_ext_mesh) :: mat_ext_mesh
+
+! material properties
+ integer :: nmat_ext_mesh,nundefMat_ext_mesh
+ double precision, dimension(6,nmat_ext_mesh) :: materials_ext_mesh
+ character (len=30), dimension(6,nundefMat_ext_mesh):: undef_mat_prop
+
+! double precision, external :: materials_ext_mesh
+
+! MPI communication
+ integer :: num_interfaces_ext_mesh,max_interface_size_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: my_neighbours_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: my_nelmnts_neighbours_ext_mesh
+ integer, dimension(6,max_interface_size_ext_mesh,num_interfaces_ext_mesh) :: my_interfaces_ext_mesh
+ integer, dimension(NGLLX*NGLLX*max_interface_size_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh
+
+! absorbing boundaries
+ 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
+ ! 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
+
+ integer :: nglob
+
+ logical :: SAVE_MESH_FILES
+ logical :: ANISOTROPY
+ logical :: OCEANS
+
+! use integer array to store topography values
+ integer :: UTM_PROJECTION_ZONE
+ logical :: SUPPRESS_UTM_PROJECTION
+ integer :: NX_TOPO,NY_TOPO
+ double precision :: ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO
+ integer, dimension(NX_TOPO,NY_TOPO) :: itopo_bathy
+
+! local parameters
+! static memory size needed by the solver
+ double precision :: static_memory_size
+ real(kind=CUSTOM_REAL) :: model_speed_max
+
+! for vtk output
+! character(len=256) prname_file
+! integer,dimension(:),allocatable :: itest_flag
+! integer, dimension(:), allocatable :: elem_flag
+
+! For Piero Basini :
+! integer :: doubling_value_found_for_Piero
+! double precision :: xmesh,ymesh,zmesh
+! double precision :: rho,vp,vs
+
+! integer,dimension(nspec) :: idoubling
+! integer :: doubling_value_found_for_Piero
+! integer, parameter :: NUMBER_OF_STATIONS = 6
+! double precision, parameter :: RADIUS_TO_EXCLUDE = 250.d0
+! double precision, dimension(NUMBER_OF_STATIONS) :: utm_x_station,utm_y_station
+
+! logical :: is_around_a_station
+! integer :: istation
+
+! ! store bedrock values
+! integer :: icornerlat,icornerlong
+! double precision :: lat,long,elevation_bedrock
+! double precision :: lat_corner,long_corner,ratio_xi,ratio_eta
+!real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: ibedrock
+
+ ! for dynamic faults
+
+! initializes arrays
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' ...allocating arrays '
+ endif
+ call crm_ext_allocate_arrays(nspec,LOCAL_PATH,myrank, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ nspec2D_bottom,nspec2D_top,ANISOTROPY)
+
+
+! 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 crm_ext_setup_jacobian(myrank, &
+ xstore,ystore,zstore,nspec, &
+ nodes_coords_ext_mesh,nnodes_ext_mesh,&
+ elmnts_ext_mesh,nelmnts_ext_mesh)
+
+! creates ibool index array for projection from local to global points
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...indexing global points'
+ endif
+
+! If the mesh contains faults we split the fault nodes
+! and generate the fault database ...
+! The node splitting procedure changes ibool size (nglob)
+! and creates Kevin_voigt_eta values .(0 : no damping).
+
+
+! crm_ext_setup_indexing : computes xstore , ystore , zstore.
+ call crm_ext_setup_indexing(ibool, &
+ xstore,ystore,zstore,nspec,nglob,npointot, &
+ nnodes_ext_mesh,nodes_coords_ext_mesh,myrank)
+
+!NEW : Here loading fault ispec and fault iface.
+ call fault_read_input()
+
+
+ if (allocated(fault_db)) call fault_setup (ibool,xstore,ystore,zstore,nspec,nglob,prname,myrank)
+! else
+! call crm_ext_setup_indexing(ibool, &
+! xstore,ystore,zstore,nspec,nglob,npointot, &
+! nnodes_ext_mesh,nodes_coords_ext_mesh,myrank)
+! endif
+
+
+! sets up MPI interfaces between partitions
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...preparing MPI interfaces '
+ endif
+ call get_MPI(myrank,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, &
+ num_interfaces_ext_mesh,max_interface_size_ext_mesh,&
+ my_neighbours_ext_mesh,NPROC)
+
+! sets material velocities
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...determining velocity model'
+ endif
+ call get_model(myrank,nspec,ibool,mat_ext_mesh,nelmnts_ext_mesh, &
+ materials_ext_mesh,nmat_ext_mesh, &
+ undef_mat_prop,nundefMat_ext_mesh, &
+ ANISOTROPY)
+
+! sets up absorbing/free surface boundaries
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...setting up absorbing boundaries '
+ endif
+ call get_absorbing_boundary(myrank,nspec,nglob,ibool, &
+ nodes_coords_ext_mesh,nnodes_ext_mesh, &
+ 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)
+
+! sets up acoustic-elastic coupling surfaces
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...detecting acoustic-elastic surfaces '
+ endif
+ call get_coupling_surfaces(myrank, &
+ nspec,nglob,ibool,NPROC, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ num_interfaces_ext_mesh,max_interface_size_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+
+! creates mass matrix
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...creating mass matrix '
+ endif
+ call create_mass_matrices(nglob,nspec,ibool)
+
+! creates ocean load mass matrix
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...creating ocean load mass matrix '
+ endif
+ call create_mass_matrices_ocean_load(nglob,nspec,ibool,OCEANS,&
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION,NX_TOPO,NY_TOPO, &
+ ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO, &
+ itopo_bathy)
+
+! saves the binary mesh 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, &
+ rhostore,kappastore,mustore, &
+ rmass,rmass_acoustic,rmass_solid_poroelastic,rmass_fluid_poroelastic, &
+ OCEANS,rmass_ocean_load,NGLOB_OCEAN,ibool,xstore_dummy,ystore_dummy,zstore_dummy, &
+ abs_boundary_normal,abs_boundary_jacobian2Dw, &
+ abs_boundary_ijk,abs_boundary_ispec,num_abs_boundary_faces, &
+ free_surface_normal,free_surface_jacobian2Dw, &
+ free_surface_ijk,free_surface_ispec,num_free_surface_faces, &
+ coupling_ac_el_normal,coupling_ac_el_jacobian2Dw, &
+ coupling_ac_el_ijk,coupling_ac_el_ispec,num_coupling_ac_el_faces, &
+ num_interfaces_ext_mesh,my_neighbours_ext_mesh,nibool_interfaces_ext_mesh, &
+ max_interface_size_ext_mesh,ibool_interfaces_ext_mesh, &
+ prname,SAVE_MESH_FILES,ANISOTROPY,NSPEC_ANISO, &
+ c11store,c12store,c13store,c14store,c15store,c16store, &
+ c22store,c23store,c24store,c25store,c26store,c33store, &
+ c34store,c35store,c36store,c44store,c45store,c46store, &
+ c55store,c56store,c66store, &
+ ispec_is_acoustic,ispec_is_elastic,ispec_is_poroelastic)
+
+!Percy : save fault database
+
+ call fault_save_arrays_test(prname,IOUT) ! for debugging
+ call fault_save_arrays(prname,IOUT)
+
+! computes the approximate amount of static memory needed to run the solver
+ call memory_eval(nspec,nglob,maxval(nibool_interfaces_ext_mesh),num_interfaces_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, model_speed_max )
+
+! 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 write_VTK_data_elem_i(nspec,nglob, &
+! xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+! elem_flag,prname_file)
+! deallocate(elem_flag)
+!
+! !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 write_VTK_data_elem_i(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
+ if( .not. SAVE_MOHO_MESH ) deallocate(xstore_dummy,ystore_dummy,zstore_dummy)
+ deallocate(xixstore,xiystore,xizstore,&
+ etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore)
+ deallocate(jacobianstore,iflag_attenuation_store)
+ deallocate(kappastore,mustore,rho_vp,rho_vs)
+
+end subroutine create_regions_mesh_ext
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine crm_ext_allocate_arrays(nspec,LOCAL_PATH,myrank, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ nspec2D_bottom,nspec2D_top,ANISOTROPY)
+
+ use create_regions_mesh_ext_par
+ implicit none
+
+ integer :: nspec,myrank
+ integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ nspec2D_bottom,nspec2D_top
+
+ character(len=256) :: LOCAL_PATH
+
+ logical :: ANISOTROPY
+
+! local parameters
+ integer :: ier
+
+! memory test
+! logical,dimension(:),allocatable :: test_mem
+!
+! 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( xelm(NGNOD),yelm(NGNOD),zelm(NGNOD),stat=ier)
+
+ allocate( iflag_attenuation_store(NGLLX,NGLLY,NGLLZ,nspec),stat=ier)
+ if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+
+! create the name for the database of the current slide and region
+ call create_name_database(prname,myrank,LOCAL_PATH)
+
+! Gauss-Lobatto-Legendre points of integration
+ allocate(xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ))
+
+! Gauss-Lobatto-Legendre weights of integration
+ 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)
+
+! 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), 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')
+
+! Stacey
+ 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),stat=ier)
+ !vpstore(NGLLX,NGLLY,NGLLZ,nspec), &
+ !vsstore(NGLLX,NGLLY,NGLLZ,nspec),
+ 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), &
+ jacobianstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier)
+ if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+
+! absorbing boundary
+ ! absorbing faces
+ num_abs_boundary_faces = nspec2D_xmin + nspec2D_xmax + nspec2D_ymin + nspec2D_ymax + nspec2D_bottom
+ ! adds faces of free surface if it also absorbs
+ if( ABSORB_FREE_SURFACE ) num_abs_boundary_faces = num_abs_boundary_faces + nspec2D_top
+
+ ! allocates arrays to store info for each face (assumes NGLLX=NGLLY=NGLLZ)
+ allocate( abs_boundary_ispec(num_abs_boundary_faces), &
+ abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces), &
+ abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces), &
+ abs_boundary_normal(NDIM,NGLLSQUARE,num_abs_boundary_faces),stat=ier)
+ if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+
+! free surface
+ ! free surface faces
+ if( ABSORB_FREE_SURFACE ) then
+ ! no free surface - uses a dummy size
+ num_free_surface_faces = 1
+ else
+ num_free_surface_faces = nspec2D_top
+ endif
+
+ ! allocates arrays to store info for each face (assumes NGLLX=NGLLY=NGLLZ)
+ allocate( free_surface_ispec(num_free_surface_faces), &
+ free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces), &
+ free_surface_jacobian2Dw(NGLLSQUARE,num_free_surface_faces), &
+ free_surface_normal(NDIM,NGLLSQUARE,num_free_surface_faces),stat=ier)
+ if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+
+! array with anisotropy
+ if( ANISOTROPY ) then
+ NSPEC_ANISO = nspec
+ else
+ NSPEC_ANISO = 1
+ endif
+ allocate(c11store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c12store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c13store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c14store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c15store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c16store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c22store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c23store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c24store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c25store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c26store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c33store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c34store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c35store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c36store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c44store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c45store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c46store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c55store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c56store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO), &
+ c66store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO),stat=ier)
+ if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+
+! material flags
+ allocate( ispec_is_acoustic(nspec), &
+ ispec_is_elastic(nspec), &
+ ispec_is_poroelastic(nspec), stat=ier)
+ if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+
+end subroutine crm_ext_allocate_arrays
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine crm_ext_setup_jacobian(myrank, &
+ xstore,ystore,zstore,nspec, &
+ nodes_coords_ext_mesh,nnodes_ext_mesh,&
+ elmnts_ext_mesh,nelmnts_ext_mesh)
+
+ use create_regions_mesh_ext_par
+ implicit none
+
+! number of spectral elements in each block
+ integer :: nspec
+
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
+
+! 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
+
+! proc numbers for MPI
+ integer :: myrank
+
+! local parameters
+ integer :: ispec,ia,i,j,k
+
+! set up coordinates of the Gauss-Lobatto-Legendre points
+ call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
+
+! if number of points is odd, the middle abscissa is exactly zero
+ if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO
+ if(mod(NGLLY,2) /= 0) yigll((NGLLY-1)/2+1) = ZERO
+ if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO
+
+! get the 3-D shape functions
+ call get_shape3D(myrank,shape3D,dershape3D,xigll,yigll,zigll)
+
+! get the 2-D shape functions
+ call get_shape2D(myrank,shape2D_x,dershape2D_x,yigll,zigll,NGLLY,NGLLZ)
+ call get_shape2D(myrank,shape2D_y,dershape2D_y,xigll,zigll,NGLLX,NGLLZ)
+ call get_shape2D(myrank,shape2D_bottom,dershape2D_bottom,xigll,yigll,NGLLX,NGLLY)
+ call get_shape2D(myrank,shape2D_top,dershape2D_top,xigll,yigll,NGLLX,NGLLY)
+
+! 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
+
+! point locations
+ xstore(:,:,:,:) = 0.d0
+ ystore(:,:,:,:) = 0.d0
+ zstore(:,:,:,:) = 0.d0
+ do ispec = 1, nspec
+ !call get_xyzelm(xelm, yelm, zelm, ispec, elmnts_ext_mesh, nodes_coords_ext_mesh, nspec, nnodes_ext_mesh)
+ do ia = 1,NGNOD
+ xelm(ia) = nodes_coords_ext_mesh(1,elmnts_ext_mesh(ia,ispec))
+ yelm(ia) = nodes_coords_ext_mesh(2,elmnts_ext_mesh(ia,ispec))
+ zelm(ia) = nodes_coords_ext_mesh(3,elmnts_ext_mesh(ia,ispec))
+ enddo
+ ! CUBIT should provide a mesh ordering such that the 3D jacobian is defined
+ ! (otherwise mesh would be degenerated)
+ call calc_jacobian(myrank,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore,jacobianstore, &
+ xstore,ystore,zstore, &
+ xelm,yelm,zelm,shape3D,dershape3D,ispec,nspec)
+ enddo
+
+end subroutine crm_ext_setup_jacobian
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine crm_ext_setup_indexing(ibool, &
+ xstore,ystore,zstore,nspec,nglob,npointot, &
+ nnodes_ext_mesh,nodes_coords_ext_mesh,myrank)
+
+! creates global indexing array ibool
+
+ use create_regions_mesh_ext_par
+ implicit none
+
+! 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,iglobnum
+
+! 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
+ yp = 0.d0
+ 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)
+ 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'
+
+! 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
+
+end subroutine crm_ext_setup_indexing
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_regions_mesh_ext_par.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_regions_mesh_ext_par.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_regions_mesh_ext_par.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,81 @@
+module create_regions_mesh_ext_par
+
+ include 'constants.h'
+
+! global point coordinates
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: xstore_dummy
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: ystore_dummy
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: zstore_dummy
+
+! Gauss-Lobatto-Legendre points and weights of integration
+ double precision, dimension(:), allocatable :: xigll,yigll,zigll,wxgll,wygll,wzgll
+
+! 3D shape functions and their derivatives
+ double precision, dimension(:,:,:,:), allocatable :: shape3D
+ double precision, dimension(:,:,:,:,:), allocatable :: dershape3D
+
+ double precision, dimension(:), allocatable :: xelm,yelm,zelm
+
+! arrays with mesh parameters
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore,jacobianstore
+
+! for model density, kappa, mu
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rhostore,kappastore,mustore
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass,rmass_acoustic,&
+ rmass_solid_poroelastic,rmass_fluid_poroelastic
+
+! ocean load
+ integer :: NGLOB_OCEAN
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_ocean_load
+
+! attenuation
+ integer, dimension(:,:,:,:), allocatable :: iflag_attenuation_store
+
+! 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 boundary arrays (for all boundaries) - keeps all infos, allowing for irregular surfaces
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: abs_boundary_normal
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: abs_boundary_jacobian2Dw
+ integer, dimension(:,:,:), allocatable :: abs_boundary_ijk
+ integer, dimension(:), allocatable :: abs_boundary_ispec
+ integer :: num_abs_boundary_faces
+
+! free surface arrays
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: free_surface_normal
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: free_surface_jacobian2Dw
+ integer, dimension(:,:,:), allocatable :: free_surface_ijk
+ integer, dimension(:), allocatable :: free_surface_ispec
+ integer :: num_free_surface_faces
+
+! acoustic-elastic coupling surface
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: coupling_ac_el_normal
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: coupling_ac_el_jacobian2Dw
+ integer, dimension(:,:,:), allocatable :: coupling_ac_el_ijk
+ integer, dimension(:), allocatable :: coupling_ac_el_ispec
+ integer :: num_coupling_ac_el_faces
+
+! for stacey
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_vp,rho_vs
+
+! anisotropy
+ integer :: NSPEC_ANISO
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ c11store,c12store,c13store,c14store,c15store,c16store,&
+ c22store,c23store,c24store,c25store,c26store,c33store,&
+ c34store,c35store,c36store,c44store,c45store,c46store,&
+ c55store,c56store,c66store
+
+! material domain flags
+ logical, dimension(:), allocatable :: ispec_is_acoustic,ispec_is_elastic,ispec_is_poroelastic
+
+! name of the database file
+ character(len=256) prname
+
+end module create_regions_mesh_ext_par
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_regions_mesh_par.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_regions_mesh_par.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_regions_mesh_par.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,84 @@
+module create_regions_mesh_ext_par
+
+ include 'constants.h'
+
+! global point coordinates
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: xstore_dummy
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: ystore_dummy
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: zstore_dummy
+
+! Gauss-Lobatto-Legendre points and weights of integration
+ double precision, dimension(:), allocatable :: xigll,yigll,zigll,wxgll,wygll,wzgll
+
+! 3D shape functions and their derivatives
+ double precision, dimension(:,:,:,:), allocatable :: shape3D
+ double precision, dimension(:,:,:,:,:), allocatable :: dershape3D
+
+ double precision, dimension(:), allocatable :: xelm,yelm,zelm
+
+! arrays with mesh parameters
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore,jacobianstore
+
+! for model density, kappa, mu
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rhostore,kappastore,mustore
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass,rmass_acoustic,&
+ rmass_solid_poroelastic,rmass_fluid_poroelastic
+
+! ocean load
+ integer :: NGLOB_OCEAN
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_ocean_load
+
+! attenuation
+ integer, dimension(:,:,:,:), allocatable :: iflag_attenuation_store
+
+! 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 boundary arrays (for all boundaries) - keeps all infos, allowing for irregular surfaces
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: abs_boundary_normal
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: abs_boundary_jacobian2Dw
+ integer, dimension(:,:,:), allocatable :: abs_boundary_ijk
+ integer, dimension(:), allocatable :: abs_boundary_ispec
+ integer :: num_abs_boundary_faces
+
+! free surface arrays
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: free_surface_normal
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: free_surface_jacobian2Dw
+ integer, dimension(:,:,:), allocatable :: free_surface_ijk
+ integer, dimension(:), allocatable :: free_surface_ispec
+ integer :: num_free_surface_faces
+
+! acoustic-elastic coupling surface
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: coupling_ac_el_normal
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: coupling_ac_el_jacobian2Dw
+ integer, dimension(:,:,:), allocatable :: coupling_ac_el_ijk
+ integer, dimension(:), allocatable :: coupling_ac_el_ispec
+ integer :: num_coupling_ac_el_faces
+
+! for stacey
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_vp,rho_vs
+
+! anisotropy
+ integer :: NSPEC_ANISO
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ c11store,c12store,c13store,c14store,c15store,c16store,&
+ c22store,c23store,c24store,c25store,c26store,c33store,&
+ c34store,c35store,c36store,c44store,c45store,c46store,&
+ c55store,c56store,c66store
+
+! material domain flags
+ logical, dimension(:), allocatable :: ispec_is_acoustic,ispec_is_elastic,ispec_is_poroelastic
+
+! name of the database file
+ character(len=256) prname
+
+end module create_regions_mesh_ext_par
+
+!
+!-------------------------------------------------------------------------------------------------
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_serial_name_database.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_serial_name_database.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/create_serial_name_database.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,86 @@
+!=====================================================================
+!
+! 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 create_serial_name_database(prname,iproc,LOCAL_PATH,NPROC,OUTPUT_FILES)
+
+! create name of the database for serial codes (AVS_DX and codes to check buffers)
+
+ implicit none
+
+ include "constants.h"
+
+ integer iproc,NPROC
+
+! name of the database file
+ character(len=256) prname,procname,LOCAL_PATH,clean_LOCAL_PATH,serial_prefix,OUTPUT_FILES
+
+ integer iprocloop,nproc_max_loop
+ integer, dimension(:), allocatable :: num_active_proc
+
+ nproc_max_loop = NPROC-1
+
+! create the name for the database of the current slide and region
+ write(procname,"('/proc',i6.6,'_')") iproc
+
+! on a Beowulf-type machine, path on frontend can be different from local paths
+ if(.not. LOCAL_PATH_IS_ALSO_GLOBAL) then
+
+! allocate array for active processors
+ allocate(num_active_proc(0:nproc_max_loop))
+
+! read filtered file with name of active machines
+ open(unit=48,file=trim(OUTPUT_FILES)//'/filtered_machines.txt',status='old',action='read')
+ do iprocloop = 0,nproc_max_loop
+ read(48,*) num_active_proc(iprocloop)
+ enddo
+ close(48)
+
+! create the serial prefix pointing to the correct machine
+ write(serial_prefix,"('/auto/scratch_n',i6.6,'/')") num_active_proc(iproc)
+
+! suppress everything until the last "/" to define the base name of local path
+! this is system dependent since it assumes the disks are mounted
+! as on our Beowulf (Unix and NFS)
+ clean_LOCAL_PATH = LOCAL_PATH(index(LOCAL_PATH,'/',.true.)+1:len_trim(LOCAL_PATH))
+
+! create full name with path
+ prname = serial_prefix(1:len_trim(serial_prefix)) // clean_LOCAL_PATH(1:len_trim(clean_LOCAL_PATH)) // procname
+
+! deallocate array
+ deallocate(num_active_proc)
+
+! on shared-memory machines, global path is the same as local path
+ else
+
+! suppress white spaces if any
+ clean_LOCAL_PATH = adjustl(LOCAL_PATH)
+
+! create full name with path
+ prname = clean_LOCAL_PATH(1:len_trim(clean_LOCAL_PATH)) // procname
+
+ endif
+
+ end subroutine create_serial_name_database
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/define_derivation_matrices.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/define_derivation_matrices.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/define_derivation_matrices.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,157 @@
+!=====================================================================
+!
+! 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 define_derivation_matrices(xigll,yigll,zigll,wxgll,wygll,wzgll, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz)
+
+ implicit none
+
+ include "constants.h"
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll,wxgll
+ double precision, dimension(NGLLY) :: yigll,wygll
+ double precision, dimension(NGLLZ) :: zigll,wzgll
+
+! array with derivatives of Lagrange polynomials and precalculated products
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLX) :: hprime_xx,hprimewgll_xx
+ real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+ 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
+
+! function for calculating derivatives of Lagrange polynomials
+ double precision, external :: lagrange_deriv_GLL
+
+ integer i,j,k,i1,i2,j1,j2,k1,k2
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! set up coordinates of the Gauss-Lobatto-Legendre points
+ call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
+
+! if number of points is odd, the middle abscissa is exactly ZERO
+ if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO
+ if(mod(NGLLY,2) /= 0) yigll((NGLLY-1)/2+1) = ZERO
+ if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+
+! calculate derivatives of the Lagrange polynomials
+! and precalculate some products in double precision
+! hprime(i,j) = h'_j(xigll_i) by definition of the derivation matrix
+ do i1=1,NGLLX
+ do i2=1,NGLLX
+ hprime_xx(i2,i1) = sngl(lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX))
+ hprimewgll_xx(i2,i1) = sngl(lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)*wxgll(i2))
+ enddo
+ enddo
+
+ do j1=1,NGLLY
+ do j2=1,NGLLY
+ hprime_yy(j2,j1) = sngl(lagrange_deriv_GLL(j1-1,j2-1,yigll,NGLLY))
+ hprimewgll_yy(j2,j1) = sngl(lagrange_deriv_GLL(j1-1,j2-1,yigll,NGLLY)*wygll(j2))
+ enddo
+ enddo
+
+ do k1=1,NGLLZ
+ do k2=1,NGLLZ
+ hprime_zz(k2,k1) = sngl(lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ))
+ hprimewgll_zz(k2,k1) = sngl(lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)*wzgll(k2))
+ enddo
+ enddo
+
+ do i=1,NGLLX
+ do j=1,NGLLY
+ wgllwgll_xy(i,j) = sngl(wxgll(i)*wygll(j))
+ enddo
+ enddo
+
+ do i=1,NGLLX
+ do k=1,NGLLZ
+ wgllwgll_xz(i,k) = sngl(wxgll(i)*wzgll(k))
+ enddo
+ enddo
+
+ do j=1,NGLLY
+ do k=1,NGLLZ
+ wgllwgll_yz(j,k) = sngl(wygll(j)*wzgll(k))
+ enddo
+ enddo
+
+ else ! double precision version
+
+! calculate derivatives of the Lagrange polynomials
+! and precalculate some products in double precision
+! hprime(i,j) = h'_j(xigll_i) by definition of the derivation matrix
+ do i1=1,NGLLX
+ do i2=1,NGLLX
+ hprime_xx(i2,i1) = lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)
+ hprimewgll_xx(i2,i1) = lagrange_deriv_GLL(i1-1,i2-1,xigll,NGLLX)*wxgll(i2)
+ enddo
+ enddo
+
+ do j1=1,NGLLY
+ do j2=1,NGLLY
+ hprime_yy(j2,j1) = lagrange_deriv_GLL(j1-1,j2-1,yigll,NGLLY)
+ hprimewgll_yy(j2,j1) = lagrange_deriv_GLL(j1-1,j2-1,yigll,NGLLY)*wygll(j2)
+ enddo
+ enddo
+
+ do k1=1,NGLLZ
+ do k2=1,NGLLZ
+ hprime_zz(k2,k1) = lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)
+ hprimewgll_zz(k2,k1) = lagrange_deriv_GLL(k1-1,k2-1,zigll,NGLLZ)*wzgll(k2)
+ enddo
+ enddo
+
+ do i=1,NGLLX
+ do j=1,NGLLY
+ wgllwgll_xy(i,j) = wxgll(i)*wygll(j)
+ enddo
+ enddo
+
+ do i=1,NGLLX
+ do k=1,NGLLZ
+ wgllwgll_xz(i,k) = wxgll(i)*wzgll(k)
+ enddo
+ enddo
+
+ do j=1,NGLLY
+ do k=1,NGLLZ
+ wgllwgll_yz(j,k) = wygll(j)*wzgll(k)
+ enddo
+ enddo
+
+ endif
+
+ end subroutine define_derivation_matrices
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/define_subregions.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/define_subregions.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/define_subregions.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,863 @@
+!=====================================================================
+!
+! 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 define_subregions(myrank,isubregion,iaddx,iaddy,iaddz, &
+ ix1,ix2,dix,iy1,iy2,diy,ir1,ir2,dir,iax,iay,iar, &
+ doubling_index,npx,npy, &
+ NER_BOTTOM_MOHO,NER_MOHO_16,NER_16_BASEMENT,NER_BASEMENT_SEDIM,NER_SEDIM,NER,USE_REGULAR_MESH)
+
+! define shape of elements in current subregion of the mesh
+
+ implicit none
+
+ include "constants.h"
+
+ integer myrank
+ integer ix1,ix2,dix,iy1,iy2,diy,ir1,ir2,dir
+ integer iax,iay,iar
+ integer isubregion,doubling_index
+ integer npx,npy
+
+ integer NER_BOTTOM_MOHO,NER_MOHO_16,NER_16_BASEMENT,NER_BASEMENT_SEDIM,NER_SEDIM,NER
+
+ logical USE_REGULAR_MESH
+
+! topology of the elements
+ integer iaddx(NGNOD)
+ integer iaddy(NGNOD)
+ integer iaddz(NGNOD)
+
+! **************
+
+!
+!--- case of a regular mesh
+!
+ if(USE_REGULAR_MESH) then
+
+! use two layers even for a regular mesh, because the algorithm detects the top of the mesh
+! (the "topography") based on one layer of elements with flag IFLAG_ONE_LAYER_TOPOGRAPHY
+ if(isubregion == 2) then
+
+ call usual_hex_nodes(iaddx,iaddy,iaddz)
+
+ iy1=0
+ iy2=npy-2
+ diy=2
+
+ ix1=0
+ ix2=npx-2
+ dix=2
+
+ ir1=0
+ ir2=2*(NER - 2)
+ dir=2
+
+ iax=1
+ iay=1
+ iar=1
+
+ doubling_index = IFLAG_BASEMENT_TOPO
+
+ else if(isubregion == 1) then
+
+ call usual_hex_nodes(iaddx,iaddy,iaddz)
+
+ iy1=0
+ iy2=npy-2
+ diy=2
+
+ ix1=0
+ ix2=npx-2
+ dix=2
+
+ ir1=2*(NER - 1)
+ ir2=ir1
+ dir=2
+
+ iax=1
+ iay=1
+ iar=1
+
+ doubling_index = IFLAG_ONE_LAYER_TOPOGRAPHY
+
+ else
+
+ call exit_MPI(myrank,'incorrect subregion code')
+
+ endif
+
+!
+!--- case of a non-regular mesh with mesh doublings
+!
+ else
+
+! this last region only defined when NER_SEDIM > 1
+ if(isubregion == 30) then
+
+ call usual_hex_nodes(iaddx,iaddy,iaddz)
+
+ iy1=0
+ iy2=npy-2
+ diy=2
+
+ ix1=0
+ ix2=npx-2
+ dix=2
+
+ ir1=2*(NER - NER_SEDIM)
+ ir2=2*(NER - 2)
+ dir=2
+
+ iax=1
+ iay=1
+ iar=1
+
+ doubling_index = IFLAG_BASEMENT_TOPO
+
+ else if(isubregion == 29) then
+
+ call usual_hex_nodes(iaddx,iaddy,iaddz)
+
+ iy1=0
+ iy2=npy-2
+ diy=2
+
+ ix1=0
+ ix2=npx-2
+ dix=2
+
+ ir1=2*(NER - 1)
+ ir2=ir1
+ dir=2
+
+ iax=1
+ iay=1
+ iar=1
+
+ doubling_index = IFLAG_ONE_LAYER_TOPOGRAPHY
+
+ else if(isubregion == 28) then
+
+ call usual_hex_nodes(iaddx,iaddy,iaddz)
+
+ iy1=0
+ iy2=npy-8
+ diy=8
+
+ ix1=0
+ ix2=npx-8
+ dix=8
+
+ ir1= 0
+ ir2= 2*NER_BOTTOM_MOHO-8
+ dir=8
+
+ iax=4
+ iay=4
+ iar=4
+
+ doubling_index= IFLAG_HALFSPACE_MOHO
+
+ else if(isubregion == 27) then
+
+ call unusual_hex_nodes1(iaddx,iaddy,iaddz)
+
+! generating stage 2 of the mesh doubling below 670
+
+ iy1=0
+ iy2=npy-8
+ diy=8
+
+ ix1=0
+ ix2=npx-16
+ dix=16
+
+ dir=4
+
+ iax=2
+ iay=2
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO + NER_MOHO_16 + NER_16_BASEMENT) - 8
+ ir2=ir1
+
+ doubling_index=IFLAG_16km_BASEMENT
+
+ else if(isubregion == 26) then
+
+ call unusual_hex_nodes1p(iaddx,iaddy,iaddz)
+
+! generating stage 3 of the mesh doubling below 670
+
+ iy1=0
+ iy2=npy-8
+ diy=8
+
+ ix1=8
+ ix2=npx-8
+ dix=16
+
+ dir=4
+
+ iax=2
+ iay=2
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO + NER_MOHO_16 + NER_16_BASEMENT) - 8
+ ir2=ir1
+
+ doubling_index=IFLAG_16km_BASEMENT
+
+ else if(isubregion == 25) then
+
+ call unusual_hex_nodes2(iaddx,iaddy,iaddz)
+
+! generating stage 4 of the mesh doubling below 670
+
+ iy1=0
+ iy2=npy-8
+ diy=8
+
+ ix1=0
+ ix2=npx-16
+ dix=16
+
+ dir=4
+
+ iax=2
+ iay=2
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO + NER_MOHO_16 + NER_16_BASEMENT) - 8
+ ir2=ir1
+
+ doubling_index=IFLAG_16km_BASEMENT
+
+ else if(isubregion == 24) then
+
+ call unusual_hex_nodes2p(iaddx,iaddy,iaddz)
+
+! generating stage 5 of the mesh doubling below 670
+
+ iy1=0
+ iy2=npy-8
+ diy=8
+
+ ix1=12
+ ix2=npx-4
+ dix=16
+
+ dir=4
+
+ iax=2
+ iay=2
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO + NER_MOHO_16 + NER_16_BASEMENT) - 6
+ ir2=ir1
+
+ doubling_index=IFLAG_16km_BASEMENT
+
+ else if(isubregion == 23) then
+
+ call unusual_hex_nodes3(iaddx,iaddy,iaddz)
+
+! generating stage 6 of the mesh doubling below 670
+
+ iy1=0
+ iy2=npy-8
+ diy=8
+
+ ix1=4
+ ix2=npx-12
+ dix=16
+
+ dir=4
+
+ iax=2
+ iay=2
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO + NER_MOHO_16 + NER_16_BASEMENT) - 6
+ ir2=ir1
+
+ doubling_index=IFLAG_16km_BASEMENT
+
+ else if(isubregion == 22) then
+
+ call unusual_hex_nodes3(iaddx,iaddy,iaddz)
+
+! generating stage 7 of the mesh doubling below 670
+
+ iy1=0
+ iy2=npy-8
+ diy=8
+
+ ix1=8
+ ix2=npx-8
+ dix=16
+
+ dir=4
+
+ iax=2
+ iay=2
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO + NER_MOHO_16 + NER_16_BASEMENT) - 6
+ ir2=ir1
+
+ doubling_index=IFLAG_16km_BASEMENT
+
+ else if(isubregion == 21) then
+
+ call unusual_hex_nodes4(iaddx,iaddy,iaddz)
+
+! generating stage 8 of the mesh doubling below 670
+
+ iy1=8
+ iy2=npy-8
+ diy=16
+
+ ix1=0
+ ix2=npx-4
+ dix=4
+
+ dir=4
+
+ iax=2
+ iay=2
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO + NER_MOHO_16 + NER_16_BASEMENT) - 4
+ ir2=ir1
+
+ doubling_index=IFLAG_16km_BASEMENT
+
+ else if(isubregion == 20) then
+
+ call unusual_hex_nodes4p(iaddx,iaddy,iaddz)
+
+! generating stage 9 of the mesh doubling below 670
+
+ iy1=0
+ iy2=npy-16
+ diy=16
+
+ ix1=0
+ ix2=npx-4
+ dix=4
+
+ dir=4
+
+ iax=2
+ iay=2
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO + NER_MOHO_16 + NER_16_BASEMENT) - 4
+ ir2=ir1
+
+ doubling_index=IFLAG_16km_BASEMENT
+
+ else if(isubregion == 19) then
+
+ call usual_hex_nodes(iaddx,iaddy,iaddz)
+
+! generating stage 10 of the mesh doubling below 670
+
+ iy1=8
+ iy2=npy-8
+ diy=16
+
+ ix1=0
+ ix2=npx-4
+ dix=4
+
+ dir=4
+
+ iax=2
+ iay=2
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO + NER_MOHO_16 + NER_16_BASEMENT) - 2
+ ir2=ir1
+
+ doubling_index=IFLAG_16km_BASEMENT
+
+ else if(isubregion == 18) then
+
+ call usual_hex_nodes(iaddx,iaddy,iaddz)
+
+! generating stage 11 of the mesh doubling below 670
+
+ iy1=4
+ iy2=npy-12
+ diy=16
+
+ ix1=0
+ ix2=npx-4
+ dix=4
+
+ dir=4
+
+ iax=2
+ iay=2
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO + NER_MOHO_16 + NER_16_BASEMENT) - 2
+ ir2=ir1
+
+ doubling_index=IFLAG_16km_BASEMENT
+
+ else if(isubregion == 17) then
+
+ call unusual_hex_nodes6(iaddx,iaddy,iaddz)
+
+! generating stage 12 of the mesh doubling below 670
+
+ iy1=12
+ iy2=npy-4
+ diy=16
+
+ ix1=0
+ ix2=npx-4
+ dix=4
+
+ dir=4
+
+ iax=2
+ iay=2
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO + NER_MOHO_16 + NER_16_BASEMENT) - 2
+ ir2=ir1
+
+ doubling_index=IFLAG_16km_BASEMENT
+
+ else if(isubregion == 16) then
+
+ call unusual_hex_nodes6p(iaddx,iaddy,iaddz)
+
+! generating stage 13 of the mesh doubling below 670
+
+ iy1=0
+ iy2=npy-16
+ diy=16
+
+ ix1=0
+ ix2=npx-4
+ dix=4
+
+ dir=4
+
+ iax=2
+ iay=2
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO + NER_MOHO_16 + NER_16_BASEMENT) - 4
+ ir2=ir1
+
+ doubling_index=IFLAG_16km_BASEMENT
+
+ else if(isubregion == 15) then
+
+ call usual_hex_nodes(iaddx,iaddy,iaddz)
+
+ iy1=0
+ iy2=npy-8
+ diy=8
+
+ ix1=0
+ ix2=npx-8
+ dix=8
+
+! honor So-Cal model discontinuity at 16 km for accuracy
+ ir1=2*NER_BOTTOM_MOHO
+ ir2=2*(NER_BOTTOM_MOHO+NER_MOHO_16) - 4
+ dir=4
+
+ iax=4
+ iay=4
+ iar=2
+
+ doubling_index = IFLAG_MOHO_16km
+
+ else if(isubregion == 14) then
+
+ call usual_hex_nodes(iaddx,iaddy,iaddz)
+
+ iy1=0
+ iy2=npy-8
+ diy=8
+
+ ix1=0
+ ix2=npx-8
+ dix=8
+
+! honor So-Cal model discontinuity at 16 km for accuracy
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16)
+ ir2=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT)-12
+ dir=4
+
+ iax=4
+ iay=4
+ iar=2
+
+ doubling_index = IFLAG_16km_BASEMENT
+
+
+ else if(isubregion == 13) then
+
+ call usual_hex_nodes(iaddx,iaddy,iaddz)
+
+! generating stage 1 of the mesh doubling below the Moho
+
+ iy1=0
+ iy2=npy-4
+ diy=4
+
+ ix1=0
+ ix2=npx-4
+ dix=4
+
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT)
+ ir2=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT+NER_BASEMENT_SEDIM)-12
+ dir=4
+
+ iax=2
+ iay=2
+ iar=2
+
+ doubling_index=IFLAG_BASEMENT_TOPO
+
+ else if(isubregion == 12) then
+
+ call unusual_hex_nodes1(iaddx,iaddy,iaddz)
+
+! generating stage 2 of the mesh doubling below the Moho
+
+ iy1=0
+ iy2=npy-4
+ diy=4
+
+ ix1=0
+ ix2=npx-8
+ dix=8
+
+ dir=4
+
+ iax=1
+ iay=1
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT+NER_BASEMENT_SEDIM)-8
+ ir2=ir1
+
+ doubling_index=IFLAG_BASEMENT_TOPO
+
+ else if(isubregion == 11) then
+
+ call unusual_hex_nodes1p(iaddx,iaddy,iaddz)
+
+! generating stage 3 of the mesh doubling below the Moho
+
+ iy1=0
+ iy2=npy-4
+ diy=4
+
+ ix1=4
+ ix2=npx-4
+ dix=8
+
+ dir=4
+
+ iax=1
+ iay=1
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT+NER_BASEMENT_SEDIM)-8
+ ir2=ir1
+
+ doubling_index=IFLAG_BASEMENT_TOPO
+
+ else if(isubregion == 10) then
+
+ call unusual_hex_nodes2(iaddx,iaddy,iaddz)
+
+! generating stage 4 of the mesh doubling below the Moho
+
+ iy1=0
+ iy2=npy-4
+ diy=4
+
+ ix1=0
+ ix2=npx-8
+ dix=8
+
+ dir=4
+
+ iax=1
+ iay=1
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT+NER_BASEMENT_SEDIM)-8
+ ir2=ir1
+
+ doubling_index=IFLAG_BASEMENT_TOPO
+
+ else if(isubregion == 9) then
+
+ call unusual_hex_nodes2p(iaddx,iaddy,iaddz)
+
+! generating stage 5 of the mesh doubling below the Moho
+
+ iy1=0
+ iy2=npy-4
+ diy=4
+
+ ix1=6
+ ix2=npx-2
+ dix=8
+
+ dir=4
+
+ iax=1
+ iay=1
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT+NER_BASEMENT_SEDIM)-6
+ ir2=ir1
+
+ doubling_index=IFLAG_BASEMENT_TOPO
+
+ else if(isubregion == 8) then
+
+ call unusual_hex_nodes3(iaddx,iaddy,iaddz)
+
+! generating stage 6 of the mesh doubling below the Moho
+
+ iy1=0
+ iy2=npy-4
+ diy=4
+
+ ix1=2
+ ix2=npx-6
+ dix=8
+
+ dir=4
+
+ iax=1
+ iay=1
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT+NER_BASEMENT_SEDIM)-6
+ ir2=ir1
+
+ doubling_index=IFLAG_BASEMENT_TOPO
+
+ else if(isubregion == 7) then
+
+ call unusual_hex_nodes3(iaddx,iaddy,iaddz)
+
+! generating stage 7 of the mesh doubling below the Moho
+
+ iy1=0
+ iy2=npy-4
+ diy=4
+
+ ix1=4
+ ix2=npx-4
+ dix=8
+
+ dir=4
+
+ iax=1
+ iay=1
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT+NER_BASEMENT_SEDIM)-6
+ ir2=ir1
+
+ doubling_index=IFLAG_BASEMENT_TOPO
+
+ else if(isubregion == 6) then
+
+ call unusual_hex_nodes4(iaddx,iaddy,iaddz)
+
+! generating stage 8 of the mesh doubling below the Moho
+
+ iy1=4
+ iy2=npy-4
+ diy=8
+
+ ix1=0
+ ix2=npx-2
+ dix=2
+
+ dir=4
+
+ iax=1
+ iay=1
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT+NER_BASEMENT_SEDIM)-4
+ ir2=ir1
+
+ doubling_index=IFLAG_BASEMENT_TOPO
+
+ else if(isubregion == 5) then
+
+ call unusual_hex_nodes4p(iaddx,iaddy,iaddz)
+
+! generating stage 9 of the mesh doubling below the Moho
+
+ iy1=0
+ iy2=npy-8
+ diy=8
+
+ ix1=0
+ ix2=npx-2
+ dix=2
+
+ dir=4
+
+ iax=1
+ iay=1
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT+NER_BASEMENT_SEDIM)-4
+ ir2=ir1
+
+ doubling_index=IFLAG_BASEMENT_TOPO
+
+ else if(isubregion == 4) then
+
+ call usual_hex_nodes(iaddx,iaddy,iaddz)
+
+! generating stage 10 of the mesh doubling below the Moho
+
+ iy1=4
+ iy2=npy-4
+ diy=8
+
+ ix1=0
+ ix2=npx-2
+ dix=2
+
+ dir=4
+
+ iax=1
+ iay=1
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT+NER_BASEMENT_SEDIM)-2
+ ir2=ir1
+
+ doubling_index=IFLAG_BASEMENT_TOPO
+
+ else if(isubregion == 3) then
+
+ call usual_hex_nodes(iaddx,iaddy,iaddz)
+
+! generating stage 11 of the mesh doubling below the Moho
+
+ iy1=2
+ iy2=npy-6
+ diy=8
+
+ ix1=0
+ ix2=npx-2
+ dix=2
+
+ dir=4
+
+ iax=1
+ iay=1
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT+NER_BASEMENT_SEDIM)-2
+ ir2=ir1
+
+ doubling_index=IFLAG_BASEMENT_TOPO
+
+ else if(isubregion == 2) then
+
+ call unusual_hex_nodes6(iaddx,iaddy,iaddz)
+
+! generating stage 12 of the mesh doubling below the Moho
+
+ iy1=6
+ iy2=npy-2
+ diy=8
+
+ ix1=0
+ ix2=npx-2
+ dix=2
+
+ dir=4
+
+ iax=1
+ iay=1
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT+NER_BASEMENT_SEDIM)-2
+ ir2=ir1
+
+ doubling_index=IFLAG_BASEMENT_TOPO
+
+ else if(isubregion == 1) then
+
+ call unusual_hex_nodes6p(iaddx,iaddy,iaddz)
+
+! generating stage 13 of the mesh doubling below the Moho
+
+ iy1=0
+ iy2=npy-8
+ diy=8
+
+ ix1=0
+ ix2=npx-2
+ dix=2
+
+ dir=4
+
+ iax=1
+ iay=1
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT+NER_BASEMENT_SEDIM)-4
+ ir2=ir1
+
+ doubling_index=IFLAG_BASEMENT_TOPO
+
+ else
+
+ call exit_MPI(myrank,'incorrect subregion code')
+
+ endif
+
+ endif
+
+ end subroutine define_subregions
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/define_subregions_heuristic.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/define_subregions_heuristic.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/define_subregions_heuristic.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,267 @@
+!=====================================================================
+!
+! 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 define_subregions_heuristic(myrank,isubregion,iaddx,iaddy,iaddz, &
+ ix1,ix2,dix,iy1,iy2,diy,ir1,ir2,dir,iax,iay,iar, &
+ itype_element,npx,npy, &
+ NER_BOTTOM_MOHO,NER_MOHO_16,NER_16_BASEMENT,NER_BASEMENT_SEDIM)
+
+! heuristic rule to deform elements to balance angles
+! to 120 degrees in doubling regions
+
+ implicit none
+
+ include "constants.h"
+
+ integer myrank
+ integer ix1,ix2,dix,iy1,iy2,diy,ir1,ir2,dir
+ integer iax,iay,iar
+ integer isubregion,itype_element
+ integer npx,npy
+
+ integer NER_BOTTOM_MOHO,NER_MOHO_16,NER_16_BASEMENT,NER_BASEMENT_SEDIM
+
+! topology of the elements
+ integer iaddx(NGNOD)
+ integer iaddy(NGNOD)
+ integer iaddz(NGNOD)
+
+! type of elements for heuristic rule
+ integer, parameter :: ITYPE_UNUSUAL_1 = 1
+ integer, parameter :: ITYPE_UNUSUAL_1p = 2
+ integer, parameter :: ITYPE_UNUSUAL_4 = 3
+ integer, parameter :: ITYPE_UNUSUAL_4p = 4
+
+
+! **************
+
+ if(isubregion == 8) then
+
+ call unusual_hex_nodes1(iaddx,iaddy,iaddz)
+
+! generating stage 2 of the mesh doubling below 670
+
+ iy1=0
+ iy2=npy-8
+ diy=8
+
+ ix1=0
+ ix2=npx-16
+ dix=16
+
+ dir=4
+
+ iax=2
+ iay=2
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO + NER_MOHO_16 + NER_16_BASEMENT) - 8
+ ir2=ir1
+
+ itype_element = ITYPE_UNUSUAL_1
+
+ else if(isubregion == 7) then
+
+ call unusual_hex_nodes1p(iaddx,iaddy,iaddz)
+
+! generating stage 3 of the mesh doubling below 670
+
+ iy1=0
+ iy2=npy-8
+ diy=8
+
+ ix1=8
+ ix2=npx-8
+ dix=16
+
+ dir=4
+
+ iax=2
+ iay=2
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO + NER_MOHO_16 + NER_16_BASEMENT) - 8
+ ir2=ir1
+
+ itype_element = ITYPE_UNUSUAL_1p
+
+ else if(isubregion == 6) then
+
+ call unusual_hex_nodes4(iaddx,iaddy,iaddz)
+
+! generating stage 8 of the mesh doubling below 670
+
+ iy1=8
+ iy2=npy-8
+ diy=16
+
+ ix1=0
+ ix2=npx-4
+ dix=4
+
+ dir=4
+
+ iax=2
+ iay=2
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO + NER_MOHO_16 + NER_16_BASEMENT) - 4
+ ir2=ir1
+
+ itype_element = ITYPE_UNUSUAL_4
+
+ else if(isubregion == 5) then
+
+ call unusual_hex_nodes4p(iaddx,iaddy,iaddz)
+
+! generating stage 9 of the mesh doubling below 670
+
+ iy1=0
+ iy2=npy-16
+ diy=16
+
+ ix1=0
+ ix2=npx-4
+ dix=4
+
+ dir=4
+
+ iax=2
+ iay=2
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO + NER_MOHO_16 + NER_16_BASEMENT) - 4
+ ir2=ir1
+
+ itype_element = ITYPE_UNUSUAL_4p
+
+ else if(isubregion == 4) then
+
+ call unusual_hex_nodes1(iaddx,iaddy,iaddz)
+
+! generating stage 2 of the mesh doubling below the Moho
+
+ iy1=0
+ iy2=npy-4
+ diy=4
+
+ ix1=0
+ ix2=npx-8
+ dix=8
+
+ dir=4
+
+ iax=1
+ iay=1
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT+NER_BASEMENT_SEDIM)-8
+ ir2=ir1
+
+ itype_element = ITYPE_UNUSUAL_1
+
+ else if(isubregion == 3) then
+
+ call unusual_hex_nodes1p(iaddx,iaddy,iaddz)
+
+! generating stage 3 of the mesh doubling below the Moho
+
+ iy1=0
+ iy2=npy-4
+ diy=4
+
+ ix1=4
+ ix2=npx-4
+ dix=8
+
+ dir=4
+
+ iax=1
+ iay=1
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT+NER_BASEMENT_SEDIM)-8
+ ir2=ir1
+
+ itype_element = ITYPE_UNUSUAL_1p
+
+ else if(isubregion == 2) then
+
+ call unusual_hex_nodes4(iaddx,iaddy,iaddz)
+
+! generating stage 8 of the mesh doubling below the Moho
+
+ iy1=4
+ iy2=npy-4
+ diy=8
+
+ ix1=0
+ ix2=npx-2
+ dix=2
+
+ dir=4
+
+ iax=1
+ iay=1
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT+NER_BASEMENT_SEDIM)-4
+ ir2=ir1
+
+ itype_element = ITYPE_UNUSUAL_4
+
+ else if(isubregion == 1) then
+
+ call unusual_hex_nodes4p(iaddx,iaddy,iaddz)
+
+! generating stage 9 of the mesh doubling below the Moho
+
+ iy1=0
+ iy2=npy-8
+ diy=8
+
+ ix1=0
+ ix2=npx-2
+ dix=2
+
+ dir=4
+
+ iax=1
+ iay=1
+ iar=1
+
+ ir1=2*(NER_BOTTOM_MOHO+NER_MOHO_16+NER_16_BASEMENT+NER_BASEMENT_SEDIM)-4
+ ir2=ir1
+
+ itype_element = ITYPE_UNUSUAL_4p
+
+ else
+
+ call exit_MPI(myrank,'incorrect subregion code')
+
+ endif
+
+ end subroutine define_subregions_heuristic
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/detect_mesh_surfaces.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/detect_mesh_surfaces.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/detect_mesh_surfaces.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,238 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+ subroutine detect_mesh_surfaces()
+
+ use specfem_par
+ use specfem_par_movie
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ implicit none
+
+ ! for mesh surface
+ allocate(ispec_is_surface_external_mesh(NSPEC_AB))
+ allocate(iglob_is_surface_external_mesh(NGLOB_AB))
+
+! determines model surface
+ if (.not. RECVS_CAN_BE_BURIED_EXT_MESH .or. &
+ EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP) then
+
+ ! returns surface points/elements
+ ! in ispec_is_surface_external_mesh / iglob_is_surface_external_mesh and
+ ! number of faces in nfaces_surface_ext_mesh
+ call detect_surface(NPROC,NGLOB_AB,NSPEC_AB,ibool,&
+ ispec_is_surface_external_mesh, &
+ iglob_is_surface_external_mesh, &
+ nfaces_surface_ext_mesh, &
+ num_interfaces_ext_mesh, &
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh, &
+ ibool_interfaces_ext_mesh)
+ endif
+
+! takes cross-section surfaces instead
+ if( (EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP) &
+ .and. PLOT_CROSS_SECTIONS ) then
+ call detect_surface_cross_section(NPROC,NGLOB_AB,NSPEC_AB,ibool,&
+ ispec_is_surface_external_mesh, &
+ iglob_is_surface_external_mesh, &
+ nfaces_surface_ext_mesh, &
+ num_interfaces_ext_mesh, &
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh, &
+ ibool_interfaces_ext_mesh,&
+ CROSS_SECTION_X,CROSS_SECTION_Y,CROSS_SECTION_Z, &
+ xstore,ystore,zstore,myrank)
+ endif
+
+! takes number of faces for top, free surface only
+ if( MOVIE_SURFACE .or. CREATE_SHAKEMAP ) then
+ nfaces_surface_ext_mesh = num_free_surface_faces
+ ! face corner indices
+ iorderi(1) = 1
+ iorderi(2) = NGLLX
+ iorderi(3) = NGLLX
+ iorderi(4) = 1
+ iorderj(1) = 1
+ iorderj(2) = 1
+ iorderj(3) = NGLLY
+ iorderj(4) = NGLLY
+ endif
+
+! handles movies and shakemaps
+ if( EXTERNAL_MESH_MOVIE_SURFACE .or. &
+ EXTERNAL_MESH_CREATE_SHAKEMAP .or. &
+ MOVIE_SURFACE .or. &
+ CREATE_SHAKEMAP ) then
+ call setup_movie_meshes()
+ endif
+
+! stores wavefields for whole volume
+ if (MOVIE_VOLUME) then
+ ! acoustic
+ if( ACOUSTIC_SIMULATION .or. ELASTIC_SIMULATION ) then
+ allocate(velocity_x(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(velocity_y(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(velocity_z(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ endif
+ ! elastic only
+ if( ELASTIC_SIMULATION ) then
+ allocate(div(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(curl_x(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(curl_y(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(curl_z(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ div(:,:,:,:) = 0._CUSTOM_REAL
+ curl_x(:,:,:,:) = 0._CUSTOM_REAL
+ curl_y(:,:,:,:) = 0._CUSTOM_REAL
+ curl_z(:,:,:,:) = 0._CUSTOM_REAL
+ endif
+ endif
+
+! initializes cross-section gif image
+ if( PNM_GIF_IMAGE ) then
+ call write_PNM_GIF_initialize()
+ endif
+
+
+!!!! NL NL REGOLITH : runs at cines for asteroid simulations. Elements in contact with surface are part of the regolith layer.
+!!$ allocate(ispec_is_regolith(NSPEC_AB))
+!!$ ispec_is_regolith(:) = .false.
+!!$ do ispec = 1, NSPEC_AB
+!!$ do k = 1, NGLLZ
+!!$ do j = 1, NGLLY
+!!$ do i = 1, NGLLX
+!!$ iglob = ibool(i,j,k,ispec)
+!!$ if (iglob_is_surface_external_mesh(iglob)) then
+!!$ ispec_is_regolith(ispec) = .true.
+!!$ endif
+!!$ enddo
+!!$ enddo
+!!$ enddo
+!!$ enddo
+!!$
+!!$ do ispec = 1, NSPEC_AB
+!!$ if (ispec_is_regolith(ispec)) then
+!!$ do k = 1, NGLLZ
+!!$ do j = 1, NGLLY
+!!$ do i = 1, NGLLX
+!!$ kappastore(i,j,k,ispec) = materials_ext_mesh(1,2)* &
+!!$ (materials_ext_mesh(2,2)*materials_ext_mesh(2,2) - &
+!!$ 4.d0*materials_ext_mesh(3,2)*materials_ext_mesh(3,2)/3.d0)
+!!$ mustore(i,j,k,ispec) = materials_ext_mesh(1,2)*materials_ext_mesh(3,2)*&
+!!$ materials_ext_mesh(3,2)
+!!$
+!!$ enddo
+!!$ enddo
+!!$ enddo
+!!$ endif
+!!$ enddo
+!!$
+!!$
+!!$ call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
+!!$ call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
+!!$ call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
+!!$
+!!$ rmass(:) = 0._CUSTOM_REAL
+!!$
+!!$ do ispec=1,NSPEC_AB
+!!$ do k=1,NGLLZ
+!!$ do j=1,NGLLY
+!!$ do i=1,NGLLX
+!!$ weight=wxgll(i)*wygll(j)*wzgll(k)
+!!$ iglob=ibool(i,j,k,ispec)
+!!$
+!!$ jacobianl=jacobian(i,j,k,ispec)
+!!$
+!!$! distinguish between single and double precision for reals
+!!$ if (.not. ispec_is_regolith(ispec)) then
+!!$ if(CUSTOM_REAL == SIZE_REAL) then
+!!$ rmass(iglob) = rmass(iglob) + &
+!!$ sngl(dble(materials_ext_mesh(1,1)) * dble(jacobianl) * weight)
+!!$ else
+!!$ rmass(iglob) = rmass(iglob) + materials_ext_mesh(1,1) * jacobianl * weight
+!!$ endif
+!!$ else
+!!$ if(CUSTOM_REAL == SIZE_REAL) then
+!!$ rmass(iglob) = rmass(iglob) + &
+!!$ sngl(dble(materials_ext_mesh(1,2)) * dble(jacobianl) * weight)
+!!$ else
+!!$ rmass(iglob) = rmass(iglob) + materials_ext_mesh(1,2) * jacobianl * weight
+!!$ endif
+!!$ endif
+!!$
+!!$ enddo
+!!$ enddo
+!!$ enddo
+!!$ enddo
+
+
+!!!! NL NL REGOLITH
+
+!!!!!!!!!! DK DK endif
+
+ end subroutine detect_mesh_surfaces
+
+
+!!!! NL NL REGOLITH
+!!$ double precision function materials_ext_mesh(i,j)
+!!$
+!!$ implicit none
+!!$
+!!$ integer :: i,j
+!!$
+!!$ select case (j)
+!!$ case (1)
+!!$ select case (i)
+!!$ case (1)
+!!$ materials_ext_mesh = 2700.d0
+!!$ case (2)
+!!$ materials_ext_mesh = 3000.d0
+!!$ case (3)
+!!$ materials_ext_mesh = 1732.051d0
+!!$ case default
+!!$ call stop_all()
+!!$ end select
+!!$ case (2)
+!!$ select case (i)
+!!$ case (1)
+!!$ materials_ext_mesh = 2000.d0
+!!$ case (2)
+!!$ materials_ext_mesh = 900.d0
+!!$ case (3)
+!!$ materials_ext_mesh = 500.d0
+!!$ case default
+!!$ call stop_all()
+!!$ end select
+!!$ case default
+!!$ call stop_all()
+!!$ end select
+!!$
+!!$ end function materials_ext_mesh
+!!!! NL NL REGOLITH
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/detect_surface.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/detect_surface.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/detect_surface.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,681 @@
+!=====================================================================
+!
+! 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 detect_surface(NPROC,nglob,nspec,ibool,&
+ ispec_is_surface_external_mesh, &
+ iglob_is_surface_external_mesh, &
+ nfaces_surface_ext_mesh, &
+ num_interfaces_ext_mesh, &
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh, &
+ ibool_interfaces_ext_mesh)
+
+! detects surface (points/elements) of model based upon valence
+!
+! returns: ispec_is_surface_external_mesh, iglob_is_surface_external_mesh
+! and nfaces_surface_ext_mesh
+
+ implicit none
+
+ include "constants.h"
+
+! global indexing
+ integer :: NPROC,nglob,nspec
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec):: ibool
+
+! surface
+ logical, dimension(nspec) :: ispec_is_surface_external_mesh
+ logical, dimension(nglob) :: iglob_is_surface_external_mesh
+ integer :: nfaces_surface_ext_mesh
+
+! MPI partitions
+ integer :: num_interfaces_ext_mesh
+ integer :: max_nibool_interfaces_ext_mesh
+ integer,dimension(num_interfaces_ext_mesh):: nibool_interfaces_ext_mesh
+ integer,dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh):: ibool_interfaces_ext_mesh
+ integer,dimension(num_interfaces_ext_mesh) :: my_neighbours_ext_mesh
+
+!local parameters
+ integer, dimension(:), allocatable :: valence_external_mesh
+ integer :: ispec,i,j,k,ii,jj,kk,iglob,ier
+
+! detecting surface points/elements (based on valence check on NGLL points) for external mesh
+ allocate(valence_external_mesh(nglob),stat=ier)
+ if( ier /= 0 ) stop 'error allocate valence array'
+
+! initialize surface indices
+ ispec_is_surface_external_mesh(:) = .false.
+ iglob_is_surface_external_mesh(:) = .false.
+ valence_external_mesh(:) = 0
+
+ do ispec = 1, nspec
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+ if( iglob < 1 .or. iglob > nglob) then
+ print*,'error valence iglob:',iglob,i,j,k,ispec
+ stop 'error valence'
+ endif
+ valence_external_mesh(iglob) = valence_external_mesh(iglob) + 1
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ! adds contributions from different partitions to valence_external_mesh
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,nglob,valence_external_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+! determines spectral elements containing surface points
+ do ispec = 1, nspec
+
+ ! loops over GLL points not on edges or corners
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ if ( &
+ (k == 1 .or. k == NGLLZ) .and. (j /= 1 .and. j /= NGLLY) .and. (i /= 1 .and. i /= NGLLX) .or. &
+ (j == 1 .or. j == NGLLY) .and. (k /= 1 .and. k /= NGLLZ) .and. (i /= 1 .and. i /= NGLLX) .or. &
+ (i == 1 .or. i == NGLLX) .and. (k /= 1 .and. k /= NGLLZ) .and. (j /= 1 .and. j /= NGLLY) &
+ ) then
+ iglob = ibool(i,j,k,ispec)
+ if (valence_external_mesh(iglob) == 1) then
+ ispec_is_surface_external_mesh(ispec) = .true.
+
+ ! sets flags for all gll points on this face
+ if (k == 1 .or. k == NGLLZ) then
+ do jj = 1, NGLLY
+ do ii = 1, NGLLX
+ iglob_is_surface_external_mesh(ibool(ii,jj,k,ispec)) = .true.
+ enddo
+ enddo
+ endif
+ if (j == 1 .or. j == NGLLY) then
+ do kk = 1, NGLLZ
+ do ii = 1, NGLLX
+ iglob_is_surface_external_mesh(ibool(ii,j,kk,ispec)) = .true.
+ enddo
+ enddo
+ endif
+ if (i == 1 .or. i == NGLLX) then
+ do kk = 1, NGLLZ
+ do jj = 1, NGLLY
+ iglob_is_surface_external_mesh(ibool(i,jj,kk,ispec)) = .true.
+ enddo
+ enddo
+ endif
+ endif
+
+ endif
+ enddo
+ enddo
+ enddo
+
+ enddo ! nspec
+
+! counts faces for external-mesh movies and shakemaps
+ nfaces_surface_ext_mesh = 0
+ do ispec = 1, nspec
+ iglob = ibool(2,2,1,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ endif
+ iglob = ibool(2,2,NGLLZ,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ endif
+ iglob = ibool(2,1,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ endif
+ iglob = ibool(2,NGLLY,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ endif
+ iglob = ibool(1,2,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ endif
+ iglob = ibool(NGLLX,2,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ endif
+ enddo
+
+ end subroutine detect_surface
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine detect_surface_cross_section(NPROC,nglob,nspec,ibool,&
+ ispec_is_surface_external_mesh, &
+ iglob_is_surface_external_mesh, &
+ nfaces_surface_ext_mesh, &
+ num_interfaces_ext_mesh, &
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh, &
+ ibool_interfaces_ext_mesh,&
+ x_section,y_section,z_section, &
+ xstore,ystore,zstore,myrank)
+
+! instead of surface of model, this returns cross-section surfaces through model
+! at specified x,y,z - coordinates
+!
+! note: x,y,z coordinates must coincide with the element (outer-)faces, no planes inside elements are taken
+! (this is only a quick & dirty cross-section implementation, no sophisticated interpolation of points considered...)
+!
+! returns: ispec_is_surface_external_mesh, iglob_is_surface_external_mesh
+! and nfaces_surface_ext_mesh
+
+ implicit none
+
+ include "constants.h"
+
+! global indexing
+ integer :: NPROC,nglob,nspec,myrank
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec):: ibool
+
+! surface
+ logical, dimension(nspec) :: ispec_is_surface_external_mesh
+ logical, dimension(nglob) :: iglob_is_surface_external_mesh
+ integer :: nfaces_surface_ext_mesh
+
+! MPI partitions
+ integer :: num_interfaces_ext_mesh
+ integer :: max_nibool_interfaces_ext_mesh
+ integer,dimension(num_interfaces_ext_mesh):: nibool_interfaces_ext_mesh
+ integer,dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh):: ibool_interfaces_ext_mesh
+ integer,dimension(num_interfaces_ext_mesh) :: my_neighbours_ext_mesh
+
+! specified x,y,z - coordinates
+ real(kind=CUSTOM_REAL):: x_section,y_section,z_section
+
+! mesh global point coordinates
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
+
+!local parameters
+ real(kind=CUSTOM_REAL),dimension(6) :: midpoint_faces_x,midpoint_faces_y, &
+ midpoint_faces_z
+ real(kind=CUSTOM_REAL),dimension(6) :: midpoint_dist_x,midpoint_dist_y,midpoint_dist_z
+ real(kind=CUSTOM_REAL),dimension(NGNOD2D) :: xcoord_face,ycoord_face,zcoord_face
+ real(kind=CUSTOM_REAL) :: mindist,normal(NDIM)
+ integer, dimension(:), allocatable :: valence_external_mesh
+ integer,dimension(3,NGLLX,NGLLX) :: face_ijk
+ integer :: ispec,i,j,k,ii,jj,kk,iglob,ier,count
+ integer :: iface,icorner
+ logical, dimension(:),allocatable :: ispec_has_points
+ logical :: has_face
+ ! corners indices of reference cube faces
+ integer,dimension(3,4),parameter :: iface1_corner_ijk = &
+ reshape((/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ /),(/3,4/)) ! xmin
+ integer,dimension(3,4),parameter :: iface2_corner_ijk = &
+ reshape((/ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),(/3,4/)) !xmax
+ integer,dimension(3,4),parameter :: iface3_corner_ijk = &
+ reshape((/ 1,1,1, 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,1,1 /),(/3,4/)) !ymin
+ integer,dimension(3,4),parameter :: iface4_corner_ijk = &
+ reshape((/ 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! ymax
+ integer,dimension(3,4),parameter :: iface5_corner_ijk = &
+ reshape((/ 1,1,1, 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,1,1 /),(/3,4/)) ! bottom
+ integer,dimension(3,4),parameter :: iface6_corner_ijk = &
+ reshape((/ 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) !top
+ integer,dimension(3,4,6),parameter :: iface_all_corner_ijk = &
+ reshape((/ iface1_corner_ijk,iface2_corner_ijk, &
+ iface3_corner_ijk,iface4_corner_ijk, &
+ iface5_corner_ijk,iface6_corner_ijk /),(/3,4,6/)) ! all faces
+ integer,dimension(3,6),parameter :: iface_midpoint_ijk = &
+ reshape( (/ 1,3,3, NGLLX,3,3, 3,1,3, 3,NGLLY,3, 3,3,1, 3,3,NGLLZ /),(/3,6/)) ! top
+
+! detecting surface points/elements (based on valence check on NGLL points) for external mesh
+ allocate(valence_external_mesh(nglob),ispec_has_points(nspec),stat=ier)
+ if( ier /= 0 ) stop 'error allocate valence array'
+
+! an estimation of the minimum distance between global points (for an element width)
+ mindist = minval( (xstore(ibool(1,3,3,:)) - xstore(ibool(NGLLX,3,3,:)))**2 &
+ + (ystore(ibool(1,3,3,:)) - ystore(ibool(NGLLX,3,3,:)))**2 &
+ + (zstore(ibool(1,3,3,:)) - zstore(ibool(NGLLX,3,3,:)))**2 )
+ mindist = sqrt(mindist)
+
+! initialize surface indices
+ ispec_is_surface_external_mesh(:) = .false.
+ iglob_is_surface_external_mesh(:) = .false.
+ nfaces_surface_ext_mesh = 0
+ valence_external_mesh(:) = 0
+
+! sets valence value to one corresponding to process rank for points on cross-sections
+ do ispec = 1, nspec
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! x cross-section
+ if( abs( xstore(iglob) - x_section ) < 0.2*mindist ) then
+ ! sets valence to 1 for points on cross-sections
+ valence_external_mesh(iglob) = myrank+1
+ endif
+
+ ! y cross-section
+ if( abs( ystore(iglob) - y_section ) < 0.2*mindist ) then
+ ! sets valence to 1 for points on cross-sections
+ valence_external_mesh(iglob) = myrank+1
+ endif
+
+ ! z cross-section
+ if( abs( zstore(iglob) - z_section ) < 0.2*mindist ) then
+ ! sets valence to 1 for points on cross-sections
+ valence_external_mesh(iglob) = myrank+1
+ endif
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+! adds contributions from different partitions to valence_external_mesh
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,nglob,valence_external_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+
+! determines spectral elements containing surface points
+! (only counts element outer faces, no planes inside element)
+ ispec_has_points(:) = .false.
+ count = 0
+ do ispec = 1, nspec
+
+ ! loops over GLL points not on edges or corners, but inside faces
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+
+ iglob = ibool(i,j,k,ispec)
+
+ ! sets flag if element has points
+ if( valence_external_mesh(iglob) > 0 ) ispec_has_points(ispec) = .true.
+
+ ! checks element surfaces for valence points
+ if ( ((k == 1 .or. k == NGLLZ) .and. (j == 2 .and. i == 2)) .or. &
+ ((j == 1 .or. j == NGLLY) .and. (k == 2 .and. i == 2)) .or. &
+ ((i == 1 .or. i == NGLLX) .and. (k == 2 .and. j == 2)) ) then
+
+ iglob = ibool(i,j,k,ispec)
+
+ ! considers only points in same process or, if point is shared between two processes,
+ ! only with higher process ranks than itself
+ if (valence_external_mesh(iglob) == myrank+1 .or. valence_external_mesh(iglob) > 2*(myrank+1) ) then
+
+ has_face = .false.
+
+
+ ! sets flags for all gll points on a face and makes sure it's not inside the element
+ ! zmin & zmax face
+ if ((k == 1 .or. k == NGLLZ) .and. valence_external_mesh(ibool(3,3,k,ispec)) >= 1 ) then
+ has_face = .true.
+ do jj = 1, NGLLY
+ do ii = 1, NGLLX
+ iglob_is_surface_external_mesh(ibool(ii,jj,k,ispec)) = .true.
+ ! resets valence to count face only once
+ valence_external_mesh(ibool(ii,jj,k,ispec)) = -1
+ enddo
+ enddo
+ endif
+
+ ! ymin & ymax
+ if ((j == 1 .or. j == NGLLY) .and. valence_external_mesh(ibool(3,j,3,ispec)) >= 1) then
+ has_face = .true.
+ do kk = 1, NGLLZ
+ do ii = 1, NGLLX
+ iglob_is_surface_external_mesh(ibool(ii,j,kk,ispec)) = .true.
+ ! resets valence to count face only once
+ valence_external_mesh(ibool(ii,j,kk,ispec)) = -1
+ enddo
+ enddo
+ endif
+
+ ! xmin & xmax
+ if ((i == 1 .or. i == NGLLX) .and. valence_external_mesh(ibool(i,3,3,ispec)) >= 1) then
+ has_face = .true.
+ do kk = 1, NGLLZ
+ do jj = 1, NGLLY
+ iglob_is_surface_external_mesh(ibool(i,jj,kk,ispec)) = .true.
+ ! resets valence to count face only once
+ valence_external_mesh(ibool(i,jj,kk,ispec)) = -1
+ enddo
+ enddo
+ endif
+
+
+ ! sets flag for element
+ if( has_face ) then
+ ispec_is_surface_external_mesh(ispec) = .true.
+ count = count+1
+ endif
+
+ endif
+ endif
+ enddo
+ enddo
+ enddo
+
+ enddo ! nspec
+
+
+! tries to find closest face if points are inside
+ do ispec = 1,nspec
+ ! checks if already assigned
+ !if( ispec_is_surface_external_mesh(ispec) ) cycle
+
+ ! in case element has still unresolved points in interior,
+ ! we take closest element face to cross-section plane
+ if( ispec_has_points(ispec) ) then
+
+ ! an estimation of the element width
+ mindist = sqrt((xstore(ibool(1,3,3,ispec)) - xstore(ibool(NGLLX,3,3,ispec)))**2 &
+ + (ystore(ibool(1,3,3,ispec)) - ystore(ibool(NGLLX,3,3,ispec)))**2 &
+ + (zstore(ibool(1,3,3,ispec)) - zstore(ibool(NGLLX,3,3,ispec)))**2 )
+
+ ! determines element face by minimum distance of midpoints
+ midpoint_faces_x(:) = 0.0
+ midpoint_faces_y(:) = 0.0
+ midpoint_faces_z(:) = 0.0
+ do iface=1,6
+ ! face corners
+ 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)
+
+ ! coordinates
+ iglob = ibool(i,j,k,ispec)
+ xcoord_face(icorner) = xstore(iglob)
+ ycoord_face(icorner) = ystore(iglob)
+ zcoord_face(icorner) = zstore(iglob)
+
+ ! face midpoint coordinates
+ midpoint_faces_x(iface) = midpoint_faces_x(iface) + xcoord_face(icorner)
+ midpoint_faces_y(iface) = midpoint_faces_y(iface) + ycoord_face(icorner)
+ midpoint_faces_z(iface) = midpoint_faces_z(iface) + zcoord_face(icorner)
+
+ enddo
+ midpoint_faces_x(iface) = midpoint_faces_x(iface) / 4.0
+ midpoint_faces_y(iface) = midpoint_faces_y(iface) / 4.0
+ midpoint_faces_z(iface) = midpoint_faces_z(iface) / 4.0
+
+ ! gets face normal
+ normal(:) = 0._CUSTOM_REAL
+ call get_element_face_normal(ispec,iface,xcoord_face,ycoord_face,zcoord_face,&
+ ibool,nspec,nglob,xstore,ystore,zstore,&
+ normal)
+
+ ! distance to cross-section planes
+ midpoint_dist_x(iface) = abs(midpoint_faces_x(iface) - x_section)
+ midpoint_dist_y(iface) = abs(midpoint_faces_y(iface) - y_section)
+ midpoint_dist_z(iface) = abs(midpoint_faces_z(iface) - z_section)
+
+
+ ! x cross-section plane
+ !minface = minloc(midpoint_dist_x)
+ !iface = minface(1)
+ i = iface_midpoint_ijk(1,iface)
+ j = iface_midpoint_ijk(2,iface)
+ k = iface_midpoint_ijk(3,iface)
+ if( midpoint_dist_x(iface) < 0.5*mindist .and. &
+ valence_external_mesh(ibool(i,j,k,ispec)) /= -1 ) then
+ ! checks face normal points in similar direction as cross-section normal
+ if( abs(normal(1)) > 0.6 ) then
+ call get_element_face_gll_indices(iface,face_ijk,NGLLX,NGLLX)
+ do jj = 1, NGLLY
+ do ii = 1, NGLLX
+ i = face_ijk(1,ii,jj)
+ j = face_ijk(2,ii,jj)
+ k = face_ijk(3,ii,jj)
+ ! sets iglob flag on face points
+ iglob_is_surface_external_mesh(ibool(i,j,k,ispec)) = .true.
+ ! sets ispec flag
+ ispec_is_surface_external_mesh(ispec) = .true.
+ ! resets valence
+ valence_external_mesh(ibool(i,j,k,ispec)) = -1
+ enddo
+ enddo
+ endif
+ endif
+
+ ! y cross-section plane
+ !minface = minloc(midpoint_dist_y)
+ !iface = minface(1)
+ i = iface_midpoint_ijk(1,iface)
+ j = iface_midpoint_ijk(2,iface)
+ k = iface_midpoint_ijk(3,iface)
+ if( midpoint_dist_y(iface) < 0.5*mindist .and. &
+ valence_external_mesh(ibool(i,j,k,ispec)) /= -1) then
+ ! checks face normal points in similar direction as cross-section normal
+ if( abs(normal(2)) > 0.6 ) then
+ call get_element_face_gll_indices(iface,face_ijk,NGLLX,NGLLX)
+ do jj = 1, NGLLY
+ do ii = 1, NGLLX
+ i = face_ijk(1,ii,jj)
+ j = face_ijk(2,ii,jj)
+ k = face_ijk(3,ii,jj)
+ ! sets iglob flag on face points
+ iglob_is_surface_external_mesh(ibool(i,j,k,ispec)) = .true.
+ ! sets ispec flag
+ ispec_is_surface_external_mesh(ispec) = .true.
+ ! resets valence
+ valence_external_mesh(ibool(i,j,k,ispec)) = -1
+ enddo
+ enddo
+ endif
+ endif
+
+ ! z cross-section plane
+ !minface = minloc(midpoint_dist_z)
+ !iface = minface(1)
+ i = iface_midpoint_ijk(1,iface)
+ j = iface_midpoint_ijk(2,iface)
+ k = iface_midpoint_ijk(3,iface)
+ if( midpoint_dist_z(iface) < 0.5*mindist .and. &
+ valence_external_mesh(ibool(i,j,k,ispec)) /= -1) then
+ ! checks face normal points in similar direction as cross-section normal
+ if( abs(normal(3)) > 0.6 ) then
+ call get_element_face_gll_indices(iface,face_ijk,NGLLX,NGLLX)
+ do jj = 1, NGLLY
+ do ii = 1, NGLLX
+ i = face_ijk(1,ii,jj)
+ j = face_ijk(2,ii,jj)
+ k = face_ijk(3,ii,jj)
+ ! sets iglob flag on face points
+ iglob_is_surface_external_mesh(ibool(i,j,k,ispec)) = .true.
+ ! sets ispec flag
+ ispec_is_surface_external_mesh(ispec) = .true.
+ ! resets valence
+ valence_external_mesh(ibool(i,j,k,ispec)) = -1
+ enddo
+ enddo
+ endif
+ endif
+
+ enddo ! iface
+
+ endif
+ enddo
+
+! counts faces for external-mesh movies and shakemaps
+ nfaces_surface_ext_mesh = 0
+ do ispec = 1, nspec
+ if( ispec_is_surface_external_mesh(ispec) ) then
+ ! zmin face
+ if (iglob_is_surface_external_mesh(ibool(2,2,1,ispec))) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ endif
+ ! zmax
+ if (iglob_is_surface_external_mesh(ibool(2,2,NGLLZ,ispec))) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ endif
+ ! ymin
+ if (iglob_is_surface_external_mesh(ibool(2,1,2,ispec))) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ endif
+ ! ymax
+ if (iglob_is_surface_external_mesh(ibool(2,NGLLY,2,ispec))) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ endif
+ !xmin
+ if (iglob_is_surface_external_mesh(ibool(1,2,2,ispec))) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ endif
+ !xmax
+ if (iglob_is_surface_external_mesh(ibool(NGLLX,2,2,ispec))) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ endif
+ endif
+ enddo
+
+ end subroutine detect_surface_cross_section
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine detect_surface_PNM_GIF_image(NPROC,nglob,nspec,ibool,&
+ ispec_is_image_surface, &
+ iglob_is_image_surface, &
+ num_iglob_image_surface, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,my_neighbours_ext_mesh, &
+ ibool_interfaces_ext_mesh,&
+ section_xorg,section_yorg,section_zorg,&
+ section_nx,section_ny,section_nz,&
+ xstore,ystore,zstore,myrank)
+
+! this returns points on a cross-section surface through model
+!
+! returns: ispec_is_image_surface, iglob_is_image_surface & num_iglob_image_surface
+
+ implicit none
+
+ include "constants.h"
+
+! global indexing
+ integer :: NPROC,nglob,nspec,myrank
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec):: ibool
+
+! surface
+ logical, dimension(nspec) :: ispec_is_image_surface
+ logical, dimension(nglob) :: iglob_is_image_surface
+ integer :: num_iglob_image_surface
+
+! MPI partitions
+ integer :: num_interfaces_ext_mesh
+ integer :: max_nibool_interfaces_ext_mesh
+ integer,dimension(num_interfaces_ext_mesh):: nibool_interfaces_ext_mesh
+ integer,dimension(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh):: ibool_interfaces_ext_mesh
+ integer,dimension(num_interfaces_ext_mesh) :: my_neighbours_ext_mesh
+
+! specified x,y,z - coordinates of cross-section origin and normal to cross-section
+ real(kind=CUSTOM_REAL):: section_xorg,section_yorg,section_zorg
+ real(kind=CUSTOM_REAL):: section_nx,section_ny,section_nz
+
+! mesh global point coordinates
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
+
+!local parameters
+ real(kind=CUSTOM_REAL) :: mindist
+ integer, dimension(:), allocatable :: valence_external_mesh
+ integer :: ispec,i,j,k,iglob,ier,count
+
+! detecting surface points/elements (based on valence check on NGLL points) for external mesh
+ allocate(valence_external_mesh(nglob),stat=ier)
+ if( ier /= 0 ) stop 'error allocate valence array'
+
+! initialize surface indices
+ ispec_is_image_surface(:) = .false.
+ iglob_is_image_surface(:) = .false.
+ valence_external_mesh(:) = 0
+ num_iglob_image_surface = 0
+
+! an estimation of the minimum distance between global points
+ mindist = minval( (xstore(ibool(1,1,1,:)) - xstore(ibool(2,1,1,:)))**2 &
+ + (ystore(ibool(1,1,1,:)) - ystore(ibool(2,1,1,:)))**2 &
+ + (zstore(ibool(1,1,1,:)) - zstore(ibool(2,1,1,:)))**2 )
+ mindist = sqrt(mindist)
+
+! sets valence value to one corresponding to process rank for points on cross-sections
+ do ispec = 1, nspec
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! chooses points close to cross-section
+ if( abs((xstore(iglob)-section_xorg)*section_nx + (ystore(iglob)-section_yorg)*section_ny &
+ + (zstore(iglob)-section_zorg)*section_nz ) < 0.8*mindist ) then
+ ! sets valence to 1 for points on cross-sections
+ valence_external_mesh(iglob) = myrank+1
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+! adds contributions from different partitions to valence_external_mesh
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,nglob,valence_external_mesh, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+
+! determines spectral elements containing points on surface
+ count = 0
+ do ispec = 1, nspec
+ ! loops over GLL points not on edges or corners, but inside faces
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+ ! considers only points in same process or, if point is shared between two processes,
+ ! only with higher process ranks than itself
+ if (valence_external_mesh(iglob) == myrank+1 .or. valence_external_mesh(iglob) > 2*(myrank+1) ) then
+ if( iglob_is_image_surface(iglob) .eqv. .false. ) count = count+1
+ iglob_is_image_surface(iglob) = .true.
+ ispec_is_image_surface(ispec) = .true.
+ endif
+ enddo
+ enddo
+ enddo
+ enddo ! nspec
+ num_iglob_image_surface = count
+
+ end subroutine detect_surface_PNM_GIF_image
+
+
+
+
\ No newline at end of file
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/devel/fault_solver.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/devel/fault_solver.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/devel/fault_solver.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,966 @@
+!=====================================================================
+!
+! 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.
+!
+!===============================================================================================================
+
+! This module was written by:
+! Percy Galvez, Jean-Paul Ampuero and Tarje Nissen-Meyer
+
+module fault_solver
+
+ implicit none
+
+ include 'constants.h'
+
+ private
+
+ ! outputs on selected fault nodes at every time step:
+ ! slip, slip velocity, fault stresses
+ type dataT_type
+ integer :: npoin
+ integer, dimension(:), pointer :: iglob ! on-fault global index of output nodes
+ real(kind=CUSTOM_REAL), dimension(:,:), pointer :: d1,v1,t1,d2,v2,t2,t3
+ character(len=70), dimension(:), pointer :: name
+ end type dataT_type
+
+
+ ! outputs at selected times for all fault nodes:
+ ! strength, state, slip, slip velocity, fault stresses, rupture time, process zone time
+ ! rupture time = first time when slip velocity = threshold V_RUPT (defined below)
+ ! process zone time = first time when slip = Dc
+ type dataXZ_type
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: stg, sta, d1, d2, v1, v2, &
+ t1, t2, t3, tRUP,tPZ
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: xcoord,ycoord,zcoord
+ integer :: npoin
+ end type dataXZ_type
+
+ type swf_type
+ private
+ integer :: kind
+ logical :: healing = .false.
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: Dc=>null(), mus=>null(), mud=>null(), theta=>null()
+ end type swf_type
+
+ type bc_dynflt_type
+ private
+ integer :: nspec,nglob
+ real(kind=CUSTOM_REAL), dimension(:,:), pointer :: T0,T,V,D
+ real(kind=CUSTOM_REAL), dimension(:,:), pointer :: coord
+ real(kind=CUSTOM_REAL), dimension(:,:,:), pointer :: R
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: MU,B,invM1,invM2,Z
+ real(kind=CUSTOM_REAL) :: dt
+ integer, dimension(:), pointer :: ibulk1, ibulk2
+ type(swf_type), pointer :: swf => null()
+ logical :: allow_opening = .false. ! default : do not allow opening
+ type(dataT_type) :: dataT
+ type(dataXZ_type) :: dataXZ
+ end type bc_dynflt_type
+
+ type(bc_dynflt_type), allocatable, save :: faults(:)
+
+ !slip velocity threshold for healing
+ !WARNING: not very robust
+ real(kind=CUSTOM_REAL), save :: V_HEALING
+
+ !slip velocity threshold for definition of rupture front
+ real(kind=CUSTOM_REAL), save :: V_RUPT
+
+ !Number of time steps defined by the user : NTOUT
+ integer, save :: NTOUT,NSNAP
+
+ integer, save :: SIMULATION_TYPE_DYN = 1
+
+
+ integer , save :: size_Kelvin_Voigt
+
+ real(kind=CUSTOM_REAL), allocatable, save :: Kelvin_Voigt_eta(:)
+
+ public :: BC_DYNFLT_init, BC_DYNFLT_set3d_all, Kelvin_Voigt_eta, &
+ size_Kelvin_Voigt, SIMULATION_TYPE_DYN
+
+
+contains
+
+
+!=====================================================================
+! BC_DYNFLT_init initializes dynamic faults
+!
+! prname fault database is read from file prname_fault_db.bin
+! Minv inverse mass matrix
+! dt global time step
+!
+ subroutine BC_DYNFLT_init(prname,Minv,DTglobal,nt)
+
+ character(len=256), intent(in) :: prname ! 'proc***'
+ real(kind=CUSTOM_REAL), intent(in) :: Minv(:)
+ double precision, intent(in) :: DTglobal
+ integer, intent(in) :: nt
+
+ real(kind=CUSTOM_REAL) :: dt
+ integer :: iflt,ier,dummy_idfault
+ integer :: nbfaults
+ character(len=256) :: filename
+ integer, parameter :: IIN_PAR =151
+ integer, parameter :: IIN_BIN =170
+
+ NAMELIST / BEGIN_FAULT / dummy_idfault
+
+ dummy_idfault = 0
+
+ filename = prname(1:len_trim(prname))//'Kelvin_voigt_eta.bin'
+ open(unit=IIN_BIN,file=trim(filename),status='old',action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) stop 'Haven not found proc*_Kelvin_voigt_eta.bin'
+ read(IIN_BIN) size_Kelvin_Voigt
+ if (size_Kelvin_Voigt > 0) then
+ allocate(Kelvin_Voigt_eta(size_Kelvin_Voigt))
+ read(IIN_BIN) Kelvin_Voigt_eta
+ endif
+ Close(IIN_BIN)
+
+ open(unit=IIN_PAR,file='DATA/FAULT/Par_file_faults.in',status='old',iostat=ier)
+ if( ier /= 0 ) then
+ write(6,*) 'Have not found Par_file_faults.in: assume no faults'
+ return
+ endif
+
+ dt = real(DTglobal)
+ filename = prname(1:len_trim(prname))//'fault_db.bin'
+ open(unit=IIN_BIN,file=trim(filename),status='old',action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) stop 'Have not found proc*_fault_db.bin'
+! WARNING TO DO: should be an MPI abort
+
+ read(IIN_PAR,*) nbfaults
+ do iflt=1,nbfaults
+ read(IIN_PAR,*)
+ enddo
+ read(IIN_PAR,*) SIMULATION_TYPE_DYN
+ if ( SIMULATION_TYPE_DYN == 1 ) then
+ read(IIN_PAR,*) NTOUT
+ read(IIN_PAR,*) NSNAP
+ read(IIN_PAR,*) V_HEALING
+ read(IIN_PAR,*) V_RUPT
+
+ read(IIN_BIN) nbfaults ! should be the same as in IIN_PAR
+ allocate( faults(nbfaults) )
+ do iflt=1,nbfaults
+ read(IIN_PAR,nml=BEGIN_FAULT,end=100)
+ call init_one_fault(faults(iflt),IIN_BIN,IIN_PAR,Minv,dt,nt,iflt)
+ enddo
+ endif
+ close(IIN_BIN)
+ close(IIN_PAR)
+
+ return
+100 stop 'Did not find BEGIN_FAULT block #'
+ ! WARNING TO DO: should be an MPI abort
+
+end subroutine BC_DYNFLT_init
+
+
+!---------------------------------------------------------------------
+
+ subroutine init_one_fault(bc,IIN_BIN,IIN_PAR,Minv,dt,NT,iflt)
+
+ type(bc_dynflt_type), intent(inout) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: Minv(:)
+ integer, intent(in) :: IIN_BIN,IIN_PAR,NT,iflt
+ real(kind=CUSTOM_REAL), intent(in) :: dt
+
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: jacobian2Dw
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: normal
+ integer, dimension(:,:), allocatable :: ibool1
+ real(kind=CUSTOM_REAL) :: norm
+ real(kind=CUSTOM_REAL) :: S1,S2,S3
+ integer :: n1,n2,n3
+ real(kind=CUSTOM_REAL) :: mus,mud,dc
+ integer :: nmus,nmud,ndc,ij,k,e
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: nx,ny,nz
+
+
+ NAMELIST / INIT_STRESS / S1,S2,S3,n1,n2,n3
+ NAMELIST / SWF / mus,mud,dc,nmus,nmud,ndc
+
+ read(IIN_BIN) bc%nspec,bc%nglob
+ if (bc%nspec==0) return
+
+ allocate( bc%ibulk1(bc%nglob) )
+ allocate( bc%ibulk2(bc%nglob) )
+ allocate( ibool1(NGLLSQUARE,bc%nspec) )
+ allocate(normal(NDIM,NGLLSQUARE,bc%nspec))
+ allocate(jacobian2Dw(NGLLSQUARE,bc%nspec))
+
+ allocate(bc%coord(3,(bc%nglob)))
+ read(IIN_BIN) ibool1
+ read(IIN_BIN) jacobian2Dw
+ read(IIN_BIN) normal
+ read(IIN_BIN) bc%ibulk1
+ read(IIN_BIN) bc%ibulk2
+ read(IIN_BIN) bc%coord(1,:)
+ read(IIN_BIN) bc%coord(2,:)
+ read(IIN_BIN) bc%coord(3,:)
+ bc%dt = dt
+
+ allocate( bc%B(bc%nglob) )
+ bc%B = 0e0_CUSTOM_REAL
+ allocate( nx(bc%nglob),ny(bc%nglob),nz(bc%nglob) )
+ nx = 0e0_CUSTOM_REAL
+ ny = 0e0_CUSTOM_REAL
+ nz = 0e0_CUSTOM_REAL
+ do e=1,bc%nspec
+ do ij = 1,NGLLSQUARE
+ k = ibool1(ij,e)
+ nx(k) = nx(k) + normal(1,ij,e)
+ ny(k) = ny(k) + normal(2,ij,e)
+ nz(k) = nz(k) + normal(3,ij,e)
+ bc%B(k) = bc%B(k) + jacobian2Dw(ij,e)
+ enddo
+ enddo
+ do k=1,bc%nglob
+ norm = sqrt( nx(k)*nx(k) + ny(k)*ny(k) + nz(k)*nz(k) )
+ nx(k) = nx(k) / norm
+ ny(k) = ny(k) / norm
+ nz(k) = nz(k) / norm
+ enddo
+
+ allocate( bc%R(3,3,bc%nglob) )
+ call compute_R(bc%R,bc%nglob,nx,ny,nz)
+
+! Needed in dA_Free = -K2*d2/M2 + K1*d1/M1
+ allocate(bc%invM1(bc%nglob))
+ allocate(bc%invM2(bc%nglob))
+ bc%invM1 = Minv(bc%ibulk1)
+ bc%invM2 = Minv(bc%ibulk2)
+
+! Fault impedance, Z in : Trac=T_Stick-Z*dV
+! Z = 1/( B1/M1 + B2/M2 ) / (0.5*dt)
+! T_stick = Z*Vfree traction as if the fault was stuck (no displ discontinuity)
+! NOTE: same Bi on both sides, see note above
+ allocate(bc%Z(bc%nglob))
+ bc%Z = 1.e0_CUSTOM_REAL/(0.5e0_CUSTOM_REAL*dt * bc%B *( bc%invM1 + bc%invM2 ))
+
+ allocate(bc%T(3,bc%nglob))
+ allocate(bc%D(3,bc%nglob))
+ allocate(bc%V(3,bc%nglob))
+ bc%T = 0e0_CUSTOM_REAL
+ bc%D = 0e0_CUSTOM_REAL
+ bc%V = 0e0_CUSTOM_REAL
+
+! Set initial fault stresses
+ allocate(bc%T0(3,bc%nglob))
+ S1 = 0e0_CUSTOM_REAL
+ S2 = 0e0_CUSTOM_REAL
+ S3 = 0e0_CUSTOM_REAL
+ n1=0
+ n2=0
+ n3=0
+ read(IIN_PAR, nml=INIT_STRESS)
+ bc%T0(1,:) = S1
+ bc%T0(2,:) = S2
+ bc%T0(3,:) = S3
+
+ call init_2d_distribution(bc%T0(1,:),bc%coord,IIN_PAR,n1)
+ call init_2d_distribution(bc%T0(2,:),bc%coord,IIN_PAR,n2)
+ call init_2d_distribution(bc%T0(3,:),bc%coord,IIN_PAR,n3)
+
+!WARNING : Quick and dirty free surface condition at z=0
+! do k=1,bc%nglob
+! if (abs(bc%zcoord(k)-0.e0_CUSTOM_REAL) <= SMALLVAL) bc%T0(2,k) = 0
+! end do
+
+! Set friction parameters and initialize friction variables
+ allocate( bc%swf )
+ allocate( bc%swf%mus(bc%nglob) )
+ allocate( bc%swf%mud(bc%nglob) )
+ allocate( bc%swf%Dc(bc%nglob) )
+ allocate( bc%swf%theta(bc%nglob) )
+ ! WARNING: if V_HEALING is negative we turn off healing
+ bc%swf%healing = (V_HEALING > 0e0_CUSTOM_REAL)
+
+ mus = 0.6e0_CUSTOM_REAL
+ mud = 0.1e0_CUSTOM_REAL
+ dc = 1e0_CUSTOM_REAL
+ nmus = 0
+ nmud = 0
+ ndc = 0
+
+ read(IIN_PAR, nml=SWF)
+ bc%swf%mus = mus
+ bc%swf%mud = mud
+ bc%swf%Dc = dc
+ call init_2d_distribution(bc%swf%mus,bc%coord,IIN_PAR,nmus)
+ call init_2d_distribution(bc%swf%mud,bc%coord,IIN_PAR,nmud)
+ call init_2d_distribution(bc%swf%Dc ,bc%coord,IIN_PAR,ndc)
+
+ bc%swf%theta = 0e0_CUSTOM_REAL
+ allocate(bc%MU(bc%nglob))
+ bc%MU = swf_mu(bc%swf)
+
+ call init_dataT(bc%dataT,bc%coord,bc%nglob,NT,iflt)
+ call init_dataXZ(bc%dataXZ,bc,bc%nglob)
+
+ end subroutine init_one_fault
+
+!---------------------------------------------------------------------
+ subroutine compute_R(R,nglob,nx,ny,nz)
+
+ integer :: nglob
+ real(kind=CUSTOM_REAL), intent(out) :: R(3,3,nglob)
+ real(kind=CUSTOM_REAL), dimension(nglob), intent(in) :: nx,ny,nz
+
+ real(kind=CUSTOM_REAL), dimension(nglob) :: sx,sy,sz,dx,dy,dz,norm
+
+! Percy , defining fault directions (in concordance with SCEC conventions) .
+! fault coordinates (s,d,n) = (1,2,3)
+! s = strike , d = dip , n = n.
+! 1 = strike , 2 = dip , 3 = n.
+ norm = sqrt(nx*nx+ny*ny)
+ sx = ny/norm
+ sy = -nx/norm
+ sz = 0.e0_CUSTOM_REAL
+
+ norm = sqrt(sy*sy*nz*nz+sx*sx*nz*nz+(sy*nx-ny*sx)*(nx*sy-ny*sx))
+ dx = -sy*nz/norm
+ dy = sx*nz/norm
+ dz = (sy*nx-ny*sx)/norm
+!Percy, dz is always dipwards = -1/norm , because (nx*sy-ny*sx)= - 1
+
+ R(1,1,:)=sx
+ R(1,2,:)=sy
+ R(1,3,:)=sz
+ R(2,1,:)=dx
+ R(2,2,:)=dy
+ R(2,3,:)=dz
+ R(3,1,:)=nx
+ R(3,2,:)=ny
+ R(3,3,:)=nz
+
+ end subroutine compute_R
+
+!---------------------------------------------------------------------
+! adds a value to a fault parameter inside an area with prescribed shape
+ subroutine init_2d_distribution(a,coord,iin,n)
+
+ real(kind=CUSTOM_REAL), intent(inout) :: a(:)
+ real(kind=CUSTOM_REAL), intent(in) :: coord(:,:)
+ integer, intent(in) :: iin,n
+
+ real(kind=CUSTOM_REAL) :: b(size(a))
+ character(len=10) :: shape
+ real(kind=CUSTOM_REAL) :: val, xc, yc, zc, r, l, lx,ly,lz
+ integer :: i
+
+ NAMELIST / DIST2D / shape, val, xc, yc, zc, r, l, lx,ly,lz
+
+ if (n==0) return
+
+ do i=1,n
+ shape = ''
+ xc = 0e0_CUSTOM_REAL
+ yc = 0e0_CUSTOM_REAL
+ zc = 0e0_CUSTOM_REAL
+ r = 0e0_CUSTOM_REAL
+ l = 0e0_CUSTOM_REAL
+ lx = 0e0_CUSTOM_REAL
+ ly = 0e0_CUSTOM_REAL
+ lz = 0e0_CUSTOM_REAL
+ read(iin,DIST2D)
+ select case(shape)
+ case ('circle')
+ b = heaviside( r - sqrt((coord(1,:)-xc)**2 + (coord(2,:)-yc)**2 + (coord(3,:)-zc)**2 ) )
+ case ('ellipse')
+ b = heaviside( 1e0_CUSTOM_REAL - sqrt( (coord(1,:)-xc)**2/lx**2 + (coord(2,:)-yc)**2/ly**2 + (coord(3,:)-zc)**2/lz**2 ) )
+ case ('square')
+ b = heaviside((l/2._CUSTOM_REAL)-abs(coord(1,:)-xc)+SMALLVAL) * &
+ heaviside((l/2._CUSTOM_REAL)-abs(coord(2,:)-yc)+SMALLVAL) * &
+ heaviside((l/2._CUSTOM_REAL)-abs(coord(3,:)-zc)+SMALLVAL)
+ case ('rectangle')
+ b = heaviside((lx/2._CUSTOM_REAL)-abs(coord(1,:)-xc)+SMALLVAL) * &
+ heaviside((ly/2._CUSTOM_REAL)-abs(coord(2,:)-yc)+SMALLVAL) * &
+ heaviside((lz/2._CUSTOM_REAL)-abs(coord(3,:)-zc)+SMALLVAL)
+ case default
+ stop 'bc_dynflt_3d::init_2d_distribution:: unknown shape'
+ end select
+! a =a + b*val
+!Percy , assigning straight values of each patch .
+
+ where (b /= 0) a = b*val
+ enddo
+
+ end subroutine init_2d_distribution
+
+!---------------------------------------------------------------------
+ elemental function heaviside(x)
+
+ real(kind=CUSTOM_REAL), intent(in) :: x
+ real(kind=CUSTOM_REAL) :: heaviside
+
+ if (x>=0e0_CUSTOM_REAL) then
+ heaviside = 1e0_CUSTOM_REAL
+ else
+ heaviside = 0e0_CUSTOM_REAL
+ endif
+
+ end function heaviside
+
+!=====================================================================
+! adds boundary term Bt into Force array for each fault.
+!
+ subroutine bc_dynflt_set3d_all(F,Vel,Dis)
+
+ real(kind=CUSTOM_REAL), dimension(:,:), intent(in) :: Vel,Dis
+ real(kind=CUSTOM_REAL), dimension(:,:), intent(inout) :: F
+
+ integer :: iflt
+
+ if (.not. allocated(faults)) return
+ do iflt=1,size(faults)
+ if (faults(iflt)%nspec>0) call BC_DYNFLT_set3d(faults(iflt),F,Vel,Dis,iflt)
+ enddo
+
+ end subroutine bc_dynflt_set3d_all
+
+!---------------------------------------------------------------------
+ subroutine BC_DYNFLT_set3d(bc,MxA,V,D,iflt)
+
+ use specfem_par, only:it,NSTEP
+
+ real(kind=CUSTOM_REAL), intent(inout) :: MxA(:,:)
+ type(bc_dynflt_type), intent(inout) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: V(:,:),D(:,:)
+ integer,intent(in) :: iflt
+
+
+ real(kind=CUSTOM_REAL), dimension(bc%nglob) :: strength
+ real(kind=CUSTOM_REAL), dimension(3,bc%nglob) :: T
+ real(kind=CUSTOM_REAL), dimension(bc%nglob) :: t1,t2,tnorm,tnew
+ real(kind=CUSTOM_REAL), dimension(3,bc%nglob) :: dD,dV,dA
+ real(kind=CUSTOM_REAL), dimension(bc%nglob) :: theta_old, Vnorm, Vnorm_old
+ real(kind=CUSTOM_REAL) :: half_dt
+! integer :: k
+
+ half_dt = 0.5e0_CUSTOM_REAL*bc%dt
+ theta_old = bc%swf%theta
+ Vnorm_old = sqrt(bc%V(1,:)*bc%V(1,:)+bc%V(2,:)*bc%V(2,:))
+
+! get predicted values
+ dD = get_jump(bc,D) ! dD_predictor
+ dV = get_jump(bc,V) ! dV_predictor
+ dA = get_weighted_jump(bc,MxA) ! dA_free
+
+! rotate to fault frame (tangent,normal)
+! component 3 is normal to the fault
+ dD = rotate(bc,dD,1)
+ dV = rotate(bc,dV,1)
+ dA = rotate(bc,dA,1)
+
+! T_stick
+ T(1,:) = bc%Z * ( dV(1,:) + half_dt*dA(1,:) )
+ T(2,:) = bc%Z * ( dV(2,:) + half_dt*dA(2,:) )
+ T(3,:) = bc%Z * ( dV(3,:) + half_dt*dA(3,:) )
+
+!Warning : dirty particular free surface condition z = 0.
+! where (bc%zcoord(:) > - SMALLVAL) T(2,:) = 0
+! do k=1,bc%nglob
+! if (abs(bc%zcoord(k)-0.e0_CUSTOM_REAL) < SMALLVAL) T(2,k) = 0.e0_CUSTOM_REAL
+! end do
+
+! add initial stress
+ T = T + bc%T0
+
+! Solve for normal stress (negative is compressive)
+ ! Opening implies free stress
+ if (bc%allow_opening) T(3,:) = min(T(3,:),0.e0_CUSTOM_REAL)
+
+! Update slip weakening friction:
+ ! Update slip state variable
+ ! WARNING: during opening the friction state variable should not evolve
+ call swf_update_state(bc%D,dD,bc%V,bc%swf)
+
+ ! Update friction coeficient
+ bc%MU = swf_mu(bc%swf)
+
+! combined with time-weakening for nucleation
+! if (associated(bc%twf)) bc%MU = min( bc%MU, twf_mu(bc%twf,bc%coord,time) )
+
+! Update strength
+ strength = -bc%MU * min(T(3,:),0.e0_CUSTOM_REAL)
+
+! Solve for shear stress
+ tnorm = sqrt( T(1,:)*T(1,:) + T(2,:)*T(2,:))
+ t1 = T(1,:)/tnorm
+ t2 = T(2,:)/tnorm
+ tnew = min(tnorm,strength)
+ T(1,:) = tnew * t1
+ T(2,:) = tnew * t2
+
+! Save total tractions
+ bc%T = T
+
+! Subtract initial stress
+ T = T - bc%T0
+
+! Update slip acceleration da=da_free-T/(0.5*dt*Z)
+ dA(1,:) = dA(1,:) - T(1,:)/(bc%Z*half_dt)
+ dA(2,:) = dA(2,:) - T(2,:)/(bc%Z*half_dt)
+ dA(3,:) = dA(3,:) - T(3,:)/(bc%Z*half_dt)
+
+! Update slip and slip rate, in fault frame
+ bc%D = dD
+ bc%V = dV + half_dt*dA
+
+! Rotate tractions back to (x,y,z) frame
+ T = rotate(bc,T,-1)
+
+! Add boundary term B*T to M*a
+ MxA(1,bc%ibulk1) = MxA(1,bc%ibulk1) + bc%B*T(1,:)
+ MxA(2,bc%ibulk1) = MxA(2,bc%ibulk1) + bc%B*T(2,:)
+ MxA(3,bc%ibulk1) = MxA(3,bc%ibulk1) + bc%B*T(3,:)
+
+ MxA(1,bc%ibulk2) = MxA(1,bc%ibulk2) - bc%B*T(1,:)
+ MxA(2,bc%ibulk2) = MxA(2,bc%ibulk2) - bc%B*T(2,:)
+ MxA(3,bc%ibulk2) = MxA(3,bc%ibulk2) - bc%B*T(3,:)
+
+
+!-- intermediate storage of outputs --
+ Vnorm = sqrt(bc%V(1,:)*bc%V(1,:)+bc%V(2,:)*bc%V(2,:))
+ call store_dataXZ(bc%dataXZ, strength, theta_old, bc%swf%theta, bc%swf%dc, &
+ Vnorm_old, Vnorm, it*bc%dt,bc%dt)
+ call store_dataT(bc%dataT,bc%D,bc%V,bc%T,it)
+
+
+!-- outputs --
+! write dataT every NTOUT time step or at the end of simulation
+ if ( mod(it,NTOUT) == 0 .or. it==NSTEP) call SCEC_write_dataT(bc%dataT,bc%dt,it)
+! write dataXZ every NSNAP time step
+ if ( mod(it,NSNAP) == 0) call write_dataXZ(bc%dataXZ,it,iflt)
+ if ( it == NSTEP) call SCEC_Write_RuptureTime(bc%dataXZ,bc%dt,NSTEP,iflt)
+
+ end subroutine BC_DYNFLT_set3d
+
+!===============================================================
+ function get_jump (bc,v) result(dv)
+
+ type(bc_dynflt_type), intent(in) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: v(:,:)
+ real(kind=CUSTOM_REAL) :: dv(3,bc%nglob)
+
+! diference between side 2 and side 1 of fault nodes. dv
+ dv(1,:) = v(1,bc%ibulk2)-v(1,bc%ibulk1)
+ dv(2,:) = v(2,bc%ibulk2)-v(2,bc%ibulk1)
+ dv(3,:) = v(3,bc%ibulk2)-v(3,bc%ibulk1)
+
+ end function get_jump
+
+!---------------------------------------------------------------------
+ function get_weighted_jump (bc,f) result(da)
+
+ type(bc_dynflt_type), intent(in) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: f(:,:)
+
+ real(kind=CUSTOM_REAL) :: da(3,bc%nglob)
+
+! diference between side 2 and side 1 of fault nodes. M-1 * F
+ da(1,:) = bc%invM2*f(1,bc%ibulk2)-bc%invM1*f(1,bc%ibulk1)
+ da(2,:) = bc%invM2*f(2,bc%ibulk2)-bc%invM1*f(2,bc%ibulk1)
+ da(3,:) = bc%invM2*f(3,bc%ibulk2)-bc%invM1*f(3,bc%ibulk1)
+
+ end function get_weighted_jump
+
+!----------------------------------------------------------------------
+ function rotate(bc,v,fb) result(vr)
+
+ type(bc_dynflt_type), intent(in) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: v(3,bc%nglob)
+ integer, intent(in) :: fb
+ real(kind=CUSTOM_REAL) :: vr(3,bc%nglob)
+
+! Percy, tangential direction Vt, equation 7 of Pablo's notes in agreement with SPECFEM3D
+
+ ! forward rotation
+ if (fb==1) then
+ vr(1,:) = v(1,:)*bc%R(1,1,:)+v(2,:)*bc%R(1,2,:)+v(3,:)*bc%R(1,3,:) ! vs
+ vr(2,:) = v(1,:)*bc%R(2,1,:)+v(2,:)*bc%R(2,2,:)+v(3,:)*bc%R(2,3,:) ! vd
+ vr(3,:) = v(1,:)*bc%R(3,1,:)+v(2,:)*bc%R(3,2,:)+v(3,:)*bc%R(3,3,:) ! vn
+
+! backward rotation
+ else
+ vr(1,:) = v(1,:)*bc%R(1,1,:)+v(2,:)*bc%R(2,1,:)+v(3,:)*bc%R(3,1,:) !vx
+ vr(2,:) = v(1,:)*bc%R(1,2,:)+v(2,:)*bc%R(2,2,:)+v(3,:)*bc%R(3,2,:) !vy
+ vr(3,:) = v(1,:)*bc%R(1,3,:)+v(2,:)*bc%R(2,3,:)+v(3,:)*bc%R(3,3,:) !vz
+
+ endif
+
+ end function rotate
+
+
+!=====================================================================
+ subroutine swf_update_state(dold,dnew,vold,f)
+
+ real(kind=CUSTOM_REAL), dimension(:,:), intent(in) :: vold,dold,dnew
+ type(swf_type), intent(inout) :: f
+
+ real(kind=CUSTOM_REAL) :: vnorm
+ integer :: k,npoin
+
+ f%theta = f%theta + sqrt( (dold(1,:)-dnew(1,:))**2 + (dold(2,:)-dnew(2,:))**2 )
+
+ if (f%healing) then
+ npoin = size(vold,2)
+ do k=1,npoin
+ vnorm = sqrt(vold(1,k)**2 + vold(2,k)**2)
+ if (vnorm<V_HEALING) f%theta(k) = 0e0_CUSTOM_REAL
+ enddo
+ endif
+ end subroutine swf_update_state
+
+
+!=====================================================================
+! Friction coefficient
+ function swf_mu(f) result(mu)
+
+ type(swf_type), intent(in) :: f
+ real(kind=CUSTOM_REAL) :: mu(size(f%theta))
+
+ !-- linear slip weakening:
+
+ mu = f%mus -(f%mus-f%mud)/f%dc *f%theta
+ mu = max( mu, f%mud)
+
+ end function swf_mu
+
+
+!===============================================================
+! OUTPUTS
+
+ subroutine init_dataT(DataT,coord,nglob,NT,iflt)
+ ! NT = total number of time steps
+
+ integer, intent(in) :: nglob,NT,iflt
+ real(kind=CUSTOM_REAL), intent(in) :: coord(3,nglob)
+ type (dataT_type), intent(out) :: DataT
+
+ real(kind=CUSTOM_REAL) :: xtarget,ytarget,ztarget,dist,distkeep
+ integer :: i, iglob , IIN, ier, jflt, np, k
+ character(len=70) :: tmpname
+
+ ! 1. read fault output coordinates from user file,
+ ! 2. define iglob: the fault global index of the node nearest to user
+ ! requested coordinate
+
+ IIN = 251
+ open(IIN,file='DATA/FAULT/FAULT_STATIONS.in',status='old',action='read',iostat=ier)
+ read(IIN,*) np
+ DataT%npoin =0
+ do i=1,np
+ read(IIN,*) xtarget,ytarget,ztarget,tmpname,jflt
+ if (jflt==iflt) DataT%npoin = DataT%npoin +1
+ enddo
+ close(IIN)
+
+ if (DataT%npoin == 0) return
+
+ allocate(DataT%iglob(DataT%npoin))
+ allocate(DataT%name(DataT%npoin))
+
+ open(IIN,file='DATA/FAULT/FAULT_STATIONS.in',status='old',action='read',iostat=ier)
+ if( ier /= 0 ) stop 'error opening FAULT_STATIONS file'
+ read(IIN,*) np
+ k = 0
+ do i=1,np
+ read(IIN,*) xtarget,ytarget,ztarget,tmpname,jflt
+ if (jflt/=iflt) cycle
+ k = k+1
+ DataT%name(k) = tmpname
+ !search nearest node
+ distkeep = huge(distkeep)
+
+ do iglob=1,nglob
+ dist = sqrt((coord(1,iglob)-xtarget)**2 &
+ + (coord(2,iglob)-ytarget)**2 &
+ + (coord(3,iglob)-ztarget)**2)
+ if (dist < distkeep) then
+ distkeep = dist
+ DataT%iglob(k) = iglob
+ endif
+ enddo
+ enddo
+
+ ! 3. allocate arrays and set to zero
+ allocate(DataT%d1(NT,DataT%npoin))
+ allocate(DataT%v1(NT,DataT%npoin))
+ allocate(DataT%t1(NT,DataT%npoin))
+ allocate(DataT%d2(NT,DataT%npoin))
+ allocate(DataT%v2(NT,DataT%npoin))
+ allocate(DataT%t2(NT,DataT%npoin))
+ allocate(DataT%t3(NT,DataT%npoin))
+ DataT%d1 = 0e0_CUSTOM_REAL
+ DataT%v1 = 0e0_CUSTOM_REAL
+ DataT%t1 = 0e0_CUSTOM_REAL
+ DataT%d2 = 0e0_CUSTOM_REAL
+ DataT%v2 = 0e0_CUSTOM_REAL
+ DataT%t2 = 0e0_CUSTOM_REAL
+ DataT%t3 = 0e0_CUSTOM_REAL
+
+ close(IIN)
+
+ end subroutine init_dataT
+
+
+!---------------------------------------------------------------
+ subroutine store_dataT(dataT,d,v,t,itime)
+
+ type(dataT_type), intent(inout) :: dataT
+ real(kind=CUSTOM_REAL), dimension(:,:), intent(in) :: d,v,t
+ integer, intent(in) :: itime
+
+ integer :: i,k
+
+ do i=1,dataT%npoin
+ k = dataT%iglob(i)
+ dataT%d1(itime,i) = d(1,k)
+ dataT%d2(itime,i) = d(2,k)
+ dataT%v1(itime,i) = v(1,k)
+ dataT%v2(itime,i) = v(2,k)
+ dataT%t1(itime,i) = t(1,k)
+ dataT%t2(itime,i) = t(2,k)
+ dataT%t3(itime,i) = t(3,k)
+ enddo
+
+ end subroutine store_dataT
+
+
+!-----------------------------------------------------------------
+ subroutine write_dataT_all(nt)
+
+ integer, intent(in) :: nt
+
+ integer :: i
+
+ if (.not.allocated(faults)) return
+ do i = 1,size(faults)
+ call SCEC_write_dataT(faults(i)%dataT,faults(i)%dt,nt)
+ enddo
+
+ end subroutine write_dataT_all
+
+!------------------------------------------------------------------------
+ subroutine SCEC_write_dataT(dataT,DT,NT)
+
+ type(dataT_type), intent(in) :: dataT
+ real(kind=CUSTOM_REAL), intent(in) :: DT
+ integer, intent(in) :: NT
+
+ integer :: i,k,IOUT
+ character :: NTchar*5
+
+ IOUT = 121 !WARNING: not very robust. Could instead look for an available ID
+
+ write(NTchar,1) NT
+ NTchar = adjustl(NTchar)
+
+1 format(I5)
+ do i=1,dataT%npoin
+
+ open(IOUT,file='OUTPUT_FILES/'//trim(dataT%name(i))//'.dat',status='replace')
+ write(IOUT,*) "# problem=TPV15"
+ write(IOUT,*) "# author=Galvez, Ampuero, Nissen-Meyer"
+ write(IOUT,*) "# date=2011/xx/xx"
+ write(IOUT,*) "# code=SPECFEM3D_FAULT "
+ write(IOUT,*) "# code_version=1.1"
+ write(IOUT,*) "# element_size=100 m (*4 GLL nodes)"
+ write(IOUT,*) "# time_step=",DT
+ write(IOUT,*) "# num_time_steps=",NT
+ write(IOUT,*) "# location=",trim(dataT%name(i))
+ write(IOUT,*) "# Time series in 8 column of E15.7"
+ write(IOUT,*) "# Column #1 = Time (s)"
+ write(IOUT,*) "# Column #2 = horizontal right-lateral slip (m)"
+ write(IOUT,*) "# Column #3 = horizontal right-lateral slip rate (m/s)"
+ write(IOUT,*) "# Column #4 = horizontal right-lateral shear stress (MPa)"
+ write(IOUT,*) "# Column #5 = vertical up-dip slip (m)"
+ write(IOUT,*) "# Column #6 = vertical up-dip slip rate (m/s)"
+ write(IOUT,*) "# Column #7 = vertical up-dip shear stress (MPa)"
+ write(IOUT,*) "# Column #8 = normal stress (MPa)"
+ write(IOUT,*) "#"
+ write(IOUT,*) "# The line below lists the names of the data fields:"
+ write(IOUT,*) "#t h-slip h-slip-rate h-shear-stress v-slip v-slip-rate v-shear-stress n-stress"
+ write(IOUT,*) "#"
+ do k=1,NT
+ write(IOUT,'(8(E15.7))') k*DT, dataT%d1(k,i), dataT%v1(k,i), dataT%t1(k,i)/1.0e6_CUSTOM_REAL, &
+ dataT%d2(k,i), dataT%v2(k,i), dataT%t2(k,i)/1.0e6_CUSTOM_REAL, &
+ dataT%t3(k,i)/1.0e6_CUSTOM_REAL
+ enddo
+ close(IOUT)
+ enddo
+
+ end subroutine SCEC_write_dataT
+
+!-------------------------------------------------------------------------------------------------
+
+ subroutine SCEC_Write_RuptureTime(dataXZ,DT,NT,iflt)
+
+ type(dataXZ_type), intent(in) :: dataXZ
+ real(kind=CUSTOM_REAL), intent(in) :: DT
+ integer, intent(in) :: NT,iflt
+
+ integer :: i,IOUT
+ character(len=70) :: filename
+
+ write(filename,"('OUTPUT_FILES/RuptureTime_Fault',I0)") iflt
+
+ IOUT = 121 !WARNING: not very robust. Could instead look for an available ID
+
+ open(IOUT,file=trim(filename),status='replace')
+ write(IOUT,*) "# problem=TPV5"
+ write(IOUT,*) "# author=Galvez, Ampuero, Tarje"
+ write(IOUT,*) "# date=2011/xx/xx"
+ write(IOUT,*) "# code=SPECFEM3D_FAULT"
+ write(IOUT,*) "# code_version=1.1"
+ write(IOUT,*) "# element_size=100 m (*4 GLL nodes)"
+ write(IOUT,*) "# time_step=",DT
+ write(IOUT,*) "# num_time_steps=",NT
+ write(IOUT,*) "# Column #1 = horizontal coordinate, distance along strike (m)"
+ write(IOUT,*) "# Column #2 = vertical coordinate, distance down-dip (m)"
+ write(IOUT,*) "# Column #3 = rupture time (s)"
+ write(IOUT,*) "# x y z time"
+ do i = 1,size(dataXZ%tRUP)
+ write(IOUT,'(4(E15.7))') dataXZ%xcoord(i), dataXZ%ycoord(i), dataXZ%zcoord(i), dataXZ%tRUP(i)
+ end do
+
+ close(IOUT)
+
+ end subroutine SCEC_Write_RuptureTime
+
+!-------------------------------------------------------------------------------------------------
+
+ subroutine init_dataXZ(DataXZ,bc,nglob)
+
+ type(dataXZ_type), intent(inout) :: DataXZ
+ type(bc_dynflt_type) :: bc
+ integer, intent(in) :: nglob
+
+ allocate(DataXZ%stg(nglob))
+ DataXZ%sta => bc%swf%theta
+ DataXZ%d1 => bc%d(1,:)
+ DataXZ%d2 => bc%d(2,:)
+ DataXZ%v1 => bc%v(1,:)
+ DataXZ%v2 => bc%v(2,:)
+ DataXZ%t1 => bc%t(1,:)
+ DataXZ%t2 => bc%t(2,:)
+ DataXZ%t3 => bc%t(3,:)
+ DataXZ%xcoord => bc%coord(1,:)
+ DataXZ%ycoord => bc%coord(2,:)
+ DataXZ%zcoord => bc%coord(3,:)
+ allocate(DataXZ%tRUP(nglob))
+ allocate(DataXZ%tPZ(nglob))
+
+!Percy , setting up initial rupture time null for all faults.
+ DataXZ%tRUP = 0e0_CUSTOM_REAL
+ DataXZ%tPZ = 0e0_CUSTOM_REAL
+
+
+ end subroutine init_dataXZ
+
+!---------------------------------------------------------------
+subroutine store_dataXZ(dataXZ,stg,dold,dnew,dc,vold,vnew,time,dt)
+
+ type(dataXZ_type), intent(inout) :: dataXZ
+ real(kind=CUSTOM_REAL), dimension(:), intent(in) :: stg,dold,dnew,dc,vold,vnew
+ real(kind=CUSTOM_REAL), intent(in) :: time,dt
+
+ integer :: i
+
+! "stg" : strength .
+
+ dataXZ%stg = stg
+
+ do i = 1,size(stg)
+ ! process zone time = first time when slip = dc (break down process).
+ ! with linear time interpolation
+ if (dataXZ%tPZ(i)==0e0_CUSTOM_REAL) then
+ if (dold(i)<=dc(i) .and. dnew(i) >= dc(i)) then
+ dataXZ%tPZ(i) = time-dt*(dnew(i)-dc(i))/(dnew(i)-dold(i))
+ endif
+ endif
+ ! rupture time = first time when slip velocity = vc
+ ! with linear time interpolation
+ ! vc should be pre-defined as input data .
+
+ if (dataXZ%tRUP(i)==0e0_CUSTOM_REAL) then
+ if (vold(i)<=V_RUPT .and. vnew(i)>=V_RUPT) dataXZ%tRUP(i)= time-dt*(vnew(i)-V_RUPT)/(vnew(i)-vold(i))
+ endif
+ enddo
+
+
+! To do : add stress criteria (firs time strength is reached).
+
+ ! note: the other arrays in dataXZ are pointers to arrays in bc
+ ! they do not need to be updated here
+
+ end subroutine store_dataXZ
+
+!---------------------------------------------------------------
+ subroutine write_dataXZ(dataXZ,itime,iflt)
+
+
+ type(dataXZ_type), intent(in) :: dataXZ
+ integer, intent(in) :: itime,iflt
+
+ character(len=70) :: filename
+
+
+ write(filename,"('OUTPUT_FILES/Snapshot',I0,'_F',I0,'.bin')") itime,iflt
+ open(unit=IOUT, file= trim(filename), status='replace', form='formatted',action='write')
+! open(unit=IOUT, file= trim(filename), status='replace', form='unformatted')
+! NOTE : It had to be adopted formatted output to avoid conflicts readings with different
+! compilers.
+
+ write(IOUT,"(5F24.15)") dataXZ%xcoord,dataXZ%ycoord,dataXZ%zcoord,dataXZ%v1,dataXZ%v2
+
+
+! WARNING: for the case of multiple faults the filename must contain a fault identifier
+! (a separate snapshot file for each fault)
+! write(filename,"('OUTPUT_FILES/Snapshot',I0,'_F',I0,'.bin')") itime,iflt
+!
+! open(unit=IOUT, file= trim(filename), status='replace', form='unformatted')
+
+! write(IOUT) dataXZ%xcoord
+! write(IOUT) dataXZ%ycoord
+! write(IOUT) dataXZ%zcoord
+! write(IOUT) dataXZ%d1
+! write(IOUT) dataXZ%d2
+! write(IOUT) dataXZ%v1
+! write(IOUT) dataXZ%v2
+! write(IOUT) dataXZ%t1
+! write(IOUT) dataXZ%t2
+! write(IOUT) dataXZ%t3
+! write(IOUT) dataXZ%sta
+! write(IOUT) dataXZ%stg
+! write(IOUT) dataXZ%tRUP
+! write(IOUT) dataXZ%tPZ
+ close(IOUT)
+
+ end subroutine write_dataXZ
+
+
+end module fault_solver
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/devel/fault_solver_kinematic.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/devel/fault_solver_kinematic.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/devel/fault_solver_kinematic.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,718 @@
+!=====================================================================
+!
+! 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.
+!
+!===============================================================================================================
+
+! This module was written by:
+! Percy Galvez , Jean-Paul Ampuero and Javier Ruiz
+! based on fault_solver.f90
+
+module fault_solver_kinematic
+
+ implicit none
+
+ include 'constants.h'
+
+ private
+
+! outputs on selected fault nodes at every time step:
+! slip, slip velocity, fault stresses
+ type dataT_type
+ integer :: npoin
+ integer, dimension(:), pointer :: iglob
+ real(kind=CUSTOM_REAL), dimension(:,:), pointer :: d1,v1,t1,d2,v2,t2,t3
+ character(len=70), dimension(:), pointer :: name
+ end type dataT_type
+
+! DATAXZ_type used to read snapshots (temporal)
+ type dataXZ_type
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: d1, d2, v1, v2, & !Slip and Slip rate.
+ t1, t2, t3 !Tractions.
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: xcoord,ycoord,zcoord
+ integer :: npoin
+ end type dataXZ_type
+
+ type bc_kinflt_type
+ private
+ integer :: nspec,nglob
+ real(kind=CUSTOM_REAL) :: dt
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: B,invM1,invM2,Z
+ real(kind=CUSTOM_REAL), dimension(:,:), pointer :: T,slip,slip_rate,coord
+ real(kind=CUSTOM_REAL), dimension(:,:,:), pointer :: R
+ integer, dimension(:), pointer :: ibulk1, ibulk2
+ type(dataT_type) :: dataT
+ type(dataXZ_type) :: dataXZ
+ real(kind=CUSTOM_REAL) :: kin_dt
+ integer :: kin_it
+ real(kind=CUSTOM_REAL), dimension(:,:), pointer :: v_kin_t1,v_kin_t2
+ end type bc_kinflt_type
+
+ type(bc_kinflt_type), allocatable, save :: faults(:)
+
+!Number of time steps defined by the user : NTOUT
+ integer, save :: NTOUT,NSNAP
+
+ integer, save :: SIMULATION_TYPE_KIN = 2
+
+! integer , save :: size_Kelvin_Voigt
+
+! real(kind=CUSTOM_REAL), allocatable, save :: Kelvin_Voigt_eta(:)
+
+
+! public :: BC_KINFLT_init, BC_KINFLT_set_all, Kelvin_Voigt_eta, &
+! size_Kelvin_Voigt, SIMULATION_TYPE_KIN
+
+ public :: BC_KINFLT_init, BC_KINFLT_set_all, SIMULATION_TYPE_KIN
+
+
+contains
+
+
+!=====================================================================
+! BC_KINFLT_init initializes kinematic faults
+!
+! prname fault database is read from file prname_fault_db.bin
+! Minv inverse mass matrix
+! dt global time step
+!
+subroutine BC_KINFLT_init(prname,Minv,DTglobal,nt)
+
+ character(len=256), intent(in) :: prname ! 'proc***'
+ real(kind=CUSTOM_REAL), intent(in) :: Minv(:)
+ double precision, intent(in) :: DTglobal
+ integer, intent(in) :: nt
+
+ real(kind=CUSTOM_REAL) :: dt
+ integer :: iflt,ier,dummy_idfault
+ integer :: nbfaults
+ character(len=256) :: filename
+ integer, parameter :: IIN_PAR =151
+ integer, parameter :: IIN_BIN =170
+ real(kind=CUSTOM_REAL) :: DUMMY
+
+ NAMELIST / BEGIN_FAULT / dummy_idfault
+
+ dummy_idfault = 0
+
+! filename = prname(1:len_trim(prname))//'Kelvin_voigt_eta.bin'
+! open(unit=IIN_BIN,file=trim(filename),status='old',action='read',form='unformatted',iostat=ier)
+! if( ier /= 0 ) stop 'Haven not found proc*_Kelvin_voigt_eta.bin'
+! read(IIN_BIN) size_Kelvin_Voigt
+! if (size_Kelvin_Voigt > 0) then
+! allocate(Kelvin_Voigt_eta(size_Kelvin_Voigt))
+! read(IIN_BIN) Kelvin_Voigt_eta
+! endif
+! Close(IIN_BIN)
+
+ open(unit=IIN_PAR,file='DATA/FAULT/Par_file_faults.in',status='old',iostat=ier)
+ if( ier /= 0 ) then
+ write(6,*) 'Have not found Par_file_faults.in: assume no faults'
+ return
+ endif
+
+ dt = real(DTglobal)
+ filename = prname(1:len_trim(prname))//'fault_db.bin'
+ open(unit=IIN_BIN,file=trim(filename),status='old',action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) stop 'Have not found proc*_fault_db.bin'
+! WARNING TO DO: should be an MPI abort
+
+ read(IIN_PAR,*) nbfaults
+ do iflt=1,nbfaults
+ read(IIN_PAR,*)
+ enddo
+
+ read(IIN_PAR,*) SIMULATION_TYPE_KIN
+ if ( SIMULATION_TYPE_KIN == 2 ) then
+ read(IIN_PAR,*) NTOUT
+ read(IIN_PAR,*) NSNAP
+ read(IIN_PAR,*) DUMMY
+ read(IIN_PAR,*) DUMMY
+ read(IIN_BIN) nbfaults ! should be the same as in IIN_PAR
+ allocate( faults(nbfaults) )
+ do iflt=1,nbfaults
+ read(IIN_PAR,nml=BEGIN_FAULT,end=100)
+ call init_one_fault(faults(iflt),IIN_BIN,IIN_PAR,Minv,dt,nt,iflt)
+ enddo
+ endif
+ close(IIN_BIN)
+ close(IIN_PAR)
+
+ return
+100 stop 'Did not find BEGIN_FAULT block #'
+ ! WARNING TO DO: should be an MPI abort
+
+end subroutine BC_KINFLT_init
+
+
+!---------------------------------------------------------------------
+
+subroutine init_one_fault(bc,IIN_BIN,IIN_PAR,Minv,dt,NT,iflt)
+
+ type(bc_kinflt_type), intent(inout) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: Minv(:)
+ integer, intent(in) :: IIN_BIN,IIN_PAR,NT,iflt
+ real(kind=CUSTOM_REAL), intent(in) :: dt
+
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: jacobian2Dw
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: normal
+ integer, dimension(:,:), allocatable :: ibool1
+ real(kind=CUSTOM_REAL) :: norm
+ integer :: ij,k,e
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: nx,ny,nz
+ real(kind=CUSTOM_REAL) :: kindt
+
+ NAMELIST / KINPAR / kindt
+
+ read(IIN_BIN) bc%nspec,bc%nglob
+ if (bc%nspec==0) return
+
+ allocate( bc%ibulk1(bc%nglob) )
+ allocate( bc%ibulk2(bc%nglob) )
+ allocate( ibool1(NGLLSQUARE,bc%nspec) )
+ allocate(normal(NDIM,NGLLSQUARE,bc%nspec))
+ allocate(jacobian2Dw(NGLLSQUARE,bc%nspec))
+ allocate(bc%coord(3,bc%nglob))
+
+ read(IIN_BIN) ibool1
+ read(IIN_BIN) jacobian2Dw
+ read(IIN_BIN) normal
+ read(IIN_BIN) bc%ibulk1
+ read(IIN_BIN) bc%ibulk2
+ read(IIN_BIN) bc%coord(1,:)
+ read(IIN_BIN) bc%coord(2,:)
+ read(IIN_BIN) bc%coord(3,:)
+ bc%dt = dt
+
+ allocate( bc%B(bc%nglob) )
+ bc%B = 0e0_CUSTOM_REAL
+ allocate( nx(bc%nglob),ny(bc%nglob),nz(bc%nglob) )
+ nx = 0e0_CUSTOM_REAL
+ ny = 0e0_CUSTOM_REAL
+ nz = 0e0_CUSTOM_REAL
+ do e=1,bc%nspec
+ do ij = 1,NGLLSQUARE
+ k = ibool1(ij,e)
+ nx(k) = nx(k) + normal(1,ij,e)
+ ny(k) = ny(k) + normal(2,ij,e)
+ nz(k) = nz(k) + normal(3,ij,e)
+ bc%B(k) = bc%B(k) + jacobian2Dw(ij,e)
+ enddo
+ enddo
+ ! TO DO: assemble B and n across processors
+ do k=1,bc%nglob
+ norm = sqrt( nx(k)*nx(k) + ny(k)*ny(k) + nz(k)*nz(k) )
+ nx(k) = nx(k) / norm
+ ny(k) = ny(k) / norm
+ nz(k) = nz(k) / norm
+ enddo
+ allocate( bc%R(3,3,bc%nglob) )
+ call compute_R(bc%R,bc%nglob,nx,ny,nz)
+ deallocate(nx,ny,nz)
+! Needed in dA_Free = -K2*d2/M2 + K1*d1/M1
+ allocate(bc%invM1(bc%nglob))
+ allocate(bc%invM2(bc%nglob))
+ bc%invM1 = Minv(bc%ibulk1)
+ bc%invM2 = Minv(bc%ibulk2)
+
+! Fault impedance, Z in : Trac=T_Stick-Z*dV
+! Z = 1/( B1/M1 + B2/M2 ) / (0.5*dt)
+! T_Stick = Z*Vfree traction as if the fault was stuck (no displ discontinuity)
+! NOTE: same Bi on both sides, see note above
+ allocate(bc%Z(bc%nglob))
+ bc%Z = 1.e0_CUSTOM_REAL/(0.5e0_CUSTOM_REAL*dt * bc%B *( bc%invM1 + bc%invM2 ))
+
+ allocate(bc%T(3,bc%nglob))
+ allocate(bc%slip(3,bc%nglob))
+ allocate(bc%slip_rate(3,bc%nglob))
+ bc%T = 0e0_CUSTOM_REAL
+ bc%slip = 0e0_CUSTOM_REAL
+ bc%slip_rate = 0e0_CUSTOM_REAL
+! Dt between two loaded slip_rates
+
+ read(IIN_PAR,nml=KINPAR)
+ bc%kin_dt = kindt
+
+ bc%kin_it=0
+! Always have in memory the slip-rate model at two times, t1 and t2,
+! spatially interpolated in the spectral element grid
+ allocate(bc%v_kin_t1(2,bc%nglob))
+ allocate(bc%v_kin_t2(2,bc%nglob))
+ bc%v_kin_t1 = 0e0_CUSTOM_REAL
+ bc%v_kin_t2 = 0e0_CUSTOM_REAL
+
+ call init_dataT(bc%dataT,bc%coord,bc%nglob,NT,iflt)
+ call init_dataXZ(bc%dataXZ,bc%nglob)
+
+end subroutine init_one_fault
+
+!---------------------------------------------------------------------
+subroutine compute_R(R,nglob,nx,ny,nz)
+
+ integer :: nglob
+ real(kind=CUSTOM_REAL), intent(out) :: R(3,3,nglob)
+ real(kind=CUSTOM_REAL), dimension(nglob), intent(in) :: nx,ny,nz
+
+ real(kind=CUSTOM_REAL), dimension(nglob) :: sx,sy,sz,dx,dy,dz,norm
+
+! Percy , defining fault directions (in concordance with SCEC conventions) .
+! fault coordinates (s,d,n) = (1,2,3)
+! s = strike , d = dip , n = n.
+! 1 = strike , 2 = dip , 3 = n.
+ norm = sqrt(nx*nx+ny*ny)
+ sx = ny/norm
+ sy = -nx/norm
+ sz = 0.e0_CUSTOM_REAL
+
+ norm = sqrt(sy*sy*nz*nz+sx*sx*nz*nz+(sy*nx-ny*sx)*(nx*sy-ny*sx))
+ dx = -sy*nz/norm
+ dy = sx*nz/norm
+ dz = (sy*nx-ny*sx)/norm
+!Percy, dz is always dipwards = -1/norm , because (nx*sy-ny*sx)= - 1
+
+ R(1,1,:)=sx
+ R(1,2,:)=sy
+ R(1,3,:)=sz
+ R(2,1,:)=dx
+ R(2,2,:)=dy
+ R(2,3,:)=dz
+ R(3,1,:)=nx
+ R(3,2,:)=ny
+ R(3,3,:)=nz
+
+
+end subroutine compute_R
+
+
+!=====================================================================
+! adds boundary term Bt to Force array for each fault.
+!
+subroutine BC_KINFLT_set_all(F,Vel,Dis)
+
+ real(kind=CUSTOM_REAL), dimension(:,:), intent(in) :: Vel,Dis
+ real(kind=CUSTOM_REAL), dimension(:,:), intent(inout) :: F
+
+ integer :: iflt
+
+ if (.not. allocated(faults)) return
+ do iflt=1,size(faults)
+ if (faults(iflt)%nspec>0) call BC_KINFLT_set_single(faults(iflt),F,Vel,Dis,iflt)
+ enddo
+
+end subroutine BC_KINFLT_set_all
+
+!---------------------------------------------------------------------
+subroutine BC_KINFLT_set_single(bc,MxA,V,D,iflt)
+
+ use specfem_par, only:it,NSTEP
+
+ real(kind=CUSTOM_REAL), intent(inout) :: MxA(:,:)
+ type(bc_kinflt_type), intent(inout) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: V(:,:),D(:,:)
+ integer,intent(in) :: iflt
+ integer :: it_kin,itime
+ real(kind=CUSTOM_REAL), dimension(3,bc%nglob) :: T
+ real(kind=CUSTOM_REAL), dimension(3,bc%nglob) :: dD,dV,dA,dV_free
+ real(kind=CUSTOM_REAL) :: t1,t2
+ real(kind=CUSTOM_REAL) :: half_dt,time
+
+ half_dt = 0.5e0_CUSTOM_REAL*bc%dt
+
+! get predicted values
+ dD = get_jump(bc,D) ! dD_predictor
+ dV = get_jump(bc,V) ! dV_predictor
+ dA = get_weighted_jump(bc,MxA) ! dA_free
+
+! rotate to fault frame (tangent,normal)
+! component 3 is normal to the fault
+ dD = rotate(bc,dD,1)
+ dV = rotate(bc,dV,1)
+ dA = rotate(bc,dA,1)
+
+! Time marching
+ time = it*bc%dt
+! Slip_rate step "it_kin"
+ it_kin = bc%kin_it*nint(bc%kin_dt/bc%dt)
+! (nint : fortran round (nearest whole number) ,
+! if nint(a)=0.5 then "a" get upper bound )
+
+! Loading the next slipt_rate one ahead it.
+! This is done in case bc%kin_dt
+! if (it_kin == it) it_kin=it_kin+1 !
+
+
+!NOTE : it and it_kin is being used due to integers are exact numbers.
+ if (it > it_kin) then
+
+ print*, 'it :'
+ print*, it
+ print*, 'it_kin'
+ print*, it_kin
+
+ bc%kin_it = bc%kin_it +1
+ bc%v_kin_t1 = bc%v_kin_t2
+ print*, 'loading v_kin_t2'
+ !Temporal : just for snapshots file names kin_dt=0.1 , dt=0.0001
+ !snapshot(100=itime).. : itime=kin_it*(kin_dt/dt)
+ itime = bc%kin_it*nint(bc%kin_dt/bc%dt)
+ call load_vslip_snapshots(bc%dataXZ,itime,bc%nglob,iflt)
+! loading slip rates
+ bc%v_kin_t2(1,:)=bc%dataXZ%v1
+ bc%v_kin_t2(2,:)=bc%dataXZ%v2
+
+ !linear interpolation in time between t1 and t2
+ !REMARK , bc%kin_dt is the delta "t" between two snapshots.
+ t1 = (bc%kin_it-1) * bc%kin_dt
+ t2 = bc%kin_it * bc%kin_dt
+
+ endif
+
+! Kinematic velocity_rate
+! bc%slip_rate : Imposed apriori and read from slip rate snapshots (from time reversal)
+! linear interpolate between consecutive kinematic time steps.
+! slip_rate will be given each time step.
+ bc%slip_rate(1,:) = ( (t2 - time)*bc%v_kin_t1(1,:) + (time - t1)*bc%v_kin_t2(1,:) )/ bc%kin_dt
+ bc%slip_rate(2,:) = ( (t2 - time)*bc%v_kin_t1(2,:) + (time - t1)*bc%v_kin_t2(2,:) )/ bc%kin_dt
+
+!dV_free = dV_predictor + (dt/2)*dA_free
+ dV_free(1,:) = dV(1,:)+half_dt*dA(1,:)
+ dV_free(2,:) = dV(2,:)+half_dt*dA(2,:)
+ dV_free(3,:) = dV(3,:)+half_dt*dA(3,:)
+
+! T = Z*( dV_free - V_slip_rate) , V_slip_rate known apriori as input.
+! CONVENTION : T(ibulk1)=T=-T(ibulk2)
+ T(1,:) = bc%Z * ( dV_free(1,:) -bc%slip_rate(1,:) )
+ T(2,:) = bc%Z * ( dV_free(2,:) -bc%slip_rate(2,:) )
+ T(3,:) = bc%Z * ( dV_free(3,:) )
+
+! Save tractions
+ bc%T = T
+
+! Update slip in fault frame
+ bc%slip = dD
+
+! Rotate tractions back to (x,y,z) frame
+ T = rotate(bc,T,-1)
+
+! Add boundary term B*T to M*a
+ MxA(1,bc%ibulk1) = MxA(1,bc%ibulk1) + bc%B*T(1,:)
+ MxA(2,bc%ibulk1) = MxA(2,bc%ibulk1) + bc%B*T(2,:)
+ MxA(3,bc%ibulk1) = MxA(3,bc%ibulk1) + bc%B*T(3,:)
+
+ MxA(1,bc%ibulk2) = MxA(1,bc%ibulk2) - bc%B*T(1,:)
+ MxA(2,bc%ibulk2) = MxA(2,bc%ibulk2) - bc%B*T(2,:)
+ MxA(3,bc%ibulk2) = MxA(3,bc%ibulk2) - bc%B*T(3,:)
+
+!-- intermediate storage of outputs --
+ call store_dataT(bc%dataT,bc%slip,bc%slip_rate,bc%T,it)
+
+!-- OUTPUTS --
+! write dataT every NTOUT time steps or at the end of simulation
+ if ( mod(it,NTOUT) == 0 .or. it==NSTEP) call SCEC_write_dataT(bc%dataT,bc%dt,it)
+! write dataXZ every NSNAP time steps
+! if ( mod(it,NSNAP) == 0) call write_dataXZ(bc,it,iflt)
+
+
+end subroutine BC_KINFLT_set_single
+
+!===============================================================
+function get_jump(bc,v) result(dv)
+
+ type(bc_kinflt_type), intent(in) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: v(:,:)
+ real(kind=CUSTOM_REAL) :: dv(3,bc%nglob)
+
+! diference between side 2 and side 1 of fault nodes. dv
+ dv(1,:) = v(1,bc%ibulk2)-v(1,bc%ibulk1)
+ dv(2,:) = v(2,bc%ibulk2)-v(2,bc%ibulk1)
+ dv(3,:) = v(3,bc%ibulk2)-v(3,bc%ibulk1)
+
+end function get_jump
+
+!---------------------------------------------------------------------
+function get_weighted_jump(bc,f) result(da)
+
+ type(bc_kinflt_type), intent(in) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: f(:,:)
+ real(kind=CUSTOM_REAL) :: da(3,bc%nglob)
+
+! diference between side 2 and side 1 of fault nodes. M-1 * F
+ da(1,:) = bc%invM2*f(1,bc%ibulk2)-bc%invM1*f(1,bc%ibulk1)
+ da(2,:) = bc%invM2*f(2,bc%ibulk2)-bc%invM1*f(2,bc%ibulk1)
+ da(3,:) = bc%invM2*f(3,bc%ibulk2)-bc%invM1*f(3,bc%ibulk1)
+
+end function get_weighted_jump
+
+!----------------------------------------------------------------------
+function rotate(bc,v,fb) result(vr)
+
+ type(bc_kinflt_type), intent(in) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: v(3,bc%nglob)
+ integer, intent(in) :: fb
+ real(kind=CUSTOM_REAL) :: vr(3,bc%nglob)
+
+! Percy, tangential direction Vt, equation 7 of Pablo's notes in agreement with SPECFEM3D
+
+! forward rotation
+ if (fb==1) then
+ vr(1,:) = v(1,:)*bc%R(1,1,:)+v(2,:)*bc%R(1,2,:)+v(3,:)*bc%R(1,3,:) ! vs
+ vr(2,:) = v(1,:)*bc%R(2,1,:)+v(2,:)*bc%R(2,2,:)+v(3,:)*bc%R(2,3,:) ! vd
+ vr(3,:) = v(1,:)*bc%R(3,1,:)+v(2,:)*bc%R(3,2,:)+v(3,:)*bc%R(3,3,:) ! vn
+
+! backward rotation
+ else
+ vr(1,:) = v(1,:)*bc%R(1,1,:)+v(2,:)*bc%R(2,1,:)+v(3,:)*bc%R(3,1,:) !vx
+ vr(2,:) = v(1,:)*bc%R(1,2,:)+v(2,:)*bc%R(2,2,:)+v(3,:)*bc%R(3,2,:) !vy
+ vr(3,:) = v(1,:)*bc%R(1,3,:)+v(2,:)*bc%R(2,3,:)+v(3,:)*bc%R(3,3,:) !vz
+
+ endif
+
+end function rotate
+
+
+!===============================================================
+! OUTPUTS
+
+subroutine init_dataT(DataT,coord,nglob,NT,iflt)
+ ! NT = total number of time steps
+
+ integer, intent(in) :: nglob,NT,iflt
+ real(kind=CUSTOM_REAL), intent(in) :: coord(3,nglob)
+ type (dataT_type), intent(out) :: DataT
+
+ real(kind=CUSTOM_REAL) :: xtarget,ytarget,ztarget,dist,distkeep
+ integer :: i, iglob , IIN, ier, jflt, np, k
+ character(len=70) :: tmpname
+
+! 1. read fault output coordinates from user file,
+! 2. define iglob: the fault global index of the node nearest to user
+! requested coordinate
+
+ IIN = 251
+ open(IIN,file='DATA/FAULT/FAULT_STATIONS.in',status='old',action='read',iostat=ier)
+ read(IIN,*) np
+ DataT%npoin =0
+ do i=1,np
+ read(IIN,*) xtarget,ytarget,ztarget,tmpname,jflt
+ if (jflt==iflt) DataT%npoin = DataT%npoin +1
+ enddo
+ close(IIN)
+
+ if (DataT%npoin == 0) return
+
+ allocate(DataT%iglob(DataT%npoin))
+ allocate(DataT%name(DataT%npoin))
+
+ open(IIN,file='DATA/FAULT/FAULT_STATIONS.in',status='old',action='read',iostat=ier)
+ if( ier /= 0 ) stop 'error opening FAULT_STATIONS file'
+ read(IIN,*) np
+ k = 0
+ do i=1,np
+ read(IIN,*) xtarget,ytarget,ztarget,tmpname,jflt
+ if (jflt/=iflt) cycle
+ k = k+1
+ DataT%name(k) = tmpname
+ !search nearest node
+ distkeep = huge(distkeep)
+
+ do iglob=1,nglob
+ dist = sqrt((coord(1,iglob)-xtarget)**2 &
+ + (coord(2,iglob)-ytarget)**2 &
+ + (coord(3,iglob)-ztarget)**2)
+ if (dist < distkeep) then
+ distkeep = dist
+ DataT%iglob(k) = iglob
+ endif
+ enddo
+ enddo
+
+! 3. allocate arrays and set to zero
+ allocate(DataT%d1(NT,DataT%npoin))
+ allocate(DataT%v1(NT,DataT%npoin))
+ allocate(DataT%t1(NT,DataT%npoin))
+ allocate(DataT%d2(NT,DataT%npoin))
+ allocate(DataT%v2(NT,DataT%npoin))
+ allocate(DataT%t2(NT,DataT%npoin))
+ allocate(DataT%t3(NT,DataT%npoin))
+ DataT%d1 = 0e0_CUSTOM_REAL
+ DataT%v1 = 0e0_CUSTOM_REAL
+ DataT%t1 = 0e0_CUSTOM_REAL
+ DataT%d2 = 0e0_CUSTOM_REAL
+ DataT%v2 = 0e0_CUSTOM_REAL
+ DataT%t2 = 0e0_CUSTOM_REAL
+ DataT%t3 = 0e0_CUSTOM_REAL
+
+ close(IIN)
+
+end subroutine init_dataT
+
+
+!---------------------------------------------------------------
+subroutine init_dataXZ(dataXZ,nglob)
+
+ type(dataXZ_type), intent(inout) :: dataXZ
+ integer, intent(in) :: nglob
+
+ allocate(dataXZ%v1(nglob))
+ allocate(dataXZ%v2(nglob))
+ allocate(dataXZ%xcoord(nglob))
+ allocate(dataXZ%ycoord(nglob))
+ allocate(dataXZ%zcoord(nglob))
+
+ dataXZ%v1= 0e0_CUSTOM_REAL
+ dataXZ%v2= 0e0_CUSTOM_REAL
+ dataXZ%xcoord= 0e0_CUSTOM_REAL
+ dataXZ%ycoord= 0e0_CUSTOM_REAL
+ dataXZ%zcoord= 0e0_CUSTOM_REAL
+
+end subroutine init_dataXZ
+
+
+!---------------------------------------------------------------
+subroutine store_dataT(dataT,d,v,t,itime)
+
+ type(dataT_type), intent(inout) :: dataT
+ real(kind=CUSTOM_REAL), dimension(:,:), intent(in) :: d,v,t
+ integer, intent(in) :: itime
+
+ integer :: i,k
+
+ do i=1,dataT%npoin
+ k = dataT%iglob(i)
+ dataT%d1(itime,i) = d(1,k)
+ dataT%d2(itime,i) = d(2,k)
+ dataT%v1(itime,i) = v(1,k)
+ dataT%v2(itime,i) = v(2,k)
+ dataT%t1(itime,i) = t(1,k)
+ dataT%t2(itime,i) = t(2,k)
+ dataT%t3(itime,i) = t(3,k)
+ enddo
+
+end subroutine store_dataT
+
+
+!-----------------------------------------------------------------
+
+subroutine SCEC_write_dataT(dataT,DT,NT)
+
+ type(dataT_type), intent(in) :: dataT
+ real(kind=CUSTOM_REAL), intent(in) :: DT
+ integer, intent(in) :: NT
+
+ integer :: i,k,IOUT
+
+ IOUT = 121 !WARNING: not very robust. Could instead look for an available ID
+
+do i=1,dataT%npoin
+
+ open(IOUT,file='OUTPUT_FILES/'//trim(dataT%name(i))//'.dat',status='replace')
+ write(IOUT,*) "% problem=TPV5"
+ write(IOUT,*) "% author=Galvez, Ampuero, Nissen-Meyer"
+ write(IOUT,*) "% date=2010/xx/xx"
+ write(IOUT,*) "% code=SPECFEM3D_FAULT "
+ write(IOUT,*) "% code_version=1.1"
+ write(IOUT,*) "% element_size=100 m (*4 GLL nodes)"
+ write(IOUT,*) "% time_step=",DT
+ write(IOUT,*) "% num_time_steps=",NT
+ write(IOUT,*) "% location=",trim(dataT%name(i))
+ write(IOUT,*) "% Time series in 8 column of E15.7"
+ write(IOUT,*) "% Column #1 = Time (s)"
+ write(IOUT,*) "% Column #2 = horizontal right-lateral slip (m)"
+ write(IOUT,*) "% Column #3 = horizontal right-lateral slip rate (m/s)"
+ write(IOUT,*) "% Column #4 = horizontal right-lateral shear stress (MPa)"
+ write(IOUT,*) "% Column #5 = vertical up-dip slip (m)"
+ write(IOUT,*) "% Column #6 = vertical up-dip slip rate (m/s)"
+ write(IOUT,*) "% Column #7 = vertical up-dip shear stress (MPa)"
+ write(IOUT,*) "% Column #8 = normal stress (MPa)"
+ write(IOUT,*) "%"
+ write(IOUT,*) "% The line below lists the names of the data fields:"
+ write(IOUT,*) "%t h-slip h-slip-rate h-shear-stress v-slip v-slip-rate v-shear-stress n-stress"
+ write(IOUT,*) "%"
+ write(IOUT,*) "% Here is the time-series data."
+ do k=1,NT
+ write(IOUT,'(8(E15.7))') k*DT, dataT%d1(k,i), dataT%v1(k,i), dataT%t1(k,i)/1.0e6_CUSTOM_REAL, &
+ dataT%d2(k,i), dataT%v2(k,i), dataT%t2(k,i)/1.0e6_CUSTOM_REAL, &
+ dataT%t3(k,i)/1.0e6_CUSTOM_REAL
+ enddo
+ close(IOUT)
+ enddo
+
+end subroutine SCEC_write_dataT
+
+
+!---------------------------------------------------------------
+!LOAD_VSLIP_SNAPSHOTS(v,dataXZ,itime,coord,npoin,nglob,iflt)
+!Loading slip velocity from snapshots.
+! INPUT itime : iteration time
+! coord : Receivers coordinates
+! npoin : number of Receivers.
+! nglob : number of gll points along the fault.
+! dataXZ : Velocity slip_rate .
+! iflt : number of faults.
+
+! OUTPUT v : slip_rate on receivers.
+
+subroutine load_vslip_snapshots(dataXZ,itime,nglob,iflt)
+
+ integer, intent(in) :: itime,nglob,iflt
+ type(dataXZ_type), intent(inout) :: dataXZ
+ character(len=70) :: filename
+ integer :: IIN_BIN,ier,IOUT
+
+ IIN_BIN=101
+ IOUT = 102
+
+ write(filename,"('OUTPUT_FILES/Snapshot',I0,'_F',I0,'.bin')") itime,iflt
+ print*, trim(filename)
+
+ open(unit=IIN_BIN, file= trim(filename), status='old', form='formatted',&
+ action='read',iostat=ier)
+! COMPILLERS WRITE BINARY OUTPUTS IN DIFFERENT FORMATS !!!!!!!!!!
+! open(unit=IIN_BIN, file= trim(filename), status='old', form='unformatted',&
+! action='read',iostat=ier)
+! if( ier /= 0 ) stop 'Snapshots have been found'
+
+ read(IIN_BIN,"(5F24.15)") dataXZ%xcoord,dataXZ%ycoord,dataXZ%zcoord,dataXZ%v1,dataXZ%v2
+
+! read(IOUT) dataXZ%xcoord
+! read(IOUT) dataXZ%ycoord
+! read(IOUT) dataXZ%zcoord
+! write(IOUT) dataXZ%d1
+! write(IOUT) dataXZ%d2
+! read(IOUT) dataXZ%v1
+! read(IOUT) dataXZ%v2
+! write(IOUT) dataXZ%t1
+! write(IOUT) dataXZ%t2
+! write(IOUT) dataXZ%t3
+! write(IOUT) dataXZ%sta
+! write(IOUT) dataXZ%stg
+! write(IOUT) dataXZ%tRUP
+! write(IOUT) dataXZ%tPZ
+ close(IOUT)
+
+ close(IIN_BIN)
+
+end subroutine load_vslip_snapshots
+!---------------------------------------------------------------
+
+end module fault_solver_kinematic
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/exit_mpi.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/exit_mpi.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/exit_mpi.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,82 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! end the simulation and exit MPI
+
+ subroutine exit_MPI(myrank,error_msg)
+
+ implicit none
+
+ include "constants.h"
+
+! identifier for error message file
+ integer, parameter :: IERROR = 30
+
+ integer myrank
+ character(len=*) error_msg
+
+ character(len=80) outputname
+ character(len=256) OUTPUT_FILES
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI... proc ',myrank
+
+! write error message to file
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+ write(outputname,"('/error_message',i6.6,'.txt')") myrank
+ open(unit=IERROR,file=trim(OUTPUT_FILES)//outputname,status='unknown')
+ write(IERROR,*) error_msg(1:len(error_msg))
+ write(IERROR,*) 'Error detected, aborting MPI... proc ',myrank
+ close(IERROR)
+
+! close output file
+ if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) close(IMAIN)
+
+ call stop_all()
+
+ end subroutine exit_MPI
+
+!
+!----
+!
+
+! version without rank number printed in the error message
+ subroutine exit_MPI_without_rank(error_msg)
+
+ implicit none
+
+ include "constants.h"
+
+ character(len=*) error_msg
+
+! write error message to screen
+ write(*,*) error_msg(1:len(error_msg))
+ write(*,*) 'Error detected, aborting MPI...'
+
+ call stop_all()
+
+ end subroutine exit_MPI_without_rank
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/fault_ibool.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/fault_ibool.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/fault_ibool.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,11 @@
+subroutine fault_ibool()
+
+! number of fault nodes : nfspec
+! initial pointers : loc
+! xp,yp,zp= coordinates of fault elements.
+! ije=ke ,
+! xp=xcoor(ke) ,
+! yp=ycoor(ke) ,
+! zp=zcoor(ke) ,
+
+call get_global(nspec,xp(ije),yp(ije),zp(ije),fault_ibool,loc,ifseg,nfault_ibool,npointot,UTM_X_MIN,UTM_X_MAX)
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/fault_object.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/fault_object.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/fault_object.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,708 @@
+!=====================================================================
+!
+! 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.
+!
+!===============================================================================================================
+
+! This module was written by:
+! Percy Galvez, Jean-Paul Ampuero and Tarje Nissen-Meyer
+! Percy : New version with split nodes done in CUBIT.
+
+module fault_object
+
+ use create_regions_mesh_ext_par, only: NGLLX,NGLLY,NGLLZ,NGLLSQUARE,NGNOD2D,NDIM,CUSTOM_REAL
+! these variables are defined in 'constants.h', which is included in create_regions_mesh_ext_par
+
+ implicit none
+ private
+
+ type fault_db_type
+ private
+ integer :: tag1,tag2,nspec=0,nglob=0
+ real(kind=CUSTOM_REAL) :: eta
+ integer, dimension(:), pointer:: ispec1, ispec2, ibulk1, ibulk2, iface1, iface2
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: xcoordbulk1,ycoordbulk1,zcoordbulk1,xcoordbulk2,ycoordbulk2,zcoordbulk2
+ integer, dimension(:,:), pointer :: ibool1, ibool2
+ integer, dimension(:,:,:), pointer :: ijk1, ijk2
+ real(kind=CUSTOM_REAL), dimension(:,:), pointer:: jacobian2Dw
+ real(kind=CUSTOM_REAL), dimension(:,:,:), pointer:: normal
+ end type fault_db_type
+
+ type(fault_db_type), allocatable, save :: fault_db(:)
+ ! fault_db(i) is the database of the i-th fault in the mesh
+ real(kind=CUSTOM_REAL), allocatable, save :: Kelvin_Voigt_eta(:)
+
+ ! corners indices of reference cube faces
+ integer,dimension(3,4),parameter :: iface1_corner_ijk = &
+ reshape( (/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ /),(/3,4/)) ! xmin
+ integer,dimension(3,4),parameter :: iface2_corner_ijk = &
+ reshape( (/ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),(/3,4/)) ! xmax
+ integer,dimension(3,4),parameter :: iface3_corner_ijk = &
+ reshape( (/ 1,1,1, 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,1,1 /),(/3,4/)) ! ymin
+ integer,dimension(3,4),parameter :: iface4_corner_ijk = &
+ reshape( (/ 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! ymax
+ integer,dimension(3,4),parameter :: iface5_corner_ijk = &
+ reshape( (/ 1,1,1, 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,1,1 /),(/3,4/)) ! bottom
+ integer,dimension(3,4),parameter :: iface6_corner_ijk = &
+ reshape( (/ 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! top
+ integer,dimension(3,4,6),parameter :: iface_all_corner_ijk = &
+ reshape( (/ iface1_corner_ijk,iface2_corner_ijk, &
+ iface3_corner_ijk,iface4_corner_ijk, &
+ iface5_corner_ijk,iface6_corner_ijk /),(/3,4,6/)) ! all faces
+
+ public :: fault_read_input, fault_setup, fault_db, fault_save_arrays_test, fault_save_arrays, fault_db_type
+
+contains
+
+!=================================================================================================================
+subroutine fault_read_input()
+
+ integer :: nb
+
+ integer :: i,ier
+
+ nb = 0
+
+ open(unit=100,file='DATA/FAULT/Par_file_faults.in',status='old',action='read',iostat=ier)
+ if (ier==0) then
+ read(100,*) nb
+ allocate(fault_db(nb))
+ do i=1,nb
+ enddo
+ else
+ write(6,*) 'File Par_file_faults.in does not exist '
+ return
+ end if
+
+ close(100)
+
+
+end subroutine fault_read_input
+
+
+!==================================================================================================================
+subroutine fault_setup(ibool,xstore,ystore,zstore,nspec,nglob,prname,myrank)
+
+!Percy : mat_ext_mesh(i,ispec) : material index properties
+! Domain tags for each element are in mat_ext_mesh(1,:)
+ use generate_databases_par, only : mat_ext_mesh
+
+ integer, intent(in) :: nspec ! number of spectral elements in each block
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec), intent(in) :: xstore,ystore,zstore
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec), intent(in) :: ibool
+ integer, intent(in) :: myrank
+ character(len=256), intent(in) :: prname ! 'proc***'
+
+ ! (assumes NGLLX=NGLLY=NGLLZ)
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xtemp,ytemp,ztemp
+ integer, intent(out) :: nglob
+
+ integer :: iflt,npointot
+ logical :: fault_exists,KELVIN_VOIGT_DAMPING
+
+
+ if (.not. allocated(fault_db)) return
+
+! 1. Generate node indexing (ibool) from original coordinates. Fault nodes are split in CUBIT .
+! 2. Slightly shift the coordinates of nodes on side 1 of the fault
+
+! to do: what happens to nodes at the edges of a fault ??? : still thinking.
+
+ npointot = nspec * NGLLX*NGLLY*NGLLZ
+! call crm_ext_setup_indexing_fault(ibool, &
+! xstore,ystore,zstore,nspec,nglob,npointot)
+
+ xtemp = xstore
+ ytemp = ystore
+ ztemp = zstore
+
+ fault_exists = .false.
+
+ do iflt=1,size(fault_db)
+ call loading_coords_and_setup(fault_db(iflt),nglob,nspec,prname,myrank)
+ if (fault_db(iflt)%nspec>0) fault_exists = .true.
+ enddo
+
+ if (fault_exists) then
+ call crm_ext_setup_indexing_fault(ibool, &
+ xtemp,ytemp,ztemp,nspec,nglob,npointot)
+
+ !-------------- Kelvin voigt damping -------------------------
+ KELVIN_VOIGT_DAMPING = .false.
+ do iflt = 1, size(fault_db)
+ if (fault_db(iflt)%eta > 0.0_CUSTOM_REAL) KELVIN_VOIGT_DAMPING = .true.
+ end do
+ if (KELVIN_VOIGT_DAMPING) then
+ allocate(Kelvin_Voigt_eta(nspec))
+ Kelvin_Voigt_eta(:) = 0.0_CUSTOM_REAL
+ endif
+ !-------------------------------------------------------------
+
+ endif
+
+! Xstore_dummy is declared in the module create_regions_mesh_par
+! and filled for first time here for processor containing a fault
+! this routine to save Xstore_dummy, with or without fault
+
+! to do : create a subroutine to shift back xtemp,ytemp,ztemp coordinates
+! otherwise the elements of MPI-interfaces will be mix up each other
+! ending up with decouple MPI-interfaces
+
+ call setup_xyzstore_dummy(ibool,xstore,ystore,zstore,nspec,nglob)
+
+
+ if (.not.fault_exists) return
+
+ do iflt=1,size(fault_db)
+
+ ! ibools = mapping from local indices on the fault (GLL index, element
+ ! index) to global indices on the fault
+ call setup_ibools(fault_db(iflt),xstore,ystore,zstore,nspec,fault_db(iflt)%nspec*NGLLSQUARE)
+
+ ! ibulks = mapping global indices of fault nodes
+ ! from global indices on the fault to global indices on the bulk
+ call setup_ibulks(fault_db(iflt),ibool,nspec)
+
+ call setup_Kelvin_Voigt_eta(fault_db(iflt))
+
+ call setup_normal_jacobian(fault_db(iflt),ibool,nspec,nglob,myrank)
+
+ enddo
+
+end subroutine fault_setup
+
+
+!==============================================================================================================
+! creates global indexing array ibool
+subroutine crm_ext_setup_indexing_fault(ibools, &
+ xtemp,ytemp,ztemp,nspec,nglob,npointot)
+
+ use generate_databases_par, only: nodes_coords_ext_mesh
+
+! number of spectral elements in each block
+ integer, intent(in) :: nspec,npointot
+ integer, intent(out) :: nglob
+
+! arrays with the mesh
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec), intent(out) :: ibools
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec), intent(in) :: xtemp,ytemp,ztemp
+
+! local parameters
+! variables for creating array ibools
+ double precision, dimension(npointot) :: xp,yp,zp
+ integer, dimension(npointot) :: locval
+ logical, dimension(npointot) :: ifseg
+
+ integer :: ieoff,ilocnum
+ integer :: i,j,k,ispec
+
+! reshapes the arrays of GLL nodal coordinates into vectors
+ 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) = xtemp(i,j,k,ispec)
+ yp(ilocnum+ieoff) = ytemp(i,j,k,ispec)
+ zp(ilocnum+ieoff) = ztemp(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+! gets ibool indexing from local (GLL points) to global points
+ call get_global(nspec,xp,yp,zp,ibools,locval,ifseg,nglob,npointot, &
+ minval(nodes_coords_ext_mesh(1,:)),maxval(nodes_coords_ext_mesh(1,:)))
+
+!to do: try if the following works
+! call get_global(nspec,xtemp,ytemp,ztemp, ...
+! Fortran should automatically reshape xtemp into a vector. That's how ibools is passed.
+! If it works we don't need xp,yp,zp anymore.
+
+!- we can create a new indirect addressing to reduce cache misses
+ call get_global_indirect_addressing(nspec,nglob,ibools)
+
+end subroutine crm_ext_setup_indexing_fault
+
+
+!==============================================================================================================
+
+subroutine loading_coords_and_setup(fdb,nglob,nspec,prname,myrank)
+
+ type(fault_db_type), intent(inout) :: fdb
+ integer, intent(in) :: nspec,nglob
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec), intent(in) :: ibool
+ integer,intent(in) :: myrank
+ character(len=256), intent(in) :: prname ! 'proc***'
+
+
+ integer :: nspec_fault,ifault
+ integer, dimension(3,NGLLSQUARE,nspec*6) :: ijk1, ijk2
+ integer :: ijk_face(3,NGLLX,NGLLY)
+! The tolerance in get_global is SMALLVALTOTAL=1-10*(whole size of the model).
+ integer :: IIN = 100
+
+ open(unit=IIN,file=prname(1:len_trim(prname))//'Database_fault',status='old',action='read',form='formatted',iostat=ier)
+ if( ier /= 0 ) then
+ write(IMAIN,*) 'error opening file: ',prname(1:len_trim(prname))//'Database_fault'
+ write(IMAIN,*) 'make sure file exists'
+ stop
+ endif
+
+ read(IIN,*) nspec_fault
+ allocate(fdb%ispec1(nspec_fault))
+ allocate(fdb%iface1(nspec_fault))
+ allocate(fdb%ijk1(3,NGLLX*NGLLY,nspec_fault))
+
+ allocate(fdb%ispec2(nspec_fault))
+ allocate(fdb%iface2(nspec_fault))
+ allocate(fdb%ijk2(3,NGLLX*NGLLY,nspec_fault))
+
+
+ do i=1,nspec_fault
+ read(IIN,*) fdb%ispec1(i),fdb%ispec2(i),fdb%iface1(i),fdb%iface2(i)
+ enddo
+
+ close(IIN)
+
+ do ifault=1,nspec_fault
+
+ ! we have identified a new fault element on fault side 1
+ iface_ref1 = fdb%iface1(i)
+ iface_ref2 = fdb%iface2(i)
+
+ ! gets i,j,k indices of GLL nodes in element face
+ call get_element_face_gll_indices(iface_ref1,ijk_face1,NGLLX,NGLLY)
+ call get_element_face_gll_indices(iface_ref2,ijk_face2,NGLLX,NGLLY)
+
+ igll = 0
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ igll = igll + 1
+
+ ijk1(:,igll,ifault)=ijk_face1(:,i,j) ! saving gll points of side 1 , needed for iulk1.
+ ijk2(:,igll,ifault)=ijk_face2(:,i,j) ! saving gll points of side 2 , needed for iulk1.
+
+ enddo
+ enddo
+ enddo
+
+ fdb%ispec1 = ispec1(1:nspec_fault)
+ fdb%iface1 = iface1(1:nspec_fault
+ fdb%ijk1 = ijk1(:,:,1:nspec_fault)
+
+ fdb%ispec2 = ispec2(1:nspec_fault)
+ fdb%iface2 = iface2(1:nspec_fault)
+ fdb%ijk2 = ijk2(:,:,1:nspec_fault)
+
+end subroutine loading_coords_and_setup
+
+!=============================================================================================================
+! unique global point locations
+subroutine setup_xyzstore_dummy(ibool,xstore,ystore,zstore,nspec,nglob)
+
+ use create_regions_mesh_ext_par, only: xstore_dummy,ystore_dummy,zstore_dummy
+
+ integer, intent(in) :: nspec, nglob, ibool(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec), intent(in) :: xstore,ystore,zstore
+
+ integer :: ier, ispec, i,j,k, iglobnum
+
+ 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
+
+end subroutine setup_xyzstore_dummy
+
+!=============================================================================================================
+ subroutine setup_Kelvin_Voigt_eta(fdb)
+
+ type(fault_db_type), intent(in) :: fdb
+
+ if (allocated(Kelvin_Voigt_eta)) then
+ Kelvin_Voigt_eta(fdb%ispec1) = fdb%eta
+ Kelvin_Voigt_eta(fdb%ispec2) = fdb%eta
+ endif
+
+ end subroutine
+
+!===============================================================================================================
+! The lexicographic oredering of node coordinates
+! guarantees that the fault nodes are
+! consistently ordered on both sides of the fault,
+! such that the K-th node of side 1 is facing the K-th node of side 2
+
+subroutine setup_ibools(fdb,xstore,ystore,zstore,nspec,npointot)
+
+ use generate_databases_par, only: nodes_coords_ext_mesh
+
+ type(fault_db_type), intent(inout) :: fdb
+ integer, intent(in) :: nspec,npointot
+ double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec), intent(in) :: xstore,ystore,zstore
+
+ double precision :: xp(npointot),yp(npointot),zp(npointot),xmin,xmax
+ integer :: loc(npointot)
+ logical :: ifseg(npointot)
+ integer :: ispec,i,j,k,igll,ie,je,ke,e
+
+ k = 0
+ do e = 1,fdb%nspec
+ ispec = fdb%ispec1(e)
+ igll = 0
+ do i=1,NGLLX
+ do j=1,NGLLX
+ igll = igll + 1
+ ie=fdb%ijk1(1,igll,e)
+ je=fdb%ijk1(2,igll,e)
+ ke=fdb%ijk1(3,igll,e)
+ k = k+1
+ xp(k) = xstore(ie,je,ke,ispec)
+ yp(k) = ystore(ie,je,ke,ispec)
+ zp(k) = zstore(ie,je,ke,ispec)
+ enddo
+ enddo
+ enddo
+ allocate( fdb%ibool1(NGLLSQUARE,fdb%nspec) )
+
+ xmin = minval(nodes_coords_ext_mesh(1,:))
+ xmax = maxval(nodes_coords_ext_mesh(1,:))
+
+ call get_global(fdb%nspec,xp,yp,zp,fdb%ibool1,loc,ifseg,fdb%nglob,npointot,xmin,xmax)
+
+! xp,yp,zp need to be recomputed on side 2
+! because they are generally not in the same order as on side 1,
+! because ispec1(e) is not necessarily facing ispec2(e).
+
+ k = 0
+ do e = 1,fdb%nspec
+ ispec = fdb%ispec2(e)
+ igll = 0
+ do i=1,NGLLX
+ do j=1,NGLLX
+ igll = igll + 1
+ ie=fdb%ijk2(1,igll,e)
+ je=fdb%ijk2(2,igll,e)
+ ke=fdb%ijk2(3,igll,e)
+ k = k+1
+ xp(k) = xstore(ie,je,ke,ispec)
+ yp(k) = ystore(ie,je,ke,ispec)
+ zp(k) = zstore(ie,je,ke,ispec)
+ enddo
+ enddo
+ enddo
+ allocate( fdb%ibool2(NGLLSQUARE,fdb%nspec) )
+ call get_global(fdb%nspec,xp,yp,zp,fdb%ibool2,loc,ifseg,fdb%nglob,npointot,xmin,xmax)
+
+end subroutine setup_ibools
+
+
+!=================================================================================
+
+subroutine setup_ibulks(fdb,ibool,nspec)
+
+ use create_regions_mesh_ext_par, only: xstore_dummy,ystore_dummy,zstore_dummy
+
+ type(fault_db_type), intent(inout) :: fdb
+ integer, intent(in) :: nspec, ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer :: e,k, K1, K2, ie,je,ke
+
+ allocate( fdb%ibulk1(fdb%nglob) )
+ allocate( fdb%ibulk2(fdb%nglob) )
+ allocate( fdb%xcoordbulk1(fdb%nglob) )
+ allocate( fdb%ycoordbulk1(fdb%nglob) )
+ allocate( fdb%zcoordbulk1(fdb%nglob) )
+ allocate( fdb%xcoordbulk2(fdb%nglob) )
+ allocate( fdb%ycoordbulk2(fdb%nglob) )
+ allocate( fdb%zcoordbulk2(fdb%nglob) )
+
+
+ do e=1, fdb%nspec
+ do k=1, NGLLSQUARE
+
+ ie=fdb%ijk1(1,k,e)
+ je=fdb%ijk1(2,k,e)
+ ke=fdb%ijk1(3,k,e)
+ K1= fdb%ibool1(k,e)
+ fdb%ibulk1(K1)=ibool(ie,je,ke,fdb%ispec1(e))
+! Adding coordinates of fault nodes side 1 .
+ fdb%xcoordbulk1(K1) = xstore_dummy(fdb%ibulk1(K1))
+ fdb%ycoordbulk1(K1) = ystore_dummy(fdb%ibulk1(K1))
+ fdb%zcoordbulk1(K1) = zstore_dummy(fdb%ibulk1(K1))
+
+ ie=fdb%ijk2(1,k,e)
+ je=fdb%ijk2(2,k,e)
+ ke=fdb%ijk2(3,k,e)
+ K2= fdb%ibool2(k,e)
+ fdb%ibulk2(K2)=ibool(ie,je,ke,fdb%ispec2(e))
+! Adding coordinates of fault nodes side 2 .
+ fdb%xcoordbulk2(K2) = xstore_dummy(fdb%ibulk2(K2))
+ fdb%ycoordbulk2(K2) = ystore_dummy(fdb%ibulk2(K2))
+ fdb%zcoordbulk2(K2) = zstore_dummy(fdb%ibulk2(K2))
+
+ enddo
+ enddo
+
+end subroutine setup_ibulks
+
+
+!=================================================================================
+
+ subroutine setup_normal_jacobian(fdb,ibool,nspec,nglob,myrank)
+
+ use create_regions_mesh_ext_par, only: xstore_dummy,ystore_dummy,zstore_dummy, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz
+
+ type(fault_db_type), intent(inout) :: fdb
+ integer, intent(in) :: nspec,nglob, ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer, intent(in) :: myrank
+
+ ! (assumes NGLLX=NGLLY=NGLLZ)
+ real(kind=CUSTOM_REAL),dimension(NGNOD2D) :: xcoord,ycoord,zcoord
+ real(kind=CUSTOM_REAL) :: jacobian2Dw_face(NGLLX,NGLLY)
+ real(kind=CUSTOM_REAL) :: normal_face(NDIM,NGLLX,NGLLY)
+ integer,dimension(NGNOD2D) :: iglob_corners_ref
+ integer :: ispec_flt,ispec,i,j,k,igll
+ integer :: iface_ref,icorner
+
+ allocate(fdb%normal(NDIM,NGLLSQUARE,fdb%nspec))
+ allocate(fdb%jacobian2Dw(NGLLSQUARE,fdb%nspec))
+
+ do ispec_flt=1,fdb%nspec
+
+ iface_ref= fdb%iface1(ispec_flt)
+ ispec = fdb%ispec1(ispec_flt)
+
+ ! takes indices of corners of reference face
+ do icorner = 1,NGNOD2D
+ i = iface_all_corner_ijk(1,icorner,iface_ref)
+ j = iface_all_corner_ijk(2,icorner,iface_ref)
+ k = iface_all_corner_ijk(3,icorner,iface_ref)
+
+ ! global reference indices
+ iglob_corners_ref(icorner) = ibool(i,j,k,ispec)
+
+ ! reference corner coordinates
+ xcoord(icorner) = xstore_dummy(iglob_corners_ref(icorner))
+ ycoord(icorner) = ystore_dummy(iglob_corners_ref(icorner))
+ zcoord(icorner) = zstore_dummy(iglob_corners_ref(icorner))
+ enddo
+
+ ! gets face GLL 2Djacobian, weighted from element face
+ 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_ref,jacobian2Dw_face,normal_face,NGLLX,NGLLY)
+
+ ! normal convention: points away from domain1, reference element.
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! directs normals such that they point outwards of element
+ call get_element_face_normal(ispec,iface_ref,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ normal_face(:,i,j) )
+ enddo
+ enddo
+
+ ! stores informations about this face
+ igll = 0
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! adds all gll points on thas face
+ igll = igll + 1
+ ! stores weighted jacobian and normals
+ fdb%jacobian2Dw(igll,ispec_flt) = jacobian2Dw_face(i,j)
+ fdb%normal(:,igll,ispec_flt) = normal_face(:,i,j)
+ enddo
+ enddo
+
+ enddo ! ispec_flt
+
+end subroutine setup_normal_jacobian
+
+!====================================================================================
+! saves all fault data in ASCII files for verification
+subroutine fault_save_arrays_test(prname,IOUT)
+
+ character(len=256), intent(in) :: prname ! 'proc***'
+ integer, intent(in) :: IOUT
+
+ integer :: nbfaults,iflt,ier
+ character(len=256) :: filename
+
+! saves mesh file proc***_fault_db.txt
+ filename = prname(1:len_trim(prname))//'fault_db.txt'
+ open(unit=IOUT,file=trim(filename),status='unknown',action='write',iostat=ier)
+ if( ier /= 0 ) stop 'error opening database proc######_external_mesh.bin'
+
+ if (allocated(fault_db)) then
+ nbfaults = size(fault_db)
+ else
+ nbfaults = 0
+ endif
+ write(IOUT,*) 'NBFAULTS = ',nbfaults
+ do iflt=1,nbfaults
+ write(IOUT,*) 'BEGIN FAULT # ',iflt
+ call save_one_fault_test(fault_db(iflt),IOUT)
+ write(IOUT,*) 'END FAULT # ',iflt
+ enddo
+ close(IOUT)
+
+end subroutine fault_save_arrays_test
+
+!-------------------------------------------------------------------------------------
+
+subroutine save_one_fault_test(f,IOUT)
+
+ type(fault_db_type), intent(in) :: f
+ integer, intent(in) :: IOUT
+
+ integer :: e,k
+ character(15) :: fmt1,fmt2
+
+ write(fmt1,'("(a,",I0,"(x,I7))")') NGLLSQUARE+1 ! fmt = (a,(NGLL^2+1)(x,I7))
+ write(fmt2,'("(a,",I0,"(x,F0.4))")') NGLLSQUARE+1 ! fmt = (a,(NGLL^2+1)(x,F0.16))
+
+ write(IOUT,*) 'TAG1 TAG2 NSPEC NGLOB NGLL = ',f%tag1,f%tag2,f%nspec,f%nglob,NGLLX
+ if (f%nspec==0) return
+ do e=1,f%nspec
+ write(IOUT,*) 'FLT_ELEM = ',e
+ write(IOUT,*) 'ISPEC1 ISPEC2 = ',f%ispec1(e),f%ispec2(e)
+ write(IOUT,fmt1) 'IBOOL1 = ',f%ibool1(:,e)
+ write(IOUT,fmt1) 'IBOOL2 = ',f%ibool2(:,e)
+ write(IOUT,fmt1) 'I1 = ',f%ijk1(1,:,e)
+ write(IOUT,fmt1) 'J1 = ',f%ijk1(2,:,e)
+ write(IOUT,fmt1) 'K1 = ',f%ijk1(3,:,e)
+ write(IOUT,fmt1) 'I2 = ',f%ijk2(1,:,e)
+ write(IOUT,fmt1) 'J2 = ',f%ijk2(2,:,e)
+ write(IOUT,fmt1) 'K2 = ',f%ijk2(3,:,e)
+ write(IOUT,fmt2) 'JAC2DW = ',f%jacobian2Dw(:,e)
+ write(IOUT,fmt2) 'N1 = ',f%normal(1,:,e)
+ write(IOUT,fmt2) 'N2 = ',f%normal(2,:,e)
+ write(IOUT,fmt2) 'N3 = ',f%normal(3,:,e)
+ enddo
+
+ write(IOUT,*) 'FLT_NODE IBULK1 IBULK2'
+ do k=1,f%nglob
+ write(IOUT,*) k,f%ibulk1(k),f%ibulk2(k)
+ enddo
+
+ write(IOUT,*) 'FLT_NODE xcoordbulk ycoordbulk zcoordbulk'
+ do k=1,f%nglob
+ write(IOUT,*) f%ibulk1(k),f%xcoordbulk1(k),f%ycoordbulk1(k),f%zcoordbulk1(k)
+ write(IOUT,*) f%ibulk2(k),f%xcoordbulk2(k),f%ycoordbulk2(k),f%zcoordbulk2(k)
+ enddo
+
+end subroutine save_one_fault_test
+
+!=================================================================================
+! saves fault data needed by the solver in binary files
+subroutine fault_save_arrays(prname,IOUT)
+
+ character(len=256), intent(in) :: prname ! 'proc***'
+ integer, intent(in) :: IOUT
+
+ integer :: nbfaults,iflt,ier,size_Kelvin_Voigt
+ character(len=256) :: filename
+
+
+! saves mesh file proc***_Kelvin_voigt_eta.bin
+ filename = prname(1:len_trim(prname))//'Kelvin_voigt_eta.bin'
+ open(unit=IOUT,file=trim(filename),status='unknown',action='write',form='unformatted',iostat=ier)
+ if( ier /= 0 ) stop 'error opening database proc######_external_mesh.bin'
+ if (allocated(Kelvin_Voigt_eta)) then
+ size_Kelvin_Voigt = size(Kelvin_Voigt_eta)
+ else
+ size_Kelvin_Voigt = 0
+ endif
+ write(IOUT) size_Kelvin_Voigt
+ if (size_Kelvin_Voigt /= 0) Write(IOUT) Kelvin_Voigt_eta
+ Close(IOUT)
+
+! saves mesh file proc***_fault_db.bin
+ filename = prname(1:len_trim(prname))//'fault_db.bin'
+ open(unit=IOUT,file=trim(filename),status='unknown',action='write',form='unformatted',iostat=ier)
+ if( ier /= 0 ) stop 'error opening database proc######_external_mesh.bin'
+
+ if (allocated(fault_db)) then
+ nbfaults = size(fault_db)
+ else
+ nbfaults = 0
+ endif
+ write(IOUT) nbfaults
+ do iflt=1,nbfaults
+ call save_one_fault_bin(fault_db(iflt),IOUT)
+ enddo
+ close(IOUT)
+
+
+end subroutine fault_save_arrays
+
+!----------------------------------------------
+
+subroutine save_one_fault_bin(f,IOUT)
+
+ type(fault_db_type), intent(in) :: f
+ integer, intent(in) :: IOUT
+
+ write(IOUT) f%nspec,f%nglob
+ if (f%nspec==0) return
+ write(IOUT) f%ibool1
+ write(IOUT) f%jacobian2Dw
+ write(IOUT) f%normal
+ write(IOUT) f%ibulk1
+ write(IOUT) f%ibulk2
+ write(IOUT) f%xcoordbulk1
+ write(IOUT) f%ycoordbulk1
+ write(IOUT) f%zcoordbulk1
+
+! ispec1 and ispec2 might be needed to define a Kelvin-Voigt damping region
+! write(IOUT) f%ispec1
+! write(IOUT) f%ispec2
+
+end subroutine save_one_fault_bin
+
+!------------------------------------------------
+
+
+end module fault_object
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/fault_solver.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/fault_solver.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/fault_solver.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,965 @@
+!=====================================================================
+!
+! 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.
+!
+!===============================================================================================================
+
+! This module was written by:
+! Percy Galvez, Jean-Paul Ampuero and Tarje Nissen-Meyer
+
+module fault_solver
+
+ implicit none
+
+ include 'constants.h'
+
+ private
+
+ ! outputs on selected fault nodes at every time step:
+ ! slip, slip velocity, fault stresses
+ type dataT_type
+ integer :: npoin
+ integer, dimension(:), pointer :: iglob ! on-fault global index of output nodes
+ real(kind=CUSTOM_REAL), dimension(:,:), pointer :: d1,v1,t1,d2,v2,t2,t3
+ character(len=70), dimension(:), pointer :: name
+ end type dataT_type
+
+
+ ! outputs at selected times for all fault nodes:
+ ! strength, state, slip, slip velocity, fault stresses, rupture time, process zone time
+ ! rupture time = first time when slip velocity = threshold V_RUPT (defined below)
+ ! process zone time = first time when slip = Dc
+ type dataXZ_type
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: stg, sta, d1, d2, v1, v2, &
+ t1, t2, t3, tRUP,tPZ
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: xcoord,ycoord,zcoord
+ integer :: npoin
+ end type dataXZ_type
+
+ type swf_type
+ private
+ integer :: kind
+ logical :: healing = .false.
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: Dc=>null(), mus=>null(), mud=>null(), theta=>null()
+ end type swf_type
+
+ type bc_dynflt_type
+ private
+ integer :: nspec,nglob
+ real(kind=CUSTOM_REAL), dimension(:,:), pointer :: T0,T,V,D
+ real(kind=CUSTOM_REAL), dimension(:,:), pointer :: coord
+ real(kind=CUSTOM_REAL), dimension(:,:,:), pointer :: R
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: MU,B,invM1,invM2,Z
+ real(kind=CUSTOM_REAL) :: dt
+ integer, dimension(:), pointer :: ibulk1, ibulk2
+ type(swf_type), pointer :: swf => null()
+ logical :: allow_opening = .false. ! default : do not allow opening
+ type(dataT_type) :: dataT
+ type(dataXZ_type) :: dataXZ
+ end type bc_dynflt_type
+
+ type(bc_dynflt_type), allocatable, save :: faults(:)
+
+ !slip velocity threshold for healing
+ !WARNING: not very robust
+ real(kind=CUSTOM_REAL), save :: V_HEALING
+
+ !slip velocity threshold for definition of rupture front
+ real(kind=CUSTOM_REAL), save :: V_RUPT
+
+ !Number of time steps defined by the user : NTOUT
+ integer, save :: NTOUT,NSNAP
+
+ integer, save :: SIMULATION_TYPE_DYN = 1
+
+
+ integer , save :: size_Kelvin_Voigt
+
+ real(kind=CUSTOM_REAL), allocatable, save :: Kelvin_Voigt_eta(:)
+
+ public :: BC_DYNFLT_init, BC_DYNFLT_set3d_all, Kelvin_Voigt_eta, &
+ size_Kelvin_Voigt, SIMULATION_TYPE_DYN
+
+
+contains
+
+
+!=====================================================================
+! BC_DYNFLT_init initializes dynamic faults
+!
+! prname fault database is read from file prname_fault_db.bin
+! Minv inverse mass matrix
+! dt global time step
+!
+ subroutine BC_DYNFLT_init(prname,Minv,DTglobal,nt)
+
+ character(len=256), intent(in) :: prname ! 'proc***'
+ real(kind=CUSTOM_REAL), intent(in) :: Minv(:)
+ double precision, intent(in) :: DTglobal
+ integer, intent(in) :: nt
+
+ real(kind=CUSTOM_REAL) :: dt
+ integer :: iflt,ier,dummy_idfault
+ integer :: nbfaults
+ character(len=256) :: filename
+ integer, parameter :: IIN_PAR =151
+ integer, parameter :: IIN_BIN =170
+
+ NAMELIST / BEGIN_FAULT / dummy_idfault
+
+ dummy_idfault = 0
+
+ filename = prname(1:len_trim(prname))//'Kelvin_voigt_eta.bin'
+ open(unit=IIN_BIN,file=trim(filename),status='old',action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) stop 'Haven not found proc*_Kelvin_voigt_eta.bin'
+ read(IIN_BIN) size_Kelvin_Voigt
+ if (size_Kelvin_Voigt > 0) then
+ allocate(Kelvin_Voigt_eta(size_Kelvin_Voigt))
+ read(IIN_BIN) Kelvin_Voigt_eta
+ endif
+ Close(IIN_BIN)
+
+ open(unit=IIN_PAR,file='DATA/FAULT/Par_file_faults.in',status='old',iostat=ier)
+ if( ier /= 0 ) then
+ write(6,*) 'Have not found Par_file_faults.in: assume no faults'
+ return
+ endif
+
+ dt = real(DTglobal)
+ filename = prname(1:len_trim(prname))//'fault_db.bin'
+ open(unit=IIN_BIN,file=trim(filename),status='old',action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) stop 'Have not found proc*_fault_db.bin'
+! WARNING TO DO: should be an MPI abort
+
+ read(IIN_PAR,*) nbfaults
+ do iflt=1,nbfaults
+ read(IIN_PAR,*)
+ enddo
+ read(IIN_PAR,*) SIMULATION_TYPE_DYN
+ if ( SIMULATION_TYPE_DYN == 2 ) goto 99
+ read(IIN_PAR,*) NTOUT
+ read(IIN_PAR,*) NSNAP
+ read(IIN_PAR,*) V_HEALING
+ read(IIN_PAR,*) V_RUPT
+
+ read(IIN_BIN) nbfaults ! should be the same as in IIN_PAR
+ allocate( faults(nbfaults) )
+ do iflt=1,nbfaults
+ read(IIN_PAR,nml=BEGIN_FAULT,end=100)
+ call init_one_fault(faults(iflt),IIN_BIN,IIN_PAR,Minv,dt,nt,iflt)
+ enddo
+99 close(IIN_BIN)
+ close(IIN_PAR)
+
+ return
+100 stop 'Did not find BEGIN_FAULT block #'
+ ! WARNING TO DO: should be an MPI abort
+
+end subroutine BC_DYNFLT_init
+
+
+!---------------------------------------------------------------------
+
+ subroutine init_one_fault(bc,IIN_BIN,IIN_PAR,Minv,dt,NT,iflt)
+
+ type(bc_dynflt_type), intent(inout) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: Minv(:)
+ integer, intent(in) :: IIN_BIN,IIN_PAR,NT,iflt
+ real(kind=CUSTOM_REAL), intent(in) :: dt
+
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: jacobian2Dw
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: normal
+ integer, dimension(:,:), allocatable :: ibool1
+ real(kind=CUSTOM_REAL) :: norm
+ real(kind=CUSTOM_REAL) :: S1,S2,S3
+ integer :: n1,n2,n3
+ real(kind=CUSTOM_REAL) :: mus,mud,dc
+ integer :: nmus,nmud,ndc,ij,k,e
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: nx,ny,nz
+
+
+ NAMELIST / INIT_STRESS / S1,S2,S3,n1,n2,n3
+ NAMELIST / SWF / mus,mud,dc,nmus,nmud,ndc
+
+ read(IIN_BIN) bc%nspec,bc%nglob
+ if (bc%nspec==0) return
+
+ allocate( bc%ibulk1(bc%nglob) )
+ allocate( bc%ibulk2(bc%nglob) )
+ allocate( ibool1(NGLLSQUARE,bc%nspec) )
+ allocate(normal(NDIM,NGLLSQUARE,bc%nspec))
+ allocate(jacobian2Dw(NGLLSQUARE,bc%nspec))
+
+ allocate(bc%coord(3,(bc%nglob)))
+ read(IIN_BIN) ibool1
+ read(IIN_BIN) jacobian2Dw
+ read(IIN_BIN) normal
+ read(IIN_BIN) bc%ibulk1
+ read(IIN_BIN) bc%ibulk2
+ read(IIN_BIN) bc%coord(1,:)
+ read(IIN_BIN) bc%coord(2,:)
+ read(IIN_BIN) bc%coord(3,:)
+ bc%dt = dt
+
+ allocate( bc%B(bc%nglob) )
+ bc%B = 0e0_CUSTOM_REAL
+ allocate( nx(bc%nglob),ny(bc%nglob),nz(bc%nglob) )
+ nx = 0e0_CUSTOM_REAL
+ ny = 0e0_CUSTOM_REAL
+ nz = 0e0_CUSTOM_REAL
+ do e=1,bc%nspec
+ do ij = 1,NGLLSQUARE
+ k = ibool1(ij,e)
+ nx(k) = nx(k) + normal(1,ij,e)
+ ny(k) = ny(k) + normal(2,ij,e)
+ nz(k) = nz(k) + normal(3,ij,e)
+ bc%B(k) = bc%B(k) + jacobian2Dw(ij,e)
+ enddo
+ enddo
+ do k=1,bc%nglob
+ norm = sqrt( nx(k)*nx(k) + ny(k)*ny(k) + nz(k)*nz(k) )
+ nx(k) = nx(k) / norm
+ ny(k) = ny(k) / norm
+ nz(k) = nz(k) / norm
+ enddo
+
+ allocate( bc%R(3,3,bc%nglob) )
+ call compute_R(bc%R,bc%nglob,nx,ny,nz)
+
+! Needed in dA_Free = -K2*d2/M2 + K1*d1/M1
+ allocate(bc%invM1(bc%nglob))
+ allocate(bc%invM2(bc%nglob))
+ bc%invM1 = Minv(bc%ibulk1)
+ bc%invM2 = Minv(bc%ibulk2)
+
+! Fault impedance, Z in : Trac=T_Stick-Z*dV
+! Z = 1/( B1/M1 + B2/M2 ) / (0.5*dt)
+! T_stick = Z*Vfree traction as if the fault was stuck (no displ discontinuity)
+! NOTE: same Bi on both sides, see note above
+ allocate(bc%Z(bc%nglob))
+ bc%Z = 1.e0_CUSTOM_REAL/(0.5e0_CUSTOM_REAL*dt * bc%B *( bc%invM1 + bc%invM2 ))
+
+ allocate(bc%T(3,bc%nglob))
+ allocate(bc%D(3,bc%nglob))
+ allocate(bc%V(3,bc%nglob))
+ bc%T = 0e0_CUSTOM_REAL
+ bc%D = 0e0_CUSTOM_REAL
+ bc%V = 0e0_CUSTOM_REAL
+
+! Set initial fault stresses
+ allocate(bc%T0(3,bc%nglob))
+ S1 = 0e0_CUSTOM_REAL
+ S2 = 0e0_CUSTOM_REAL
+ S3 = 0e0_CUSTOM_REAL
+ n1=0
+ n2=0
+ n3=0
+ read(IIN_PAR, nml=INIT_STRESS)
+ bc%T0(1,:) = S1
+ bc%T0(2,:) = S2
+ bc%T0(3,:) = S3
+
+ call init_2d_distribution(bc%T0(1,:),bc%coord,IIN_PAR,n1)
+ call init_2d_distribution(bc%T0(2,:),bc%coord,IIN_PAR,n2)
+ call init_2d_distribution(bc%T0(3,:),bc%coord,IIN_PAR,n3)
+
+!WARNING : Quick and dirty free surface condition at z=0
+! do k=1,bc%nglob
+! if (abs(bc%zcoord(k)-0.e0_CUSTOM_REAL) <= SMALLVAL) bc%T0(2,k) = 0
+! end do
+
+! Set friction parameters and initialize friction variables
+ allocate( bc%swf )
+ allocate( bc%swf%mus(bc%nglob) )
+ allocate( bc%swf%mud(bc%nglob) )
+ allocate( bc%swf%Dc(bc%nglob) )
+ allocate( bc%swf%theta(bc%nglob) )
+ ! WARNING: if V_HEALING is negative we turn off healing
+ bc%swf%healing = (V_HEALING > 0e0_CUSTOM_REAL)
+
+ mus = 0.6e0_CUSTOM_REAL
+ mud = 0.1e0_CUSTOM_REAL
+ dc = 1e0_CUSTOM_REAL
+ nmus = 0
+ nmud = 0
+ ndc = 0
+
+ read(IIN_PAR, nml=SWF)
+ bc%swf%mus = mus
+ bc%swf%mud = mud
+ bc%swf%Dc = dc
+ call init_2d_distribution(bc%swf%mus,bc%coord,IIN_PAR,nmus)
+ call init_2d_distribution(bc%swf%mud,bc%coord,IIN_PAR,nmud)
+ call init_2d_distribution(bc%swf%Dc ,bc%coord,IIN_PAR,ndc)
+
+ bc%swf%theta = 0e0_CUSTOM_REAL
+ allocate(bc%MU(bc%nglob))
+ bc%MU = swf_mu(bc%swf)
+
+ call init_dataT(bc%dataT,bc%coord,bc%nglob,NT,iflt)
+ call init_dataXZ(bc%dataXZ,bc,bc%nglob)
+
+ end subroutine init_one_fault
+
+!---------------------------------------------------------------------
+ subroutine compute_R(R,nglob,nx,ny,nz)
+
+ integer :: nglob
+ real(kind=CUSTOM_REAL), intent(out) :: R(3,3,nglob)
+ real(kind=CUSTOM_REAL), dimension(nglob), intent(in) :: nx,ny,nz
+
+ real(kind=CUSTOM_REAL), dimension(nglob) :: sx,sy,sz,dx,dy,dz,norm
+
+! Percy , defining fault directions (in concordance with SCEC conventions) .
+! fault coordinates (s,d,n) = (1,2,3)
+! s = strike , d = dip , n = n.
+! 1 = strike , 2 = dip , 3 = n.
+ norm = sqrt(nx*nx+ny*ny)
+ sx = ny/norm
+ sy = -nx/norm
+ sz = 0.e0_CUSTOM_REAL
+
+ norm = sqrt(sy*sy*nz*nz+sx*sx*nz*nz+(sy*nx-ny*sx)*(nx*sy-ny*sx))
+ dx = -sy*nz/norm
+ dy = sx*nz/norm
+ dz = (sy*nx-ny*sx)/norm
+!Percy, dz is always dipwards = -1/norm , because (nx*sy-ny*sx)= - 1
+
+ R(1,1,:)=sx
+ R(1,2,:)=sy
+ R(1,3,:)=sz
+ R(2,1,:)=dx
+ R(2,2,:)=dy
+ R(2,3,:)=dz
+ R(3,1,:)=nx
+ R(3,2,:)=ny
+ R(3,3,:)=nz
+
+ end subroutine compute_R
+
+!---------------------------------------------------------------------
+! adds a value to a fault parameter inside an area with prescribed shape
+ subroutine init_2d_distribution(a,coord,iin,n)
+
+ real(kind=CUSTOM_REAL), intent(inout) :: a(:)
+ real(kind=CUSTOM_REAL), intent(in) :: coord(:,:)
+ integer, intent(in) :: iin,n
+
+ real(kind=CUSTOM_REAL) :: b(size(a))
+ character(len=10) :: shape
+ real(kind=CUSTOM_REAL) :: val, xc, yc, zc, r, l, lx,ly,lz
+ integer :: i
+
+ NAMELIST / DIST2D / shape, val, xc, yc, zc, r, l, lx,ly,lz
+
+ if (n==0) return
+
+ do i=1,n
+ shape = ''
+ xc = 0e0_CUSTOM_REAL
+ yc = 0e0_CUSTOM_REAL
+ zc = 0e0_CUSTOM_REAL
+ r = 0e0_CUSTOM_REAL
+ l = 0e0_CUSTOM_REAL
+ lx = 0e0_CUSTOM_REAL
+ ly = 0e0_CUSTOM_REAL
+ lz = 0e0_CUSTOM_REAL
+ read(iin,DIST2D)
+ select case(shape)
+ case ('circle')
+ b = heaviside( r - sqrt((coord(1,:)-xc)**2 + (coord(2,:)-yc)**2 + (coord(3,:)-zc)**2 ) )
+ case ('ellipse')
+ b = heaviside( 1e0_CUSTOM_REAL - sqrt( (coord(1,:)-xc)**2/lx**2 + (coord(2,:)-yc)**2/ly**2 + (coord(3,:)-zc)**2/lz**2 ) )
+ case ('square')
+ b = heaviside((l/2._CUSTOM_REAL)-abs(coord(1,:)-xc)+SMALLVAL) * &
+ heaviside((l/2._CUSTOM_REAL)-abs(coord(2,:)-yc)+SMALLVAL) * &
+ heaviside((l/2._CUSTOM_REAL)-abs(coord(3,:)-zc)+SMALLVAL)
+ case ('rectangle')
+ b = heaviside((lx/2._CUSTOM_REAL)-abs(coord(1,:)-xc)+SMALLVAL) * &
+ heaviside((ly/2._CUSTOM_REAL)-abs(coord(2,:)-yc)+SMALLVAL) * &
+ heaviside((lz/2._CUSTOM_REAL)-abs(coord(3,:)-zc)+SMALLVAL)
+ case default
+ stop 'bc_dynflt_3d::init_2d_distribution:: unknown shape'
+ end select
+! a =a + b*val
+!Percy , assigning straight values of each patch .
+
+ where (b /= 0) a = b*val
+ enddo
+
+ end subroutine init_2d_distribution
+
+!---------------------------------------------------------------------
+ elemental function heaviside(x)
+
+ real(kind=CUSTOM_REAL), intent(in) :: x
+ real(kind=CUSTOM_REAL) :: heaviside
+
+ if (x>=0e0_CUSTOM_REAL) then
+ heaviside = 1e0_CUSTOM_REAL
+ else
+ heaviside = 0e0_CUSTOM_REAL
+ endif
+
+ end function heaviside
+
+!=====================================================================
+! adds boundary term Bt into Force array for each fault.
+!
+ subroutine bc_dynflt_set3d_all(F,Vel,Dis)
+
+ real(kind=CUSTOM_REAL), dimension(:,:), intent(in) :: Vel,Dis
+ real(kind=CUSTOM_REAL), dimension(:,:), intent(inout) :: F
+
+ integer :: iflt
+
+ if (.not. allocated(faults)) return
+ do iflt=1,size(faults)
+ if (faults(iflt)%nspec>0) call BC_DYNFLT_set3d(faults(iflt),F,Vel,Dis,iflt)
+ enddo
+
+ end subroutine bc_dynflt_set3d_all
+
+!---------------------------------------------------------------------
+ subroutine BC_DYNFLT_set3d(bc,MxA,V,D,iflt)
+
+ use specfem_par, only:it,NSTEP
+
+ real(kind=CUSTOM_REAL), intent(inout) :: MxA(:,:)
+ type(bc_dynflt_type), intent(inout) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: V(:,:),D(:,:)
+ integer,intent(in) :: iflt
+
+
+ real(kind=CUSTOM_REAL), dimension(bc%nglob) :: strength
+ real(kind=CUSTOM_REAL), dimension(3,bc%nglob) :: T
+ real(kind=CUSTOM_REAL), dimension(bc%nglob) :: t1,t2,tnorm,tnew
+ real(kind=CUSTOM_REAL), dimension(3,bc%nglob) :: dD,dV,dA
+ real(kind=CUSTOM_REAL), dimension(bc%nglob) :: theta_old, Vnorm, Vnorm_old
+ real(kind=CUSTOM_REAL) :: half_dt
+! integer :: k
+
+ half_dt = 0.5e0_CUSTOM_REAL*bc%dt
+ theta_old = bc%swf%theta
+ Vnorm_old = sqrt(bc%V(1,:)*bc%V(1,:)+bc%V(2,:)*bc%V(2,:))
+
+! get predicted values
+ dD = get_jump(bc,D) ! dD_predictor
+ dV = get_jump(bc,V) ! dV_predictor
+ dA = get_weighted_jump(bc,MxA) ! dA_free
+
+! rotate to fault frame (tangent,normal)
+! component 3 is normal to the fault
+ dD = rotate(bc,dD,1)
+ dV = rotate(bc,dV,1)
+ dA = rotate(bc,dA,1)
+
+! T_stick
+ T(1,:) = bc%Z * ( dV(1,:) + half_dt*dA(1,:) )
+ T(2,:) = bc%Z * ( dV(2,:) + half_dt*dA(2,:) )
+ T(3,:) = bc%Z * ( dV(3,:) + half_dt*dA(3,:) )
+
+!Warning : dirty particular free surface condition z = 0.
+! where (bc%zcoord(:) > - SMALLVAL) T(2,:) = 0
+! do k=1,bc%nglob
+! if (abs(bc%zcoord(k)-0.e0_CUSTOM_REAL) < SMALLVAL) T(2,k) = 0.e0_CUSTOM_REAL
+! end do
+
+! add initial stress
+ T = T + bc%T0
+
+! Solve for normal stress (negative is compressive)
+ ! Opening implies free stress
+ if (bc%allow_opening) T(3,:) = min(T(3,:),0.e0_CUSTOM_REAL)
+
+! Update slip weakening friction:
+ ! Update slip state variable
+ ! WARNING: during opening the friction state variable should not evolve
+ call swf_update_state(bc%D,dD,bc%V,bc%swf)
+
+ ! Update friction coeficient
+ bc%MU = swf_mu(bc%swf)
+
+! combined with time-weakening for nucleation
+! if (associated(bc%twf)) bc%MU = min( bc%MU, twf_mu(bc%twf,bc%coord,time) )
+
+! Update strength
+ strength = -bc%MU * min(T(3,:),0.e0_CUSTOM_REAL)
+
+! Solve for shear stress
+ tnorm = sqrt( T(1,:)*T(1,:) + T(2,:)*T(2,:))
+ t1 = T(1,:)/tnorm
+ t2 = T(2,:)/tnorm
+ tnew = min(tnorm,strength)
+ T(1,:) = tnew * t1
+ T(2,:) = tnew * t2
+
+! Save total tractions
+ bc%T = T
+
+! Subtract initial stress
+ T = T - bc%T0
+
+! Update slip acceleration da=da_free-T/(0.5*dt*Z)
+ dA(1,:) = dA(1,:) - T(1,:)/(bc%Z*half_dt)
+ dA(2,:) = dA(2,:) - T(2,:)/(bc%Z*half_dt)
+ dA(3,:) = dA(3,:) - T(3,:)/(bc%Z*half_dt)
+
+! Update slip and slip rate, in fault frame
+ bc%D = dD
+ bc%V = dV + half_dt*dA
+
+! Rotate tractions back to (x,y,z) frame
+ T = rotate(bc,T,-1)
+
+! Add boundary term B*T to M*a
+ MxA(1,bc%ibulk1) = MxA(1,bc%ibulk1) + bc%B*T(1,:)
+ MxA(2,bc%ibulk1) = MxA(2,bc%ibulk1) + bc%B*T(2,:)
+ MxA(3,bc%ibulk1) = MxA(3,bc%ibulk1) + bc%B*T(3,:)
+
+ MxA(1,bc%ibulk2) = MxA(1,bc%ibulk2) - bc%B*T(1,:)
+ MxA(2,bc%ibulk2) = MxA(2,bc%ibulk2) - bc%B*T(2,:)
+ MxA(3,bc%ibulk2) = MxA(3,bc%ibulk2) - bc%B*T(3,:)
+
+
+!-- intermediate storage of outputs --
+ Vnorm = sqrt(bc%V(1,:)*bc%V(1,:)+bc%V(2,:)*bc%V(2,:))
+ call store_dataXZ(bc%dataXZ, strength, theta_old, bc%swf%theta, bc%swf%dc, &
+ Vnorm_old, Vnorm, it*bc%dt,bc%dt)
+ call store_dataT(bc%dataT,bc%D,bc%V,bc%T,it)
+
+
+!-- outputs --
+! write dataT every NTOUT time step or at the end of simulation
+ if ( mod(it,NTOUT) == 0 .or. it==NSTEP) call SCEC_write_dataT(bc%dataT,bc%dt,it)
+! write dataXZ every NSNAP time step
+ if ( mod(it,NSNAP) == 0) call write_dataXZ(bc%dataXZ,it,iflt)
+ if ( it == NSTEP) call SCEC_Write_RuptureTime(bc%dataXZ,bc%dt,NSTEP,iflt)
+
+ end subroutine BC_DYNFLT_set3d
+
+!===============================================================
+ function get_jump (bc,v) result(dv)
+
+ type(bc_dynflt_type), intent(in) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: v(:,:)
+ real(kind=CUSTOM_REAL) :: dv(3,bc%nglob)
+
+! diference between side 2 and side 1 of fault nodes. dv
+ dv(1,:) = v(1,bc%ibulk2)-v(1,bc%ibulk1)
+ dv(2,:) = v(2,bc%ibulk2)-v(2,bc%ibulk1)
+ dv(3,:) = v(3,bc%ibulk2)-v(3,bc%ibulk1)
+
+ end function get_jump
+
+!---------------------------------------------------------------------
+ function get_weighted_jump (bc,f) result(da)
+
+ type(bc_dynflt_type), intent(in) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: f(:,:)
+
+ real(kind=CUSTOM_REAL) :: da(3,bc%nglob)
+
+! diference between side 2 and side 1 of fault nodes. M-1 * F
+ da(1,:) = bc%invM2*f(1,bc%ibulk2)-bc%invM1*f(1,bc%ibulk1)
+ da(2,:) = bc%invM2*f(2,bc%ibulk2)-bc%invM1*f(2,bc%ibulk1)
+ da(3,:) = bc%invM2*f(3,bc%ibulk2)-bc%invM1*f(3,bc%ibulk1)
+
+ end function get_weighted_jump
+
+!----------------------------------------------------------------------
+ function rotate(bc,v,fb) result(vr)
+
+ type(bc_dynflt_type), intent(in) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: v(3,bc%nglob)
+ integer, intent(in) :: fb
+ real(kind=CUSTOM_REAL) :: vr(3,bc%nglob)
+
+! Percy, tangential direction Vt, equation 7 of Pablo's notes in agreement with SPECFEM3D
+
+ ! forward rotation
+ if (fb==1) then
+ vr(1,:) = v(1,:)*bc%R(1,1,:)+v(2,:)*bc%R(1,2,:)+v(3,:)*bc%R(1,3,:) ! vs
+ vr(2,:) = v(1,:)*bc%R(2,1,:)+v(2,:)*bc%R(2,2,:)+v(3,:)*bc%R(2,3,:) ! vd
+ vr(3,:) = v(1,:)*bc%R(3,1,:)+v(2,:)*bc%R(3,2,:)+v(3,:)*bc%R(3,3,:) ! vn
+
+! backward rotation
+ else
+ vr(1,:) = v(1,:)*bc%R(1,1,:)+v(2,:)*bc%R(2,1,:)+v(3,:)*bc%R(3,1,:) !vx
+ vr(2,:) = v(1,:)*bc%R(1,2,:)+v(2,:)*bc%R(2,2,:)+v(3,:)*bc%R(3,2,:) !vy
+ vr(3,:) = v(1,:)*bc%R(1,3,:)+v(2,:)*bc%R(2,3,:)+v(3,:)*bc%R(3,3,:) !vz
+
+ endif
+
+ end function rotate
+
+
+!=====================================================================
+ subroutine swf_update_state(dold,dnew,vold,f)
+
+ real(kind=CUSTOM_REAL), dimension(:,:), intent(in) :: vold,dold,dnew
+ type(swf_type), intent(inout) :: f
+
+ real(kind=CUSTOM_REAL) :: vnorm
+ integer :: k,npoin
+
+ f%theta = f%theta + sqrt( (dold(1,:)-dnew(1,:))**2 + (dold(2,:)-dnew(2,:))**2 )
+
+ if (f%healing) then
+ npoin = size(vold,2)
+ do k=1,npoin
+ vnorm = sqrt(vold(1,k)**2 + vold(2,k)**2)
+ if (vnorm<V_HEALING) f%theta(k) = 0e0_CUSTOM_REAL
+ enddo
+ endif
+ end subroutine swf_update_state
+
+
+!=====================================================================
+! Friction coefficient
+ function swf_mu(f) result(mu)
+
+ type(swf_type), intent(in) :: f
+ real(kind=CUSTOM_REAL) :: mu(size(f%theta))
+
+ !-- linear slip weakening:
+
+ mu = f%mus -(f%mus-f%mud)/f%dc *f%theta
+ mu = max( mu, f%mud)
+
+ end function swf_mu
+
+
+!===============================================================
+! OUTPUTS
+
+ subroutine init_dataT(DataT,coord,nglob,NT,iflt)
+ ! NT = total number of time steps
+
+ integer, intent(in) :: nglob,NT,iflt
+ real(kind=CUSTOM_REAL), intent(in) :: coord(3,nglob)
+ type (dataT_type), intent(out) :: DataT
+
+ real(kind=CUSTOM_REAL) :: xtarget,ytarget,ztarget,dist,distkeep
+ integer :: i, iglob , IIN, ier, jflt, np, k
+ character(len=70) :: tmpname
+
+ ! 1. read fault output coordinates from user file,
+ ! 2. define iglob: the fault global index of the node nearest to user
+ ! requested coordinate
+
+ IIN = 251
+ open(IIN,file='DATA/FAULT/FAULT_STATIONS.in',status='old',action='read',iostat=ier)
+ read(IIN,*) np
+ DataT%npoin =0
+ do i=1,np
+ read(IIN,*) xtarget,ytarget,ztarget,tmpname,jflt
+ if (jflt==iflt) DataT%npoin = DataT%npoin +1
+ enddo
+ close(IIN)
+
+ if (DataT%npoin == 0) return
+
+ allocate(DataT%iglob(DataT%npoin))
+ allocate(DataT%name(DataT%npoin))
+
+ open(IIN,file='DATA/FAULT/FAULT_STATIONS.in',status='old',action='read',iostat=ier)
+ if( ier /= 0 ) stop 'error opening FAULT_STATIONS file'
+ read(IIN,*) np
+ k = 0
+ do i=1,np
+ read(IIN,*) xtarget,ytarget,ztarget,tmpname,jflt
+ if (jflt/=iflt) cycle
+ k = k+1
+ DataT%name(k) = tmpname
+ !search nearest node
+ distkeep = huge(distkeep)
+
+ do iglob=1,nglob
+ dist = sqrt((coord(1,iglob)-xtarget)**2 &
+ + (coord(2,iglob)-ytarget)**2 &
+ + (coord(3,iglob)-ztarget)**2)
+ if (dist < distkeep) then
+ distkeep = dist
+ DataT%iglob(k) = iglob
+ endif
+ enddo
+ enddo
+
+ ! 3. allocate arrays and set to zero
+ allocate(DataT%d1(NT,DataT%npoin))
+ allocate(DataT%v1(NT,DataT%npoin))
+ allocate(DataT%t1(NT,DataT%npoin))
+ allocate(DataT%d2(NT,DataT%npoin))
+ allocate(DataT%v2(NT,DataT%npoin))
+ allocate(DataT%t2(NT,DataT%npoin))
+ allocate(DataT%t3(NT,DataT%npoin))
+ DataT%d1 = 0e0_CUSTOM_REAL
+ DataT%v1 = 0e0_CUSTOM_REAL
+ DataT%t1 = 0e0_CUSTOM_REAL
+ DataT%d2 = 0e0_CUSTOM_REAL
+ DataT%v2 = 0e0_CUSTOM_REAL
+ DataT%t2 = 0e0_CUSTOM_REAL
+ DataT%t3 = 0e0_CUSTOM_REAL
+
+ close(IIN)
+
+ end subroutine init_dataT
+
+
+!---------------------------------------------------------------
+ subroutine store_dataT(dataT,d,v,t,itime)
+
+ type(dataT_type), intent(inout) :: dataT
+ real(kind=CUSTOM_REAL), dimension(:,:), intent(in) :: d,v,t
+ integer, intent(in) :: itime
+
+ integer :: i,k
+
+ do i=1,dataT%npoin
+ k = dataT%iglob(i)
+ dataT%d1(itime,i) = d(1,k)
+ dataT%d2(itime,i) = d(2,k)
+ dataT%v1(itime,i) = v(1,k)
+ dataT%v2(itime,i) = v(2,k)
+ dataT%t1(itime,i) = t(1,k)
+ dataT%t2(itime,i) = t(2,k)
+ dataT%t3(itime,i) = t(3,k)
+ enddo
+
+ end subroutine store_dataT
+
+
+!-----------------------------------------------------------------
+ subroutine write_dataT_all(nt)
+
+ integer, intent(in) :: nt
+
+ integer :: i
+
+ if (.not.allocated(faults)) return
+ do i = 1,size(faults)
+ call SCEC_write_dataT(faults(i)%dataT,faults(i)%dt,nt)
+ enddo
+
+ end subroutine write_dataT_all
+
+!------------------------------------------------------------------------
+ subroutine SCEC_write_dataT(dataT,DT,NT)
+
+ type(dataT_type), intent(in) :: dataT
+ real(kind=CUSTOM_REAL), intent(in) :: DT
+ integer, intent(in) :: NT
+
+ integer :: i,k,IOUT
+ character :: NTchar*5
+
+ IOUT = 121 !WARNING: not very robust. Could instead look for an available ID
+
+ write(NTchar,1) NT
+ NTchar = adjustl(NTchar)
+
+1 format(I5)
+ do i=1,dataT%npoin
+
+ open(IOUT,file='OUTPUT_FILES/'//trim(dataT%name(i))//'.dat',status='replace')
+ write(IOUT,*) "# problem=TPV15"
+ write(IOUT,*) "# author=Galvez, Ampuero, Nissen-Meyer"
+ write(IOUT,*) "# date=2011/xx/xx"
+ write(IOUT,*) "# code=SPECFEM3D_FAULT "
+ write(IOUT,*) "# code_version=1.1"
+ write(IOUT,*) "# element_size=100 m (*4 GLL nodes)"
+ write(IOUT,*) "# time_step=",DT
+ write(IOUT,*) "# num_time_steps=",NT
+ write(IOUT,*) "# location=",trim(dataT%name(i))
+ write(IOUT,*) "# Time series in 8 column of E15.7"
+ write(IOUT,*) "# Column #1 = Time (s)"
+ write(IOUT,*) "# Column #2 = horizontal right-lateral slip (m)"
+ write(IOUT,*) "# Column #3 = horizontal right-lateral slip rate (m/s)"
+ write(IOUT,*) "# Column #4 = horizontal right-lateral shear stress (MPa)"
+ write(IOUT,*) "# Column #5 = vertical up-dip slip (m)"
+ write(IOUT,*) "# Column #6 = vertical up-dip slip rate (m/s)"
+ write(IOUT,*) "# Column #7 = vertical up-dip shear stress (MPa)"
+ write(IOUT,*) "# Column #8 = normal stress (MPa)"
+ write(IOUT,*) "#"
+ write(IOUT,*) "# The line below lists the names of the data fields:"
+ write(IOUT,*) "#t h-slip h-slip-rate h-shear-stress v-slip v-slip-rate v-shear-stress n-stress"
+ write(IOUT,*) "#"
+ do k=1,NT
+ write(IOUT,'(8(E15.7))') k*DT, dataT%d1(k,i), dataT%v1(k,i), dataT%t1(k,i)/1.0e6_CUSTOM_REAL, &
+ dataT%d2(k,i), dataT%v2(k,i), dataT%t2(k,i)/1.0e6_CUSTOM_REAL, &
+ dataT%t3(k,i)/1.0e6_CUSTOM_REAL
+ enddo
+ close(IOUT)
+ enddo
+
+ end subroutine SCEC_write_dataT
+
+!-------------------------------------------------------------------------------------------------
+
+ subroutine SCEC_Write_RuptureTime(dataXZ,DT,NT,iflt)
+
+ type(dataXZ_type), intent(in) :: dataXZ
+ real(kind=CUSTOM_REAL), intent(in) :: DT
+ integer, intent(in) :: NT,iflt
+
+ integer :: i,IOUT
+ character(len=70) :: filename
+
+ write(filename,"('OUTPUT_FILES/RuptureTime_Fault',I0)") iflt
+
+ IOUT = 121 !WARNING: not very robust. Could instead look for an available ID
+
+ open(IOUT,file=trim(filename),status='replace')
+ write(IOUT,*) "# problem=TPV5"
+ write(IOUT,*) "# author=Galvez, Ampuero, Tarje"
+ write(IOUT,*) "# date=2011/xx/xx"
+ write(IOUT,*) "# code=SPECFEM3D_FAULT"
+ write(IOUT,*) "# code_version=1.1"
+ write(IOUT,*) "# element_size=100 m (*4 GLL nodes)"
+ write(IOUT,*) "# time_step=",DT
+ write(IOUT,*) "# num_time_steps=",NT
+ write(IOUT,*) "# Column #1 = horizontal coordinate, distance along strike (m)"
+ write(IOUT,*) "# Column #2 = vertical coordinate, distance down-dip (m)"
+ write(IOUT,*) "# Column #3 = rupture time (s)"
+ write(IOUT,*) "# x y z time"
+ do i = 1,size(dataXZ%tRUP)
+ write(IOUT,'(4(E15.7))') dataXZ%xcoord(i), dataXZ%ycoord(i), dataXZ%zcoord(i), dataXZ%tRUP(i)
+ end do
+
+ close(IOUT)
+
+ end subroutine SCEC_Write_RuptureTime
+
+!-------------------------------------------------------------------------------------------------
+
+ subroutine init_dataXZ(DataXZ,bc,nglob)
+
+ type(dataXZ_type), intent(inout) :: DataXZ
+ type(bc_dynflt_type) :: bc
+ integer, intent(in) :: nglob
+
+ allocate(DataXZ%stg(nglob))
+ DataXZ%sta => bc%swf%theta
+ DataXZ%d1 => bc%d(1,:)
+ DataXZ%d2 => bc%d(2,:)
+ DataXZ%v1 => bc%v(1,:)
+ DataXZ%v2 => bc%v(2,:)
+ DataXZ%t1 => bc%t(1,:)
+ DataXZ%t2 => bc%t(2,:)
+ DataXZ%t3 => bc%t(3,:)
+ DataXZ%xcoord => bc%coord(1,:)
+ DataXZ%ycoord => bc%coord(2,:)
+ DataXZ%zcoord => bc%coord(3,:)
+ allocate(DataXZ%tRUP(nglob))
+ allocate(DataXZ%tPZ(nglob))
+
+!Percy , setting up initial rupture time null for all faults.
+ DataXZ%tRUP = 0e0_CUSTOM_REAL
+ DataXZ%tPZ = 0e0_CUSTOM_REAL
+
+
+ end subroutine init_dataXZ
+
+!---------------------------------------------------------------
+subroutine store_dataXZ(dataXZ,stg,dold,dnew,dc,vold,vnew,time,dt)
+
+ type(dataXZ_type), intent(inout) :: dataXZ
+ real(kind=CUSTOM_REAL), dimension(:), intent(in) :: stg,dold,dnew,dc,vold,vnew
+ real(kind=CUSTOM_REAL), intent(in) :: time,dt
+
+ integer :: i
+
+! "stg" : strength .
+
+ dataXZ%stg = stg
+
+ do i = 1,size(stg)
+ ! process zone time = first time when slip = dc (break down process).
+ ! with linear time interpolation
+ if (dataXZ%tPZ(i)==0e0_CUSTOM_REAL) then
+ if (dold(i)<=dc(i) .and. dnew(i) >= dc(i)) then
+ dataXZ%tPZ(i) = time-dt*(dnew(i)-dc(i))/(dnew(i)-dold(i))
+ endif
+ endif
+ ! rupture time = first time when slip velocity = vc
+ ! with linear time interpolation
+ ! vc should be pre-defined as input data .
+
+ if (dataXZ%tRUP(i)==0e0_CUSTOM_REAL) then
+ if (vold(i)<=V_RUPT .and. vnew(i)>=V_RUPT) dataXZ%tRUP(i)= time-dt*(vnew(i)-V_RUPT)/(vnew(i)-vold(i))
+ endif
+ enddo
+
+
+! To do : add stress criteria (firs time strength is reached).
+
+ ! note: the other arrays in dataXZ are pointers to arrays in bc
+ ! they do not need to be updated here
+
+ end subroutine store_dataXZ
+
+!---------------------------------------------------------------
+ subroutine write_dataXZ(dataXZ,itime,iflt)
+
+
+ type(dataXZ_type), intent(in) :: dataXZ
+ integer, intent(in) :: itime,iflt
+
+ character(len=70) :: filename
+
+
+ write(filename,"('OUTPUT_FILES/Snapshot',I0,'_F',I0,'.bin')") itime,iflt
+ open(unit=IOUT, file= trim(filename), status='replace', form='formatted',action='write')
+! open(unit=IOUT, file= trim(filename), status='replace', form='unformatted')
+! NOTE : It had to be adopted formatted output to avoid conflicts readings with different
+! compilers.
+
+ write(IOUT,"(5F24.15)") dataXZ%xcoord,dataXZ%ycoord,dataXZ%zcoord,dataXZ%v1,dataXZ%v2
+
+
+! WARNING: for the case of multiple faults the filename must contain a fault identifier
+! (a separate snapshot file for each fault)
+! write(filename,"('OUTPUT_FILES/Snapshot',I0,'_F',I0,'.bin')") itime,iflt
+!
+! open(unit=IOUT, file= trim(filename), status='replace', form='unformatted')
+
+! write(IOUT) dataXZ%xcoord
+! write(IOUT) dataXZ%ycoord
+! write(IOUT) dataXZ%zcoord
+! write(IOUT) dataXZ%d1
+! write(IOUT) dataXZ%d2
+! write(IOUT) dataXZ%v1
+! write(IOUT) dataXZ%v2
+! write(IOUT) dataXZ%t1
+! write(IOUT) dataXZ%t2
+! write(IOUT) dataXZ%t3
+! write(IOUT) dataXZ%sta
+! write(IOUT) dataXZ%stg
+! write(IOUT) dataXZ%tRUP
+! write(IOUT) dataXZ%tPZ
+ close(IOUT)
+
+ end subroutine write_dataXZ
+
+
+end module fault_solver
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/fault_solver_kinematic.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/fault_solver_kinematic.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/fault_solver_kinematic.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,717 @@
+!=====================================================================
+!
+! 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.
+!
+!===============================================================================================================
+
+! This module was written by:
+! Percy Galvez , Jean-Paul Ampuero and Javier Ruiz
+! based on fault_solver.f90
+
+module fault_solver_kinematic
+
+ implicit none
+
+ include 'constants.h'
+
+ private
+
+! outputs on selected fault nodes at every time step:
+! slip, slip velocity, fault stresses
+ type dataT_type
+ integer :: npoin
+ integer, dimension(:), pointer :: iglob
+ real(kind=CUSTOM_REAL), dimension(:,:), pointer :: d1,v1,t1,d2,v2,t2,t3
+ character(len=70), dimension(:), pointer :: name
+ end type dataT_type
+
+! DATAXZ_type used to read snapshots (temporal)
+ type dataXZ_type
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: d1, d2, v1, v2, & !Slip and Slip rate.
+ t1, t2, t3 !Tractions.
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: xcoord,ycoord,zcoord
+ integer :: npoin
+ end type dataXZ_type
+
+ type bc_kinflt_type
+ private
+ integer :: nspec,nglob
+ real(kind=CUSTOM_REAL) :: dt
+ real(kind=CUSTOM_REAL), dimension(:), pointer :: B,invM1,invM2,Z
+ real(kind=CUSTOM_REAL), dimension(:,:), pointer :: T,slip,slip_rate,coord
+ real(kind=CUSTOM_REAL), dimension(:,:,:), pointer :: R
+ integer, dimension(:), pointer :: ibulk1, ibulk2
+ type(dataT_type) :: dataT
+ type(dataXZ_type) :: dataXZ
+ real(kind=CUSTOM_REAL) :: kin_dt
+ integer :: kin_it
+ real(kind=CUSTOM_REAL), dimension(:,:), pointer :: v_kin_t1,v_kin_t2
+ end type bc_kinflt_type
+
+ type(bc_kinflt_type), allocatable, save :: faults(:)
+
+!Number of time steps defined by the user : NTOUT
+ integer, save :: NTOUT,NSNAP
+
+ integer, save :: SIMULATION_TYPE_KIN = 2
+
+! integer , save :: size_Kelvin_Voigt
+
+! real(kind=CUSTOM_REAL), allocatable, save :: Kelvin_Voigt_eta(:)
+
+
+! public :: BC_KINFLT_init, BC_KINFLT_set_all, Kelvin_Voigt_eta, &
+! size_Kelvin_Voigt, SIMULATION_TYPE_KIN
+
+ public :: BC_KINFLT_init, BC_KINFLT_set_all, SIMULATION_TYPE_KIN
+
+
+contains
+
+
+!=====================================================================
+! BC_KINFLT_init initializes kinematic faults
+!
+! prname fault database is read from file prname_fault_db.bin
+! Minv inverse mass matrix
+! dt global time step
+!
+subroutine BC_KINFLT_init(prname,Minv,DTglobal,nt)
+
+ character(len=256), intent(in) :: prname ! 'proc***'
+ real(kind=CUSTOM_REAL), intent(in) :: Minv(:)
+ double precision, intent(in) :: DTglobal
+ integer, intent(in) :: nt
+
+ real(kind=CUSTOM_REAL) :: dt
+ integer :: iflt,ier,dummy_idfault
+ integer :: nbfaults
+ character(len=256) :: filename
+ integer, parameter :: IIN_PAR =151
+ integer, parameter :: IIN_BIN =170
+ real(kind=CUSTOM_REAL) :: DUMMY
+
+ NAMELIST / BEGIN_FAULT / dummy_idfault
+
+ dummy_idfault = 0
+
+! filename = prname(1:len_trim(prname))//'Kelvin_voigt_eta.bin'
+! open(unit=IIN_BIN,file=trim(filename),status='old',action='read',form='unformatted',iostat=ier)
+! if( ier /= 0 ) stop 'Haven not found proc*_Kelvin_voigt_eta.bin'
+! read(IIN_BIN) size_Kelvin_Voigt
+! if (size_Kelvin_Voigt > 0) then
+! allocate(Kelvin_Voigt_eta(size_Kelvin_Voigt))
+! read(IIN_BIN) Kelvin_Voigt_eta
+! endif
+! Close(IIN_BIN)
+
+ open(unit=IIN_PAR,file='DATA/FAULT/Par_file_faults.in',status='old',iostat=ier)
+ if( ier /= 0 ) then
+ write(6,*) 'Have not found Par_file_faults.in: assume no faults'
+ return
+ endif
+
+ dt = real(DTglobal)
+ filename = prname(1:len_trim(prname))//'fault_db.bin'
+ open(unit=IIN_BIN,file=trim(filename),status='old',action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) stop 'Have not found proc*_fault_db.bin'
+! WARNING TO DO: should be an MPI abort
+
+ read(IIN_PAR,*) nbfaults
+ do iflt=1,nbfaults
+ read(IIN_PAR,*)
+ enddo
+
+ read(IIN_PAR,*) SIMULATION_TYPE_KIN
+ if ( SIMULATION_TYPE_KIN == 1 ) goto 99
+ read(IIN_PAR,*) NTOUT
+ read(IIN_PAR,*) NSNAP
+ read(IIN_PAR,*) DUMMY
+ read(IIN_PAR,*) DUMMY
+ read(IIN_BIN) nbfaults ! should be the same as in IIN_PAR
+ allocate( faults(nbfaults) )
+ do iflt=1,nbfaults
+ read(IIN_PAR,nml=BEGIN_FAULT,end=100)
+ call init_one_fault(faults(iflt),IIN_BIN,IIN_PAR,Minv,dt,nt,iflt)
+ enddo
+99 close(IIN_BIN)
+ close(IIN_PAR)
+
+ return
+100 stop 'Did not find BEGIN_FAULT block #'
+ ! WARNING TO DO: should be an MPI abort
+
+end subroutine BC_KINFLT_init
+
+
+!---------------------------------------------------------------------
+
+subroutine init_one_fault(bc,IIN_BIN,IIN_PAR,Minv,dt,NT,iflt)
+
+ type(bc_kinflt_type), intent(inout) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: Minv(:)
+ integer, intent(in) :: IIN_BIN,IIN_PAR,NT,iflt
+ real(kind=CUSTOM_REAL), intent(in) :: dt
+
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: jacobian2Dw
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: normal
+ integer, dimension(:,:), allocatable :: ibool1
+ real(kind=CUSTOM_REAL) :: norm
+ integer :: ij,k,e
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: nx,ny,nz
+ real(kind=CUSTOM_REAL) :: kindt
+
+ NAMELIST / KINPAR / kindt
+
+ read(IIN_BIN) bc%nspec,bc%nglob
+ if (bc%nspec==0) return
+
+ allocate( bc%ibulk1(bc%nglob) )
+ allocate( bc%ibulk2(bc%nglob) )
+ allocate( ibool1(NGLLSQUARE,bc%nspec) )
+ allocate(normal(NDIM,NGLLSQUARE,bc%nspec))
+ allocate(jacobian2Dw(NGLLSQUARE,bc%nspec))
+ allocate(bc%coord(3,bc%nglob))
+
+ read(IIN_BIN) ibool1
+ read(IIN_BIN) jacobian2Dw
+ read(IIN_BIN) normal
+ read(IIN_BIN) bc%ibulk1
+ read(IIN_BIN) bc%ibulk2
+ read(IIN_BIN) bc%coord(1,:)
+ read(IIN_BIN) bc%coord(2,:)
+ read(IIN_BIN) bc%coord(3,:)
+ bc%dt = dt
+
+ allocate( bc%B(bc%nglob) )
+ bc%B = 0e0_CUSTOM_REAL
+ allocate( nx(bc%nglob),ny(bc%nglob),nz(bc%nglob) )
+ nx = 0e0_CUSTOM_REAL
+ ny = 0e0_CUSTOM_REAL
+ nz = 0e0_CUSTOM_REAL
+ do e=1,bc%nspec
+ do ij = 1,NGLLSQUARE
+ k = ibool1(ij,e)
+ nx(k) = nx(k) + normal(1,ij,e)
+ ny(k) = ny(k) + normal(2,ij,e)
+ nz(k) = nz(k) + normal(3,ij,e)
+ bc%B(k) = bc%B(k) + jacobian2Dw(ij,e)
+ enddo
+ enddo
+ ! TO DO: assemble B and n across processors
+ do k=1,bc%nglob
+ norm = sqrt( nx(k)*nx(k) + ny(k)*ny(k) + nz(k)*nz(k) )
+ nx(k) = nx(k) / norm
+ ny(k) = ny(k) / norm
+ nz(k) = nz(k) / norm
+ enddo
+ allocate( bc%R(3,3,bc%nglob) )
+ call compute_R(bc%R,bc%nglob,nx,ny,nz)
+ deallocate(nx,ny,nz)
+! Needed in dA_Free = -K2*d2/M2 + K1*d1/M1
+ allocate(bc%invM1(bc%nglob))
+ allocate(bc%invM2(bc%nglob))
+ bc%invM1 = Minv(bc%ibulk1)
+ bc%invM2 = Minv(bc%ibulk2)
+
+! Fault impedance, Z in : Trac=T_Stick-Z*dV
+! Z = 1/( B1/M1 + B2/M2 ) / (0.5*dt)
+! T_Stick = Z*Vfree traction as if the fault was stuck (no displ discontinuity)
+! NOTE: same Bi on both sides, see note above
+ allocate(bc%Z(bc%nglob))
+ bc%Z = 1.e0_CUSTOM_REAL/(0.5e0_CUSTOM_REAL*dt * bc%B *( bc%invM1 + bc%invM2 ))
+
+ allocate(bc%T(3,bc%nglob))
+ allocate(bc%slip(3,bc%nglob))
+ allocate(bc%slip_rate(3,bc%nglob))
+ bc%T = 0e0_CUSTOM_REAL
+ bc%slip = 0e0_CUSTOM_REAL
+ bc%slip_rate = 0e0_CUSTOM_REAL
+! Dt between two loaded slip_rates
+
+ read(IIN_PAR,nml=KINPAR)
+ bc%kin_dt = kindt
+
+ bc%kin_it=0
+! Always have in memory the slip-rate model at two times, t1 and t2,
+! spatially interpolated in the spectral element grid
+ allocate(bc%v_kin_t1(2,bc%nglob))
+ allocate(bc%v_kin_t2(2,bc%nglob))
+ bc%v_kin_t1 = 0e0_CUSTOM_REAL
+ bc%v_kin_t2 = 0e0_CUSTOM_REAL
+
+ call init_dataT(bc%dataT,bc%coord,bc%nglob,NT,iflt)
+ call init_dataXZ(bc%dataXZ,bc%nglob)
+
+end subroutine init_one_fault
+
+!---------------------------------------------------------------------
+subroutine compute_R(R,nglob,nx,ny,nz)
+
+ integer :: nglob
+ real(kind=CUSTOM_REAL), intent(out) :: R(3,3,nglob)
+ real(kind=CUSTOM_REAL), dimension(nglob), intent(in) :: nx,ny,nz
+
+ real(kind=CUSTOM_REAL), dimension(nglob) :: sx,sy,sz,dx,dy,dz,norm
+
+! Percy , defining fault directions (in concordance with SCEC conventions) .
+! fault coordinates (s,d,n) = (1,2,3)
+! s = strike , d = dip , n = n.
+! 1 = strike , 2 = dip , 3 = n.
+ norm = sqrt(nx*nx+ny*ny)
+ sx = ny/norm
+ sy = -nx/norm
+ sz = 0.e0_CUSTOM_REAL
+
+ norm = sqrt(sy*sy*nz*nz+sx*sx*nz*nz+(sy*nx-ny*sx)*(nx*sy-ny*sx))
+ dx = -sy*nz/norm
+ dy = sx*nz/norm
+ dz = (sy*nx-ny*sx)/norm
+!Percy, dz is always dipwards = -1/norm , because (nx*sy-ny*sx)= - 1
+
+ R(1,1,:)=sx
+ R(1,2,:)=sy
+ R(1,3,:)=sz
+ R(2,1,:)=dx
+ R(2,2,:)=dy
+ R(2,3,:)=dz
+ R(3,1,:)=nx
+ R(3,2,:)=ny
+ R(3,3,:)=nz
+
+
+end subroutine compute_R
+
+
+!=====================================================================
+! adds boundary term Bt to Force array for each fault.
+!
+subroutine BC_KINFLT_set_all(F,Vel,Dis)
+
+ real(kind=CUSTOM_REAL), dimension(:,:), intent(in) :: Vel,Dis
+ real(kind=CUSTOM_REAL), dimension(:,:), intent(inout) :: F
+
+ integer :: iflt
+
+ if (.not. allocated(faults)) return
+ do iflt=1,size(faults)
+ if (faults(iflt)%nspec>0) call BC_KINFLT_set_single(faults(iflt),F,Vel,Dis,iflt)
+ enddo
+
+end subroutine BC_KINFLT_set_all
+
+!---------------------------------------------------------------------
+subroutine BC_KINFLT_set_single(bc,MxA,V,D,iflt)
+
+ use specfem_par, only:it,NSTEP
+
+ real(kind=CUSTOM_REAL), intent(inout) :: MxA(:,:)
+ type(bc_kinflt_type), intent(inout) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: V(:,:),D(:,:)
+ integer,intent(in) :: iflt
+ integer :: it_kin,itime
+ real(kind=CUSTOM_REAL), dimension(3,bc%nglob) :: T
+ real(kind=CUSTOM_REAL), dimension(3,bc%nglob) :: dD,dV,dA,dV_free
+ real(kind=CUSTOM_REAL) :: t1,t2
+ real(kind=CUSTOM_REAL) :: half_dt,time
+
+ half_dt = 0.5e0_CUSTOM_REAL*bc%dt
+
+! get predicted values
+ dD = get_jump(bc,D) ! dD_predictor
+ dV = get_jump(bc,V) ! dV_predictor
+ dA = get_weighted_jump(bc,MxA) ! dA_free
+
+! rotate to fault frame (tangent,normal)
+! component 3 is normal to the fault
+ dD = rotate(bc,dD,1)
+ dV = rotate(bc,dV,1)
+ dA = rotate(bc,dA,1)
+
+! Time marching
+ time = it*bc%dt
+! Slip_rate step "it_kin"
+ it_kin = bc%kin_it*nint(bc%kin_dt/bc%dt)
+! (nint : fortran round (nearest whole number) ,
+! if nint(a)=0.5 then "a" get upper bound )
+
+! Loading the next slipt_rate one ahead it.
+! This is done in case bc%kin_dt
+! if (it_kin == it) it_kin=it_kin+1 !
+
+
+!NOTE : it and it_kin is being used due to integers are exact numbers.
+ if (it > it_kin) then
+
+ print*, 'it :'
+ print*, it
+ print*, 'it_kin'
+ print*, it_kin
+
+ bc%kin_it = bc%kin_it +1
+ bc%v_kin_t1 = bc%v_kin_t2
+ print*, 'loading v_kin_t2'
+ !Temporal : just for snapshots file names kin_dt=0.1 , dt=0.0001
+ !snapshot(100=itime).. : itime=kin_it*(kin_dt/dt)
+ itime = bc%kin_it*nint(bc%kin_dt/bc%dt)
+ call load_vslip_snapshots(bc%dataXZ,itime,bc%nglob,iflt)
+! loading slip rates
+ bc%v_kin_t2(1,:)=bc%dataXZ%v1
+ bc%v_kin_t2(2,:)=bc%dataXZ%v2
+
+ !linear interpolation in time between t1 and t2
+ !REMARK , bc%kin_dt is the delta "t" between two snapshots.
+ t1 = (bc%kin_it-1) * bc%kin_dt
+ t2 = bc%kin_it * bc%kin_dt
+
+ endif
+
+! Kinematic velocity_rate
+! bc%slip_rate : Imposed apriori and read from slip rate snapshots (from time reversal)
+! linear interpolate between consecutive kinematic time steps.
+! slip_rate will be given each time step.
+ bc%slip_rate(1,:) = ( (t2 - time)*bc%v_kin_t1(1,:) + (time - t1)*bc%v_kin_t2(1,:) )/ bc%kin_dt
+ bc%slip_rate(2,:) = ( (t2 - time)*bc%v_kin_t1(2,:) + (time - t1)*bc%v_kin_t2(2,:) )/ bc%kin_dt
+
+!dV_free = dV_predictor + (dt/2)*dA_free
+ dV_free(1,:) = dV(1,:)+half_dt*dA(1,:)
+ dV_free(2,:) = dV(2,:)+half_dt*dA(2,:)
+ dV_free(3,:) = dV(3,:)+half_dt*dA(3,:)
+
+! T = Z*( dV_free - V_slip_rate) , V_slip_rate known apriori as input.
+! CONVENTION : T(ibulk1)=T=-T(ibulk2)
+ T(1,:) = bc%Z * ( dV_free(1,:) -bc%slip_rate(1,:) )
+ T(2,:) = bc%Z * ( dV_free(2,:) -bc%slip_rate(2,:) )
+ T(3,:) = bc%Z * ( dV_free(3,:) )
+
+! Save tractions
+ bc%T = T
+
+! Update slip in fault frame
+ bc%slip = dD
+
+! Rotate tractions back to (x,y,z) frame
+ T = rotate(bc,T,-1)
+
+! Add boundary term B*T to M*a
+ MxA(1,bc%ibulk1) = MxA(1,bc%ibulk1) + bc%B*T(1,:)
+ MxA(2,bc%ibulk1) = MxA(2,bc%ibulk1) + bc%B*T(2,:)
+ MxA(3,bc%ibulk1) = MxA(3,bc%ibulk1) + bc%B*T(3,:)
+
+ MxA(1,bc%ibulk2) = MxA(1,bc%ibulk2) - bc%B*T(1,:)
+ MxA(2,bc%ibulk2) = MxA(2,bc%ibulk2) - bc%B*T(2,:)
+ MxA(3,bc%ibulk2) = MxA(3,bc%ibulk2) - bc%B*T(3,:)
+
+!-- intermediate storage of outputs --
+ call store_dataT(bc%dataT,bc%slip,bc%slip_rate,bc%T,it)
+
+!-- OUTPUTS --
+! write dataT every NTOUT time steps or at the end of simulation
+ if ( mod(it,NTOUT) == 0 .or. it==NSTEP) call SCEC_write_dataT(bc%dataT,bc%dt,it)
+! write dataXZ every NSNAP time steps
+! if ( mod(it,NSNAP) == 0) call write_dataXZ(bc,it,iflt)
+
+
+end subroutine BC_KINFLT_set_single
+
+!===============================================================
+function get_jump(bc,v) result(dv)
+
+ type(bc_kinflt_type), intent(in) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: v(:,:)
+ real(kind=CUSTOM_REAL) :: dv(3,bc%nglob)
+
+! diference between side 2 and side 1 of fault nodes. dv
+ dv(1,:) = v(1,bc%ibulk2)-v(1,bc%ibulk1)
+ dv(2,:) = v(2,bc%ibulk2)-v(2,bc%ibulk1)
+ dv(3,:) = v(3,bc%ibulk2)-v(3,bc%ibulk1)
+
+end function get_jump
+
+!---------------------------------------------------------------------
+function get_weighted_jump(bc,f) result(da)
+
+ type(bc_kinflt_type), intent(in) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: f(:,:)
+ real(kind=CUSTOM_REAL) :: da(3,bc%nglob)
+
+! diference between side 2 and side 1 of fault nodes. M-1 * F
+ da(1,:) = bc%invM2*f(1,bc%ibulk2)-bc%invM1*f(1,bc%ibulk1)
+ da(2,:) = bc%invM2*f(2,bc%ibulk2)-bc%invM1*f(2,bc%ibulk1)
+ da(3,:) = bc%invM2*f(3,bc%ibulk2)-bc%invM1*f(3,bc%ibulk1)
+
+end function get_weighted_jump
+
+!----------------------------------------------------------------------
+function rotate(bc,v,fb) result(vr)
+
+ type(bc_kinflt_type), intent(in) :: bc
+ real(kind=CUSTOM_REAL), intent(in) :: v(3,bc%nglob)
+ integer, intent(in) :: fb
+ real(kind=CUSTOM_REAL) :: vr(3,bc%nglob)
+
+! Percy, tangential direction Vt, equation 7 of Pablo's notes in agreement with SPECFEM3D
+
+! forward rotation
+ if (fb==1) then
+ vr(1,:) = v(1,:)*bc%R(1,1,:)+v(2,:)*bc%R(1,2,:)+v(3,:)*bc%R(1,3,:) ! vs
+ vr(2,:) = v(1,:)*bc%R(2,1,:)+v(2,:)*bc%R(2,2,:)+v(3,:)*bc%R(2,3,:) ! vd
+ vr(3,:) = v(1,:)*bc%R(3,1,:)+v(2,:)*bc%R(3,2,:)+v(3,:)*bc%R(3,3,:) ! vn
+
+! backward rotation
+ else
+ vr(1,:) = v(1,:)*bc%R(1,1,:)+v(2,:)*bc%R(2,1,:)+v(3,:)*bc%R(3,1,:) !vx
+ vr(2,:) = v(1,:)*bc%R(1,2,:)+v(2,:)*bc%R(2,2,:)+v(3,:)*bc%R(3,2,:) !vy
+ vr(3,:) = v(1,:)*bc%R(1,3,:)+v(2,:)*bc%R(2,3,:)+v(3,:)*bc%R(3,3,:) !vz
+
+ endif
+
+end function rotate
+
+
+!===============================================================
+! OUTPUTS
+
+subroutine init_dataT(DataT,coord,nglob,NT,iflt)
+ ! NT = total number of time steps
+
+ integer, intent(in) :: nglob,NT,iflt
+ real(kind=CUSTOM_REAL), intent(in) :: coord(3,nglob)
+ type (dataT_type), intent(out) :: DataT
+
+ real(kind=CUSTOM_REAL) :: xtarget,ytarget,ztarget,dist,distkeep
+ integer :: i, iglob , IIN, ier, jflt, np, k
+ character(len=70) :: tmpname
+
+! 1. read fault output coordinates from user file,
+! 2. define iglob: the fault global index of the node nearest to user
+! requested coordinate
+
+ IIN = 251
+ open(IIN,file='DATA/FAULT/FAULT_STATIONS.in',status='old',action='read',iostat=ier)
+ read(IIN,*) np
+ DataT%npoin =0
+ do i=1,np
+ read(IIN,*) xtarget,ytarget,ztarget,tmpname,jflt
+ if (jflt==iflt) DataT%npoin = DataT%npoin +1
+ enddo
+ close(IIN)
+
+ if (DataT%npoin == 0) return
+
+ allocate(DataT%iglob(DataT%npoin))
+ allocate(DataT%name(DataT%npoin))
+
+ open(IIN,file='DATA/FAULT/FAULT_STATIONS.in',status='old',action='read',iostat=ier)
+ if( ier /= 0 ) stop 'error opening FAULT_STATIONS file'
+ read(IIN,*) np
+ k = 0
+ do i=1,np
+ read(IIN,*) xtarget,ytarget,ztarget,tmpname,jflt
+ if (jflt/=iflt) cycle
+ k = k+1
+ DataT%name(k) = tmpname
+ !search nearest node
+ distkeep = huge(distkeep)
+
+ do iglob=1,nglob
+ dist = sqrt((coord(1,iglob)-xtarget)**2 &
+ + (coord(2,iglob)-ytarget)**2 &
+ + (coord(3,iglob)-ztarget)**2)
+ if (dist < distkeep) then
+ distkeep = dist
+ DataT%iglob(k) = iglob
+ endif
+ enddo
+ enddo
+
+! 3. allocate arrays and set to zero
+ allocate(DataT%d1(NT,DataT%npoin))
+ allocate(DataT%v1(NT,DataT%npoin))
+ allocate(DataT%t1(NT,DataT%npoin))
+ allocate(DataT%d2(NT,DataT%npoin))
+ allocate(DataT%v2(NT,DataT%npoin))
+ allocate(DataT%t2(NT,DataT%npoin))
+ allocate(DataT%t3(NT,DataT%npoin))
+ DataT%d1 = 0e0_CUSTOM_REAL
+ DataT%v1 = 0e0_CUSTOM_REAL
+ DataT%t1 = 0e0_CUSTOM_REAL
+ DataT%d2 = 0e0_CUSTOM_REAL
+ DataT%v2 = 0e0_CUSTOM_REAL
+ DataT%t2 = 0e0_CUSTOM_REAL
+ DataT%t3 = 0e0_CUSTOM_REAL
+
+ close(IIN)
+
+end subroutine init_dataT
+
+
+!---------------------------------------------------------------
+subroutine init_dataXZ(dataXZ,nglob)
+
+ type(dataXZ_type), intent(inout) :: dataXZ
+ integer, intent(in) :: nglob
+
+ allocate(dataXZ%v1(nglob))
+ allocate(dataXZ%v2(nglob))
+ allocate(dataXZ%xcoord(nglob))
+ allocate(dataXZ%ycoord(nglob))
+ allocate(dataXZ%zcoord(nglob))
+
+ dataXZ%v1= 0e0_CUSTOM_REAL
+ dataXZ%v2= 0e0_CUSTOM_REAL
+ dataXZ%xcoord= 0e0_CUSTOM_REAL
+ dataXZ%ycoord= 0e0_CUSTOM_REAL
+ dataXZ%zcoord= 0e0_CUSTOM_REAL
+
+end subroutine init_dataXZ
+
+
+!---------------------------------------------------------------
+subroutine store_dataT(dataT,d,v,t,itime)
+
+ type(dataT_type), intent(inout) :: dataT
+ real(kind=CUSTOM_REAL), dimension(:,:), intent(in) :: d,v,t
+ integer, intent(in) :: itime
+
+ integer :: i,k
+
+ do i=1,dataT%npoin
+ k = dataT%iglob(i)
+ dataT%d1(itime,i) = d(1,k)
+ dataT%d2(itime,i) = d(2,k)
+ dataT%v1(itime,i) = v(1,k)
+ dataT%v2(itime,i) = v(2,k)
+ dataT%t1(itime,i) = t(1,k)
+ dataT%t2(itime,i) = t(2,k)
+ dataT%t3(itime,i) = t(3,k)
+ enddo
+
+end subroutine store_dataT
+
+
+!-----------------------------------------------------------------
+
+subroutine SCEC_write_dataT(dataT,DT,NT)
+
+ type(dataT_type), intent(in) :: dataT
+ real(kind=CUSTOM_REAL), intent(in) :: DT
+ integer, intent(in) :: NT
+
+ integer :: i,k,IOUT
+
+ IOUT = 121 !WARNING: not very robust. Could instead look for an available ID
+
+do i=1,dataT%npoin
+
+ open(IOUT,file='OUTPUT_FILES/'//trim(dataT%name(i))//'.dat',status='replace')
+ write(IOUT,*) "% problem=TPV5"
+ write(IOUT,*) "% author=Galvez, Ampuero, Nissen-Meyer"
+ write(IOUT,*) "% date=2010/xx/xx"
+ write(IOUT,*) "% code=SPECFEM3D_FAULT "
+ write(IOUT,*) "% code_version=1.1"
+ write(IOUT,*) "% element_size=100 m (*4 GLL nodes)"
+ write(IOUT,*) "% time_step=",DT
+ write(IOUT,*) "% num_time_steps=",NT
+ write(IOUT,*) "% location=",trim(dataT%name(i))
+ write(IOUT,*) "% Time series in 8 column of E15.7"
+ write(IOUT,*) "% Column #1 = Time (s)"
+ write(IOUT,*) "% Column #2 = horizontal right-lateral slip (m)"
+ write(IOUT,*) "% Column #3 = horizontal right-lateral slip rate (m/s)"
+ write(IOUT,*) "% Column #4 = horizontal right-lateral shear stress (MPa)"
+ write(IOUT,*) "% Column #5 = vertical up-dip slip (m)"
+ write(IOUT,*) "% Column #6 = vertical up-dip slip rate (m/s)"
+ write(IOUT,*) "% Column #7 = vertical up-dip shear stress (MPa)"
+ write(IOUT,*) "% Column #8 = normal stress (MPa)"
+ write(IOUT,*) "%"
+ write(IOUT,*) "% The line below lists the names of the data fields:"
+ write(IOUT,*) "%t h-slip h-slip-rate h-shear-stress v-slip v-slip-rate v-shear-stress n-stress"
+ write(IOUT,*) "%"
+ write(IOUT,*) "% Here is the time-series data."
+ do k=1,NT
+ write(IOUT,'(8(E15.7))') k*DT, dataT%d1(k,i), dataT%v1(k,i), dataT%t1(k,i)/1.0e6_CUSTOM_REAL, &
+ dataT%d2(k,i), dataT%v2(k,i), dataT%t2(k,i)/1.0e6_CUSTOM_REAL, &
+ dataT%t3(k,i)/1.0e6_CUSTOM_REAL
+ enddo
+ close(IOUT)
+ enddo
+
+end subroutine SCEC_write_dataT
+
+
+!---------------------------------------------------------------
+!LOAD_VSLIP_SNAPSHOTS(v,dataXZ,itime,coord,npoin,nglob,iflt)
+!Loading slip velocity from snapshots.
+! INPUT itime : iteration time
+! coord : Receivers coordinates
+! npoin : number of Receivers.
+! nglob : number of gll points along the fault.
+! dataXZ : Velocity slip_rate .
+! iflt : number of faults.
+
+! OUTPUT v : slip_rate on receivers.
+
+subroutine load_vslip_snapshots(dataXZ,itime,nglob,iflt)
+
+ integer, intent(in) :: itime,nglob,iflt
+ type(dataXZ_type), intent(inout) :: dataXZ
+ character(len=70) :: filename
+ integer :: IIN_BIN,ier,IOUT
+
+ IIN_BIN=101
+ IOUT = 102
+
+ write(filename,"('OUTPUT_FILES/Snapshot',I0,'_F',I0,'.bin')") itime,iflt
+ print*, trim(filename)
+
+ open(unit=IIN_BIN, file= trim(filename), status='old', form='formatted',&
+ action='read',iostat=ier)
+! COMPILLERS WRITE BINARY OUTPUTS IN DIFFERENT FORMATS !!!!!!!!!!
+! open(unit=IIN_BIN, file= trim(filename), status='old', form='unformatted',&
+! action='read',iostat=ier)
+! if( ier /= 0 ) stop 'Snapshots have been found'
+
+ read(IIN_BIN,"(5F24.15)") dataXZ%xcoord,dataXZ%ycoord,dataXZ%zcoord,dataXZ%v1,dataXZ%v2
+
+! read(IOUT) dataXZ%xcoord
+! read(IOUT) dataXZ%ycoord
+! read(IOUT) dataXZ%zcoord
+! write(IOUT) dataXZ%d1
+! write(IOUT) dataXZ%d2
+! read(IOUT) dataXZ%v1
+! read(IOUT) dataXZ%v2
+! write(IOUT) dataXZ%t1
+! write(IOUT) dataXZ%t2
+! write(IOUT) dataXZ%t3
+! write(IOUT) dataXZ%sta
+! write(IOUT) dataXZ%stg
+! write(IOUT) dataXZ%tRUP
+! write(IOUT) dataXZ%tPZ
+ close(IOUT)
+
+ close(IIN_BIN)
+
+end subroutine load_vslip_snapshots
+!---------------------------------------------------------------
+
+end module fault_solver_kinematic
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/finalize_simulation.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/finalize_simulation.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/finalize_simulation.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,141 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+ subroutine finalize_simulation()
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+
+ implicit none
+
+ integer :: irec_local
+
+! save last frame
+
+ if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD) then
+ open(unit=27,file=prname(1:len_trim(prname))//'save_forward_arrays.bin',&
+ status='unknown',form='unformatted')
+
+ if( ACOUSTIC_SIMULATION ) then
+ write(27) potential_acoustic
+ write(27) potential_dot_acoustic
+ write(27) potential_dot_dot_acoustic
+ endif
+
+ if( ELASTIC_SIMULATION ) then
+ write(27) displ
+ write(27) veloc
+ write(27) accel
+ endif
+
+ if (ATTENUATION) then
+ write(27) R_xx
+ write(27) R_yy
+ write(27) R_xy
+ write(27) R_xz
+ write(27) R_yz
+ write(27) epsilondev_xx
+ write(27) epsilondev_yy
+ write(27) epsilondev_xy
+ write(27) epsilondev_xz
+ write(27) epsilondev_yz
+ endif
+ close(27)
+
+! adjoint simulations
+ else if (SIMULATION_TYPE == 3) then
+
+ ! adjoint kernels
+ call save_adjoint_kernels()
+
+ endif
+
+! closing source time function file
+ if(PRINT_SOURCE_TIME_FUNCTION .and. myrank == 0) then
+ close(IOSTF)
+ endif
+
+! stacey absorbing fields will be reconstructed for adjoint simulations
+! using snapshot files of wavefields
+ if( ABSORBING_CONDITIONS ) then
+ ! closes absorbing wavefield saved/to-be-saved by forward simulations
+ if( num_abs_boundary_faces > 0 .and. (SIMULATION_TYPE == 3 .or. &
+ (SIMULATION_TYPE == 1 .and. SAVE_FORWARD)) ) then
+
+ if( ELASTIC_SIMULATION) close(IOABS)
+ if( ACOUSTIC_SIMULATION) close(IOABS_AC)
+
+ endif
+ endif
+
+! seismograms and source parameter gradients for (pure type=2) adjoint simulation runs
+ if (nrec_local > 0) then
+ if (.not. (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3)) then
+ ! seismograms
+ call write_adj_seismograms2_to_file(myrank,seismograms_eps,number_receiver_global, &
+ nrec_local,it,DT,NSTEP,t0,LOCAL_PATH)
+
+ ! source gradients (for sources in elastic domains)
+ do irec_local = 1, nrec_local
+ write(outputname,'(a,i5.5)') 'OUTPUT_FILES/src_frechet.',number_receiver_global(irec_local)
+ open(unit=27,file=trim(outputname),status='unknown')
+ !
+ ! r -> z, theta -> -y, phi -> x
+ !
+ ! Mrr = Mzz
+ ! Mtt = Myy
+ ! Mpp = Mxx
+ ! Mrt = -Myz
+ ! Mrp = Mxz
+ ! Mtp = -Mxy
+ write(27,*) Mzz_der(irec_local)
+ write(27,*) Myy_der(irec_local)
+ write(27,*) Mxx_der(irec_local)
+ write(27,*) -Myz_der(irec_local)
+ write(27,*) Mxz_der(irec_local)
+ write(27,*) -Mxy_der(irec_local)
+ write(27,*) sloc_der(1,irec_local)
+ write(27,*) sloc_der(2,irec_local)
+ write(27,*) sloc_der(3,irec_local)
+ close(27)
+ enddo
+ endif
+ endif
+
+! close the main output file
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'End of the simulation'
+ write(IMAIN,*)
+ close(IMAIN)
+ endif
+
+! synchronize all the processes to make sure everybody has finished
+ call sync_all()
+
+ end subroutine finalize_simulation
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/generate_databases.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/generate_databases.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/generate_databases.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,955 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+!
+!=============================================================================!
+! !
+! generate_databases produces a spectral element grid !
+! for a local or regional model. !
+! The mesher uses the UTM projection !
+! !
+!=============================================================================!
+!
+! If you use this code for your own research, please cite at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @ARTICLE{LiPoKoTr04,
+! author = {Qinya Liu and Jascha Polet and Dimitri Komatitsch and Jeroen Tromp},
+! title = {Spectral-element moment tensor inversions for earthquakes in {S}outhern {C}alifornia},
+! journal={Bull. Seismol. Soc. Am.},
+! year = {2004},
+! volume = {94},
+! pages = {1748-1761},
+! number = {5},
+! doi = {10.1785/012004038}}
+!
+! @INCOLLECTION{ChKoViCaVaFe07,
+! author = {Emmanuel Chaljub and Dimitri Komatitsch and Jean-Pierre Vilotte and
+! Yann Capdeville and Bernard Valette and Gaetano Festa},
+! title = {Spectral Element Analysis in Seismology},
+! booktitle = {Advances in Wave Propagation in Heterogeneous Media},
+! publisher = {Elsevier - Academic Press},
+! year = {2007},
+! editor = {Ru-Shan Wu and Val\'erie Maupin},
+! volume = {48},
+! series = {Advances in Geophysics},
+! pages = {365-419}}
+!
+! @ARTICLE{KoVi98,
+! author={D. Komatitsch and J. P. Vilotte},
+! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
+! journal={Bull. Seismol. Soc. Am.},
+! year=1998,
+! volume=88,
+! number=2,
+! pages={368-392}}
+!
+! @ARTICLE{KoTr99,
+! author={D. Komatitsch and J. Tromp},
+! year=1999,
+! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
+! journal={Geophys. J. Int.},
+! volume=139,
+! number=3,
+! pages={806-822},
+! doi={10.1046/j.1365-246x.1999.00967.x}}
+!
+! @ARTICLE{KoLiTrSuStSh04,
+! author={Dimitri Komatitsch and Qinya Liu and Jeroen Tromp and Peter S\"{u}ss
+! and Christiane Stidham and John H. Shaw},
+! year=2004,
+! title={Simulations of Ground Motion in the {L}os {A}ngeles {B}asin
+! based upon the Spectral-Element Method},
+! journal={Bull. Seism. Soc. Am.},
+! volume=94,
+! number=1,
+! pages={187-206}}
+!
+! and/or another article from http://web.univ-pau.fr/~dkomati1/publications.html
+!
+!
+! If you use the kernel capabilities of the code, please cite at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @ARTICLE{LiTr06,
+! author={Qinya Liu and Jeroen Tromp},
+! title={Finite-frequency kernels based on adjoint methods},
+! journal={Bull. Seismol. Soc. Am.},
+! year=2006,
+! volume=96,
+! number=6,
+! pages={2383-2397},
+! doi={10.1785/0120060041}}
+!
+!
+! Reference frame - convention:
+! ----------------------------
+!
+! The code uses the following convention for the reference frame:
+!
+! - X axis is East
+! - Y axis is North
+! - Z axis is up
+!
+! Note that this convention is different from both the Aki-Richards convention
+! and the Harvard CMT convention.
+!
+! Let us recall that the Aki-Richards convention is:
+!
+! - X axis is North
+! - Y axis is East
+! - Z axis is down
+!
+! and that the Harvard CMT convention is:
+!
+! - X axis is South
+! - Y axis is East
+! - Z axis is up
+!
+! To report bugs or suggest improvements to the code, please send an email
+! to Jeroen Tromp <jtromp AT princeton.edu> and/or use our online
+! bug tracking system at http://www.geodynamics.org/roundup .
+!
+! Evolution of the code:
+! ---------------------
+!
+! MPI v. 2.0 "SESAME" (Spectral ElementS on Any MEsh), Fall 2009:
+! Dimitri Komatitsch, Nicolas Le Goff, Roland Martin and Pieyre Le Loher, University of Pau, France,
+! Jeroen Tromp and the Princeton group of developers, Princeton University, USA,
+! and Emanuele Casarotti, INGV Roma, Italy:
+! support for CUBIT meshes decomposed by SCOTCH, METIS or ZOLTAN;
+! much faster solver using Michel Deville's inlined matrix products.
+!
+! MPI v. 1.4 Dimitri Komatitsch, University of Pau, Qinya Liu and others, Caltech, September 2006:
+! better adjoint and kernel calculations, faster and better I/Os
+! on very large systems, many small improvements and bug fixes
+!
+! MPI v. 1.3 Dimitri Komatitsch, University of Pau, and Qinya Liu, Caltech, July 2005:
+! serial version, regular mesh, adjoint and kernel calculations, ParaView support
+!
+! MPI v. 1.2 Min Chen and Dimitri Komatitsch, Caltech, July 2004:
+! full anisotropy, volume movie
+!
+! MPI v. 1.1 Dimitri Komatitsch, Caltech, October 2002: Zhu's Moho map, scaling
+! of Vs with depth, Hauksson's regional model, attenuation, oceans, movies
+!
+! 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
+
+! local to global indexing array
+ integer, dimension(:,:,:,:), allocatable :: ibool
+
+! arrays with the mesh in double precision
+ double precision, dimension(:,:,:,:), allocatable :: xstore,ystore,zstore
+
+! proc numbers for MPI
+ integer :: myrank,sizeprocs,ier
+
+! use integer array to store topography values
+ integer :: UTM_PROJECTION_ZONE
+ logical :: SUPPRESS_UTM_PROJECTION
+ integer :: NX_TOPO,NY_TOPO
+ double precision :: ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO
+ character(len=100) :: topo_file
+ integer, dimension(:,:), allocatable :: itopo_bathy
+
+! timer MPI
+ double precision, external :: wtime
+ double precision :: time_start,tCPU
+
+! parameters read from parameter file
+ integer :: NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,SIMULATION_TYPE
+ integer :: NSOURCES
+
+ double precision :: DT,HDUR_MOVIE
+
+ logical :: ATTENUATION,USE_OLSEN_ATTENUATION, &
+ OCEANS, SAVE_FORWARD
+ logical :: ANISOTROPY,ABSORBING_CONDITIONS,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION
+
+ logical :: MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ USE_HIGHRES_FOR_MOVIES
+ integer :: NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
+
+ character(len=256) OUTPUT_FILES,LOCAL_PATH
+
+! parameters deduced from parameters read from file
+ integer :: NPROC
+
+! static memory size that will be needed by the solver
+ double precision :: max_static_memory_size,max_static_memory_size_request
+
+! this for all the regions
+ integer NSPEC_AB,NGLOB_AB
+
+ integer NSPEC2D_BOTTOM,NSPEC2D_TOP
+
+ double precision min_elevation,max_elevation
+ double precision min_elevation_all,max_elevation_all
+
+! for Databases of external meshes
+ character(len=256) prname
+ integer :: dummy_node
+ integer :: dummy_elmnt
+ integer :: ispec, inode, num_interface,ie,imat,iface,icorner
+ integer :: nnodes_ext_mesh, nelmnts_ext_mesh
+ integer :: num_interfaces_ext_mesh
+ integer :: max_interface_size_ext_mesh
+ integer :: nmat_ext_mesh, nundefMat_ext_mesh
+ integer, dimension(:), allocatable :: my_neighbours_ext_mesh
+ integer, dimension(:), allocatable :: my_nelmnts_neighbours_ext_mesh
+ integer, dimension(:,:,:), allocatable :: my_interfaces_ext_mesh
+ integer, dimension(:,:), allocatable :: ibool_interfaces_ext_mesh
+ integer, dimension(:), allocatable :: nibool_interfaces_ext_mesh
+ double precision, dimension(:,:), allocatable :: nodes_coords_ext_mesh
+
+!!!! TAGS and ELEMENTS .
+ integer, dimension(:,:), allocatable :: elmnts_ext_mesh
+ integer, dimension(:,:), allocatable :: mat_ext_mesh
+ integer :: max_nibool_interfaces_ext_mesh
+ integer, dimension(:,:), allocatable :: ibool_interfaces_ext_mesh_dummy
+
+! boundaries and materials
+ integer :: ispec2D, boundary_number
+ integer :: nspec2D_xmin, nspec2D_xmax, nspec2D_ymin, nspec2D_ymax, nspec2D_bottom_ext, nspec2D_top_ext
+ character (len=30), dimension(:,:), allocatable :: undef_mat_prop
+ integer, dimension(:), allocatable :: ibelm_xmin,ibelm_xmax, ibelm_ymin, ibelm_ymax, ibelm_bottom, ibelm_top
+ integer, dimension(:,:), allocatable :: nodes_ibelm_xmin,nodes_ibelm_xmax, &
+ nodes_ibelm_ymin, nodes_ibelm_ymax, nodes_ibelm_bottom, nodes_ibelm_top
+ double precision, dimension(:,:), allocatable :: materials_ext_mesh
+
+! moho (optional)
+ integer :: nspec2D_moho_ext
+ integer, dimension(:), allocatable :: ibelm_moho
+ integer, dimension(:,:), allocatable :: nodes_ibelm_moho
+
+! number of points per spectral element
+ integer, parameter :: NGLLCUBE = NGLLX * NGLLY * NGLLZ
+
+ integer :: nglob,nglob_total,nspec_total
+
+ integer,dimension(:),allocatable :: ispec_is_surface_external_mesh,iglob_is_surface_external_mesh
+ integer :: nfaces_surface_ext_mesh,nfaces_surface_glob_ext_mesh
+
+ end module generate_databases_par
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine generate_databases
+
+ use generate_databases_par
+ implicit none
+
+! 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
+! and also takes care of the main output
+ call world_size(sizeprocs)
+ call world_rank(myrank)
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! open main output file, only written to by process 0
+ if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) &
+ open(unit=IMAIN,file=trim(OUTPUT_FILES)//'/output_mesher.txt',status='unknown')
+
+! get MPI starting time
+ time_start = wtime()
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '******************************************'
+ write(IMAIN,*) '*** Specfem3D MPI Mesher - f90 version ***'
+ write(IMAIN,*) '******************************************'
+ write(IMAIN,*)
+ endif
+
+! read the parameter file
+ call gd_read_parameters()
+
+! makes sure processes are synchronized
+ call sync_all()
+
+! reads topography and bathymetry file
+ call gd_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 gd_read_partition_files()
+
+! external mesh creation
+ call gd_setup_mesh()
+
+! finalize mesher
+ call gd_finalize()
+
+ end subroutine generate_databases
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine gd_read_parameters
+
+! reads and checks user input parameters
+
+ use generate_databases_par
+ implicit none
+
+! reads DATA/Par_file
+ call read_parameter_file( NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ ATTENUATION,USE_OLSEN_ATTENUATION,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,SIMULATION_TYPE,SAVE_FORWARD)
+
+! check that the code is running with the requested nb of processes
+ if(sizeprocs /= NPROC) then
+ write(IMAIN,*) 'error: number of processors supposed to run on: ',NPROC
+ write(IMAIN,*) 'error: number of processors actually run on: ',sizeprocs
+ call exit_MPI(myrank,'wrong number of MPI processes')
+ 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,
+! NPROC will be known
+
+ if(myrank == 0) then
+ write(IMAIN,*) 'This is process ',myrank
+ write(IMAIN,*) 'There are ',sizeprocs,' MPI processes'
+ write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
+ write(IMAIN,*)
+ write(IMAIN,*) 'There is a total of ',NPROC,' slices'
+ write(IMAIN,*)
+ write(IMAIN,*) 'NGLLX = ',NGLLX
+ write(IMAIN,*) 'NGLLY = ',NGLLY
+ write(IMAIN,*) 'NGLLZ = ',NGLLZ
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'Shape functions defined by NGNOD = ',NGNOD,' control nodes'
+ write(IMAIN,*) 'Surface shape functions defined by NGNOD2D = ',NGNOD2D,' control nodes'
+ write(IMAIN,*)
+ 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(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')
+
+! for the number of standard linear solids for attenuation
+ if(N_SLS /= 3) call exit_MPI(myrank,'number of SLS must be 3')
+
+ ! exclusive movie flags
+ if( EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP ) then
+ MOVIE_SURFACE = .false.
+ CREATE_SHAKEMAP = .false.
+ endif
+
+
+ if(myrank == 0) then
+! chris: I am not sure if we should suppress the following. topography should appear in the external mesh
+! leave it for now
+
+ write(IMAIN,*)
+ if(SUPPRESS_UTM_PROJECTION) then
+ write(IMAIN,*) 'suppressing UTM projection'
+ else
+ write(IMAIN,*) 'using UTM projection in region ',UTM_PROJECTION_ZONE
+ endif
+
+ write(IMAIN,*)
+ if(ATTENUATION) then
+ write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids'
+ if(USE_OLSEN_ATTENUATION) then
+ write(IMAIN,*) 'using Olsen''s attenuation'
+ else
+ write(IMAIN,*) 'not using Olsen''s attenuation'
+ endif
+ else
+ write(IMAIN,*) 'no attenuation'
+ endif
+
+ write(IMAIN,*)
+ if(ANISOTROPY) then
+ write(IMAIN,*) 'incorporating anisotropy'
+ else
+ write(IMAIN,*) 'no anisotropy'
+ endif
+
+ write(IMAIN,*)
+ if(OCEANS) then
+ write(IMAIN,*) 'incorporating the oceans using equivalent load'
+ else
+ write(IMAIN,*) 'no oceans'
+ endif
+
+ write(IMAIN,*)
+
+ endif
+
+ end subroutine gd_read_parameters
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine gd_read_topography
+
+! reads in topography files
+
+ use generate_databases_par
+ implicit none
+
+ allocate(itopo_bathy(NX_TOPO,NY_TOPO))
+
+ if(OCEANS) then
+
+! for Southern California
+ NX_TOPO = NX_TOPO_SOCAL
+ NY_TOPO = NY_TOPO_SOCAL
+ ORIG_LAT_TOPO = ORIG_LAT_TOPO_SOCAL
+ ORIG_LONG_TOPO = ORIG_LONG_TOPO_SOCAL
+ DEGREES_PER_CELL_TOPO = DEGREES_PER_CELL_TOPO_SOCAL
+ topo_file = TOPO_FILE_SOCAL
+
+ call read_topo_bathy_file(itopo_bathy,NX_TOPO,NY_TOPO,topo_file)
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'regional topography file read ranges in m from ',minval(itopo_bathy),' to ',maxval(itopo_bathy)
+ write(IMAIN,*)
+ endif
+ endif
+
+!! read basement map
+! if(BASEMENT_MAP) then
+! call get_value_string(BASEMENT_MAP_FILE,'model.BASEMENT_MAP_FILE','DATA/la_basement/reggridbase2_filtered_ascii.dat')
+! open(unit=55,file=BASEMENT_MAP_FILE,status='old',action='read')
+! do ix=1,NX_BASEMENT
+! do iy=1,NY_BASEMENT
+! read(55,*) iz_basement
+! z_basement(ix,iy) = dble(iz_basement)
+! enddo
+! enddo
+! close(55)
+! endif
+
+ end subroutine gd_read_topography
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine gd_read_partition_files
+
+! reads in proc***_Databases files
+
+ use generate_databases_par
+ implicit none
+
+ integer :: num_xmin,num_xmax,num_ymin,num_ymax,num_top,num_bottom,num
+ integer :: num_moho
+ integer :: j
+ character(len=128) :: line
+
+! 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
+ write(IMAIN,*) 'error opening file: ',prname(1:len_trim(prname))//'Database'
+ write(IMAIN,*) 'make sure file exists'
+ call exit_mpi(myrank,'error opening database file')
+ endif
+ 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)
+ enddo
+
+ call sum_all_i(nnodes_ext_mesh,num)
+ if(myrank == 0) then
+ write(IMAIN,*) ' external mesh points: ',num
+ endif
+ call sync_all()
+
+! read materials' physical properties
+ read(IIN,*) nmat_ext_mesh, nundefMat_ext_mesh
+ allocate(materials_ext_mesh(6,nmat_ext_mesh))
+ allocate(undef_mat_prop(6,nundefMat_ext_mesh))
+ do imat = 1, nmat_ext_mesh
+ ! format: #(1) rho #(2) vp #(3) vs #(4) Q_flag #(5) anisotropy_flag #(6) material_domain_id
+ read(IIN,*) materials_ext_mesh(1,imat), materials_ext_mesh(2,imat), materials_ext_mesh(3,imat), &
+ materials_ext_mesh(4,imat), materials_ext_mesh(5,imat), materials_ext_mesh(6,imat)
+
+ ! output
+ !print*,'materials:',materials_ext_mesh(1,imat), materials_ext_mesh(2,imat), materials_ext_mesh(3,imat), &
+ ! materials_ext_mesh(4,imat), materials_ext_mesh(5,imat), materials_ext_mesh(6,imat)
+ end do
+
+ if(myrank == 0) then
+ write(IMAIN,*) ' defined materials: ',nmat_ext_mesh
+ endif
+ call sync_all()
+
+ do imat = 1, nundefMat_ext_mesh
+ read(IIN,*) undef_mat_prop(1,imat),undef_mat_prop(2,imat),undef_mat_prop(3,imat),undef_mat_prop(4,imat), &
+ undef_mat_prop(5,imat), undef_mat_prop(6,imat)
+ end do
+
+ if(myrank == 0) then
+ write(IMAIN,*) ' undefined materials: ',nundefMat_ext_mesh
+ 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))
+
+ ! reads in material association for each spectral element and corner node indices
+ do ispec = 1, nelmnts_ext_mesh
+ ! format:
+ ! # ispec_local # material_index_1 # material_index_2 # corner_id1 # corner_id2 # ... # corner_id8
+ read(IIN,*) dummy_elmnt, mat_ext_mesh(1,ispec),mat_ext_mesh(2,ispec), &
+ elmnts_ext_mesh(1,ispec), elmnts_ext_mesh(2,ispec), elmnts_ext_mesh(3,ispec), elmnts_ext_mesh(4,ispec), &
+ elmnts_ext_mesh(5,ispec), elmnts_ext_mesh(6,ispec), elmnts_ext_mesh(7,ispec), elmnts_ext_mesh(8,ispec)
+ enddo
+ NSPEC_AB = nelmnts_ext_mesh
+
+ call sum_all_i(nspec_ab,num)
+ if(myrank == 0) then
+ write(IMAIN,*) ' spectral elements: ',num
+ endif
+ call sync_all()
+
+
+! read boundaries
+ read(IIN,*) boundary_number ,nspec2D_xmin
+ if(boundary_number /= 1) stop "Error : invalid database file"
+ read(IIN,*) boundary_number ,nspec2D_xmax
+ if(boundary_number /= 2) stop "Error : invalid database file"
+ read(IIN,*) boundary_number ,nspec2D_ymin
+ if(boundary_number /= 3) stop "Error : invalid database file"
+ read(IIN,*) boundary_number ,nspec2D_ymax
+ if(boundary_number /= 4) stop "Error : invalid database file"
+ read(IIN,*) boundary_number ,nspec2D_bottom_ext
+ 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"
+
+ NSPEC2D_BOTTOM = nspec2D_bottom_ext
+ NSPEC2D_TOP = nspec2D_top_ext
+
+ allocate(ibelm_xmin(nspec2D_xmin),nodes_ibelm_xmin(4,nspec2D_xmin))
+ do ispec2D = 1,nspec2D_xmin
+ read(IIN,*) ibelm_xmin(ispec2D),(nodes_ibelm_xmin(j,ispec2D),j=1,4)
+ end do
+
+ allocate(ibelm_xmax(nspec2D_xmax),nodes_ibelm_xmax(4,nspec2D_xmax))
+ do ispec2D = 1,nspec2D_xmax
+ read(IIN,*) ibelm_xmax(ispec2D),(nodes_ibelm_xmax(j,ispec2D),j=1,4)
+ end do
+
+ allocate(ibelm_ymin(nspec2D_ymin),nodes_ibelm_ymin(4,nspec2D_ymin))
+ do ispec2D = 1,nspec2D_ymin
+ read(IIN,*) ibelm_ymin(ispec2D),(nodes_ibelm_ymin(j,ispec2D),j=1,4)
+ end do
+
+ allocate(ibelm_ymax(nspec2D_ymax),nodes_ibelm_ymax(4,nspec2D_ymax))
+ do ispec2D = 1,nspec2D_ymax
+ read(IIN,*) ibelm_ymax(ispec2D),(nodes_ibelm_ymax(j,ispec2D),j=1,4)
+ end do
+
+ allocate(ibelm_bottom(nspec2D_bottom_ext),nodes_ibelm_bottom(4,nspec2D_bottom_ext))
+ do ispec2D = 1,nspec2D_bottom_ext
+ read(IIN,*) ibelm_bottom(ispec2D),(nodes_ibelm_bottom(j,ispec2D),j=1,4)
+ end do
+
+ allocate(ibelm_top(nspec2D_top_ext),nodes_ibelm_top(4,nspec2D_top_ext))
+ do ispec2D = 1,nspec2D_top_ext
+ read(IIN,*) ibelm_top(ispec2D),(nodes_ibelm_top(j,ispec2D),j=1,4)
+ end do
+
+ call sum_all_i(nspec2D_xmin,num_xmin)
+ call sum_all_i(nspec2D_xmax,num_xmax)
+ call sum_all_i(nspec2D_ymin,num_ymin)
+ call sum_all_i(nspec2D_ymax,num_ymax)
+ call sum_all_i(nspec2D_top_ext,num_top)
+ call sum_all_i(nspec2D_bottom_ext,num_bottom)
+
+ if(myrank == 0) then
+ write(IMAIN,*) ' absorbing boundaries: '
+ write(IMAIN,*) ' xmin,xmax: ',num_xmin,num_xmax
+ write(IMAIN,*) ' ymin,ymax: ',num_ymin,num_ymax
+ write(IMAIN,*) ' bottom,top: ',num_bottom,num_top
+ endif
+ call sync_all()
+
+! MPI interfaces between different partitions
+ ! format: #number_of_MPI_interfaces #maximum_number_of_elements_on_each_interface
+ read(IIN,*) num_interfaces_ext_mesh, max_interface_size_ext_mesh
+
+ ! allocates interfaces
+ allocate(my_neighbours_ext_mesh(num_interfaces_ext_mesh))
+ allocate(my_nelmnts_neighbours_ext_mesh(num_interfaces_ext_mesh))
+ allocate(my_interfaces_ext_mesh(6,max_interface_size_ext_mesh,num_interfaces_ext_mesh))
+ allocate(ibool_interfaces_ext_mesh(NGLLX*NGLLX*max_interface_size_ext_mesh,num_interfaces_ext_mesh))
+ allocate(nibool_interfaces_ext_mesh(num_interfaces_ext_mesh))
+
+ ! loops over MPI interfaces with other partitions
+ do num_interface = 1, num_interfaces_ext_mesh
+ ! format: #process_interface_id #number_of_elements_on_interface
+ ! where
+ ! process_interface_id = rank of (neighbor) process to share MPI interface with
+ ! number_of_elements_on_interface = number of interface elements
+ read(IIN,*) my_neighbours_ext_mesh(num_interface), my_nelmnts_neighbours_ext_mesh(num_interface)
+
+ ! loops over interface elements
+ do ie = 1, my_nelmnts_neighbours_ext_mesh(num_interface)
+ ! format: #(1)spectral_element_id #(2)interface_type #(3)node_id1 #(4)node_id2 #(5)...
+ !
+ ! interface types:
+ ! 1 - corner point only
+ ! 2 - element edge
+ ! 4 - element face
+ read(IIN,*) my_interfaces_ext_mesh(1,ie,num_interface), my_interfaces_ext_mesh(2,ie,num_interface), &
+ my_interfaces_ext_mesh(3,ie,num_interface), my_interfaces_ext_mesh(4,ie,num_interface), &
+ my_interfaces_ext_mesh(5,ie,num_interface), my_interfaces_ext_mesh(6,ie,num_interface)
+ enddo
+ enddo
+
+ call sum_all_i(num_interfaces_ext_mesh,num)
+ if(myrank == 0) then
+ write(IMAIN,*) ' number of MPI partition interfaces: ',num
+ endif
+ call sync_all()
+
+ ! optional moho
+ if( SAVE_MOHO_MESH ) then
+ ! checks if additional line exists
+ read(IIN,'(a128)',iostat=ier) line
+ if( ier /= 0 ) then
+ ! no moho informations given
+ nspec2D_moho_ext = 0
+ boundary_number = 7
+ else
+ ! tries to read in number of moho elements
+ read(line,*,iostat=ier) boundary_number ,nspec2D_moho_ext
+ if( ier /= 0 ) call exit_mpi(myrank,'error reading moho mesh in database')
+ endif
+ if(boundary_number /= 7) stop "Error : invalid database file"
+
+ ! checks total number of elements
+ call sum_all_i(nspec2D_moho_ext,num_moho)
+ if( num_moho == 0 ) call exit_mpi(myrank,'error no moho mesh in database')
+
+ ! reads in element informations
+ allocate(ibelm_moho(nspec2D_moho_ext),nodes_ibelm_moho(4,nspec2D_moho_ext))
+ do ispec2D = 1,nspec2D_moho_ext
+ ! format: #element_id #node_id1 #node_id2 #node_id3 #node_id4
+ read(IIN,*) ibelm_moho(ispec2D),(nodes_ibelm_moho(j,ispec2D),j=1,4)
+ end do
+
+ ! user output
+ if(myrank == 0) then
+ write(IMAIN,*) ' moho surfaces: ',num_moho
+ endif
+ call sync_all()
+ endif
+
+ close(IIN)
+
+ end subroutine gd_read_partition_files
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine gd_setup_mesh
+
+! mesh creation for static solver
+
+ use generate_databases_par
+ implicit none
+
+! assign theoretical number of elements
+ nspec = NSPEC_AB
+
+! compute maximum number of points
+ npointot = nspec * NGLLCUBE
+
+! 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)
+ if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+
+ call memory_eval_mesher(myrank,nspec,npointot,nnodes_ext_mesh,&
+ nelmnts_ext_mesh,nmat_ext_mesh,num_interfaces_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
+
+! make sure everybody is synchronized
+ call sync_all()
+
+! 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(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, &
+ num_interfaces_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, &
+ ANISOTROPY,NPROC,OCEANS, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION,NX_TOPO,NY_TOPO, &
+ ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO, &
+ itopo_bathy)
+
+
+! Moho boundary parameters, 2-D jacobians and normals
+ if( SAVE_MOHO_MESH ) then
+ call create_regions_mesh_save_moho(myrank,nglob,nspec, &
+ nspec2D_moho_ext,ibelm_moho,nodes_ibelm_moho, &
+ nodes_coords_ext_mesh,nnodes_ext_mesh,ibool )
+ endif
+
+! defines global number of nodes in model
+ NGLOB_AB = nglob
+
+! print min and max of topography included
+ min_elevation = HUGEVAL
+ max_elevation = -HUGEVAL
+ do iface = 1,nspec2D_top_ext
+ do icorner = 1,NGNOD2D
+ inode = nodes_ibelm_top(icorner,iface)
+ if (nodes_coords_ext_mesh(3,inode) < min_elevation) then
+ min_elevation = nodes_coords_ext_mesh(3,inode)
+ end if
+ if (nodes_coords_ext_mesh(3,inode) > max_elevation) then
+ max_elevation = nodes_coords_ext_mesh(3,inode)
+ end if
+ end do
+ end do
+
+! compute the maximum of the maxima for all the slices using an MPI reduction
+ call min_all_dp(min_elevation,min_elevation_all)
+ call max_all_dp(max_elevation,max_elevation_all)
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'min and max of topography included in mesh in m is ',min_elevation_all,' ',max_elevation_all
+ write(IMAIN,*)
+ endif
+
+! clean-up
+ deallocate(xstore,ystore,zstore)
+
+! make sure everybody is synchronized
+ call sync_all()
+
+ end subroutine gd_setup_mesh
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine gd_finalize
+
+! checks user input parameters
+
+ use generate_databases_par
+ implicit none
+
+ integer :: i
+
+! 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,*)
+ endif
+
+! gets number of surface elements (for movie outputs)
+ allocate( ispec_is_surface_external_mesh(NSPEC_AB), &
+ iglob_is_surface_external_mesh(NGLOB_AB),stat=ier)
+ if( ier /= 0 ) stop 'error allocating array'
+ max_nibool_interfaces_ext_mesh = maxval(nibool_interfaces_ext_mesh)
+ allocate(ibool_interfaces_ext_mesh_dummy(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier)
+ if( ier /= 0 ) stop 'error allocating array'
+ do i = 1, num_interfaces_ext_mesh
+ ibool_interfaces_ext_mesh_dummy(:,:) = ibool_interfaces_ext_mesh(1:max_nibool_interfaces_ext_mesh,:)
+ enddo
+ call sync_all()
+ call detect_surface(NPROC,NGLOB_AB,NSPEC_AB,ibool, &
+ ispec_is_surface_external_mesh, &
+ iglob_is_surface_external_mesh, &
+ nfaces_surface_ext_mesh, &
+ num_interfaces_ext_mesh, &
+ max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh, &
+ ibool_interfaces_ext_mesh_dummy )
+
+ deallocate(ibool)
+ deallocate(ispec_is_surface_external_mesh)
+ deallocate(iglob_is_surface_external_mesh)
+ deallocate(ibool_interfaces_ext_mesh_dummy)
+
+ ! takes number of faces for top, free surface only
+ if( MOVIE_SURFACE .or. CREATE_SHAKEMAP ) then
+ nfaces_surface_ext_mesh = NSPEC2D_TOP
+ endif
+
+! number of surface faces for all partitions together
+ call sum_all_i(nfaces_surface_ext_mesh,nfaces_surface_glob_ext_mesh)
+
+
+! copy number of elements and points in an include file for the solver
+ if( myrank == 0 ) then
+ call save_header_file(NSPEC_AB,NGLOB_AB,NPROC, &
+ ATTENUATION,ANISOTROPY,NSTEP,DT, &
+ SIMULATION_TYPE,max_static_memory_size,nfaces_surface_glob_ext_mesh)
+ endif
+
+! 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 gd_finalize
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_MPI.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_MPI.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_MPI.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,229 @@
+!=====================================================================
+!
+! 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 get_MPI(myrank,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, &
+ num_interfaces_ext_mesh,max_interface_size_ext_mesh, &
+ my_neighbours_ext_mesh,NPROC)
+
+! sets up the MPI interface for communication between partitions
+
+ use create_regions_mesh_ext_par
+ implicit none
+
+ integer :: myrank,nglob,nspec,NPROC
+
+! global indexing
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+! external mesh, element indexing
+ integer :: nelmnts_ext_mesh
+ integer, dimension(ESIZE,nelmnts_ext_mesh) :: elmnts_ext_mesh
+
+ integer :: num_interfaces_ext_mesh,max_interface_size_ext_mesh
+
+ integer, dimension(num_interfaces_ext_mesh) :: my_nelmnts_neighbours_ext_mesh
+ integer, dimension(6,max_interface_size_ext_mesh,num_interfaces_ext_mesh) :: my_interfaces_ext_mesh
+
+ integer, dimension(num_interfaces_ext_mesh) :: my_neighbours_ext_mesh
+
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh
+ integer, dimension(NGLLX*NGLLX*max_interface_size_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
+
+
+ !integer :: nnodes_ext_mesh
+ !double precision, dimension(NDIM,nnodes_ext_mesh) :: nodes_coords_ext_mesh
+
+!local parameters
+ double precision, dimension(:), allocatable :: xp,yp,zp
+ double precision, dimension(:), allocatable :: work_ext_mesh
+
+ integer, dimension(:), allocatable :: locval
+ integer, dimension(:), allocatable :: nibool_interfaces_ext_mesh_true
+
+ ! 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
+ logical, dimension(:), allocatable :: ifseg
+ integer :: iinterface,ilocnum
+ integer :: num_points1, num_points2
+
+ ! assembly test
+ integer :: i,j,k,ispec,iglob,count,inum
+ integer :: max_nibool_interfaces_ext_mesh
+ integer,dimension(:),allocatable :: test_flag
+ real(kind=CUSTOM_REAL), dimension(:),allocatable :: test_flag_cr
+ integer, dimension(:,:), allocatable :: ibool_interfaces_dummy
+
+! gets global indices for points on MPI interfaces (defined by my_interfaces_ext_mesh) between different partitions
+! and stores them in ibool_interfaces_ext_mesh & nibool_interfaces_ext_mesh (number of total points)
+ call prepare_assemble_MPI( nelmnts_ext_mesh,elmnts_ext_mesh, &
+ ibool,nglob,ESIZE, &
+ num_interfaces_ext_mesh, max_interface_size_ext_mesh, &
+ my_nelmnts_neighbours_ext_mesh, my_interfaces_ext_mesh, &
+ ibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh )
+
+ allocate(nibool_interfaces_ext_mesh_true(num_interfaces_ext_mesh))
+
+! sorts ibool comm buffers lexicographically for all MPI interfaces
+ num_points1 = 0
+ num_points2 = 0
+ do iinterface = 1, num_interfaces_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)))
+
+ ! gets x,y,z coordinates of global points on MPI interface
+ 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
+
+ ! sorts (lexicographically?) ibool_interfaces_ext_mesh and updates value
+ ! of total number of points nibool_interfaces_ext_mesh_true(iinterface)
+ 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)
+
+ ! checks that number of MPI points are still the same
+ num_points1 = num_points1 + nibool_interfaces_ext_mesh(iinterface)
+ num_points2 = num_points2 + nibool_interfaces_ext_mesh_true(iinterface)
+ if( num_points1 /= num_points2 ) then
+ write(*,*) 'error sorting MPI interface points:',myrank
+ write(*,*) ' interface:',iinterface,num_points1,num_points2
+ call exit_mpi(myrank,'error sorting MPI interface')
+ endif
+ !write(*,*) myrank,'intfc',iinterface,num_points2,nibool_interfaces_ext_mesh_true(iinterface)
+
+ ! cleanup temporary arrays
+ 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)
+
+ enddo
+
+ ! cleanup
+ deallocate(nibool_interfaces_ext_mesh_true)
+
+ ! outputs total number of MPI interface points
+ call sum_all_i(num_points2,ilocnum)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' total MPI interface points: ',ilocnum
+ endif
+
+! checks with assembly of test fields
+ allocate(test_flag(nglob),test_flag_cr(nglob))
+ test_flag(:) = 0
+ test_flag_cr(:) = 0._CUSTOM_REAL
+ count = 0
+ do ispec = 1, nspec
+ ! sets flags on global points
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ ! global index
+ iglob = ibool(i,j,k,ispec)
+
+ ! counts number of unique global points to set
+ if( test_flag(iglob) == 0 ) count = count+1
+
+ ! sets identifier
+ test_flag(iglob) = myrank + 1
+ test_flag_cr(iglob) = myrank + 1.0
+ enddo
+ enddo
+ enddo
+ enddo
+ call sync_all()
+
+ ! collects contributions from different MPI partitions
+ ! sets up MPI communications
+ max_nibool_interfaces_ext_mesh = maxval( nibool_interfaces_ext_mesh(:) )
+ allocate(ibool_interfaces_dummy(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+
+ count = 0
+ do iinterface = 1, num_interfaces_ext_mesh
+ ibool_interfaces_dummy(:,iinterface) = ibool_interfaces_ext_mesh(1:max_nibool_interfaces_ext_mesh,iinterface)
+ count = count + nibool_interfaces_ext_mesh(iinterface)
+ !write(*,*) myrank,'interfaces ',iinterface,nibool_interfaces_ext_mesh(iinterface),max_nibool_interfaces_ext_mesh
+ enddo
+ call sync_all()
+
+ call sum_all_i(count,iglob)
+ if( myrank == 0 ) then
+ if( iglob /= ilocnum ) call exit_mpi(myrank,'error total global MPI interface points')
+ endif
+
+ ! adds contributions from different partitions to flag arrays
+ ! integer arrays
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,nglob,test_flag, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_dummy,&
+ my_neighbours_ext_mesh)
+ ! custom_real arrays
+ call assemble_MPI_scalar_ext_mesh(NPROC,nglob,test_flag_cr, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_dummy, &
+ my_neighbours_ext_mesh)
+
+ ! checks number of interface points
+ i = 0
+ j = 0
+ do iglob=1,nglob
+ ! only counts flags with MPI contributions
+ if( test_flag(iglob) > myrank+1 ) i = i + 1
+ if( test_flag_cr(iglob) > myrank+1.0) j = j + 1
+ enddo
+ call sum_all_i(i,inum)
+ call sum_all_i(j,iglob)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' total assembled MPI interface points:',inum
+ if( inum /= iglob .or. inum > ilocnum ) call exit_mpi(myrank,'error MPI assembly')
+ endif
+
+ end subroutine get_MPI
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_MPI_cutplanes_eta.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_MPI_cutplanes_eta.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_MPI_cutplanes_eta.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,179 @@
+!=====================================================================
+!
+! 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 get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, &
+ xstore,ystore,zstore,mask_ibool,npointot, &
+ NSPEC2D_A_XI,NSPEC2D_B_XI)
+
+! this routine detects cut planes along eta
+! In principle the left cut plane of the first slice
+! and the right cut plane of the last slice are not used
+! in the solver except if we want to have periodic conditions
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank
+ integer NSPEC2D_A_XI,NSPEC2D_B_XI
+
+ logical iMPIcut_eta(2,nspec)
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! logical mask used to create arrays iboolleft_eta and iboolright_eta
+ integer npointot
+ logical mask_ibool(npointot)
+
+! global element numbering
+ integer ispec
+
+! MPI cut-plane element numbering
+ integer ispecc1,ispecc2,npoin2D_eta,ix,iy,iz
+ integer nspec2Dtheor1,nspec2Dtheor2
+
+! processor identification
+ character(len=256) prname
+
+! theoretical number of surface elements in the buffers
+! cut planes along eta=constant correspond to XI faces
+ nspec2Dtheor1 = NSPEC2D_A_XI
+ nspec2Dtheor2 = NSPEC2D_B_XI
+
+! write the MPI buffers for the left and right edges of the slice
+! and the position of the points to check that the buffers are fine
+
+!
+! determine if the element falls on the left MPI cut plane
+!
+
+! global point number and coordinates left MPI cut-plane
+ open(unit=10,file=prname(1:len_trim(prname))//'iboolleft_eta.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin2D_eta = 0
+
+! nb of elements in this cut-plane
+ ispecc1=0
+
+ do ispec=1,nspec
+ if(iMPIcut_eta(1,ispec)) then
+
+ ispecc1=ispecc1+1
+
+! loop on all the points in that 2-D element, including edges
+ iy = 1
+ do ix=1,NGLLX
+ do iz=1,NGLLZ
+
+! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_eta = npoin2D_eta + 1
+
+ write(10,*) ibool(ix,iy,iz,ispec),xstore(ix,iy,iz,ispec), &
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
+
+ enddo
+ enddo
+
+ endif
+ enddo
+
+! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+ write(10,*) npoin2D_eta
+
+ close(10)
+
+! compare number of surface elements detected to analytical value
+ if(ispecc1 /= nspec2Dtheor1 .and. ispecc1 /= nspec2Dtheor2) &
+ call exit_MPI(myrank,'error MPI cut-planes detection in eta=left')
+
+!
+! determine if the element falls on the right MPI cut plane
+!
+
+! global point number and coordinates right MPI cut-plane
+ open(unit=10,file=prname(1:len_trim(prname))//'iboolright_eta.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin2D_eta = 0
+
+! nb of elements in this cut-plane
+ ispecc2=0
+
+ do ispec=1,nspec
+ if(iMPIcut_eta(2,ispec)) then
+
+ ispecc2=ispecc2+1
+
+! loop on all the points in that 2-D element, including edges
+ iy = NGLLY
+ do ix=1,NGLLX
+ do iz=1,NGLLZ
+
+! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_eta = npoin2D_eta + 1
+
+ write(10,*) ibool(ix,iy,iz,ispec),xstore(ix,iy,iz,ispec), &
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
+
+ enddo
+ enddo
+
+ endif
+ enddo
+
+! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+ write(10,*) npoin2D_eta
+
+ close(10)
+
+! compare number of surface elements detected to analytical value
+ if(ispecc2 /= nspec2Dtheor1 .and. ispecc2 /= nspec2Dtheor2) &
+ call exit_MPI(myrank,'error MPI cut-planes detection in eta=right')
+
+ end subroutine get_MPI_cutplanes_eta
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_MPI_cutplanes_xi.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_MPI_cutplanes_xi.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_MPI_cutplanes_xi.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,178 @@
+!=====================================================================
+!
+! 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 get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, &
+ xstore,ystore,zstore,mask_ibool,npointot, &
+ NSPEC2D_A_ETA,NSPEC2D_B_ETA)
+
+! this routine detects cut planes along xi
+! In principle the left cut plane of the first slice
+! and the right cut plane of the last slice are not used
+! in the solver except if we want to have periodic conditions
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank
+ integer NSPEC2D_A_ETA,NSPEC2D_B_ETA
+
+ logical iMPIcut_xi(2,nspec)
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! logical mask used to create arrays iboolleft_xi and iboolright_xi
+ integer npointot
+ logical mask_ibool(npointot)
+
+! global element numbering
+ integer ispec
+
+! MPI cut-plane element numbering
+ integer ispecc1,ispecc2,npoin2D_xi,ix,iy,iz
+ integer nspec2Dtheor1,nspec2Dtheor2
+
+! processor identification
+ character(len=256) prname
+
+! theoretical number of surface elements in the buffers
+! cut planes along xi=constant correspond to ETA faces
+ nspec2Dtheor1 = NSPEC2D_A_ETA
+ nspec2Dtheor2 = NSPEC2D_B_ETA
+
+! write the MPI buffers for the left and right edges of the slice
+! and the position of the points to check that the buffers are fine
+
+!
+! determine if the element falls on the left MPI cut plane
+!
+
+! global point number and coordinates left MPI cut-plane
+ open(unit=10,file=prname(1:len_trim(prname))//'iboolleft_xi.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin2D_xi = 0
+
+! nb of elements in this cut-plane
+ ispecc1=0
+
+ do ispec=1,nspec
+ if(iMPIcut_xi(1,ispec)) then
+
+ ispecc1=ispecc1+1
+
+! loop on all the points in that 2-D element, including edges
+ ix = 1
+ do iy=1,NGLLY
+ do iz=1,NGLLZ
+
+! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_xi = npoin2D_xi + 1
+
+ write(10,*) ibool(ix,iy,iz,ispec),xstore(ix,iy,iz,ispec), &
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
+
+ enddo
+ enddo
+
+ endif
+ enddo
+
+! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+ write(10,*) npoin2D_xi
+
+ close(10)
+
+! compare number of surface elements detected to analytical value
+ if(ispecc1 /= nspec2Dtheor1 .and. ispecc1 /= nspec2Dtheor2) &
+ call exit_MPI(myrank,'error MPI cut-planes detection in xi=left')
+
+!
+! determine if the element falls on the right MPI cut plane
+!
+
+! global point number and coordinates right MPI cut-plane
+ open(unit=10,file=prname(1:len_trim(prname))//'iboolright_xi.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! nb of global points shared with the other slice
+ npoin2D_xi = 0
+
+! nb of elements in this cut-plane
+ ispecc2=0
+
+ do ispec=1,nspec
+ if(iMPIcut_xi(2,ispec)) then
+
+ ispecc2=ispecc2+1
+
+! loop on all the points in that 2-D element, including edges
+ ix = NGLLX
+ do iy=1,NGLLY
+ do iz=1,NGLLZ
+
+! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_xi = npoin2D_xi + 1
+
+ write(10,*) ibool(ix,iy,iz,ispec),xstore(ix,iy,iz,ispec), &
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
+
+ enddo
+ enddo
+
+ endif
+ enddo
+
+! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+
+! write total number of points
+ write(10,*) npoin2D_xi
+
+ close(10)
+
+! compare number of surface elements detected to analytical value
+ if(ispecc2 /= nspec2Dtheor1 .and. ispecc2 /= nspec2Dtheor2) &
+ call exit_MPI(myrank,'error MPI cut-planes detection in xi=right')
+
+ end subroutine get_MPI_cutplanes_xi
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_absorb.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_absorb.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_absorb.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,270 @@
+!=====================================================================
+!
+! 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 get_absorb(myrank,prname,iboun,nspec, &
+ nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM)
+
+! put Stacey back, here define overlap flags
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank
+
+ integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM
+
+ integer nimin(2,NSPEC2DMAX_YMIN_YMAX),nimax(2,NSPEC2DMAX_YMIN_YMAX)
+ integer njmin(2,NSPEC2DMAX_XMIN_XMAX),njmax(2,NSPEC2DMAX_XMIN_XMAX)
+ integer nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX),nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX)
+
+ logical iboun(6,nspec)
+
+! global element numbering
+ integer ispecg
+
+! counters to keep track of the number of elements on each of the
+! five absorbing boundaries
+ integer ispecb1,ispecb2,ispecb3,ispecb4,ispecb5
+
+! processor identification
+ character(len=256) prname
+
+ ispecb1=0
+ ispecb2=0
+ ispecb3=0
+ ispecb4=0
+ ispecb5=0
+
+ do ispecg=1,nspec
+
+! determine if the element falls on an absorbing boundary
+
+ if(iboun(1,ispecg)) then
+
+! on boundary 1: xmin
+ ispecb1=ispecb1+1
+
+! this is useful even if it is constant because it can be zero inside the slices
+ njmin(1,ispecb1)=1
+ njmax(1,ispecb1)=NGLLY
+
+! check for ovelap with other boundaries
+ nkmin_xi(1,ispecb1)=1
+ if(iboun(5,ispecg)) nkmin_xi(1,ispecb1)=2
+ endif
+
+ if(iboun(2,ispecg)) then
+
+! on boundary 2: xmax
+ ispecb2=ispecb2+1
+
+! this is useful even if it is constant because it can be zero inside the slices
+ njmin(2,ispecb2)=1
+ njmax(2,ispecb2)=NGLLY
+
+! check for ovelap with other boundaries
+ nkmin_xi(2,ispecb2)=1
+ if(iboun(5,ispecg)) nkmin_xi(2,ispecb2)=2
+ endif
+
+ if(iboun(3,ispecg)) then
+
+! on boundary 3: ymin
+ ispecb3=ispecb3+1
+
+! check for ovelap with other boundaries
+ nimin(1,ispecb3)=1
+ if(iboun(1,ispecg)) nimin(1,ispecb3)=2
+ nimax(1,ispecb3)=NGLLX
+ if(iboun(2,ispecg)) nimax(1,ispecb3)=NGLLX-1
+ nkmin_eta(1,ispecb3)=1
+ if(iboun(5,ispecg)) nkmin_eta(1,ispecb3)=2
+ endif
+
+ if(iboun(4,ispecg)) then
+
+! on boundary 4: ymax
+ ispecb4=ispecb4+1
+
+! check for ovelap with other boundaries
+ nimin(2,ispecb4)=1
+ if(iboun(1,ispecg)) nimin(2,ispecb4)=2
+ nimax(2,ispecb4)=NGLLX
+ if(iboun(2,ispecg)) nimax(2,ispecb4)=NGLLX-1
+ nkmin_eta(2,ispecb4)=1
+ if(iboun(5,ispecg)) nkmin_eta(2,ispecb4)=2
+ endif
+
+! on boundary 5: bottom
+ if(iboun(5,ispecg)) ispecb5=ispecb5+1
+
+ enddo
+
+! check theoretical value of elements at the bottom
+ if(ispecb5 /= NSPEC2D_BOTTOM) &
+ call exit_MPI(myrank,'ispecb5 should equal NSPEC2D_BOTTOM in absorbing boundary detection')
+
+! IMPROVE save these temporary arrays for the solver for Stacey conditions
+
+ open(unit=27,file=prname(1:len_trim(prname))//'nimin.bin',status='unknown',form='unformatted')
+ write(27) nimin
+ close(27)
+
+ open(unit=27,file=prname(1:len_trim(prname))//'nimax.bin',status='unknown',form='unformatted')
+ write(27) nimax
+ close(27)
+
+ open(unit=27,file=prname(1:len_trim(prname))//'njmin.bin',status='unknown',form='unformatted')
+ write(27) njmin
+ close(27)
+
+ open(unit=27,file=prname(1:len_trim(prname))//'njmax.bin',status='unknown',form='unformatted')
+ write(27) njmax
+ close(27)
+
+ open(unit=27,file=prname(1:len_trim(prname))//'nkmin_xi.bin',status='unknown',form='unformatted')
+ write(27) nkmin_xi
+ close(27)
+
+ open(unit=27,file=prname(1:len_trim(prname))//'nkmin_eta.bin',status='unknown',form='unformatted')
+ write(27) nkmin_eta
+ close(27)
+
+ 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)
+
+! put Stacey back, here define overlap flags
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank
+
+ integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM
+
+ integer nimin(2,NSPEC2DMAX_YMIN_YMAX),nimax(2,NSPEC2DMAX_YMIN_YMAX)
+ integer njmin(2,NSPEC2DMAX_XMIN_XMAX),njmax(2,NSPEC2DMAX_XMIN_XMAX)
+ integer nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX),nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX)
+
+ logical iboun(6,nspec)
+
+! global element numbering
+ integer ispecg
+
+! counters to keep track of the number of elements on each of the
+! five absorbing boundaries
+ integer ispecb1,ispecb2,ispecb3,ispecb4,ispecb5
+
+ ispecb1=0
+ ispecb2=0
+ ispecb3=0
+ ispecb4=0
+ ispecb5=0
+
+ do ispecg=1,nspec
+
+! determine if the element falls on an absorbing boundary
+
+ if(iboun(1,ispecg)) then
+
+! on boundary 1: xmin
+ ispecb1=ispecb1+1
+
+! this is useful even if it is constant because it can be zero inside the slices
+ njmin(1,ispecb1)=1
+ njmax(1,ispecb1)=NGLLY
+
+! check for ovelap with other boundaries
+ nkmin_xi(1,ispecb1)=1
+ if(iboun(5,ispecg)) nkmin_xi(1,ispecb1)=2
+ endif
+
+ if(iboun(2,ispecg)) then
+
+! on boundary 2: xmax
+ ispecb2=ispecb2+1
+
+! this is useful even if it is constant because it can be zero inside the slices
+ njmin(2,ispecb2)=1
+ njmax(2,ispecb2)=NGLLY
+
+! check for ovelap with other boundaries
+ nkmin_xi(2,ispecb2)=1
+ if(iboun(5,ispecg)) nkmin_xi(2,ispecb2)=2
+ endif
+
+ if(iboun(3,ispecg)) then
+
+! on boundary 3: ymin
+ ispecb3=ispecb3+1
+
+! check for ovelap with other boundaries
+ nimin(1,ispecb3)=1
+ if(iboun(1,ispecg)) nimin(1,ispecb3)=2
+ nimax(1,ispecb3)=NGLLX
+ if(iboun(2,ispecg)) nimax(1,ispecb3)=NGLLX-1
+ nkmin_eta(1,ispecb3)=1
+ if(iboun(5,ispecg)) nkmin_eta(1,ispecb3)=2
+ endif
+
+ if(iboun(4,ispecg)) then
+
+! on boundary 4: ymax
+ ispecb4=ispecb4+1
+
+! check for ovelap with other boundaries
+ nimin(2,ispecb4)=1
+ if(iboun(1,ispecg)) nimin(2,ispecb4)=2
+ nimax(2,ispecb4)=NGLLX
+ if(iboun(2,ispecg)) nimax(2,ispecb4)=NGLLX-1
+ nkmin_eta(2,ispecb4)=1
+ if(iboun(5,ispecg)) nkmin_eta(2,ispecb4)=2
+ endif
+
+! on boundary 5: bottom
+ if(iboun(5,ispecg)) ispecb5=ispecb5+1
+
+ enddo
+
+! check theoretical value of elements at the bottom
+ if(ispecb5 /= NSPEC2D_BOTTOM) &
+ call exit_MPI(myrank,'ispecb5 should equal NSPEC2D_BOTTOM in absorbing boundary detection')
+
+ end subroutine get_absorb_ext_mesh
+
+
+
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_absorbing_boundary.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_absorbing_boundary.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_absorbing_boundary.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,498 @@
+!=====================================================================
+!
+! 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 get_absorbing_boundary(myrank,nspec,nglob,ibool, &
+ nodes_coords_ext_mesh,nnodes_ext_mesh, &
+ 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)
+
+! determines absorbing boundaries/free-surface, 2D jacobians, face normals for Stacey conditions
+
+ use create_regions_mesh_ext_par
+ implicit none
+
+! number of spectral elements in each block
+ integer :: myrank,nspec,nglob
+
+! arrays with the mesh
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+! data from the external mesh
+ integer :: nnodes_ext_mesh
+ double precision, dimension(NDIM,nnodes_ext_mesh) :: nodes_coords_ext_mesh
+
+! absorbing boundaries (as defined in CUBIT)
+ 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
+
+ ! 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
+
+! local parameters
+ logical, dimension(:,:),allocatable :: iboun ! pll
+
+ ! (assumes NGLLX=NGLLY=NGLLZ)
+ real(kind=CUSTOM_REAL) :: jacobian2Dw_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,igllfree,ifree
+
+! 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.
+
+! 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)
+
+ iboun(iface,ispec) = .true.
+
+ ! 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,jacobian2Dw_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
+
+ ! sets face infos
+ iabs = iabs + 1
+ abs_boundary_ispec(iabs) = ispec
+
+ ! gll points -- assuming NGLLX = NGLLY = NGLLZ
+ igll = 0
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ igll = igll+1
+ abs_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ abs_boundary_jacobian2Dw(igll,iabs) = jacobian2Dw_face(i,j)
+ abs_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
+ enddo
+ enddo
+
+ 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,jacobian2Dw_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
+
+ ! sets face infos
+ iabs = iabs + 1
+ abs_boundary_ispec(iabs) = ispec
+
+ ! gll points -- assuming NGLLX = NGLLY = NGLLZ
+ igll = 0
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ igll = igll+1
+ abs_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ abs_boundary_jacobian2Dw(igll,iabs) = jacobian2Dw_face(i,j)
+ abs_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,jacobian2Dw_face,normal_face,NGLLY,NGLLZ)
+
+ ! 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
+
+ ! sets face infos
+ iabs = iabs + 1
+ abs_boundary_ispec(iabs) = ispec
+
+ ! gll points -- assuming NGLLX = NGLLY = NGLLZ
+ igll = 0
+ do j=1,NGLLZ
+ do i=1,NGLLY
+ igll = igll+1
+ abs_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ abs_boundary_jacobian2Dw(igll,iabs) = jacobian2Dw_face(i,j)
+ abs_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
+ enddo
+ enddo
+
+ enddo
+
+ ! 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)
+
+ ! 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,jacobian2Dw_face,normal_face,NGLLY,NGLLZ)
+
+ ! 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
+
+ ! sets face infos
+ iabs = iabs + 1
+ abs_boundary_ispec(iabs) = ispec
+
+ ! gll points -- assuming NGLLX = NGLLY = NGLLZ
+ igll = 0
+ do j=1,NGLLY
+ do i=1,NGLLX
+ igll = igll+1
+ abs_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ abs_boundary_jacobian2Dw(igll,iabs) = jacobian2Dw_face(i,j)
+ abs_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,jacobian2Dw_face,normal_face,NGLLX,NGLLY)
+
+ ! 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
+
+ ! sets face infos
+ iabs = iabs + 1
+ abs_boundary_ispec(iabs) = ispec
+
+ ! gll points -- assuming NGLLX = NGLLY = NGLLZ
+ igll = 0
+ do j=1,NGLLY
+ do i=1,NGLLX
+ igll = igll+1
+ abs_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ abs_boundary_jacobian2Dw(igll,iabs) = jacobian2Dw_face(i,j)
+ abs_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
+ enddo
+ enddo
+
+ enddo
+
+ ! top
+ ! free surface face counter
+ ifree = 0
+ 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)
+
+ ! 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,jacobian2Dw_face,normal_face,NGLLX,NGLLY)
+
+ ! 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
+
+ ! stores surface infos
+ if( .not. ABSORB_FREE_SURFACE ) then
+ ! store for free surface
+ !jacobian2D_top(:,:,ispec2D) = jacobian2Dw_face(:,:)
+ !normal_top(:,:,:,ispec2D) = normal_face(:,:,:)
+
+ ! sets face infos
+ ifree = ifree + 1
+ free_surface_ispec(ifree) = ispec
+
+ ! gll points -- assuming NGLLX = NGLLY = NGLLZ
+ igllfree = 0
+ do j=1,NGLLY
+ do i=1,NGLLX
+ igllfree = igllfree+1
+ free_surface_ijk(:,igllfree,ifree) = ijk_face(:,i,j)
+ free_surface_jacobian2Dw(igllfree,ifree) = jacobian2Dw_face(i,j)
+ free_surface_normal(:,igllfree,ifree) = normal_face(:,i,j)
+ enddo
+ enddo
+ else
+ ! adds face infos to absorbing boundary surface
+ iabs = iabs + 1
+ abs_boundary_ispec(iabs) = ispec
+
+ ! gll points -- assuming NGLLX = NGLLY = NGLLZ
+ igll = 0
+ do j=1,NGLLY
+ do i=1,NGLLX
+ igll = igll+1
+ abs_boundary_ijk(:,igll,iabs) = ijk_face(:,i,j)
+ abs_boundary_jacobian2Dw(igll,iabs) = jacobian2Dw_face(i,j)
+ abs_boundary_normal(:,igll,iabs) = normal_face(:,i,j)
+ enddo
+ enddo
+
+ ! resets free surface
+ ifree = 1
+ free_surface_ispec(:) = 0
+ free_surface_ijk(:,:,:) = 0
+ free_surface_jacobian2Dw(:,:) = 0.0
+ free_surface_normal(:,:,:) = 0.0
+ endif
+ enddo
+
+! checks counters
+ if( ifree /= num_free_surface_faces ) then
+ print*,'error number of free surface faces:',ifree,num_free_surface_faces
+ stop 'error number of free surface faces'
+ endif
+
+ if( iabs /= num_abs_boundary_faces ) then
+ print*,'error number of absorbing faces:',iabs,num_abs_boundary_faces
+ stop 'error number of absorbing faces'
+ endif
+
+ call sum_all_i(num_abs_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
+
+ end subroutine get_absorbing_boundary
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_attenuation_model.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_attenuation_model.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_attenuation_model.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,278 @@
+!=====================================================================
+!
+! 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 get_attenuation_model(myrank,iattenuation, &
+ tau_mu,tau_sigma,beta,one_minus_sum_beta,factor_scale)
+
+! return attenuation mechanisms Q_mu using standard linear solids
+! frequency range: 20.000000 -- 1000.000000 mHz
+! period range: 1.000000 -- 50.000000 s
+! central logarithmic frequency: 0.141421 Hz
+! the Tau values computed by Jeroen's code are used
+! number of relaxation mechanisms: 3
+
+! in the future when more memory is available on computers
+! it would be more accurate to use four mechanisms instead of three
+
+ implicit none
+
+ include "constants.h"
+
+! define central frequency of source in seconds using values from Jeroen's code
+! logarithmic mean of frequency interval
+ double precision, parameter :: f_c_source = 0.141421d0
+
+! reference frequency for target velocity values in velocity model
+! arbitrarily set to typical resolution of model (3 sec)
+ double precision, parameter :: f0_REFERENCE = 0.3d0
+
+ integer iattenuation,myrank
+
+ double precision, dimension(N_SLS) :: tau_mu,tau_sigma,beta
+ double precision one_minus_sum_beta
+
+ integer i
+
+ double precision Q_mu,w_c_source
+ double precision factor_scale_mu0,factor_scale_mu,factor_scale
+ double precision a_val,b_val,big_omega
+
+! check number of SLS is okay
+ if(N_SLS /= 3) call exit_MPI(myrank,'wrong number of SLS for attenuation, must be 3')
+
+! clear arrays
+ tau_mu(:) = 0.d0
+ tau_sigma(:) = 0.d0
+
+! tau sigma evenly spaced in log frequency, does not depend on value of Q
+ tau_sigma( 1) = 7.957747154594766669788441504352d0
+ tau_sigma( 2) = 1.125395395196382652969191440206d0
+ tau_sigma( 3) = 0.159154943091895345608222100964d0
+
+! determine in which region we are based upon doubling flag
+
+ select case(iattenuation)
+
+!--- sediments
+
+! select value needed here, from Q_mu = 40 to Q_mu = 150
+
+ case(IATTENUATION_SEDIMENTS_40)
+
+ Q_mu = 40.000000d0
+ tau_mu( 1) = 8.207413221956890936326090013608d0
+ tau_mu( 2) = 1.161729745747647424281012717984d0
+ tau_mu( 3) = 0.165834182312059152941685624683d0
+
+ case(IATTENUATION_SEDIMENTS_50)
+
+ Q_mu = 50.000000d0
+ tau_mu( 1) = 8.169307711419302009403509146068d0
+ tau_mu( 2) = 1.153839195800796080249028818798d0
+ tau_mu( 3) = 0.164437605011117371489604011003d0
+
+ case(IATTENUATION_SEDIMENTS_60)
+
+ Q_mu = 60.000000d0
+ tau_mu( 1) = 8.140254475505114939437589782756d0
+ tau_mu( 2) = 1.148759228190431747052002720011d0
+ tau_mu( 3) = 0.163522774234807849458306350243d0
+
+ case(IATTENUATION_SEDIMENTS_70)
+
+ Q_mu = 70.000000d0
+ tau_mu( 1) = 8.117833196570874321196242817678d0
+ tau_mu( 2) = 1.145216760190841176481058028003d0
+ tau_mu( 3) = 0.162877472647593862786763452277d0
+
+ case(IATTENUATION_SEDIMENTS_80)
+
+ Q_mu = 80.000000d0
+ tau_mu( 1) = 8.100148465407393416626291582361d0
+ tau_mu( 2) = 1.142606124533341649396334105404d0
+ tau_mu( 3) = 0.162398031255151509277823151933d0
+
+ case(IATTENUATION_SEDIMENTS_90)
+
+ Q_mu = 90.000000d0
+ tau_mu( 1) = 8.085897732468197318667080253363d0
+ tau_mu( 2) = 1.140602642076625095057806902332d0
+ tau_mu( 3) = 0.162027854074084459723437134926d0
+
+ case(IATTENUATION_SEDIMENTS_100)
+
+ Q_mu = 100.000000d0
+ tau_mu( 1) = 8.074193745349216300155603676103d0
+ tau_mu( 2) = 1.139016691991711960341149278975d0
+ tau_mu( 3) = 0.161733443689579814428469717313d0
+
+ case(IATTENUATION_SEDIMENTS_110)
+
+ Q_mu = 110.000000d0
+ tau_mu( 1) = 8.064421863800781409281626110896d0
+ tau_mu( 2) = 1.137730132230029722606445830024d0
+ tau_mu( 3) = 0.161493715940844051459635011270d0
+
+ case(IATTENUATION_SEDIMENTS_120)
+
+ Q_mu = 120.000000d0
+ tau_mu( 1) = 8.056146565814696458573962445371d0
+ tau_mu( 2) = 1.136665532765689157201904890826d0
+ tau_mu( 3) = 0.161294740739552050490246415393d0
+
+ case(IATTENUATION_SEDIMENTS_130)
+
+ Q_mu = 130.000000d0
+ tau_mu( 1) = 8.049052148467024991873586259317d0
+ tau_mu( 2) = 1.135770035674695810357093250786d0
+ tau_mu( 3) = 0.161126946571733903335044146843d0
+
+ case(IATTENUATION_SEDIMENTS_140)
+
+ Q_mu = 140.000000d0
+ tau_mu( 1) = 8.042904857756342451580167107750d0
+ tau_mu( 2) = 1.135006327178704310654211440124d0
+ tau_mu( 3) = 0.160983540254336005004276444197d0
+
+ case(IATTENUATION_SEDIMENTS_150)
+
+ Q_mu = 150.000000d0
+ tau_mu( 1) = 8.037528252037535736462814384140d0
+ tau_mu( 2) = 1.134347316535732730358176922891d0
+ tau_mu( 3) = 0.160859567464536307168643247678d0
+
+!--- bedrock
+
+ case(IATTENUATION_BEDROCK)
+
+ tau_mu( 1) = 7.959142154402283786396310460987d0
+ tau_mu( 2) = 1.125540477911388892451327592426d0
+ tau_mu( 3) = 0.159182872336587483141912002793d0
+
+ Q_mu = 9000.d0
+
+ case default
+
+ call exit_MPI(myrank,'wrong attenuation flag in mesh')
+
+ end select
+
+!--- compute beta
+ beta(:) = 1.d0 - tau_mu(:) / tau_sigma(:)
+
+!--- compute central angular frequency of source
+ w_c_source = TWO_PI * f_c_source
+
+!--- quantity by which to scale mu_0 to get mu
+ factor_scale_mu0 = ONE + TWO * log(f_c_source / f0_REFERENCE) / (PI * Q_mu)
+
+!--- compute a, b and Omega parameters, also compute one minus sum of betas
+ a_val = ONE
+ b_val = ZERO
+ one_minus_sum_beta = ONE
+
+ do i = 1,N_SLS
+ a_val = a_val - w_c_source * w_c_source * tau_mu(i) * &
+ (tau_mu(i) - tau_sigma(i)) / (1.d0 + w_c_source * w_c_source * tau_mu(i) * tau_mu(i))
+ b_val = b_val + w_c_source * (tau_mu(i) - tau_sigma(i)) / &
+ (1.d0 + w_c_source * w_c_source * tau_mu(i) * tau_mu(i))
+ one_minus_sum_beta = one_minus_sum_beta - beta(i)
+ enddo
+
+ big_omega = a_val*(sqrt(1.d0 + b_val*b_val/(a_val*a_val))-1.d0)
+
+!--- quantity by which to scale mu to get mu_relaxed
+ factor_scale_mu = b_val * b_val / (TWO * big_omega)
+
+!--- total factor by which to scale mu0
+ factor_scale = factor_scale_mu * factor_scale_mu0
+
+!--- check that the correction factor is close to one
+ if(factor_scale < 0.9 .or. factor_scale > 1.1) &
+ call exit_MPI(myrank,'incorrect correction factor in attenuation model')
+
+ end subroutine get_attenuation_model
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine get_attenuation_model_olsen( vs_val, iselected )
+
+! uses scaling rule similar to Olsen et al. (2003) to determine attenuation medium
+!
+! returns: selected sediment iselected
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL) :: vs_val
+ integer :: iselected
+
+!local parameters
+ real(kind=CUSTOM_REAL) :: Q_mu
+ integer :: int_Q_mu,iattenuation_sediments
+
+ ! use rule Q_mu = constant * v_s
+ Q_mu = OLSEN_ATTENUATION_RATIO * vs_val
+ int_Q_mu = 10 * nint(Q_mu / 10.)
+
+ if(int_Q_mu < 40) int_Q_mu = 40
+ if(int_Q_mu > 150) int_Q_mu = 150
+
+ if(int_Q_mu == 40) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_40
+ else if(int_Q_mu == 50) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_50
+ else if(int_Q_mu == 60) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_60
+ else if(int_Q_mu == 70) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_70
+ else if(int_Q_mu == 80) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_80
+ else if(int_Q_mu == 90) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_90
+ else if(int_Q_mu == 100) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_100
+ else if(int_Q_mu == 110) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_110
+ else if(int_Q_mu == 120) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_120
+ else if(int_Q_mu == 130) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_130
+ else if(int_Q_mu == 140) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_140
+ else if(int_Q_mu == 150) then
+ iattenuation_sediments = IATTENUATION_SEDIMENTS_150
+ else
+ stop 'incorrect attenuation coefficient'
+ endif
+
+ ! return sediment number
+ iselected = iattenuation_sediments
+
+ end subroutine get_attenuation_model_olsen
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_cmt.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_cmt.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_cmt.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,159 @@
+!=====================================================================
+!
+! 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 get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,NSOURCES)
+
+ implicit none
+
+ include "constants.h"
+
+ integer yr,jda,ho,mi,NSOURCES
+ double precision sec
+ double precision, dimension(NSOURCES) :: t_cmt,hdur,lat,long,depth
+ double precision moment_tensor(6,NSOURCES)
+
+ integer mo,da,julian_day,isource
+ character(len=5) datasource
+ character(len=256) string, CMTSOLUTION
+
+!
+!---- read hypocenter info
+!
+ call get_value_string(CMTSOLUTION, 'solver.CMTSOLUTION', 'DATA/CMTSOLUTION')
+ open(unit=1,file=CMTSOLUTION,status='old',action='read')
+
+! read source number isource
+ do isource=1,NSOURCES
+
+ read(1,"(a256)") string
+ ! skips empty lines
+ do while( len_trim(string) == 0 )
+ read(1,"(a256)") string
+ enddo
+
+ ! read header with event information
+ read(string,"(a4,i5,i3,i3,i3,i3,f6.2)") datasource,yr,mo,da,ho,mi,sec
+ jda=julian_day(yr,mo,da)
+
+ ! ignore line with event name
+ read(1,"(a)") string
+
+ ! read time shift
+ read(1,"(a)") string
+ read(string(12:len_trim(string)),*) t_cmt(isource)
+
+ ! read half duration
+ read(1,"(a)") string
+ read(string(15:len_trim(string)),*) hdur(isource)
+
+ ! read latitude
+ read(1,"(a)") string
+ read(string(10:len_trim(string)),*) lat(isource)
+
+ ! read longitude
+ read(1,"(a)") string
+ read(string(11:len_trim(string)),*) long(isource)
+
+ ! read depth
+ read(1,"(a)") string
+ read(string(7:len_trim(string)),*) depth(isource)
+
+ ! read Mrr
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(1,isource)
+
+ ! read Mtt
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(2,isource)
+
+ ! read Mpp
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(3,isource)
+
+ ! read Mrt
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(4,isource)
+
+ ! read Mrp
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(5,isource)
+
+ ! read Mtp
+ read(1,"(a)") string
+ read(string(5:len_trim(string)),*) moment_tensor(6,isource)
+
+ enddo
+
+ close(1)
+
+ !
+ ! scale the moment tensor
+ ! CMTSOLUTION file values are in dyne.cm
+ ! 1 dyne is 1 gram * 1 cm / (1 second)^2
+ ! 1 Newton is 1 kg * 1 m / (1 second)^2
+ ! thus 1 Newton = 100,000 dynes
+ ! therefore 1 dyne.cm = 1e-7 Newton.m
+ !
+ moment_tensor(:,:) = moment_tensor(:,:) * 1.d-7
+
+ end subroutine get_cmt
+
+! ------------------------------------------------------------------
+
+ integer function julian_day(yr,mo,da)
+
+ implicit none
+
+ integer yr,mo,da
+
+ integer mon(12)
+ integer lpyr
+ data mon /0,31,59,90,120,151,181,212,243,273,304,334/
+
+ julian_day = da + mon(mo)
+ if(mo>2) julian_day = julian_day + lpyr(yr)
+
+ end function julian_day
+
+! ------------------------------------------------------------------
+
+ integer function lpyr(yr)
+
+ implicit none
+
+ integer yr
+!
+!---- returns 1 if leap year
+!
+ lpyr=0
+ if(mod(yr,400) == 0) then
+ lpyr=1
+ else if(mod(yr,4) == 0) then
+ lpyr=1
+ if(mod(yr,100) == 0) lpyr=0
+ endif
+
+ end function lpyr
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_coupling_domain1_domain2.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_coupling_domain1_domain2.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_coupling_domain1_domain2.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,408 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+module coupling
+
+ implicit none
+ type (coupling_type)
+ private
+ double precision, dimension(:,:) :: jacobian2Dw
+ double precision, dimension(:,:,:) :: normal,ijk
+
+ integer :: tag1,tag2,num_faces,NbFaults
+ integer, dimension(:) :: ispec
+ end type coupling_type
+ type (coupling_type),pointer :: fault_db(:)
+ public :: get_coupling_surfaces_domain2_domain1
+
+contains
+
+!=====================================================================
+subroutine read_parameters_fault
+
+ implicit none
+
+! open Par_file_fault
+ open(unit=100,file='~/SPECFEM3D_FAULT/DATA/Par_file_faults.in')
+! if file does not exist: NbFaults=0
+
+ read(*,*) fault_db%NbFaults
+! if already allocated (associated), deallocate
+ allocate(fault_db%NbFaults)
+ do i=1,fault_db%NbFaults
+ read(*,*) fault_db(i)%tag1,fault_db(i)%tag2
+ enddo
+
+! close Par_file_fault
+ close(100)
+
+
+end subroutine read_parameters_fault
+
+!=====================================================================
+
+
+
+!=====================================================================
+! BEGIN INPUT BLOCK
+
+! inputs:
+! myrank: processor index
+! domain_1tag and domain_2tag : tags created by cubit specifying different domain.
+! nspec : number of spectral elements in each block.
+! nglob : number of gobal nodes in each block.
+! ibool : local to global numbering table, iglob = ibool(i,j,k,ispec)
+
+! do inum = 1,coupling%num_faces
+! coupling%normal(:,:,inum) = tmp_normal(:,:,inum)
+! coupling%jacobian2Dw(:,inum) = tmp_jacobian2Dw(:,inum)
+! coupling%ijk(:,:,inum) = tmp_ijk(:,:,inum)
+! coupling%ispec(inum) = tmp_ispec(inum)
+!
+! INPUTS for MPI comunications
+! NPROC : number of processors.
+! nibool_interfaces_ext_mesh:
+! ibool_interfaces_ext_mesh:
+! num_interfaces_ext_mesh :
+! max_interface_size_ext_mesh:
+! my_neighbours_ext_mesh:
+
+!
+! OUTPUTS:
+! coupling: fault structure (database)
+
+
+! determines coupling surface for domain2-domain1 domains
+
+subroutine get_coupling_surfaces_domain2_domain1(myrank, &
+ coupling,domain1_flag,domain2_flag, &
+ nspec,nglob,ibool,NPROC, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ num_interfaces_ext_mesh,max_interface_size_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+
+ use generate_databases_par, only:mat_ext_mesh,elmnts_ext_mesh ! mat_ext_mesh , elemnts_ext_mesh
+ use create_regions_mesh_ext_par
+
+ type(coupling_type), intent(inout) ::coupling
+ integer, dimension(:), allocatable :: domain1_flag,domain2_flag
+
+
+! domain1_flag=fault_db%tag1
+! domain2_flag=fault_db%tag2
+
+
+! number of spectral elements in each block
+ integer :: myrank,nspec,nglob,NPROC
+
+! arrays with the mesh
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+! MPI communication
+ integer :: num_interfaces_ext_mesh,max_interface_size_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: my_neighbours_ext_mesh
+ integer, dimension(NGLLX*NGLLX*max_interface_size_ext_mesh,num_interfaces_ext_mesh) :: &
+ ibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh
+
+! local parameters
+ ! (assumes NGLLX=NGLLY=NGLLZ)
+! only defining local variables...
+ real(kind=CUSTOM_REAL),dimension(NGNOD2D) :: xcoord,ycoord,zcoord
+ real(kind=CUSTOM_REAL) :: jacobian2Dw_face(NGLLX,NGLLY)
+ real(kind=CUSTOM_REAL) :: normal_face(NDIM,NGLLX,NGLLY)
+ real(kind=CUSTOM_REAL),dimension(:,:,:),allocatable :: tmp_normal
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable :: tmp_jacobian2Dw
+ integer :: ijk_face(3,NGLLX,NGLLY)
+ integer,dimension(:,:,:),allocatable :: tmp_ijk
+ integer,dimension(:),allocatable :: tmp_ispec
+ integer,dimension(NGNOD2D) :: iglob_corners_ref !,iglob_corners
+ integer :: ispec,i,j,k,igll,ier,iglob
+ integer :: inum,iface_ref,icorner,iglob_midpoint ! iface,ispec_neighbor
+ integer :: count_domain1,count_domain2
+ ! mpi interface communication
+ integer, dimension(:), allocatable :: test_flag
+ integer, dimension(:,:), allocatable :: ibool_interfaces_ext_mesh_dummy
+ integer :: max_nibool_interfaces_ext_mesh
+ logical, dimension(:), allocatable :: mask_ibool
+
+ ! corners indices of reference cube faces
+ integer,dimension(3,4),parameter :: iface1_corner_ijk = &
+ reshape( (/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ /),(/3,4/)) ! xmin
+ integer,dimension(3,4),parameter :: iface2_corner_ijk = &
+ reshape( (/ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),(/3,4/)) ! xmax
+ integer,dimension(3,4),parameter :: iface3_corner_ijk = &
+ reshape( (/ 1,1,1, 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,1,1 /),(/3,4/)) ! ymin
+ integer,dimension(3,4),parameter :: iface4_corner_ijk = &
+ reshape( (/ 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! ymax
+ integer,dimension(3,4),parameter :: iface5_corner_ijk = &
+ reshape( (/ 1,1,1, 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,1,1 /),(/3,4/)) ! bottom
+ integer,dimension(3,4),parameter :: iface6_corner_ijk = &
+ reshape( (/ 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! top
+ integer,dimension(3,4,6),parameter :: iface_all_corner_ijk = &
+ reshape( (/ iface1_corner_ijk,iface2_corner_ijk, &
+ iface3_corner_ijk,iface4_corner_ijk, &
+ iface5_corner_ijk,iface6_corner_ijk /),(/3,4,6/)) ! all faces
+ ! midpoint indices for each face (xmin,xmax,ymin,ymax,zmin,zmax)
+ integer,dimension(3,6),parameter :: iface_all_midpointijk = &
+ reshape( (/ 1,2,2, NGLLX,2,2, 2,1,2, 2,NGLLY,2, 2,2,1, 2,2,NGLLZ /),(/3,6/)) ! top
+
+
+ ! test vtk output
+ !integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: gll_data
+ !character(len=256):: prname_file
+
+
+! allocates temporary arrays
+ allocate(tmp_normal(NDIM,NGLLSQUARE,nspec*6))
+ allocate(tmp_jacobian2Dw(NGLLSQUARE,nspec*6))
+ allocate(tmp_ijk(3,NGLLSQUARE,nspec*6))
+ allocate(tmp_ispec(nspec*6))
+ tmp_ispec(:) = 0
+ tmp_ijk(:,:,:) = 0
+ tmp_normal(:,:,:) = 0.0
+ tmp_jacobian2Dw(:,:) = 0.0
+
+ ! sets flags for domain2 / domain1 on global points
+ allocate(domain1_flag(nglob),stat=ier)
+ allocate(domain2_flag(nglob),stat=ier)
+
+ ! what is this test_flag is for .
+ allocate(test_flag(nglob),stat=ier)
+ allocate(mask_ibool(nglob),stat=ier)
+ if( ier /= 0 ) stop 'error allocate flag array'
+ domain1_flag(:) = 0
+ domain2_flag(:) = 0
+ test_flag(:) = 0
+ count_domain1 = 0
+ count_domain2 = 0
+
+!!!! running onver all the elements over each block.
+
+ do ispec = 1, nspec
+ ! counts elements
+!!!change this variable.. my_tag(ispec)==domain2+_tag)
+!!!change this variable.. my_tag(ispec)==domain2-_tag)
+!!!! allocate my_tag
+! my_tag = mat_ext_mesh(1,ispec)
+
+ my_tag(ispec)=mat_ext_mesh(1,ispec)
+ if( my_tag(ispec)==domain1_tag ) count_domain1 = count_domain1 + 1
+ if( my_tag(ispec)==domain2_tag ) count_domain2 = count_domain2 + 1
+
+!!!!!! inserting domains into processor , one by one. ...
+ ! sets flags on global points
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ ! global index
+ iglob = ibool(i,j,k,ispec)
+ ! sets domain1 flag1
+ if( ispec_is_domain1(ispec) ) domain1_flag(iglob) = myrank+1
+ ! sets domain2 flag2
+ if( ispec_is_domain2(ispec) ) domain2_flag(iglob) = myrank+1
+ ! sets test flag
+ test_flag(iglob) = myrank+1
+ enddo
+ enddo
+ enddo
+ enddo
+
+!!! counting number of domains and assigning them into each processors.
+ call sum_all_i(count_domain2,inum)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' total domain2 elements:',inum
+ endif
+ call sum_all_i(count_domain1,inum)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' total domain1 elements :',inum
+ endif
+
+
+
+ ! collects contributions from different MPI partitions
+ ! sets up MPI communications
+ max_nibool_interfaces_ext_mesh = maxval( nibool_interfaces_ext_mesh(:) )
+ allocate(ibool_interfaces_ext_mesh_dummy(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier)
+ if( ier /= 0 ) stop 'error allocating array'
+ do i = 1, num_interfaces_ext_mesh
+ ibool_interfaces_ext_mesh_dummy(:,i) = ibool_interfaces_ext_mesh(1:max_nibool_interfaces_ext_mesh,i)
+ enddo
+ ! sums domain1 flags
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,nglob,domain1_flag, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh_dummy,&
+ my_neighbours_ext_mesh)
+ ! sums domain2 flags
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,nglob,domain2_flag, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh_dummy,&
+ my_neighbours_ext_mesh)
+
+ ! sums test flags
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,nglob,test_flag, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh_dummy,&
+ my_neighbours_ext_mesh)
+
+ ! loops over all element faces and
+ ! counts number of coupling faces between domain2 and domain1 elements
+ mask_ibool(:) = .false.
+ inum = 0
+ do ispec=1,nspec
+
+ ! loops over each face
+ do iface_ref= 1, 6
+
+ ! takes indices of corners of reference face
+ do icorner = 1,NGNOD2D
+ i = iface_all_corner_ijk(1,icorner,iface_ref)
+ j = iface_all_corner_ijk(2,icorner,iface_ref)
+ k = iface_all_corner_ijk(3,icorner,iface_ref)
+ ! global reference indices
+ iglob_corners_ref(icorner) = ibool(i,j,k,ispec)
+
+ ! reference corner coordinates
+ xcoord(icorner) = xstore_dummy(iglob_corners_ref(icorner))
+ ycoord(icorner) = ystore_dummy(iglob_corners_ref(icorner))
+ zcoord(icorner) = zstore_dummy(iglob_corners_ref(icorner))
+ enddo
+
+ ! checks if face has domain2 side
+ if( domain2_flag( iglob_corners_ref(1) ) >= 1 .and. &
+ domain2_flag( iglob_corners_ref(2) ) >= 1 .and. &
+ domain2_flag( iglob_corners_ref(3) ) >= 1 .and. &
+ domain2_flag( iglob_corners_ref(4) ) >= 1) then
+ ! checks if face is has an domain1 side
+ if( domain1_flag( iglob_corners_ref(1) ) >= 1 .and. &
+ domain1_flag( iglob_corners_ref(2) ) >= 1 .and. &
+ domain1_flag( iglob_corners_ref(3) ) >= 1 .and. &
+ domain1_flag( iglob_corners_ref(4) ) >= 1) then
+
+ ! reference midpoint on face (used to avoid redundant face counting)
+ i = iface_all_midpointijk(1,iface_ref)
+ j = iface_all_midpointijk(2,iface_ref)
+ k = iface_all_midpointijk(3,iface_ref)
+ iglob_midpoint = ibool(i,j,k,ispec)
+
+ ! checks if points on this face are masked already
+ if( .not. mask_ibool(iglob_midpoint) ) then
+
+ ! gets face GLL points i,j,k indices from element face
+ call get_element_face_gll_indices(iface_ref,ijk_face,NGLLX,NGLLY)
+
+ ! takes each element face only once, if it lies on an MPI interface
+ ! note: this is not exactly load balanced
+ ! lowest rank process collects as many faces as possible, second lowest as so forth
+ if( (test_flag(iglob_midpoint) == myrank+1) .or. &
+ (test_flag(iglob_midpoint) > 2*(myrank+1)) ) then
+
+ ! gets face GLL 2Djacobian, weighted from element face
+ 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_ref,jacobian2Dw_face,normal_face,NGLLX,NGLLY)
+
+ ! normal convention: points away from domain2, reference element
+ ! switch normal direction if necessary
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! directs normals such that they point outwards of element
+ call get_element_face_normal(ispec,iface_ref,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ normal_face(:,i,j) )
+ ! makes sure that it always points away from domain2 element,
+ ! otherwise switch direction
+ if( ispec_is_domain1(ispec) ) normal_face(:,i,j) = - normal_face(:,i,j)
+ enddo
+ enddo
+
+ ! stores informations about this face
+ inum = inum + 1
+ tmp_ispec(inum) = ispec
+ igll = 0
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! adds all gll points on this face
+ igll = igll + 1
+
+ ! do we need to store local i,j,k,ispec info? or only global indices iglob?
+ tmp_ijk(:,igll,inum) = ijk_face(:,i,j)
+
+ ! stores weighted jacobian and normals
+ tmp_jacobian2Dw(igll,inum) = jacobian2Dw_face(i,j)
+ tmp_normal(:,igll,inum) = normal_face(:,i,j)
+
+ ! masks global points ( to avoid redundant counting of faces)
+ iglob = ibool(ijk_face(1,i,j),ijk_face(2,i,j),ijk_face(3,i,j),ispec)
+ mask_ibool(iglob) = .true.
+ enddo
+ enddo
+ else
+ ! assumes to be already collected by lower rank process, masks face points
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(ijk_face(1,i,j),ijk_face(2,i,j),ijk_face(3,i,j),ispec)
+ mask_ibool(iglob) = .true.
+ enddo
+ enddo
+ endif ! test_flag
+ endif ! mask_ibool
+ endif ! domain1_flag
+ endif ! domain2_flag
+ enddo ! iface_ref
+ enddo ! ispec
+
+! stores completed coupling domain2-domain1 face informations
+!
+! note: no need to store material parameters on these coupling points
+! for domain2-domain1 interface
+! defining new parameter , renaming coupling_fa_el_normal ..
+
+
+ coupling%num_faces = inum
+ allocate(coupling%normal(NDIM,NGLLSQUARE,coupling%num_faces))
+ allocate(coupling%jacobian2Dw(NGLLSQUARE,coupling%num_faces))
+ allocate(coupling%ijk(3,NGLLSQUARE,coupling%num_faces))
+ allocate(coupling%ispec(coupling%num_faces))
+ do inum = 1,coupling%num_faces
+ coupling%normal(:,:,inum) = tmp_normal(:,:,inum)
+ coupling%jacobian2Dw(:,inum) = tmp_jacobian2Dw(:,inum)
+ coupling%ijk(:,:,inum) = tmp_ijk(:,:,inum)
+ coupling%ispec(inum) = tmp_ispec(inum)
+ enddo
+
+! user output
+ call sum_all_i(coupling%num_faces,inum)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' domain2-domain1 coupling:'
+ write(IMAIN,*) ' total number of faces = ',inum
+ endif
+
+ end subroutine get_coupling_surfaces_domain2_domain1
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_coupling_surfaces.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_coupling_surfaces.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_coupling_surfaces.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,308 @@
+!=====================================================================
+!
+! 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 get_coupling_surfaces(myrank, &
+ nspec,nglob,ibool,NPROC, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ num_interfaces_ext_mesh,max_interface_size_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+! determines coupling surface for acoustic-elastic domains
+
+ use create_regions_mesh_ext_par
+ implicit none
+
+! number of spectral elements in each block
+ integer :: myrank,nspec,nglob,NPROC
+
+! arrays with the mesh
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+! MPI communication
+ integer :: num_interfaces_ext_mesh,max_interface_size_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: my_neighbours_ext_mesh
+ integer, dimension(NGLLX*NGLLX*max_interface_size_ext_mesh,num_interfaces_ext_mesh) :: &
+ ibool_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh
+
+! local parameters
+ ! (assumes NGLLX=NGLLY=NGLLZ)
+ real(kind=CUSTOM_REAL),dimension(NGNOD2D) :: xcoord,ycoord,zcoord
+ real(kind=CUSTOM_REAL) :: jacobian2Dw_face(NGLLX,NGLLY)
+ real(kind=CUSTOM_REAL) :: normal_face(NDIM,NGLLX,NGLLY)
+ real(kind=CUSTOM_REAL),dimension(:,:,:),allocatable :: tmp_normal
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable :: tmp_jacobian2Dw
+ integer :: ijk_face(3,NGLLX,NGLLY)
+ integer,dimension(:,:,:),allocatable :: tmp_ijk
+ integer,dimension(:),allocatable :: tmp_ispec
+
+ integer,dimension(NGNOD2D) :: iglob_corners_ref !,iglob_corners
+ integer :: ispec,i,j,k,igll,ier,iglob
+ integer :: inum,iface_ref,icorner,iglob_midpoint ! iface,ispec_neighbor
+ integer :: count_elastic,count_acoustic
+
+ ! mpi interface communication
+ integer, dimension(:), allocatable :: elastic_flag,acoustic_flag,test_flag
+ integer, dimension(:,:), allocatable :: ibool_interfaces_ext_mesh_dummy
+ integer :: max_nibool_interfaces_ext_mesh
+ logical, dimension(:), allocatable :: mask_ibool
+
+ ! corners indices of reference cube faces
+ integer,dimension(3,4),parameter :: iface1_corner_ijk = &
+ reshape( (/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ /),(/3,4/)) ! xmin
+ integer,dimension(3,4),parameter :: iface2_corner_ijk = &
+ reshape( (/ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),(/3,4/)) ! xmax
+ integer,dimension(3,4),parameter :: iface3_corner_ijk = &
+ reshape( (/ 1,1,1, 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,1,1 /),(/3,4/)) ! ymin
+ integer,dimension(3,4),parameter :: iface4_corner_ijk = &
+ reshape( (/ 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! ymax
+ integer,dimension(3,4),parameter :: iface5_corner_ijk = &
+ reshape( (/ 1,1,1, 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,1,1 /),(/3,4/)) ! bottom
+ integer,dimension(3,4),parameter :: iface6_corner_ijk = &
+ reshape( (/ 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! top
+ integer,dimension(3,4,6),parameter :: iface_all_corner_ijk = &
+ reshape( (/ iface1_corner_ijk,iface2_corner_ijk, &
+ iface3_corner_ijk,iface4_corner_ijk, &
+ iface5_corner_ijk,iface6_corner_ijk /),(/3,4,6/)) ! all faces
+ ! midpoint indices for each face (xmin,xmax,ymin,ymax,zmin,zmax)
+ integer,dimension(3,6),parameter :: iface_all_midpointijk = &
+ reshape( (/ 1,2,2, NGLLX,2,2, 2,1,2, 2,NGLLY,2, 2,2,1, 2,2,NGLLZ /),(/3,6/)) ! top
+
+
+ ! test vtk output
+ !integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: gll_data
+ !character(len=256):: prname_file
+
+! allocates temporary arrays
+ allocate(tmp_normal(NDIM,NGLLSQUARE,nspec*6))
+ allocate(tmp_jacobian2Dw(NGLLSQUARE,nspec*6))
+ allocate(tmp_ijk(3,NGLLSQUARE,nspec*6))
+ allocate(tmp_ispec(nspec*6))
+ tmp_ispec(:) = 0
+ tmp_ijk(:,:,:) = 0
+ tmp_normal(:,:,:) = 0.0
+ tmp_jacobian2Dw(:,:) = 0.0
+
+ ! sets flags for acoustic / elastic on global points
+ allocate(elastic_flag(nglob),stat=ier)
+ allocate(acoustic_flag(nglob),stat=ier)
+ allocate(test_flag(nglob),stat=ier)
+ allocate(mask_ibool(nglob),stat=ier)
+ if( ier /= 0 ) stop 'error allocate flag array'
+ elastic_flag(:) = 0
+ acoustic_flag(:) = 0
+ test_flag(:) = 0
+ count_elastic = 0
+ count_acoustic = 0
+ do ispec = 1, nspec
+ ! counts elements
+ if( ispec_is_elastic(ispec) ) count_elastic = count_elastic + 1
+ if( ispec_is_acoustic(ispec) ) count_acoustic = count_acoustic + 1
+
+ ! sets flags on global points
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ ! global index
+ iglob = ibool(i,j,k,ispec)
+ ! sets elastic flag
+ if( ispec_is_elastic(ispec) ) elastic_flag(iglob) = myrank+1
+ ! sets acoustic flag
+ if( ispec_is_acoustic(ispec) ) acoustic_flag(iglob) = myrank+1
+ ! sets test flag
+ test_flag(iglob) = myrank+1
+ enddo
+ enddo
+ enddo
+ enddo
+ call sum_all_i(count_acoustic,inum)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' total acoustic elements:',inum
+ endif
+ call sum_all_i(count_elastic,inum)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' total elastic elements :',inum
+ endif
+
+ ! collects contributions from different MPI partitions
+ ! sets up MPI communications
+ max_nibool_interfaces_ext_mesh = maxval( nibool_interfaces_ext_mesh(:) )
+ allocate(ibool_interfaces_ext_mesh_dummy(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh),stat=ier)
+ if( ier /= 0 ) stop 'error allocating array'
+ do i = 1, num_interfaces_ext_mesh
+ ibool_interfaces_ext_mesh_dummy(:,i) = ibool_interfaces_ext_mesh(1:max_nibool_interfaces_ext_mesh,i)
+ enddo
+ ! sums elastic flags
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,nglob,elastic_flag, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh_dummy,&
+ my_neighbours_ext_mesh)
+ ! sums acoustic flags
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,nglob,acoustic_flag, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh_dummy,&
+ my_neighbours_ext_mesh)
+
+ ! sums test flags
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,nglob,test_flag, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh_dummy,&
+ my_neighbours_ext_mesh)
+
+ ! loops over all element faces and
+ ! counts number of coupling faces between acoustic and elastic elements
+ mask_ibool(:) = .false.
+ inum = 0
+ do ispec=1,nspec
+
+ ! loops over each face
+ do iface_ref= 1, 6
+
+ ! takes indices of corners of reference face
+ do icorner = 1,NGNOD2D
+ i = iface_all_corner_ijk(1,icorner,iface_ref)
+ j = iface_all_corner_ijk(2,icorner,iface_ref)
+ k = iface_all_corner_ijk(3,icorner,iface_ref)
+ ! global reference indices
+ iglob_corners_ref(icorner) = ibool(i,j,k,ispec)
+
+ ! reference corner coordinates
+ xcoord(icorner) = xstore_dummy(iglob_corners_ref(icorner))
+ ycoord(icorner) = ystore_dummy(iglob_corners_ref(icorner))
+ zcoord(icorner) = zstore_dummy(iglob_corners_ref(icorner))
+ enddo
+
+ ! checks if face has acoustic side
+ if( acoustic_flag( iglob_corners_ref(1) ) >= 1 .and. &
+ acoustic_flag( iglob_corners_ref(2) ) >= 1 .and. &
+ acoustic_flag( iglob_corners_ref(3) ) >= 1 .and. &
+ acoustic_flag( iglob_corners_ref(4) ) >= 1) then
+ ! checks if face is has an elastic side
+ if( elastic_flag( iglob_corners_ref(1) ) >= 1 .and. &
+ elastic_flag( iglob_corners_ref(2) ) >= 1 .and. &
+ elastic_flag( iglob_corners_ref(3) ) >= 1 .and. &
+ elastic_flag( iglob_corners_ref(4) ) >= 1) then
+
+ ! reference midpoint on face (used to avoid redundant face counting)
+ i = iface_all_midpointijk(1,iface_ref)
+ j = iface_all_midpointijk(2,iface_ref)
+ k = iface_all_midpointijk(3,iface_ref)
+ iglob_midpoint = ibool(i,j,k,ispec)
+
+ ! checks if points on this face are masked already
+ if( .not. mask_ibool(iglob_midpoint) ) then
+
+ ! gets face GLL points i,j,k indices from element face
+ call get_element_face_gll_indices(iface_ref,ijk_face,NGLLX,NGLLY)
+
+ ! takes each element face only once, if it lies on an MPI interface
+ ! note: this is not exactly load balanced
+ ! lowest rank process collects as many faces as possible, second lowest as so forth
+ if( (test_flag(iglob_midpoint) == myrank+1) .or. &
+ (test_flag(iglob_midpoint) > 2*(myrank+1)) ) then
+
+ ! gets face GLL 2Djacobian, weighted from element face
+ 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_ref,jacobian2Dw_face,normal_face,NGLLX,NGLLY)
+
+ ! normal convention: points away from acoustic, reference element
+ ! switch normal direction if necessary
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! directs normals such that they point outwards of element
+ call get_element_face_normal(ispec,iface_ref,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ normal_face(:,i,j) )
+ ! makes sure that it always points away from acoustic element,
+ ! otherwise switch direction
+ if( ispec_is_elastic(ispec) ) normal_face(:,i,j) = - normal_face(:,i,j)
+ enddo
+ enddo
+
+ ! stores informations about this face
+ inum = inum + 1
+ tmp_ispec(inum) = ispec
+ igll = 0
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ! adds all gll points on this face
+ igll = igll + 1
+
+ ! do we need to store local i,j,k,ispec info? or only global indices iglob?
+ tmp_ijk(:,igll,inum) = ijk_face(:,i,j)
+
+ ! stores weighted jacobian and normals
+ tmp_jacobian2Dw(igll,inum) = jacobian2Dw_face(i,j)
+ tmp_normal(:,igll,inum) = normal_face(:,i,j)
+
+ ! masks global points ( to avoid redundant counting of faces)
+ iglob = ibool(ijk_face(1,i,j),ijk_face(2,i,j),ijk_face(3,i,j),ispec)
+ mask_ibool(iglob) = .true.
+ enddo
+ enddo
+ else
+ ! assumes to be already collected by lower rank process, masks face points
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(ijk_face(1,i,j),ijk_face(2,i,j),ijk_face(3,i,j),ispec)
+ mask_ibool(iglob) = .true.
+ enddo
+ enddo
+ endif ! test_flag
+ endif ! mask_ibool
+ endif ! elastic_flag
+ endif ! acoustic_flag
+ enddo ! iface_ref
+ enddo ! ispec
+
+! stores completed coupling face informations
+!
+! note: no need to store material parameters on these coupling points
+! for acoustic-elastic interface
+ num_coupling_ac_el_faces = inum
+ allocate(coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces))
+ allocate(coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces))
+ allocate(coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces))
+ allocate(coupling_ac_el_ispec(num_coupling_ac_el_faces))
+ do inum = 1,num_coupling_ac_el_faces
+ coupling_ac_el_normal(:,:,inum) = tmp_normal(:,:,inum)
+ coupling_ac_el_jacobian2Dw(:,inum) = tmp_jacobian2Dw(:,inum)
+ coupling_ac_el_ijk(:,:,inum) = tmp_ijk(:,:,inum)
+ coupling_ac_el_ispec(inum) = tmp_ispec(inum)
+ enddo
+
+! user output
+ call sum_all_i(num_coupling_ac_el_faces,inum)
+ if( myrank == 0 ) then
+ write(IMAIN,*) ' acoustic-elastic coupling:'
+ write(IMAIN,*) ' total number of faces = ',inum
+ endif
+
+ end subroutine get_coupling_surfaces
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_element_face.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_element_face.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_element_face.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,538 @@
+!
+!----
+!
+
+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
+ ! shapes of arrays below
+ integer,dimension(2),parameter :: face_shape = (/3,4/)
+ integer,dimension(3),parameter :: all_faces_shape = (/3,4,6/)
+
+ ! xmin
+ integer,dimension(3,4),parameter :: iface1_corner_ijk = &
+ reshape((/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ /),face_shape)
+ ! xmax
+ integer,dimension(3,4),parameter :: iface2_corner_ijk = &
+ reshape((/ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),face_shape)
+ ! ymin
+ integer,dimension(3,4),parameter :: iface3_corner_ijk = &
+ reshape((/ 1,1,1, 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,1,1 /),face_shape)
+ ! ymax
+ integer,dimension(3,4),parameter :: iface4_corner_ijk = &
+ reshape((/ 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),face_shape)
+ ! bottom
+ integer,dimension(3,4),parameter :: iface5_corner_ijk = &
+ reshape((/ 1,1,1, 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,1,1 /),face_shape)
+ ! top
+ integer,dimension(3,4),parameter :: iface6_corner_ijk = &
+ reshape((/ 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),face_shape)
+ ! all faces
+ integer,dimension(3,4,6),parameter :: iface_all_corner_ijk = &
+ reshape((/ iface1_corner_ijk,iface2_corner_ijk, &
+ iface3_corner_ijk,iface4_corner_ijk, &
+ iface5_corner_ijk,iface6_corner_ijk /),all_faces_shape)
+
+! 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:',xstore_dummy(iglob),ystore_dummy(iglob),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),dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
+
+! 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)*face_n(1) + face_n(2)*face_n(2) + face_n(3)*face_n(3) )
+ if( abs(tmp) < TINYVAL ) then
+ print*,'error get face normal: length',tmp
+ print*,'normal:',face_n(:)
+ call exit_mpi(0,'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
+
+! in case given normal has zero length, sets it to computed face normal
+ if( ( normal(1)**2 + normal(2)**2 + normal(3)**2 ) < TINYVAL ) then
+ normal(:) = face_n(:)
+ return
+ endif
+
+! otherwise determines orientation of 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
+
+!
+!----
+!
+
+subroutine get_element_face_normal_idirect(ispec,iface,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ normal,idirect)
+
+! returns direction of normal:
+! idirect = 1 to point outwards of/away from element
+! idirect = 2 to point into 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
+
+! direction type
+ integer, intent(out) :: idirect
+
+! local parameters
+ real(kind=CUSTOM_REAL) :: face_n(3),tmp,v_tmp(3)
+ integer :: iglob
+
+! initializes
+ idirect = 0
+
+! 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(:)
+ call exit_mpi(0,'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
+
+! in case given normal has zero length, exit
+ if( ( normal(1)**2 + normal(2)**2 + normal(3)**2 ) < TINYVAL ) then
+ print*,'problem: given normal is zero'
+ return
+ endif
+
+! otherwise determines orientation of normal
+ tmp = face_n(1)*normal(1) + face_n(2)*normal(2) + face_n(3)*normal(3)
+ if( tmp < 0.0 ) then
+ ! points into element
+ idirect = 2
+ else
+ ! points away from element/ outwards
+ idirect = 1
+ endif
+
+end subroutine get_element_face_normal_idirect
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_flags_boundaries.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_flags_boundaries.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_flags_boundaries.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,162 @@
+!=====================================================================
+!
+! 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 get_flags_boundaries(nspec,iproc_xi,iproc_eta,ispec,idoubling, &
+ xstore,ystore,zstore,iboun,iMPIcut_xi,iMPIcut_eta, &
+ NPROC_XI,NPROC_ETA, &
+ UTM_X_MIN,UTM_X_MAX,UTM_Y_MIN,UTM_Y_MAX,Z_DEPTH_BLOCK)
+
+ implicit none
+
+ include "constants.h"
+ include "constants_gocad.h"
+
+ integer nspec
+ integer ispec,idoubling
+ integer NPROC_XI,NPROC_ETA
+
+ double precision UTM_X_MIN,UTM_X_MAX,UTM_Y_MIN,UTM_Y_MAX,Z_DEPTH_BLOCK
+
+ logical iboun(6,nspec)
+ logical iMPIcut_xi(2,nspec),iMPIcut_eta(2,nspec)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ)
+ double precision ystore(NGLLX,NGLLY,NGLLZ)
+ double precision zstore(NGLLX,NGLLY,NGLLZ)
+
+! use iproc_xi and iproc_eta to determine MPI cut planes along xi and eta
+ integer iproc_xi,iproc_eta
+
+ double precision target,sizeslice,TOLERANCE_METERS
+ double precision xelm(8),yelm(8),zelm(8)
+
+! find the coordinates of the eight corner nodes of the element
+ xelm(1)=xstore(1,1,1)
+ yelm(1)=ystore(1,1,1)
+ zelm(1)=zstore(1,1,1)
+ xelm(2)=xstore(NGLLX,1,1)
+ yelm(2)=ystore(NGLLX,1,1)
+ zelm(2)=zstore(NGLLX,1,1)
+ xelm(3)=xstore(NGLLX,NGLLY,1)
+ yelm(3)=ystore(NGLLX,NGLLY,1)
+ zelm(3)=zstore(NGLLX,NGLLY,1)
+ xelm(4)=xstore(1,NGLLY,1)
+ yelm(4)=ystore(1,NGLLY,1)
+ zelm(4)=zstore(1,NGLLY,1)
+ xelm(5)=xstore(1,1,NGLLZ)
+ yelm(5)=ystore(1,1,NGLLZ)
+ zelm(5)=zstore(1,1,NGLLZ)
+ xelm(6)=xstore(NGLLX,1,NGLLZ)
+ yelm(6)=ystore(NGLLX,1,NGLLZ)
+ zelm(6)=zstore(NGLLX,1,NGLLZ)
+ xelm(7)=xstore(NGLLX,NGLLY,NGLLZ)
+ yelm(7)=ystore(NGLLX,NGLLY,NGLLZ)
+ zelm(7)=zstore(NGLLX,NGLLY,NGLLZ)
+ xelm(8)=xstore(1,NGLLY,NGLLZ)
+ yelm(8)=ystore(1,NGLLY,NGLLZ)
+ zelm(8)=zstore(1,NGLLY,NGLLZ)
+
+! compute geometrical tolerance small compared to size of model to detect edges
+ TOLERANCE_METERS = dabs(UTM_X_MAX - UTM_X_MIN) / 100000.
+
+! ****************************************************
+! determine if the element falls on a boundary
+! ****************************************************
+
+ iboun(:,ispec)=.false.
+
+! on boundary 1: x=xmin
+ target= UTM_X_MIN + TOLERANCE_METERS
+ if(xelm(1)<target .and. xelm(4)<target .and. xelm(5)<target .and. xelm(8)<target) iboun(1,ispec)=.true.
+
+! on boundary 2: xmax
+ target= UTM_X_MAX - TOLERANCE_METERS
+ if(xelm(2)>target .and. xelm(3)>target .and. xelm(6)>target .and. xelm(7)>target) iboun(2,ispec)=.true.
+
+! on boundary 3: ymin
+ target= UTM_Y_MIN + TOLERANCE_METERS
+ if(yelm(1)<target .and. yelm(2)<target .and. yelm(5)<target .and. yelm(6)<target) iboun(3,ispec)=.true.
+
+! on boundary 4: ymax
+ target= UTM_Y_MAX - TOLERANCE_METERS
+ if(yelm(3)>target .and. yelm(4)>target .and. yelm(7)>target .and. yelm(8)>target) iboun(4,ispec)=.true.
+
+! on boundary 5: bottom
+ target = Z_DEPTH_BLOCK + TOLERANCE_METERS
+ if(zelm(1)<target .and. zelm(2)<target .and. zelm(3)<target .and. zelm(4)<target) iboun(5,ispec)=.true.
+
+! on boundary 6: top
+ if(idoubling == IFLAG_ONE_LAYER_TOPOGRAPHY) iboun(6,ispec)=.true.
+
+! *******************************************************************
+! determine if the element falls on an MPI cut plane along xi
+! *******************************************************************
+
+! detect the MPI cut planes along xi in the cubed sphere
+
+ iMPIcut_xi(:,ispec)=.false.
+
+! angular size of a slice along xi
+ sizeslice = (UTM_X_MAX-UTM_X_MIN) / NPROC_XI
+
+! left cut-plane in the current slice along X = constant (Xmin of this slice)
+! and add geometrical tolerance
+
+ target = UTM_X_MIN + iproc_xi*sizeslice + TOLERANCE_METERS
+ if(xelm(1)<target .and. xelm(4)<target .and. xelm(5)<target .and. xelm(8)<target) &
+ iMPIcut_xi(1,ispec)=.true.
+
+! right cut-plane in the current slice along X = constant (Xmax of this slice)
+! and add geometrical tolerance
+
+ target = UTM_X_MIN + (iproc_xi+1)*sizeslice - TOLERANCE_METERS
+ if(xelm(2)>target .and. xelm(3)>target .and. xelm(6)>target .and. xelm(7)>target) &
+ iMPIcut_xi(2,ispec)=.true.
+
+! ********************************************************************
+! determine if the element falls on an MPI cut plane along eta
+! ********************************************************************
+
+ iMPIcut_eta(:,ispec)=.false.
+
+! angular size of a slice along eta
+ sizeslice = (UTM_Y_MAX-UTM_Y_MIN) / NPROC_ETA
+
+! left cut-plane in the current slice along Y = constant (Ymin of this slice)
+! and add geometrical tolerance
+
+ target = UTM_Y_MIN + iproc_eta*sizeslice + TOLERANCE_METERS
+ if(yelm(1)<target .and. yelm(2)<target .and. yelm(5)<target .and. yelm(6)<target) &
+ iMPIcut_eta(1,ispec)=.true.
+
+! right cut-plane in the current slice along Y = constant (Ymax of this slice)
+! and add geometrical tolerance
+
+ target = UTM_Y_MIN + (iproc_eta+1)*sizeslice - TOLERANCE_METERS
+ if(yelm(3)>target .and. yelm(4)>target .and. yelm(7)>target .and. yelm(8)>target) &
+ iMPIcut_eta(2,ispec)=.true.
+
+ end subroutine get_flags_boundaries
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_global.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_global.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_global.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,306 @@
+!=====================================================================
+!
+! 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 get_global(nspec,xp,yp,zp,iglob,loc,ifseg,nglob,npointot,UTM_X_MIN,UTM_X_MAX)
+
+! this routine MUST be in double precision to avoid sensitivity
+! to roundoff errors in the coordinates of the points
+
+! non-structured global numbering software provided by Paul F. Fischer
+
+! leave the sorting subroutines in the same source file to allow for inlining
+
+ implicit none
+
+ include "constants.h"
+
+
+ integer npointot
+ integer nspec,nglob
+ integer iglob(npointot),loc(npointot)
+ logical ifseg(npointot)
+ double precision xp(npointot),yp(npointot),zp(npointot)
+ double precision UTM_X_MIN,UTM_X_MAX
+
+ integer ispec,i,j,ier
+ integer ieoff,ilocnum,nseg,ioff,iseg,ig
+
+ integer, dimension(:), allocatable :: ind,ninseg,iwork
+ double precision, dimension(:), allocatable :: work
+
+! geometry tolerance parameter to calculate number of independent grid points
+! small value for double precision and to avoid sensitivity to roundoff
+ double precision :: SMALLVALTOL
+
+! number of points per spectral element
+! integer, parameter :: NGLLCUBE = NGLLX * NGLLY * NGLLZ
+ !jpampuero To allow usage of this routine for volume and surface meshes:
+ !jpampuero For volumes NGLLCUBE = NGLLX * NGLLY * NGLLZ
+ !jpampuero For surfaces NGLLCUBE = NGLLX * NGLLY
+ integer :: NGLLCUBE
+
+ NGLLCUBE=npointot/nspec
+! for vectorization of loops
+! integer, parameter :: NGLLCUBE_NDIM = NGLLCUBE * NDIM
+
+
+! define geometrical tolerance based upon typical size of the model
+ SMALLVALTOL = 1.d-10 * dabs(UTM_X_MAX - UTM_X_MIN)
+
+! dynamically allocate arrays
+ allocate(ind(npointot), &
+ ninseg(npointot), &
+ iwork(npointot), &
+ work(npointot),stat=ier)
+ if( ier /= 0 ) stop 'error allocating arrays'
+
+! establish initial pointers
+ do ispec=1,nspec
+ ieoff=NGLLCUBE*(ispec-1)
+ do ilocnum=1,NGLLCUBE
+ loc(ilocnum+ieoff)=ilocnum+ieoff
+ enddo
+ enddo
+
+ ifseg(:)=.false.
+
+ nseg=1
+ ifseg(1)=.true.
+ ninseg(1)=npointot
+
+ do j=1,NDIM
+
+! sort within each segment
+ ioff=1
+ do iseg=1,nseg
+ if(j == 1) then
+ call rank(xp(ioff),ind,ninseg(iseg))
+ else 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
+ do i=2,npointot
+ if(dabs(xp(i)-xp(i-1)) > SMALLVALTOL) ifseg(i)=.true.
+ 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
+ do i=1,npointot
+ if(ifseg(i)) ig=ig+1
+ iglob(loc(i))=ig
+ enddo
+
+ nglob=ig
+
+! deallocate arrays
+ deallocate(ind)
+ deallocate(ninseg)
+ deallocate(iwork)
+ deallocate(work)
+
+ end subroutine get_global
+
+! -----------------------------------
+
+! sorting routines put in same file to allow for inlining
+
+ subroutine rank(A,IND,N)
+!
+! Use Heap Sort (Numerical Recipes)
+!
+ implicit none
+
+ integer n
+ double precision A(n)
+ integer IND(n)
+
+ integer i,j,l,ir,indx
+ double precision q
+
+ do j=1,n
+ IND(j)=j
+ enddo
+
+ if (n == 1) return
+
+ L=n/2+1
+ ir=n
+ 100 CONTINUE
+ IF (l>1) THEN
+ l=l-1
+ indx=ind(l)
+ q=a(indx)
+ ELSE
+ indx=ind(ir)
+ q=a(indx)
+ ind(ir)=ind(1)
+ ir=ir-1
+ if (ir == 1) then
+ ind(1)=indx
+ return
+ endif
+ ENDIF
+ i=l
+ j=l+l
+ 200 CONTINUE
+ IF (J <= IR) THEN
+ IF (J<IR) THEN
+ IF ( A(IND(j))<A(IND(j+1)) ) j=j+1
+ ENDIF
+ IF (q<A(IND(j))) THEN
+ IND(I)=IND(J)
+ I=J
+ J=J+J
+ ELSE
+ J=IR+1
+ ENDIF
+ goto 200
+ ENDIF
+ IND(I)=INDX
+ goto 100
+
+ end subroutine rank
+
+! ------------------------------------------------------------------
+
+ subroutine swap_all(IA,A,B,C,IW,W,ind,n)
+!
+! swap arrays IA, A, B and C according to addressing in array IND
+!
+ implicit none
+
+ integer n
+
+ integer IND(n)
+ integer IA(n),IW(n)
+ double precision A(n),B(n),C(n),W(n)
+
+ integer i
+
+ IW(:) = IA(:)
+ W(:) = A(:)
+
+ do i=1,n
+ IA(i)=IW(ind(i))
+ A(i)=W(ind(i))
+ enddo
+
+ W(:) = B(:)
+
+ do i=1,n
+ B(i)=W(ind(i))
+ enddo
+
+ W(:) = C(:)
+
+ do i=1,n
+ C(i)=W(ind(i))
+ enddo
+
+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
+ integer:: 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
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_jacobian_boundaries.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_jacobian_boundaries.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_jacobian_boundaries.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,932 @@
+!=====================================================================
+!
+! 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 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,jacobian2Dw_face,normal_face,NGLLA,NGLLB)
+
+! returns jacobian2Dw_face and normal_face (pointing outwards of element)
+
+ 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)
+
+! face information
+ integer :: iface,ispec,NGLLA,NGLLB
+ real(kind=CUSTOM_REAL) jacobian2Dw_face(NGLLA,NGLLB)
+ real(kind=CUSTOM_REAL) normal_face(NDIM,NGLLA,NGLLB)
+
+ 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
+
+! local parameters
+! face corners
+ double precision xelm(NGNOD2D),yelm(NGNOD2D),zelm(NGNOD2D)
+
+! 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')
+
+ 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) )
+
+ call compute_jacobian_2D_face(myrank,xelm,yelm,zelm, &
+ dershape2D_x,wgllwgll_yz, &
+ jacobian2Dw_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) )
+
+ call compute_jacobian_2D_face(myrank,xelm,yelm,zelm, &
+ dershape2D_x,wgllwgll_yz, &
+ jacobian2Dw_face,normal_face,NGLLY,NGLLZ)
+
+! 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) )
+
+ call compute_jacobian_2D_face(myrank,xelm,yelm,zelm, &
+ dershape2D_y,wgllwgll_xz, &
+ jacobian2Dw_face,normal_face,NGLLX,NGLLZ)
+
+! 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) )
+
+ call compute_jacobian_2D_face(myrank,xelm,yelm,zelm, &
+ dershape2D_y, wgllwgll_xz, &
+ jacobian2Dw_face,normal_face,NGLLX,NGLLZ)
+
+
+! 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, &
+ jacobian2Dw_face,normal_face,NGLLX,NGLLY)
+
+! 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) )
+
+ call compute_jacobian_2D_face(myrank,xelm,yelm,zelm,&
+ dershape2D_top, wgllwgll_xy, &
+ jacobian2Dw_face,normal_face,NGLLX,NGLLY)
+
+ case default
+ stop 'error 2D jacobian'
+ end select
+
+ end subroutine get_jacobian_boundary_face
+
+
+! -------------------------------------------------------
+
+ subroutine compute_jacobian_2D_face(myrank,xelm,yelm,zelm, &
+ dershape2D,wgllwgll, &
+ jacobian2Dw_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 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) jacobian2Dw_face(NGLLA,NGLLB)
+ real(kind=CUSTOM_REAL) normal_face(NDIM,NGLLA,NGLLB)
+
+ 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
+ jacobian2Dw_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
+ jacobian2Dw_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_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,jacobian2Dw_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) jacobian2Dw_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
+ jacobian2Dw_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
+ jacobian2Dw_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
+!
+! 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
+!
+! 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
+!
+! 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
+!
+! 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
+!
+! 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
+!
+!
+! 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
+!!
+! 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
+!
+! 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
+!
+! 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
+!
+! 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
+!
+! 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
+!
+! 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
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_model.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_model.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_model.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,274 @@
+!=====================================================================
+!
+! 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 get_model(myrank,nspec,ibool,mat_ext_mesh,nelmnts_ext_mesh, &
+ materials_ext_mesh,nmat_ext_mesh, &
+ undef_mat_prop,nundefMat_ext_mesh, &
+ ANISOTROPY)
+
+ use create_regions_mesh_ext_par
+ implicit none
+
+ ! number of spectral elements in each block
+ integer :: myrank,nspec
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+ ! 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(6,nmat_ext_mesh) :: materials_ext_mesh
+ character (len=30), dimension(6,nundefMat_ext_mesh):: undef_mat_prop
+
+ ! anisotropy
+ logical :: ANISOTROPY
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: vp,vs,rho
+ real(kind=CUSTOM_REAL) :: c11,c12,c13,c14,c15,c16,c22,c23,c24,c25, &
+ c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66
+ integer :: ispec,i,j,k,iundef,iflag_atten
+ integer :: iflag,flag_below,flag_above
+ integer :: iflag_aniso,idomain_id,imaterial_id
+
+ ! gll point location
+ double precision :: xloc,yloc,zloc
+ integer :: iglob
+
+ ! initializes element domain flags
+ ispec_is_acoustic(:) = .false.
+ ispec_is_elastic(:) = .false.
+ ispec_is_poroelastic(:) = .false.
+
+ ! prepares tomography model if needed for elements with undefined material definitions
+ if( nundefMat_ext_mesh > 0 ) then
+ call model_tomography_broadcast(myrank)
+ endif
+
+ ! prepares external model values if needed
+ if( USE_MODEL_EXTERNAL_VALUES ) then
+ call model_external_broadcast(myrank)
+ endif
+
+! ! Piero, read bedrock file
+! in case, see file model_interface_bedrock.f90:
+! call model_bedrock_broadcast(myrank)
+
+
+ ! material properties on all GLL points: taken from material values defined for
+ ! each spectral element in input mesh
+ do ispec = 1, nspec
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+
+ ! material index 1: associated material number
+ imaterial_id = mat_ext_mesh(1,ispec)
+
+ ! check if the material is known or unknown
+ if( imaterial_id > 0) then
+ ! gets velocity model as specified by (cubit) mesh files
+
+ ! density
+ ! materials_ext_mesh format:
+ ! #index1 = rho #index2 = vp #index3 = vs #index4 = Q_flag #index5 = 0
+ rho = materials_ext_mesh(1,imaterial_id)
+
+ ! isotropic values: vp, vs
+ vp = materials_ext_mesh(2,imaterial_id)
+ vs = materials_ext_mesh(3,imaterial_id)
+
+ ! attenuation
+ iflag_atten = materials_ext_mesh(4,imaterial_id)
+ !change for piero :
+ !if(mat_ext_mesh(1,ispec) == 1) then
+ ! iflag_attenuation_store(i,j,k,ispec) = 1
+ !else
+ ! iflag_attenuation_store(i,j,k,ispec) = 2
+ !endif
+
+ ! anisotropy
+ iflag_aniso = materials_ext_mesh(5,imaterial_id)
+
+ ! material domain_id
+ idomain_id = materials_ext_mesh(6,imaterial_id)
+
+ 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
+ read(undef_mat_prop(5,iundef),'(1i3)') flag_above
+ endif
+ enddo
+
+ ! see file model_interface_bedrock.f90: routine interface()
+ !call interface(iflag,flag_below,flag_above,ispec,nspec,i,j,k,xstore,ystore,zstore,ibedrock)
+
+ iflag = 1
+ rho = materials_ext_mesh(1,iflag)
+ vp = materials_ext_mesh(2,iflag)
+ vs = materials_ext_mesh(3,iflag)
+ iflag_atten = materials_ext_mesh(4,iflag)
+ !change for piero :
+ ! if(iflag == 1) then
+ ! iflag_attenuation_store(i,j,k,ispec) = 1
+ ! else
+ ! iflag_attenuation_store(i,j,k,ispec) = 2
+ ! endif
+ iflag_aniso = materials_ext_mesh(5,iflag)
+ idomain_id = materials_ext_mesh(6,iflag)
+
+ else if ( imaterial_id < 0 ) then
+
+ ! material definition undefined, uses definition from tomography model
+ ! GLL point location
+ iglob = ibool(i,j,k,ispec)
+ xloc = xstore_dummy(iglob)
+ yloc = ystore_dummy(iglob)
+ zloc = zstore_dummy(iglob)
+
+ ! gets model values from tomography file
+ call model_tomography(xloc,yloc,zloc, &
+ rho,vp,vs)
+
+ iflag_atten = 1 ! attenuation: would use IATTENUATION_SEDIMENTS_40
+ iflag_aniso = 0 ! no anisotropy
+ idomain_id = 2 ! elastic domain
+
+ else
+
+ stop 'material: not implemented yet'
+
+ end if
+
+ ! adds/gets velocity model as specified in model_external_values.f90
+ if( USE_MODEL_EXTERNAL_VALUES ) then
+ call model_external_values(i,j,k,ispec,idomain_id,imaterial_id, &
+ nspec,ibool, &
+ iflag_aniso,iflag_atten, &
+ rho,vp,vs, &
+ c11,c12,c13,c14,c15,c16, &
+ c22,c23,c24,c25,c26,c33, &
+ c34,c35,c36,c44,c45,c46, &
+ c55,c56,c66,ANISOTROPY)
+ endif
+
+ ! adds anisotropic default model
+ if( ANISOTROPY .and. .not. USE_MODEL_EXTERNAL_VALUES ) then
+ call model_aniso(iflag_aniso,rho,vp,vs,c11,c12,c13,c14,c15,c16, &
+ c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45, &
+ c46,c55,c56,c66)
+
+ endif
+
+ ! stores velocity model
+
+ ! density
+ rhostore(i,j,k,ispec) = rho
+
+ ! kappa, mu
+ kappastore(i,j,k,ispec) = rho*( vp*vp - FOUR_THIRDS*vs*vs )
+ mustore(i,j,k,ispec) = rho*vs*vs
+
+ ! attenuation
+ iflag_attenuation_store(i,j,k,ispec) = iflag_atten
+
+ ! Stacey, a completer par la suite
+ rho_vp(i,j,k,ispec) = rho*vp
+ rho_vs(i,j,k,ispec) = rho*vs
+ !end pll
+
+ ! adds anisotropic perturbation to vp, vs
+ if( ANISOTROPY ) then
+ !call model_aniso(iflag_aniso,rho,vp,vs,c11,c12,c13,c14,c15,c16, &
+ ! c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66)
+ c11store(i,j,k,ispec) = c11
+ c12store(i,j,k,ispec) = c12
+ c13store(i,j,k,ispec) = c13
+ c14store(i,j,k,ispec) = c14
+ c15store(i,j,k,ispec) = c15
+ c16store(i,j,k,ispec) = c16
+ c22store(i,j,k,ispec) = c22
+ c23store(i,j,k,ispec) = c23
+ c24store(i,j,k,ispec) = c24
+ c25store(i,j,k,ispec) = c25
+ c26store(i,j,k,ispec) = c26
+ c33store(i,j,k,ispec) = c33
+ c34store(i,j,k,ispec) = c34
+ c35store(i,j,k,ispec) = c35
+ c36store(i,j,k,ispec) = c36
+ c44store(i,j,k,ispec) = c44
+ c45store(i,j,k,ispec) = c45
+ c46store(i,j,k,ispec) = c46
+ c55store(i,j,k,ispec) = c55
+ c56store(i,j,k,ispec) = c56
+ c66store(i,j,k,ispec) = c66
+ endif
+
+ ! material domain
+ !print*,'velocity model:',ispec,idomain_id
+ if( idomain_id == IDOMAIN_ACOUSTIC ) then
+ ispec_is_acoustic(ispec) = .true.
+ else if( idomain_id == IDOMAIN_ELASTIC ) then
+ ispec_is_elastic(ispec) = .true.
+ else if( idomain_id == IDOMAIN_POROELASTIC ) then
+ stop 'poroelastic material domain not implemented yet'
+ ispec_is_poroelastic(ispec) = .true.
+ else
+ stop 'error material domain index'
+ endif
+
+ enddo
+ enddo
+ enddo
+ !print*,myrank,'ispec:',ispec,'rho:',rhostore(1,1,1,ispec),'vp:',vpstore(1,1,1,ispec),'vs:',vsstore(1,1,1,ispec)
+ enddo
+
+ ! checks material domains
+ do ispec=1,nspec
+ if( (ispec_is_acoustic(ispec) .eqv. .false.) &
+ .and. (ispec_is_elastic(ispec) .eqv. .false.) &
+ .and. (ispec_is_poroelastic(ispec) .eqv. .false.) ) then
+ print*,'error material domain not assigned to element:',ispec
+ print*,'acoustic: ',ispec_is_acoustic(ispec)
+ print*,'elastic: ',ispec_is_elastic(ispec)
+ print*,'poroelastic: ',ispec_is_poroelastic(ispec)
+ stop 'error material domain index element'
+ endif
+ 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
+! in case, see file model_interface_bedrock.f90: routine model_bedrock_store()
+
+ end subroutine get_model
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_shape2D.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_shape2D.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_shape2D.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,120 @@
+!=====================================================================
+!
+! 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 get_shape2D(myrank,shape2D,dershape2D,xigll,yigll,NGLLA,NGLLB)
+
+ implicit none
+
+ include "constants.h"
+
+! generic routine that accepts any polynomial degree in each direction
+
+ integer NGLLA,NGLLB,myrank
+
+ double precision xigll(NGLLA)
+ double precision yigll(NGLLB)
+
+! 2D shape functions and their derivatives
+ double precision shape2D(NGNOD2D,NGLLA,NGLLB)
+ double precision dershape2D(NDIM2D,NGNOD2D,NGLLA,NGLLB)
+
+ integer i,j,ia
+
+! location of the nodes of the 2D quadrilateral elements
+ double precision xi,eta
+ double precision xi_map,eta_map
+
+! for checking the 2D shape functions
+ double precision sumshape,sumdershapexi,sumdershapeeta
+
+! 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')
+
+! generate the 2D shape functions and their derivatives (4 nodes)
+ do i=1,NGLLA
+
+ xi=xigll(i)
+
+ do j=1,NGLLB
+
+ eta=yigll(j)
+
+! map coordinates to [0,1]
+ xi_map = (xi + 1.) / 2.
+ eta_map = (eta + 1.) / 2.
+
+! corner nodes
+ shape2D(1,i,j) = (1 - xi_map)*(1 - eta_map)
+ shape2D(2,i,j) = xi_map*(1 - eta_map)
+ shape2D(3,i,j) = xi_map*eta_map
+ shape2D(4,i,j) = (1 - xi_map)*eta_map
+
+ dershape2D(1,1,i,j) = (eta - 1.) / 4.
+ dershape2D(2,1,i,j) = (xi - 1.) / 4.
+
+ dershape2D(1,2,i,j) = (1. - eta) / 4.
+ dershape2D(2,2,i,j) = (-1. - xi) / 4.
+
+ dershape2D(1,3,i,j) = (1. + eta) / 4.
+ dershape2D(2,3,i,j) = (1. + xi) / 4.
+
+ dershape2D(1,4,i,j) = (- 1. - eta) / 4.
+ dershape2D(2,4,i,j) = (1. - xi) / 4.
+
+ enddo
+ enddo
+
+! check the 2D shape functions
+ do i=1,NGLLA
+ do j=1,NGLLB
+
+ sumshape=ZERO
+
+ sumdershapexi=ZERO
+ sumdershapeeta=ZERO
+
+ do ia=1,NGNOD2D
+ sumshape=sumshape+shape2D(ia,i,j)
+
+ sumdershapexi=sumdershapexi+dershape2D(1,ia,i,j)
+ sumdershapeeta=sumdershapeeta+dershape2D(2,ia,i,j)
+ enddo
+
+! the sum of the shape functions should be 1
+ if(abs(sumshape-ONE)>TINYVAL) call exit_MPI(myrank,'error in 2D shape functions')
+
+! the sum of the derivatives of the shape functions should be 0
+ if(abs(sumdershapexi)>TINYVAL) &
+ call exit_MPI(myrank,'error in xi derivatives of 2D shape function')
+
+ if(abs(sumdershapeeta)>TINYVAL) &
+ call exit_MPI(myrank,'error in eta derivatives of 2D shape function')
+
+ enddo
+ enddo
+
+ end subroutine get_shape2D
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_shape3D.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_shape3D.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_shape3D.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,269 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! 3D shape functions for 8-node element
+
+ subroutine get_shape3D(myrank,shape3D,dershape3D,xigll,yigll,zigll)
+
+ implicit none
+
+ include "constants.h"
+
+ integer myrank
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision xigll(NGLLX)
+ double precision yigll(NGLLY)
+ double precision zigll(NGLLZ)
+
+! 3D shape functions and their derivatives
+ double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ)
+ double precision dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ)
+
+ integer i,j,k,ia
+
+! location of the nodes of the 3D quadrilateral elements
+ double precision xi,eta,gamma
+ double precision ra1,ra2,rb1,rb2,rc1,rc2
+
+! for checking the 3D shape functions
+ double precision sumshape,sumdershapexi,sumdershapeeta,sumdershapegamma
+
+ double precision, parameter :: ONE_EIGHTH = 0.125d0
+
+! check that the parameter file is correct
+ if(NGNOD /= 8) call exit_MPI(myrank,'elements should have 8 control nodes')
+
+! ***
+! *** create 3D shape functions and jacobian
+! ***
+
+!--- case of a 3D 8-node element (Dhatt-Touzot p. 115)
+
+ do i=1,NGLLX
+ do j=1,NGLLY
+ do k=1,NGLLZ
+
+ xi = xigll(i)
+ eta = yigll(j)
+ gamma = zigll(k)
+
+ ra1 = one + xi
+ ra2 = one - xi
+
+ rb1 = one + eta
+ rb2 = one - eta
+
+ rc1 = one + gamma
+ rc2 = one - gamma
+
+ shape3D(1,i,j,k) = ONE_EIGHTH*ra2*rb2*rc2
+ shape3D(2,i,j,k) = ONE_EIGHTH*ra1*rb2*rc2
+ shape3D(3,i,j,k) = ONE_EIGHTH*ra1*rb1*rc2
+ shape3D(4,i,j,k) = ONE_EIGHTH*ra2*rb1*rc2
+ shape3D(5,i,j,k) = ONE_EIGHTH*ra2*rb2*rc1
+ shape3D(6,i,j,k) = ONE_EIGHTH*ra1*rb2*rc1
+ shape3D(7,i,j,k) = ONE_EIGHTH*ra1*rb1*rc1
+ shape3D(8,i,j,k) = ONE_EIGHTH*ra2*rb1*rc1
+
+ dershape3D(1,1,i,j,k) = - ONE_EIGHTH*rb2*rc2
+ dershape3D(1,2,i,j,k) = ONE_EIGHTH*rb2*rc2
+ dershape3D(1,3,i,j,k) = ONE_EIGHTH*rb1*rc2
+ dershape3D(1,4,i,j,k) = - ONE_EIGHTH*rb1*rc2
+ dershape3D(1,5,i,j,k) = - ONE_EIGHTH*rb2*rc1
+ dershape3D(1,6,i,j,k) = ONE_EIGHTH*rb2*rc1
+ dershape3D(1,7,i,j,k) = ONE_EIGHTH*rb1*rc1
+ dershape3D(1,8,i,j,k) = - ONE_EIGHTH*rb1*rc1
+
+ dershape3D(2,1,i,j,k) = - ONE_EIGHTH*ra2*rc2
+ dershape3D(2,2,i,j,k) = - ONE_EIGHTH*ra1*rc2
+ dershape3D(2,3,i,j,k) = ONE_EIGHTH*ra1*rc2
+ dershape3D(2,4,i,j,k) = ONE_EIGHTH*ra2*rc2
+ dershape3D(2,5,i,j,k) = - ONE_EIGHTH*ra2*rc1
+ dershape3D(2,6,i,j,k) = - ONE_EIGHTH*ra1*rc1
+ dershape3D(2,7,i,j,k) = ONE_EIGHTH*ra1*rc1
+ dershape3D(2,8,i,j,k) = ONE_EIGHTH*ra2*rc1
+
+ dershape3D(3,1,i,j,k) = - ONE_EIGHTH*ra2*rb2
+ dershape3D(3,2,i,j,k) = - ONE_EIGHTH*ra1*rb2
+ dershape3D(3,3,i,j,k) = - ONE_EIGHTH*ra1*rb1
+ dershape3D(3,4,i,j,k) = - ONE_EIGHTH*ra2*rb1
+ dershape3D(3,5,i,j,k) = ONE_EIGHTH*ra2*rb2
+ dershape3D(3,6,i,j,k) = ONE_EIGHTH*ra1*rb2
+ dershape3D(3,7,i,j,k) = ONE_EIGHTH*ra1*rb1
+ dershape3D(3,8,i,j,k) = ONE_EIGHTH*ra2*rb1
+
+ enddo
+ enddo
+ enddo
+
+!--- check the shape functions and their derivatives
+
+ do i=1,NGLLX
+ do j=1,NGLLY
+ do k=1,NGLLZ
+
+ sumshape = ZERO
+ sumdershapexi = ZERO
+ sumdershapeeta = ZERO
+ sumdershapegamma = ZERO
+
+ do ia=1,NGNOD
+ sumshape = sumshape + shape3D(ia,i,j,k)
+ sumdershapexi = sumdershapexi + dershape3D(1,ia,i,j,k)
+ sumdershapeeta = sumdershapeeta + dershape3D(2,ia,i,j,k)
+ sumdershapegamma = sumdershapegamma + dershape3D(3,ia,i,j,k)
+ enddo
+
+! sum of shape functions should be one
+! sum of derivative of shape functions should be zero
+ if(abs(sumshape-one) > TINYVAL) call exit_MPI(myrank,'error shape functions')
+ if(abs(sumdershapexi) > TINYVAL) call exit_MPI(myrank,'error derivative xi shape functions')
+ if(abs(sumdershapeeta) > TINYVAL) call exit_MPI(myrank,'error derivative eta shape functions')
+ if(abs(sumdershapegamma) > TINYVAL) call exit_MPI(myrank,'error derivative gamma shape functions')
+
+ enddo
+ enddo
+ enddo
+
+ end subroutine get_shape3D
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+! 3D shape functions for given, single xi/eta/gamma location
+
+ subroutine get_shape3D_single(myrank,shape3D,xi,eta,gamma)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: myrank
+
+ ! 3D shape functions
+ double precision :: shape3D(NGNOD)
+
+ ! location
+ double precision :: xi,eta,gamma
+
+ ! local parameters
+ double precision :: ra1,ra2,rb1,rb2,rc1,rc2
+ double precision, parameter :: ONE_EIGHTH = 0.125d0
+ double precision :: sumshape
+ integer :: ia
+
+! check that the parameter file is correct
+ if(NGNOD /= 8) call exit_MPI(myrank,'elements should have 8 control nodes')
+
+!--- case of a 3D 8-node element (Dhatt-Touzot p. 115)
+ ra1 = one + xi
+ ra2 = one - xi
+
+ rb1 = one + eta
+ rb2 = one - eta
+
+ rc1 = one + gamma
+ rc2 = one - gamma
+
+ ! shape functions
+ shape3D(1) = ONE_EIGHTH*ra2*rb2*rc2
+ shape3D(2) = ONE_EIGHTH*ra1*rb2*rc2
+ shape3D(3) = ONE_EIGHTH*ra1*rb1*rc2
+ shape3D(4) = ONE_EIGHTH*ra2*rb1*rc2
+ shape3D(5) = ONE_EIGHTH*ra2*rb2*rc1
+ shape3D(6) = ONE_EIGHTH*ra1*rb2*rc1
+ shape3D(7) = ONE_EIGHTH*ra1*rb1*rc1
+ shape3D(8) = ONE_EIGHTH*ra2*rb1*rc1
+
+ ! check the shape functions
+ sumshape = ZERO
+ do ia=1,NGNOD
+ sumshape = sumshape + shape3D(ia)
+ enddo
+
+ ! sum of shape functions should be one
+ ! sum of derivative of shape functions should be zero
+ if(abs(sumshape-one) > TINYVAL) call exit_MPI(myrank,'error single shape functions')
+
+ end subroutine get_shape3D_single
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine get_shape3D_element_corners(xelm,yelm,zelm,ispec,&
+ ibool,xstore,ystore,zstore,NSPEC_AB,NGLOB_AB)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: ispec
+ integer :: NSPEC_AB,NGLOB_AB
+
+ real(kind=CUSTOM_REAL),dimension(NGNOD),intent(out) :: xelm,yelm,zelm
+
+ ! mesh coordinates
+ real(kind=CUSTOM_REAL),dimension(NGLOB_AB) :: xstore,ystore,zstore
+ integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! 8 node corners
+ xelm(1)=xstore(ibool(1,1,1,ispec))
+ yelm(1)=ystore(ibool(1,1,1,ispec))
+ zelm(1)=zstore(ibool(1,1,1,ispec))
+
+ xelm(2)=xstore(ibool(NGLLX,1,1,ispec))
+ yelm(2)=ystore(ibool(NGLLX,1,1,ispec))
+ zelm(2)=zstore(ibool(NGLLX,1,1,ispec))
+
+ xelm(3)=xstore(ibool(NGLLX,NGLLY,1,ispec))
+ yelm(3)=ystore(ibool(NGLLX,NGLLY,1,ispec))
+ zelm(3)=zstore(ibool(NGLLX,NGLLY,1,ispec))
+
+ xelm(4)=xstore(ibool(1,NGLLY,1,ispec))
+ yelm(4)=ystore(ibool(1,NGLLY,1,ispec))
+ zelm(4)=zstore(ibool(1,NGLLY,1,ispec))
+
+ xelm(5)=xstore(ibool(1,1,NGLLZ,ispec))
+ yelm(5)=ystore(ibool(1,1,NGLLZ,ispec))
+ zelm(5)=zstore(ibool(1,1,NGLLZ,ispec))
+
+ xelm(6)=xstore(ibool(NGLLX,1,NGLLZ,ispec))
+ yelm(6)=ystore(ibool(NGLLX,1,NGLLZ,ispec))
+ zelm(6)=zstore(ibool(NGLLX,1,NGLLZ,ispec))
+
+ xelm(7)=xstore(ibool(NGLLX,NGLLY,NGLLZ,ispec))
+ yelm(7)=ystore(ibool(NGLLX,NGLLY,NGLLZ,ispec))
+ zelm(7)=zstore(ibool(NGLLX,NGLLY,NGLLZ,ispec))
+
+ xelm(8)=xstore(ibool(1,NGLLY,NGLLZ,ispec))
+ yelm(8)=ystore(ibool(1,NGLLY,NGLLZ,ispec))
+ zelm(8)=zstore(ibool(1,NGLLY,NGLLZ,ispec))
+
+ end subroutine get_shape3D_element_corners
+
+
\ No newline at end of file
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_value_parameters.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_value_parameters.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/get_value_parameters.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,97 @@
+!=====================================================================
+!
+! 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 get_value_integer(value_to_get, name, default_value)
+
+ implicit none
+
+ integer value_to_get, default_value
+ character(len=*) name
+
+ call unused_string(name)
+
+ value_to_get = default_value
+
+ end subroutine get_value_integer
+
+!--------------------
+
+ subroutine get_value_double_precision(value_to_get, name, default_value)
+
+ implicit none
+
+ double precision value_to_get, default_value
+ character(len=*) name
+
+ call unused_string(name)
+
+ value_to_get = default_value
+
+ end subroutine get_value_double_precision
+
+!--------------------
+
+ subroutine get_value_logical(value_to_get, name, default_value)
+
+ implicit none
+
+ logical value_to_get, default_value
+ character(len=*) name
+
+ call unused_string(name)
+
+ value_to_get = default_value
+
+ end subroutine get_value_logical
+
+!--------------------
+
+ subroutine get_value_string(value_to_get, name, default_value)
+
+ implicit none
+
+ character(len=*) value_to_get, default_value
+ character(len=*) name
+
+ call unused_string(name)
+
+ value_to_get = default_value
+
+ end subroutine get_value_string
+
+!--------------------
+
+! dummy subroutine to avoid warnings about variable not used in other subroutines
+ subroutine unused_string(s)
+
+ implicit none
+
+ character(len=*) s
+
+ if (len(s) == 1) continue
+
+ end subroutine unused_string
+
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/gll_library.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/gll_library.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/gll_library.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,529 @@
+
+!=======================================================================
+!
+! Library to compute the Gauss-Lobatto-Legendre points and weights
+! Based on Gauss-Lobatto routines from M.I.T.
+! Department of Mechanical Engineering
+!
+!=======================================================================
+
+ double precision function endw1(n,alpha,beta)
+
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+ double precision, external :: gammaf
+ integer i
+
+ f3 = zero
+ apb = alpha+beta
+ if (n == 0) then
+ endw1 = zero
+ return
+ endif
+ f1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if (n == 1) then
+ endw1 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+two)*gammaf(beta+one)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (-two*(beta+two)*fint1 + (apb+four)*fint2) * (apb+three)/four
+ if (n == 2) then
+ endw1 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw1 = f3
+
+ end function endw1
+
+!
+!=======================================================================
+!
+
+ double precision function endw2(n,alpha,beta)
+
+ implicit none
+
+ integer n
+ double precision alpha,beta
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0,three=3.d0,four=4.d0
+ double precision apb,f1,fint1,fint2,f2,di,abn,abnn,a1,a2,a3,f3
+ double precision, external :: gammaf
+ integer i
+
+ apb = alpha+beta
+ f3 = zero
+ if (n == 0) then
+ endw2 = zero
+ return
+ endif
+ f1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ f1 = f1*(apb+two)*two**(apb+two)/two
+ if (n == 1) then
+ endw2 = f1
+ return
+ endif
+ fint1 = gammaf(alpha+one)*gammaf(beta+two)/gammaf(apb+three)
+ fint1 = fint1*two**(apb+two)
+ fint2 = gammaf(alpha+two)*gammaf(beta+two)/gammaf(apb+four)
+ fint2 = fint2*two**(apb+three)
+ f2 = (two*(alpha+two)*fint1 - (apb+four)*fint2) * (apb+three)/four
+ if (n == 2) then
+ endw2 = f2
+ return
+ endif
+ do i=3,n
+ di = dble(i-1)
+ abn = alpha+beta+di
+ abnn = abn+di
+ a1 = -(two*(di+alpha)*(di+beta))/(abn*abnn*(abnn+one))
+ a2 = (two*(alpha-beta))/(abnn*(abnn+two))
+ a3 = (two*(abn+one))/((abnn+two)*(abnn+one))
+ f3 = -(a2*f2+a1*f1)/a3
+ f1 = f2
+ f2 = f3
+ enddo
+ endw2 = f3
+
+ end function endw2
+
+!
+!=======================================================================
+!
+
+ double precision function gammaf (x)
+
+ implicit none
+
+ double precision, parameter :: pi = 3.141592653589793d0
+
+ double precision x
+
+ double precision, parameter :: half=0.5d0,one=1.d0,two=2.d0
+
+ gammaf = one
+
+ if (x == -half) gammaf = -two*dsqrt(pi)
+ if (x == half) gammaf = dsqrt(pi)
+ if (x == one ) gammaf = one
+ if (x == two ) gammaf = one
+ if (x == 1.5d0) gammaf = dsqrt(pi)/2.d0
+ if (x == 2.5d0) gammaf = 1.5d0*dsqrt(pi)/2.d0
+ if (x == 3.5d0) gammaf = 2.5d0*1.5d0*dsqrt(pi)/2.d0
+ if (x == 3.d0 ) gammaf = 2.d0
+ if (x == 4.d0 ) gammaf = 6.d0
+ if (x == 5.d0 ) gammaf = 24.d0
+ if (x == 6.d0 ) gammaf = 120.d0
+
+ end function gammaf
+
+!
+!=====================================================================
+!
+
+ subroutine jacg (xjac,np,alpha,beta)
+
+!=======================================================================
+!
+! computes np Gauss points, which are the zeros of the
+! Jacobi polynomial with parameters alpha and beta
+!
+! .alpha = beta = 0.0 -> Legendre points
+! .alpha = beta = -0.5 -> Chebyshev points
+!
+!=======================================================================
+
+ implicit none
+
+ integer np
+ double precision alpha,beta
+ double precision xjac(np)
+
+ integer k,j,i,jmin,jm,n
+ double precision xlast,dth,x,x1,x2,recsum,delx,xmin,swap
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+
+ integer, parameter :: K_MAX_ITER = 10
+ double precision, parameter :: zero = 0.d0, eps = 1.0d-12
+
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ xlast = 0.d0
+ n = np-1
+ dth = 4.d0*datan(1.d0)/(2.d0*dble(n)+2.d0)
+ p = 0.d0
+ pd = 0.d0
+ jmin = 0
+ do j=1,np
+ if(j == 1) then
+ x = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
+ else
+ x1 = dcos((2.d0*(dble(j)-1.d0)+1.d0)*dth)
+ x2 = xlast
+ x = (x1+x2)/2.d0
+ endif
+ do k=1,K_MAX_ITER
+ call jacobf (p,pd,pm1,pdm1,pm2,pdm2,np,alpha,beta,x)
+ recsum = 0.d0
+ jm = j-1
+ do i=1,jm
+ recsum = recsum+1.d0/(x-xjac(np-i+1))
+ enddo
+ delx = -p/(pd-recsum*p)
+ x = x+delx
+ if(abs(delx) < eps) goto 31
+ enddo
+ 31 continue
+ xjac(np-j+1) = x
+ xlast = x
+ enddo
+ do i=1,np
+ xmin = 2.d0
+ do j=i,np
+ if(xjac(j) < xmin) then
+ xmin = xjac(j)
+ jmin = j
+ endif
+ enddo
+ if(jmin /= i) then
+ swap = xjac(i)
+ xjac(i) = xjac(jmin)
+ xjac(jmin) = swap
+ endif
+ enddo
+
+ end subroutine jacg
+
+!
+!=====================================================================
+!
+
+ subroutine jacobf (poly,pder,polym1,pderm1,polym2,pderm2,n,alp,bet,x)
+
+!=======================================================================
+!
+! Computes the Jacobi polynomial of degree n and its derivative at x
+!
+!=======================================================================
+
+ implicit none
+
+ double precision poly,pder,polym1,pderm1,polym2,pderm2,alp,bet,x
+ integer n
+
+ double precision apb,polyl,pderl,dk,a1,a2,b3,a3,a4,polyn,pdern,psave,pdsave
+ integer k
+
+ apb = alp+bet
+ poly = 1.d0
+ pder = 0.d0
+ psave = 0.d0
+ pdsave = 0.d0
+
+ if (n == 0) return
+
+ polyl = poly
+ pderl = pder
+ poly = (alp-bet+(apb+2.d0)*x)/2.d0
+ pder = (apb+2.d0)/2.d0
+ if (n == 1) return
+
+ do k=2,n
+ dk = dble(k)
+ a1 = 2.d0*dk*(dk+apb)*(2.d0*dk+apb-2.d0)
+ a2 = (2.d0*dk+apb-1.d0)*(alp**2-bet**2)
+ b3 = (2.d0*dk+apb-2.d0)
+ a3 = b3*(b3+1.d0)*(b3+2.d0)
+ a4 = 2.d0*(dk+alp-1.d0)*(dk+bet-1.d0)*(2.d0*dk+apb)
+ polyn = ((a2+a3*x)*poly-a4*polyl)/a1
+ pdern = ((a2+a3*x)*pder-a4*pderl+a3*poly)/a1
+ psave = polyl
+ pdsave = pderl
+ polyl = poly
+ poly = polyn
+ pderl = pder
+ pder = pdern
+ enddo
+
+ polym1 = polyl
+ pderm1 = pderl
+ polym2 = psave
+ pderm2 = pdsave
+
+ end subroutine jacobf
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision FUNCTION PNDLEG (Z,N)
+
+!------------------------------------------------------------------------
+!
+! Compute the derivative of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!------------------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P1D,P2D,P3D,FK,P3
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P1D = 0.d0
+ P2D = 1.d0
+ P3D = 1.d0
+
+ do K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P3D = ((2.d0*FK+1.d0)*P2 + (2.d0*FK+1.d0)*Z*P2D - FK*P1D) / (FK+1.d0)
+ P1 = P2
+ P2 = P3
+ P1D = P2D
+ P2D = P3D
+ enddo
+
+ PNDLEG = P3D
+
+ end function pndleg
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision FUNCTION PNLEG (Z,N)
+
+!------------------------------------------------------------------------
+!
+! Compute the value of the Nth order Legendre polynomial at Z.
+! Based on the recursion formula for the Legendre polynomials.
+!
+!------------------------------------------------------------------------
+ implicit none
+
+ double precision z
+ integer n
+
+ double precision P1,P2,P3,FK
+ integer k
+
+ P1 = 1.d0
+ P2 = Z
+ P3 = P2
+
+ do K = 1, N-1
+ FK = dble(K)
+ P3 = ((2.d0*FK+1.d0)*Z*P2 - FK*P1)/(FK+1.d0)
+ P1 = P2
+ P2 = P3
+ enddo
+
+ PNLEG = P3
+
+ end function pnleg
+
+!
+!------------------------------------------------------------------------
+!
+
+ double precision function pnormj (n,alpha,beta)
+
+ implicit none
+
+ double precision alpha,beta
+ integer n
+
+ double precision one,two,dn,const,prod,dindx,frac
+ double precision, external :: gammaf
+ integer i
+
+ one = 1.d0
+ two = 2.d0
+ dn = dble(n)
+ const = alpha+beta+one
+
+ if (n <= 1) then
+ prod = gammaf(dn+alpha)*gammaf(dn+beta)
+ prod = prod/(gammaf(dn)*gammaf(dn+alpha+beta))
+ pnormj = prod * two**const/(two*dn+const)
+ return
+ endif
+
+ prod = gammaf(alpha+one)*gammaf(beta+one)
+ prod = prod/(two*(one+const)*gammaf(const+one))
+ prod = prod*(one+alpha)*(two+alpha)
+ prod = prod*(one+beta)*(two+beta)
+
+ do i=3,n
+ dindx = dble(i)
+ frac = (dindx+alpha)*(dindx+beta)/(dindx*(dindx+alpha+beta))
+ prod = prod*frac
+ enddo
+
+ pnormj = prod * two**const/(two*dn+const)
+
+ end function pnormj
+
+!
+!------------------------------------------------------------------------
+!
+
+ subroutine zwgjd(z,w,np,alpha,beta)
+
+!=======================================================================
+!
+! Z w g j d : Generate np Gauss-Jacobi points and weights
+! associated with Jacobi polynomial of degree n = np-1
+!
+! Note : Coefficients alpha and beta must be greater than -1.
+! ----
+!=======================================================================
+
+ implicit none
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision z(np),w(np)
+ double precision alpha,beta
+
+ integer n,np1,np2,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision apb,dnp1,dnp2,fac1,fac2,fac3,fnorm,rcoef
+ double precision, external :: gammaf,pnormj
+
+ pd = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ apb = alpha+beta
+ p = zero
+ pdm1 = zero
+
+ if (np <= 0) stop 'minimum number of Gauss points is 1'
+
+ if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
+
+ if (np == 1) then
+ z(1) = (beta-alpha)/(apb+two)
+ w(1) = gammaf(alpha+one)*gammaf(beta+one)/gammaf(apb+two) * two**(apb+one)
+ return
+ endif
+
+ call jacg(z,np,alpha,beta)
+
+ np1 = n+1
+ np2 = n+2
+ dnp1 = dble(np1)
+ dnp2 = dble(np2)
+ fac1 = dnp1+alpha+beta+one
+ fac2 = fac1+dnp1
+ fac3 = fac2+one
+ fnorm = pnormj(np1,alpha,beta)
+ rcoef = (fnorm*fac2*fac3)/(two*fac1*dnp2)
+ do i=1,np
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,np2,alpha,beta,z(i))
+ w(i) = -rcoef/(p*pdm1)
+ enddo
+
+ end subroutine zwgjd
+
+!
+!------------------------------------------------------------------------
+!
+
+ subroutine zwgljd(z,w,np,alpha,beta)
+
+!=======================================================================
+!
+! Z w g l j d : Generate np Gauss-Lobatto-Jacobi points and the
+! ----------- weights associated with Jacobi polynomials of degree
+! n = np-1.
+!
+! Note : alpha and beta coefficients must be greater than -1.
+! Legendre polynomials are special case of Jacobi polynomials
+! just by setting alpha and beta to 0.
+!
+!=======================================================================
+
+ implicit none
+
+ double precision, parameter :: zero=0.d0,one=1.d0,two=2.d0
+
+ integer np
+ double precision alpha,beta
+ double precision z(np), w(np)
+
+ integer n,nm1,i
+ double precision p,pd,pm1,pdm1,pm2,pdm2
+ double precision alpg,betg
+ double precision, external :: endw1,endw2
+
+ p = zero
+ pm1 = zero
+ pm2 = zero
+ pdm1 = zero
+ pdm2 = zero
+
+ n = np-1
+ nm1 = n-1
+ pd = zero
+
+ if (np <= 1) stop 'minimum number of Gauss-Lobatto points is 2'
+
+! with spectral elements, use at least 3 points
+ if (np <= 2) stop 'minimum number of Gauss-Lobatto points for the SEM is 3'
+
+ if ((alpha <= -one) .or. (beta <= -one)) stop 'alpha and beta must be greater than -1'
+
+ if (nm1 > 0) then
+ alpg = alpha+one
+ betg = beta+one
+ call zwgjd(z(2),w(2),nm1,alpg,betg)
+ endif
+
+ z(1) = - one
+ z(np) = one
+
+ do i=2,np-1
+ w(i) = w(i)/(one-z(i)**2)
+ enddo
+
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(1))
+ w(1) = endw1(n,alpha,beta)/(two*pd)
+ call jacobf(p,pd,pm1,pdm1,pm2,pdm2,n,alpha,beta,z(np))
+ w(np) = endw2(n,alpha,beta)/(two*pd)
+
+ end subroutine zwgljd
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/hauksson_model.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/hauksson_model.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/hauksson_model.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,227 @@
+!=====================================================================
+!
+! 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 hauksson_model(vp,vs,utm_x_eval,utm_y_eval,z_eval,vp_final,vs_final,MOHO_MAP_LUPEI)
+
+ implicit none
+
+ include "constants.h"
+ include "constants_gocad.h"
+
+!! DK DK UGLY one day, we should clarify the issue of merging Hauksson's Moho
+!! DK DK UGLY with our Lupei Moho. Should not be a big issue because in
+!! DK DK UGLY principle Hauksson used Lupei's map to build his model
+
+ double precision utm_x_eval,utm_y_eval,z_eval
+ double precision vp_final,vs_final
+ logical MOHO_MAP_LUPEI
+
+ double precision, dimension(NLAYERS_HAUKSSON,NGRID_NEW_HAUKSSON,NGRID_NEW_HAUKSSON) :: vp,vs
+ double precision, dimension(NLAYERS_HAUKSSON) :: vp_interp,vs_interp
+
+ integer ilayer
+ integer icell_interp_x,icell_interp_y
+ double precision spacing_x,spacing_y
+ double precision utm_x_eval_copy,utm_y_eval_copy
+ double precision gamma_interp_x,gamma_interp_y,gamma_interp_z
+ double precision v1,v2,v3,v4
+ double precision vp_upper,vs_upper,vp_lower,vs_lower,z_upper,z_lower
+
+! copy input values
+ utm_x_eval_copy = utm_x_eval
+ utm_y_eval_copy = utm_y_eval
+
+! make sure we stay inside Hauksson's grid
+ if(utm_x_eval_copy < UTM_X_ORIG_HAUKSSON) utm_x_eval_copy = UTM_X_ORIG_HAUKSSON
+ if(utm_y_eval_copy < UTM_Y_ORIG_HAUKSSON) utm_y_eval_copy = UTM_Y_ORIG_HAUKSSON
+
+! determine spacing and cell for linear interpolation
+ spacing_x = (utm_x_eval_copy - UTM_X_ORIG_HAUKSSON) / SPACING_UTM_X_HAUKSSON
+ spacing_y = (utm_y_eval_copy - UTM_Y_ORIG_HAUKSSON) / SPACING_UTM_Y_HAUKSSON
+
+ icell_interp_x = int(spacing_x) + 1
+ icell_interp_y = int(spacing_y) + 1
+
+ gamma_interp_x = spacing_x - int(spacing_x)
+ gamma_interp_y = spacing_y - int(spacing_y)
+
+! suppress edge effects for points outside of Hauksson's model
+ if(icell_interp_x < 1) then
+ icell_interp_x = 1
+ gamma_interp_x = 0.d0
+ endif
+ if(icell_interp_x > NGRID_NEW_HAUKSSON-1) then
+ icell_interp_x = NGRID_NEW_HAUKSSON-1
+ gamma_interp_x = 1.d0
+ endif
+
+ if(icell_interp_y < 1) then
+ icell_interp_y = 1
+ gamma_interp_y = 0.d0
+ endif
+ if(icell_interp_y > NGRID_NEW_HAUKSSON-1) then
+ icell_interp_y = NGRID_NEW_HAUKSSON-1
+ gamma_interp_y = 1.d0
+ endif
+
+! make sure interpolation makes sense
+ if(gamma_interp_x < -0.001d0 .or. gamma_interp_x > 1.001d0) &
+ stop 'interpolation in x is incorrect in Hauksson'
+ if(gamma_interp_y < -0.001d0 .or. gamma_interp_y > 1.001d0) &
+ stop 'interpolation in y is incorrect in Hauksson'
+
+! interpolate Hauksson's model at right location using bilinear interpolation
+ do ilayer = 1,NLAYERS_HAUKSSON
+
+! for Vp
+ v1 = vp(ilayer,icell_interp_x,icell_interp_y)
+ v2 = vp(ilayer,icell_interp_x+1,icell_interp_y)
+ v3 = vp(ilayer,icell_interp_x+1,icell_interp_y+1)
+ v4 = vp(ilayer,icell_interp_x,icell_interp_y+1)
+
+ vp_interp(ilayer) = v1*(1.-gamma_interp_x)*(1.-gamma_interp_y) + &
+ v2*gamma_interp_x*(1.-gamma_interp_y) + &
+ v3*gamma_interp_x*gamma_interp_y + &
+ v4*(1.-gamma_interp_x)*gamma_interp_y
+
+! for Vs
+ v1 = vs(ilayer,icell_interp_x,icell_interp_y)
+ v2 = vs(ilayer,icell_interp_x+1,icell_interp_y)
+ v3 = vs(ilayer,icell_interp_x+1,icell_interp_y+1)
+ v4 = vs(ilayer,icell_interp_x,icell_interp_y+1)
+
+ vs_interp(ilayer) = v1*(1.-gamma_interp_x)*(1.-gamma_interp_y) + &
+ v2*gamma_interp_x*(1.-gamma_interp_y) + &
+ v3*gamma_interp_x*gamma_interp_y + &
+ v4*(1.-gamma_interp_x)*gamma_interp_y
+
+ enddo
+
+! choose right values depending on depth of target point
+ if(z_eval >= Z_HAUKSSON_LAYER_1) then
+ vp_final = vp_interp(1)
+ vs_final = vs_interp(1)
+ return
+
+ else if(z_eval <= Z_HAUKSSON_LAYER_9) then
+ vp_final = vp_interp(9)
+ vs_final = vs_interp(9)
+ return
+
+ else if(z_eval >= Z_HAUKSSON_LAYER_2) then
+ vp_upper = vp_interp(1)
+ vs_upper = vs_interp(1)
+ z_upper = Z_HAUKSSON_LAYER_1
+
+ vp_lower = vp_interp(2)
+ vs_lower = vs_interp(2)
+ z_lower = Z_HAUKSSON_LAYER_2
+
+ else if(z_eval >= Z_HAUKSSON_LAYER_3) then
+ vp_upper = vp_interp(2)
+ vs_upper = vs_interp(2)
+ z_upper = Z_HAUKSSON_LAYER_2
+
+ vp_lower = vp_interp(3)
+ vs_lower = vs_interp(3)
+ z_lower = Z_HAUKSSON_LAYER_3
+
+ else if(z_eval >= Z_HAUKSSON_LAYER_4) then
+ vp_upper = vp_interp(3)
+ vs_upper = vs_interp(3)
+ z_upper = Z_HAUKSSON_LAYER_3
+
+ vp_lower = vp_interp(4)
+ vs_lower = vs_interp(4)
+ z_lower = Z_HAUKSSON_LAYER_4
+
+ else if(z_eval >= Z_HAUKSSON_LAYER_5) then
+ vp_upper = vp_interp(4)
+ vs_upper = vs_interp(4)
+ z_upper = Z_HAUKSSON_LAYER_4
+
+ vp_lower = vp_interp(5)
+ vs_lower = vs_interp(5)
+ z_lower = Z_HAUKSSON_LAYER_5
+
+ else if(z_eval >= Z_HAUKSSON_LAYER_6) then
+ vp_upper = vp_interp(5)
+ vs_upper = vs_interp(5)
+ z_upper = Z_HAUKSSON_LAYER_5
+
+ vp_lower = vp_interp(6)
+ vs_lower = vs_interp(6)
+ z_lower = Z_HAUKSSON_LAYER_6
+
+ else if(z_eval >= Z_HAUKSSON_LAYER_7) then
+ vp_upper = vp_interp(6)
+ vs_upper = vs_interp(6)
+ z_upper = Z_HAUKSSON_LAYER_6
+
+ vp_lower = vp_interp(7)
+ vs_lower = vs_interp(7)
+ z_lower = Z_HAUKSSON_LAYER_7
+
+ else if(z_eval >= Z_HAUKSSON_LAYER_8) then
+ vp_upper = vp_interp(7)
+ vs_upper = vs_interp(7)
+ z_upper = Z_HAUKSSON_LAYER_7
+
+ vp_lower = vp_interp(8)
+ vs_lower = vs_interp(8)
+ z_lower = Z_HAUKSSON_LAYER_8
+
+ else
+ if(.not. MOHO_MAP_LUPEI) then
+ vp_upper = vp_interp(8)
+ vs_upper = vs_interp(8)
+ z_upper = Z_HAUKSSON_LAYER_8
+
+ vp_lower = vp_interp(9)
+ vs_lower = vs_interp(9)
+ z_lower = Z_HAUKSSON_LAYER_9
+ !!! waiting for better interpolation of Moho maps.
+ else
+ vp_upper = vp_interp(8)
+ vs_upper = vs_interp(8)
+ z_upper = Z_HAUKSSON_LAYER_8
+
+ vp_lower = vp_interp(9)
+ vs_lower = vs_interp(9)
+ z_lower = Z_HAUKSSON_LAYER_9
+ endif
+
+ endif
+
+ gamma_interp_z = (z_eval - z_lower) / (z_upper - z_lower)
+
+ if(gamma_interp_z < -0.001d0 .or. gamma_interp_z > 1.001d0) &
+ stop 'interpolation in z is incorrect in Hauksson'
+
+ vp_final = vp_upper * gamma_interp_z + vp_lower * (1.-gamma_interp_z)
+ vs_final = vs_upper * gamma_interp_z + vs_lower * (1.-gamma_interp_z)
+
+ end subroutine hauksson_model
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/hex_nodes.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/hex_nodes.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/hex_nodes.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,478 @@
+!=====================================================================
+!
+! 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 usual_hex_nodes(iaddx,iaddy,iaddz)
+
+ implicit none
+
+ include "constants.h"
+
+ integer iaddx(NGNOD),iaddy(NGNOD),iaddz(NGNOD)
+
+! define the topology of the hexahedral elements
+
+! check that the parameter file is correct
+ if(NGNOD /= 8) stop 'elements should have 8 control nodes'
+
+! corner nodes
+ iaddx(1)=0
+ iaddy(1)=0
+ iaddz(1)=0
+
+ iaddx(2)=2
+ iaddy(2)=0
+ iaddz(2)=0
+
+ iaddx(3)=2
+ iaddy(3)=2
+ iaddz(3)=0
+
+ iaddx(4)=0
+ iaddy(4)=2
+ iaddz(4)=0
+
+ iaddx(5)=0
+ iaddy(5)=0
+ iaddz(5)=2
+
+ iaddx(6)=2
+ iaddy(6)=0
+ iaddz(6)=2
+
+ iaddx(7)=2
+ iaddy(7)=2
+ iaddz(7)=2
+
+ iaddx(8)=0
+ iaddy(8)=2
+ iaddz(8)=2
+
+ end subroutine usual_hex_nodes
+
+ subroutine unusual_hex_nodes1(iaddx,iaddy,iaddz)
+
+ implicit none
+
+ include "constants.h"
+
+ integer iaddx(NGNOD),iaddy(NGNOD),iaddz(NGNOD)
+
+! define the topology of the hexahedral elements
+
+! corner nodes
+ iaddx(1)=0
+ iaddy(1)=0
+ iaddz(1)=0
+
+ iaddx(2)=4
+ iaddy(2)=0
+ iaddz(2)=0
+
+ iaddx(3)=4
+ iaddy(3)=4
+ iaddz(3)=0
+
+ iaddx(4)=0
+ iaddy(4)=4
+ iaddz(4)=0
+
+ iaddx(5)=2
+ iaddy(5)=0
+ iaddz(5)=2
+
+ iaddx(6)=4
+ iaddy(6)=0
+ iaddz(6)=2
+
+ iaddx(7)=4
+ iaddy(7)=4
+ iaddz(7)=2
+
+ iaddx(8)=2
+ iaddy(8)=4
+ iaddz(8)=2
+
+ end subroutine unusual_hex_nodes1
+
+ subroutine unusual_hex_nodes1p(iaddx,iaddy,iaddz)
+
+ implicit none
+
+ include "constants.h"
+
+ integer iaddx(NGNOD),iaddy(NGNOD),iaddz(NGNOD)
+
+! define the topology of the hexahedral elements
+
+! corner nodes
+ iaddx(1)=0
+ iaddy(1)=0
+ iaddz(1)=0
+
+ iaddx(2)=4
+ iaddy(2)=0
+ iaddz(2)=0
+
+ iaddx(3)=4
+ iaddy(3)=4
+ iaddz(3)=0
+
+ iaddx(4)=0
+ iaddy(4)=4
+ iaddz(4)=0
+
+ iaddx(5)=0
+ iaddy(5)=0
+ iaddz(5)=2
+
+ iaddx(6)=2
+ iaddy(6)=0
+ iaddz(6)=2
+
+ iaddx(7)=2
+ iaddy(7)=4
+ iaddz(7)=2
+
+ iaddx(8)=0
+ iaddy(8)=4
+ iaddz(8)=2
+
+ end subroutine unusual_hex_nodes1p
+
+ subroutine unusual_hex_nodes2(iaddx,iaddy,iaddz)
+
+ implicit none
+
+ include "constants.h"
+
+ integer iaddx(NGNOD),iaddy(NGNOD),iaddz(NGNOD)
+
+! define the topology of the hexahedral elements
+
+! corner nodes
+ iaddx(1)=0
+ iaddy(1)=0
+ iaddz(1)=0
+
+ iaddx(2)=2
+ iaddy(2)=0
+ iaddz(2)=2
+
+ iaddx(3)=2
+ iaddy(3)=4
+ iaddz(3)=2
+
+ iaddx(4)=0
+ iaddy(4)=4
+ iaddz(4)=0
+
+ iaddx(5)=0
+ iaddy(5)=0
+ iaddz(5)=4
+
+ iaddx(6)=2
+ iaddy(6)=0
+ iaddz(6)=4
+
+ iaddx(7)=2
+ iaddy(7)=4
+ iaddz(7)=4
+
+ iaddx(8)=0
+ iaddy(8)=4
+ iaddz(8)=4
+
+ end subroutine unusual_hex_nodes2
+
+ subroutine unusual_hex_nodes2p(iaddx,iaddy,iaddz)
+
+ implicit none
+
+ include "constants.h"
+
+ integer iaddx(NGNOD),iaddy(NGNOD),iaddz(NGNOD)
+
+! define the topology of the hexahedral elements
+
+! corner nodes
+ iaddx(1)=0
+ iaddy(1)=0
+ iaddz(1)=0
+
+ iaddx(2)=2
+ iaddy(2)=0
+ iaddz(2)=-2
+
+ iaddx(3)=2
+ iaddy(3)=4
+ iaddz(3)=-2
+
+ iaddx(4)=0
+ iaddy(4)=4
+ iaddz(4)=0
+
+ iaddx(5)=0
+ iaddy(5)=0
+ iaddz(5)=2
+
+ iaddx(6)=2
+ iaddy(6)=0
+ iaddz(6)=2
+
+ iaddx(7)=2
+ iaddy(7)=4
+ iaddz(7)=2
+
+ iaddx(8)=0
+ iaddy(8)=4
+ iaddz(8)=2
+
+ end subroutine unusual_hex_nodes2p
+
+ subroutine unusual_hex_nodes3(iaddx,iaddy,iaddz)
+
+ implicit none
+
+ include "constants.h"
+
+ integer iaddx(NGNOD),iaddy(NGNOD),iaddz(NGNOD)
+
+! define the topology of the hexahedral elements
+
+! corner nodes
+ iaddx(1)=0
+ iaddy(1)=0
+ iaddz(1)=0
+
+ iaddx(2)=2
+ iaddy(2)=0
+ iaddz(2)=0
+
+ iaddx(3)=2
+ iaddy(3)=4
+ iaddz(3)=0
+
+ iaddx(4)=0
+ iaddy(4)=4
+ iaddz(4)=0
+
+ iaddx(5)=0
+ iaddy(5)=0
+ iaddz(5)=2
+
+ iaddx(6)=2
+ iaddy(6)=0
+ iaddz(6)=2
+
+ iaddx(7)=2
+ iaddy(7)=4
+ iaddz(7)=2
+
+ iaddx(8)=0
+ iaddy(8)=4
+ iaddz(8)=2
+
+ end subroutine unusual_hex_nodes3
+
+ subroutine unusual_hex_nodes4(iaddx,iaddy,iaddz)
+
+ implicit none
+
+ include "constants.h"
+
+ integer iaddx(NGNOD),iaddy(NGNOD),iaddz(NGNOD)
+
+! define the topology of the hexahedral elements
+
+! corner nodes
+ iaddx(1)=0
+ iaddy(1)=0
+ iaddz(1)=0
+
+ iaddx(2)=2
+ iaddy(2)=0
+ iaddz(2)=0
+
+ iaddx(3)=2
+ iaddy(3)=4
+ iaddz(3)=0
+
+ iaddx(4)=0
+ iaddy(4)=4
+ iaddz(4)=0
+
+ iaddx(5)=0
+ iaddy(5)=0
+ iaddz(5)=2
+
+ iaddx(6)=2
+ iaddy(6)=0
+ iaddz(6)=2
+
+ iaddx(7)=2
+ iaddy(7)=2
+ iaddz(7)=2
+
+ iaddx(8)=0
+ iaddy(8)=2
+ iaddz(8)=2
+
+ end subroutine unusual_hex_nodes4
+
+ subroutine unusual_hex_nodes4p(iaddx,iaddy,iaddz)
+
+ implicit none
+
+ include "constants.h"
+
+ integer iaddx(NGNOD),iaddy(NGNOD),iaddz(NGNOD)
+
+! define the topology of the hexahedral elements
+
+! corner nodes
+ iaddx(1)=0
+ iaddy(1)=0
+ iaddz(1)=0
+
+ iaddx(2)=2
+ iaddy(2)=0
+ iaddz(2)=0
+
+ iaddx(3)=2
+ iaddy(3)=4
+ iaddz(3)=0
+
+ iaddx(4)=0
+ iaddy(4)=4
+ iaddz(4)=0
+
+ iaddx(5)=0
+ iaddy(5)=2
+ iaddz(5)=2
+
+ iaddx(6)=2
+ iaddy(6)=2
+ iaddz(6)=2
+
+ iaddx(7)=2
+ iaddy(7)=4
+ iaddz(7)=2
+
+ iaddx(8)=0
+ iaddy(8)=4
+ iaddz(8)=2
+
+ end subroutine unusual_hex_nodes4p
+
+ subroutine unusual_hex_nodes6(iaddx,iaddy,iaddz)
+
+ implicit none
+
+ include "constants.h"
+
+ integer iaddx(NGNOD),iaddy(NGNOD),iaddz(NGNOD)
+
+! define the topology of the hexahedral elements
+
+! corner nodes
+ iaddx(1)=0
+ iaddy(1)=0
+ iaddz(1)=0
+
+ iaddx(2)=2
+ iaddy(2)=0
+ iaddz(2)=0
+
+ iaddx(3)=2
+ iaddy(3)=2
+ iaddz(3)=-2
+
+ iaddx(4)=0
+ iaddy(4)=2
+ iaddz(4)=-2
+
+ iaddx(5)=0
+ iaddy(5)=0
+ iaddz(5)=2
+
+ iaddx(6)=2
+ iaddy(6)=0
+ iaddz(6)=2
+
+ iaddx(7)=2
+ iaddy(7)=2
+ iaddz(7)=2
+
+ iaddx(8)=0
+ iaddy(8)=2
+ iaddz(8)=2
+
+ end subroutine unusual_hex_nodes6
+
+ subroutine unusual_hex_nodes6p(iaddx,iaddy,iaddz)
+
+ implicit none
+
+ include "constants.h"
+
+ integer iaddx(NGNOD),iaddy(NGNOD),iaddz(NGNOD)
+
+! define the topology of the hexahedral elements
+
+! corner nodes
+ iaddx(1)=0
+ iaddy(1)=0
+ iaddz(1)=0
+
+ iaddx(2)=2
+ iaddy(2)=0
+ iaddz(2)=0
+
+ iaddx(3)=2
+ iaddy(3)=2
+ iaddz(3)=2
+
+ iaddx(4)=0
+ iaddy(4)=2
+ iaddz(4)=2
+
+ iaddx(5)=0
+ iaddy(5)=0
+ iaddz(5)=4
+
+ iaddx(6)=2
+ iaddy(6)=0
+ iaddz(6)=4
+
+ iaddx(7)=2
+ iaddy(7)=2
+ iaddz(7)=4
+
+ iaddx(8)=0
+ iaddy(8)=2
+ iaddz(8)=4
+
+ end subroutine unusual_hex_nodes6p
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/initialize_simulation.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/initialize_simulation.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/initialize_simulation.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,264 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+ subroutine initialize_simulation()
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_poroelastic
+ use specfem_par_movie
+ implicit none
+
+ integer :: ier
+
+ ! read the parameter file
+ call read_parameter_file( NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ ATTENUATION,USE_OLSEN_ATTENUATION,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,SIMULATION_TYPE,SAVE_FORWARD)
+
+ ! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+ ! myrank is the rank of each process, between 0 and NPROC-1.
+ ! as usual in MPI, process 0 is in charge of coordinating everything
+ ! and also takes care of the main output
+ call world_rank(myrank)
+
+ ! checks flags
+ call initialize_simulation_check()
+
+ ! open main output file, only written to by process 0
+ if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) &
+ open(unit=IMAIN,file=trim(OUTPUT_FILES)//'/output_solver.txt',status='unknown')
+ ! user output
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '**********************************************'
+ write(IMAIN,*) '**** Specfem 3-D Solver - MPI version f90 ****'
+ write(IMAIN,*) '**********************************************'
+ write(IMAIN,*)
+ write(IMAIN,*)
+ if(FIX_UNDERFLOW_PROBLEM) write(IMAIN,*) 'Fixing slow underflow trapping problem using small initial field'
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',NPROC,' MPI processes'
+ write(IMAIN,*) 'Processes are numbered from 0 to ',NPROC-1
+ write(IMAIN,*)
+ write(IMAIN,*) 'There is a total of ',NPROC,' slices'
+ write(IMAIN,*)
+ write(IMAIN,*) ' NDIM = ',NDIM
+ write(IMAIN,*)
+ write(IMAIN,*) ' NGLLX = ',NGLLX
+ write(IMAIN,*) ' NGLLY = ',NGLLY
+ write(IMAIN,*) ' NGLLZ = ',NGLLZ
+ 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,*)
+ endif
+
+ ! reads in numbers of spectral elements and points for this process' domain
+ 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',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error: could not open database '
+ print*,'path: ',prname(1:len_trim(prname))//'external_mesh.bin'
+ call exit_mpi(myrank,'error opening database')
+ endif
+ read(27) NSPEC_AB
+ read(27) NGLOB_AB
+ close(27)
+
+ ! attenuation arrays size
+ if( ATTENUATION ) then
+ !pll
+ NSPEC_ATTENUATION_AB = NSPEC_AB
+ else
+ ! if attenuation is off, set dummy size of arrays to one
+ NSPEC_ATTENUATION_AB = 1
+ endif
+
+ ! anisotropy arrays size
+ if( ANISOTROPY ) then
+ NSPEC_ANISO = NSPEC_AB
+ else
+ ! if off, set dummy size
+ NSPEC_ANISO = 1
+ endif
+
+ ! allocate arrays for storing the databases
+ allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(xix(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(xiy(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(xiz(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(etax(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(etay(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(etaz(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(gammax(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(gammay(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(gammaz(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(jacobian(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ ! mesh node locations
+ allocate(xstore(NGLOB_AB))
+ allocate(ystore(NGLOB_AB))
+ allocate(zstore(NGLOB_AB))
+ ! material properties
+ allocate(kappastore(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(mustore(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ ! material flags
+ allocate(ispec_is_acoustic(NSPEC_AB))
+ allocate(ispec_is_elastic(NSPEC_AB))
+ allocate(ispec_is_poroelastic(NSPEC_AB))
+
+ ! ocean mass matrix
+ allocate(rmass_ocean_load(NGLOB_AB))
+
+ ! initializes adjoint simulations
+ call initialize_simulation_adjoint()
+
+ end subroutine initialize_simulation
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine initialize_simulation_check()
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_poroelastic
+ use specfem_par_movie
+ implicit none
+
+ integer :: sizeprocs
+
+ ! sizeprocs returns number of processes started
+ ! (should be equal to NPROC)
+ call world_size(sizeprocs)
+
+ ! check that the code is running with the requested nb of processes
+ if(sizeprocs /= NPROC) call exit_MPI(myrank,'wrong number of MPI processes')
+
+ ! check that we have at least one source
+ if(NSOURCES < 1) call exit_MPI(myrank,'need at least one source')
+
+ ! check simulation type
+ if (SIMULATION_TYPE /= 1 .and. SIMULATION_TYPE /= 2 .and. SIMULATION_TYPE /= 3) &
+ call exit_mpi(myrank,'SIMULATION_TYPE can only be 1, 2, or 3')
+
+ ! check that optimized routines from Deville et al. (2002) can be used
+ if( USE_DEVILLE_PRODUCTS) then
+ if(NGLLX /= 5 .or. NGLLY /= 5 .or. NGLLZ /= 5) &
+ stop 'Deville et al. (2002) routines can only be used if NGLLX = NGLLY = NGLLZ = 5'
+ endif
+
+ ! absorbing surfaces
+ if( ABSORBING_CONDITIONS ) then
+ ! for arbitrary orientation of elements, which face belongs to xmin,xmax,etc... -
+ ! 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 'ABSORBING_CONDITIONS must have NGLLX = NGLLY = NGLLZ'
+ endif
+
+ ! exclusive movie flags
+ if( EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP ) then
+ if( EXTERNAL_MESH_MOVIE_SURFACE .and. EXTERNAL_MESH_CREATE_SHAKEMAP ) &
+ stop 'EXTERNAL_MESH_MOVIE_SURFACE and EXTERNAL_MESH_MOVIE_SURFACE cannot be both true'
+ if( MOVIE_SURFACE ) &
+ stop 'MOVIE_SURFACE cannot be used when EXTERNAL_MESH_MOVIE_SURFACE or EXTERNAL_MESH_CREATE_SHAKEMAP is true'
+ if( CREATE_SHAKEMAP ) &
+ stop 'CREATE_SHAKEMAP cannot be used when EXTERNAL_MESH_MOVIE_SURFACE or EXTERNAL_MESH_CREATE_SHAKEMAP is true'
+ endif
+
+ end subroutine initialize_simulation_check
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine initialize_simulation_adjoint()
+
+! initialization for ADJOINT simulations
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_poroelastic
+ implicit none
+
+ ! check simulation parameters
+ if (SIMULATION_TYPE /= 1 .and. NSOURCES > 1000) &
+ call exit_mpi(myrank, 'for adjoint simulations, NSOURCES <= 1000')
+
+ ! snapshot file names: ADJOINT attenuation
+ if (ATTENUATION .and. ((SIMULATION_TYPE == 1 .and. SAVE_FORWARD) .or. SIMULATION_TYPE == 3)) &
+ call create_name_database(prname_Q,myrank,LOCAL_PATH_Q)
+
+ ! number of elements and points for adjoint arrays
+ if( SIMULATION_TYPE == 3 ) then
+ NSPEC_ADJOINT = NSPEC_AB
+ NGLOB_ADJOINT = NGLOB_AB
+ else
+ ! dummy array size
+ NSPEC_ADJOINT = 1
+ NGLOB_ADJOINT = 1
+ endif
+
+ ! strain/attenuation
+ if( ATTENUATION .and. SIMULATION_TYPE == 3 ) then
+ NSPEC_ATT_AND_KERNEL = NSPEC_AB
+ else
+ NSPEC_ATT_AND_KERNEL = 1
+ endif
+
+ ! moho boundary
+ if( SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3 ) then
+ NSPEC_BOUN = NSPEC_AB
+ else
+ NSPEC_BOUN = 1
+ endif
+
+ end subroutine initialize_simulation_adjoint
+
+
+
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/interpolate_gocad_block_HR.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/interpolate_gocad_block_HR.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/interpolate_gocad_block_HR.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,161 @@
+
+ subroutine interpolate_gocad_block_HR(vp_block_gocad_HR,vp_block_gocad_MR, &
+ utm_x_eval,utm_y_eval,z_eval,rho_final,vp_final,vs_final,point_is_in_sediments, &
+ VP_MIN_GOCAD,VP_VS_RATIO_GOCAD_TOP,VP_VS_RATIO_GOCAD_BOTTOM, &
+ IMPOSE_MINIMUM_VP_GOCAD,THICKNESS_TAPER_BLOCK_HR, &
+ vp_hauksson,vs_hauksson,doubling_index,HAUKSSON_REGIONAL_MODEL, MOHO_MAP_LUPEI)
+
+ implicit none
+
+ include "constants.h"
+ include "constants_gocad.h"
+
+ double precision vp_block_gocad_HR(0:NX_GOCAD_HR-1,0:NY_GOCAD_HR-1,0:NZ_GOCAD_HR-1)
+ double precision vp_block_gocad_MR(0:NX_GOCAD_MR-1,0:NY_GOCAD_MR-1,0:NZ_GOCAD_MR-1)
+
+ integer ix,iy,iz
+
+ double precision utm_x_eval,utm_y_eval,z_eval
+ double precision spacing_x,spacing_y,spacing_z
+ double precision gamma_interp_x,gamma_interp_y,gamma_interp_z
+ double precision v1,v2,v3,v4,v5,v6,v7,v8
+ double precision vp_final,vs_final,rho_final,vp_vs_ratio
+ double precision rho_ref_MR,vp_ref_MR,vs_ref_MR
+ double precision THICKNESS_TAPER_BLOCK_HR, &
+ VP_MIN_GOCAD,VP_VS_RATIO_GOCAD_TOP,VP_VS_RATIO_GOCAD_BOTTOM
+
+ logical point_is_in_sediments,dummy_flag,IMPOSE_MINIMUM_VP_GOCAD
+
+! for Hauksson's model
+ integer doubling_index
+ logical HAUKSSON_REGIONAL_MODEL,MOHO_MAP_LUPEI
+ double precision, dimension(NLAYERS_HAUKSSON,NGRID_NEW_HAUKSSON,NGRID_NEW_HAUKSSON) :: vp_hauksson,vs_hauksson
+
+! determine spacing and cell for linear interpolation
+ spacing_x = (utm_x_eval - ORIG_X_GOCAD_HR) / SPACING_X_GOCAD_HR
+ spacing_y = (utm_y_eval - ORIG_Y_GOCAD_HR) / SPACING_Y_GOCAD_HR
+ spacing_z = (z_eval - ORIG_Z_GOCAD_HR) / SPACING_Z_GOCAD_HR
+
+ ix = int(spacing_x)
+ iy = int(spacing_y)
+ iz = int(spacing_z)
+
+ gamma_interp_x = spacing_x - dble(ix)
+ gamma_interp_y = spacing_y - dble(iy)
+ gamma_interp_z = spacing_z - dble(iz)
+
+! this block is smaller than the grid, therefore just exit
+! if the target point is outside of the block
+ if(ix < 0 .or. ix > NX_GOCAD_HR-2 .or. iy < 0 .or. iy > NY_GOCAD_HR-2) return
+
+! suppress edge effects in vertical direction
+ if(iz < 0) then
+ iz = 0
+ gamma_interp_z = 0.d0
+ endif
+ if(iz > NZ_GOCAD_HR-2) then
+ iz = NZ_GOCAD_HR-2
+ gamma_interp_z = 1.d0
+ endif
+
+! define 8 corners of interpolation element
+ v1 = vp_block_gocad_HR(ix,iy,iz)
+ v2 = vp_block_gocad_HR(ix+1,iy,iz)
+ v3 = vp_block_gocad_HR(ix+1,iy+1,iz)
+ v4 = vp_block_gocad_HR(ix,iy+1,iz)
+
+ v5 = vp_block_gocad_HR(ix,iy,iz+1)
+ v6 = vp_block_gocad_HR(ix+1,iy,iz+1)
+ v7 = vp_block_gocad_HR(ix+1,iy+1,iz+1)
+ v8 = vp_block_gocad_HR(ix,iy+1,iz+1)
+
+! check if element is defined (i.e. is in the sediments in Voxet)
+! do nothing if element is undefined
+! a P-velocity of 20 km/s is used to indicate fictitious elements
+ if(v1 < 19000. .and. v2 < 19000. .and. &
+ v3 < 19000. .and. v4 < 19000. .and. &
+ v5 < 19000. .and. v6 < 19000. .and. &
+ v7 < 19000. .and. v8 < 19000.) then
+
+! set flag indicating whether point is in the sediments
+ point_is_in_sediments = .true.
+
+! use trilinear interpolation in cell to define Vp
+ vp_final = &
+ v1*(1.-gamma_interp_x)*(1.-gamma_interp_y)*(1.-gamma_interp_z) + &
+ v2*gamma_interp_x*(1.-gamma_interp_y)*(1.-gamma_interp_z) + &
+ v3*gamma_interp_x*gamma_interp_y*(1.-gamma_interp_z) + &
+ v4*(1.-gamma_interp_x)*gamma_interp_y*(1.-gamma_interp_z) + &
+ v5*(1.-gamma_interp_x)*(1.-gamma_interp_y)*gamma_interp_z + &
+ v6*gamma_interp_x*(1.-gamma_interp_y)*gamma_interp_z + &
+ v7*gamma_interp_x*gamma_interp_y*gamma_interp_z + &
+ v8*(1.-gamma_interp_x)*gamma_interp_y*gamma_interp_z
+
+! impose minimum velocity if needed
+ if(IMPOSE_MINIMUM_VP_GOCAD .and. vp_final < VP_MIN_GOCAD) vp_final = VP_MIN_GOCAD
+
+! taper edges to make smooth transition between MR and HR blocks
+! get value from edge of medium-resolution block
+! then use linear interpolation from edge of the model
+ if(TAPER_GOCAD_TRANSITIONS) then
+
+! x = xmin
+ if(utm_x_eval < ORIG_X_GOCAD_HR + THICKNESS_TAPER_BLOCK_HR) then
+ gamma_interp_x = (utm_x_eval - ORIG_X_GOCAD_HR) / THICKNESS_TAPER_BLOCK_HR
+ call interpolate_gocad_block_MR(vp_block_gocad_MR, &
+ ORIG_X_GOCAD_HR,utm_y_eval,z_eval,rho_ref_MR,vp_ref_MR,vs_ref_MR,dummy_flag, &
+ VP_MIN_GOCAD,VP_VS_RATIO_GOCAD_TOP,VP_VS_RATIO_GOCAD_BOTTOM, &
+ IMPOSE_MINIMUM_VP_GOCAD,THICKNESS_TAPER_BLOCK_HR, &
+ vp_hauksson,vs_hauksson,doubling_index,HAUKSSON_REGIONAL_MODEL,MOHO_MAP_LUPEI)
+ vp_final = vp_ref_MR * (1. - gamma_interp_x) + vp_final * gamma_interp_x
+
+! x = xmax
+ else if(utm_x_eval > END_X_GOCAD_HR - THICKNESS_TAPER_BLOCK_HR) then
+ gamma_interp_x = (utm_x_eval - (END_X_GOCAD_HR - THICKNESS_TAPER_BLOCK_HR)) / THICKNESS_TAPER_BLOCK_HR
+ call interpolate_gocad_block_MR(vp_block_gocad_MR, &
+ END_X_GOCAD_HR,utm_y_eval,z_eval,rho_ref_MR,vp_ref_MR,vs_ref_MR,dummy_flag, &
+ VP_MIN_GOCAD,VP_VS_RATIO_GOCAD_TOP,VP_VS_RATIO_GOCAD_BOTTOM, &
+ IMPOSE_MINIMUM_VP_GOCAD,THICKNESS_TAPER_BLOCK_HR, &
+ vp_hauksson,vs_hauksson,doubling_index,HAUKSSON_REGIONAL_MODEL, MOHO_MAP_LUPEI)
+ vp_final = vp_ref_MR * gamma_interp_x + vp_final * (1. - gamma_interp_x)
+
+! y = ymin
+ else if(utm_y_eval < ORIG_Y_GOCAD_HR + THICKNESS_TAPER_BLOCK_HR) then
+ gamma_interp_y = (utm_y_eval - ORIG_Y_GOCAD_HR) / THICKNESS_TAPER_BLOCK_HR
+ call interpolate_gocad_block_MR(vp_block_gocad_MR, &
+ utm_x_eval,ORIG_Y_GOCAD_HR,z_eval,rho_ref_MR,vp_ref_MR,vs_ref_MR,dummy_flag, &
+ VP_MIN_GOCAD,VP_VS_RATIO_GOCAD_TOP,VP_VS_RATIO_GOCAD_BOTTOM, &
+ IMPOSE_MINIMUM_VP_GOCAD,THICKNESS_TAPER_BLOCK_HR, &
+ vp_hauksson,vs_hauksson,doubling_index,HAUKSSON_REGIONAL_MODEL, MOHO_MAP_LUPEI)
+ vp_final = vp_ref_MR * (1. - gamma_interp_y) + vp_final * gamma_interp_y
+
+! y = ymax
+ else if(utm_y_eval > END_Y_GOCAD_HR - THICKNESS_TAPER_BLOCK_HR) then
+ gamma_interp_y = (utm_y_eval - (END_Y_GOCAD_HR - THICKNESS_TAPER_BLOCK_HR)) / THICKNESS_TAPER_BLOCK_HR
+ call interpolate_gocad_block_MR(vp_block_gocad_MR, &
+ utm_x_eval,END_Y_GOCAD_HR,z_eval,rho_ref_MR,vp_ref_MR,vs_ref_MR,dummy_flag, &
+ VP_MIN_GOCAD,VP_VS_RATIO_GOCAD_TOP,VP_VS_RATIO_GOCAD_BOTTOM, &
+ IMPOSE_MINIMUM_VP_GOCAD,THICKNESS_TAPER_BLOCK_HR, &
+ vp_hauksson,vs_hauksson,doubling_index,HAUKSSON_REGIONAL_MODEL, MOHO_MAP_LUPEI)
+ vp_final = vp_ref_MR * gamma_interp_y + vp_final * (1. - gamma_interp_y)
+
+ endif
+
+ endif
+
+! use linear variation of vp/vs ratio with depth, between 0. and 8.5 km
+ vp_vs_ratio = VP_VS_RATIO_GOCAD_BOTTOM + &
+ (VP_VS_RATIO_GOCAD_TOP - VP_VS_RATIO_GOCAD_BOTTOM) * &
+ (z_eval - (-8500.d0)) / (0.d0 - (-8500.d0))
+
+! make sure ratio remains in interval
+ if(vp_vs_ratio < VP_VS_RATIO_GOCAD_BOTTOM) vp_vs_ratio = VP_VS_RATIO_GOCAD_BOTTOM
+ if(vp_vs_ratio > VP_VS_RATIO_GOCAD_TOP) vp_vs_ratio = VP_VS_RATIO_GOCAD_TOP
+
+ vs_final = vp_final / vp_vs_ratio
+ call compute_rho_estimate(rho_final,vp_final)
+
+ endif
+
+ end subroutine interpolate_gocad_block_HR
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/interpolate_gocad_block_MR.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/interpolate_gocad_block_MR.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/interpolate_gocad_block_MR.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,186 @@
+
+ subroutine interpolate_gocad_block_MR(vp_block_gocad_MR, &
+ utm_x_eval,utm_y_eval,z_eval,rho_final,vp_final,vs_final,point_is_in_sediments, &
+ VP_MIN_GOCAD,VP_VS_RATIO_GOCAD_TOP,VP_VS_RATIO_GOCAD_BOTTOM, &
+ IMPOSE_MINIMUM_VP_GOCAD,THICKNESS_TAPER_BLOCK_MR, &
+ vp_hauksson,vs_hauksson,doubling_index,HAUKSSON_REGIONAL_MODEL,MOHO_MAP_LUPEI)
+
+ implicit none
+
+ include "constants.h"
+ include "constants_gocad.h"
+
+ double precision vp_block_gocad_MR(0:NX_GOCAD_MR-1,0:NY_GOCAD_MR-1,0:NZ_GOCAD_MR-1)
+ double precision VP_MIN_GOCAD,VP_VS_RATIO_GOCAD_TOP,VP_VS_RATIO_GOCAD_BOTTOM,THICKNESS_TAPER_BLOCK_MR
+
+ integer ix,iy,iz
+
+ double precision utm_x_eval,utm_y_eval,z_eval
+ double precision spacing_x,spacing_y,spacing_z
+ double precision gamma_interp_x,gamma_interp_y,gamma_interp_z
+ double precision v1,v2,v3,v4,v5,v6,v7,v8
+ double precision vp_final,vs_final,rho_final,vp_vs_ratio
+ double precision xmesh,ymesh,zmesh,vs_dummy,rho_dummy
+
+ logical point_is_in_sediments,IMPOSE_MINIMUM_VP_GOCAD
+
+! for Hauksson's model
+ integer doubling_index
+ logical HAUKSSON_REGIONAL_MODEL,MOHO_MAP_LUPEI
+ double precision vp_ref_hauksson
+ double precision, dimension(NLAYERS_HAUKSSON,NGRID_NEW_HAUKSSON,NGRID_NEW_HAUKSSON) :: vp_hauksson,vs_hauksson
+
+! determine spacing and cell for linear interpolation
+ spacing_x = (utm_x_eval - ORIG_X_GOCAD_MR) / SPACING_X_GOCAD_MR
+ spacing_y = (utm_y_eval - ORIG_Y_GOCAD_MR) / SPACING_Y_GOCAD_MR
+ spacing_z = (z_eval - ORIG_Z_GOCAD_MR) / SPACING_Z_GOCAD_MR
+
+ ix = int(spacing_x)
+ iy = int(spacing_y)
+ iz = int(spacing_z)
+
+ gamma_interp_x = spacing_x - dble(ix)
+ gamma_interp_y = spacing_y - dble(iy)
+ gamma_interp_z = spacing_z - dble(iz)
+
+! suppress edge effects for points outside of Gocad model
+ if(ix < 0) then
+ ix = 0
+ gamma_interp_x = 0.d0
+ endif
+ if(ix > NX_GOCAD_MR-2) then
+ ix = NX_GOCAD_MR-2
+ gamma_interp_x = 1.d0
+ endif
+
+ if(iy < 0) then
+ iy = 0
+ gamma_interp_y = 0.d0
+ endif
+ if(iy > NY_GOCAD_MR-2) then
+ iy = NY_GOCAD_MR-2
+ gamma_interp_y = 1.d0
+ endif
+
+ if(iz < 0) then
+ iz = 0
+ gamma_interp_z = 0.d0
+ endif
+ if(iz > NZ_GOCAD_MR-2) then
+ iz = NZ_GOCAD_MR-2
+ gamma_interp_z = 1.d0
+ endif
+
+! define 8 corners of interpolation element
+ v1 = vp_block_gocad_MR(ix,iy,iz)
+ v2 = vp_block_gocad_MR(ix+1,iy,iz)
+ v3 = vp_block_gocad_MR(ix+1,iy+1,iz)
+ v4 = vp_block_gocad_MR(ix,iy+1,iz)
+
+ v5 = vp_block_gocad_MR(ix,iy,iz+1)
+ v6 = vp_block_gocad_MR(ix+1,iy,iz+1)
+ v7 = vp_block_gocad_MR(ix+1,iy+1,iz+1)
+ v8 = vp_block_gocad_MR(ix,iy+1,iz+1)
+
+! check if element is defined (i.e. is in the sediments in Voxet)
+! do nothing if element is undefined
+! a P-velocity of 20 km/s is used to indicate fictitious elements
+ if(v1 < 19000. .and. v2 < 19000. .and. &
+ v3 < 19000. .and. v4 < 19000. .and. &
+ v5 < 19000. .and. v6 < 19000. .and. &
+ v7 < 19000. .and. v8 < 19000.) then
+
+! set flag indicating whether point is in the sediments
+ point_is_in_sediments = .true.
+
+! use trilinear interpolation in cell to define Vp
+ vp_final = &
+ v1*(1.-gamma_interp_x)*(1.-gamma_interp_y)*(1.-gamma_interp_z) + &
+ v2*gamma_interp_x*(1.-gamma_interp_y)*(1.-gamma_interp_z) + &
+ v3*gamma_interp_x*gamma_interp_y*(1.-gamma_interp_z) + &
+ v4*(1.-gamma_interp_x)*gamma_interp_y*(1.-gamma_interp_z) + &
+ v5*(1.-gamma_interp_x)*(1.-gamma_interp_y)*gamma_interp_z + &
+ v6*gamma_interp_x*(1.-gamma_interp_y)*gamma_interp_z + &
+ v7*gamma_interp_x*gamma_interp_y*gamma_interp_z + &
+ v8*(1.-gamma_interp_x)*gamma_interp_y*gamma_interp_z
+
+! impose minimum velocity if needed
+ if(IMPOSE_MINIMUM_VP_GOCAD .and. vp_final < VP_MIN_GOCAD) vp_final = VP_MIN_GOCAD
+
+! taper edges to make smooth transition between Hauksson and MR blocks
+! get value from edge of medium-resolution block
+! then use linear interpolation from edge of the model
+ if(TAPER_GOCAD_TRANSITIONS) then
+
+! x = xmin
+ if(utm_x_eval < ORIG_X_GOCAD_MR + THICKNESS_TAPER_BLOCK_MR) then
+ xmesh = ORIG_X_GOCAD_MR
+ ymesh = utm_y_eval
+ zmesh = z_eval
+ if(HAUKSSON_REGIONAL_MODEL) then
+ call hauksson_model(vp_hauksson,vs_hauksson,xmesh,ymesh,zmesh,vp_ref_hauksson,vs_dummy, MOHO_MAP_LUPEI)
+ else
+ call socal_model(doubling_index,rho_dummy,vp_ref_hauksson,vs_dummy)
+ endif
+ gamma_interp_x = (utm_x_eval - ORIG_X_GOCAD_MR) / THICKNESS_TAPER_BLOCK_MR
+ vp_final = vp_ref_hauksson * (1. - gamma_interp_x) + vp_final * gamma_interp_x
+
+! x = xmax
+ else if(utm_x_eval > END_X_GOCAD_MR - THICKNESS_TAPER_BLOCK_MR) then
+ xmesh = END_X_GOCAD_MR
+ ymesh = utm_y_eval
+ zmesh = z_eval
+ if(HAUKSSON_REGIONAL_MODEL) then
+ call hauksson_model(vp_hauksson,vs_hauksson,xmesh,ymesh,zmesh,vp_ref_hauksson,vs_dummy, MOHO_MAP_LUPEI)
+ else
+ call socal_model(doubling_index,rho_dummy,vp_ref_hauksson,vs_dummy)
+ endif
+ gamma_interp_x = (utm_x_eval - (END_X_GOCAD_MR - THICKNESS_TAPER_BLOCK_MR)) / THICKNESS_TAPER_BLOCK_MR
+ vp_final = vp_ref_hauksson * gamma_interp_x + vp_final * (1. - gamma_interp_x)
+
+! y = ymin
+ else if(utm_y_eval < ORIG_Y_GOCAD_MR + THICKNESS_TAPER_BLOCK_MR) then
+ xmesh = utm_x_eval
+ ymesh = ORIG_Y_GOCAD_MR
+ zmesh = z_eval
+ if(HAUKSSON_REGIONAL_MODEL) then
+ call hauksson_model(vp_hauksson,vs_hauksson,xmesh,ymesh,zmesh,vp_ref_hauksson,vs_dummy, MOHO_MAP_LUPEI)
+ else
+ call socal_model(doubling_index,rho_dummy,vp_ref_hauksson,vs_dummy)
+ endif
+ gamma_interp_y = (utm_y_eval - ORIG_Y_GOCAD_MR) / THICKNESS_TAPER_BLOCK_MR
+ vp_final = vp_ref_hauksson * (1. - gamma_interp_y) + vp_final * gamma_interp_y
+
+! y = ymax
+ else if(utm_y_eval > END_Y_GOCAD_MR - THICKNESS_TAPER_BLOCK_MR) then
+ xmesh = utm_x_eval
+ ymesh = END_Y_GOCAD_MR
+ zmesh = z_eval
+ if(HAUKSSON_REGIONAL_MODEL) then
+ call hauksson_model(vp_hauksson,vs_hauksson,xmesh,ymesh,zmesh,vp_ref_hauksson,vs_dummy, MOHO_MAP_LUPEI)
+ else
+ call socal_model(doubling_index,rho_dummy,vp_ref_hauksson,vs_dummy)
+ endif
+ gamma_interp_y = (utm_y_eval - (END_Y_GOCAD_MR - THICKNESS_TAPER_BLOCK_MR)) / THICKNESS_TAPER_BLOCK_MR
+ vp_final = vp_ref_hauksson * gamma_interp_y + vp_final * (1. - gamma_interp_y)
+
+ endif
+
+ endif
+
+! use linear variation of vp/vs ratio with depth, between 0. and 8.5 km
+ vp_vs_ratio = VP_VS_RATIO_GOCAD_BOTTOM + &
+ (VP_VS_RATIO_GOCAD_TOP - VP_VS_RATIO_GOCAD_BOTTOM) * &
+ (z_eval - (-8500.d0)) / (0.d0 - (-8500.d0))
+
+! make sure ratio remains in interval
+ if(vp_vs_ratio < VP_VS_RATIO_GOCAD_BOTTOM) vp_vs_ratio = VP_VS_RATIO_GOCAD_BOTTOM
+ if(vp_vs_ratio > VP_VS_RATIO_GOCAD_TOP) vp_vs_ratio = VP_VS_RATIO_GOCAD_TOP
+
+ vs_final = vp_final / vp_vs_ratio
+ call compute_rho_estimate(rho_final,vp_final)
+
+ endif
+
+ end subroutine interpolate_gocad_block_MR
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/iterate_time.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/iterate_time.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/iterate_time.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,510 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+ subroutine iterate_time()
+
+ use specfem_par
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ use specfem_par_poroelastic
+ use specfem_par_movie
+ implicit none
+
+!
+! s t a r t t i m e i t e r a t i o n s
+!
+
+! synchronize all processes to make sure everybody is ready to start time loop
+ call sync_all()
+ if(myrank == 0) write(IMAIN,*) 'All processes are synchronized before time loop'
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Starting time iteration loop...'
+ write(IMAIN,*)
+ endif
+
+! create an empty file to monitor the start of the simulation
+ if(myrank == 0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/starttimeloop.txt',status='unknown')
+ write(IOUT,*) 'starting time loop'
+ close(IOUT)
+ endif
+
+! get MPI starting time
+ time_start = wtime()
+
+! *********************************************************
+! ************* MAIN LOOP OVER THE TIME STEPS *************
+! *********************************************************
+
+ do it = 1,NSTEP
+
+ ! simulation status output and stability check
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then
+ call it_check_stability()
+ endif
+
+ ! update displacement using Newark time scheme
+ call it_update_displacement_scheme()
+
+ ! acoustic solver
+ ! (needs to be done first, before elastic one)
+ if( ACOUSTIC_SIMULATION ) call compute_forces_acoustic()
+
+ ! elastic solver
+ if( ELASTIC_SIMULATION ) call compute_forces_elastic()
+
+ ! poroelastic solver
+ if( POROELASTIC_SIMULATION ) stop 'poroelastic simulation not implemented yet'
+
+ ! write the seismograms with time shift
+ if (nrec_local > 0) then
+ call write_seismograms()
+ endif
+
+ ! resetting d/v/a/R/eps for the backward reconstruction with attenuation
+ if (ATTENUATION ) then
+ call it_store_attenuation_arrays()
+ endif
+
+
+ ! adjoint simulations: kernels
+ if( SIMULATION_TYPE == 3 ) then
+ call it_update_adjointkernels()
+ endif
+
+ ! outputs movie files
+ if( MOVIE_SIMULATION ) then
+ call write_movie_output()
+ endif
+
+!
+!---- end of time iteration loop
+!
+ enddo ! end of main time loop
+
+ end subroutine iterate_time
+
+
+!=====================================================================
+
+ subroutine it_check_stability()
+
+! computes the maximum of the norm of the displacement
+! in all the slices using an MPI reduction
+! and output timestamp file to check that simulation is running fine
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ implicit none
+
+ double precision :: tCPU,t_remain,t_total
+ integer :: ihours,iminutes,iseconds,int_tCPU, &
+ ihours_remain,iminutes_remain,iseconds_remain,int_t_remain, &
+ ihours_total,iminutes_total,iseconds_total,int_t_total
+
+! compute maximum of norm of displacement in each slice
+ if( ELASTIC_SIMULATION ) then
+ Usolidnorm = maxval(sqrt(displ(1,:)**2 + displ(2,:)**2 + displ(3,:)**2))
+ else
+ if( ACOUSTIC_SIMULATION ) then
+ Usolidnorm = maxval(abs(potential_dot_dot_acoustic(:)))
+ endif
+ endif
+
+! compute the maximum of the maxima for all the slices using an MPI reduction
+ call max_all_cr(Usolidnorm,Usolidnorm_all)
+
+! adjoint simulations
+ if( SIMULATION_TYPE == 3 ) then
+ if( ELASTIC_SIMULATION ) then
+ b_Usolidnorm = maxval(sqrt(b_displ(1,:)**2 + b_displ(2,:)**2 + b_displ(3,:)**2))
+ else
+ if( ACOUSTIC_SIMULATION ) then
+ b_Usolidnorm = maxval(abs(b_potential_dot_dot_acoustic(:)))
+ endif
+ endif
+ call max_all_cr(b_Usolidnorm,b_Usolidnorm_all)
+ endif
+
+! user output
+ if(myrank == 0) then
+
+ write(IMAIN,*) 'Time step # ',it
+ write(IMAIN,*) 'Time: ',sngl((it-1)*DT-t0),' seconds'
+
+! elapsed time since beginning of the simulation
+ tCPU = wtime() - time_start
+ int_tCPU = int(tCPU)
+ ihours = int_tCPU / 3600
+ iminutes = (int_tCPU - 3600*ihours) / 60
+ iseconds = int_tCPU - 3600*ihours - 60*iminutes
+ write(IMAIN,*) 'Elapsed time in seconds = ',tCPU
+ write(IMAIN,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(IMAIN,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ if( ELASTIC_SIMULATION ) then
+ write(IMAIN,*) 'Max norm displacement vector U in all slices (m) = ',Usolidnorm_all
+ else
+ if( ACOUSTIC_SIMULATION ) then
+ write(IMAIN,*) 'Max norm pressure P in all slices (Pa) = ',Usolidnorm_all
+ endif
+ endif
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) write(IMAIN,*) &
+ 'Max norm U (backward) in all slices = ',b_Usolidnorm_all
+
+! compute estimated remaining simulation time
+ t_remain = (NSTEP - it) * (tCPU/dble(it))
+ int_t_remain = int(t_remain)
+ ihours_remain = int_t_remain / 3600
+ iminutes_remain = (int_t_remain - 3600*ihours_remain) / 60
+ iseconds_remain = int_t_remain - 3600*ihours_remain - 60*iminutes_remain
+ write(IMAIN,*) 'Time steps done = ',it,' out of ',NSTEP
+ write(IMAIN,*) 'Time steps remaining = ',NSTEP - it
+ write(IMAIN,*) 'Estimated remaining time in seconds = ',t_remain
+ write(IMAIN,"(' Estimated remaining time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
+ ihours_remain,iminutes_remain,iseconds_remain
+
+! compute estimated total simulation time
+ t_total = t_remain + tCPU
+ int_t_total = int(t_total)
+ ihours_total = int_t_total / 3600
+ iminutes_total = (int_t_total - 3600*ihours_total) / 60
+ iseconds_total = int_t_total - 3600*ihours_total - 60*iminutes_total
+ write(IMAIN,*) 'Estimated total run time in seconds = ',t_total
+ write(IMAIN,"(' Estimated total run time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
+ ihours_total,iminutes_total,iseconds_total
+ write(IMAIN,*) 'We have done ',sngl(100.d0*dble(it)/dble(NSTEP)),'% of that'
+
+ if(it < 100) then
+ write(IMAIN,*) '************************************************************'
+ write(IMAIN,*) '**** BEWARE: the above time estimates are not reliable'
+ write(IMAIN,*) '**** because fewer than 100 iterations have been performed'
+ write(IMAIN,*) '************************************************************'
+ endif
+ write(IMAIN,*)
+
+! write time stamp file to give information about progression of simulation
+ write(outputname,"('/timestamp',i6.6)") it
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='unknown')
+ write(IOUT,*) 'Time step # ',it
+ write(IOUT,*) 'Time: ',sngl((it-1)*DT-t0),' seconds'
+ write(IOUT,*) 'Elapsed time in seconds = ',tCPU
+ write(IOUT,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ write(IOUT,*) 'Max norm displacement vector U in all slices (m) = ',Usolidnorm_all
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3) write(IOUT,*) &
+ 'Max norm U (backward) in all slices = ',b_Usolidnorm_all
+ close(IOUT)
+
+
+! check stability of the code, exit if unstable
+! negative values can occur with some compilers when the unstable value is greater
+! than the greatest possible floating-point number of the machine
+ if(Usolidnorm_all > STABILITY_THRESHOLD .or. Usolidnorm_all < 0) &
+ call exit_MPI(myrank,'forward simulation became unstable and blew up')
+ ! adjoint simulations
+ if(SIMULATION_TYPE == 3 .and. (b_Usolidnorm_all > STABILITY_THRESHOLD &
+ .or. b_Usolidnorm_all < 0)) &
+ call exit_MPI(myrank,'backward simulation became unstable and blew up')
+
+ endif ! myrank
+
+ end subroutine it_check_stability
+
+
+!=====================================================================
+
+ subroutine it_update_displacement_scheme()
+
+! explicit Newark time scheme with acoustic & elastic domains:
+! (see e.g. Hughes, 1987; Chaljub et al., 2003)
+!
+! chi(t+delta_t) = chi(t) + delta_t chi_dot(t) + 1/2 delta_t**2 chi_dot_dot(t)
+! chi_dot(t+delta_t) = chi_dot(t) + 1/2 delta_t chi_dot_dot(t) + 1/2 delta_t chi_dot_dot(t+delta_t)
+! chi_dot_dot(t+delta_t) = 1/M_acoustic( -K_acoustic chi(t+delta) + B_acoustic u(t+delta_t) + f(t+delta_t) )
+!
+! u(t+delta_t) = u(t) + delta_t v(t) + 1/2 delta_t**2 a(t)
+! v(t+delta_t) = v(t) + 1/2 delta_t a(t) + 1/2 delta_t a(t+delta_t)
+! a(t+delta_t) = 1/M_elastic ( -K_elastic u(t+delta) + B_elastic chi_dot_dot(t+delta_t) + f( t+delta_t) )
+!
+! where
+! chi, chi_dot, chi_dot_dot are acoustic (fluid) potentials ( dotted with respect to time)
+! u, v, a are displacement,velocity & acceleration
+! M is mass matrix, K stiffness matrix and B boundary term for acoustic/elastic domains
+! f denotes a source term (acoustic/elastic)
+!
+! note that this stage calculates the predictor terms
+!
+! for
+! potential chi_dot(t+delta) requires + 1/2 delta_t chi_dot_dot(t+delta_t)
+! at a later stage (corrector) once where chi_dot_dot(t+delta) is calculated
+! and similar,
+! velocity v(t+delta_t) requires + 1/2 delta_t a(t+delta_t)
+! at a later stage once where a(t+delta) is calculated
+! also:
+! boundary term B_elastic requires chi_dot_dot(t+delta)
+! thus chi_dot_dot has to be updated first before the elastic boundary term is considered
+
+ use specfem_par
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ use specfem_par_poroelastic
+ use PML_par
+ use PML_par_acoustic
+ implicit none
+
+! updates acoustic potentials
+ if( ACOUSTIC_SIMULATION ) then
+ potential_acoustic(:) = potential_acoustic(:) &
+ + deltat * potential_dot_acoustic(:) &
+ + deltatsqover2 * potential_dot_dot_acoustic(:)
+ potential_dot_acoustic(:) = potential_dot_acoustic(:) &
+ + deltatover2 * potential_dot_dot_acoustic(:)
+ potential_dot_dot_acoustic(:) = 0._CUSTOM_REAL
+
+ ! time marching potentials
+ if(PML) call PML_acoustic_time_march(NSPEC_AB,NGLOB_AB,ibool,&
+ potential_acoustic,potential_dot_acoustic,&
+ deltat,deltatsqover2,deltatover2,&
+ num_PML_ispec,PML_ispec,PML_damping_d,&
+ chi1,chi2,chi2_t,chi3,chi4,&
+ chi1_dot,chi2_t_dot,chi3_dot,chi4_dot,&
+ chi1_dot_dot,chi2_t_dot_dot,chi3_dot_dot,chi4_dot_dot,&
+ iglob_is_PML_interface,PML_mask_ibool,&
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh,&
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh,NPROC,&
+ ispec_is_acoustic)
+ endif
+
+! updates elastic displacement and velocity
+ if( ELASTIC_SIMULATION ) then
+ displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsqover2*accel(:,:)
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+ accel(:,:) = 0._CUSTOM_REAL
+ endif
+
+! adjoint simulations
+ if (SIMULATION_TYPE == 3) then
+ ! acoustic backward fields
+ if( ACOUSTIC_SIMULATION ) then
+ b_potential_acoustic(:) = b_potential_acoustic(:) &
+ + b_deltat * b_potential_dot_acoustic(:) &
+ + b_deltatsqover2 * b_potential_dot_dot_acoustic(:)
+ b_potential_dot_acoustic(:) = b_potential_dot_acoustic(:) &
+ + b_deltatover2 * b_potential_dot_dot_acoustic(:)
+ b_potential_dot_dot_acoustic(:) = 0._CUSTOM_REAL
+ endif
+ ! elastic backward fields
+ if( ELASTIC_SIMULATION ) then
+ b_displ(:,:) = b_displ(:,:) + b_deltat*b_veloc(:,:) + b_deltatsqover2*b_accel(:,:)
+ b_veloc(:,:) = b_veloc(:,:) + b_deltatover2*b_accel(:,:)
+ b_accel(:,:) = 0._CUSTOM_REAL
+ endif
+ endif
+
+! adjoint simulations: moho kernel
+ if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
+ ispec2D_moho_top = 0
+ ispec2D_moho_bot = 0
+ endif
+
+
+ end subroutine it_update_displacement_scheme
+
+!=====================================================================
+
+
+ subroutine it_store_attenuation_arrays()
+
+! resetting d/v/a/R/eps for the backward reconstruction with attenuation
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+
+ implicit none
+
+ if( it > 1 .and. it < NSTEP) then
+ ! adjoint simulations
+ if (SIMULATION_TYPE == 3 .and. mod(NSTEP-it,NSTEP_Q_SAVE) == 0) then
+ ! reads files content
+ write(outputname,"('save_Q_arrays_',i6.6,'.bin')") NSTEP-it
+ open(unit=27,file=trim(prname_Q)//trim(outputname),status='old',&
+ action='read',form='unformatted')
+ if( ELASTIC_SIMULATION ) then
+ read(27) b_displ
+ read(27) b_veloc
+ read(27) b_accel
+ read(27) b_R_xx
+ read(27) b_R_yy
+ read(27) b_R_xy
+ read(27) b_R_xz
+ read(27) b_R_yz
+ read(27) b_epsilondev_xx
+ read(27) b_epsilondev_yy
+ read(27) b_epsilondev_xy
+ read(27) b_epsilondev_xz
+ read(27) b_epsilondev_yz
+ endif
+ if( ACOUSTIC_SIMULATION ) then
+ read(27) b_potential_acoustic
+ read(27) b_potential_dot_acoustic
+ read(27) b_potential_dot_dot_acoustic
+ endif
+ close(27)
+ else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. mod(it,NSTEP_Q_SAVE) == 0) then
+ ! stores files content
+ write(outputname,"('save_Q_arrays_',i6.6,'.bin')") it
+ open(unit=27,file=trim(prname_Q)//trim(outputname),status='unknown',&
+ action='write',form='unformatted')
+ if( ELASTIC_SIMULATION ) then
+ write(27) displ
+ write(27) veloc
+ write(27) accel
+ write(27) R_xx
+ write(27) R_yy
+ write(27) R_xy
+ write(27) R_xz
+ write(27) R_yz
+ write(27) epsilondev_xx
+ write(27) epsilondev_yy
+ write(27) epsilondev_xy
+ write(27) epsilondev_xz
+ write(27) epsilondev_yz
+ endif
+ if( ACOUSTIC_SIMULATION ) then
+ write(27) b_potential_acoustic
+ write(27) b_potential_dot_acoustic
+ write(27) b_potential_dot_dot_acoustic
+ endif
+ close(27)
+ endif ! SIMULATION_TYPE
+ endif ! it
+
+ end subroutine it_store_attenuation_arrays
+
+!================================================================
+
+ subroutine it_update_adjointkernels()
+
+! kernel calculations
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+
+ implicit none
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: b_displ_elm,accel_elm
+ real(kind=CUSTOM_REAL) :: kappal
+ integer :: i,j,k,ispec,iglob
+
+ !elastic domains
+ if(ELASTIC_SIMULATION ) then
+
+ ! NOTE: kappa and mu kernels have already been updated in compute_forces_elastic()
+
+ ! density kernel update
+ do ispec = 1, NSPEC_AB
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! note: takes displacement from backward/reconstructed (forward) field b_displ
+ ! and acceleration from adjoint field accel (containing adjoint sources)
+ !
+ ! note: : time integral summation uses deltat
+ !
+ ! compare with Tromp et al. (2005), eq. (14), which takes adjoint displacement
+ ! and forward acceleration, that is the symmetric form of what is calculated here
+ ! however, this kernel expression is symmetric with regards to interchange adjoint - forward field
+ rho_kl(i,j,k,ispec) = rho_kl(i,j,k,ispec) &
+ + deltat * dot_product(accel(:,iglob), b_displ(:,iglob))
+ enddo
+ enddo
+ enddo
+ enddo
+
+ ! moho kernel
+ if (SAVE_MOHO_MESH) then
+ call compute_boundary_kernel()
+ endif
+
+ endif ! elastic
+
+ ! acoustic domains
+ if( ACOUSTIC_SIMULATION ) then
+
+ do ispec=1,NSPEC_AB
+
+ ! acoustic wave field
+ if( ispec_is_acoustic(ispec) ) then
+
+ ! backward fields: displacement vector
+ call compute_gradient(ispec,NSPEC_ADJOINT,NGLOB_ADJOINT, &
+ b_potential_acoustic, b_displ_elm,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! adjoint fields: acceleration vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_dot_acoustic, accel_elm,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! density kernel
+ rho_ac_kl(i,j,k,ispec) = rho_ac_kl(i,j,k,ispec) &
+ - deltat * dot_product(accel_elm(:,i,j,k), b_displ_elm(:,i,j,k))
+
+ ! bulk modulus kernel
+ kappal = kappastore(i,j,k,ispec)
+ kappa_ac_kl(i,j,k,ispec) = kappa_ac_kl(i,j,k,ispec) &
+ - deltat * kappal &
+ * potential_dot_dot_acoustic(iglob)/kappal &
+ * b_potential_dot_dot_acoustic(iglob)/kappal
+ enddo
+ enddo
+ enddo
+
+ endif ! ispec_is_acoustic
+ enddo
+ endif !acoustic
+
+ end subroutine it_update_adjointkernels
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/lagrange_poly.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/lagrange_poly.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/lagrange_poly.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,109 @@
+!=====================================================================
+!
+! 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 lagrange_any(xi,NGLL,xigll,h,hprime)
+
+! subroutine to compute the Lagrange interpolants based upon the GLL points
+! and their first derivatives at any point xi in [-1,1]
+
+ implicit none
+
+ integer, intent(in) :: NGLL
+ double precision, intent(in) :: xi,xigll(NGLL)
+ double precision, intent(out) :: h(NGLL),hprime(NGLL)
+
+ integer dgr,i,j
+ double precision prod1,prod2
+
+ do dgr=1,NGLL
+
+ prod1 = 1.0d0
+ prod2 = 1.0d0
+ do i=1,NGLL
+ if(i /= dgr) then
+ prod1 = prod1*(xi-xigll(i))
+ prod2 = prod2*(xigll(dgr)-xigll(i))
+ endif
+ enddo
+ h(dgr)=prod1/prod2
+
+ hprime(dgr)=0.0d0
+ do i=1,NGLL
+ if(i /= dgr) then
+ prod1=1.0d0
+ do j=1,NGLL
+ if(j /= dgr .and. j /= i) prod1 = prod1*(xi-xigll(j))
+ enddo
+ hprime(dgr) = hprime(dgr)+prod1
+ endif
+ enddo
+ hprime(dgr) = hprime(dgr)/prod2
+
+ enddo
+
+ end subroutine lagrange_any
+
+!
+!=====================================================================
+!
+
+! subroutine to compute the derivative of the Lagrange interpolants
+! at the GLL points at any given GLL point
+
+ double precision function lagrange_deriv_GLL(I,j,ZGLL,NZ)
+
+!------------------------------------------------------------------------
+!
+! Compute the value of the derivative of the I-th
+! Lagrange interpolant through the
+! NZ Gauss-Lobatto Legendre points ZGLL at point ZGLL(j)
+!
+!------------------------------------------------------------------------
+
+ implicit none
+
+ integer i,j,nz
+ double precision zgll(0:nz-1)
+
+ integer degpoly
+
+ double precision, external :: pnleg,pndleg
+
+ degpoly = nz - 1
+ if (i == 0 .and. j == 0) then
+ lagrange_deriv_GLL = - dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
+ else if (i == degpoly .and. j == degpoly) then
+ lagrange_deriv_GLL = dble(degpoly)*(dble(degpoly)+1.d0) / 4.d0
+ else if (i == j) then
+ lagrange_deriv_GLL = 0.d0
+ else
+ lagrange_deriv_GLL = pnleg(zgll(j),degpoly) / &
+ (pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))) &
+ + (1.d0-zgll(j)*zgll(j))*pndleg(zgll(j),degpoly) / (dble(degpoly)* &
+ (dble(degpoly)+1.d0)*pnleg(zgll(i),degpoly)*(zgll(j)-zgll(i))*(zgll(j)-zgll(i)))
+ endif
+
+ end function lagrange_deriv_GLL
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/locate_receivers.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/locate_receivers.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/locate_receivers.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,974 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+!----
+!---- locate_receivers finds the correct position of the receivers
+!----
+ subroutine locate_receivers(ibool,myrank,NSPEC_AB,NGLOB_AB, &
+ xstore,ystore,zstore,xigll,yigll,zigll,rec_filename, &
+ nrec,islice_selected_rec,ispec_selected_rec, &
+ xi_receiver,eta_receiver,gamma_receiver,station_name,network_name,nu, &
+ NPROC,utm_x_source,utm_y_source, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ iglob_is_surface_external_mesh,ispec_is_surface_external_mesh, &
+ num_free_surface_faces,free_surface_ispec,free_surface_ijk)
+
+ implicit none
+
+ include "constants.h"
+
+ logical SUPPRESS_UTM_PROJECTION
+
+ integer NPROC,UTM_PROJECTION_ZONE
+
+ integer nrec,myrank
+
+ integer NSPEC_AB,NGLOB_AB
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+! arrays containing coordinates of the points
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: xstore,ystore,zstore
+
+! 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
+ integer :: num_free_surface_faces
+ real(kind=CUSTOM_REAL), dimension(3) :: u_vector,v_vector,w_vector
+ logical, dimension(NGLOB_AB) :: iglob_is_surface_external_mesh
+ logical, dimension(NSPEC_AB) :: ispec_is_surface_external_mesh
+ integer, dimension(num_free_surface_faces) :: free_surface_ispec
+ integer, dimension(3,NGLLSQUARE,num_free_surface_faces) :: free_surface_ijk
+
+ integer, allocatable, dimension(:) :: ix_initial_guess,iy_initial_guess,iz_initial_guess
+
+ integer iprocloop
+ integer ios
+
+ double precision,dimension(1) :: altitude_rec,distmin_ele
+ double precision,dimension(4) :: elevation_node,dist_node
+ double precision,dimension(NPROC) :: distmin_ele_all,elevation_all
+ double precision, allocatable, dimension(:) :: x_target,y_target,z_target
+ double precision, allocatable, dimension(:) :: horiz_dist
+ double precision, allocatable, dimension(:) :: x_found,y_found,z_found
+ double precision, allocatable, dimension(:,:) :: x_found_all,y_found_all,z_found_all
+
+ integer irec
+ integer i,j,k,ispec,iglob,iface,inode,imin,imax,jmin,jmax,kmin,kmax,igll,jgll,kgll
+ integer iselected,jselected,iface_selected,iadjust,jadjust
+ integer iproc(1)
+
+ double precision utm_x_source,utm_y_source
+ double precision dist
+ double precision xi,eta,gamma,dx,dy,dz,dxi,deta,dgamma
+
+! Gauss-Lobatto-Legendre points of integration
+ double precision xigll(NGLLX)
+ double precision yigll(NGLLY)
+ double precision zigll(NGLLZ)
+
+! input receiver file name
+ character(len=*) rec_filename
+
+! topology of the control points of the surface element
+ integer iax,iay,iaz
+ integer iaddx(NGNOD),iaddy(NGNOD),iaddz(NGNOD)
+
+! coordinates of the control points of the surface element
+ double precision xelm(NGNOD),yelm(NGNOD),zelm(NGNOD)
+
+ integer iter_loop,ispec_iterate
+
+ integer ia
+ double precision x,y,z
+ double precision xix,xiy,xiz
+ double precision etax,etay,etaz
+ double precision gammax,gammay,gammaz
+
+! timer MPI
+ double precision, external :: wtime
+ double precision time_start,tCPU
+
+! use dynamic allocation
+ double precision, dimension(:), allocatable :: final_distance
+ double precision, dimension(:,:), allocatable :: final_distance_all
+ double precision distmin,final_distance_max
+
+! receiver information
+! timing information for the stations
+! station information for writing the seismograms
+
+ integer :: iglob_selected
+ integer, dimension(nrec) :: islice_selected_rec,ispec_selected_rec
+ double precision, dimension(nrec) :: xi_receiver,eta_receiver,gamma_receiver
+ double precision, dimension(3,3,nrec) :: nu
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+
+ integer, allocatable, dimension(:,:) :: ispec_selected_rec_all
+ double precision, allocatable, dimension(:) :: stlat,stlon,stele,stbur,stutm_x,stutm_y,elevation
+ double precision, allocatable, dimension(:,:) :: xi_receiver_all,eta_receiver_all,gamma_receiver_all
+ double precision, allocatable, dimension(:,:,:,:) :: nu_all
+
+
+ character(len=256) OUTPUT_FILES
+
+! **************
+
+
+! get MPI starting time
+ time_start = wtime()
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '********************'
+ write(IMAIN,*) ' locating receivers'
+ write(IMAIN,*) '********************'
+ write(IMAIN,*)
+ endif
+
+! define topology of the control element
+ call usual_hex_nodes(iaddx,iaddy,iaddz)
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '*****************************************************************'
+ write(IMAIN,'(1x,a,a,a)') 'reading receiver information from ', trim(rec_filename), ' file'
+ write(IMAIN,*) '*****************************************************************'
+ endif
+
+! get number of stations from receiver file
+ open(unit=1,file=trim(rec_filename),status='old',action='read',iostat=ios)
+ if (ios /= 0) call exit_mpi(myrank,'error opening file '//trim(rec_filename))
+
+! allocate memory for arrays using number of stations
+ allocate(stlat(nrec))
+ allocate(stlon(nrec))
+ allocate(stele(nrec))
+ allocate(stbur(nrec))
+ allocate(stutm_x(nrec))
+ allocate(stutm_y(nrec))
+ allocate(horiz_dist(nrec))
+ allocate(elevation(nrec))
+
+ allocate(ix_initial_guess(nrec))
+ allocate(iy_initial_guess(nrec))
+ allocate(iz_initial_guess(nrec))
+ allocate(x_target(nrec))
+ allocate(y_target(nrec))
+ allocate(z_target(nrec))
+ allocate(x_found(nrec))
+ allocate(y_found(nrec))
+ allocate(z_found(nrec))
+ allocate(final_distance(nrec))
+
+ allocate(ispec_selected_rec_all(nrec,0:NPROC-1))
+ allocate(xi_receiver_all(nrec,0:NPROC-1))
+ allocate(eta_receiver_all(nrec,0:NPROC-1))
+ allocate(gamma_receiver_all(nrec,0:NPROC-1))
+ allocate(x_found_all(nrec,0:NPROC-1))
+ allocate(y_found_all(nrec,0:NPROC-1))
+ allocate(z_found_all(nrec,0:NPROC-1))
+ allocate(final_distance_all(nrec,0:NPROC-1))
+ allocate(nu_all(3,3,nrec,0:NPROC-1))
+
+! loop on all the stations
+ do irec=1,nrec
+
+ read(1,*,iostat=ios) station_name(irec),network_name(irec),stlat(irec),stlon(irec),stele(irec),stbur(irec)
+ if (ios /= 0) call exit_mpi(myrank, 'Error reading station file '//trim(rec_filename))
+
+! convert station location to UTM
+ call utm_geo(stlon(irec),stlat(irec),stutm_x(irec),stutm_y(irec),&
+ UTM_PROJECTION_ZONE,ILONGLAT2UTM,SUPPRESS_UTM_PROJECTION)
+
+! compute horizontal distance between source and receiver in km
+ horiz_dist(irec) = dsqrt((stutm_y(irec)-utm_y_source)**2 + (stutm_x(irec)-utm_x_source)**2) / 1000.
+
+! print some information about stations
+ if(myrank == 0) &
+ write(IMAIN,*) 'Station #',irec,': ',station_name(irec)(1:len_trim(station_name(irec))), &
+ '.',network_name(irec)(1:len_trim(network_name(irec))), &
+ ' horizontal distance: ',sngl(horiz_dist(irec)),' km'
+
+! get approximate topography elevation at source long/lat coordinates
+! set distance to huge initial value
+ distmin = HUGEVAL
+ if(num_free_surface_faces > 0) then
+ iglob_selected = 1
+! loop only on points inside the element
+! exclude edges to ensure this point is not shared with other elements
+ imin = 2
+ imax = NGLLX - 1
+
+ jmin = 2
+ jmax = NGLLY - 1
+ do iface=1,num_free_surface_faces
+ do j=jmin,jmax
+ do i=imin,imax
+
+ ispec = free_surface_ispec(iface)
+ igll = free_surface_ijk(1,(j-1)*NGLLY+i,iface)
+ jgll = free_surface_ijk(2,(j-1)*NGLLY+i,iface)
+ kgll = free_surface_ijk(3,(j-1)*NGLLY+i,iface)
+ iglob = ibool(igll,jgll,kgll,ispec)
+
+ ! keep this point if it is closer to the receiver
+ dist = dsqrt((stutm_x(irec)-dble(xstore(iglob)))**2 + &
+ (stutm_y(irec)-dble(ystore(iglob)))**2)
+ if(dist < distmin) then
+ distmin = dist
+ iglob_selected = iglob
+ iface_selected = iface
+ iselected = i
+ jselected = j
+ altitude_rec(1) = zstore(iglob_selected)
+ endif
+ enddo
+ enddo
+ ! end of loop on all the elements on the free surface
+ end do
+! weighted mean at current point of topography elevation of the four closest nodes
+! set distance to huge initial value
+ distmin = HUGEVAL
+ do j=jselected,jselected+1
+ do i=iselected,iselected+1
+ inode = 1
+ do jadjust=0,1
+ do iadjust= 0,1
+ ispec = free_surface_ispec(iface_selected)
+ igll = free_surface_ijk(1,(j-jadjust-1)*NGLLY+i-iadjust,iface_selected)
+ jgll = free_surface_ijk(2,(j-jadjust-1)*NGLLY+i-iadjust,iface_selected)
+ kgll = free_surface_ijk(3,(j-jadjust-1)*NGLLY+i-iadjust,iface_selected)
+ iglob = ibool(igll,jgll,kgll,ispec)
+
+ elevation_node(inode) = zstore(iglob)
+ dist_node(inode) = dsqrt((stutm_x(irec)-dble(xstore(iglob)))**2 + &
+ (stutm_y(irec)-dble(ystore(iglob)))**2)
+ inode = inode + 1
+ end do
+ end do
+ dist = sum(dist_node)
+ if(dist < distmin) then
+ distmin = dist
+ altitude_rec(1) = (dist_node(1)/dist)*elevation_node(1) + &
+ (dist_node(2)/dist)*elevation_node(2) + &
+ (dist_node(3)/dist)*elevation_node(3) + &
+ (dist_node(4)/dist)*elevation_node(4)
+ endif
+ end do
+ end do
+ end if
+! MPI communications to determine the best slice
+ distmin_ele(1)= distmin
+ call gather_all_dp(distmin_ele,1,distmin_ele_all,1,NPROC)
+ call gather_all_dp(altitude_rec,1,elevation_all,1,NPROC)
+ if(myrank == 0) then
+ iproc = minloc(distmin_ele_all)
+ altitude_rec(1) = elevation_all(iproc(1))
+ end if
+ call bcast_all_dp(altitude_rec,1)
+ elevation(irec) = altitude_rec(1)
+
+! reset distance to huge initial value
+ distmin=HUGEVAL
+
+! get the Cartesian components of n in the model: nu
+
+! orientation consistent with the UTM projection
+
+! East
+ nu(1,1,irec) = 1.d0
+ nu(1,2,irec) = 0.d0
+ nu(1,3,irec) = 0.d0
+
+! North
+ nu(2,1,irec) = 0.d0
+ nu(2,2,irec) = 1.d0
+ nu(2,3,irec) = 0.d0
+
+! Vertical
+ nu(3,1,irec) = 0.d0
+ nu(3,2,irec) = 0.d0
+ nu(3,3,irec) = 1.d0
+
+
+ x_target(irec) = stutm_x(irec)
+ y_target(irec) = stutm_y(irec)
+ z_target(irec) = elevation(irec) - stbur(irec)
+ !z_target(irec) = stbur(irec)
+ !if (myrank == 0) write(IOVTK,*) x_target(irec), y_target(irec), z_target(irec)
+
+! examine top of the elements only (receivers always at the surface)
+! k = NGLLZ
+
+ ispec_selected_rec(irec) = 0
+
+ do ispec=1,NSPEC_AB
+
+! define the interval in which we look for points
+ if(FASTER_RECEIVERS_POINTS_ONLY) then
+ imin = 1
+ imax = NGLLX
+
+ jmin = 1
+ jmax = NGLLY
+
+ kmin = 1
+ kmax = NGLLZ
+
+ else
+! loop only on points inside the element
+! exclude edges to ensure this point is not shared with other elements
+ imin = 2
+ imax = NGLLX - 1
+
+ jmin = 2
+ jmax = NGLLY - 1
+
+ kmin = 2
+ kmax = NGLLZ - 1
+ endif
+
+ do k = kmin,kmax
+ do j = jmin,jmax
+ do i = imin,imax
+
+ iglob = ibool(i,j,k,ispec)
+
+ if (.not. RECVS_CAN_BE_BURIED_EXT_MESH) then
+ if ((.not. iglob_is_surface_external_mesh(iglob)) .or. (.not. ispec_is_surface_external_mesh(ispec))) then
+ cycle
+ endif
+ endif
+
+ dist = dsqrt((x_target(irec)-dble(xstore(iglob)))**2 &
+ +(y_target(irec)-dble(ystore(iglob)))**2 &
+ +(z_target(irec)-dble(zstore(iglob)))**2)
+
+! keep this point if it is closer to the receiver
+ if(dist < distmin) then
+ distmin = dist
+ ispec_selected_rec(irec) = ispec
+ ix_initial_guess(irec) = i
+ iy_initial_guess(irec) = j
+ iz_initial_guess(irec) = k
+
+ xi_receiver(irec) = dble(ix_initial_guess(irec))
+ eta_receiver(irec) = dble(iy_initial_guess(irec))
+ gamma_receiver(irec) = dble(iz_initial_guess(irec))
+ x_found(irec) = xstore(iglob)
+ y_found(irec) = ystore(iglob)
+ z_found(irec) = zstore(iglob)
+ endif
+
+ enddo
+ enddo
+ enddo
+
+! compute final distance between asked and found (converted to km)
+ final_distance(irec) = dsqrt((x_target(irec)-x_found(irec))**2 + &
+ (y_target(irec)-y_found(irec))**2 + (z_target(irec)-z_found(irec))**2)
+! endif
+
+! end of loop on all the spectral elements in current slice
+ enddo
+
+ if (ispec_selected_rec(irec) == 0) then
+ final_distance(irec) = HUGEVAL
+ endif
+
+! get normal to the face of the hexaedra if receiver is on the surface
+ if ((.not. RECVS_CAN_BE_BURIED_EXT_MESH) .and. &
+ .not. (ispec_selected_rec(irec) == 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
+! we get two vectors of the face (three points) to compute the normal
+ if (ix_initial_guess(irec) == 1 .and. &
+ iglob_is_surface_external_mesh(ibool(1,2,2,ispec_selected_rec(irec)))) 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 (ix_initial_guess(irec) == NGLLX .and. &
+ iglob_is_surface_external_mesh(ibool(NGLLX,2,2,ispec_selected_rec(irec)))) 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 (iy_initial_guess(irec) == 1 .and. &
+ iglob_is_surface_external_mesh(ibool(2,1,2,ispec_selected_rec(irec)))) 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 (iy_initial_guess(irec) == NGLLY .and. &
+ iglob_is_surface_external_mesh(ibool(2,NGLLY,2,ispec_selected_rec(irec)))) 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 (iz_initial_guess(irec) == 1 .and. &
+ iglob_is_surface_external_mesh(ibool(2,2,1,ispec_selected_rec(irec)))) 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 (iz_initial_guess(irec) == NGLLZ .and. &
+ iglob_is_surface_external_mesh(ibool(2,2,NGLLZ,ispec_selected_rec(irec)))) 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
+
+ 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 receivers.'
+ endif
+
+ u_vector(1) = xstore(ibool(pt1_ix,pt1_iy,pt1_iz,ispec_selected_rec(irec))) &
+ - xstore(ibool(pt0_ix,pt0_iy,pt0_iz,ispec_selected_rec(irec)))
+ u_vector(2) = ystore(ibool(pt1_ix,pt1_iy,pt1_iz,ispec_selected_rec(irec))) &
+ - ystore(ibool(pt0_ix,pt0_iy,pt0_iz,ispec_selected_rec(irec)))
+ u_vector(3) = zstore(ibool(pt1_ix,pt1_iy,pt1_iz,ispec_selected_rec(irec))) &
+ - zstore(ibool(pt0_ix,pt0_iy,pt0_iz,ispec_selected_rec(irec)))
+ v_vector(1) = xstore(ibool(pt2_ix,pt2_iy,pt2_iz,ispec_selected_rec(irec))) &
+ - xstore(ibool(pt0_ix,pt0_iy,pt0_iz,ispec_selected_rec(irec)))
+ v_vector(2) = ystore(ibool(pt2_ix,pt2_iy,pt2_iz,ispec_selected_rec(irec))) &
+ - ystore(ibool(pt0_ix,pt0_iy,pt0_iz,ispec_selected_rec(irec)))
+ v_vector(3) = zstore(ibool(pt2_ix,pt2_iy,pt2_iz,ispec_selected_rec(irec))) &
+ - zstore(ibool(pt0_ix,pt0_iy,pt0_iz,ispec_selected_rec(irec)))
+
+! 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)
+
+! normalize vector w
+ 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)
+
+! build rotation matrice nu for seismograms
+ if (EXT_MESH_RECV_NORMAL) then
+! East (u)
+ nu(1,1,irec) = u_vector(1)
+ nu(1,2,irec) = v_vector(1)
+ nu(1,3,irec) = w_vector(1)
+
+! North (v)
+ nu(2,1,irec) = u_vector(2)
+ nu(2,2,irec) = v_vector(2)
+ nu(2,3,irec) = w_vector(2)
+
+! Vertical (w)
+ nu(3,1,irec) = u_vector(3)
+ nu(3,2,irec) = v_vector(3)
+ nu(3,3,irec) = w_vector(3)
+ else
+! East
+ nu(1,1,irec) = 1.d0
+ nu(1,2,irec) = 0.d0
+ nu(1,3,irec) = 0.d0
+
+! North
+ nu(2,1,irec) = 0.d0
+ nu(2,2,irec) = 1.d0
+ nu(2,3,irec) = 0.d0
+
+! Vertical
+ nu(3,1,irec) = 0.d0
+ nu(3,2,irec) = 0.d0
+ nu(3,3,irec) = 1.d0
+ endif
+
+ endif ! of if (.not. RECVS_CAN_BE_BURIED_EXT_MESH)
+
+! end of loop on all the stations
+ enddo
+
+! close receiver file
+ close(1)
+
+! ****************************************
+! find the best (xi,eta,gamma) for each receiver
+! ****************************************
+
+ if(.not. FASTER_RECEIVERS_POINTS_ONLY) then
+
+! loop on all the receivers to iterate in that slice
+ do irec = 1,nrec
+
+ ispec_iterate = ispec_selected_rec(irec)
+
+! use initial guess in xi and eta
+
+ xi = xigll(ix_initial_guess(irec))
+ eta = yigll(iy_initial_guess(irec))
+ gamma = zigll(iz_initial_guess(irec))
+
+! define coordinates of the control points of the element
+
+ 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(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
+
+ iglob = ibool(iax,iay,iaz,ispec_iterate)
+ xelm(ia) = dble(xstore(iglob))
+ yelm(ia) = dble(ystore(iglob))
+ zelm(ia) = dble(zstore(iglob))
+
+ enddo
+
+! iterate to solve the non linear system
+ do iter_loop = 1,NUM_ITER
+
+! impose receiver exactly at the surface
+! gamma = 1.d0
+
+! recompute jacobian for the new point
+ 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(irec))
+ dy = - (y - y_target(irec))
+ dz = - (z - z_target(irec))
+
+! compute increments
+! gamma does not change since we know the receiver is exactly on the surface
+ 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
+
+! impose that we stay in that element
+! (useful if user gives a receiver outside the mesh for instance)
+! we can go slightly outside the [1,1] segment since with finite elements
+! the polynomial solution is defined everywhere
+! this can be useful for convergence of itertive scheme with distorted elements
+ if (xi > 1.10d0) xi = 1.10d0
+ if (xi < -1.10d0) xi = -1.10d0
+ if (eta > 1.10d0) eta = 1.10d0
+ if (eta < -1.10d0) eta = -1.10d0
+ if (gamma > 1.10d0) gamma = 1.10d0
+ if (gamma < -1.10d0) gamma = -1.10d0
+
+! end of non linear iterations
+ enddo
+
+! impose receiver exactly at the surface after final iteration
+! gamma = 1.d0
+
+! compute final coordinates of point found
+ call recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
+
+! store xi,eta and x,y,z of point found
+ xi_receiver(irec) = xi
+ eta_receiver(irec) = eta
+ gamma_receiver(irec) = gamma
+ x_found(irec) = x
+ y_found(irec) = y
+ z_found(irec) = z
+
+! compute final distance between asked and found (converted to km)
+ final_distance(irec) = dsqrt((x_target(irec)-x_found(irec))**2 + &
+ (y_target(irec)-y_found(irec))**2 + (z_target(irec)-z_found(irec))**2)
+
+ enddo
+
+ endif ! of if (.not. FASTER_RECEIVERS_POINTS_ONLY)
+
+! synchronize all the processes to make sure all the estimates are available
+ call sync_all()
+
+! for MPI version, gather information from all the nodes
+ ispec_selected_rec_all(:,:) = -1
+ call gather_all_i(ispec_selected_rec,nrec,ispec_selected_rec_all,nrec,NPROC)
+ call gather_all_dp(xi_receiver,nrec,xi_receiver_all,nrec,NPROC)
+ call gather_all_dp(eta_receiver,nrec,eta_receiver_all,nrec,NPROC)
+ call gather_all_dp(gamma_receiver,nrec,gamma_receiver_all,nrec,NPROC)
+ call gather_all_dp(final_distance,nrec,final_distance_all,nrec,NPROC)
+ call gather_all_dp(x_found,nrec,x_found_all,nrec,NPROC)
+ call gather_all_dp(y_found,nrec,y_found_all,nrec,NPROC)
+ call gather_all_dp(z_found,nrec,z_found_all,nrec,NPROC)
+ call gather_all_dp(nu,3*3*nrec,nu_all,3*3*nrec,NPROC)
+
+! this is executed by main process only
+ if(myrank == 0) then
+
+! check that the gather operation went well
+ if(any(ispec_selected_rec_all(:,:) == -1)) call exit_MPI(myrank,'gather operation failed for receivers')
+
+! MPI loop on all the results to determine the best slice
+ islice_selected_rec(:) = -1
+ do irec = 1,nrec
+ distmin = HUGEVAL
+ do iprocloop = 0,NPROC-1
+ if(final_distance_all(irec,iprocloop) < distmin) then
+ distmin = final_distance_all(irec,iprocloop)
+ islice_selected_rec(irec) = iprocloop
+ ispec_selected_rec(irec) = ispec_selected_rec_all(irec,iprocloop)
+ xi_receiver(irec) = xi_receiver_all(irec,iprocloop)
+ eta_receiver(irec) = eta_receiver_all(irec,iprocloop)
+ gamma_receiver(irec) = gamma_receiver_all(irec,iprocloop)
+ x_found(irec) = x_found_all(irec,iprocloop)
+ y_found(irec) = y_found_all(irec,iprocloop)
+ z_found(irec) = z_found_all(irec,iprocloop)
+ nu(:,:,irec) = nu_all(:,:,irec,iprocloop)
+ endif
+ enddo
+ final_distance(irec) = distmin
+ enddo
+
+ do irec=1,nrec
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'station # ',irec,' ',station_name(irec),network_name(irec)
+
+ if(final_distance(irec) == HUGEVAL) call exit_MPI(myrank,'error locating receiver')
+
+ write(IMAIN,*) ' original latitude: ',sngl(stlat(irec))
+ write(IMAIN,*) ' original longitude: ',sngl(stlon(irec))
+ if( SUPPRESS_UTM_PROJECTION ) then
+ write(IMAIN,*) ' original x: ',sngl(stutm_x(irec))
+ write(IMAIN,*) ' original y: ',sngl(stutm_y(irec))
+ else
+ write(IMAIN,*) ' original UTM x: ',sngl(stutm_x(irec))
+ write(IMAIN,*) ' original UTM y: ',sngl(stutm_y(irec))
+ endif
+ write(IMAIN,*) ' original depth: ',sngl(stbur(irec)),' m'
+ write(IMAIN,*) ' horizontal distance: ',sngl(horiz_dist(irec))
+ write(IMAIN,*) ' target x, y, z: ',sngl(x_target(irec)),sngl(y_target(irec)),sngl(z_target(irec))
+
+ write(IMAIN,*) ' closest estimate found: ',sngl(final_distance(irec)),' m away'
+ write(IMAIN,*) ' in slice ',islice_selected_rec(irec),' in element ',ispec_selected_rec(irec)
+ if(FASTER_RECEIVERS_POINTS_ONLY) then
+ write(IMAIN,*) ' in point i,j,k = ',nint(xi_receiver(irec)),nint(eta_receiver(irec)),nint(gamma_receiver(irec))
+ write(IMAIN,*) ' nu1 = ',nu(1,:,irec)
+ write(IMAIN,*) ' nu2 = ',nu(2,:,irec)
+ write(IMAIN,*) ' nu3 = ',nu(3,:,irec)
+ else
+ write(IMAIN,*) ' at coordinates: '
+ write(IMAIN,*) ' xi = ',xi_receiver(irec)
+ write(IMAIN,*) ' eta = ',eta_receiver(irec)
+ write(IMAIN,*) ' gamma = ',gamma_receiver(irec)
+ endif
+ if( SUPPRESS_UTM_PROJECTION ) then
+ write(IMAIN,*) ' x: ',x_found(irec)
+ write(IMAIN,*) ' y: ',y_found(irec)
+ else
+ write(IMAIN,*) ' UTM x: ',x_found(irec)
+ write(IMAIN,*) ' UTM y: ',y_found(irec)
+ endif
+ write(IMAIN,*) ' depth: ',dabs(z_found(irec) - elevation(irec)),' m'
+ write(IMAIN,*) ' z: ',z_found(irec)
+ write(IMAIN,*)
+
+
+! add warning if estimate is poor
+! (usually means receiver outside the mesh given by the user)
+ if(final_distance(irec) > 3000.d0) then
+ write(IMAIN,*) '*******************************************************'
+ write(IMAIN,*) '***** WARNING: receiver location estimate is poor *****'
+ write(IMAIN,*) '*******************************************************'
+ endif
+
+ write(IMAIN,*)
+
+ enddo
+
+! compute maximal distance for all the receivers
+ final_distance_max = maxval(final_distance(:))
+
+! display maximum error for all the receivers
+ write(IMAIN,*) 'maximum error in location of all the receivers: ',sngl(final_distance_max),' m'
+
+! add warning if estimate is poor
+! (usually means receiver outside the mesh given by the user)
+ if(final_distance_max > 1000.d0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '************************************************************'
+ write(IMAIN,*) '************************************************************'
+ write(IMAIN,*) '***** WARNING: at least one receiver is poorly located *****'
+ write(IMAIN,*) '************************************************************'
+ write(IMAIN,*) '************************************************************'
+ endif
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! write the list of stations and associated epicentral distance
+ open(unit=27,file=trim(OUTPUT_FILES)//'/output_list_stations.txt',status='unknown')
+ do irec=1,nrec
+ write(27,*) station_name(irec),'.',network_name(irec),' : ',horiz_dist(irec),' km horizontal distance'
+ enddo
+ close(27)
+
+! elapsed time since beginning of mesh generation
+ tCPU = wtime() - time_start
+ write(IMAIN,*)
+ write(IMAIN,*) 'Elapsed time for receiver detection in seconds = ',tCPU
+ write(IMAIN,*)
+ write(IMAIN,*) 'End of receiver detection - done'
+ write(IMAIN,*)
+
+ endif ! end of section executed by main process only
+
+! main process broadcasts the results to all the slices
+ call bcast_all_i(islice_selected_rec,nrec)
+ call bcast_all_i(ispec_selected_rec,nrec)
+ call bcast_all_dp(xi_receiver,nrec)
+ call bcast_all_dp(eta_receiver,nrec)
+ call bcast_all_dp(gamma_receiver,nrec)
+! synchronize all the processes to make sure everybody has finished
+ call sync_all()
+
+! deallocate arrays
+ deallocate(stlat)
+ deallocate(stlon)
+ deallocate(stele)
+ deallocate(stbur)
+ deallocate(stutm_x)
+ deallocate(stutm_y)
+ deallocate(horiz_dist)
+ deallocate(ix_initial_guess)
+ deallocate(iy_initial_guess)
+ deallocate(iz_initial_guess)
+ deallocate(x_target)
+ deallocate(y_target)
+ deallocate(z_target)
+ deallocate(x_found)
+ deallocate(y_found)
+ deallocate(z_found)
+ deallocate(final_distance)
+ deallocate(ispec_selected_rec_all)
+ deallocate(xi_receiver_all)
+ deallocate(eta_receiver_all)
+ deallocate(gamma_receiver_all)
+ deallocate(x_found_all)
+ deallocate(y_found_all)
+ deallocate(z_found_all)
+ deallocate(final_distance_all)
+
+ end subroutine locate_receivers
+
+!=====================================================================
+
+
+ subroutine station_filter(SUPPRESS_UTM_PROJECTION,UTM_PROJECTION_ZONE,myrank,filename,filtered_filename,nfilter, &
+ LATITUDE_MIN, LATITUDE_MAX, LONGITUDE_MIN, LONGITUDE_MAX)
+
+ implicit none
+
+ include 'constants.h'
+
+! input
+ logical :: SUPPRESS_UTM_PROJECTION
+ integer :: UTM_PROJECTION_ZONE
+ integer :: myrank
+ character(len=*) :: filename,filtered_filename
+ double precision :: LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN,LONGITUDE_MAX
+
+! output
+ integer :: nfilter
+
+ integer :: nrec, nrec_filtered, ios !, irec
+
+ double precision :: stlat,stlon,stele,stbur,stutm_x,stutm_y
+ character(len=MAX_LENGTH_STATION_NAME) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME) :: network_name
+ character(len=256) :: dummystring
+
+ nrec = 0
+ nrec_filtered = 0
+
+ ! counts number of lines in stations file
+ open(unit=IIN, file=trim(filename), status = 'old', iostat = ios)
+ if (ios /= 0) call exit_mpi(myrank, 'No file '//trim(filename)//', exit')
+ do while(ios == 0)
+ read(IIN,"(a256)",iostat = ios) dummystring
+ if(ios /= 0) exit
+
+ if( len_trim(dummystring) > 0 ) nrec = nrec + 1
+ enddo
+ close(IIN)
+
+ ! reads in station locations
+ open(unit=IIN, file=trim(filename), status = 'old', iostat = ios)
+ !do irec = 1,nrec
+ ! read(IIN,*) station_name,network_name,stlat,stlon,stele,stbur
+ do while(ios == 0)
+ read(IIN,"(a256)",iostat = ios) dummystring
+ if( ios /= 0 ) exit
+
+ ! counts number of stations in min/max region
+ if( len_trim(dummystring) > 0 ) then
+ dummystring = trim(dummystring)
+ read(dummystring, *) station_name, network_name, stlat, stlon, stele, stbur
+
+ ! convert station location to UTM
+ call utm_geo(stlon,stlat,stutm_x,stutm_y,&
+ UTM_PROJECTION_ZONE,ILONGLAT2UTM,SUPPRESS_UTM_PROJECTION)
+
+ ! counts stations within lon/lat region
+ if( stutm_y >= LATITUDE_MIN .and. stutm_y <= LATITUDE_MAX .and. &
+ stutm_x >= LONGITUDE_MIN .and. stutm_x <= LONGITUDE_MAX) &
+ nrec_filtered = nrec_filtered + 1
+ endif
+ enddo
+ close(IIN)
+
+ ! writes out filtered stations file
+ if (myrank == 0) then
+ open(unit=IIN,file=trim(filename),status='old',action='read',iostat=ios)
+ open(unit=IOUT,file=trim(filtered_filename),status='unknown')
+ !write(IOUT,*) nrec_filtered
+ !do irec = 1,nrec
+ do while(ios == 0)
+ read(IIN,"(a256)",iostat = ios) dummystring
+ if( ios /= 0 ) exit
+
+ !read(IIN,*) station_name,network_name,stlat,stlon,stele,stbur
+ if( len_trim(dummystring) > 0 ) then
+ dummystring = trim(dummystring)
+ read(dummystring, *) station_name, network_name, stlat, stlon, stele, stbur
+
+ ! convert station location to UTM
+ call utm_geo(stlon,stlat,stutm_x,stutm_y,&
+ UTM_PROJECTION_ZONE,ILONGLAT2UTM,SUPPRESS_UTM_PROJECTION)
+
+ if( stutm_y >= LATITUDE_MIN .and. stutm_y <= LATITUDE_MAX .and. &
+ stutm_x >= LONGITUDE_MIN .and. stutm_x <= LONGITUDE_MAX) then
+ write(IOUT,*) trim(station_name),' ',trim(network_name),' ',sngl(stlat), &
+ ' ',sngl(stlon), ' ',sngl(stele), ' ',sngl(stbur)
+ endif
+ end if
+ enddo
+ close(IIN)
+ close(IOUT)
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'there are ',nrec,' stations in file ', trim(filename)
+ write(IMAIN,*) 'saving ',nrec_filtered,' stations inside the model in file ', trim(filtered_filename)
+ write(IMAIN,*) 'excluding ',nrec - nrec_filtered,' stations located outside the model'
+ write(IMAIN,*)
+
+ if( nrec_filtered < 1 ) then
+ write(IMAIN,*) 'error filtered stations:'
+ write(IMAIN,*) ' simulation needs at least 1 station but got ',nrec_filtered
+ write(IMAIN,*)
+ write(IMAIN,*) ' check that stations in file '//trim(filename)//' are within'
+ write(IMAIN,*) ' latitude min/max : ',LATITUDE_MIN,LATITUDE_MAX
+ write(IMAIN,*) ' longitude min/max: ',LONGITUDE_MIN,LONGITUDE_MAX
+ write(IMAIN,*)
+ endif
+
+ endif
+
+ nfilter = nrec_filtered
+
+ end subroutine station_filter
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/locate_source.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/locate_source.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/locate_source.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,876 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+!----
+!---- locate_source finds the correct position of the source
+!----
+
+ subroutine locate_source(ibool,NSOURCES,myrank,NSPEC_AB,NGLOB_AB,xstore,ystore,zstore, &
+ xigll,yigll,zigll,NPROC, &
+ t_cmt,yr,jda,ho,mi,utm_x_source,utm_y_source, &
+ DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ islice_selected_source,ispec_selected_source, &
+ xi_source,eta_source,gamma_source, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ PRINT_SOURCE_TIME_FUNCTION, &
+ nu_source,iglob_is_surface_external_mesh,ispec_is_surface_external_mesh, &
+ ispec_is_acoustic,ispec_is_elastic, &
+ num_free_surface_faces,free_surface_ispec,free_surface_ijk)
+
+ implicit none
+
+ include "constants.h"
+
+ integer NPROC,UTM_PROJECTION_ZONE
+ integer NSPEC_AB,NGLOB_AB,NSOURCES
+
+ logical PRINT_SOURCE_TIME_FUNCTION,SUPPRESS_UTM_PROJECTION
+
+ double precision DT
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: ibool
+
+ integer myrank
+
+! arrays containing coordinates of the points
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: xstore,ystore,zstore
+
+ logical, dimension(NSPEC_AB) :: ispec_is_acoustic,ispec_is_elastic
+
+ integer yr,jda,ho,mi
+
+ double precision t_cmt(NSOURCES)
+ double precision sec
+
+ integer iprocloop
+
+ integer i,j,k,ispec,iglob,iglob_selected,inode,iface,isource,imin,imax,jmin,jmax,kmin,kmax,igll,jgll,kgll
+ integer iselected,jselected,iface_selected,iadjust,jadjust
+ integer iproc(1)
+
+ double precision, dimension(NSOURCES) :: utm_x_source,utm_y_source
+ double precision dist
+ double precision xi,eta,gamma,dx,dy,dz,dxi,deta
+
+ ! Gauss-Lobatto-Legendre points of integration
+ double precision xigll(NGLLX)
+ double precision yigll(NGLLY)
+ double precision zigll(NGLLZ)
+
+ ! topology of the control points of the surface element
+ integer iax,iay,iaz
+ integer iaddx(NGNOD),iaddy(NGNOD),iaddz(NGNOD)
+
+ ! coordinates of the control points of the surface element
+ double precision xelm(NGNOD),yelm(NGNOD),zelm(NGNOD)
+
+ integer iter_loop
+
+ integer ia
+ double precision x,y,z
+ double precision xix,xiy,xiz
+ double precision etax,etay,etaz
+ double precision gammax,gammay,gammaz
+ double precision dgamma
+
+ double precision final_distance_source(NSOURCES)
+
+ double precision x_target_source,y_target_source,z_target_source
+
+ double precision,dimension(1) :: altitude_source,distmin_ele
+ double precision,dimension(NPROC) :: distmin_ele_all,elevation_all
+ double precision,dimension(4) :: elevation_node,dist_node
+
+ integer islice_selected_source(NSOURCES)
+
+ ! timer MPI
+ double precision, external :: wtime
+ double precision time_start,tCPU
+
+ integer ispec_selected_source(NSOURCES)
+
+ integer ngather, ns, ne, ig, is, ng
+
+ integer, dimension(NGATHER_SOURCES,0:NPROC-1) :: ispec_selected_source_all
+ double precision, dimension(NGATHER_SOURCES,0:NPROC-1) :: xi_source_all,eta_source_all,gamma_source_all, &
+ 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
+ double precision, dimension(NSOURCES) :: xi_source,eta_source,gamma_source
+ double precision, dimension(3,3,NSOURCES) :: nu_source
+
+ double precision, dimension(NSOURCES) :: lat,long,depth
+ double precision moment_tensor(6,NSOURCES)
+
+ character(len=256) OUTPUT_FILES
+
+ double precision, dimension(NSOURCES) :: x_found_source,y_found_source,z_found_source
+ double precision, dimension(NSOURCES) :: elevation
+ 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
+ integer :: num_free_surface_faces
+ real(kind=CUSTOM_REAL), dimension(3) :: u_vector,v_vector,w_vector
+ logical, dimension(NGLOB_AB) :: iglob_is_surface_external_mesh
+ logical, dimension(NSPEC_AB) :: ispec_is_surface_external_mesh
+ integer, dimension(num_free_surface_faces) :: free_surface_ispec
+ integer, dimension(3,NGLLSQUARE,num_free_surface_faces) :: free_surface_ijk
+
+ integer ix_initial_guess_source,iy_initial_guess_source,iz_initial_guess_source
+
+ ! for calculation of source time function
+ !integer it
+ !double precision time_source
+ !double precision, external :: comp_source_time_function
+
+ integer, dimension(NSOURCES) :: idomain
+ integer, dimension(NGATHER_SOURCES,0:NPROC-1) :: idomain_all
+
+
+ ! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+ ! read all the sources
+ call get_cmt(yr,jda,ho,mi,sec,t_cmt,hdur,lat,long,depth,moment_tensor,NSOURCES)
+
+ ! checks half-durations
+ do isource = 1, NSOURCES
+ ! null half-duration indicates a Heaviside
+ ! replace with very short error function
+ if(hdur(isource) < 5. * DT) hdur(isource) = 5. * DT
+ enddo
+
+ ! convert the half duration for triangle STF to the one for gaussian STF
+ !hdur_gaussian = hdur/SOURCE_DECAY_MIMIC_TRIANGLE
+
+ ! define t0 as the earliest start time
+ !t0 = - 1.5d0 * minval(t_cmt-hdur)
+
+ ! define topology of the control element
+ call usual_hex_nodes(iaddx,iaddy,iaddz)
+
+ ! get MPI starting time
+ time_start = wtime()
+
+ ! loop on all the sources
+ do isource = 1,NSOURCES
+
+ !
+ ! r -> z, theta -> -y, phi -> x
+ !
+ ! Mrr = Mzz
+ ! Mtt = Myy
+ ! Mpp = Mxx
+ ! Mrt = -Myz
+ ! Mrp = Mxz
+ ! 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)
+
+ ! gets UTM x,y
+ call utm_geo(long(isource),lat(isource),utm_x_source(isource),utm_y_source(isource), &
+ UTM_PROJECTION_ZONE,ILONGLAT2UTM,SUPPRESS_UTM_PROJECTION)
+
+ ! get approximate topography elevation at source long/lat coordinates
+ ! set distance to huge initial value
+ distmin = HUGEVAL
+ if(num_free_surface_faces > 0) then
+ iglob_selected = 1
+ ! loop only on points inside the element
+ ! exclude edges to ensure this point is not shared with other elements
+ imin = 2
+ imax = NGLLX - 1
+
+ jmin = 2
+ jmax = NGLLY - 1
+ do iface=1,num_free_surface_faces
+ do j=jmin,jmax
+ do i=imin,imax
+
+ ispec = free_surface_ispec(iface)
+ igll = free_surface_ijk(1,(j-1)*NGLLY+i,iface)
+ jgll = free_surface_ijk(2,(j-1)*NGLLY+i,iface)
+ kgll = free_surface_ijk(3,(j-1)*NGLLY+i,iface)
+ iglob = ibool(igll,jgll,kgll,ispec)
+
+ ! keep this point if it is closer to the receiver
+ dist = dsqrt((utm_x_source(isource)-dble(xstore(iglob)))**2 + &
+ (utm_y_source(isource)-dble(ystore(iglob)))**2)
+ if(dist < distmin) then
+ distmin = dist
+ iglob_selected = iglob
+ iface_selected = iface
+ iselected = i
+ jselected = j
+ altitude_source(1) = zstore(iglob_selected)
+ endif
+ enddo
+ enddo
+ ! end of loop on all the elements on the free surface
+ end do
+! weighted mean at current point of topography elevation of the four closest nodes
+! set distance to huge initial value
+ distmin = HUGEVAL
+ do j=jselected,jselected+1
+ do i=iselected,iselected+1
+ inode = 1
+ do jadjust=0,1
+ do iadjust= 0,1
+ ispec = free_surface_ispec(iface_selected)
+ igll = free_surface_ijk(1,(j-jadjust-1)*NGLLY+i-iadjust,iface_selected)
+ jgll = free_surface_ijk(2,(j-jadjust-1)*NGLLY+i-iadjust,iface_selected)
+ kgll = free_surface_ijk(3,(j-jadjust-1)*NGLLY+i-iadjust,iface_selected)
+ iglob = ibool(igll,jgll,kgll,ispec)
+
+ elevation_node(inode) = zstore(iglob)
+ dist_node(inode) = dsqrt((utm_x_source(isource)-dble(xstore(iglob)))**2 + &
+ (utm_y_source(isource)-dble(ystore(iglob)))**2)
+ inode = inode + 1
+ end do
+ end do
+ dist = sum(dist_node)
+ if(dist < distmin) then
+ distmin = dist
+ altitude_source(1) = (dist_node(1)/dist)*elevation_node(1) + &
+ (dist_node(2)/dist)*elevation_node(2) + &
+ (dist_node(3)/dist)*elevation_node(3) + &
+ (dist_node(4)/dist)*elevation_node(4)
+ endif
+ end do
+ end do
+ end if
+ ! MPI communications to determine the best slice
+ distmin_ele(1)= distmin
+ call gather_all_dp(distmin_ele,1,distmin_ele_all,1,NPROC)
+ call gather_all_dp(altitude_source,1,elevation_all,1,NPROC)
+ if(myrank == 0) then
+ iproc = minloc(distmin_ele_all)
+ altitude_source(1) = elevation_all(iproc(1))
+ end if
+ call bcast_all_dp(altitude_source,1)
+ elevation(isource) = altitude_source(1)
+
+ ! 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
+ ! North
+ 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
+
+ x_target_source = utm_x_source(isource)
+ y_target_source = utm_y_source(isource)
+ !z_target_source = depth(isource)
+ z_target_source = - depth(isource)*1000.0d0 + elevation(isource)
+
+ ! set distance to huge initial value
+ distmin = HUGEVAL
+
+ ispec_selected_source(isource) = 0
+
+ do ispec=1,NSPEC_AB
+
+
+ ! define the interval in which we look for points
+ if(USE_FORCE_POINT_SOURCE) then
+ imin = 1
+ imax = NGLLX
+
+ jmin = 1
+ jmax = NGLLY
+
+ kmin = 1
+ kmax = NGLLZ
+
+ else
+ ! loop only on points inside the element
+ ! exclude edges to ensure this point is not shared with other elements
+ imin = 2
+ imax = NGLLX - 1
+
+ jmin = 2
+ jmax = NGLLY - 1
+
+ kmin = 2
+ kmax = NGLLZ - 1
+ endif
+
+ do k = kmin,kmax
+ do j = jmin,jmax
+ do i = imin,imax
+
+ iglob = ibool(i,j,k,ispec)
+
+ if (.not. SOURCES_CAN_BE_BURIED_EXT_MESH) then
+ if ((.not. iglob_is_surface_external_mesh(iglob)) .or. (.not. ispec_is_surface_external_mesh(ispec))) then
+ cycle
+ endif
+ endif
+
+ ! keep this point if it is closer to the source
+ 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
+
+ ! 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)
+
+ ! 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)
+
+ endif
+
+ enddo
+ enddo
+ enddo
+
+ ! end of loop on all the elements in current slice
+ enddo
+
+ if (ispec_selected_source(isource) == 0) then
+ final_distance_source(isource) = HUGEVAL
+ endif
+
+ ! sets whether acoustic (1) or elastic (2)
+ if( ispec_is_acoustic( ispec_selected_source(isource) ) ) then
+ idomain(isource) = 1
+ else if( ispec_is_elastic( ispec_selected_source(isource) ) ) then
+ idomain(isource) = 2
+ else
+ idomain(isource) = 0
+ endif
+
+ ! get normal to the face of the hexaedra if receiver is on the surface
+ 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
+ ! we get two vectors of the face (three points) to compute the normal
+ 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. &
+ 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. &
+ 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. &
+ 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. &
+ 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. &
+ 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
+
+ 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
+
+ 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))) &
+ - 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))) &
+ - 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))) &
+ - 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))) &
+ - 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))) &
+ - 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)
+
+ ! normalize vector w
+ 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)
+
+ ! build rotation matrice nu for seismograms
+ ! East (u)
+ nu_source(1,1,isource) = u_vector(1)
+ nu_source(1,2,isource) = v_vector(1)
+ nu_source(1,3,isource) = w_vector(1)
+ ! North (v)
+ nu_source(2,1,isource) = u_vector(2)
+ nu_source(2,2,isource) = v_vector(2)
+ nu_source(2,3,isource) = w_vector(2)
+ ! Vertical (w)
+ nu_source(3,1,isource) = u_vector(3)
+ 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)
+
+! *******************************************
+! find the best (xi,eta,gamma) for the source
+! *******************************************
+
+ 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)
+
+ ! define coordinates of the control points of the element
+ 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(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
+
+ 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
+
+ ! iterate to solve the non linear system
+ do iter_loop = 1,NUM_ITER
+
+ ! recompute jacobian for the new point
+ 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)
+
+ ! compute increments
+ 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
+
+ ! 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
+
+ enddo
+
+ ! compute final coordinates of point found
+ 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
+ ! note: xi/eta/gamma will be in range [-1,1]
+ 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)
+
+ endif ! of if (.not. USE_FORCE_POINT_SOURCE)
+
+ ! end of loop on all the sources
+ enddo
+
+ ! now gather information from all the nodes
+ ngather = NSOURCES/NGATHER_SOURCES
+ if (mod(NSOURCES,NGATHER_SOURCES)/= 0) ngather = ngather+1
+ do ig = 1, ngather
+ ns = (ig-1) * NGATHER_SOURCES + 1
+ ne = min(ig*NGATHER_SOURCES, NSOURCES)
+ ng = ne - ns + 1
+
+ ispec_selected_source_all(:,:) = -1
+
+ ! 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))
+ 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(:,:)
+
+ ! acoustic/elastic domain
+ tmp_i_local(:) = idomain(ns:ne)
+ call gather_all_i(tmp_i_local,ng,tmp_i_all_local,ng,NPROC)
+ idomain_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))
+ 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(:,:)
+
+ 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(:,:)
+
+ 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(:,:)
+
+ 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(:,:)
+
+ 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(:,:)
+
+ 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(:,:)
+
+ 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(:,:)
+
+ 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
+
+ ! 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')
+
+ ! loop on all the sources
+ 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)
+ idomain(isource) = idomain_all(is,iprocloop)
+ endif
+ enddo
+ final_distance_source(isource) = distmin
+
+ enddo
+ endif !myrank
+ enddo ! ngather
+
+ if (myrank == 0) then
+
+ do isource = 1,NSOURCES
+
+ 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)
+ if( idomain(isource) == 1 ) then
+ write(IMAIN,*) ' in acoustic domain'
+ else if( idomain(isource) == 2 ) then
+ write(IMAIN,*) ' in elastic domain'
+ else
+ write(IMAIN,*) ' in unknown domain'
+ endif
+
+ 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
+
+ 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,*)
+ if( SUPPRESS_UTM_PROJECTION ) then
+ write(IMAIN,*) ' x: ',utm_x_source(isource)
+ write(IMAIN,*) ' y: ',utm_y_source(isource)
+ else
+ write(IMAIN,*) ' UTM x: ',utm_x_source(isource)
+ write(IMAIN,*) ' UTM y: ',utm_y_source(isource)
+ endif
+ write(IMAIN,*) ' depth: ',depth(isource),' km'
+ write(IMAIN,*) 'topo elevation: ',elevation(isource)
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'position of the source that will be used:'
+ write(IMAIN,*)
+ if( SUPPRESS_UTM_PROJECTION ) then
+ write(IMAIN,*) ' x: ',x_found_source(isource)
+ write(IMAIN,*) ' y: ',y_found_source(isource)
+ else
+ write(IMAIN,*) ' UTM x: ',x_found_source(isource)
+ write(IMAIN,*) ' UTM y: ',y_found_source(isource)
+ endif
+ write(IMAIN,*) ' depth: ',dabs(z_found_source(isource) - elevation(isource))/1000.,' km'
+ write(IMAIN,*) ' z: ',z_found_source(isource)
+ write(IMAIN,*)
+
+ ! display error in location estimate
+ 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
+
+ endif ! end of detailed output to locate source
+
+ if(PRINT_SOURCE_TIME_FUNCTION) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'printing the source-time function'
+ endif
+
+ ! checks CMTSOLUTION format for acoustic case
+ if( idomain(isource) == 1 ) then
+ if( Mxx(isource) /= Myy(isource) .or. Myy(isource) /= Mzz(isource) .or. &
+ Mxy(isource) > TINYVAL .or. Mxz(isource) > TINYVAL .or. Myz(isource) > TINYVAL ) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' error CMTSOLUTION format for acoustic source:'
+ write(IMAIN,*) ' acoustic source needs explosive moment tensor with'
+ write(IMAIN,*) ' Mrr = Mtt = Mpp '
+ write(IMAIN,*) ' and '
+ write(IMAIN,*) ' Mrt = Mrp = Mtp = zero'
+ write(IMAIN,*)
+ call exit_mpi(myrank,'error acoustic source')
+ endif
+ endif
+
+! end of loop on all the sources
+ enddo
+
+! display maximum error in location estimate
+ write(IMAIN,*)
+ write(IMAIN,*) 'maximum error in location of the sources: ',sngl(maxval(final_distance_source)),' m'
+ write(IMAIN,*)
+
+ endif ! end of section executed by main process only
+
+! main process broadcasts the results to all the slices
+ call bcast_all_i(islice_selected_source,NSOURCES)
+ call bcast_all_i(ispec_selected_source,NSOURCES)
+ call bcast_all_dp(xi_source,NSOURCES)
+ call bcast_all_dp(eta_source,NSOURCES)
+ call bcast_all_dp(gamma_source,NSOURCES)
+
+! elapsed time since beginning of source detection
+ if(myrank == 0) then
+ tCPU = wtime() - time_start
+ write(IMAIN,*)
+ write(IMAIN,*) 'Elapsed time for detection of sources in seconds = ',tCPU
+ write(IMAIN,*)
+ write(IMAIN,*) 'End of source detection - done'
+ write(IMAIN,*)
+ endif
+
+ end subroutine locate_source
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/memory_eval.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/memory_eval.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/memory_eval.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,139 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+
+! compute the approximate amount of static memory needed to run the solver
+
+ subroutine memory_eval(NSPEC_AB,NGLOB_AB,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh,static_memory_size)
+
+ implicit none
+
+ include "constants.h"
+
+! input
+! logical, intent(in) :: ATTENUATION
+ integer, intent(in) :: NSPEC_AB,NGLOB_AB
+ integer, intent(in) :: max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh
+
+! output
+ double precision, intent(out) :: static_memory_size
+
+
+ static_memory_size = 0.d0
+
+! add size of each set of static arrays multiplied by the number of such arrays
+
+! ibool,idoubling
+ static_memory_size = static_memory_size + 2.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_AB*dble(SIZE_INTEGER)
+
+! xix,xiy,xiz,
+! etax,etay,etaz,
+! gammax,gammay,gammaz,jacobian
+! kappavstore,muvstore
+! flag_sediments,rho_vp,rho_vs
+ static_memory_size = static_memory_size + 15.d0*dble(NGLLX)*dble(NGLLY)*dble(NGLLZ)*NSPEC_AB*dble(CUSTOM_REAL)
+
+! xstore,ystore,zstore,rmass,rmass_ocean_load
+ static_memory_size = static_memory_size + 5.d0*NGLOB_AB*dble(CUSTOM_REAL)
+
+! updated_dof_ocean_load,iglob_is_inner_ext_mesh
+ static_memory_size = static_memory_size + 2.d0*NGLOB_AB*dble(SIZE_LOGICAL)
+
+! ispec_is_inner_ext_mesh
+ static_memory_size = static_memory_size + NSPEC_AB*dble(SIZE_LOGICAL)
+
+! displ,veloc,accel
+ static_memory_size = static_memory_size + 3.d0*dble(NDIM)*NGLOB_AB*dble(CUSTOM_REAL)
+
+! my_neighbours_ext_mesh,nibool_interfaces_ext_mesh
+ static_memory_size = static_memory_size + 2.d0*num_interfaces_ext_mesh*dble(SIZE_INTEGER)
+
+! ibool_interfaces_ext_mesh
+ static_memory_size = static_memory_size + max_nibool_interfaces_ext_mesh*num_interfaces_ext_mesh*dble(SIZE_INTEGER)
+
+! buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh
+ static_memory_size = static_memory_size + 2.d0*dble(NDIM)*max_nibool_interfaces_ext_mesh*num_interfaces_ext_mesh*dble(CUSTOM_REAL)
+
+! buffer_send_scalar_ext_mesh,buffer_recv_scalar_ext_mesh
+ static_memory_size = static_memory_size + 2.d0*max_nibool_interfaces_ext_mesh*num_interfaces_ext_mesh*dble(CUSTOM_REAL)
+
+! request_send_vector_ext_mesh,request_recv_vector_ext_mesh,request_send_scalar_ext_mesh,request_recv_scalar_ext_mesh
+ static_memory_size = static_memory_size + 4.d0*num_interfaces_ext_mesh*dble(SIZE_INTEGER)
+
+
+ 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,num_interfaces_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,num_interfaces_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*num_interfaces_ext_mesh + 6*max_interface_size_ext_mesh*num_interfaces_ext_mesh*4 &
+ + NGLLX*NGLLX*max_interface_size_ext_mesh*num_interfaces_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() 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
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/mesh_vertical.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/mesh_vertical.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/mesh_vertical.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,120 @@
+!=====================================================================
+!
+! 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 mesh_vertical(myrank,rn,NER,NER_BOTTOM_MOHO,NER_MOHO_16, &
+ NER_16_BASEMENT,NER_BASEMENT_SEDIM,NER_SEDIM, &
+!! DK DK UGLY modif z_top by Emmanuel Chaljub here
+!! DK DK UGLY modif Manu removed z_top, &
+ Z_DEPTH_BLOCK,Z_BASEMENT_SURFACE,Z_DEPTH_MOHO,MOHO_MAP_LUPEI)
+
+! create the vertical mesh, honoring the major discontinuities in the model
+
+ implicit none
+
+ include "constants.h"
+
+ integer myrank
+ integer NER,NER_BOTTOM_MOHO,NER_MOHO_16,NER_16_BASEMENT,NER_BASEMENT_SEDIM,NER_SEDIM
+ logical MOHO_MAP_LUPEI
+ double precision Z_DEPTH_BLOCK,Z_BASEMENT_SURFACE,Z_DEPTH_MOHO
+ double precision rn(0:2*NER)
+
+!! DK DK UGLY modif z_top by Emmanuel Chaljub here
+!! DK DK UGLY modif Manu removed double precision z_top
+
+ integer npr,ir
+
+ npr = -1
+
+!
+!--- bottom of the mesh (Z_DEPTH_BLOCK) to Moho
+!
+ do ir=0,2*NER_BOTTOM_MOHO-1
+ npr=npr+1
+ rn(npr)=(Z_DEPTH_MOHO-Z_DEPTH_BLOCK)*dble(ir)/dble(2*NER_BOTTOM_MOHO)
+ enddo
+
+! do not use d16km when Moho map is honored
+ if(MOHO_MAP_LUPEI) then
+
+!
+!--- Moho to modified basement surface
+!
+ do ir=0,2*(NER_MOHO_16+NER_16_BASEMENT)-1
+ npr=npr+1
+ rn(npr)=(Z_DEPTH_MOHO-Z_DEPTH_BLOCK) + (Z_BASEMENT_SURFACE-Z_DEPTH_MOHO)*dble(ir)/dble(2*(NER_MOHO_16+NER_16_BASEMENT))
+ enddo
+
+ else
+!
+!--- Moho to d16km
+!
+ do ir=0,2*NER_MOHO_16-1
+ npr=npr+1
+ rn(npr)=(Z_DEPTH_MOHO-Z_DEPTH_BLOCK) + (DEPTH_16km_SOCAL-Z_DEPTH_MOHO)*dble(ir)/dble(2*NER_MOHO_16)
+ enddo
+!
+!--- d16km to modified basement surface
+!
+ do ir=0,2*NER_16_BASEMENT-1
+ npr=npr+1
+ rn(npr)=(DEPTH_16km_SOCAL-Z_DEPTH_BLOCK) + (Z_BASEMENT_SURFACE-DEPTH_16km_SOCAL)*dble(ir)/dble(2*NER_16_BASEMENT)
+ enddo
+
+ endif
+
+!
+!--- modified basement surface to surface of model (topography/bathymetry)
+!
+! also create last point exactly at the surface
+! other regions above stop one point below
+ do ir=0,2*(NER_BASEMENT_SEDIM+NER_SEDIM) - 0
+ npr=npr+1
+ rn(npr)=(Z_BASEMENT_SURFACE-Z_DEPTH_BLOCK) + &
+!! DK DK UGLY modif z_top by Emmanuel Chaljub here
+!! DK DK UGLY suppressed Manu's modif and put old code back because better mesh
+!! DK DK UGLY investigate this in detail one day
+ (Z_SURFACE-Z_BASEMENT_SURFACE)*dble(ir)/dble(2*(NER_BASEMENT_SEDIM+NER_SEDIM))
+!! DK DK UGLY modif Manu removed (z_top-Z_BASEMENT_SURFACE)*dble(ir)/dble(2*(NER_BASEMENT_SEDIM+NER_SEDIM))
+ enddo
+
+! normalize depths
+!! DK DK UGLY modif z_top by Emmanuel Chaljub here
+!! DK DK UGLY suppressed Manu's modif and put old code back because better mesh
+!! DK DK UGLY investigate this in detail one day
+!! DK DK UGLY modif Manu removed rn(:) = rn(:) / (z_top-Z_DEPTH_BLOCK)
+!! DK DK UGLY modif Manu removed
+ rn(:) = rn(:) / (Z_SURFACE-Z_DEPTH_BLOCK)
+
+! check that the mesh that has been generated is correct
+ if(npr /= 2*NER) call exit_MPI(myrank,'incorrect intervals for model')
+
+! check that vertical spacing makes sense
+ do ir=0,2*NER-1
+ if(rn(ir+1) < rn(ir)) call exit_MPI(myrank,'incorrect vertical spacing for model')
+ enddo
+
+ end subroutine mesh_vertical
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/model_aniso.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/model_aniso.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/model_aniso.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,300 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+!=====================================================================
+! 07/09/04 Last changed by Min Chen
+! Users need to modify this subroutine to implement their own
+! anisotropic models.
+!=====================================================================
+
+ subroutine model_aniso(iflag_aniso,rho,vp,vs,c11,c12,c13,c14,c15,c16, &
+ c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66)
+
+ implicit none
+
+ include "constants.h"
+
+! see for example:
+!
+! M. Chen & J. Tromp, 2006. Theoretical & numerical investigations
+! of global and regional seismic wave propagation in weakly anisotropic earth models,
+! GJI, 168, 1130-1152.
+
+!------------------------------------------------------------------------------
+! for anisotropy simulations in a halfspace model
+
+! only related to body waves
+! one-zeta term
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_CS1p_A = 0.2_CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_CS1sv_A = 0._CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_CS1sh_N = 0._CUSTOM_REAL
+! three-zeta term
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_CS3_L = 0._CUSTOM_REAL
+
+! Relative to Love wave
+! four-zeta term
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_N = 0._CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_E_N = 0._CUSTOM_REAL
+
+! Relative to Rayleigh wave
+! two-zeta term
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_A = 0._CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_C = 0._CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_F = 0._CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_H_F = 0._CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_B_A = 0._CUSTOM_REAL
+
+! Relative to both Love wave and Rayleigh wave
+! two-zeta term
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_L = 0._CUSTOM_REAL
+ real(kind=CUSTOM_REAL), parameter :: FACTOR_G_L = 0._CUSTOM_REAL
+
+!------------------------------------------------------------------------------
+
+ !integer idoubling
+ integer iflag_aniso
+
+ !real(kind=CUSTOM_REAL) zmesh
+ real(kind=CUSTOM_REAL) rho,vp,vs
+ real(kind=CUSTOM_REAL) c11,c12,c13,c14,c15,c16,c22,c23,c24,c25,c26,c33,c34,c35,c36, &
+ c44,c45,c46,c55,c56,c66
+
+! local parameters
+ real(kind=CUSTOM_REAL) vpv,vph,vsv,vsh,eta_aniso
+ real(kind=CUSTOM_REAL) aa,cc,nn,ll,ff
+ real(kind=CUSTOM_REAL) A,C,F,AL,AN,Bc,Bs,Gc,Gs,Hc,Hs,Ec,Es,C1p,C1sv,C1sh,C3,S1p,S1sv,S1sh,S3
+ real(kind=CUSTOM_REAL) d11,d12,d13,d14,d15,d16,d22,d23,d24,d25,d26,d33,d34,d35,d36, &
+ d44,d45,d46,d55,d56,d66
+
+! assumes vp,vs given in m/s, rho in kg/m**3
+ vph = vp
+ vpv = vp
+ vsh = vs
+ vsv = vs
+ eta_aniso = 1.0_CUSTOM_REAL
+
+
+! for definition, see for example:
+!
+! Dziewonski & Anderson, 1981. Preliminary reference earth model, PEPI, 25, 297-356.
+! page 305:
+ aa = rho*vph*vph
+ cc = rho*vpv*vpv
+ nn = rho*vsh*vsh
+ ll = rho*vsv*vsv
+ ff = eta_aniso*(aa - 2.*ll)
+
+! Add anisotropic perturbation
+
+! notation: see Chen & Tromp, 2006, appendix A, page 1151
+!
+! zeta-independant terms:
+! A = \delta A
+! C = \delta C
+! AN = \delta N
+! AL = \delta L
+! F = \delta F
+!
+! zeta-dependant terms:
+! C1p = J_c
+! C1sv = K_c
+! C1sh = M_c
+! S1p = J_s
+! S1sv = K_s
+! S1sh = M_s
+!
+! two-zeta dependant terms:
+! Gc = G_c
+! Gs = G_s
+! Bc = B_c
+! Bs = B_s
+! Hc = H_c
+! Hs = H_s
+!
+! three-zeta dependant terms:
+! C3 = D_c
+! S3 = D_s
+!
+! four-zeta dependant terms:
+! Ec = E_c
+! Es = E_s
+
+! no anisotropic perturbation
+ if( iflag_aniso <= 0 ) then
+ ! zeta-independant
+ A = aa
+ C = cc
+ AN = nn
+ AL = ll
+ F = ff
+
+ ! zeta-dependant terms
+ C1p = 0._CUSTOM_REAL
+ C1sv = 0._CUSTOM_REAL
+ C1sh = 0._CUSTOM_REAL
+ S1p = 0._CUSTOM_REAL
+ S1sv = 0._CUSTOM_REAL
+ S1sh = 0._CUSTOM_REAL
+
+ ! two-zeta dependant terms
+ Gc = 0._CUSTOM_REAL
+ Gs = 0._CUSTOM_REAL
+
+ Bc = 0._CUSTOM_REAL
+ Bs = 0._CUSTOM_REAL
+
+ Hc = 0._CUSTOM_REAL
+ Hs = 0._CUSTOM_REAL
+
+ ! three-zeta dependant terms
+ C3 = 0._CUSTOM_REAL
+ S3 = 0._CUSTOM_REAL
+
+ ! four-zeta dependant terms
+ Ec = 0._CUSTOM_REAL
+ Es = 0._CUSTOM_REAL
+ endif
+
+! perturbation model 1
+ if( iflag_aniso == IANISOTROPY_MODEL1 ) then
+ ! zeta-independant
+ A = aa*(1.0_CUSTOM_REAL + FACTOR_A)
+ C = cc*(1.0_CUSTOM_REAL + FACTOR_C)
+ AN = nn*(1.0_CUSTOM_REAL + FACTOR_N)
+ AL = ll*(1.0_CUSTOM_REAL + FACTOR_L)
+ F = ff*(1.0_CUSTOM_REAL + FACTOR_F)
+
+ ! zeta-dependant terms
+ C1p = FACTOR_CS1p_A*aa
+ C1sv = FACTOR_CS1sv_A*aa
+ C1sh = FACTOR_CS1sh_N*nn
+ S1p = 0._CUSTOM_REAL
+ S1sv = 0._CUSTOM_REAL
+ S1sh = 0._CUSTOM_REAL
+
+ ! two-zeta dependant terms
+ Gc = FACTOR_G_L*ll
+ Bc = FACTOR_B_A*aa
+ Hc = FACTOR_H_F*ff
+ Gs = 0._CUSTOM_REAL
+ Bs = 0._CUSTOM_REAL
+ Hs = 0._CUSTOM_REAL
+
+ ! three-zeta dependant terms
+ C3 = FACTOR_CS3_L*ll
+ S3 = 0._CUSTOM_REAL
+
+ ! four-zeta dependant terms
+ Ec = FACTOR_E_N*nn
+ Es = 0._CUSTOM_REAL
+ endif
+
+! perturbation model 2
+ if( iflag_aniso == IANISOTROPY_MODEL2 ) then
+ ! zeta-independant
+ A = aa*(1.0_CUSTOM_REAL + FACTOR_A + 0.1)
+ C = cc*(1.0_CUSTOM_REAL + FACTOR_C + 0.1)
+ AN = nn*(1.0_CUSTOM_REAL + FACTOR_N + 0.1)
+ AL = ll*(1.0_CUSTOM_REAL + FACTOR_L + 0.1)
+ F = ff*(1.0_CUSTOM_REAL + FACTOR_F + 0.1)
+
+ ! zeta-dependant terms
+ C1p = FACTOR_CS1p_A*aa
+ C1sv = FACTOR_CS1sv_A*aa
+ C1sh = FACTOR_CS1sh_N*nn
+ S1p = 0._CUSTOM_REAL
+ S1sv = 0._CUSTOM_REAL
+ S1sh = 0._CUSTOM_REAL
+
+ ! two-zeta dependant terms
+ Gc = FACTOR_G_L*ll
+ Bc = FACTOR_B_A*aa
+ Hc = FACTOR_H_F*ff
+ Gs = 0._CUSTOM_REAL
+ Bs = 0._CUSTOM_REAL
+ Hs = 0._CUSTOM_REAL
+
+ ! three-zeta dependant terms
+ C3 = FACTOR_CS3_L*ll
+ S3 = 0._CUSTOM_REAL
+
+ ! four-zeta dependant terms
+ Ec = FACTOR_E_N*nn
+ Es = 0._CUSTOM_REAL
+ endif
+
+
+! The mapping from the elastic coefficients to the elastic tensor elements
+! in the local Cartesian coordinate system (classical geographic) used in the
+! global code (1---South, 2---East, 3---up)
+! Always keep the following part when you modify this subroutine
+ d11 = A + Ec + Bc
+ d12 = A - 2.*AN - Ec
+ d13 = F + Hc
+ d14 = S3 + 2.*S1sh + 2.*S1p
+ d15 = 2.*C1p + C3
+ d16 = -Bs/2. - Es
+ d22 = A + Ec - Bc
+ d23 = F - Hc
+ d24 = 2.*S1p - S3
+ d25 = 2.*C1p - 2.*C1sh - C3
+ d26 = -Bs/2. + Es
+ d33 = C
+ d34 = 2.*(S1p - S1sv)
+ d35 = 2.*(C1p - C1sv)
+ d36 = -Hs
+ d44 = AL - Gc
+ d45 = -Gs
+ d46 = C1sh - C3
+ d55 = AL + Gc
+ d56 = S3 - S1sh
+ d66 = AN - Ec
+
+! The mapping to the global Cartesian coordinate system used in the code
+! (1---East, 2---North, 3---up)
+ c11 = d22
+ c12 = d12
+ c13 = d23
+ c14 = - d25
+ c15 = d24
+ c16 = - d26
+ c22 = d11
+ c23 = d13
+ c24 = - d15
+ c25 = d14
+ c26 = - d16
+ c33 = d33
+ c34 = - d35
+ c35 = d34
+ c36 = - d36
+ c44 = d55
+ c45 = - d45
+ c46 = d56
+ c55 = d44
+ c56 = - d46
+ c66 = d66
+
+ end subroutine model_aniso
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/model_external_values.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/model_external_values.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/model_external_values.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,218 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! generic model file
+!
+! note: the idea is to super-impose velocity model values on the GLL points,
+! additional to the ones assigned on the CUBIT mesh
+!
+! most of the routines here are place-holders, please add/implement your own routines
+!
+
+ module external_model
+
+!---
+!
+! ADD YOUR MODEL HERE
+!
+!---
+
+ ! only here to illustrate an example
+ ! type model_external_variables
+ ! sequence
+ ! double precision dvs(0:dummy_size)
+ ! end type model_external_variables
+ ! type (model_external_variables) MEXT_V
+
+ end module external_model
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine model_external_broadcast(myrank)
+
+! standard routine to setup model
+
+ use external_model
+
+ implicit none
+
+ include "constants.h"
+ ! standard include of the MPI library
+ include 'mpif.h'
+
+ integer :: myrank
+
+ ! local parameters
+ integer :: idummy
+
+ ! dummy to ignore compiler warnings
+ idummy = myrank
+
+!---
+!
+! ADD YOUR MODEL HERE
+!
+!---
+
+ ! the variables read are declared and stored in structure MEXT_V
+ !if(myrank == 0) call read_external_model()
+
+ ! broadcast the information read on the master to the nodes
+ !call MPI_BCAST(MEXT_V%dvs,size(MEXT_V%dvs),MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ end subroutine model_external_broadcast
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+!
+! subroutine read_external_model()
+!
+! use external_model
+!
+! implicit none
+!
+! include "constants.h"
+!---
+!
+! ADD YOUR MODEL HERE
+!
+!---
+!
+! end subroutine read_external_model
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine model_external_values(i,j,k,ispec,idomain_id,imaterial_id,&
+ nspec,ibool, &
+ iflag_aniso,iflag_atten, &
+ rho,vp,vs, &
+ c11,c12,c13,c14,c15,c16, &
+ c22,c23,c24,c25,c26,c33, &
+ c34,c35,c36,c44,c45,c46, &
+ c55,c56,c66,ANISOTROPY)
+
+! given a GLL point, returns super-imposed velocity model values
+
+ use external_model
+ use create_regions_mesh_ext_par
+
+ implicit none
+
+ ! GLL point indices
+ integer :: i,j,k,ispec
+
+ ! acoustic/elastic/.. domain flag ( 1 = acoustic / 2 = elastic / ... )
+ integer :: idomain_id
+
+ ! associated material flag (in cubit, this would be the volume id number)
+ integer :: imaterial_id
+
+ ! local-to-global index array
+ integer :: nspec
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+ ! anisotropy flag
+ integer :: iflag_aniso
+
+ ! attenuation flag
+ integer :: iflag_atten
+
+ ! density, Vp and Vs
+ real(kind=CUSTOM_REAL) :: vp,vs,rho
+
+ ! all anisotropy coefficients
+ real(kind=CUSTOM_REAL) :: c11,c12,c13,c14,c15,c16,c22,c23,c24,c25, &
+ c26,c33,c34,c35,c36,c44,c45,c46,c55,c56,c66
+ logical :: ANISOTROPY
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: x,y,z
+ real(kind=CUSTOM_REAL) :: xmin,xmax,ymin,ymax,zmin,zmax
+ real(kind=CUSTOM_REAL) :: depth
+ integer :: iglob,idummy
+
+!---
+!
+! ADD YOUR MODEL HERE
+!
+!---
+
+ ! GLL point location
+ iglob = ibool(i,j,k,ispec)
+ x = xstore_dummy(iglob)
+ y = ystore_dummy(iglob)
+ z = zstore_dummy(iglob)
+
+ ! model dimensions
+ xmin = 0. ! minval(xstore_dummy)
+ xmax = 134000. ! maxval(xstore_dummy)
+ ymin = 0. !minval(ystore_dummy)
+ ymax = 134000. ! maxval(ystore_dummy)
+ zmin = 0. ! minval(zstore_dummy)
+ zmax = -60000. ! maxval(zstore_dummy)
+
+ ! depth in Z-direction
+ depth = zmax - z
+
+ ! normalizes depth between 0 and 1
+ if( abs( zmax - zmin ) > TINYVAL ) depth = depth / (zmax - zmin)
+
+
+ ! super-imposes values
+ !rho = 2.6910d0+0.6924d0*depth
+ !vp = 4.1875d0+3.9382d0*depth
+ !vs = 2.1519d0+2.3481d0*depth
+
+ ! adds a velocity depth gradient
+ ! (e.g. from PREM mantle gradients:
+ ! vp : 3.9382*6371/5.5
+ ! vs : 2.3481*6371/5.5
+ ! rho : 0.6924*6371/5.5 )
+ rho = rho + 802.d0 * depth
+ vp = vp + 4562.d0 * depth
+ vs = vs + 2720.d0 * depth
+
+ ! adds anisotropic velocity values
+ if( ANISOTROPY ) &
+ call model_aniso(iflag_aniso,rho,vp,vs,c11,c12,c13,c14,c15,c16, &
+ c22,c23,c24,c25,c26,c33,c34,c35,c36,c44,c45, &
+ c46,c55,c56,c66)
+
+ ! to avoid compiler warnings
+ idummy = imaterial_id
+ idummy = idomain_id
+ idummy = iflag_atten
+
+ end subroutine model_external_values
+
+
\ No newline at end of file
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/model_interface_bedrock.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/model_interface_bedrock.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/model_interface_bedrock.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,390 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! interface model file
+! example file only, unused so far
+
+! ! Piero
+! module bedrock
+!
+! real,dimension(:,:),allocatable :: ibedrock
+!
+! end module bedrock
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+! subroutine model_bedrock_broadcast(myrank)
+!
+!! standard routine to setup model
+!
+! use bedrock
+!
+! implicit none
+!
+! include "constants.h"
+! ! standard include of the MPI library
+! include 'mpif.h'
+!
+! integer :: myrank
+!
+! ! local parameters
+! integer :: idummy
+!
+! ! dummy to ignore compiler warnings
+! idummy = myrank
+!
+! allocate(ibedrock(NX_TOPO_ANT,NY_TOPO_ANT))
+
+! if(myrank == 0) then
+! call read_bedrock_file(ibedrock)
+! ! write(IMAIN,*)
+! ! write(IMAIN,*) 'regional bedrock file read ranges in m from ',minval(ibedrock),' to ',maxval(ibedrock)
+! ! write(IMAIN,*)
+! endif
+
+! ! 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)
+
+! end subroutine model_bedrock_broadcast
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+!
+! subroutine read_bedrock_file()
+!
+! use bedrock
+!
+! implicit none
+!
+! include "constants.h"
+!---
+!
+! ADD YOUR MODEL HERE
+!
+!---
+!
+! end subroutine read_external_model
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+! subroutine model_bedrock_store()
+!
+! use bedrock
+!
+! implicit none
+!
+! !! 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
+! utm_x_station(1) = 783500.6250000d0
+! utm_y_station(1) = -11828.7519531d0
+
+! utm_x_station(2) = 853644.5000000d0
+! utm_y_station(2) = -114.0138092d0
+
+! utm_x_station(3) = 863406.0000000d0
+! utm_y_station(3) = -53736.1640625d0
+
+! utm_x_station(4) = 823398.8125000d0
+! utm_y_station(4) = 29847.4511719d0
+
+! utm_x_station(5) = 863545.3750000d0
+! utm_y_station(5) = 19669.6621094d0
+
+! utm_x_station(6) = 817099.3750000d0
+! utm_y_station(6) = -24430.2871094d0
+
+! print*,myrank,'après store the position of the six stations'
+! call flush(6)
+
+! print*, myrank,minval(nodes_coords_ext_mesh(1,:))
+! call flush(6)
+
+
+! print*, myrank,maxval(nodes_coords_ext_mesh(1,:))
+! call flush(6)
+
+
+! do ispec = 1, nspec
+
+! zmesh = zstore(2,2,2,ispec)
+
+! ! if(doubling_index == IFLAG_ONE_LAYER_TOPOGRAPHY) then
+! if(any(ibelm_top == ispec)) then
+! doubling_value_found_for_Piero = IFLAG_ONE_LAYER_TOPOGRAPHY
+
+! else if(zmesh < Z_23p4km) then
+! doubling_value_found_for_Piero = IFLAG_MANTLE_BELOW_23p4km
+
+! else if(zmesh < Z_14km) then
+! doubling_value_found_for_Piero = IFLAG_14km_to_23p4km
+
+! else
+! doubling_value_found_for_Piero = IFLAG_BEDROCK_down_to_14km
+! endif
+! idoubling(ispec) = doubling_value_found_for_Piero
+
+! do k = 1, NGLLZ
+! do j = 1, NGLLY
+! do i = 1, NGLLX
+
+
+! 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
+! long = xstore(i,j,k,ispec)
+! lat = ystore(i,j,k,ispec)
+
+! ! get coordinate of corner in model
+! icornerlong = int((long - ORIG_LONG_TOPO) / DEGREES_PER_CELL_TOPO) + 1
+! icornerlat = int((lat - ORIG_LAT_TOPO) / DEGREES_PER_CELL_TOPO) + 1
+
+! ! avoid edge effects and extend with identical point if outside model
+! if(icornerlong < 1) icornerlong = 1
+! if(icornerlong > NX_TOPO-1) icornerlong = NX_TOPO-1
+! if(icornerlat < 1) icornerlat = 1
+! if(icornerlat > NY_TOPO-1) icornerlat = NY_TOPO-1
+
+! ! compute coordinates of corner
+! long_corner = ORIG_LONG_TOPO + (icornerlong-1)*DEGREES_PER_CELL_TOPO
+! lat_corner = ORIG_LAT_TOPO + (icornerlat-1)*DEGREES_PER_CELL_TOPO
+
+! ! compute ratio for interpolation
+! ratio_xi = (long - long_corner) / DEGREES_PER_CELL_TOPO
+! ratio_eta = (lat - lat_corner) / DEGREES_PER_CELL_TOPO
+
+! ! avoid edge effects
+! if(ratio_xi < 0.) ratio_xi = 0.
+! if(ratio_xi > 1.) ratio_xi = 1.
+! if(ratio_eta < 0.) ratio_eta = 0.
+! if(ratio_eta > 1.) ratio_eta = 1.
+
+! ! interpolate elevation at current point
+! elevation_bedrock = &
+! ibedrock(icornerlong,icornerlat)*(1.-ratio_xi)*(1.-ratio_eta) + &
+! ibedrock(icornerlong+1,icornerlat)*ratio_xi*(1.-ratio_eta) + &
+! ibedrock(icornerlong+1,icornerlat+1)*ratio_xi*ratio_eta + &
+! ibedrock(icornerlong,icornerlat+1)*(1.-ratio_xi)*ratio_eta
+
+! !! DK DK exclude circles around each station to make sure they are on the bedrock
+! !! DK DK and not in the ice
+! is_around_a_station = .false.
+! do istation = 1,NUMBER_OF_STATIONS
+! if(sqrt((long - utm_x_station(istation))**2 + (lat - utm_y_station(istation))**2) < RADIUS_TO_EXCLUDE) then
+! is_around_a_station = .true.
+! exit
+! endif
+! enddo
+
+! ! define elastic parameters in the model
+
+! ! we are above the bedrock interface i.e. in the ice, and not too close to a station
+! if(zmesh >= elevation_bedrock .and. .not. is_around_a_station) then
+! vp = 3800.d0
+! vs = 1900.d0
+! rho = 900.d0
+! iflag_attenuation_store(i,j,k,ispec) = IATTENUATION_ICE
+
+! ! we are below the bedrock interface i.e. in the bedrock, or close to a station
+! else
+! vp = 5800.d0
+! vs = 3200.d0
+! rho = 2600.d0
+! iflag_attenuation_store(i,j,k,ispec) = IATTENUATION_BEDROCK
+! endif
+
+! else if(idoubling(ispec) == IFLAG_14km_to_23p4km) then
+! vp = 6800.d0
+! vs = 3900.d0
+! rho = 2900.d0
+! iflag_attenuation_store(i,j,k,ispec) = IATTENUATION_BEDROCK
+
+! else if(idoubling(ispec) == IFLAG_MANTLE_BELOW_23p4km) then
+! vp = 8100.d0
+! vs = 4480.d0
+! rho = 3380.d0
+! iflag_attenuation_store(i,j,k,ispec) = IATTENUATION_BEDROCK
+
+! endif
+
+! !pll 8/06
+! if(CUSTOM_REAL == SIZE_REAL) then
+! rhostore(i,j,k,ispec) = sngl(rho)
+! vpstore(i,j,k,ispec) = sngl(vp)
+! vsstore(i,j,k,ispec) = sngl(vs)
+! else
+! rhostore(i,j,k,ispec) = rho
+! vpstore(i,j,k,ispec) = vp
+! vsstore(i,j,k,ispec) = vs
+! 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)
+
+! ! Stacey, a completer par la suite
+! rho_vp(i,j,k,ispec) = rhostore(i,j,k,ispec)*vpstore(i,j,k,ispec)
+! rho_vs(i,j,k,ispec) = rhostore(i,j,k,ispec)*vsstore(i,j,k,ispec)
+! !end pll
+
+! ! 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))*&
+! ! x materials_ext_mesh(3,mat_ext_mesh(ispec))
+! enddo
+! enddo
+! enddo
+! enddo
+!
+! end subroutine
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+!pll
+! subroutine interface(iflag,flag_below,flag_above,ispec,nspec,i,j,k,xstore,ystore,zstore,ibedrock)
+
+! implicit none
+
+! include "constants.h"
+
+! integer :: iflag,flag_below,flag_above
+! integer :: ispec,nspec
+! integer :: i,j,k
+! double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
+! real(kind=CUSTOM_REAL), dimension(NX_TOPO_ANT,NY_TOPO_ANT) :: ibedrock
+! integer, parameter :: NUMBER_OF_STATIONS = 1
+! double precision, parameter :: RADIUS_TO_EXCLUDE = 250.d0
+! double precision, dimension(NUMBER_OF_STATIONS) :: utm_x_station,utm_y_station
+
+! !-------------------
+
+! !for Piero
+! logical :: is_around_a_station
+! integer :: istation
+
+! ! store bedrock values
+! integer :: icornerlat,icornerlong
+! double precision :: lat,long,elevation_bedrock
+! double precision :: lat_corner,long_corner,ratio_xi,ratio_eta
+
+
+! !! 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
+! utm_x_station(1) = 783500.6250000d0
+! utm_y_station(1) = -11828.7519531d0
+
+! utm_x_station(2) = 853644.5000000d0
+! utm_y_station(2) = -114.0138092d0
+
+! utm_x_station(3) = 863406.0000000d0
+! utm_y_station(3) = -53736.1640625d0
+
+! utm_x_station(4) = 823398.8125000d0
+! utm_y_station(4) = 29847.4511719d0
+
+! utm_x_station(5) = 863545.3750000d0
+! utm_y_station(5) = 19669.6621094d0
+
+! utm_x_station(6) = 817099.3750000d0
+! utm_y_station(6) = -24430.2871094d0
+
+! ! since we have suppressed UTM projection for Piero Basini, UTMx is the same as long
+! ! and UTMy is the same as lat
+! long = xstore(i,j,k,ispec)
+! lat = ystore(i,j,k,ispec)
+
+! ! get coordinate of corner in model
+! icornerlong = int((long - ORIG_LONG_TOPO_ANT) / DEGREES_PER_CELL_TOPO_ANT) + 1
+! icornerlat = int((lat - ORIG_LAT_TOPO_ANT) / DEGREES_PER_CELL_TOPO_ANT) + 1
+
+! ! avoid edge effects and extend with identical point if outside model
+! if(icornerlong < 1) icornerlong = 1
+! if(icornerlong > NX_TOPO_ANT-1) icornerlong = NX_TOPO_ANT-1
+! if(icornerlat < 1) icornerlat = 1
+! if(icornerlat > NY_TOPO_ANT-1) icornerlat = NY_TOPO_ANT-1
+
+! ! compute coordinates of corner
+! long_corner = ORIG_LONG_TOPO_ANT + (icornerlong-1)*DEGREES_PER_CELL_TOPO_ANT
+! lat_corner = ORIG_LAT_TOPO_ANT + (icornerlat-1)*DEGREES_PER_CELL_TOPO_ANT
+
+! ! compute ratio for interpolation
+! ratio_xi = (long - long_corner) / DEGREES_PER_CELL_TOPO_ANT
+! ratio_eta = (lat - lat_corner) / DEGREES_PER_CELL_TOPO_ANT
+
+! ! avoid edge effects
+! if(ratio_xi < 0.) ratio_xi = 0.
+! if(ratio_xi > 1.) ratio_xi = 1.
+! if(ratio_eta < 0.) ratio_eta = 0.
+! if(ratio_eta > 1.) ratio_eta = 1.
+
+! ! interpolate elevation at current point
+! elevation_bedrock = &
+! ibedrock(icornerlong,icornerlat)*(1.-ratio_xi)*(1.-ratio_eta) + &
+! ibedrock(icornerlong+1,icornerlat)*ratio_xi*(1.-ratio_eta) + &
+! ibedrock(icornerlong+1,icornerlat+1)*ratio_xi*ratio_eta + &
+! ibedrock(icornerlong,icornerlat+1)*(1.-ratio_xi)*ratio_eta
+
+! !! DK DK exclude circles around each station to make sure they are on the bedrock
+! !! DK DK and not in the ice
+! is_around_a_station = .false.
+! do istation = 1,NUMBER_OF_STATIONS
+! if(sqrt((xstore(i,j,k,ispec) - utm_x_station(istation))**2 + (ystore(i,j,k,ispec) - &
+! utm_y_station(istation))**2) < RADIUS_TO_EXCLUDE) then
+! is_around_a_station = .true.
+! exit
+! endif
+! enddo
+
+! ! we are above the bedrock interface i.e. in the ice, and not too close to a station
+! if(zstore(i,j,k,ispec) >= elevation_bedrock .and. .not. is_around_a_station) then
+! iflag = flag_above
+! !iflag_attenuation_store(i,j,k,ispec) = IATTENUATION_ICE
+! ! we are below the bedrock interface i.e. in the bedrock, or close to a station
+! else
+! iflag = flag_below
+! !iflag_attenuation_store(i,j,k,ispec) = IATTENUATION_BEDROCK
+! endif
+
+
+! end subroutine interface
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/model_tomography.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/model_tomography.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/model_tomography.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,355 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! generic tomography file
+!
+! note: the idea is to use an external, tomography velocity model
+!
+! most of the routines here are place-holders, please add/implement your own routines
+!
+
+ module tomography
+
+ include "constants.h"
+
+ ! for external tomography....
+ ! (regular spaced, xyz-block file in ascii)
+ character (len=80) :: TOMO_FILENAME = 'DATA/veryfast_tomography_abruzzo_complete.xyz'
+
+ ! model dimensions
+ double precision :: ORIG_X,ORIG_Y,ORIG_Z
+ double precision :: END_X,END_Y,END_Z
+ double precision :: SPACING_X,SPACING_Y,SPACING_Z
+
+ ! model parameter records
+ real(kind=CUSTOM_REAL), dimension (:), allocatable :: vp_tomography,vs_tomography,rho_tomography,z_tomography
+
+ ! model entries
+ integer :: NX,NY,NZ
+ integer :: nrecord
+
+ ! min/max statistics
+ double precision :: VP_MIN,VS_MIN,RHO_MIN,VP_MAX,VS_MAX,RHO_MAX
+
+ end module tomography
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine model_tomography_broadcast(myrank)
+
+ implicit none
+
+ ! include "constants.h"
+ ! include "precision.h"
+ ! include 'mpif.h'
+ integer :: myrank
+
+ ! all processes read in same file
+ ! note: for a high number of processes this might lead to a bottleneck
+ call read_model_tomography(myrank)
+
+ ! otherwise:
+
+ ! only master reads in model file
+ !if(myrank == 0) call read_external_model()
+ ! broadcast the information read on the master to the nodes, e.g.
+ !call MPI_BCAST(nrecord,1,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ !if( myrank /= 0 ) allocate( vp_tomography(1:nrecord) )
+ !call MPI_BCAST(vp_tomography,size(vp_tomography),CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+
+ end subroutine model_tomography_broadcast
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_model_tomography(myrank)
+
+! start magnoni 29/11/09
+! read Vp Vs and rho from extracted text file
+
+! assuming that only tomography undefined material is allowed....
+! and all the tomographic regions are collect inside one file called TOMO_FILENAME with homogenous resolution
+! this could be problematic for example if the tomographic regions have different resolution
+! leading to a waste of memory and cpu time in the partitioning process
+
+ use tomography
+
+ implicit none
+
+ integer :: myrank
+
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: x_tomo,y_tomo,z_tomo,vp_tomo,vs_tomo,rho_tomo
+ integer :: irecord,ier
+
+ !TOMO_FILENAME='DATA/veryfast_tomography_abruzzo_complete.xyz'
+ ! probably the simple position for the filename is the constat.h
+ ! but it is also possible to include the name of the file in the material file (therefore in the undef_mat_prop)
+ ! if we want more than one tomofile (Examples: 2 file with a differente resolution
+ ! as in los angeles case we need to loop over mat_ext_mesh(1,ispec)...
+ ! it is a possible solution )
+ ! magnoni 1/12/09
+ open(unit=27,file=TOMO_FILENAME,status='old',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error reading tomography file')
+
+ ! reads in model dimensions
+ read(27,*) ORIG_X, ORIG_Y, ORIG_Z, END_X, END_Y, END_Z
+ read(27,*) SPACING_X, SPACING_Y, SPACING_Z
+ read(27,*) NX, NY, NZ
+ read(27,*) VP_MIN, VP_MAX, VS_MIN, VS_MAX, RHO_MIN, RHO_MAX
+
+ nrecord = NX*NY*NZ
+
+ ! allocates model records
+ allocate(vp_tomography(1:nrecord), &
+ vs_tomography(1:nrecord), &
+ rho_tomography(1:nrecord), &
+ z_tomography(1:nrecord),stat=ier)
+ if(ier /= 0) call exit_MPI(myrank,'not enough memory to allocate arrays')
+
+ ! reads in record sections
+ do irecord = 1,nrecord
+ read(27,*) x_tomo,y_tomo,z_tomo,vp_tomo,vs_tomo,rho_tomo
+
+ ! stores record values
+ vp_tomography(irecord) = vp_tomo
+ vs_tomography(irecord) = vs_tomo
+ rho_tomography(irecord) = rho_tomo
+ z_tomography(irecord) = z_tomo
+ enddo
+
+ close(27)
+
+ end subroutine read_model_tomography
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine model_tomography(x_eval,y_eval,z_eval, &
+ rho_final,vp_final,vs_final)
+
+ use tomography
+
+ implicit none
+
+ !integer, intent(in) :: NX,NY,NZ
+ !real(kind=CUSTOM_REAL), dimension(1:NX*NY*NZ), intent(in) :: vp_tomography,vs_tomography,rho_tomography,z_tomography
+ !double precision, intent(in) :: ORIG_X,ORIG_Y,ORIG_Z,SPACING_X,SPACING_Y,SPACING_Z
+ !double precision, intent(in) :: VP_MIN,VS_MIN,RHO_MIN,VP_MAX,VS_MAX,RHO_MAX
+
+ double precision, intent(in) :: x_eval,y_eval,z_eval
+ real(kind=CUSTOM_REAL), intent(out) :: vp_final,vs_final,rho_final
+
+ ! local parameters
+ integer :: ix,iy,iz
+ integer :: p0,p1,p2,p3,p4,p5,p6,p7
+
+ double precision :: spac_x,spac_y,spac_z
+ double precision :: gamma_interp_x,gamma_interp_y
+ double precision :: gamma_interp_z1,gamma_interp_z2,gamma_interp_z3, &
+ gamma_interp_z4,gamma_interp_z5,gamma_interp_z6,gamma_interp_z7,gamma_interp_z8
+ real(kind=CUSTOM_REAL) :: vp1,vp2,vp3,vp4,vp5,vp6,vp7,vp8, &
+ vs1,vs2,vs3,vs4,vs5,vs6,vs7,vs8,rho1,rho2,rho3,rho4,rho5,rho6,rho7,rho8
+
+ ! determine spacing and cell for linear interpolation
+ spac_x = (x_eval - ORIG_X) / SPACING_X
+ spac_y = (y_eval - ORIG_Y) / SPACING_Y
+ spac_z = (z_eval - ORIG_Z) / SPACING_Z
+
+ ix = int(spac_x)
+ iy = int(spac_y)
+ iz = int(spac_z)
+
+ gamma_interp_x = spac_x - dble(ix)
+ gamma_interp_y = spac_y - dble(iy)
+
+ ! suppress edge effects for points outside of the model SPOSTARE DOPO
+ if(ix < 0) then
+ ix = 0
+ gamma_interp_x = 0.d0
+ endif
+ if(ix > NX-2) then
+ ix = NX-2
+ gamma_interp_x = 1.d0
+ endif
+
+ if(iy < 0) then
+ iy = 0
+ gamma_interp_y = 0.d0
+ endif
+ if(iy > NY-2) then
+ iy = NY-2
+ gamma_interp_y = 1.d0
+ endif
+
+ if(iz < 0) then
+ iz = 0
+ ! gamma_interp_z = 0.d0
+ endif
+ if(iz > NZ-2) then
+ iz = NZ-2
+ ! gamma_interp_z = 1.d0
+ endif
+
+
+ ! define 8 corners of interpolation element
+ p0 = ix+iy*NX+iz*(NX*NY)
+ p1 = (ix+1)+iy*NX+iz*(NX*NY)
+ p2 = (ix+1)+(iy+1)*NX+iz*(NX*NY)
+ p3 = ix+(iy+1)*NX+iz*(NX*NY)
+ p4 = ix+iy*NX+(iz+1)*(NX*NY)
+ p5 = (ix+1)+iy*NX+(iz+1)*(NX*NY)
+ p6 = (ix+1)+(iy+1)*NX+(iz+1)*(NX*NY)
+ p7 = ix+(iy+1)*NX+(iz+1)*(NX*NY)
+
+ if(z_tomography(p4+1) == z_tomography(p0+1)) then
+ gamma_interp_z1 = 1.d0
+ else
+ gamma_interp_z1 = (z_eval-z_tomography(p0+1))/(z_tomography(p4+1)-z_tomography(p0+1))
+ endif
+ if(gamma_interp_z1 > 1.d0) then
+ gamma_interp_z1 = 1.d0
+ endif
+ if(gamma_interp_z1 < 0.d0) then
+ gamma_interp_z1 = 0.d0
+ endif
+
+
+ if(z_tomography(p5+1) == z_tomography(p1+1)) then
+ gamma_interp_z2 = 1.d0
+ else
+ gamma_interp_z2 = (z_eval-z_tomography(p1+1))/(z_tomography(p5+1)-z_tomography(p1+1))
+ endif
+ if(gamma_interp_z2 > 1.d0) then
+ gamma_interp_z2 = 1.d0
+ endif
+ if(gamma_interp_z2 < 0.d0) then
+ gamma_interp_z2 = 0.d0
+ endif
+
+
+ if(z_tomography(p6+1) == z_tomography(p2+1)) then
+ gamma_interp_z3 = 1.d0
+ else
+ gamma_interp_z3 = (z_eval-z_tomography(p2+1))/(z_tomography(p6+1)-z_tomography(p2+1))
+ endif
+ if(gamma_interp_z3 > 1.d0) then
+ gamma_interp_z3 = 1.d0
+ endif
+ if(gamma_interp_z3 < 0.d0) then
+ gamma_interp_z3 = 0.d0
+ endif
+
+
+ if(z_tomography(p7+1) == z_tomography(p3+1)) then
+ gamma_interp_z4 = 1.d0
+ else
+ gamma_interp_z4 = (z_eval-z_tomography(p3+1))/(z_tomography(p7+1)-z_tomography(p3+1))
+ endif
+ if(gamma_interp_z4 > 1.d0) then
+ gamma_interp_z4 = 1.d0
+ endif
+ if(gamma_interp_z4 < 0.d0) then
+ gamma_interp_z4 = 0.d0
+ endif
+
+ gamma_interp_z5 = 1. - gamma_interp_z1
+ gamma_interp_z6 = 1. - gamma_interp_z2
+ gamma_interp_z7 = 1. - gamma_interp_z3
+ gamma_interp_z8 = 1. - gamma_interp_z4
+
+ vp1 = vp_tomography(p0+1)
+ vp2 = vp_tomography(p1+1)
+ vp3 = vp_tomography(p2+1)
+ vp4 = vp_tomography(p3+1)
+ vp5 = vp_tomography(p4+1)
+ vp6 = vp_tomography(p5+1)
+ vp7 = vp_tomography(p6+1)
+ vp8 = vp_tomography(p7+1)
+
+ vs1 = vs_tomography(p0+1)
+ vs2 = vs_tomography(p1+1)
+ vs3 = vs_tomography(p2+1)
+ vs4 = vs_tomography(p3+1)
+ vs5 = vs_tomography(p4+1)
+ vs6 = vs_tomography(p5+1)
+ vs7 = vs_tomography(p6+1)
+ vs8 = vs_tomography(p7+1)
+
+ rho1 = rho_tomography(p0+1)
+ rho2 = rho_tomography(p1+1)
+ rho3 = rho_tomography(p2+1)
+ rho4 = rho_tomography(p3+1)
+ rho5 = rho_tomography(p4+1)
+ rho6 = rho_tomography(p5+1)
+ rho7 = rho_tomography(p6+1)
+ rho8 = rho_tomography(p7+1)
+
+ ! use trilinear interpolation in cell to define Vp Vs and rho
+ vp_final = &
+ vp1*(1.-gamma_interp_x)*(1.-gamma_interp_y)*(1.-gamma_interp_z1) + &
+ vp2*gamma_interp_x*(1.-gamma_interp_y)*(1.-gamma_interp_z2) + &
+ vp3*gamma_interp_x*gamma_interp_y*(1.-gamma_interp_z3) + &
+ vp4*(1.-gamma_interp_x)*gamma_interp_y*(1.-gamma_interp_z4) + &
+ vp5*(1.-gamma_interp_x)*(1.-gamma_interp_y)*gamma_interp_z1 + &
+ vp6*gamma_interp_x*(1.-gamma_interp_y)*gamma_interp_z2 + &
+ vp7*gamma_interp_x*gamma_interp_y*gamma_interp_z3 + &
+ vp8*(1.-gamma_interp_x)*gamma_interp_y*gamma_interp_z4
+
+ vs_final = &
+ vs1*(1.-gamma_interp_x)*(1.-gamma_interp_y)*(1.-gamma_interp_z1) + &
+ vs2*gamma_interp_x*(1.-gamma_interp_y)*(1.-gamma_interp_z2) + &
+ vs3*gamma_interp_x*gamma_interp_y*(1.-gamma_interp_z3) + &
+ vs4*(1.-gamma_interp_x)*gamma_interp_y*(1.-gamma_interp_z4) + &
+ vs5*(1.-gamma_interp_x)*(1.-gamma_interp_y)*gamma_interp_z1 + &
+ vs6*gamma_interp_x*(1.-gamma_interp_y)*gamma_interp_z2 + &
+ vs7*gamma_interp_x*gamma_interp_y*gamma_interp_z3 + &
+ vs8*(1.-gamma_interp_x)*gamma_interp_y*gamma_interp_z4
+
+ rho_final = &
+ rho1*(1.-gamma_interp_x)*(1.-gamma_interp_y)*(1.-gamma_interp_z1) + &
+ rho2*gamma_interp_x*(1.-gamma_interp_y)*(1.-gamma_interp_z2) + &
+ rho3*gamma_interp_x*gamma_interp_y*(1.-gamma_interp_z3) + &
+ rho4*(1.-gamma_interp_x)*gamma_interp_y*(1.-gamma_interp_z4) + &
+ rho5*(1.-gamma_interp_x)*(1.-gamma_interp_y)*gamma_interp_z1 + &
+ rho6*gamma_interp_x*(1.-gamma_interp_y)*gamma_interp_z2 + &
+ rho7*gamma_interp_x*gamma_interp_y*gamma_interp_z3 + &
+ rho8*(1.-gamma_interp_x)*gamma_interp_y*gamma_interp_z4
+
+ ! impose minimum and maximum velocity and density if needed
+ if(vp_final < VP_MIN) vp_final = VP_MIN
+ if(vs_final < VS_MIN) vs_final = VS_MIN
+ if(rho_final < RHO_MIN) rho_final = RHO_MIN
+ if(vp_final > VP_MAX) vp_final = VP_MAX
+ if(vs_final > VS_MAX) vs_final = VS_MAX
+ if(rho_final > RHO_MAX) rho_final = RHO_MAX
+
+ end subroutine model_tomography
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/netlib_specfun_erf.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/netlib_specfun_erf.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/netlib_specfun_erf.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,318 @@
+
+ subroutine calerf(ARG,RESULT,JINT)
+
+!------------------------------------------------------------------
+!
+! This routine can be freely obtained from Netlib
+! at http://www.netlib.org/specfun/erf
+!
+! Most Netlib software packages have no restrictions on their use
+! but Netlib recommends that you check with the authors to be sure.
+! See http://www.netlib.org/misc/faq.html#2.3 for details.
+!
+!------------------------------------------------------------------
+!
+! This packet evaluates erf(x) for a real argument x.
+! It contains one FUNCTION type subprogram: ERF,
+! and one SUBROUTINE type subprogram, CALERF. The calling
+! statements for the primary entries are:
+!
+! Y = ERF(X)
+!
+! The routine CALERF is intended for internal packet use only,
+! all computations within the packet being concentrated in this
+! routine. The function subprograms invoke CALERF with the
+! statement
+!
+! call CALERF(ARG,RESULT,JINT)
+!
+! where the parameter usage is as follows
+!
+! Function Parameters for CALERF
+! call ARG Result JINT
+!
+! ERF(ARG) ANY REAL ARGUMENT ERF(ARG) 0
+!
+! The main computation evaluates near-minimax approximations
+! from "Rational Chebyshev approximations for the error function"
+! by William J. Cody, Math. Comp., 1969, PP. 631-638. This
+! transportable program uses rational functions that theoretically
+! approximate erf(x) and erfc(x) to at least 18 significant
+! decimal digits. The accuracy achieved depends on the arithmetic
+! system, the compiler, the intrinsic functions, and proper
+! selection of the machine-dependent constants.
+!
+!*******************************************************************
+!*******************************************************************
+!
+! Explanation of machine-dependent constants
+!
+! XMIN = the smallest positive floating-point number.
+! XINF = the largest positive finite floating-point number.
+! XNEG = the largest negative argument acceptable to ERFCX;
+! the negative of the solution to the equation
+! 2*exp(x*x) = XINF.
+! XSMALL = argument below which erf(x) may be represented by
+! 2*x/sqrt(pi) and above which x*x will not underflow.
+! A conservative value is the largest machine number X
+! such that 1.0 + X = 1.0 to machine precision.
+! XBIG = largest argument acceptable to ERFC; solution to
+! the equation: W(x) * (1-0.5/x**2) = XMIN, where
+! W(x) = exp(-x*x)/[x*sqrt(pi)].
+! XHUGE = argument above which 1.0 - 1/(2*x*x) = 1.0 to
+! machine precision. A conservative value is
+! 1/[2*sqrt(XSMALL)]
+! XMAX = largest acceptable argument to ERFCX; the minimum
+! of XINF and 1/[sqrt(pi)*XMIN].
+!
+! Approximate IEEE double precision values are defined below.
+!
+!*******************************************************************
+!*******************************************************************
+!
+! Error returns
+!
+! The program returns ERFC = 0 for ARG >= XBIG;
+!
+! Author: William J. Cody
+! Mathematics and Computer Science Division
+! Argonne National Laboratory
+! Argonne, IL 60439, USA
+!
+! Latest modification: March 19, 1990
+!
+! Converted to Fortran90 and slightly modified by
+! Dimitri Komatitsch, University of Pau, France, November 2007.
+!
+!------------------------------------------------------------------
+
+ implicit none
+
+ integer I,JINT
+ double precision A,ARG,B,C,D,DEL,FOUR,HALF,P,ONE,Q,RESULT,SIXTEEN,SQRPI, &
+ TWO,THRESHOLD,X,XBIG,XDEN,XHUGE,XINF,XMAX,XNEG,XNUM,XSMALL, &
+ Y,YSQ,ZERO
+ dimension A(5),B(4),C(9),D(8),P(6),Q(5)
+
+!------------------------------------------------------------------
+! Mathematical constants
+!------------------------------------------------------------------
+ data FOUR,ONE,HALF,TWO,ZERO/4.0D0,1.0D0,0.5D0,2.0D0,0.0D0/, &
+ SQRPI/5.6418958354775628695D-1/,THRESHOLD/0.46875D0/, &
+ SIXTEEN/16.0D0/
+
+!------------------------------------------------------------------
+! Machine-dependent constants
+!------------------------------------------------------------------
+ data XINF,XNEG,XSMALL/1.79D308,-26.628D0,1.11D-16/, &
+ XBIG,XHUGE,XMAX/26.543D0,6.71D7,2.53D307/
+
+!------------------------------------------------------------------
+! Coefficients for approximation to erf in first interval
+!------------------------------------------------------------------
+ data A/3.16112374387056560D00,1.13864154151050156D02, &
+ 3.77485237685302021D02,3.20937758913846947D03, &
+ 1.85777706184603153D-1/
+ data B/2.36012909523441209D01,2.44024637934444173D02, &
+ 1.28261652607737228D03,2.84423683343917062D03/
+
+!------------------------------------------------------------------
+! Coefficients for approximation to erfc in second interval
+!------------------------------------------------------------------
+ data C/5.64188496988670089D-1,8.88314979438837594D0, &
+ 6.61191906371416295D01,2.98635138197400131D02, &
+ 8.81952221241769090D02,1.71204761263407058D03, &
+ 2.05107837782607147D03,1.23033935479799725D03, &
+ 2.15311535474403846D-8/
+ data D/1.57449261107098347D01,1.17693950891312499D02, &
+ 5.37181101862009858D02,1.62138957456669019D03, &
+ 3.29079923573345963D03,4.36261909014324716D03, &
+ 3.43936767414372164D03,1.23033935480374942D03/
+
+!------------------------------------------------------------------
+! Coefficients for approximation to erfc in third interval
+!------------------------------------------------------------------
+ data P/3.05326634961232344D-1,3.60344899949804439D-1, &
+ 1.25781726111229246D-1,1.60837851487422766D-2, &
+ 6.58749161529837803D-4,1.63153871373020978D-2/
+ data Q/2.56852019228982242D00,1.87295284992346047D00, &
+ 5.27905102951428412D-1,6.05183413124413191D-2, &
+ 2.33520497626869185D-3/
+
+ X = ARG
+ Y = ABS(X)
+ if (Y <= THRESHOLD) then
+
+!------------------------------------------------------------------
+! Evaluate erf for |X| <= 0.46875
+!------------------------------------------------------------------
+ YSQ = ZERO
+ if (Y > XSMALL) YSQ = Y * Y
+ XNUM = A(5)*YSQ
+ XDEN = YSQ
+
+ do I = 1, 3
+ XNUM = (XNUM + A(I)) * YSQ
+ XDEN = (XDEN + B(I)) * YSQ
+ enddo
+
+ RESULT = X * (XNUM + A(4)) / (XDEN + B(4))
+ if (JINT /= 0) RESULT = ONE - RESULT
+ if (JINT == 2) RESULT = EXP(YSQ) * RESULT
+ goto 800
+
+!------------------------------------------------------------------
+! Evaluate erfc for 0.46875 <= |X| <= 4.0
+!------------------------------------------------------------------
+ else if (Y <= FOUR) then
+ XNUM = C(9)*Y
+ XDEN = Y
+
+ do I = 1, 7
+ XNUM = (XNUM + C(I)) * Y
+ XDEN = (XDEN + D(I)) * Y
+ enddo
+
+ RESULT = (XNUM + C(8)) / (XDEN + D(8))
+ if (JINT /= 2) then
+ YSQ = AINT(Y*SIXTEEN)/SIXTEEN
+ DEL = (Y-YSQ)*(Y+YSQ)
+ RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
+ endif
+
+!------------------------------------------------------------------
+! Evaluate erfc for |X| > 4.0
+!------------------------------------------------------------------
+ else
+ RESULT = ZERO
+ if (Y >= XBIG) then
+ if (JINT /= 2 .OR. Y >= XMAX) goto 300
+ if (Y >= XHUGE) then
+ RESULT = SQRPI / Y
+ goto 300
+ endif
+ endif
+ YSQ = ONE / (Y * Y)
+ XNUM = P(6)*YSQ
+ XDEN = YSQ
+
+ do I = 1, 4
+ XNUM = (XNUM + P(I)) * YSQ
+ XDEN = (XDEN + Q(I)) * YSQ
+ enddo
+
+ RESULT = YSQ *(XNUM + P(5)) / (XDEN + Q(5))
+ RESULT = (SQRPI - RESULT) / Y
+ if (JINT /= 2) then
+ YSQ = AINT(Y*SIXTEEN)/SIXTEEN
+ DEL = (Y-YSQ)*(Y+YSQ)
+ RESULT = EXP(-YSQ*YSQ) * EXP(-DEL) * RESULT
+ endif
+ endif
+
+!------------------------------------------------------------------
+! Fix up for negative argument, erf, etc.
+!------------------------------------------------------------------
+ 300 if (JINT == 0) then
+ RESULT = (HALF - RESULT) + HALF
+ if (X < ZERO) RESULT = -RESULT
+ else if (JINT == 1) then
+ if (X < ZERO) RESULT = TWO - RESULT
+ else
+ if (X < ZERO) then
+ if (X < XNEG) then
+ RESULT = XINF
+ else
+ YSQ = AINT(X*SIXTEEN)/SIXTEEN
+ DEL = (X-YSQ)*(X+YSQ)
+ Y = EXP(YSQ*YSQ) * EXP(DEL)
+ RESULT = (Y+Y) - RESULT
+ endif
+ endif
+ endif
+
+ 800 return
+
+ end subroutine calerf
+
+!--------------------------------------------------------------------
+
+ double precision function netlib_specfun_erf(X)
+
+! This subprogram computes approximate values for erf(x).
+! (see comments heading CALERF).
+!
+! Author/date: William J. Cody, January 8, 1985
+
+ implicit none
+
+ integer JINT
+ double precision X, RESULT
+
+ JINT = 0
+ call calerf(X,RESULT,JINT)
+ netlib_specfun_erf = RESULT
+
+ end function netlib_specfun_erf
+
+!
+! Subject: RE: Can one freely use and redistribute Fortran routines "specfun" from Netlib?
+! From: Jack Dongarra
+! Date: Wed, 21 Nov 2007 10:33:45 -0500
+! To: Rusty Lusk, Dimitri Komatitsch
+!
+! Yes the code can freely be used and incorporated into other software. You
+! should of course acknowledge the use of the software.
+!
+! Hope this helps,
+!
+! Jack Dongarra
+!
+! **********************************************************************
+! Prof. Jack Dongarra; Innovative Computing Laboratory; EECS Department;
+! 1122 Volunteer Blvd; University of Tennessee; Knoxville TN 37996-3450;
+! +1-865-974-8295; http://www.cs.utk.edu/~dongarra/
+!
+! -----Original Message-----
+! From: Rusty Lusk
+! Sent: Wednesday, November 21, 2007 10:29 AM
+! To: Dimitri Komatitsch
+! Cc: Jack Dongarra
+! Subject: Re: Can one freely use and redistribute Fortran routines "specfun"
+! from Netlib?
+!
+! Netlib is managed at the University of Tennesee, not Argonne at this
+! point. I have copied Jack Dongarra on this reply; he should be able
+! to answer questions about licensing issues for code from Netlib.
+!
+! Regards,
+! Rusty
+!
+! On Nov 21, 2007, at 8:36 AM, Dimitri Komatitsch wrote:
+!
+! >
+! > Dear Sir,
+! >
+! > Can one freely use and redistribute Fortran routines "specfun" from
+! > Netlib http://netlib2.cs.utk.edu/specfun/
+! > which were written back in 1985-1990 by William J. Cody
+! > from the Mathematics and Computer Science Division at Argonne?
+! >
+! > We use one of these routines (the error function, erf())
+! > in one of our source codes, which we would like to
+! > release as open source under GPL v2+, and we therefore
+! > wonder if we could include that erf() routine in the
+! > package in a separate file (of course saying in a comment in the
+! > header that it comes from Netlib and was written by William J. Cody from
+! > Argonne).
+! >
+! > Thank you,
+! > Best regards,
+! >
+! > Dimitri Komatitsch.
+! >
+! > --
+! > Dimitri Komatitsch - dimitri.komatitsch aT univ-pau.fr
+! > Professor, University of Pau, Institut universitaire de France
+! > and INRIA Magique3D, France http://www.univ-pau.fr/~dkomati1
+! >
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/numbering.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/numbering.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/numbering.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,447 @@
+ module numbering
+
+ use data_gllmesh
+ use data_numbering
+ use data_spec
+ use data_mesh
+ use data_grid
+ use data_diag
+
+ implicit none
+ public :: define_global_global_numbering
+ public :: define_global_flobal_numbering
+ public :: define_global_slobal_numbering
+ public :: get_global
+ private
+ contains
+
+!--------------------------------------------------------------------------
+! dk define_global_global_numbering----------------------------------------
+subroutine define_global_global_numbering
+
+ integer npointot
+ double precision, dimension(:), allocatable :: sgtmp,zgtmp
+ logical, dimension(:), allocatable :: ifseg
+ integer, dimension(:), allocatable :: loc
+ integer :: iel, jpol,ipol, ipt
+!
+ ngllcube = (npol+1)**2
+ npointot = neltot * (npol+1)**2
+
+ if (dump_mesh_info_screen) then
+ write(6,*)
+ write(6,*) 'NPOINTOT GLOBAL IS ' , npointot
+ end if
+!
+ open(2,file='crds',form="UNFORMATTED")
+ write(2) sgll
+ write(2) zgll
+ close(2)
+
+ allocate(sgtmp(npointot)) ; sgtmp(:) = 0.
+ do iel = 1, neltot
+ do jpol = 0, npol
+ do ipol = 0, npol
+ ipt = (iel-1)*(npol+1)**2 + jpol*(npol+1) + ipol+1
+ sgtmp(ipt) = sgll(ipol,jpol,iel)
+ end do
+ end do
+ end do
+ deallocate(sgll)
+ allocate(zgtmp(npointot)) ; zgtmp(:) = 0.
+ do iel = 1, neltot
+ do jpol = 0, npol
+ do ipol = 0, npol
+ ipt = (iel-1)*(npol+1)**2 + jpol*(npol+1) + ipol+1
+ zgtmp(ipt) = zgll(ipol,jpol,iel)
+ end do
+ end do
+ end do
+ deallocate(zgll)
+
+ allocate(iglob(npointot)); iglob(:) = 0
+ allocate(loc(npointot)); loc(:) = 0
+ allocate(ifseg(npointot))
+ call get_global(neltot,sgtmp,zgtmp,iglob,loc,ifseg,nglobglob,npointot,ngllcube,NDIM)
+ deallocate(ifseg)
+ deallocate(loc)
+ deallocate(sgtmp)
+ deallocate(zgtmp)
+ allocate(zgll(0:npol,0:npol,neltot))
+ allocate(sgll(0:npol,0:npol,neltot))
+ open(2,file='crds',form="unformatted")
+ read(2) sgll
+ read(2) zgll
+ close(2)
+
+ if (dump_mesh_info_screen) write(6,*) 'NGLOBGLOB IS ' , NGLOBGLOB
+
+end subroutine define_global_global_numbering
+!--------------------------------------------------------------------------
+!
+!dk define_global_flobal_numbering-----------------------------------------
+ subroutine define_global_flobal_numbering
+ integer npointot
+ double precision, dimension(:), allocatable :: sgtmp,zgtmp
+ integer, dimension(:), allocatable :: loc_fluid
+ logical, dimension(:), allocatable :: ifseg
+ integer :: iel, jpol,ipol, ipt
+!
+
+ npointot = neltot_fluid * (npol+1)**2
+!
+ if (dump_mesh_info_screen) then
+ write(6,*)
+ write(6,*) 'NPOINTOT FLOBAL IS ' , npointot
+ end if
+!
+ open(2,file='crds',form="UNFORMATTED")
+ write(2) sgll_fluid
+ write(2) zgll_fluid
+ close(2)
+ allocate(sgtmp(npointot))
+ do iel = 1, neltot_fluid
+ do jpol = 0, npol
+ do ipol = 0, npol
+ ipt = (iel-1)*(npol+1)**2 + jpol*(npol+1) + ipol+1
+ sgtmp(ipt) = sgll_fluid(ipol,jpol,iel)
+ end do
+ end do
+ end do
+ deallocate(sgll_fluid)
+ allocate(zgtmp(npointot))
+ do iel = 1, neltot_fluid
+ do jpol = 0, npol
+ do ipol = 0, npol
+ ipt = (iel-1)*(npol+1)**2 + jpol*(npol+1) + ipol+1
+ zgtmp(ipt) = zgll_fluid(ipol,jpol,iel)
+ end do
+ end do
+ end do
+ deallocate(zgll_fluid)
+!
+ allocate(iglob_fluid(npointot)) ; iglob_fluid(:) = 0
+ allocate(loc_fluid(npointot)) ; loc_fluid(:) = 0
+ allocate(ifseg(npointot))
+!
+ call get_global(neltot_fluid,sgtmp,zgtmp,iglob_fluid,loc_fluid,ifseg,nglobflob,npointot,NGLLcube,NDIM)
+!
+ deallocate(ifseg)
+ deallocate(loc_fluid)
+ deallocate(zgtmp)
+ deallocate(sgtmp)
+!
+! allocate(zgll_fluid(0:npol,0:npol,neltot_fluid))
+! allocate(sgll_fluid(0:npol,0:npol,neltot_fluid))
+! open(2,file='crds',form="UNFORMATTED")
+! read(2) sgll_fluid
+! read(2) zgll_fluid
+! close(2)
+
+ if (dump_mesh_info_screen) write(6,*) 'NGLOBFLOB IS ' , NGLOBFLOB
+
+ end subroutine define_global_flobal_numbering
+!
+!-------------------------------------------------------------------------
+! dk define_global_slobal_numbering---------------------------------------
+ subroutine define_global_slobal_numbering
+ integer npointot
+ double precision, dimension(:), allocatable :: sgtmp,zgtmp
+ integer, dimension(:), allocatable :: loc_solid
+ logical, dimension(:), allocatable :: ifseg
+!
+ integer :: iel, jpol,ipol, ipt
+!
+! test
+! double precision, dimension(:), allocatable :: utest, uglob
+
+ npointot = neltot_solid * (npol+1)**2
+!
+ if (dump_mesh_info_screen) then
+ write(6,*)
+ write(6,*) 'NPOINTOT SLOBAL IS ' , npointot
+ end if
+! To save some memory
+ open(2,file='crds',form="UNFORMATTED")
+ write(2) sgll
+ write(2) zgll
+ close(2)
+ deallocate(sgll,zgll)
+!
+ allocate(sgtmp(npointot))
+ do iel = 1, neltot_solid
+ do jpol = 0, npol
+ do ipol = 0, npol
+ ipt = (iel-1)*(npol+1)**2 + jpol*(npol+1) + ipol+1
+ sgtmp(ipt) = sgll_solid(ipol,jpol,iel)
+ end do
+ end do
+ end do
+ deallocate(sgll_solid) ! not needed anymore
+ allocate(zgtmp(npointot))
+ do iel = 1, neltot_solid
+ do jpol = 0, npol
+ do ipol = 0, npol
+ ipt = (iel-1)*(npol+1)**2 + jpol*(npol+1) + ipol+1
+ zgtmp(ipt) = zgll_solid(ipol,jpol,iel)
+ end do
+ end do
+ end do
+ deallocate(zgll_solid) ! not needed anymore
+!
+ allocate(iglob_solid(npointot)) ; iglob_solid(:) = 0
+ allocate(loc_solid(npointot)) ; loc_solid(:) = 0
+ allocate(ifseg(npointot))
+
+ call get_global(neltot_solid,sgtmp,zgtmp,iglob_solid,loc_solid,ifseg,nglobslob,npointot,NGLLcube,NDIM)
+
+ deallocate(ifseg)
+ deallocate(loc_solid)
+ deallocate(zgtmp)
+ deallocate(sgtmp)
+! now load global coordinate arrays back in
+ allocate(zgll(0:npol,0:npol,neltot))
+ allocate(sgll(0:npol,0:npol,neltot))
+ open(2,file='crds',form="UNFORMATTED")
+ read(2) sgll
+ read(2) zgll
+ close(2)
+!
+ if (dump_mesh_info_screen) write(6,*) 'NGLOBSLOB IS ' , NGLOBSLOB
+!
+ end subroutine define_global_slobal_numbering
+!
+
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 3 . 4
+! --------------------------------------------------
+!
+! Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory - California Institute of Technology
+! (c) California Institute of Technology September 2002
+!
+! A signed non-commercial agreement is required to use this program.
+! Please check http://www.gps.caltech.edu/research/jtromp for details.
+! Free for non-commercial academic research ONLY.
+! This program is distributed WITHOUT ANY WARRANTY whatsoever.
+! Do not redistribute this program without written permission.
+!
+!=====================================================================
+
+subroutine get_global2(nspec2,xp,yp,iglob2,loc2,ifseg2,nglob2,npointot2,NGLLCUBE2,NDIM2)
+
+ ! this routine MUST be in double precision to avoid sensitivity
+ ! to roundoff errors in the coordinates of the points
+
+ ! non-structured global numbering software provided by Paul F. Fischer
+
+ ! leave sorting subroutines in same source file to allow for inlining
+
+ implicit none
+
+ ! include "constants.h"
+
+ integer, intent(in) :: nspec2,npointot2,NGLLCUBE2,NDIM2
+ double precision, intent(in) :: xp(npointot2),yp(npointot2)
+ integer, intent(out) :: iglob2(npointot2),loc2(npointot2),nglob2
+ logical, intent(out) :: ifseg2(npointot2)
+
+ integer ispec,i,j
+ integer ieoff,ilocnum,nseg,ioff,iseg,ig
+
+ integer, dimension(:), allocatable :: ind,ninseg,iwork
+ double precision, dimension(:), allocatable :: work
+
+! TNM: that's what I had
+! double precision, parameter :: SMALLVALTOL = 1.d-15
+ double precision, parameter :: SMALLVALTOL = 1.d-08
+
+! write(6,*)'GLOBAL NUMBERING npointot2,nspec2,NGLLCUBE2:',npointot2,nspec2,NGLLCUBE2
+! write(6,*)'GLOBAL NUMBERING xp yp max:', maxval(abs(xp)),maxval(abs(yp))
+
+! establish initial pointers
+ do ispec=1,nspec2
+ ieoff=NGLLCUBE2*(ispec-1)
+ do ilocnum=1,NGLLCUBE2
+ loc2(ilocnum+ieoff)=ilocnum+ieoff
+ enddo
+ enddo
+
+ ifseg2(:)=.false.
+
+! dynamically allocate arrays
+ allocate(ind(npointot2))
+ allocate(ninseg(npointot2))
+ allocate(iwork(npointot2))
+ allocate(work(npointot2))
+
+ nseg=1
+ ifseg2(1)=.true.
+ ninseg(1)=npointot2
+
+!==========================================
+ do j=1,NDIM2
+!==========================================
+
+! sort within each segment
+ ioff=1
+ do iseg=1,nseg
+ if(j == 1) then
+ call rank(xp(ioff),ind,ninseg(iseg))
+ else
+ call rank(yp(ioff),ind,ninseg(iseg))
+ endif
+!af
+ call swap_all(loc2(ioff),xp(ioff),yp(ioff),iwork,work,ind,ninseg(iseg))
+!end af
+ 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,npointot2
+ if(dabs(xp(i)-xp(i-1)) > SMALLVALTOL) ifseg2(i)=.true.
+! if(dabs(xp(i)-xp(i-1)) > SMALLVALTOL) write(6666,*)'DISTANCE X:',i,loc2(i),dabs(xp(i)-xp(i-1))
+! if(dabs(xp(i)-xp(i-1)) < SMALLVALTOL) write(6667,*)'DISTANCE X:',i,loc2(i),dabs(xp(i)-xp(i-1))
+ enddo
+ else
+ do i=2,npointot2
+ if(dabs(yp(i)-yp(i-1)) > SMALLVALTOL) ifseg2(i)=.true.
+! if(dabs(yp(i)-yp(i-1)) > SMALLVALTOL) write(6666,*)'DISTANCE Y:',i,loc2(i),dabs(yp(i)-yp(i-1))
+! if(dabs(yp(i)-yp(i-1)) < SMALLVALTOL) write(6667,*)'DISTANCE Y:',i,loc2(i),dabs(yp(i)-yp(i-1))
+ enddo
+
+ endif
+
+! count up number of different segments
+ nseg=0
+ do i=1,npointot2
+ if(ifseg2(i)) then
+ nseg=nseg+1
+ ninseg(nseg)=1
+ else
+ ninseg(nseg)=ninseg(nseg)+1
+ endif
+
+ enddo
+
+!==========================================
+ enddo ! NDIM2 loop
+!==========================================
+
+! deallocate arrays
+ deallocate(ind)
+ deallocate(iwork)
+ deallocate(work)
+ deallocate(ninseg)
+
+! assign global node numbers (now sorted lexicographically)
+ ig=0
+ do i=1,npointot2
+ if(ifseg2(i)) ig=ig+1
+ iglob2(loc2(i))=ig
+ enddo
+ nglob2=ig
+
+end subroutine get_global
+!-------------------------------------------------------------------------
+!-------------------------------------------------------------------------
+
+! sorting routines put in same file to allow for inlining
+
+subroutine rank(A,IND,N)
+ !
+ ! Use Heap Sort (Numerical Recipes)
+ !
+ implicit none
+
+ integer n
+ double precision A(n)
+ integer IND(n)
+
+ integer i,j,l,ir,indx
+ double precision q
+
+ do j=1,n
+ IND(j)=j
+ enddo
+
+ if (n == 1) return
+
+ L=n/2+1
+ ir=n
+100 CONTINUE
+ IF (l>1) THEN
+ l=l-1
+ indx=ind(l)
+ q=a(indx)
+ ELSE
+ indx=ind(ir)
+ q=a(indx)
+ ind(ir)=ind(1)
+ ir=ir-1
+ if (ir == 1) then
+ ind(1)=indx
+
+ return
+ endif
+ ENDIF
+ i=l
+ j=l+l
+200 CONTINUE
+ IF (J <= IR) THEN
+ IF (J<IR) THEN
+ IF ( A(IND(j))<A(IND(j+1)) ) j=j+1
+ ENDIF
+ IF (q<A(IND(j))) THEN
+ IND(I)=IND(J)
+ I=J
+ J=J+J
+ ELSE
+ J=IR+1
+ ENDIF
+ goto 200
+ ENDIF
+ IND(I)=INDX
+ goto 100
+
+end subroutine rank
+
+! ------------------------------------------------------------------
+
+subroutine swap_all(IA,A,B,IW,W,ind,n)
+ !
+ ! swap arrays IA, A, B and C according to addressing in array IND
+ !
+ implicit none
+
+ integer n
+
+ integer IND(n)
+ integer IA(n),IW(n)
+ double precision A(n),B(n),W(n)
+
+ integer i
+
+ IW(:) = IA(:)
+ W(:) = A(:)
+
+ do i=1,n
+ IA(i)=IW(ind(i))
+ A(i)=W(ind(i))
+ enddo
+
+ W(:) = B(:)
+
+ do i=1,n
+ B(i)=W(ind(i))
+ enddo
+
+end subroutine swap_all
+
+
+!=========================
+ end module numbering
+!=========================
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/parallel.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/parallel.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/parallel.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,899 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+!----
+!---- Parallel routines. All MPI calls belong in this file!
+!----
+
+
+ subroutine stop_all()
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer ier
+
+! stop all the MPI processes, and exit
+ call MPI_ABORT(MPI_COMM_WORLD,30,ier)
+ stop 'error, program ended in exit_MPI'
+
+ end subroutine stop_all
+
+!
+!----
+!
+
+ double precision function wtime()
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ wtime = MPI_WTIME()
+
+ end function wtime
+
+!
+!----
+!
+
+ subroutine sync_all()
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer ier
+
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+ end subroutine sync_all
+
+!
+!----
+!
+
+ subroutine bcast_all_i(buffer, count)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer count
+ integer, dimension(count) :: buffer
+
+ integer ier
+
+ call MPI_BCAST(buffer,count,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ end subroutine bcast_all_i
+
+!
+!----
+!
+
+ subroutine bcast_all_cr(buffer, count)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer count
+ real(kind=CUSTOM_REAL), dimension(count) :: buffer
+
+ integer ier
+
+ call MPI_BCAST(buffer,count,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
+
+ end subroutine bcast_all_cr
+
+!
+!----
+!
+
+ subroutine bcast_all_dp(buffer, count)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer count
+ double precision, dimension(count) :: buffer
+
+ integer ier
+
+ call MPI_BCAST(buffer,count,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ier)
+
+ end subroutine bcast_all_dp
+
+!
+!----
+!
+
+ subroutine gather_all_i(sendbuf, sendcnt, recvbuf, recvcount, NPROC)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer sendcnt, recvcount, NPROC
+ integer, dimension(sendcnt) :: sendbuf
+ integer, dimension(recvcount,0:NPROC-1) :: recvbuf
+
+ integer ier
+
+ call MPI_GATHER(sendbuf,sendcnt,MPI_INTEGER, &
+ recvbuf,recvcount,MPI_INTEGER, &
+ 0,MPI_COMM_WORLD,ier)
+
+ end subroutine gather_all_i
+
+!
+!----
+!
+
+ subroutine gather_all_dp(sendbuf, sendcnt, recvbuf, recvcount, NPROC)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer sendcnt, recvcount, NPROC
+ double precision, dimension(sendcnt) :: sendbuf
+ double precision, dimension(recvcount,0:NPROC-1) :: recvbuf
+
+ integer ier
+
+ call MPI_GATHER(sendbuf,sendcnt,MPI_DOUBLE_PRECISION, &
+ recvbuf,recvcount,MPI_DOUBLE_PRECISION, &
+ 0,MPI_COMM_WORLD,ier)
+
+ end subroutine gather_all_dp
+
+!
+!----
+!
+
+ subroutine gather_all_cr(sendbuf, sendcnt, recvbuf, recvcount, NPROC)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer sendcnt, recvcount, NPROC
+ real(kind=CUSTOM_REAL), dimension(sendcnt) :: sendbuf
+ real(kind=CUSTOM_REAL), dimension(recvcount,0:NPROC-1) :: recvbuf
+
+ integer ier
+
+ call MPI_GATHER(sendbuf,sendcnt,CUSTOM_MPI_TYPE, &
+ recvbuf,recvcount,CUSTOM_MPI_TYPE, &
+ 0,MPI_COMM_WORLD,ier)
+
+ end subroutine gather_all_cr
+
+!
+!----
+!
+
+ subroutine gather_all_all_cr(sendbuf, recvbuf, counts, NPROC)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer NPROC,counts
+ real(kind=CUSTOM_REAL), dimension(counts) :: sendbuf
+ real(kind=CUSTOM_REAL), dimension(counts,0:NPROC-1) :: recvbuf
+
+ integer ier
+
+ call MPI_ALLGATHER(sendbuf,counts,CUSTOM_MPI_TYPE,recvbuf,counts,CUSTOM_MPI_TYPE, &
+ MPI_COMM_WORLD,ier)
+
+ end subroutine gather_all_all_cr
+
+!
+!----
+!
+
+ subroutine gatherv_all_cr(sendbuf, sendcnt, recvbuf, recvcount, recvoffset,recvcounttot, NPROC)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer sendcnt,recvcounttot,NPROC
+ integer, dimension(NPROC) :: recvcount,recvoffset
+ real(kind=CUSTOM_REAL), dimension(sendcnt) :: sendbuf
+ real(kind=CUSTOM_REAL), dimension(recvcounttot) :: recvbuf
+
+ integer ier
+
+ call MPI_GATHERV(sendbuf,sendcnt,CUSTOM_MPI_TYPE, &
+ recvbuf,recvcount,recvoffset,CUSTOM_MPI_TYPE, &
+ 0,MPI_COMM_WORLD,ier)
+
+ end subroutine gatherv_all_cr
+
+!
+!----
+!
+
+ subroutine init()
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer ier
+
+! initialize the MPI communicator and start the NPROCTOT MPI processes.
+ call MPI_INIT(ier)
+
+ end subroutine init
+
+!
+!----
+!
+
+ subroutine finalize()
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer ier
+
+! stop all the MPI processes, and exit
+ call MPI_FINALIZE(ier)
+
+ end subroutine finalize
+
+!
+!----
+!
+
+ subroutine world_size(size)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer size
+ integer ier
+
+ call MPI_COMM_SIZE(MPI_COMM_WORLD,size,ier)
+
+ end subroutine world_size
+
+!
+!----
+!
+
+ subroutine world_rank(rank)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer rank
+ integer ier
+
+ call MPI_COMM_RANK(MPI_COMM_WORLD,rank,ier)
+
+ end subroutine world_rank
+
+!
+!----
+!
+
+ subroutine min_all_dp(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ double precision sendbuf, recvbuf
+ integer ier
+
+ call MPI_REDUCE(sendbuf,recvbuf,1,MPI_DOUBLE_PRECISION, &
+ MPI_MIN,0,MPI_COMM_WORLD,ier)
+
+ end subroutine min_all_dp
+
+!
+!----
+!
+
+ subroutine max_all_dp(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ double precision sendbuf, recvbuf
+ integer ier
+
+ call MPI_REDUCE(sendbuf,recvbuf,1,MPI_DOUBLE_PRECISION, &
+ MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ end subroutine max_all_dp
+
+!
+!----
+!
+
+ subroutine max_all_cr(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ real(kind=CUSTOM_REAL) sendbuf, recvbuf
+ integer ier
+
+ call MPI_REDUCE(sendbuf,recvbuf,1,CUSTOM_MPI_TYPE, &
+ MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ end subroutine max_all_cr
+
+!
+!----
+!
+
+ subroutine min_all_cr(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+ include "constants.h"
+ include "precision.h"
+
+ real(kind=CUSTOM_REAL) sendbuf, recvbuf
+ integer ier
+
+ call MPI_REDUCE(sendbuf,recvbuf,1,CUSTOM_MPI_TYPE, &
+ MPI_MIN,0,MPI_COMM_WORLD,ier)
+
+ end subroutine min_all_cr
+
+
+!
+!----
+!
+
+ subroutine min_all_all_cr(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+ include "constants.h"
+ include "precision.h"
+
+ real(kind=CUSTOM_REAL):: sendbuf, recvbuf
+ integer ier
+
+ call MPI_ALLREDUCE(sendbuf,recvbuf,1,CUSTOM_MPI_TYPE, &
+ MPI_MIN,MPI_COMM_WORLD,ier)
+
+ end subroutine min_all_all_cr
+
+!
+!----
+!
+!
+!
+! subroutine min_all_all_dp(sendbuf, recvbuf)
+!
+! implicit none
+!
+!! standard include of the MPI library
+! include 'mpif.h'
+! include "constants.h"
+! include "precision.h"
+!
+! double precision :: sendbuf, recvbuf
+! integer ier
+!
+! call MPI_ALLREDUCE(sendbuf,recvbuf,1,MPI_DOUBLE_PRECISION, &
+! MPI_MIN,MPI_COMM_WORLD,ier)
+!
+! end subroutine min_all_all_dp
+!
+!
+!----
+!
+
+ subroutine max_all_i(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer :: sendbuf, recvbuf
+ integer :: ier
+
+ call MPI_REDUCE(sendbuf,recvbuf,1,MPI_INTEGER, &
+ MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ end subroutine max_all_i
+
+!
+!----
+!
+
+ subroutine max_all_all_cr(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+ include "constants.h"
+ include "precision.h"
+
+ real(kind=CUSTOM_REAL):: sendbuf, recvbuf
+ integer ier
+
+ call MPI_ALLREDUCE(sendbuf,recvbuf,1,CUSTOM_MPI_TYPE, &
+ MPI_MAX,MPI_COMM_WORLD,ier)
+
+ end subroutine max_all_all_cr
+
+
+!
+!----
+!
+
+
+ subroutine max_all_all_dp(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+ include "constants.h"
+ include "precision.h"
+
+ double precision :: sendbuf, recvbuf
+ integer ier
+
+ call MPI_ALLREDUCE(sendbuf,recvbuf,1,MPI_DOUBLE_PRECISION, &
+ MPI_MAX,MPI_COMM_WORLD,ier)
+
+ end subroutine max_all_all_dp
+
+
+!
+!----
+!
+
+ subroutine min_all_i(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer:: sendbuf, recvbuf
+ integer ier
+
+ call MPI_REDUCE(sendbuf,recvbuf,1,MPI_INTEGER, &
+ MPI_MIN,0,MPI_COMM_WORLD,ier)
+
+ end subroutine min_all_i
+
+!
+!----
+!
+
+
+ subroutine sum_all_dp(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ double precision sendbuf, recvbuf
+ integer ier
+
+ call MPI_REDUCE(sendbuf,recvbuf,1,MPI_DOUBLE_PRECISION, &
+ MPI_SUM,0,MPI_COMM_WORLD,ier)
+
+ end subroutine sum_all_dp
+
+!
+!----
+!
+
+ subroutine sum_all_cr(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+ include "constants.h"
+ include "precision.h"
+
+ real(kind=CUSTOM_REAL) sendbuf, recvbuf
+ integer ier
+
+ call MPI_REDUCE(sendbuf,recvbuf,1,CUSTOM_MPI_TYPE, &
+ MPI_SUM,0,MPI_COMM_WORLD,ier)
+
+ end subroutine sum_all_cr
+
+!
+!----
+!
+
+ subroutine sum_all_i(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer sendbuf, recvbuf
+ integer ier
+
+ call MPI_REDUCE(sendbuf,recvbuf,1,MPI_INTEGER, &
+ MPI_SUM,0,MPI_COMM_WORLD,ier)
+
+ end subroutine sum_all_i
+
+!
+!----
+!
+
+ subroutine sum_all_all_i(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer sendbuf, recvbuf
+ integer ier
+
+ call MPI_ALLREDUCE(sendbuf,recvbuf,1,MPI_INTEGER, &
+ MPI_SUM,MPI_COMM_WORLD,ier)
+
+ end subroutine sum_all_all_i
+
+!
+!----
+!
+
+ subroutine any_all_l(sendbuf, recvbuf)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ logical sendbuf, recvbuf
+ integer ier
+
+ call MPI_ALLREDUCE(sendbuf,recvbuf,1,MPI_LOGICAL, &
+ MPI_LOR,MPI_COMM_WORLD,ier)
+
+ end subroutine any_all_l
+
+!
+!----
+!
+
+ subroutine sendrecv_all_cr(sendbuf, sendcount, dest, sendtag, &
+ recvbuf, recvcount, source, recvtag)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer sendcount, recvcount, dest, sendtag, source, recvtag
+ real(kind=CUSTOM_REAL), dimension(sendcount) :: sendbuf
+ real(kind=CUSTOM_REAL), dimension(recvcount) :: recvbuf
+
+! MPI status of messages to be received
+ integer msg_status(MPI_STATUS_SIZE)
+
+ integer ier
+
+ call MPI_SENDRECV(sendbuf,sendcount,CUSTOM_MPI_TYPE,dest,sendtag, &
+ recvbuf,recvcount,CUSTOM_MPI_TYPE,source,recvtag, &
+ MPI_COMM_WORLD,msg_status,ier)
+
+ end subroutine sendrecv_all_cr
+
+!
+!----
+!
+
+ integer function proc_null()
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ proc_null = MPI_PROC_NULL
+
+ end function proc_null
+
+!
+!----
+!
+
+ subroutine issend_cr(sendbuf, sendcount, dest, sendtag, req)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer sendcount, dest, sendtag, req
+ real(kind=CUSTOM_REAL), dimension(sendcount) :: sendbuf
+
+ integer ier
+
+ call MPI_ISSEND(sendbuf(1),sendcount,CUSTOM_MPI_TYPE,dest,sendtag, &
+ MPI_COMM_WORLD,req,ier)
+
+ end subroutine issend_cr
+
+!
+!----
+!
+
+ subroutine irecv_cr(recvbuf, recvcount, dest, recvtag, req)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer recvcount, dest, recvtag, req
+ real(kind=CUSTOM_REAL), dimension(recvcount) :: recvbuf
+
+ integer ier
+
+ call MPI_IRECV(recvbuf(1),recvcount,CUSTOM_MPI_TYPE,dest,recvtag, &
+ MPI_COMM_WORLD,req,ier)
+
+ end subroutine irecv_cr
+
+!
+!----
+!
+
+ subroutine issend_i(sendbuf, sendcount, dest, sendtag, req)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer sendcount, dest, sendtag, req
+ integer, dimension(sendcount) :: sendbuf
+
+ integer ier
+
+ call MPI_ISSEND(sendbuf(1),sendcount,MPI_INTEGER,dest,sendtag, &
+ MPI_COMM_WORLD,req,ier)
+
+ end subroutine issend_i
+
+!
+!----
+!
+
+ subroutine irecv_i(recvbuf, recvcount, dest, recvtag, req)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+ include "precision.h"
+
+ integer recvcount, dest, recvtag, req
+ integer, dimension(recvcount) :: recvbuf
+ integer ier
+
+ call MPI_IRECV(recvbuf(1),recvcount,MPI_INTEGER,dest,recvtag, &
+ MPI_COMM_WORLD,req,ier)
+
+ end subroutine irecv_i
+
+
+!
+!----
+!
+
+ subroutine recv_i(recvbuf, recvcount, dest, recvtag )
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer dest,recvtag
+ integer recvcount
+ !integer recvbuf
+ integer,dimension(recvcount):: recvbuf
+ 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 dest,sendtag
+ integer sendcount
+ integer,dimension(sendcount):: sendbuf
+ 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
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ integer :: req
+
+ integer, dimension(MPI_STATUS_SIZE) :: req_mpi_status
+
+ integer :: ier
+
+ call mpi_wait(req,req_mpi_status,ier)
+
+ end subroutine wait_req
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/param_reader.c
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/param_reader.c (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/param_reader.c 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,179 @@
+/*
+ !=====================================================================
+ !
+ ! 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.
+ !
+ !=====================================================================
+ */
+
+/*
+
+by Dennis McRitchie
+
+ January 7, 2010 - par_file parsing
+ ..
+ You'll notice that the heart of the parser is a complex regular
+ expression that is compiled within the C code, and then used to split
+ the lines appropriately. It does all the heavy lifting. I don't know of
+ any way to do this in Fortran. I believe that to accomplish this in
+ Fortran, you'd have to write a lot of procedural string manipulation
+ code, for which Fortran is not very well suited.
+
+ But Fortran-C mixes are pretty common these days, so I would not expect
+ any problems on that account. There are no wrapper functions used: just
+ the C routine called directly from a Fortran routine. Also, regarding
+ the use of C, I assumed this would not be a problem since there are
+ already six C files that make up part of the build (though they all are
+ related to the pyre-framework).
+ ..
+*/
+
+#include <stdlib.h>
+#include <stdio.h>
+#define __USE_GNU
+#include <string.h>
+#include <regex.h>
+
+#define LINE_MAX 255
+
+FILE * fd;
+
+void param_open_(char * filename, int * length, int * ierr)
+{
+ char * fncopy;
+ char * blank;
+
+ // Trim the file name.
+ fncopy = strndup(filename, *length);
+ blank = strchr(fncopy, ' ');
+ if (blank != NULL) {
+ fncopy[blank - fncopy] = '\0';
+ }
+ if ((fd = fopen(fncopy, "r")) == NULL) {
+ printf("Can't open '%s'\n", fncopy);
+ *ierr = 1;
+ return;
+ }
+ free(fncopy);
+}
+
+void param_close_()
+{
+ fclose(fd);
+}
+
+void param_read_(char * string_read, int * string_read_len, char * name, int * name_len, int * ierr)
+{
+ char * namecopy;
+ char * blank;
+ char * namecopy2;
+ int status;
+ regex_t compiled_pattern;
+ char line[LINE_MAX];
+ int regret;
+ regmatch_t parameter[3];
+ char * keyword;
+ char * value;
+
+ // Trim the keyword name we're looking for.
+ namecopy = strndup(name, *name_len);
+ blank = strchr(namecopy, ' ');
+ if (blank != NULL) {
+ namecopy[blank - namecopy] = '\0';
+ }
+ // Then get rid of any dot-terminated prefix.
+ namecopy2 = strchr(namecopy, '.');
+ if (namecopy2 != NULL) {
+ namecopy2 += 1;
+ } else {
+ namecopy2 = namecopy;
+ }
+ /* Regular expression for parsing lines from param file.
+ ** Good luck reading this regular expression. Basically, the lines of
+ ** the parameter file should be of the form 'parameter = value'. Blank
+ ** lines, lines containing only white space and lines whose first non-
+ ** whitespace character is '#' are ignored. White space is generally
+ ** ignored. As you will see later in the code, if both parameter and
+ ** value are not specified the line is ignored.
+ */
+ char pattern[] = "^[ \t]*([^# \t]*)[ \t]*=[ \t]*([^# \t]*)[ \t]*(#.*){0,1}$";
+
+ // Compile the regular expression.
+ status = regcomp(&compiled_pattern, pattern, REG_EXTENDED);
+ if (status != 0) {
+ printf("regcomp returned error %d\n", status);
+ }
+ // Position the open file to the beginning.
+ if (fseek(fd, 0, SEEK_SET) != 0) {
+ printf("Can't seek to begining of parameter file\n");
+ *ierr = 1;
+ regfree(&compiled_pattern);
+ return;
+ }
+ // Read every line in the file.
+ while (fgets(line, LINE_MAX, fd) != NULL) {
+ // Get rid of the ending newline.
+ int linelen = strlen(line);
+ if (line[linelen-1] == '\n') {
+ line[linelen-1] = '\0';
+ }
+ /* Test if line matches the regular expression pattern, if so
+ ** return position of keyword and value */
+ regret = regexec(&compiled_pattern, line, 3, parameter, 0);
+ // If no match, check the next line.
+ if (regret == REG_NOMATCH) {
+ continue;
+ }
+ // If any error, bail out with an error message.
+ if(regret != 0) {
+ printf("regexec returned error %d\n", regret);
+ *ierr = 1;
+ regfree(&compiled_pattern);
+ return;
+ }
+ // printf("Line read = %s\n", line);
+ // If we have a match, extract the keyword from the line.
+ keyword = strndup(line+parameter[1].rm_so, parameter[1].rm_eo-parameter[1].rm_so);
+ // If the keyword is not the one we're looking for, check the next line.
+ if (strcmp(keyword, namecopy2) != 0) {
+ free(keyword);
+ continue;
+ }
+ free(keyword);
+ regfree(&compiled_pattern);
+ // If it matches, extract the value from the line.
+ value = strndup(line+parameter[2].rm_so, parameter[2].rm_eo-parameter[2].rm_so);
+ // Clear out the return string with blanks, copy the value into it, and return.
+ memset(string_read, ' ', *string_read_len);
+ strncpy(string_read, value, strlen(value));
+ free(value);
+ free(namecopy);
+ *ierr = 0;
+ return;
+ }
+ // If no keyword matches, print out error and die.
+ printf("No match in parameter file for keyword %s\n", namecopy);
+ free(namecopy);
+ regfree(&compiled_pattern);
+ *ierr = 1;
+ return;
+}
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/prepare_assemble_MPI.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/prepare_assemble_MPI.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/prepare_assemble_MPI.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,571 @@
+!=====================================================================
+!
+! 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,knods, &
+ ibool,npoin,ngnode, &
+ 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)
+! nibool_interfaces_asteroid with the number of points in ibool_interfaces_asteroid
+!
+! for all points on the interface defined by ninterface, my_nelmnts_neighbours and my_interfaces
+
+ implicit none
+
+ include 'constants.h'
+
+! spectral element indexing
+! ( nelmnts = number of spectral elements
+! ngnode = number of element corners (8)
+! knods = corner indices array )
+ integer, intent(in) :: nelmnts,ngnode
+ integer, dimension(ngnode,nelmnts), intent(in) :: knods
+
+! global number of points
+ integer, intent(in) :: npoin
+
+! global indexing
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nelmnts), intent(in) :: ibool
+
+! MPI interfaces
+ 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
+
+! local parameters
+ 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
+
+! initializes
+ allocate( mask_ibool_asteroid(npoin), stat=ier); if( ier /= 0) stop 'error allocating array'
+
+ ibool_interfaces_asteroid(:,:) = 0
+ nibool_interfaces_asteroid(:) = 0
+
+! loops over MPI interfaces
+ do num_interface = 1, ninterface
+ npoin_interface_asteroid = 0
+ mask_ibool_asteroid(:) = .false.
+
+ ! loops over number of elements on interface
+ do ispec_interface = 1, my_nelmnts_neighbours(num_interface)
+ ! spectral element on interface
+ ispec = my_interfaces(1,ispec_interface,num_interface)
+ ! type of interface: (1) corner point, (2) edge, (4) face
+ type = my_interfaces(2,ispec_interface,num_interface)
+ ! gets spectral element corner indices (defines all nodes of face/edge)
+ do k = 1, ngnode
+ n(k) = knods(k,ispec)
+ end do
+
+ ! interface node ids
+ 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)
+
+ ! gets i,j,k ranges for interface type
+ call get_edge(ngnode, n, type, e1, e2, e3, e4, ixmin, ixmax, iymin, iymax, izmin, izmax)
+
+ ! counts number and stores indices of (global) points on MPI interface
+ do iz = min(izmin,izmax), max(izmin,izmax)
+ do iy = min(iymin,iymax), max(iymin,iymax)
+ do ix = min(ixmin,ixmax), max(ixmin,ixmax)
+ ! stores global index of point on interface
+ if(.not. mask_ibool_asteroid(ibool(ix,iy,iz,ispec))) then
+ ! masks point as being accounted for
+ mask_ibool_asteroid(ibool(ix,iy,iz,ispec)) = .true.
+ ! adds point to interface
+ 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
+
+ ! stores total number of (global) points on this MPI interface
+ 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 )
+
+! returns range of local (GLL) point indices i,j,k depending on given type for corner point (1), edge (2) or face (4)
+
+ implicit none
+
+ include "constants.h"
+
+! corner node indices per spectral element (8)
+ integer, intent(in) :: ngnode
+ integer, dimension(ngnode), intent(in) :: n
+
+! interface type & nodes
+ integer, intent(in) :: type, e1, e2, e3, e4
+
+! local (GLL) i,j,k index ranges
+ integer, intent(out) :: ixmin, ixmax, iymin, iymax, izmin, izmax
+
+! local parameters
+ integer, dimension(4) :: en
+ integer :: valence, i
+
+! determines local indexes for corners/edges/faces
+ if ( type == 1 ) then
+
+! corner point
+
+ 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
+
+! edges
+
+ 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
+
+! face corners
+
+ en(1) = e1
+ en(2) = e2
+ en(3) = e3
+ en(4) = e4
+
+ ! zmin face
+ 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
+
+ ! ymin face
+ 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
+
+ ! xmax face
+ 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
+
+ ! ymax face
+ 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
+
+ ! xmin face
+ 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
+
+ ! zmax face
+ 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
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/prepare_timerun.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/prepare_timerun.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/prepare_timerun.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,590 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+ subroutine prepare_timerun()
+
+ use specfem_par
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ use specfem_par_poroelastic
+ use specfem_par_movie
+ use fault_solver, only : BC_DYNFLT_init
+ use fault_solver_kinematic, only : BC_KINFLT_init
+
+ implicit none
+ character(len=256) :: plot_file
+
+ ! flag for any movie simulation
+ if( EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP .or. &
+ MOVIE_SURFACE .or. CREATE_SHAKEMAP .or. MOVIE_VOLUME .or. PNM_GIF_IMAGE ) then
+ MOVIE_SIMULATION = .true.
+ else
+ MOVIE_SIMULATION = .false.
+ endif
+
+ ! user info
+ if(myrank == 0) then
+
+ write(IMAIN,*)
+ if(ATTENUATION) then
+ write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids'
+ if(USE_OLSEN_ATTENUATION) then
+ write(IMAIN,*) 'using Olsen''s attenuation'
+ else
+ write(IMAIN,*) 'not using Olsen''s attenuation'
+ endif
+ else
+ write(IMAIN,*) 'no attenuation'
+ endif
+
+ write(IMAIN,*)
+ if(ANISOTROPY) then
+ write(IMAIN,*) 'incorporating anisotropy'
+ else
+ write(IMAIN,*) 'no anisotropy'
+ endif
+
+ write(IMAIN,*)
+ if(OCEANS) then
+ write(IMAIN,*) 'incorporating the oceans using equivalent load'
+ else
+ write(IMAIN,*) 'no oceans'
+ endif
+
+ write(IMAIN,*)
+ if(ACOUSTIC_SIMULATION) then
+ write(IMAIN,*) 'incorporating acoustic simulation'
+ else
+ write(IMAIN,*) 'no acoustic simulation'
+ endif
+
+ write(IMAIN,*)
+ if(ELASTIC_SIMULATION) then
+ write(IMAIN,*) 'incorporating elastic simulation'
+ else
+ write(IMAIN,*) 'no elastic simulation'
+ endif
+
+ write(IMAIN,*)
+ if(POROELASTIC_SIMULATION) then
+ write(IMAIN,*) 'incorporating poroelastic simulation'
+ else
+ write(IMAIN,*) 'no poroelastic simulation'
+ endif
+ write(IMAIN,*)
+
+ write(IMAIN,*)
+ if(MOVIE_SIMULATION) then
+ write(IMAIN,*) 'incorporating movie simulation'
+ else
+ write(IMAIN,*) 'no movie simulation'
+ endif
+ write(IMAIN,*)
+
+ endif
+
+ ! synchronize all the processes before assembling the mass matrix
+ ! to make sure all the nodes have finished to read their databases
+ call sync_all()
+
+ ! sets up mass matrices
+ call prepare_timerun_mass_matrices()
+
+ ! Loading kinematic and dynamic fault solvers.
+ call BC_DYNFLT_init(prname,rmass,DT,NSTEP)
+
+ call BC_KINFLT_init(prname,rmass,DT,NSTEP)
+
+ ! initialize acoustic arrays to zero
+ if( ACOUSTIC_SIMULATION ) then
+ potential_acoustic(:) = 0._CUSTOM_REAL
+ potential_dot_acoustic(:) = 0._CUSTOM_REAL
+ potential_dot_dot_acoustic(:) = 0._CUSTOM_REAL
+ ! put negligible initial value to avoid very slow underflow trapping
+ if(FIX_UNDERFLOW_PROBLEM) potential_dot_dot_acoustic(:) = VERYSMALLVAL
+ endif
+
+ ! initialize elastic arrays to zero/verysmallvall
+ if( ELASTIC_SIMULATION ) then
+ displ(:,:) = 0._CUSTOM_REAL
+ veloc(:,:) = 0._CUSTOM_REAL
+ accel(:,:) = 0._CUSTOM_REAL
+ ! put negligible initial value to avoid very slow underflow trapping
+ if(FIX_UNDERFLOW_PROBLEM) displ(:,:) = VERYSMALLVAL
+ endif
+
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ deltat = sngl(DT)
+ else
+ deltat = DT
+ endif
+ deltatover2 = deltat/2._CUSTOM_REAL
+ deltatsqover2 = deltat*deltat/2._CUSTOM_REAL
+
+ ! seismograms
+ if (nrec_local > 0) then
+ ! allocate seismogram array
+ allocate(seismograms_d(NDIM,nrec_local,NSTEP))
+ allocate(seismograms_v(NDIM,nrec_local,NSTEP))
+ allocate(seismograms_a(NDIM,nrec_local,NSTEP))
+
+ ! initialize seismograms
+ seismograms_d(:,:,:) = 0._CUSTOM_REAL
+ seismograms_v(:,:,:) = 0._CUSTOM_REAL
+ seismograms_a(:,:,:) = 0._CUSTOM_REAL
+ endif
+
+ ! prepares attenuation arrays
+ call prepare_timerun_attenuation()
+
+ ! initializes PML arrays
+ if( ABSORBING_CONDITIONS ) then
+ if (SIMULATION_TYPE /= 1 .and. ABSORB_USE_PML ) then
+ write(IMAIN,*) 'NOTE: adjoint simulations and PML not supported yet...'
+ else
+ if( ABSORB_USE_PML ) then
+ call PML_initialize()
+ endif
+ endif
+ endif
+
+ ! opens source time function file
+ if(PRINT_SOURCE_TIME_FUNCTION .and. myrank == 0) then
+ ! print the source-time function
+ if(NSOURCES == 1) then
+ plot_file = '/plot_source_time_function.txt'
+ else
+ if(NSOURCES < 10) then
+ write(plot_file,"('/plot_source_time_function',i1,'.txt')") NSOURCES
+ else
+ write(plot_file,"('/plot_source_time_function',i2,'.txt')") NSOURCES
+ endif
+ endif
+ open(unit=IOSTF,file=trim(OUTPUT_FILES)//plot_file,status='unknown')
+ endif
+
+ ! user output
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' time step: ',sngl(DT),' s'
+ write(IMAIN,*) 'number of time steps: ',NSTEP
+ write(IMAIN,*) 'total simulated time: ',sngl(NSTEP*DT),' seconds'
+ write(IMAIN,*)
+ endif
+
+ ! prepares ADJOINT simulations
+ call prepare_timerun_adjoint()
+
+ end subroutine prepare_timerun
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_timerun_mass_matrices()
+
+ use specfem_par
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ use specfem_par_poroelastic
+ implicit none
+
+! the mass matrix needs to be assembled with MPI here once and for all
+ if(ACOUSTIC_SIMULATION) then
+ call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,rmass_acoustic, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh,&
+ my_neighbours_ext_mesh)
+
+ ! fill mass matrix with fictitious non-zero values to make sure it can be inverted globally
+ where(rmass_acoustic <= 0._CUSTOM_REAL) rmass_acoustic = 1._CUSTOM_REAL
+ rmass_acoustic(:) = 1._CUSTOM_REAL / rmass_acoustic(:)
+
+ endif ! ACOUSTIC_SIMULATION
+
+ if(ELASTIC_SIMULATION) then
+ call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,rmass, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+ ! fill mass matrix with fictitious non-zero values to make sure it can be inverted globally
+ where(rmass <= 0._CUSTOM_REAL) rmass = 1._CUSTOM_REAL
+ rmass(:) = 1._CUSTOM_REAL / rmass(:)
+
+ if(OCEANS ) then
+ if( minval(rmass_ocean_load(:)) <= 0._CUSTOM_REAL) &
+ call exit_MPI(myrank,'negative ocean load mass matrix term')
+ rmass_ocean_load(:) = 1. / rmass_ocean_load(:)
+ endif
+
+ endif ! ELASTIC_SIMULATION
+
+ if(POROELASTIC_SIMULATION) then
+
+ stop 'poroelastic simulation not implemented yet'
+ ! but would be something like this...
+ call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,rmass_solid_poroelastic, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+ call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,rmass_fluid_poroelastic, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,ibool_interfaces_ext_mesh, &
+ my_neighbours_ext_mesh)
+
+ ! fills mass matrix with fictitious non-zero values to make sure it can be inverted globally
+ where(rmass_solid_poroelastic <= 0._CUSTOM_REAL) rmass_solid_poroelastic = 1._CUSTOM_REAL
+ where(rmass_fluid_poroelastic <= 0._CUSTOM_REAL) rmass_fluid_poroelastic = 1._CUSTOM_REAL
+ rmass_solid_poroelastic(:) = 1._CUSTOM_REAL / rmass_solid_poroelastic(:)
+ rmass_fluid_poroelastic(:) = 1._CUSTOM_REAL / rmass_fluid_poroelastic(:)
+
+ endif ! POROELASTIC_SIMULATION
+
+ if(myrank == 0) write(IMAIN,*) 'end assembling MPI mass matrix'
+
+
+ end subroutine prepare_timerun_mass_matrices
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_timerun_attenuation()
+
+ use specfem_par
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ use specfem_par_poroelastic
+ implicit none
+
+ ! local parameters
+ double precision :: scale_factor
+ real(kind=CUSTOM_REAL):: vs_val
+ integer :: i,j,k,ispec
+ integer :: iattenuation,iselected
+
+! if attenuation is on, shift PREM to right frequency
+! rescale mu in PREM to average frequency for attenuation
+ if(ATTENUATION) then
+
+! get and store PREM attenuation model
+ do iattenuation = 1,NUM_REGIONS_ATTENUATION
+
+ call get_attenuation_model(myrank,iattenuation,tau_mu_dble, &
+ tau_sigma_dble,beta_dble,one_minus_sum_beta_dble,factor_scale_dble)
+
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ tau_mu(iattenuation,:) = sngl(tau_mu_dble(:))
+ tau_sigma(iattenuation,:) = sngl(tau_sigma_dble(:))
+ beta(iattenuation,:) = sngl(beta_dble(:))
+ factor_scale(iattenuation) = sngl(factor_scale_dble)
+ one_minus_sum_beta(iattenuation) = sngl(one_minus_sum_beta_dble)
+ else
+ tau_mu(iattenuation,:) = tau_mu_dble(:)
+ tau_sigma(iattenuation,:) = tau_sigma_dble(:)
+ beta(iattenuation,:) = beta_dble(:)
+ factor_scale(iattenuation) = factor_scale_dble
+ one_minus_sum_beta(iattenuation) = one_minus_sum_beta_dble
+ endif
+ enddo
+
+! rescale shear modulus according to attenuation model
+ do ispec = 1,NSPEC_AB
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+
+ ! use scaling rule similar to Olsen et al. (2003)
+ !! We might need to fix the attenuation part for the anisotropy case
+ !! At this stage, we turn the ATTENUATION flag off always, and still keep mustore
+ if(USE_OLSEN_ATTENUATION) then
+ vs_val = mustore(i,j,k,ispec) / rho_vs(i,j,k,ispec)
+ call get_attenuation_model_olsen( vs_val, iselected )
+ else
+ ! takes iflag set in (CUBIT) mesh
+ iselected = iflag_attenuation_store(i,j,k,ispec)
+ endif
+
+ ! scales only mu
+ scale_factor = factor_scale(iselected)
+ mustore(i,j,k,ispec) = mustore(i,j,k,ispec) * scale_factor
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+! precompute Runge-Kutta coefficients if attenuation
+ tauinv(:,:) = - 1._CUSTOM_REAL / tau_sigma(:,:)
+ factor_common(:,:) = 2._CUSTOM_REAL * beta(:,:) * tauinv(:,:)
+ alphaval(:,:) = 1 + deltat*tauinv(:,:) + deltat**2*tauinv(:,:)**2 / 2._CUSTOM_REAL &
+ + deltat**3*tauinv(:,:)**3 / 6._CUSTOM_REAL &
+ + deltat**4*tauinv(:,:)**4 / 24._CUSTOM_REAL
+ betaval(:,:) = deltat / 2._CUSTOM_REAL + deltat**2*tauinv(:,:) / 3._CUSTOM_REAL &
+ + deltat**3*tauinv(:,:)**2 / 8._CUSTOM_REAL &
+ + deltat**4*tauinv(:,:)**3 / 24._CUSTOM_REAL
+ gammaval(:,:) = deltat / 2._CUSTOM_REAL + deltat**2*tauinv(:,:) / 6._CUSTOM_REAL &
+ + deltat**3*tauinv(:,:)**2 / 24._CUSTOM_REAL
+ endif
+
+
+ !pll, to put elsewhere
+ ! note: currently, they need to be defined here, as they are used in the routine arguments
+ ! for compute_forces_with_Deville()
+ allocate(R_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB,N_SLS))
+ allocate(R_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB,N_SLS))
+ allocate(R_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB,N_SLS))
+ allocate(R_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB,N_SLS))
+ allocate(R_yz(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB,N_SLS))
+ allocate(epsilondev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB))
+ allocate(epsilondev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB))
+ allocate(epsilondev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB))
+ allocate(epsilondev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB))
+ allocate(epsilondev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_ATTENUATION_AB))
+
+! clear memory variables if attenuation
+ if(ATTENUATION) then
+
+ ! initialize memory variables for attenuation
+ epsilondev_xx(:,:,:,:) = 0._CUSTOM_REAL
+ epsilondev_yy(:,:,:,:) = 0._CUSTOM_REAL
+ epsilondev_xy(:,:,:,:) = 0._CUSTOM_REAL
+ epsilondev_xz(:,:,:,:) = 0._CUSTOM_REAL
+ epsilondev_yz(:,:,:,:) = 0._CUSTOM_REAL
+
+ R_xx(:,:,:,:,:) = 0._CUSTOM_REAL
+ R_yy(:,:,:,:,:) = 0._CUSTOM_REAL
+ R_xy(:,:,:,:,:) = 0._CUSTOM_REAL
+ R_xz(:,:,:,:,:) = 0._CUSTOM_REAL
+ R_yz(:,:,:,:,:) = 0._CUSTOM_REAL
+
+ if(FIX_UNDERFLOW_PROBLEM) then
+ R_xx(:,:,:,:,:) = VERYSMALLVAL
+ R_yy(:,:,:,:,:) = VERYSMALLVAL
+ R_xy(:,:,:,:,:) = VERYSMALLVAL
+ R_xz(:,:,:,:,:) = VERYSMALLVAL
+ R_yz(:,:,:,:,:) = VERYSMALLVAL
+ endif
+ endif
+
+ end subroutine prepare_timerun_attenuation
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine prepare_timerun_adjoint()
+
+! prepares adjoint simulations
+
+ use specfem_par
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ use specfem_par_poroelastic
+ implicit none
+
+ integer :: ier
+
+! seismograms
+ if (nrec_local > 0 .and. SIMULATION_TYPE == 2 ) then
+ ! allocate Frechet derivatives array
+ allocate(Mxx_der(nrec_local),Myy_der(nrec_local), &
+ Mzz_der(nrec_local),Mxy_der(nrec_local), &
+ Mxz_der(nrec_local),Myz_der(nrec_local), &
+ sloc_der(NDIM,nrec_local))
+ Mxx_der = 0._CUSTOM_REAL
+ Myy_der = 0._CUSTOM_REAL
+ Mzz_der = 0._CUSTOM_REAL
+ Mxy_der = 0._CUSTOM_REAL
+ Mxz_der = 0._CUSTOM_REAL
+ Myz_der = 0._CUSTOM_REAL
+ sloc_der = 0._CUSTOM_REAL
+
+ allocate(seismograms_eps(NDIM,NDIM,nrec_local,NSTEP))
+ seismograms_eps(:,:,:,:) = 0._CUSTOM_REAL
+ endif
+
+! timing
+ if (SIMULATION_TYPE == 3) then
+
+ ! backward/reconstructed wavefields: time stepping is in time-reversed sense
+ ! (negative time increments)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ b_deltat = - sngl(DT)
+ else
+ b_deltat = - DT
+ endif
+ b_deltatover2 = b_deltat/2._CUSTOM_REAL
+ b_deltatsqover2 = b_deltat*b_deltat/2._CUSTOM_REAL
+
+ endif
+
+! attenuation backward memories
+ if( ATTENUATION .and. SIMULATION_TYPE == 3 ) then
+ ! precompute Runge-Kutta coefficients if attenuation
+ b_alphaval(:,:) = 1 + b_deltat*tauinv(:,:) + b_deltat**2*tauinv(:,:)**2 / 2._CUSTOM_REAL &
+ + b_deltat**3*tauinv(:,:)**3 / 6._CUSTOM_REAL &
+ + b_deltat**4*tauinv(:,:)**4 / 24._CUSTOM_REAL
+ b_betaval(:,:) = b_deltat / 2._CUSTOM_REAL + b_deltat**2*tauinv(:,:) / 3._CUSTOM_REAL &
+ + b_deltat**3*tauinv(:,:)**2 / 8._CUSTOM_REAL &
+ + b_deltat**4*tauinv(:,:)**3 / 24._CUSTOM_REAL
+ b_gammaval(:,:) = b_deltat / 2._CUSTOM_REAL + b_deltat**2*tauinv(:,:) / 6._CUSTOM_REAL &
+ + b_deltat**3*tauinv(:,:)**2 / 24._CUSTOM_REAL
+ endif
+
+! kernel calculation, reads in last frame
+ if (SIMULATION_TYPE == 3) then
+ ! reads in wavefields
+ open(unit=27,file=trim(prname)//'save_forward_arrays.bin',status='old',&
+ action='read',form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error: opening save_forward_arrays'
+ print*,'path: ',trim(prname)//'save_forward_arrays.bin'
+ call exit_mpi(myrank,'error open file save_forward_arrays.bin')
+ endif
+
+ if( ACOUSTIC_SIMULATION ) then
+ read(27) b_potential_acoustic
+ read(27) b_potential_dot_acoustic
+ read(27) b_potential_dot_dot_acoustic
+ endif
+
+ ! elastic wavefields
+ if( ELASTIC_SIMULATION ) then
+ read(27) b_displ
+ read(27) b_veloc
+ read(27) b_accel
+ endif
+
+ ! memory variables if attenuation
+ if( ATTENUATION ) then
+ read(27) b_R_xx
+ read(27) b_R_yy
+ read(27) b_R_xy
+ read(27) b_R_xz
+ read(27) b_R_yz
+ read(27) b_epsilondev_xx
+ read(27) b_epsilondev_yy
+ read(27) b_epsilondev_xy
+ read(27) b_epsilondev_xz
+ read(27) b_epsilondev_yz
+ endif
+
+ close(27)
+ endif
+
+! initializes adjoint kernels
+ if (SIMULATION_TYPE == 3) then
+ ! elastic domain
+ if( ELASTIC_SIMULATION ) then
+ rho_kl(:,:,:,:) = 0._CUSTOM_REAL
+ mu_kl(:,:,:,:) = 0._CUSTOM_REAL
+ kappa_kl(:,:,:,:) = 0._CUSTOM_REAL
+ endif
+
+ ! acoustic domain
+ if( ACOUSTIC_SIMULATION ) then
+ rho_ac_kl(:,:,:,:) = 0._CUSTOM_REAL
+ kappa_ac_kl(:,:,:,:) = 0._CUSTOM_REAL
+ endif
+ endif
+
+! initialize Moho boundary index
+ if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
+ ispec2D_moho_top = 0
+ ispec2D_moho_bot = 0
+ endif
+
+! stacey absorbing fields will be reconstructed for adjoint simulations
+! using snapshot files of wavefields
+ if( ABSORBING_CONDITIONS ) then
+
+ ! opens absorbing wavefield saved/to-be-saved by forward simulations
+ if( num_abs_boundary_faces > 0 .and. (SIMULATION_TYPE == 3 .or. &
+ (SIMULATION_TYPE == 1 .and. SAVE_FORWARD)) ) then
+
+ b_num_abs_boundary_faces = num_abs_boundary_faces
+
+ ! elastic domains
+ if( ELASTIC_SIMULATION) then
+ ! allocates wavefield
+ allocate(b_absorb_field(NDIM,NGLLSQUARE,b_num_abs_boundary_faces))
+
+ b_reclen_field = CUSTOM_REAL * (NDIM * NGLLSQUARE * num_abs_boundary_faces)
+
+ if (SIMULATION_TYPE == 3) then
+ ! opens existing files
+ open(unit=IOABS,file=trim(prname)//'absorb_field.bin',status='old',&
+ action='read',form='unformatted',access='direct', &
+ recl=b_reclen_field+2*4 )
+ else
+ ! opens new file
+ open(unit=IOABS,file=trim(prname)//'absorb_field.bin',status='unknown',&
+ form='unformatted',access='direct',&
+ recl=b_reclen_field+2*4 )
+ endif
+ endif
+
+ ! acoustic domains
+ if( ACOUSTIC_SIMULATION) then
+ ! allocates wavefield
+ allocate(b_absorb_potential(NGLLSQUARE,b_num_abs_boundary_faces))
+
+ b_reclen_potential = CUSTOM_REAL * (NGLLSQUARE * num_abs_boundary_faces)
+
+ if (SIMULATION_TYPE == 3) then
+ ! opens existing files
+ open(unit=IOABS_AC,file=trim(prname)//'absorb_potential.bin',status='old',&
+ action='read',form='unformatted',access='direct', &
+ recl=b_reclen_potential+2*4 )
+ else
+ ! opens new file
+ open(unit=IOABS_AC,file=trim(prname)//'absorb_potential.bin',status='unknown',&
+ form='unformatted',access='direct',&
+ recl=b_reclen_potential+2*4 )
+ endif
+ endif
+
+ else
+ ! dummy array
+ b_num_abs_boundary_faces = 1
+ if( ELASTIC_SIMULATION ) &
+ allocate(b_absorb_field(NDIM,NGLLSQUARE,b_num_abs_boundary_faces))
+
+ if( ACOUSTIC_SIMULATION ) &
+ allocate(b_absorb_potential(NGLLSQUARE,b_num_abs_boundary_faces))
+
+ endif
+ endif
+
+ end subroutine prepare_timerun_adjoint
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/program_create_header_file.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/program_create_header_file.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/program_create_header_file.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,7 @@
+
+ program xcreate_header_file
+
+! run the main program
+ call create_header_file
+
+ end program xcreate_header_file
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/program_generate_databases.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/program_generate_databases.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/program_generate_databases.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,37 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+ program xgenerate_databases
+
+! mpi initialization
+ call init()
+
+! run the main program
+ call generate_databases()
+
+! mpi finish
+ call finalize()
+
+ end program xgenerate_databases
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/program_specfem3D.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/program_specfem3D.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/program_specfem3D.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,37 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+ program xspecfem3D
+
+! mpi initialization
+ call init()
+
+! run the main program
+ call specfem3D
+
+! mpi finish
+ call finalize()
+
+ end program xspecfem3D
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_arrays_buffers_solver.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_arrays_buffers_solver.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_arrays_buffers_solver.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,150 @@
+!=====================================================================
+!
+! 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 read_arrays_buffers_solver(myrank, &
+ iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta, &
+ npoin2D_xi,npoin2D_eta, &
+ NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,LOCAL_PATH)
+
+ implicit none
+
+ include "constants.h"
+
+ integer myrank
+
+ integer npoin2D_xi,npoin2D_eta
+ integer NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX
+
+ character(len=256) LOCAL_PATH
+
+ integer, dimension(NPOIN2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
+ integer, dimension(NPOIN2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
+
+ integer npoin2D_xi_mesher,npoin2D_eta_mesher
+
+ double precision xdummy,ydummy,zdummy
+
+! processor identification
+ character(len=256) prname
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! create the name for the database of the current slide and region
+ call create_name_database(prname,myrank,LOCAL_PATH)
+
+! read 2-D addressing for summation between slices along xi with MPI
+
+! read iboolleft_xi of this slice
+ open(unit=IIN,file=prname(1:len_trim(prname))//'iboolleft_xi.txt',status='old',action='read')
+ npoin2D_xi = 1
+ 350 continue
+ read(IIN,*) iboolleft_xi(npoin2D_xi),xdummy,ydummy,zdummy
+ if(iboolleft_xi(npoin2D_xi) > 0) then
+ npoin2D_xi = npoin2D_xi + 1
+ goto 350
+ endif
+! subtract the line that contains the flag after the last point
+ npoin2D_xi = npoin2D_xi - 1
+! read nb of points given by the mesher
+ read(IIN,*) npoin2D_xi_mesher
+ if(npoin2D_xi > NPOIN2DMAX_XMIN_XMAX .or. npoin2D_xi /= npoin2D_xi_mesher) &
+ call exit_MPI(myrank,'incorrect iboolleft_xi read')
+ close(IIN)
+
+! read iboolright_xi of this slice
+ open(unit=IIN,file=prname(1:len_trim(prname))//'iboolright_xi.txt',status='old',action='read')
+ npoin2D_xi = 1
+ 360 continue
+ read(IIN,*) iboolright_xi(npoin2D_xi),xdummy,ydummy,zdummy
+ if(iboolright_xi(npoin2D_xi) > 0) then
+ npoin2D_xi = npoin2D_xi + 1
+ goto 360
+ endif
+! subtract the line that contains the flag after the last point
+ npoin2D_xi = npoin2D_xi - 1
+! read nb of points given by the mesher
+ read(IIN,*) npoin2D_xi_mesher
+ if(npoin2D_xi > NPOIN2DMAX_XMIN_XMAX .or. npoin2D_xi /= npoin2D_xi_mesher) &
+ call exit_MPI(myrank,'incorrect iboolright_xi read')
+ close(IIN)
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '# of points in MPI buffers along xi npoin2D_xi = ', &
+ npoin2D_xi
+ write(IMAIN,*) '# of array elements transferred npoin2D_xi*NDIM = ', &
+ npoin2D_xi*NDIM
+ write(IMAIN,*)
+ endif
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! read 2-D addressing for summation between slices along eta with MPI
+
+! read iboolleft_eta of this slice
+ open(unit=IIN,file=prname(1:len_trim(prname))//'iboolleft_eta.txt',status='old',action='read')
+ npoin2D_eta = 1
+ 370 continue
+ read(IIN,*) iboolleft_eta(npoin2D_eta),xdummy,ydummy,zdummy
+ if(iboolleft_eta(npoin2D_eta) > 0) then
+ npoin2D_eta = npoin2D_eta + 1
+ goto 370
+ endif
+! subtract the line that contains the flag after the last point
+ npoin2D_eta = npoin2D_eta - 1
+! read nb of points given by the mesher
+ read(IIN,*) npoin2D_eta_mesher
+ if(npoin2D_eta > NPOIN2DMAX_YMIN_YMAX .or. npoin2D_eta /= npoin2D_eta_mesher) &
+ call exit_MPI(myrank,'incorrect iboolleft_eta read')
+ close(IIN)
+
+! read iboolright_eta of this slice
+ open(unit=IIN,file=prname(1:len_trim(prname))//'iboolright_eta.txt',status='old',action='read')
+ npoin2D_eta = 1
+ 380 continue
+ read(IIN,*) iboolright_eta(npoin2D_eta),xdummy,ydummy,zdummy
+ if(iboolright_eta(npoin2D_eta) > 0) then
+ npoin2D_eta = npoin2D_eta + 1
+ goto 380
+ endif
+! subtract the line that contains the flag after the last point
+ npoin2D_eta = npoin2D_eta - 1
+! read nb of points given by the mesher
+ read(IIN,*) npoin2D_eta_mesher
+ if(npoin2D_eta > NPOIN2DMAX_YMIN_YMAX .or. npoin2D_eta /= npoin2D_eta_mesher) &
+ call exit_MPI(myrank,'incorrect iboolright_eta read')
+ close(IIN)
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '# of points in MPI buffers along eta npoin2D_eta = ', &
+ npoin2D_eta
+ write(IMAIN,*) '# of array elements transferred npoin2D_eta*NDIM = ', &
+ npoin2D_eta*NDIM
+ write(IMAIN,*)
+ endif
+
+ end subroutine read_arrays_buffers_solver
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_arrays_solver.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_arrays_solver.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_arrays_solver.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,320 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! read arrays created by the mesher
+
+ subroutine read_arrays_solver(myrank,NSPEC_AB,NGLOB_AB,xstore,ystore,zstore, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,jacobian, &
+ flag_sediments,not_fully_in_bedrock,rho_vp,rho_vs,ANISOTROPY, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ kappastore,mustore,ibool,idoubling,rmass,rmass_ocean_load,LOCAL_PATH,OCEANS)
+
+ implicit none
+
+ include "constants.h"
+
+! include "OUTPUT_FILES/values_from_mesher.h"
+
+ integer myrank
+
+ integer NSPEC_AB
+ integer NGLOB_AB
+
+ logical OCEANS
+
+ character(len=256) LOCAL_PATH
+
+! coordinates in single precision
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: xstore,ystore,zstore
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_AB) :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,jacobian
+
+ logical ANISOTROPY
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO) :: &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store
+
+! material properties
+ real(kind=CUSTOM_REAL) kappastore(NGLLX,NGLLY,NGLLZ,NSPEC_AB)
+ real(kind=CUSTOM_REAL) mustore(NGLLX,NGLLY,NGLLZ,NSPEC_AB)
+
+! flag for sediments
+ logical not_fully_in_bedrock(NSPEC_AB)
+ logical flag_sediments(NGLLX,NGLLY,NGLLZ,NSPEC_AB)
+
+! Stacey
+ real(kind=CUSTOM_REAL) rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB)
+ real(kind=CUSTOM_REAL) rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB)
+
+! mass matrix and additional ocean load mass matrix
+ real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: rmass,rmass_ocean_load
+
+! global addressing
+ integer ibool(NGLLX,NGLLY,NGLLZ,NSPEC_AB)
+
+ integer idoubling(NSPEC_AB)
+
+! processor identification
+ character(len=256) prname
+
+! create the name for the database of the current slide and region
+ call create_name_database(prname,myrank,LOCAL_PATH)
+
+! xix
+ open(unit=IIN,file=prname(1:len_trim(prname))//'xix.bin',status='old',action='read',form='unformatted')
+ read(IIN) xix
+ close(IIN)
+
+! xiy
+ open(unit=IIN,file=prname(1:len_trim(prname))//'xiy.bin',status='old',action='read',form='unformatted')
+ read(IIN) xiy
+ close(IIN)
+
+! xiz
+ open(unit=IIN,file=prname(1:len_trim(prname))//'xiz.bin',status='old',action='read',form='unformatted')
+ read(IIN) xiz
+ close(IIN)
+
+! etax
+ open(unit=IIN,file=prname(1:len_trim(prname))//'etax.bin',status='old',action='read',form='unformatted')
+ read(IIN) etax
+ close(IIN)
+
+! etay
+ open(unit=IIN,file=prname(1:len_trim(prname))//'etay.bin',status='old',action='read',form='unformatted')
+ read(IIN) etay
+ close(IIN)
+
+! etaz
+ open(unit=IIN,file=prname(1:len_trim(prname))//'etaz.bin',status='old',action='read',form='unformatted')
+ read(IIN) etaz
+ close(IIN)
+
+! gammax
+ open(unit=IIN,file=prname(1:len_trim(prname))//'gammax.bin',status='old',action='read',form='unformatted')
+ read(IIN) gammax
+ close(IIN)
+
+! gammay
+ open(unit=IIN,file=prname(1:len_trim(prname))//'gammay.bin',status='old',action='read',form='unformatted')
+ read(IIN) gammay
+ close(IIN)
+
+! gammaz
+ open(unit=IIN,file=prname(1:len_trim(prname))//'gammaz.bin',status='old',action='read',form='unformatted')
+ read(IIN) gammaz
+ close(IIN)
+
+! jacobian
+ open(unit=IIN,file=prname(1:len_trim(prname))//'jacobian.bin',status='old',action='read',form='unformatted')
+ read(IIN) jacobian
+ close(IIN)
+
+! read coordinates of the mesh
+ open(unit=IIN,file=prname(1:len_trim(prname))//'x.bin',status='old',action='read',form='unformatted')
+ read(IIN) xstore
+ close(IIN)
+
+ open(unit=IIN,file=prname(1:len_trim(prname))//'y.bin',status='old',action='read',form='unformatted')
+ read(IIN) ystore
+ close(IIN)
+
+ open(unit=IIN,file=prname(1:len_trim(prname))//'z.bin',status='old',action='read',form='unformatted')
+ read(IIN) zstore
+ close(IIN)
+
+! ibool
+ open(unit=IIN,file=prname(1:len_trim(prname))//'ibool.bin',status='old',action='read',form='unformatted')
+ read(IIN) ibool
+ close(IIN)
+
+! idoubling
+ open(unit=IIN,file=prname(1:len_trim(prname))//'idoubling.bin',status='old',action='read',form='unformatted')
+ read(IIN) idoubling
+ close(IIN)
+
+! mass matrix
+ open(unit=IIN,file=prname(1:len_trim(prname))//'rmass.bin',status='old',action='read',form='unformatted')
+ read(IIN) rmass
+ close(IIN)
+
+! read additional ocean load mass matrix
+ if(OCEANS) then
+ open(unit=IIN,file=prname(1:len_trim(prname))//'rmass_ocean_load.bin',status='old',action='read',form='unformatted')
+ read(IIN) rmass_ocean_load
+ close(IIN)
+ endif
+
+! flag_sediments
+ open(unit=IIN,file=prname(1:len_trim(prname))//'flag_sediments.bin',status='old',action='read',form='unformatted')
+ read(IIN) flag_sediments
+ close(IIN)
+
+! not_fully_in_bedrock
+ open(unit=IIN,file=prname(1:len_trim(prname))//'not_fully_in_bedrock.bin',status='old',action='read',form='unformatted')
+ read(IIN) not_fully_in_bedrock
+ close(IIN)
+
+! rho_vs
+! Stacey
+
+! rho_vp
+ open(unit=IIN,file=prname(1:len_trim(prname))//'rho_vp.bin',status='old',action='read',form='unformatted')
+ read(IIN) rho_vp
+ close(IIN)
+
+! rho_vs
+ open(unit=IIN,file=prname(1:len_trim(prname))//'rho_vs.bin',status='old',action='read',form='unformatted')
+ read(IIN) rho_vs
+ close(IIN)
+
+
+! model arrays
+
+! kappa
+ open(unit=IIN,file=prname(1:len_trim(prname))//'kappa.bin',status='old',action='read',form='unformatted')
+ read(IIN) kappastore
+ close(IIN)
+
+! mu
+ open(unit=IIN,file=prname(1:len_trim(prname))//'mu.bin',status='old',action='read',form='unformatted')
+ read(IIN) mustore
+ close(IIN)
+
+ if(ANISOTROPY) then
+
+! c11
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c11.bin',status='old',action='read',form='unformatted')
+ read(IIN) c11store
+ close(IIN)
+
+! c12
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c12.bin',status='old',action='read',form='unformatted')
+ read(IIN) c12store
+ close(IIN)
+
+! c13
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c13.bin',status='old',action='read',form='unformatted')
+ read(IIN) c13store
+ close(IIN)
+
+! c14
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c14.bin',status='old',action='read',form='unformatted')
+ read(IIN) c14store
+ close(IIN)
+
+! c15
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c15.bin',status='old',action='read',form='unformatted')
+ read(IIN) c15store
+ close(IIN)
+
+! c16
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c16.bin',status='old',action='read',form='unformatted')
+ read(IIN) c16store
+ close(IIN)
+
+! c22
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c22.bin',status='old',action='read',form='unformatted')
+ read(IIN) c22store
+ close(IIN)
+
+! c23
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c23.bin',status='old',action='read',form='unformatted')
+ read(IIN) c23store
+ close(IIN)
+
+! c24
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c24.bin',status='old',action='read',form='unformatted')
+ read(IIN) c24store
+ close(IIN)
+
+! c25
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c25.bin',status='old',action='read',form='unformatted')
+ read(IIN) c25store
+ close(IIN)
+
+! c26
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c26.bin',status='old',action='read',form='unformatted')
+ read(IIN) c26store
+ close(IIN)
+
+! c33
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c33.bin',status='old',action='read',form='unformatted')
+ read(IIN) c33store
+ close(IIN)
+
+! c34
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c34.bin',status='old',action='read',form='unformatted')
+ read(IIN) c34store
+ close(IIN)
+
+! c35
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c35.bin',status='old',action='read',form='unformatted')
+ read(IIN) c35store
+ close(IIN)
+
+! c36
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c36.bin',status='old',action='read',form='unformatted')
+ read(IIN) c36store
+ close(IIN)
+
+! c44
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c44.bin',status='old',action='read',form='unformatted')
+ read(IIN) c44store
+ close(IIN)
+
+! c45
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c45.bin',status='old',action='read',form='unformatted')
+ read(IIN) c45store
+ close(IIN)
+
+! c46
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c46.bin',status='old',action='read',form='unformatted')
+ read(IIN) c46store
+ close(IIN)
+
+! c55
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c55.bin',status='old',action='read',form='unformatted')
+ read(IIN) c55store
+ close(IIN)
+
+! c56
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c56.bin',status='old',action='read',form='unformatted')
+ read(IIN) c56store
+ close(IIN)
+
+! c66
+ open(unit=IIN,file=prname(1:len_trim(prname))//'c66.bin',status='old',action='read',form='unformatted')
+ read(IIN) c66store
+ close(IIN)
+
+ endif
+
+ end subroutine read_arrays_solver
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_mesh_databases.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_mesh_databases.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_mesh_databases.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,546 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+ subroutine read_mesh_databases()
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_poroelastic
+ implicit none
+
+ integer :: i,j,k,ispec,iglob
+ integer :: iinterface,ier
+ real(kind=CUSTOM_REAL):: minl,maxl,min_all,max_all
+
+! start reading the databasesa
+
+! info about external mesh simulation
+ 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',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error: could not open database '
+ print*,'path: ',prname(1:len_trim(prname))//'external_mesh.bin'
+ call exit_mpi(myrank,'error opening database')
+ endif
+
+ read(27) NSPEC_AB
+ read(27) NGLOB_AB
+
+ read(27) ibool
+
+ read(27) xstore
+ read(27) ystore
+ read(27) zstore
+
+ read(27) xix
+ read(27) xiy
+ read(27) xiz
+ read(27) etax
+ read(27) etay
+ read(27) etaz
+ read(27) gammax
+ read(27) gammay
+ read(27) gammaz
+ read(27) jacobian
+
+ read(27) kappastore
+ read(27) mustore
+
+ read(27) ispec_is_acoustic
+ read(27) ispec_is_elastic
+ read(27) ispec_is_poroelastic
+
+ ! acoustic
+ ! all processes will have acoustic_simulation set if any flag is .true.
+ call any_all_l( ANY(ispec_is_acoustic), ACOUSTIC_SIMULATION )
+ if( ACOUSTIC_SIMULATION ) then
+ ! potentials
+ allocate(potential_acoustic(NGLOB_AB))
+ allocate(potential_dot_acoustic(NGLOB_AB))
+ allocate(potential_dot_dot_acoustic(NGLOB_AB))
+
+ ! mass matrix, density
+ allocate(rmass_acoustic(NGLOB_AB))
+ allocate(rhostore(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+
+ read(27) rmass_acoustic
+ read(27) rhostore
+ endif
+
+ ! elastic
+ call any_all_l( ANY(ispec_is_elastic), ELASTIC_SIMULATION )
+ if( ELASTIC_SIMULATION ) then
+ ! displacement,velocity,acceleration
+ allocate(displ(NDIM,NGLOB_AB))
+ allocate(veloc(NDIM,NGLOB_AB))
+ allocate(accel(NDIM,NGLOB_AB))
+
+ allocate(rmass(NGLOB_AB))
+ allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(iflag_attenuation_store(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(c11store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c12store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c13store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c14store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c15store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c16store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c22store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c23store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c24store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c25store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c26store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c33store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c34store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c35store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c36store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c44store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c45store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c46store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c55store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c56store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+ allocate(c66store(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO))
+
+ read(27) rmass
+ if( OCEANS ) then
+ read(27) rmass_ocean_load
+ endif
+ !pll
+ read(27) rho_vp
+ read(27) rho_vs
+ read(27) iflag_attenuation_store
+
+ else
+ ! no elastic attenuation & anisotropy
+ ATTENUATION = .false.
+ ANISOTROPY = .false.
+ endif
+
+ ! poroelastic
+ call any_all_l( ANY(ispec_is_poroelastic), POROELASTIC_SIMULATION )
+ if( POROELASTIC_SIMULATION ) then
+
+ stop 'not implemented yet: read rmass_solid_poroelastic .. '
+
+ allocate(rmass_solid_poroelastic(NGLOB_AB))
+ allocate(rmass_fluid_poroelastic(NGLOB_AB))
+
+ read(27) rmass_solid_poroelastic
+ read(27) rmass_fluid_poroelastic
+ endif
+
+! checks simulation types are valid
+ if( (.not. ACOUSTIC_SIMULATION ) .and. &
+ (.not. ELASTIC_SIMULATION ) .and. &
+ (.not. POROELASTIC_SIMULATION ) ) then
+ close(27)
+ call exit_mpi(myrank,'error no simulation type defined')
+ endif
+
+ ! checks attenuation flags: see integers defined in constants.h
+ if( ATTENUATION ) then
+ if( minval(iflag_attenuation_store(:,:,:,:)) < 1 ) then
+ close(27)
+ call exit_MPI(myrank,'error attenuation flag entry exceeds range')
+ endif
+ if( maxval(iflag_attenuation_store(:,:,:,:)) > NUM_REGIONS_ATTENUATION ) then
+ close(27)
+ call exit_MPI(myrank,'error attenuation flag entry exceeds range')
+ endif
+ endif
+
+! absorbing boundary surface
+ read(27) num_abs_boundary_faces
+ allocate(abs_boundary_ispec(num_abs_boundary_faces))
+ allocate(abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces))
+ allocate(abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces))
+ allocate(abs_boundary_normal(NDIM,NGLLSQUARE,num_abs_boundary_faces))
+ read(27) abs_boundary_ispec
+ read(27) abs_boundary_ijk
+ read(27) abs_boundary_jacobian2Dw
+ read(27) abs_boundary_normal
+
+! free surface
+ read(27) num_free_surface_faces
+ allocate(free_surface_ispec(num_free_surface_faces))
+ allocate(free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces))
+ allocate(free_surface_jacobian2Dw(NGLLSQUARE,num_free_surface_faces))
+ allocate(free_surface_normal(NDIM,NGLLSQUARE,num_free_surface_faces))
+ read(27) free_surface_ispec
+ read(27) free_surface_ijk
+ read(27) free_surface_jacobian2Dw
+ read(27) free_surface_normal
+
+! acoustic-elastic coupling surface
+ read(27) num_coupling_ac_el_faces
+ allocate(coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces))
+ allocate(coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces))
+ allocate(coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces))
+ allocate(coupling_ac_el_ispec(num_coupling_ac_el_faces))
+ read(27) coupling_ac_el_ispec
+ read(27) coupling_ac_el_ijk
+ read(27) coupling_ac_el_jacobian2Dw
+ read(27) coupling_ac_el_normal
+
+! MPI interfaces
+ read(27) num_interfaces_ext_mesh
+ read(27) max_nibool_interfaces_ext_mesh
+ allocate(my_neighbours_ext_mesh(num_interfaces_ext_mesh))
+ allocate(nibool_interfaces_ext_mesh(num_interfaces_ext_mesh))
+ allocate(ibool_interfaces_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ read(27) my_neighbours_ext_mesh
+ read(27) nibool_interfaces_ext_mesh
+ read(27) ibool_interfaces_ext_mesh
+
+ if( ANISOTROPY ) then
+ read(27) c11store
+ read(27) c12store
+ read(27) c13store
+ read(27) c14store
+ read(27) c15store
+ read(27) c16store
+ read(27) c22store
+ read(27) c23store
+ read(27) c24store
+ read(27) c25store
+ read(27) c26store
+ read(27) c33store
+ read(27) c34store
+ read(27) c35store
+ read(27) c36store
+ read(27) c44store
+ read(27) c45store
+ read(27) c46store
+ read(27) c55store
+ read(27) c56store
+ read(27) c66store
+ endif
+
+ close(27)
+
+! MPI communications
+ allocate(buffer_send_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(buffer_recv_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(buffer_send_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(buffer_recv_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(request_send_vector_ext_mesh(num_interfaces_ext_mesh))
+ allocate(request_recv_vector_ext_mesh(num_interfaces_ext_mesh))
+ allocate(request_send_scalar_ext_mesh(num_interfaces_ext_mesh))
+ allocate(request_recv_scalar_ext_mesh(num_interfaces_ext_mesh))
+
+! locate inner and outer elements
+ allocate(ispec_is_inner(NSPEC_AB))
+ allocate(iglob_is_inner(NGLOB_AB))
+ ispec_is_inner(:) = .true.
+ iglob_is_inner(:) = .true.
+ do iinterface = 1, num_interfaces_ext_mesh
+ do i = 1, nibool_interfaces_ext_mesh(iinterface)
+ iglob = ibool_interfaces_ext_mesh(i,iinterface)
+ iglob_is_inner(iglob) = .false.
+ enddo
+ enddo
+ do ispec = 1, NSPEC_AB
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+ ispec_is_inner(ispec) = iglob_is_inner(iglob) .and. ispec_is_inner(ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+ deallocate( iglob_is_inner )
+
+! sets up elements for loops in acoustic simulations
+ if( ACOUSTIC_SIMULATION ) then
+ ! counts inner and outer elements
+ nspec_inner_acoustic = 0
+ nspec_outer_acoustic = 0
+ do ispec = 1, NSPEC_AB
+ if( ispec_is_acoustic(ispec) ) then
+ if( ispec_is_inner(ispec) .eqv. .true. ) then
+ nspec_inner_acoustic = nspec_inner_acoustic + 1
+ else
+ nspec_outer_acoustic = nspec_outer_acoustic + 1
+ endif
+ endif
+ enddo
+
+ ! stores indices of inner and outer elements for faster(?) computation
+ num_phase_ispec_acoustic = max(nspec_inner_acoustic,nspec_outer_acoustic)
+ allocate( phase_ispec_inner_acoustic(num_phase_ispec_acoustic,2))
+ nspec_inner_acoustic = 0
+ nspec_outer_acoustic = 0
+ do ispec = 1, NSPEC_AB
+ if( ispec_is_acoustic(ispec) ) then
+ if( ispec_is_inner(ispec) .eqv. .true. ) then
+ nspec_inner_acoustic = nspec_inner_acoustic + 1
+ phase_ispec_inner_acoustic(nspec_inner_acoustic,2) = ispec
+ else
+ nspec_outer_acoustic = nspec_outer_acoustic + 1
+ phase_ispec_inner_acoustic(nspec_outer_acoustic,1) = ispec
+ endif
+ endif
+ enddo
+ !print *,'rank ',myrank,' acoustic inner spec: ',nspec_inner_acoustic
+ !print *,'rank ',myrank,' acoustic outer spec: ',nspec_outer_acoustic
+ endif
+
+! sets up elements for loops in acoustic simulations
+ if( ELASTIC_SIMULATION ) then
+ ! counts inner and outer elements
+ nspec_inner_elastic = 0
+ nspec_outer_elastic = 0
+ do ispec = 1, NSPEC_AB
+ if( ispec_is_elastic(ispec) ) then
+ if( ispec_is_inner(ispec) .eqv. .true. ) then
+ nspec_inner_elastic = nspec_inner_elastic + 1
+ else
+ nspec_outer_elastic = nspec_outer_elastic + 1
+ endif
+ endif
+ enddo
+
+ ! stores indices of inner and outer elements for faster(?) computation
+ num_phase_ispec_elastic = max(nspec_inner_elastic,nspec_outer_elastic)
+ allocate( phase_ispec_inner_elastic(num_phase_ispec_elastic,2))
+ nspec_inner_elastic = 0
+ nspec_outer_elastic = 0
+ do ispec = 1, NSPEC_AB
+ if( ispec_is_elastic(ispec) ) then
+ if( ispec_is_inner(ispec) .eqv. .true. ) then
+ nspec_inner_elastic = nspec_inner_elastic + 1
+ phase_ispec_inner_elastic(nspec_inner_elastic,2) = ispec
+ else
+ nspec_outer_elastic = nspec_outer_elastic + 1
+ phase_ispec_inner_elastic(nspec_outer_elastic,1) = ispec
+ endif
+ endif
+ enddo
+ !print *,'rank ',myrank,' elastic inner spec: ',nspec_inner_elastic
+ !print *,'rank ',myrank,' elastic outer spec: ',nspec_outer_elastic
+ endif
+
+
+
+! gets model dimensions
+ minl = minval( xstore )
+ maxl = maxval( xstore )
+ call min_all_all_cr(minl,min_all)
+ call max_all_all_cr(maxl,max_all)
+ LONGITUDE_MIN = min_all
+ LONGITUDE_MAX = max_all
+
+ minl = minval( ystore )
+ maxl = maxval( ystore )
+ call min_all_all_cr(minl,min_all)
+ call max_all_all_cr(maxl,max_all)
+ LATITUDE_MIN = min_all
+ LATITUDE_MAX = max_all
+
+! check courant criteria on mesh
+ if( ELASTIC_SIMULATION ) then
+ call check_mesh_resolution(myrank,NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore, &
+ kappastore,mustore,rho_vp,rho_vs,DT,model_speed_max )
+ else if( ACOUSTIC_SIMULATION ) then
+ allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ rho_vp = sqrt( kappastore / rhostore ) * rhostore
+ rho_vs = 0.0_CUSTOM_REAL
+ call check_mesh_resolution(myrank,NSPEC_AB,NGLOB_AB,ibool,xstore,ystore,zstore, &
+ kappastore,mustore,rho_vp,rho_vs,DT,model_speed_max )
+ deallocate(rho_vp,rho_vs)
+ endif
+
+! reads adjoint parameters
+ call read_mesh_databases_adjoint()
+
+ end subroutine read_mesh_databases
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine read_mesh_databases_adjoint()
+
+! reads in moho meshes
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_poroelastic
+ implicit none
+
+ integer :: ier
+
+! allocates adjoint arrays for elastic simulations
+ if( ELASTIC_SIMULATION .and. SIMULATION_TYPE == 3 ) then
+ ! backward displacement,velocity,acceleration fields
+ allocate(b_displ(NDIM,NGLOB_ADJOINT))
+ allocate(b_veloc(NDIM,NGLOB_ADJOINT))
+ allocate(b_accel(NDIM,NGLOB_ADJOINT))
+
+ ! adjoint kernels
+
+ ! primary, isotropic kernels
+ ! density kernel
+ allocate(rho_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+ ! shear modulus kernel
+ allocate(mu_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+ ! compressional modulus kernel
+ allocate(kappa_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+
+ ! derived kernels
+ ! density prime kernel
+ allocate(rhop_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+ ! vp kernel
+ allocate(alpha_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+ ! vs kernel
+ allocate(beta_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+
+ ! MPI handling
+ allocate(b_request_send_vector_ext_mesh(num_interfaces_ext_mesh))
+ allocate(b_request_recv_vector_ext_mesh(num_interfaces_ext_mesh))
+ allocate(b_buffer_send_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(b_buffer_recv_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+
+ endif
+
+! allocates adjoint arrays for acoustic simulations
+ if( ACOUSTIC_SIMULATION .and. SIMULATION_TYPE == 3 ) then
+ ! backward potentials
+ allocate(b_potential_acoustic(NGLOB_ADJOINT))
+ allocate(b_potential_dot_acoustic(NGLOB_ADJOINT))
+ allocate(b_potential_dot_dot_acoustic(NGLOB_ADJOINT))
+
+ ! kernels
+ allocate(rho_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+ allocate(rhop_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+ allocate(kappa_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+ allocate(alpha_ac_kl(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT))
+
+ ! MPI handling
+ allocate(b_request_send_scalar_ext_mesh(num_interfaces_ext_mesh))
+ allocate(b_request_recv_scalar_ext_mesh(num_interfaces_ext_mesh))
+ allocate(b_buffer_send_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+ allocate(b_buffer_recv_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,num_interfaces_ext_mesh))
+
+ endif
+
+! allocates attenuation solids
+ if( ATTENUATION .and. SIMULATION_TYPE == 3 ) then
+ allocate(b_R_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL,N_SLS), &
+ b_R_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL,N_SLS), &
+ b_R_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL,N_SLS), &
+ b_R_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL,N_SLS), &
+ b_R_yz(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL,N_SLS) )
+
+ allocate(b_epsilondev_xx(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL), &
+ b_epsilondev_yy(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL), &
+ b_epsilondev_xy(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL), &
+ b_epsilondev_xz(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL), &
+ b_epsilondev_yz(NGLLX,NGLLY,NGLLZ,NSPEC_ATT_AND_KERNEL) )
+ endif
+
+! ADJOINT moho
+! moho boundary
+ if( ELASTIC_SIMULATION ) then
+ allocate( is_moho_top(NSPEC_BOUN),is_moho_bot(NSPEC_BOUN) )
+
+ if( SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3 ) then
+
+ ! boundary elements
+ !open(unit=27,file=prname(1:len_trim(prname))//'ibelm_moho.bin',status='unknown',form='unformatted')
+ open(unit=27,file=prname(1:len_trim(prname))//'ibelm_moho.bin',status='old',&
+ form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error: could not open ibelm_moho '
+ print*,'path: ',prname(1:len_trim(prname))//'ibelm_moho.bin'
+ call exit_mpi(myrank,'error opening ibelm_moho')
+ endif
+
+ read(27) NSPEC2D_MOHO
+
+ ! allocates arrays for moho mesh
+ allocate(ibelm_moho_bot(NSPEC2D_MOHO))
+ allocate(ibelm_moho_top(NSPEC2D_MOHO))
+ allocate(normal_moho_top(NDIM,NGLLSQUARE,NSPEC2D_MOHO))
+ allocate(normal_moho_bot(NDIM,NGLLSQUARE,NSPEC2D_MOHO))
+ allocate(ijk_moho_bot(3,NGLLSQUARE,NSPEC2D_MOHO))
+ allocate(ijk_moho_top(3,NGLLSQUARE,NSPEC2D_MOHO))
+
+ read(27) ibelm_moho_top
+ read(27) ibelm_moho_bot
+ read(27) ijk_moho_top
+ read(27) ijk_moho_bot
+
+ close(27)
+
+ ! normals
+ open(unit=27,file=prname(1:len_trim(prname))//'normal_moho.bin',status='old',&
+ form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error: could not open normal_moho '
+ print*,'path: ',prname(1:len_trim(prname))//'normal_moho.bin'
+ call exit_mpi(myrank,'error opening normal_moho')
+ endif
+
+ read(27) normal_moho_top
+ read(27) normal_moho_bot
+ close(27)
+
+ ! flags
+ open(unit=27,file=prname(1:len_trim(prname))//'is_moho.bin',status='old',&
+ form='unformatted',iostat=ier)
+ if( ier /= 0 ) then
+ print*,'error: could not open is_moho '
+ print*,'path: ',prname(1:len_trim(prname))//'is_moho.bin'
+ call exit_mpi(myrank,'error opening is_moho')
+ endif
+
+ read(27) is_moho_top
+ read(27) is_moho_bot
+
+ close(27)
+
+ ! moho kernel
+ allocate( moho_kl(NGLLSQUARE,NSPEC2D_MOHO) )
+ moho_kl = 0._CUSTOM_REAL
+
+ else
+ NSPEC2D_MOHO = 1
+ endif
+
+ allocate( dsdx_top(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO), &
+ dsdx_bot(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO), &
+ b_dsdx_top(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO), &
+ b_dsdx_bot(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO) )
+ endif
+
+ end subroutine read_mesh_databases_adjoint
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_moho_map.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_moho_map.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_moho_map.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,60 @@
+!=====================================================================
+!
+! 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 read_moho_map(imoho_depth)
+!
+!---- read Lupei Zhu's Moho map of Southern California once and for all
+!
+ implicit none
+
+ include "constants.h"
+
+! use integer array to store Moho depth
+ integer imoho_depth(NX_MOHO,NY_MOHO)
+
+ integer ix,iy
+
+ double precision long,lat,depth_km
+
+ character(len=256) MOHO_MAP_FILE
+
+ imoho_depth(:,:) = 0
+
+ call get_value_string(MOHO_MAP_FILE, &
+ 'model.MOHO_MAP_FILE', &
+ 'DATA/moho_map/moho_lupei_zhu.dat')
+ open(unit=13,file=MOHO_MAP_FILE,status='old',action='read')
+! file starts from North-West corner
+ do iy=NY_MOHO,1,-1
+ do ix=1,NX_MOHO
+ read(13,*) long,lat,depth_km
+! convert depth to meters
+ imoho_depth(ix,iy) = nint(depth_km * 1000.d0)
+ enddo
+ enddo
+ close(13)
+
+ end subroutine read_moho_map
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_parameter_file.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_parameter_file.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_parameter_file.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,178 @@
+!=====================================================================
+!
+! 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 read_parameter_file( NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ ATTENUATION,USE_OLSEN_ATTENUATION,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, &
+ SIMULATION_TYPE,SAVE_FORWARD )
+
+ implicit none
+
+ include "constants.h"
+
+ integer NPROC,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,SIMULATION_TYPE
+ integer NSOURCES,NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO,UTM_PROJECTION_ZONE
+
+ double precision DT,HDUR_MOVIE
+
+ logical ATTENUATION,USE_OLSEN_ATTENUATION,OCEANS,ABSORBING_CONDITIONS,SAVE_FORWARD
+ logical MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT,USE_HIGHRES_FOR_MOVIES
+ logical ANISOTROPY,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION,SUPPRESS_UTM_PROJECTION
+
+ character(len=256) LOCAL_PATH,CMTSOLUTION
+
+! local variables
+ integer ::ios,icounter,isource,idummy,nproc_eta_old,nproc_xi_old
+ double precision :: hdur,minval_hdur
+ character(len=256) :: dummystring
+ integer, external :: err_occurred
+
+ ! opens file DATA/Par_file
+ call open_parameter_file()
+
+ ! reads in parameters
+ call read_value_integer(SIMULATION_TYPE, 'solver.SIMULATION_TYPE')
+ if(err_occurred() /= 0) return
+ call read_value_logical(SAVE_FORWARD, 'solver.SAVE_FORWARD')
+ if(err_occurred() /= 0) return
+ call read_value_integer(UTM_PROJECTION_ZONE, 'mesher.UTM_PROJECTION_ZONE')
+ if(err_occurred() /= 0) return
+ call read_value_logical(SUPPRESS_UTM_PROJECTION, 'mesher.SUPPRESS_UTM_PROJECTION')
+ if(err_occurred() /= 0) return
+ ! total number of processors
+ call read_value_integer(NPROC, 'mesher.NPROC')
+ if(err_occurred() /= 0) then
+ ! checks if it's using an old Par_file format
+ call read_value_integer(nproc_eta_old, 'mesher.NPROC_ETA')
+ if( err_occurred() /= 0 ) then
+ print*,'please specify the number of processes in Par_file as:'
+ print*,'NPROC = <my_number_of_desired_processes> '
+ return
+ endif
+ ! checks if it's using an old Par_file format
+ call read_value_integer(nproc_xi_old, 'mesher.NPROC_XI')
+ if( err_occurred() /= 0 ) then
+ print*,'please specify the number of processes in Par_file as:'
+ print*,'NPROC = <my_number_of_desired_processes> '
+ return
+ endif
+ NPROC = nproc_eta_old * nproc_xi_old
+ endif
+ call read_value_integer(NSTEP, 'solver.NSTEP')
+ if(err_occurred() /= 0) return
+ call read_value_double_precision(DT, 'solver.DT')
+ if(err_occurred() /= 0) return
+ call read_value_logical(OCEANS, 'model.OCEANS')
+ if(err_occurred() /= 0) return
+ call read_value_logical(ATTENUATION, 'model.ATTENUATION')
+ if(err_occurred() /= 0) return
+ call read_value_logical(USE_OLSEN_ATTENUATION, 'model.USE_OLSEN_ATTENUATION')
+ if(err_occurred() /= 0) return
+ call read_value_logical(ANISOTROPY, 'model.ANISOTROPY')
+ if(err_occurred() /= 0) return
+ call read_value_logical(ABSORBING_CONDITIONS, 'solver.ABSORBING_CONDITIONS')
+ if(err_occurred() /= 0) return
+ call read_value_logical(MOVIE_SURFACE, 'solver.MOVIE_SURFACE')
+ if(err_occurred() /= 0) return
+ call read_value_logical(MOVIE_VOLUME, 'solver.MOVIE_VOLUME')
+ if(err_occurred() /= 0) return
+ call read_value_integer(NTSTEP_BETWEEN_FRAMES, 'solver.NTSTEP_BETWEEN_FRAMES')
+ if(err_occurred() /= 0) return
+ call read_value_logical(CREATE_SHAKEMAP, 'solver.CREATE_SHAKEMAP')
+ if(err_occurred() /= 0) return
+ call read_value_logical(SAVE_DISPLACEMENT, 'solver.SAVE_DISPLACEMENT')
+ if(err_occurred() /= 0) return
+ call read_value_logical(USE_HIGHRES_FOR_MOVIES, 'solver.USE_HIGHRES_FOR_MOVIES')
+ if(err_occurred() /= 0) return
+ call read_value_double_precision(HDUR_MOVIE, 'solver.HDUR_MOVIE')
+ if(err_occurred() /= 0) return
+ call read_value_logical(SAVE_MESH_FILES, 'mesher.SAVE_MESH_FILES')
+ if(err_occurred() /= 0) return
+ call read_value_string(LOCAL_PATH, 'LOCAL_PATH')
+ if(err_occurred() /= 0) return
+ call read_value_integer(NTSTEP_BETWEEN_OUTPUT_INFO, 'solver.NTSTEP_BETWEEN_OUTPUT_INFO')
+ if(err_occurred() /= 0) return
+ call read_value_integer(NTSTEP_BETWEEN_OUTPUT_SEISMOS, 'solver.NTSTEP_BETWEEN_OUTPUT_SEISMOS')
+ if(err_occurred() /= 0) return
+ call read_value_logical(PRINT_SOURCE_TIME_FUNCTION, 'solver.PRINT_SOURCE_TIME_FUNCTION')
+ if(err_occurred() /= 0) return
+
+
+ ! compute the total number of sources in the CMTSOLUTION file
+ ! there are NLINES_PER_CMTSOLUTION_SOURCE lines per source in that file
+ call get_value_string(CMTSOLUTION, 'solver.CMTSOLUTION', 'DATA/CMTSOLUTION')
+
+ open(unit=1,file=CMTSOLUTION,iostat=ios,status='old',action='read')
+ if(ios /= 0) stop 'error opening CMTSOLUTION file'
+
+ icounter = 0
+ do while(ios == 0)
+ read(1,"(a)",iostat=ios) dummystring
+ if(ios == 0) icounter = icounter + 1
+ enddo
+ close(1)
+
+ if(mod(icounter,NLINES_PER_CMTSOLUTION_SOURCE) /= 0) &
+ stop 'total number of lines in CMTSOLUTION file should be a multiple of NLINES_PER_CMTSOLUTION_SOURCE'
+
+ NSOURCES = icounter / NLINES_PER_CMTSOLUTION_SOURCE
+ if(NSOURCES < 1) stop 'need at least one source in CMTSOLUTION file'
+
+ ! compute the minimum value of hdur in CMTSOLUTION file
+ open(unit=1,file=CMTSOLUTION,status='old',action='read')
+ minval_hdur = HUGEVAL
+ do isource = 1,NSOURCES
+
+ ! skip other information
+ do idummy = 1,3
+ read(1,"(a)") dummystring
+ enddo
+
+ ! read half duration and compute minimum
+ read(1,"(a)") dummystring
+ read(dummystring(15:len_trim(dummystring)),*) hdur
+ minval_hdur = min(minval_hdur,hdur)
+
+ ! skip other information
+ do idummy = 1,9
+ read(1,"(a)") dummystring
+ enddo
+
+ enddo
+ close(1)
+
+! one cannot use a Heaviside source for the movies
+ if((MOVIE_SURFACE .or. MOVIE_VOLUME) .and. sqrt(minval_hdur**2 + HDUR_MOVIE**2) < TINYVAL) &
+ stop 'hdur too small for movie creation, movies do not make sense for Heaviside source'
+
+! close parameter file
+ call close_parameter_file()
+
+ end subroutine read_parameter_file
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_topo_bathy_file.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_topo_bathy_file.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_topo_bathy_file.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,54 @@
+!=====================================================================
+!
+! 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 read_topo_bathy_file(itopo_bathy,NX_TOPO,NY_TOPO,topo_file)
+!
+!---- read topography and bathymetry file once and for all
+!
+ implicit none
+
+ include "constants.h"
+
+ integer NX_TOPO,NY_TOPO
+
+! use integer array to store topography values
+ integer itopo_bathy(NX_TOPO,NY_TOPO)
+
+ character(len=100) topo_file
+
+ integer ix,iy
+
+ itopo_bathy(:,:) = 0
+
+ open(unit=13,file=topo_file,status='old',action='read')
+ do iy=1,NY_TOPO
+ do ix=1,NX_TOPO
+ read(13,*) itopo_bathy(ix,iy)
+ enddo
+ enddo
+ close(13)
+
+ end subroutine read_topo_bathy_file
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_topography_bathymetry.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_topography_bathymetry.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_topography_bathymetry.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,63 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+ subroutine read_topography_bathymetry()
+
+ use specfem_par
+ implicit none
+
+! read topography and bathymetry file
+
+! if(TOPOGRAPHY .or. OCEANS) then
+ if(OCEANS) then
+
+ NX_TOPO = NX_TOPO_SOCAL
+ NY_TOPO = NY_TOPO_SOCAL
+ ORIG_LAT_TOPO = ORIG_LAT_TOPO_SOCAL
+ ORIG_LONG_TOPO = ORIG_LONG_TOPO_SOCAL
+ DEGREES_PER_CELL_TOPO = DEGREES_PER_CELL_TOPO_SOCAL
+ topo_file = TOPO_FILE_SOCAL
+
+ allocate(itopo_bathy(NX_TOPO,NY_TOPO))
+
+ call read_topo_bathy_file(itopo_bathy,NX_TOPO,NY_TOPO,topo_file)
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'regional topography file read ranges in m from ', &
+ minval(itopo_bathy),' to ',maxval(itopo_bathy)
+ write(IMAIN,*)
+ endif
+
+ else
+ NX_TOPO = 1
+ NY_TOPO = 1
+ allocate(itopo_bathy(NX_TOPO,NY_TOPO))
+
+ endif
+
+ end subroutine read_topography_bathymetry
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_value_parameters.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_value_parameters.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/read_value_parameters.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,288 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! read values from parameter file, ignoring white lines and comments
+
+ subroutine read_value_integer(value_to_read, name)
+
+ implicit none
+
+ integer value_to_read
+ character(len=*) name
+ character(len=100) string_read
+ integer ierr
+ common /param_err_common/ ierr
+
+ call param_read(string_read, len(string_read), name, len(name), ierr);
+ if (ierr .ne. 0) return
+ read(string_read,*) value_to_read
+
+ end subroutine read_value_integer
+
+!--------------------
+
+ subroutine read_value_double_precision(value_to_read, name)
+
+ implicit none
+
+ double precision value_to_read
+ character(len=*) name
+ character(len=100) string_read
+ integer ierr
+ common /param_err_common/ ierr
+
+ call param_read(string_read, len(string_read), name, len(name), ierr);
+ if (ierr .ne. 0) return
+ read(string_read,*) value_to_read
+
+ end subroutine read_value_double_precision
+
+!--------------------
+
+ subroutine read_value_logical(value_to_read, name)
+
+ implicit none
+
+ logical value_to_read
+ character(len=*) name
+ character(len=100) string_read
+ integer ierr
+ common /param_err_common/ ierr
+
+ call param_read(string_read, len(string_read), name, len(name), ierr);
+ if (ierr .ne. 0) return
+ read(string_read,*) value_to_read
+
+ end subroutine read_value_logical
+
+!--------------------
+
+ subroutine read_value_string(value_to_read, name)
+
+ implicit none
+
+ character(len=*) value_to_read
+ character(len=*) name
+ character(len=100) string_read
+ integer ierr
+ common /param_err_common/ ierr
+
+ call param_read(string_read, len(string_read), name, len(name), ierr);
+ if (ierr .ne. 0) return
+ value_to_read = string_read
+
+ end subroutine read_value_string
+
+!--------------------
+
+ subroutine open_parameter_file()
+
+ integer ierr
+ common /param_err_common/ ierr
+ character(len=50) filename
+ filename = 'DATA/Par_file'
+
+ call param_open(filename, len(filename), ierr);
+ if (ierr .ne. 0) return
+
+ end subroutine open_parameter_file
+
+!--------------------
+
+ subroutine close_parameter_file()
+
+ call param_close();
+
+ end subroutine close_parameter_file
+
+!--------------------
+
+ integer function err_occurred()
+
+ integer ierr
+ common /param_err_common/ ierr
+
+ err_occurred = ierr
+
+ end function err_occurred
+
+!--------------------
+
+
+!
+! unused routines:
+!
+
+
+! subroutine read_value_integer(value_to_read, name)
+!
+! implicit none
+!
+! integer value_to_read
+! character(len=*) name
+! character(len=256) string_read
+!
+! call unused_string(name)
+!
+! call read_next_line(string_read)
+! read(string_read,*) value_to_read
+!
+! end subroutine read_value_integer
+!
+!!--------------------
+!
+! subroutine read_value_double_precision(value_to_read, name)
+!
+! implicit none
+!
+! double precision value_to_read
+! character(len=*) name
+! character(len=256) string_read
+!
+! call unused_string(name)
+!
+! call read_next_line(string_read)
+! read(string_read,*) value_to_read
+!
+! end subroutine read_value_double_precision
+!
+!!--------------------
+!
+! subroutine read_value_logical(value_to_read, name)
+!
+! implicit none
+!
+! logical value_to_read
+! character(len=*) name
+! character(len=256) string_read
+!
+! call unused_string(name)
+!
+! call read_next_line(string_read)
+! read(string_read,*) value_to_read
+!
+! end subroutine read_value_logical
+!
+!!--------------------
+!
+! subroutine read_value_string(value_to_read, name)
+!
+! implicit none
+!
+! character(len=*) value_to_read
+! character(len=*) name
+! character(len=256) string_read
+!
+! call unused_string(name)
+!
+! call read_next_line(string_read)
+! value_to_read = string_read
+!
+! end subroutine read_value_string
+!
+!!--------------------
+!
+! subroutine read_next_line(string_read)
+!
+! implicit none
+!
+! include "constants.h"
+!
+! character(len=256) string_read
+!
+! integer index_equal_sign,ios
+!
+! do
+! read(unit=IIN,fmt="(a256)",iostat=ios) string_read
+! if(ios /= 0) stop 'error while reading parameter file'
+!
+!! suppress leading white spaces, if any
+! string_read = adjustl(string_read)
+!
+!! suppress trailing carriage return (ASCII code 13) if any (e.g. if input text file coming from Windows/DOS)
+! if(index(string_read,achar(13)) > 0) string_read = string_read(1:index(string_read,achar(13))-1)
+!
+!! exit loop when we find the first line that is not a comment or a white line
+! if(len_trim(string_read) == 0) cycle
+! if(string_read(1:1) /= '#') exit
+!
+! enddo
+!
+!! suppress trailing white spaces, if any
+! string_read = string_read(1:len_trim(string_read))
+!
+!! suppress trailing comments, if any
+! if(index(string_read,'#') > 0) string_read = string_read(1:index(string_read,'#')-1)
+!
+!! suppress leading junk (up to the first equal sign, included)
+! index_equal_sign = index(string_read,'=')
+! if(index_equal_sign <= 1 .or. index_equal_sign == len_trim(string_read)) stop 'incorrect syntax detected in DATA/Par_file'
+! string_read = string_read(index_equal_sign + 1:len_trim(string_read))
+!
+!! suppress leading and trailing white spaces again, if any, after having suppressed the leading junk
+! string_read = adjustl(string_read)
+! string_read = string_read(1:len_trim(string_read))
+!
+! end subroutine read_next_line
+!
+!!--------------------
+!
+! subroutine open_parameter_file
+!
+! include "constants.h"
+!
+! open(unit=IIN,file='DATA/Par_file',status='old',action='read')
+!
+! end subroutine open_parameter_file
+!
+!!--------------------
+!
+! subroutine close_parameter_file
+!
+! include "constants.h"
+!
+! close(IIN)
+!
+! end subroutine close_parameter_file
+!
+!!--------------------
+!
+! integer function err_occurred()
+!
+! err_occurred = 0
+!
+! end function err_occurred
+!
+!!--------------------
+!
+!! dummy subroutine to avoid warnings about variable not used in other subroutines
+! subroutine unused_string(s)
+!
+! character(len=*) s
+!
+! if (len(s) == 1) continue
+!
+! end subroutine unused_string
+!
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/recompute_jacobian.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/recompute_jacobian.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/recompute_jacobian.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,157 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! recompute 3D jacobian at a given point for a 8-node element
+
+ subroutine recompute_jacobian(xelm,yelm,zelm,xi,eta,gamma,x,y,z, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision x,y,z,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz
+ double precision xi,eta,gamma,jacobian
+
+! coordinates of the control points
+ double precision xelm(NGNOD),yelm(NGNOD),zelm(NGNOD)
+
+! 3D shape functions and their derivatives at receiver
+ double precision shape3D(NGNOD)
+ double precision dershape3D(NDIM,NGNOD)
+
+ double precision xxi,yxi,zxi
+ double precision xeta,yeta,zeta
+ double precision xgamma,ygamma,zgamma
+ double precision ra1,ra2,rb1,rb2,rc1,rc2
+
+ integer ia
+
+! for 8-node element
+ double precision, parameter :: ONE_EIGHTH = 0.125d0
+
+! recompute jacobian for any (xi,eta,gamma) point, not necessarily a GLL point
+
+! check that the parameter file is correct
+ if(NGNOD /= 8) stop 'elements should have 8 control nodes'
+
+! ***
+! *** create the 3D shape functions and the Jacobian for an 8-node element
+! ***
+
+!--- case of an 8-node 3D element (Dhatt-Touzot p. 115)
+
+ ra1 = one + xi
+ ra2 = one - xi
+
+ rb1 = one + eta
+ rb2 = one - eta
+
+ rc1 = one + gamma
+ rc2 = one - gamma
+
+ shape3D(1) = ONE_EIGHTH*ra2*rb2*rc2
+ shape3D(2) = ONE_EIGHTH*ra1*rb2*rc2
+ shape3D(3) = ONE_EIGHTH*ra1*rb1*rc2
+ shape3D(4) = ONE_EIGHTH*ra2*rb1*rc2
+ shape3D(5) = ONE_EIGHTH*ra2*rb2*rc1
+ shape3D(6) = ONE_EIGHTH*ra1*rb2*rc1
+ shape3D(7) = ONE_EIGHTH*ra1*rb1*rc1
+ shape3D(8) = ONE_EIGHTH*ra2*rb1*rc1
+
+ dershape3D(1,1) = - ONE_EIGHTH*rb2*rc2
+ dershape3D(1,2) = ONE_EIGHTH*rb2*rc2
+ dershape3D(1,3) = ONE_EIGHTH*rb1*rc2
+ dershape3D(1,4) = - ONE_EIGHTH*rb1*rc2
+ dershape3D(1,5) = - ONE_EIGHTH*rb2*rc1
+ dershape3D(1,6) = ONE_EIGHTH*rb2*rc1
+ dershape3D(1,7) = ONE_EIGHTH*rb1*rc1
+ dershape3D(1,8) = - ONE_EIGHTH*rb1*rc1
+
+ dershape3D(2,1) = - ONE_EIGHTH*ra2*rc2
+ dershape3D(2,2) = - ONE_EIGHTH*ra1*rc2
+ dershape3D(2,3) = ONE_EIGHTH*ra1*rc2
+ dershape3D(2,4) = ONE_EIGHTH*ra2*rc2
+ dershape3D(2,5) = - ONE_EIGHTH*ra2*rc1
+ dershape3D(2,6) = - ONE_EIGHTH*ra1*rc1
+ dershape3D(2,7) = ONE_EIGHTH*ra1*rc1
+ dershape3D(2,8) = ONE_EIGHTH*ra2*rc1
+
+ dershape3D(3,1) = - ONE_EIGHTH*ra2*rb2
+ dershape3D(3,2) = - ONE_EIGHTH*ra1*rb2
+ dershape3D(3,3) = - ONE_EIGHTH*ra1*rb1
+ dershape3D(3,4) = - ONE_EIGHTH*ra2*rb1
+ dershape3D(3,5) = ONE_EIGHTH*ra2*rb2
+ dershape3D(3,6) = ONE_EIGHTH*ra1*rb2
+ dershape3D(3,7) = ONE_EIGHTH*ra1*rb1
+ dershape3D(3,8) = ONE_EIGHTH*ra2*rb1
+
+! compute coordinates and jacobian matrix
+ x=ZERO
+ y=ZERO
+ z=ZERO
+ xxi=ZERO
+ xeta=ZERO
+ xgamma=ZERO
+ yxi=ZERO
+ yeta=ZERO
+ ygamma=ZERO
+ zxi=ZERO
+ zeta=ZERO
+ zgamma=ZERO
+
+ do ia=1,NGNOD
+ x=x+shape3D(ia)*xelm(ia)
+ y=y+shape3D(ia)*yelm(ia)
+ z=z+shape3D(ia)*zelm(ia)
+
+ xxi=xxi+dershape3D(1,ia)*xelm(ia)
+ xeta=xeta+dershape3D(2,ia)*xelm(ia)
+ xgamma=xgamma+dershape3D(3,ia)*xelm(ia)
+ yxi=yxi+dershape3D(1,ia)*yelm(ia)
+ yeta=yeta+dershape3D(2,ia)*yelm(ia)
+ ygamma=ygamma+dershape3D(3,ia)*yelm(ia)
+ zxi=zxi+dershape3D(1,ia)*zelm(ia)
+ zeta=zeta+dershape3D(2,ia)*zelm(ia)
+ zgamma=zgamma+dershape3D(3,ia)*zelm(ia)
+ enddo
+
+ jacobian = xxi*(yeta*zgamma-ygamma*zeta) - xeta*(yxi*zgamma-ygamma*zxi) + xgamma*(yxi*zeta-yeta*zxi)
+
+ if(jacobian <= ZERO) stop '3D Jacobian undefined'
+
+! 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
+
+ end subroutine recompute_jacobian
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/salton_trough_gocad.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/salton_trough_gocad.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/salton_trough_gocad.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,168 @@
+!=====================================================================
+!
+! 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 read_salton_sea_model(vp_array)
+
+ implicit none
+
+ include 'constants.h'
+ include 'constants_gocad.h'
+
+ real :: vp_array(GOCAD_ST_NU,GOCAD_ST_NV,GOCAD_ST_NW)
+ integer :: ios, reclen
+
+ character(len=256) SALTON_SEA_MODEL_FILE
+
+ reclen=(GOCAD_ST_NU * GOCAD_ST_NV * GOCAD_ST_NW) * 4
+ call get_value_string(SALTON_SEA_MODEL_FILE, &
+ 'model.SALTON_SEA_MODEL_FILE', &
+ 'DATA/st_3D_block_harvard/regrid3_vel_p.bin')
+ open(11,file=SALTON_SEA_MODEL_FILE,status='old',action='read',form='unformatted',access='direct',recl=reclen,iostat=ios)
+ if (ios /= 0) then
+ print *, 'iostat = ', ios
+ stop 'Error opening file'
+ endif
+ read(11,rec=1,iostat=ios) vp_array
+ if (ios /= 0) stop 'Error reading vp_array'
+ close(11)
+
+end subroutine read_salton_sea_model
+
+
+subroutine vx_xyz2uvw(xmesh, ymesh, zmesh, uc, vc, wc)
+
+
+ implicit none
+ include 'constants.h'
+
+ double precision :: xmesh, ymesh, zmesh, uc, vc, wc
+
+ uc = (GOCAD_ST_NU-1) * ((xmesh - GOCAD_ST_O_X) * GOCAD_ST_V_Y - (ymesh - GOCAD_ST_O_Y) * GOCAD_ST_V_X) &
+ / (GOCAD_ST_U_X * GOCAD_ST_V_Y - GOCAD_ST_U_Y * GOCAD_ST_V_X)
+ vc = (GOCAD_ST_NV-1) * ((ymesh - GOCAD_ST_O_Y) - uc * GOCAD_ST_U_Y/(GOCAD_ST_NU-1) ) / GOCAD_ST_V_Y
+ wc = (GOCAD_ST_NW-1) * (zmesh - GOCAD_ST_O_Z) / GOCAD_ST_W_Z
+
+end subroutine vx_xyz2uvw
+
+
+subroutine vx_xyz_interp(uc,vc,wc, vp, vs, rho, vp_array)
+
+ implicit none
+ include 'constants.h'
+
+ double precision :: uc,vc,wc, vp, vs, rho
+ real :: vp_array(GOCAD_ST_NU,GOCAD_ST_NV,GOCAD_ST_NW)
+
+ integer :: i,j,k,ixi,ieta,iga
+ real :: v1, v2, v3, v4, v5, v6, v7, v8, xi, eta, ga, vi
+ double precision :: zmesh
+ real,parameter :: eps = 1.0e-3
+
+
+ i = uc + 1
+ j = vc + 1
+ k = wc + 1
+
+ xi = uc + 1 - i
+ eta = vc + 1- j
+ ga = wc + 1 -k
+
+ ixi = nint(xi)
+ ieta = nint(eta)
+ iga = nint(ga)
+
+! print *, 'gc = ', i, j, k
+! print *, 'xi, eta, ga = ', xi, eta, ga
+! print *, 'ixi, ieta, iga = ', ixi, ieta, iga
+
+
+ if (i > 0 .or. i < GOCAD_ST_NU .or. j > 0 .or. j < GOCAD_ST_NV .or. k > 0 .or. k < GOCAD_ST_NW) then
+ v1 = vp_array(i,j,k)
+ v2 = vp_array(i+1,j,k)
+ v3 = vp_array(i+1,j+1,k)
+ v4 = vp_array(i,j+1,k)
+ v5 = vp_array(i,j,k+1)
+ v6 = vp_array(i+1,j,k+1)
+ v7 = vp_array(i+1,j+1,k+1)
+ v8 = vp_array(i,j+1,k+1)
+ vi = vp_array(i+ixi,j+ieta,k+iga)
+! print *, v1, v2, v3, v4, v5, v6, v7, v8
+ if ((v1 - GOCAD_ST_NO_DATA_VALUE) > eps .and. &
+ (v2 - GOCAD_ST_NO_DATA_VALUE) > eps .and. &
+ (v3 - GOCAD_ST_NO_DATA_VALUE) > eps .and. &
+ (v4 - GOCAD_ST_NO_DATA_VALUE) > eps .and. &
+ (v5 - GOCAD_ST_NO_DATA_VALUE) > eps .and. &
+ (v6 - GOCAD_ST_NO_DATA_VALUE) > eps .and. &
+ (v7 - GOCAD_ST_NO_DATA_VALUE) > eps .and. &
+ (v8 - GOCAD_ST_NO_DATA_VALUE) > eps ) then
+ vp = dble(&
+ v1 * (1-xi) * (1-eta) * (1-ga) +&
+ v2 * xi * (1-eta) * (1-ga) +&
+ v3 * xi * eta * (1-ga) +&
+ v4 * (1-xi) * eta * (1-ga) +&
+ v5 * (1-xi) * (1-eta) * ga +&
+ v6 * xi * (1-eta) * ga +&
+ v7 * xi * eta * ga +&
+ v8 * (1-xi) * eta * ga)
+ else if ((vi - GOCAD_ST_NO_DATA_VALUE) > eps) then
+ vp = dble(vi)
+! else if ((v1 - GOCAD_ST_NO_DATA_VALUE) > eps) then
+! vp = dble(v1)
+! else if ((v2 - GOCAD_ST_NO_DATA_VALUE) > eps) then
+! vp = dble(v2)
+! else if ((v3 - GOCAD_ST_NO_DATA_VALUE) > eps) then
+! vp = dble(v3)
+! else if ((v4 - GOCAD_ST_NO_DATA_VALUE) > eps) then
+! vp = dble(v4)
+! else if ((v5 - GOCAD_ST_NO_DATA_VALUE) > eps) then
+! vp = dble(v5)
+! else if ((v6 - GOCAD_ST_NO_DATA_VALUE) > eps) then
+! vp = dble(v6)
+! else if ((v7 - GOCAD_ST_NO_DATA_VALUE) > eps) then
+! vp = dble(v7)
+! else if ((v7 - GOCAD_ST_NO_DATA_VALUE) > eps) then
+! vp = dble(v8)
+ else
+ vp = GOCAD_ST_NO_DATA_VALUE
+ endif
+ zmesh = wc / (GOCAD_ST_NW - 1) * GOCAD_ST_W_Z + GOCAD_ST_O_Z
+ if (zmesh > -8500.) then
+ vs = vp / (2 - (0.27*zmesh/(-8500)))
+ else
+ vs = vp/1.73
+ endif
+ if (vp > 2160.) then
+ rho = vp/3 + 1280.
+ else
+ rho = 2000.
+ endif
+ else
+ rho = GOCAD_ST_NO_DATA_VALUE
+ vp = GOCAD_ST_NO_DATA_VALUE
+ vs = GOCAD_ST_NO_DATA_VALUE
+ endif
+
+end subroutine vx_xyz_interp
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/save_adjoint_kernels.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/save_adjoint_kernels.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/save_adjoint_kernels.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,145 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+ subroutine save_adjoint_kernels()
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+
+ implicit none
+ integer:: ispec,i,j,k,iglob
+
+ ! finalizes calculation of rhop, beta, alpha kernels
+ do ispec = 1, NSPEC_AB
+
+ ! elastic simulations
+ if( ispec_is_elastic(ispec) ) then
+
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+
+ ! isotropic adjoint kernels (see e.g. Tromp et al. 2005)
+
+ ! density kernel
+ ! multiplies with rho
+ rho_kl(i,j,k,ispec) = - rho_vs(i,j,k,ispec)**2 / mustore(i,j,k,ispec) * rho_kl(i,j,k,ispec)
+
+ ! shear modulus kernel
+ mu_kl(i,j,k,ispec) = - mustore(i,j,k,ispec) * mu_kl(i,j,k,ispec)
+
+ ! bulk modulus kernel
+ kappa_kl(i,j,k,ispec) = - kappastore(i,j,k,ispec) * kappa_kl(i,j,k,ispec)
+
+ ! density prime kernel
+ rhop_kl(i,j,k,ispec) = rho_kl(i,j,k,ispec) + kappa_kl(i,j,k,ispec) + mu_kl(i,j,k,ispec)
+
+ ! vs kernel
+ beta_kl(i,j,k,ispec) = 2._CUSTOM_REAL * (mu_kl(i,j,k,ispec) &
+ - 4._CUSTOM_REAL * mustore(i,j,k,ispec) &
+ / (3._CUSTOM_REAL * kappastore(i,j,k,ispec)) * kappa_kl(i,j,k,ispec))
+
+ ! vp kernel
+ alpha_kl(i,j,k,ispec) = 2._CUSTOM_REAL * (1._CUSTOM_REAL &
+ + 4._CUSTOM_REAL * mustore(i,j,k,ispec) &
+ / (3._CUSTOM_REAL * kappastore(i,j,k,ispec))) * kappa_kl(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+
+ endif ! elastic
+
+ ! acoustic simulations
+ if( ispec_is_acoustic(ispec) ) then
+
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ ! rho prime kernel
+ rhop_ac_kl(i,j,k,ispec) = rho_ac_kl(i,j,k,ispec) + kappa_ac_kl(i,j,k,ispec)
+
+ ! vp kernel
+ alpha_ac_kl(i,j,k,ispec) = TWO * kappa_ac_kl(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+
+ endif ! acoustic
+
+
+ enddo
+
+ ! save kernels to binary files
+ if( ELASTIC_SIMULATION ) then
+ open(unit=27,file=prname(1:len_trim(prname))//'rho_kernel.bin',status='unknown',form='unformatted')
+ write(27) rho_kl
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'mu_kernel.bin',status='unknown',form='unformatted')
+ write(27) mu_kl
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'kappa_kernel.bin',status='unknown',form='unformatted')
+ write(27) kappa_kl
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'rhop_kernel.bin',status='unknown',form='unformatted')
+ write(27) rhop_kl
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'beta_kernel.bin',status='unknown',form='unformatted')
+ write(27) beta_kl
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'alpha_kernel.bin',status='unknown',form='unformatted')
+ write(27) alpha_kl
+ close(27)
+
+ if (SAVE_MOHO_MESH) then
+ open(unit=27,file=prname(1:len_trim(prname))//'moho_kernel.bin',status='unknown',form='unformatted')
+ write(27) moho_kl
+ close(27)
+ endif
+
+ endif
+
+
+ ! save kernels to binary files
+ if( ACOUSTIC_SIMULATION ) then
+ open(unit=27,file=prname(1:len_trim(prname))//'rho_acoustic_kernel.bin',status='unknown',form='unformatted')
+ write(27) rho_ac_kl
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'kappa_acoustic_kernel.bin',status='unknown',form='unformatted')
+ write(27) kappa_ac_kl
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'rho_prime_acoustic_kernel.bin',status='unknown',form='unformatted')
+ write(27) rhop_ac_kl
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'alpha_acoustic_kernel.bin',status='unknown',form='unformatted')
+ write(27) alpha_ac_kl
+ close(27)
+
+ endif
+
+ end subroutine save_adjoint_kernels
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/save_arrays_solver.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/save_arrays_solver.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/save_arrays_solver.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,865 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+
+! for external mesh
+
+ 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, &
+ rhostore,kappastore,mustore, &
+ rmass,rmass_acoustic,rmass_solid_poroelastic,rmass_fluid_poroelastic, &
+ OCEANS,rmass_ocean_load,NGLOB_OCEAN,&
+ ibool, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ abs_boundary_normal,abs_boundary_jacobian2Dw, &
+ abs_boundary_ijk,abs_boundary_ispec, &
+ num_abs_boundary_faces, &
+ free_surface_normal,free_surface_jacobian2Dw, &
+ free_surface_ijk,free_surface_ispec, &
+ num_free_surface_faces, &
+ coupling_ac_el_normal,coupling_ac_el_jacobian2Dw, &
+ coupling_ac_el_ijk,coupling_ac_el_ispec, &
+ num_coupling_ac_el_faces, &
+ num_interfaces_ext_mesh,my_neighbours_ext_mesh,nibool_interfaces_ext_mesh, &
+ max_interface_size_ext_mesh,ibool_interfaces_ext_mesh, &
+ prname,SAVE_MESH_FILES, &
+ ANISOTROPY,NSPEC_ANISO, &
+ c11store,c12store,c13store,c14store,c15store,c16store, &
+ c22store,c23store,c24store,c25store,c26store,c33store, &
+ c34store,c35store,c36store,c44store,c45store,c46store, &
+ c55store,c56store,c66store, &
+ ispec_is_acoustic,ispec_is_elastic,ispec_is_poroelastic)
+
+ implicit none
+
+ 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
+
+! material
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: rhostore,kappastore,mustore
+ real(kind=CUSTOM_REAL), dimension(nglob) :: rmass,rmass_acoustic, &
+ rmass_solid_poroelastic,rmass_fluid_poroelastic
+! ocean load
+ logical :: OCEANS
+ integer :: NGLOB_OCEAN
+ real(kind=CUSTOM_REAL),dimension(NGLOB_OCEAN) :: rmass_ocean_load
+
+! mesh coordinates
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
+
+! absorbing boundary surface
+ integer :: num_abs_boundary_faces
+ real(kind=CUSTOM_REAL) :: abs_boundary_normal(NDIM,NGLLSQUARE,num_abs_boundary_faces)
+ real(kind=CUSTOM_REAL) :: abs_boundary_jacobian2Dw(NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ijk(3,NGLLSQUARE,num_abs_boundary_faces)
+ integer :: abs_boundary_ispec(num_abs_boundary_faces)
+
+! free surface
+ integer :: num_free_surface_faces
+ real(kind=CUSTOM_REAL) :: free_surface_normal(NDIM,NGLLSQUARE,num_free_surface_faces)
+ real(kind=CUSTOM_REAL) :: free_surface_jacobian2Dw(NGLLSQUARE,num_free_surface_faces)
+ integer :: free_surface_ijk(3,NGLLSQUARE,num_free_surface_faces)
+ integer :: free_surface_ispec(num_free_surface_faces)
+
+! acoustic-elastic coupling surface
+ integer :: num_coupling_ac_el_faces
+ real(kind=CUSTOM_REAL) :: coupling_ac_el_normal(NDIM,NGLLSQUARE,num_coupling_ac_el_faces)
+ real(kind=CUSTOM_REAL) :: coupling_ac_el_jacobian2Dw(NGLLSQUARE,num_coupling_ac_el_faces)
+ integer :: coupling_ac_el_ijk(3,NGLLSQUARE,num_coupling_ac_el_faces)
+ integer :: coupling_ac_el_ispec(num_coupling_ac_el_faces)
+
+! MPI interfaces
+ integer :: num_interfaces_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: my_neighbours_ext_mesh
+ integer, dimension(num_interfaces_ext_mesh) :: nibool_interfaces_ext_mesh
+ integer :: max_interface_size_ext_mesh
+ integer, dimension(NGLLX*NGLLX*max_interface_size_ext_mesh,num_interfaces_ext_mesh) :: ibool_interfaces_ext_mesh
+
+! file name
+ character(len=256) prname
+ logical :: SAVE_MESH_FILES
+
+! anisotropy
+ logical :: ANISOTROPY
+ integer :: NSPEC_ANISO
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ANISO) :: &
+ c11store,c12store,c13store,c14store,c15store,c16store, &
+ c22store,c23store,c24store,c25store,c26store,c33store, &
+ c34store,c35store,c36store,c44store,c45store,c46store, &
+ c55store,c56store,c66store
+
+! material domain flags
+ logical, dimension(nspec) :: ispec_is_acoustic,ispec_is_elastic,ispec_is_poroelastic
+
+! local parameters
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: v_tmp
+ integer,dimension(:),allocatable :: v_tmp_i
+
+ !real(kind=CUSTOM_REAL) :: minimum(1)
+ integer, dimension(:,:), allocatable :: ibool_interfaces_ext_mesh_dummy
+ integer :: ier,i
+ logical :: ACOUSTIC_SIMULATION,ELASTIC_SIMULATION,POROELASTIC_SIMULATION
+ character(len=256) :: filename
+
+ integer, dimension(:), allocatable :: iglob_tmp
+ integer :: j,inum
+
+! saves mesh file proc***_external_mesh.bin
+ filename = prname(1:len_trim(prname))//'external_mesh.bin'
+ open(unit=IOUT,file=trim(filename),status='unknown',action='write',form='unformatted',iostat=ier)
+ if( ier /= 0 ) stop 'error opening database proc######_external_mesh.bin'
+
+ write(IOUT) nspec
+ write(IOUT) nglob
+
+ write(IOUT) ibool
+
+ write(IOUT) xstore_dummy
+ write(IOUT) ystore_dummy
+ write(IOUT) zstore_dummy
+
+ write(IOUT) xixstore
+ write(IOUT) xiystore
+ write(IOUT) xizstore
+ write(IOUT) etaxstore
+ write(IOUT) etaystore
+ write(IOUT) etazstore
+ write(IOUT) gammaxstore
+ write(IOUT) gammaystore
+ write(IOUT) gammazstore
+ write(IOUT) jacobianstore
+
+ write(IOUT) kappastore
+ write(IOUT) mustore
+
+ write(IOUT) ispec_is_acoustic
+ write(IOUT) ispec_is_elastic
+ write(IOUT) ispec_is_poroelastic
+
+! acoustic
+! all processes will have acoustic_simulation set if any flag is .true. somewhere
+ call any_all_l( ANY(ispec_is_acoustic), ACOUSTIC_SIMULATION )
+ if( ACOUSTIC_SIMULATION ) then
+ write(IOUT) rmass_acoustic
+ write(IOUT) rhostore
+ endif
+
+! elastic
+ call any_all_l( ANY(ispec_is_elastic), ELASTIC_SIMULATION )
+ if( ELASTIC_SIMULATION ) then
+ write(IOUT) rmass
+ if( OCEANS) then
+ write(IOUT) rmass_ocean_load
+ endif
+ !pll Stacey
+ write(IOUT) rho_vp
+ write(IOUT) rho_vs
+ write(IOUT) iflag_attenuation_store
+ endif
+
+! poroelastic
+ call any_all_l( ANY(ispec_is_poroelastic), POROELASTIC_SIMULATION )
+ if( POROELASTIC_SIMULATION ) then
+ write(IOUT) rmass_solid_poroelastic
+ write(IOUT) rmass_fluid_poroelastic
+ endif
+
+! absorbing boundary surface
+ write(IOUT) num_abs_boundary_faces
+ write(IOUT) abs_boundary_ispec
+ write(IOUT) abs_boundary_ijk
+ write(IOUT) abs_boundary_jacobian2Dw
+ write(IOUT) abs_boundary_normal
+
+! free surface
+ write(IOUT) num_free_surface_faces
+ write(IOUT) free_surface_ispec
+ write(IOUT) free_surface_ijk
+ write(IOUT) free_surface_jacobian2Dw
+ write(IOUT) free_surface_normal
+
+! acoustic-elastic coupling surface
+ write(IOUT) num_coupling_ac_el_faces
+ write(IOUT) coupling_ac_el_ispec
+ write(IOUT) coupling_ac_el_ijk
+ write(IOUT) coupling_ac_el_jacobian2Dw
+ write(IOUT) coupling_ac_el_normal
+
+!MPI interfaces
+ write(IOUT) num_interfaces_ext_mesh
+ write(IOUT) maxval(nibool_interfaces_ext_mesh(:))
+ write(IOUT) my_neighbours_ext_mesh
+ write(IOUT) nibool_interfaces_ext_mesh
+
+ allocate(ibool_interfaces_ext_mesh_dummy(maxval(nibool_interfaces_ext_mesh(:)),num_interfaces_ext_mesh),stat=ier)
+ if( ier /= 0 ) stop 'error allocating array'
+
+ do i = 1, num_interfaces_ext_mesh
+ ibool_interfaces_ext_mesh_dummy(:,i) = ibool_interfaces_ext_mesh(1:maxval(nibool_interfaces_ext_mesh(:)),i)
+ enddo
+ write(IOUT) ibool_interfaces_ext_mesh_dummy
+
+! anisotropy
+ if( ANISOTROPY ) then
+ write(IOUT) c11store
+ write(IOUT) c12store
+ write(IOUT) c13store
+ write(IOUT) c14store
+ write(IOUT) c15store
+ write(IOUT) c16store
+ write(IOUT) c22store
+ write(IOUT) c23store
+ write(IOUT) c24store
+ write(IOUT) c25store
+ write(IOUT) c26store
+ write(IOUT) c33store
+ write(IOUT) c34store
+ write(IOUT) c35store
+ write(IOUT) c36store
+ write(IOUT) c44store
+ write(IOUT) c45store
+ write(IOUT) c46store
+ write(IOUT) c55store
+ write(IOUT) c56store
+ write(IOUT) c66store
+ endif
+
+ close(IOUT)
+
+
+! stores arrays in binary files
+ if( SAVE_MESH_FILES ) then
+
+ ! mesh arrays used for example 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
+ close(27)
+
+ !--- y coordinate
+ open(unit=27,file=prname(1:len_trim(prname))//'y.bin',status='unknown',form='unformatted')
+ write(27) ystore_dummy
+ close(27)
+
+ !--- z coordinate
+ open(unit=27,file=prname(1:len_trim(prname))//'z.bin',status='unknown',form='unformatted')
+ write(27) zstore_dummy
+ close(27)
+
+ ! ibool
+ open(unit=27,file=prname(1:len_trim(prname))//'ibool.bin',status='unknown',form='unformatted')
+ write(27) ibool
+ close(27)
+
+ allocate( v_tmp(NGLLX,NGLLY,NGLLZ,nspec), stat=ier); if( ier /= 0 ) stop 'error allocating array '
+
+ ! vp (for checking the mesh and model)
+ !minimum = minval( abs(rho_vp) )
+ !if( minimum(1) /= 0.0 ) then
+ ! v_tmp = (FOUR_THIRDS * mustore + kappastore) / rho_vp
+ !else
+ ! v_tmp = 0.0
+ !endif
+ v_tmp = 0.0
+ where( rho_vp /= 0._CUSTOM_REAL ) v_tmp = (FOUR_THIRDS * mustore + kappastore) / rho_vp
+ open(unit=27,file=prname(1:len_trim(prname))//'vp.bin',status='unknown',form='unformatted')
+ write(27) v_tmp
+ close(27)
+
+ ! VTK file output
+ ! vp values
+ filename = prname(1:len_trim(prname))//'vp'
+ call write_VTK_data_gll_cr(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ v_tmp,filename)
+
+
+ ! vs (for checking the mesh and model)
+ !minimum = minval( abs(rho_vs) )
+ !if( minimum(1) /= 0.0 ) then
+ ! v_tmp = mustore / rho_vs
+ !else
+ ! v_tmp = 0.0
+ !endif
+ v_tmp = 0.0
+ where( rho_vs /= 0._CUSTOM_REAL ) v_tmp = mustore / rho_vs
+ open(unit=27,file=prname(1:len_trim(prname))//'vs.bin',status='unknown',form='unformatted')
+ write(27) v_tmp
+ close(27)
+
+ ! VTK file output
+ ! vs values
+ filename = prname(1:len_trim(prname))//'vs'
+ call write_VTK_data_gll_cr(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ v_tmp,filename)
+
+ ! VTK file output
+ ! saves attenuation flag assigned on each gll point into a vtk file
+ filename = prname(1:len_trim(prname))//'attenuation_flag'
+ call write_VTK_data_gll_i(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ iflag_attenuation_store,&
+ filename)
+ ! VTK file output
+ ! acoustic-elastic domains
+ if( ACOUSTIC_SIMULATION .and. ELASTIC_SIMULATION ) then
+ ! saves points on acoustic-elastic coupling interface
+ allocate( iglob_tmp(NGLLSQUARE*num_coupling_ac_el_faces))
+ inum = 0
+ iglob_tmp(:) = 0
+ do i=1,num_coupling_ac_el_faces
+ do j=1,NGLLSQUARE
+ inum = inum+1
+ iglob_tmp(inum) = ibool(coupling_ac_el_ijk(1,j,i), &
+ coupling_ac_el_ijk(2,j,i), &
+ coupling_ac_el_ijk(3,j,i), &
+ coupling_ac_el_ispec(i) )
+ enddo
+ enddo
+ filename = prname(1:len_trim(prname))//'coupling_acoustic_elastic'
+ call write_VTK_data_points(nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ iglob_tmp,NGLLSQUARE*num_coupling_ac_el_faces, &
+ filename)
+
+
+!Py insertation of fault nodes is right here.
+!====================================================
+
+! SAVING FAULT NODES ....write_VTK_data_points(....
+
+!=====================================================
+
+
+ ! saves acoustic/elastic flag
+ allocate(v_tmp_i(nspec))
+ do i=1,nspec
+ if( ispec_is_acoustic(i) ) then
+ v_tmp_i(i) = 1
+ else if( ispec_is_elastic(i) ) then
+ v_tmp_i(i) = 2
+ else
+ v_tmp_i(i) = 0
+ endif
+ enddo
+ filename = prname(1:len_trim(prname))//'acoustic_elastic_flag'
+ call write_VTK_data_elem_i(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ v_tmp_i,filename)
+ endif
+
+ !! saves 1. MPI interface
+ ! if( num_interfaces_ext_mesh >= 1 ) then
+ ! filename = prname(1:len_trim(prname))//'MPI_1_points'
+ ! call write_VTK_data_points(nglob, &
+ ! xstore_dummy,ystore_dummy,zstore_dummy, &
+ ! ibool_interfaces_ext_mesh_dummy(1:nibool_interfaces_ext_mesh(1),1), &
+ ! nibool_interfaces_ext_mesh(1), &
+ ! filename)
+ ! endif
+ !
+
+ deallocate(v_tmp)
+
+ endif ! SAVE_MESH_FILES
+
+! cleanup
+ deallocate(ibool_interfaces_ext_mesh_dummy,stat=ier); if( ier /= 0 ) stop 'error deallocating array'
+
+
+ end subroutine save_arrays_solver_ext_mesh
+
+
+
+!=============================================================
+!
+!! 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=256) 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
+!
+!!=============================================================
+
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/save_header_file.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/save_header_file.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/save_header_file.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,230 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! save header file OUTPUT_FILES/values_from_mesher.h
+
+ subroutine save_header_file(NSPEC_AB,NGLOB_AB,NPROC, &
+ ATTENUATION,ANISOTROPY,NSTEP,DT, &
+ SIMULATION_TYPE,static_memory_size,nfaces_surface_glob_ext_mesh)
+
+ implicit none
+
+ include "constants.h"
+
+! number of points per surface element
+ integer, parameter :: NGLLSQUARE_NDIM = NGLLSQUARE * NDIM
+
+ integer NSPEC_AB,NGLOB_AB,NPROC,NSTEP,SIMULATION_TYPE
+ ! NPOIN2DMAX_XY,NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,
+
+ logical ATTENUATION,ANISOTROPY
+
+ double precision DT
+
+ double precision :: static_memory_size
+
+ character(len=256) HEADER_FILE
+
+ integer :: nfaces_surface_glob_ext_mesh
+
+! copy number of elements and points in an include file for the solver
+ 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)
+
+ open(unit=IOUT,file=HEADER_FILE,status='unknown')
+ write(IOUT,*)
+
+ write(IOUT,*) '!'
+ write(IOUT,*) '! this is the parameter file for static compilation of the solver'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! mesh statistics:'
+ write(IOUT,*) '! ---------------'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! DK DK'
+ write(IOUT,*) '! DK DK'
+ write(IOUT,*) '! DK DK'
+ write(IOUT,*) '! DK DK'
+ write(IOUT,*) '! DK DK'
+ write(IOUT,*) '! DK DK these statistics are now INCORRECT'
+ write(IOUT,*) '! DK DK because the CUBIT + SCOTCH mesh has'
+ write(IOUT,*) '! DK DK a different number of mesh elements and points in each slice'
+ write(IOUT,*) '! DK DK'
+ write(IOUT,*) '! DK DK'
+ write(IOUT,*) '! DK DK'
+ write(IOUT,*) '! DK DK'
+ write(IOUT,*) '! DK DK'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! number of processors = ',NPROC
+ write(IOUT,*) '!'
+ write(IOUT,*) '! number of ES nodes = ',real(NPROC)/8.
+ write(IOUT,*) '! percentage of total 640 ES nodes = ',100.*(real(NPROC)/8.)/640.,' %'
+ write(IOUT,*) '! total memory available on these ES nodes (Gb) = ',16.*real(NPROC)/8.
+
+! write(IOUT,*) 'integer, parameter :: NPROC_VAL = ',NPROC
+! write(IOUT,*) 'integer, parameter :: NPROC_XI_VAL = ', NPROC_XI
+! write(IOUT,*) 'integer, parameter :: NPROC_ETA_VAL = ', NPROC_ETA
+
+ write(IOUT,*) '!'
+! write(IOUT,*) '! max points per processor = max vector length = ',NGLOB_AB
+ write(IOUT,*) '! min vector length = ',NGLLSQUARE
+ write(IOUT,*) '! min critical vector length = ',NGLLSQUARE_NDIM
+ write(IOUT,*) '!'
+! write(IOUT,*) '! on ES and SX-5, make sure "loopcnt=" parameter'
+! write(IOUT,*) '! in Makefile is greater than ',NGLOB_AB
+! write(IOUT,*) '!'
+
+! 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,*) '!'
+
+ write(IOUT,*) '! total for full mesh:'
+ write(IOUT,*) '! -------------------'
+ write(IOUT,*) '!'
+! write(IOUT,*) '! exact total number of spectral elements in entire mesh = '
+! write(IOUT,*) '! ',NPROC*NSPEC_AB
+! write(IOUT,*) '! approximate total number of points in entire mesh = '
+! write(IOUT,*) '! ',dble(NPROC)*dble(NGLOB_AB)
+! there are 3 DOFs in solid regions
+! write(IOUT,*) '! approximate total number of degrees of freedom in entire mesh = '
+! write(IOUT,*) '! ',3.d0*dble(NPROC)*dble(NGLOB_AB)
+! write(IOUT,*) '!'
+
+ write(IOUT,*) '!'
+ write(IOUT,*) '! number of time steps = ',NSTEP
+ write(IOUT,*) '!'
+ write(IOUT,*) '! time step = ',DT
+ write(IOUT,*) '!'
+
+! if attenuation is off, set dummy size of arrays to one
+! both parameters are obsolete for specfem3D
+! they are only used in ampuero_implicit_ABC_specfem3D.f90
+ write(IOUT,*) '! only needed for ampuero_implicit_ABC_specfem3D.f90 compilation: '
+ write(IOUT,*) '! (uncomment next line) '
+ if(ATTENUATION) then
+ write(IOUT,*) '! integer, parameter :: NSPEC_ATTENUATION = ', NSPEC_AB
+! write(IOUT,*) '! logical, parameter :: ATTENUATION_VAL = .true.'
+ else
+ write(IOUT,*) '! integer, parameter :: NSPEC_ATTENUATION = ', 1
+! write(IOUT,*) '! logical, parameter :: ATTENUATION_VAL = .false.'
+ endif
+
+ write(IOUT,*)
+
+! anisotropy
+ if(ANISOTROPY) then
+ !stop 'ANISOTROPY not supported yet in the CUBIT + SCOTCH version because of arrays of constant size defined'
+ !write(IOUT,*) 'integer, parameter :: NSPEC_ANISO = ',NSPEC_AB
+ !write(IOUT,*) 'logical, parameter :: ANISOTROPY_VAL = .true.'
+ write(IOUT,*) '! with anisotropy'
+ else
+ !write(IOUT,*) 'integer, parameter :: NSPEC_ANISO = ', 1
+ !write(IOUT,*) 'logical, parameter :: ANISOTROPY_VAL = .false.'
+ write(IOUT,*) '! no anisotropy'
+ endif
+
+ write(IOUT,*)
+
+!! DK DK May 2009: removed all the things that are not supported in the CUBIT + SCOTCH version yet
+!! DK DK May 2009: removed all the things that are not supported in the CUBIT + SCOTCH version yet
+!! DK DK May 2009: removed all the things that are not supported in the CUBIT + SCOTCH version yet
+
+ write(IOUT,*) '! approximate static memory needed by the solver:'
+ write(IOUT,*) '! ----------------------------------------------'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! size of static arrays for the biggest slice = ',static_memory_size/1048576.d0,' MB'
+ write(IOUT,*) '! = ',static_memory_size/1073741824.d0,' GB'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! (should be below and typically equal to 80% of 1.5 GB = 1.2 GB on pangu'
+ write(IOUT,*) '! at Caltech, and below and typically equal to 85% of 2 GB = 1.7 GB'
+ write(IOUT,*) '! on Marenostrum in Barcelona)'
+ write(IOUT,*) '! (if significantly more, the job will not run by lack of memory)'
+ write(IOUT,*) '! (if significantly less, you waste a significant amount of memory)'
+ write(IOUT,*) '!'
+
+! strain/attenuation
+ if (ATTENUATION .and. SIMULATION_TYPE == 3) then
+! write(IOUT,*) 'integer, parameter :: NSPEC_ATT_AND_KERNEL = ', NSPEC_AB
+ else
+! write(IOUT,*) 'integer, parameter :: NSPEC_ATT_AND_KERNEL = ', 1
+ endif
+
+ ! adjoint
+ if (SIMULATION_TYPE == 3) then
+! write(IOUT,*) 'integer, parameter :: NSPEC_ADJOINT = ', NSPEC_AB
+! write(IOUT,*) 'integer, parameter :: NGLOB_ADJOINT = ', NGLOB_AB
+ else
+! write(IOUT,*) 'integer, parameter :: NSPEC_ADJOINT = ', 1
+! write(IOUT,*) 'integer, parameter :: NGLOB_ADJOINT = ', 1
+ endif
+
+ write(IOUT,*)
+
+! write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_XMIN_XMAX_VAL = ', NSPEC2DMAX_XMIN_XMAX
+! write(IOUT,*) 'integer, parameter :: NSPEC2DMAX_YMIN_YMAX_VAL = ', NSPEC2DMAX_YMIN_YMAX
+! write(IOUT,*) 'integer, parameter :: NSPEC2D_BOTTOM_VAL = ', NSPEC2D_BOTTOM
+! write(IOUT,*) 'integer, parameter :: NSPEC2D_TOP_VAL = ', NSPEC2D_TOP
+! write(IOUT,*) 'integer, parameter :: NPOIN2DMAX_XMIN_XMAX_VAL = ', NPOIN2DMAX_XMIN_XMAX
+! write(IOUT,*) 'integer, parameter :: NPOIN2DMAX_YMIN_YMAX_VAL = ', NPOIN2DMAX_YMIN_YMAX
+! write(IOUT,*) 'integer, parameter :: NPOIN2DMAX_XY_VAL = ', NPOIN2DMAX_XY
+
+ write(IOUT,*)
+
+! Moho boundary
+! if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
+! write(IOUT,*) 'integer, parameter :: NSPEC2D_MOHO_BOUN = ', NSPEC2D_BOTTOM
+! write(IOUT,*) 'integer, parameter :: NSPEC_BOUN = ', NSPEC_AB
+! else
+! write(IOUT,*) 'integer, parameter :: NSPEC2D_MOHO_BOUN = ', 1
+! write(IOUT,*) 'integer, parameter :: NSPEC_BOUN = ', 1
+! endif
+
+ close(IOUT)
+
+
+! copy number of surface elements in an include file for the movies
+ if( nfaces_surface_glob_ext_mesh > 0 ) then
+
+ call get_value_string(HEADER_FILE, 'solver.HEADER_FILE', 'OUTPUT_FILES/surface_from_mesher.h')
+
+ open(unit=IOUT,file=HEADER_FILE,status='unknown')
+ write(IOUT,*) '!'
+ write(IOUT,*) '! this is the parameter file for static compilation for movie creation'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! number of elements containing surface faces '
+ write(IOUT,*) '! ---------------'
+ write(IOUT,*)
+ write(IOUT,*) 'integer,parameter :: NSPEC_SURFACE_EXT_MESH = ',nfaces_surface_glob_ext_mesh
+ write(IOUT,*)
+ close(IOUT)
+
+ endif
+
+ end subroutine save_header_file
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/save_moho_arrays.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/save_moho_arrays.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/save_moho_arrays.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,330 @@
+!=====================================================================
+!
+! 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 save_moho_arrays( myrank,nglob,nspec, &
+ nspec2D_moho_ext,ibelm_moho,nodes_ibelm_moho, &
+ nodes_coords_ext_mesh,nnodes_ext_mesh,ibool )
+
+ use create_regions_mesh_ext_par
+ implicit none
+
+ integer :: nspec2D_moho_ext
+ integer, dimension(nspec2D_moho_ext) :: ibelm_moho
+ integer, dimension(4,nspec2D_moho_ext) :: nodes_ibelm_moho
+
+ integer :: myrank,nglob,nspec
+
+ ! data from the external mesh
+ integer :: nnodes_ext_mesh
+ double precision, dimension(NDIM,nnodes_ext_mesh) :: nodes_coords_ext_mesh
+
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+! local parameters
+ ! Moho mesh
+ real(CUSTOM_REAL), dimension(:,:,:),allocatable :: normal_moho_top
+ real(CUSTOM_REAL), dimension(:,:,:),allocatable :: normal_moho_bot
+ integer,dimension(:,:,:),allocatable :: ijk_moho_top, ijk_moho_bot
+ integer,dimension(:),allocatable :: ibelm_moho_top, ibelm_moho_bot
+ integer :: NSPEC2D_MOHO
+ logical, dimension(:),allocatable :: is_moho_top, is_moho_bot
+
+ real(kind=CUSTOM_REAL),dimension(NGNOD2D) :: xcoord,ycoord,zcoord
+ real(kind=CUSTOM_REAL) :: jacobian2Dw_face(NGLLX,NGLLY)
+ real(kind=CUSTOM_REAL) :: normal_face(NDIM,NGLLX,NGLLY)
+ real(kind=CUSTOM_REAL),dimension(NDIM):: normal
+ integer :: ijk_face(3,NGLLX,NGLLY)
+
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable :: iglob_normals
+ integer,dimension(:),allocatable:: iglob_is_surface
+
+ integer :: imoho_bot,imoho_top
+ integer :: ispec2D,ispec,icorner,iface,i,j,k,igll,iglob
+ integer :: iglob_midpoint,idirect,counter
+ integer :: imoho_top_all,imoho_bot_all,imoho_all
+
+ ! corners indices of reference cube faces
+ integer,dimension(3,4),parameter :: iface1_corner_ijk = &
+ reshape( (/ 1,1,1, 1,NGLLY,1, 1,NGLLY,NGLLZ, 1,1,NGLLZ /),(/3,4/)) ! xmin
+ integer,dimension(3,4),parameter :: iface2_corner_ijk = &
+ reshape( (/ NGLLX,1,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, NGLLX,1,NGLLZ /),(/3,4/)) ! xmax
+ integer,dimension(3,4),parameter :: iface3_corner_ijk = &
+ reshape( (/ 1,1,1, 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,1,1 /),(/3,4/)) ! ymin
+ integer,dimension(3,4),parameter :: iface4_corner_ijk = &
+ reshape( (/ 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! ymax
+ integer,dimension(3,4),parameter :: iface5_corner_ijk = &
+ reshape( (/ 1,1,1, 1,NGLLY,1, NGLLX,NGLLY,1, NGLLX,1,1 /),(/3,4/)) ! bottom
+ integer,dimension(3,4),parameter :: iface6_corner_ijk = &
+ reshape( (/ 1,1,NGLLZ, NGLLX,1,NGLLZ, NGLLX,NGLLY,NGLLZ, 1,NGLLY,NGLLZ /),(/3,4/)) ! top
+ integer,dimension(3,4,6),parameter :: iface_all_corner_ijk = &
+ reshape( (/ iface1_corner_ijk,iface2_corner_ijk, &
+ iface3_corner_ijk,iface4_corner_ijk, &
+ iface5_corner_ijk,iface6_corner_ijk /),(/3,4,6/)) ! all faces
+ ! midpoint indices for each face (xmin,xmax,ymin,ymax,zmin,zmax)
+ integer,dimension(3,6),parameter :: iface_all_midpointijk = &
+ reshape( (/ 1,2,2, NGLLX,2,2, 2,1,2, 2,NGLLY,2, 2,2,1, 2,2,NGLLZ /),(/3,6/)) ! top
+
+ ! temporary arrays for passing information
+ allocate(iglob_is_surface(nglob))
+ allocate(iglob_normals(NDIM,nglob))
+ iglob_is_surface = 0
+ iglob_normals = 0._CUSTOM_REAL
+
+ ! loops over given moho surface elements
+ do ispec2D=1, nspec2D_moho_ext
+
+ ! gets element id
+ ispec = ibelm_moho(ispec2D)
+
+ ! looks for i,j,k indices of GLL points on boundary face
+ ! determines element face by given CUBIT corners
+ ! (note: uses point locations rather than point indices to find the element face,
+ ! because the indices refer no more to the newly indexed ibool array )
+ do icorner=1,NGNOD2D
+ xcoord(icorner) = nodes_coords_ext_mesh(1,nodes_ibelm_moho(icorner,ispec2D))
+ ycoord(icorner) = nodes_coords_ext_mesh(2,nodes_ibelm_moho(icorner,ispec2D))
+ zcoord(icorner) = nodes_coords_ext_mesh(3,nodes_ibelm_moho(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)
+
+ ! 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,jacobian2Dw_face,normal_face,NGLLX,NGLLZ)
+
+ ! 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
+
+ ! stores information on global points on moho surface
+ igll = 0
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(ijk_face(1,i,j),ijk_face(2,i,j),ijk_face(3,i,j),ispec)
+ ! sets flag
+ iglob_is_surface(iglob) = ispec2D
+ ! sets normals
+ iglob_normals(:,iglob) = normal_face(:,i,j)
+ enddo
+ enddo
+ enddo
+
+ ! stores moho elements
+ NSPEC2D_MOHO = nspec2D_moho_ext
+
+ allocate(ibelm_moho_bot(NSPEC2D_MOHO))
+ allocate(ibelm_moho_top(NSPEC2D_MOHO))
+ allocate(normal_moho_top(NDIM,NGLLSQUARE,NSPEC2D_MOHO))
+ allocate(normal_moho_bot(NDIM,NGLLSQUARE,NSPEC2D_MOHO))
+ allocate(ijk_moho_bot(3,NGLLSQUARE,NSPEC2D_MOHO))
+ allocate(ijk_moho_top(3,NGLLSQUARE,NSPEC2D_MOHO))
+ ibelm_moho_bot = 0
+ ibelm_moho_top = 0
+
+ ! element flags
+ allocate(is_moho_top(nspec))
+ allocate(is_moho_bot(nspec))
+ is_moho_top = .false.
+ is_moho_bot = .false.
+
+ ! finds spectral elements with moho surface
+ imoho_top = 0
+ imoho_bot = 0
+ do ispec=1,nspec
+
+ ! loops over each face
+ do iface = 1,6
+ ! checks if corners of face on surface
+ counter = 0
+ 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)
+
+ ! checks if point on surface
+ if( iglob_is_surface(iglob) > 0 ) then
+ counter = counter+1
+
+ ! reference corner coordinates
+ xcoord(icorner) = xstore_dummy(iglob)
+ ycoord(icorner) = ystore_dummy(iglob)
+ zcoord(icorner) = zstore_dummy(iglob)
+ endif
+ enddo
+
+ ! stores moho informations
+ if( counter == NGNOD2D ) then
+
+ ! gets face GLL points i,j,k indices from element face
+ call get_element_face_gll_indices(iface,ijk_face,NGLLX,NGLLY)
+
+ ! re-computes face infos
+ ! 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,jacobian2Dw_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
+
+ ! takes normal stored temporary on a face midpoint
+ i = iface_all_midpointijk(1,iface)
+ j = iface_all_midpointijk(2,iface)
+ k = iface_all_midpointijk(3,iface)
+ iglob_midpoint = ibool(i,j,k,ispec)
+ normal(:) = iglob_normals(:,iglob_midpoint)
+
+ ! determines whether normal points into element or not (top/bottom distinction)
+ call get_element_face_normal_idirect(ispec,iface,xcoord,ycoord,zcoord, &
+ ibool,nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ normal,idirect )
+
+ ! takes moho surface element id given by id on midpoint
+ ispec2D = iglob_is_surface(iglob_midpoint)
+
+ ! sets face infos for bottom (normal points away from element)
+ if( idirect == 1 ) then
+
+ ! checks validity
+ if( is_moho_bot( ispec) .eqv. .true. ) then
+ print*,'error: moho surface geometry bottom'
+ print*,' does not allow for mulitple element faces in kernel computation'
+ call exit_mpi(myrank,'error moho bottom elements')
+ endif
+
+ imoho_bot = imoho_bot + 1
+ is_moho_bot(ispec) = .true.
+ ibelm_moho_bot(ispec2D) = ispec
+
+ ! stores on surface gll points (assuming NGLLX = NGLLY = NGLLZ)
+ igll = 0
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ igll = igll+1
+ ijk_moho_bot(:,igll,ispec2D) = ijk_face(:,i,j)
+ normal_moho_bot(:,igll,ispec2D) = normal_face(:,i,j)
+ enddo
+ enddo
+
+ ! sets face infos for top element
+ else if( idirect == 2 ) then
+
+ ! checks validity
+ if( is_moho_top( ispec) .eqv. .true. ) then
+ print*,'error: moho surface geometry top'
+ print*,' does not allow for mulitple element faces kernel computation'
+ call exit_mpi(myrank,'error moho top elements')
+ endif
+
+ imoho_top = imoho_top + 1
+ is_moho_top(ispec) = .true.
+ ibelm_moho_top(ispec2D) = ispec
+
+ ! gll points
+ igll = 0
+ do j=1,NGLLZ
+ do i=1,NGLLX
+ igll = igll+1
+ ijk_moho_top(:,igll,ispec) = ijk_face(:,i,j)
+ ! note: top elements have normal pointing into element
+ normal_moho_top(:,igll,ispec) = - normal_face(:,i,j)
+ enddo
+ enddo
+ endif
+
+ endif ! counter
+
+ enddo ! iface
+
+ ! checks validity of top/bottom distinction
+ if( is_moho_top(ispec) .and. is_moho_bot(ispec) ) then
+ print*,'error: moho surface elements confusing'
+ print*,' element:',ispec,'has top and bottom surface'
+ call exit_mpi(myrank,'error moho surface element')
+ endif
+
+ enddo ! ispec2D
+
+ ! note: surface e.g. could be at the free-surface and have no top elements etc...
+ ! user output
+ call sum_all_i( imoho_top, imoho_top_all )
+ call sum_all_i( imoho_bot, imoho_bot_all )
+ call sum_all_i( NSPEC2D_MOHO, imoho_all )
+ if( myrank == 0 ) then
+ write(IMAIN,*) '********'
+ write(IMAIN,*) 'Moho surface:'
+ write(IMAIN,*) ' total surface elements: ',imoho_all
+ write(IMAIN,*) ' top elements :',imoho_top_all
+ write(IMAIN,*) ' bottom elements:',imoho_bot_all
+ write(IMAIN,*) '********'
+ endif
+
+ ! saves moho files: total number of elements, corner points, all points
+ open(unit=27,file=prname(1:len_trim(prname))//'ibelm_moho.bin',status='unknown',form='unformatted')
+ write(27) NSPEC2D_MOHO
+ write(27) ibelm_moho_top
+ write(27) ibelm_moho_bot
+ write(27) ijk_moho_top
+ write(27) ijk_moho_bot
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'normal_moho.bin',status='unknown',form='unformatted')
+ write(27) normal_moho_top
+ write(27) normal_moho_bot
+ close(27)
+ open(unit=27,file=prname(1:len_trim(prname))//'is_moho.bin',status='unknown',form='unformatted')
+ write(27) is_moho_top
+ write(27) is_moho_bot
+ close(27)
+
+end subroutine save_moho_arrays
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/serial.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/serial.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/serial.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,596 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+!----
+!---- Stubs for parallel routines. Used by the serial version.
+!----
+
+
+ subroutine stop_all()
+ stop 'error, program ended in exit_MPI'
+ end subroutine stop_all
+
+!
+!----
+!
+
+ double precision function wtime()
+ wtime = 0.d0
+ end function wtime
+
+!
+!----
+!
+
+ subroutine sync_all()
+ end subroutine sync_all
+
+!
+!----
+!
+
+ subroutine bcast_all_i(buffer, count)
+
+ integer count
+ integer, dimension(count) :: buffer
+
+ end subroutine bcast_all_i
+
+!
+!----
+!
+
+ subroutine bcast_all_cr(buffer, count)
+
+ include "constants.h"
+
+ integer count
+ real(kind=CUSTOM_REAL), dimension(count) :: buffer
+
+ end subroutine bcast_all_cr
+
+!
+!----
+!
+
+ subroutine bcast_all_dp(buffer, count)
+
+ integer count
+ double precision, dimension(count) :: buffer
+
+ end subroutine bcast_all_dp
+
+!
+!----
+!
+
+ subroutine gather_all_i(sendbuf, sendcnt, recvbuf, recvcount, NPROC)
+
+ implicit none
+
+ integer sendcnt, recvcount, NPROC
+ integer, dimension(sendcnt) :: sendbuf
+ integer, dimension(recvcount,0:NPROC-1) :: recvbuf
+
+ recvbuf(:,0) = sendbuf(:)
+
+ end subroutine gather_all_i
+
+!
+!----
+!
+
+ subroutine gather_all_dp(sendbuf, sendcnt, recvbuf, recvcount, NPROC)
+
+ implicit none
+
+ integer sendcnt, recvcount, NPROC
+ double precision, dimension(sendcnt) :: sendbuf
+ double precision, dimension(recvcount,0:NPROC-1) :: recvbuf
+
+ recvbuf(:,0) = sendbuf(:)
+
+ end subroutine gather_all_dp
+
+!
+!----
+!
+
+ subroutine gather_all_cr(sendbuf, sendcnt, recvbuf, recvcount, NPROC)
+
+ implicit none
+
+ include "constants.h"
+
+ integer sendcnt, recvcount, NPROC
+ real(kind=CUSTOM_REAL), dimension(sendcnt) :: sendbuf
+ real(kind=CUSTOM_REAL), dimension(recvcount,0:NPROC-1) :: recvbuf
+
+ recvbuf(:,0) = sendbuf(:)
+
+ end subroutine gather_all_cr
+
+!
+!----
+!
+
+ subroutine gather_all_all_cr(sendbuf, recvbuf, counts,NPROC)
+
+ implicit none
+
+ include "constants.h"
+
+ integer NPROC,counts
+ real(kind=CUSTOM_REAL), dimension(counts) :: sendbuf
+ real(kind=CUSTOM_REAL), dimension(counts,0:NPROC-1) :: recvbuf
+
+ recvbuf(:,0) = sendbuf(:)
+
+ end subroutine gather_all_all_cr
+
+!
+!----
+!
+
+ 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
+
+!
+!----
+!
+
+ subroutine finalize()
+ end subroutine finalize
+
+
+!
+!----
+!
+
+ subroutine world_size(size)
+
+ implicit none
+
+ integer size
+
+ size = 1
+
+ end subroutine world_size
+
+!
+!----
+!
+
+ subroutine world_rank(rank)
+
+ implicit none
+
+ integer rank
+
+ rank = 0
+
+ end subroutine world_rank
+
+!
+!----
+!
+
+ subroutine min_all_dp(sendbuf, recvbuf)
+
+ implicit none
+
+ double precision sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine min_all_dp
+
+!
+!----
+!
+
+ subroutine max_all_dp(sendbuf, recvbuf)
+
+ implicit none
+
+ double precision sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine max_all_dp
+
+!
+!----
+!
+
+ subroutine max_all_cr(sendbuf, recvbuf)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL) sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine max_all_cr
+
+!
+!----
+!
+
+ subroutine max_all_all_cr(sendbuf, recvbuf)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL) sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine max_all_all_cr
+
+!
+!----
+!
+
+ subroutine max_all_all_dp(sendbuf, recvbuf)
+
+ implicit none
+
+ double precision :: sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine max_all_all_dp
+
+
+!
+!----
+!
+!
+! subroutine min_all_all_dp(sendbuf, recvbuf)
+!
+! implicit none
+!
+! double precision :: sendbuf, recvbuf
+!
+! recvbuf = sendbuf
+!
+! end subroutine min_all_all_dp
+!
+!----
+!
+
+ subroutine min_all_cr(sendbuf, recvbuf)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL) sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine min_all_cr
+
+!
+!----
+!
+
+ subroutine min_all_all_cr(sendbuf, recvbuf)
+
+ implicit none
+
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL) sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine min_all_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
+
+ double precision sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine sum_all_dp
+
+!
+!----
+!
+
+ subroutine sum_all_cr(sendbuf, recvbuf)
+
+ implicit none
+ include "constants.h"
+
+ real(kind=CUSTOM_REAL) sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine sum_all_cr
+
+!
+!----
+!
+
+ subroutine sum_all_i(sendbuf, recvbuf)
+
+ implicit none
+
+ integer sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine sum_all_i
+
+
+!
+!----
+!
+ subroutine sum_all_all_i(sendbuf, recvbuf)
+
+ implicit none
+
+ integer sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine sum_all_all_i
+
+!
+!----
+!
+
+ subroutine any_all_l(sendbuf, recvbuf)
+
+ implicit none
+
+ logical sendbuf, recvbuf
+
+ recvbuf = sendbuf
+
+ end subroutine any_all_l
+
+!
+!----
+!
+
+ subroutine sendrecv_all_cr(sendbuf, sendcount, dest, sendtag, &
+ recvbuf, recvcount, source, recvtag)
+
+ implicit none
+
+ include "constants.h"
+
+ integer sendcount, recvcount, dest, sendtag, source, recvtag
+ real(kind=CUSTOM_REAL), dimension(sendcount) :: sendbuf
+ real(kind=CUSTOM_REAL), dimension(recvcount) :: recvbuf
+
+ stop 'sendrecv_all_cr not implemented for serial code'
+
+ end subroutine sendrecv_all_cr
+
+!
+!----
+!
+
+ 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
+ integer dest,recvtag
+ integer recvcount
+ integer,dimension(recvcount):: recvbuf
+
+ 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
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/setup_GLL_points.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/setup_GLL_points.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/setup_GLL_points.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,66 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+ subroutine setup_GLL_points()
+
+ use specfem_par
+ implicit none
+ integer :: i,j
+
+ if(myrank == 0) then
+ write(IMAIN,*) '******************************************'
+ write(IMAIN,*) 'There is a total of ',NPROC,' slices'
+ write(IMAIN,*) '******************************************'
+ write(IMAIN,*)
+ endif
+
+! set up GLL points, weights and derivation matrices for reference element (between -1,1)
+ call define_derivation_matrices(xigll,yigll,zigll,wxgll,wygll,wzgll, &
+ hprime_xx,hprime_yy,hprime_zz, &
+ hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
+ wgllwgll_xy,wgllwgll_xz,wgllwgll_yz)
+
+! define transpose of derivation matrix
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ hprime_xxT(j,i) = hprime_xx(i,j)
+ hprimewgll_xxT(j,i) = hprimewgll_xx(i,j)
+ enddo
+ enddo
+
+! allocate 1-D Lagrange interpolators and derivatives
+ allocate(hxir(NGLLX))
+ allocate(hpxir(NGLLX))
+ allocate(hetar(NGLLY))
+ allocate(hpetar(NGLLY))
+ allocate(hgammar(NGLLZ))
+ allocate(hpgammar(NGLLZ))
+
+! create name of database
+ call create_name_database(prname,myrank,LOCAL_PATH)
+
+ end subroutine
\ No newline at end of file
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/setup_movie_meshes.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/setup_movie_meshes.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/setup_movie_meshes.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,295 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+! creation of arrays for movie and shakemap routines for external meshes
+
+ subroutine setup_movie_meshes()
+
+ use specfem_par
+ use specfem_par_movie
+ implicit none
+
+ integer :: i,j,k,ispec,iglob
+ integer :: ipoin,nfaces_org
+ character(len=256):: filename
+
+! initializes mesh arrays for movies and shakemaps
+ allocate(nfaces_perproc_surface_ext_mesh(NPROC))
+ allocate(faces_surface_offset_ext_mesh(NPROC))
+ nfaces_org = nfaces_surface_ext_mesh
+ if (nfaces_surface_ext_mesh == 0) then
+ ! dummy arrays
+ if (USE_HIGHRES_FOR_MOVIES) then
+ allocate(faces_surface_ext_mesh(NGLLX*NGLLY,1))
+ allocate(store_val_x_external_mesh(NGLLX*NGLLY*1))
+ allocate(store_val_y_external_mesh(NGLLX*NGLLY*1))
+ allocate(store_val_z_external_mesh(NGLLX*NGLLY*1))
+ allocate(store_val_ux_external_mesh(NGLLX*NGLLY*1))
+ allocate(store_val_uy_external_mesh(NGLLX*NGLLY*1))
+ allocate(store_val_uz_external_mesh(NGLLX*NGLLY*1))
+ else
+ allocate(faces_surface_ext_mesh(NGNOD2D,1))
+ allocate(store_val_x_external_mesh(NGNOD2D*1))
+ allocate(store_val_y_external_mesh(NGNOD2D*1))
+ allocate(store_val_z_external_mesh(NGNOD2D*1))
+ allocate(store_val_ux_external_mesh(NGNOD2D*1))
+ allocate(store_val_uy_external_mesh(NGNOD2D*1))
+ allocate(store_val_uz_external_mesh(NGNOD2D*1))
+ endif
+ else
+ if (USE_HIGHRES_FOR_MOVIES) then
+ allocate(faces_surface_ext_mesh(NGLLX*NGLLY,nfaces_surface_ext_mesh))
+ allocate(store_val_x_external_mesh(NGLLX*NGLLY*nfaces_surface_ext_mesh))
+ allocate(store_val_y_external_mesh(NGLLX*NGLLY*nfaces_surface_ext_mesh))
+ allocate(store_val_z_external_mesh(NGLLX*NGLLY*nfaces_surface_ext_mesh))
+ allocate(store_val_ux_external_mesh(NGLLX*NGLLY*nfaces_surface_ext_mesh))
+ allocate(store_val_uy_external_mesh(NGLLX*NGLLY*nfaces_surface_ext_mesh))
+ allocate(store_val_uz_external_mesh(NGLLX*NGLLY*nfaces_surface_ext_mesh))
+ else
+ allocate(faces_surface_ext_mesh(NGNOD2D,nfaces_surface_ext_mesh))
+ allocate(store_val_x_external_mesh(NGNOD2D*nfaces_surface_ext_mesh))
+ allocate(store_val_y_external_mesh(NGNOD2D*nfaces_surface_ext_mesh))
+ allocate(store_val_z_external_mesh(NGNOD2D*nfaces_surface_ext_mesh))
+ allocate(store_val_ux_external_mesh(NGNOD2D*nfaces_surface_ext_mesh))
+ allocate(store_val_uy_external_mesh(NGNOD2D*nfaces_surface_ext_mesh))
+ allocate(store_val_uz_external_mesh(NGNOD2D*nfaces_surface_ext_mesh))
+ endif
+ endif
+ store_val_ux_external_mesh(:) = 0._CUSTOM_REAL
+ store_val_uy_external_mesh(:) = 0._CUSTOM_REAL
+ store_val_uz_external_mesh(:) = 0._CUSTOM_REAL
+
+ ! number of surface faces for all partitions together
+ call sum_all_i(nfaces_surface_ext_mesh,nfaces_surface_glob_ext_mesh)
+
+ ! arrays used for collected/gathered fields
+ if (myrank == 0) then
+ if (USE_HIGHRES_FOR_MOVIES) then
+ allocate(store_val_x_all_external_mesh(NGLLX*NGLLY*nfaces_surface_glob_ext_mesh))
+ allocate(store_val_y_all_external_mesh(NGLLX*NGLLY*nfaces_surface_glob_ext_mesh))
+ allocate(store_val_z_all_external_mesh(NGLLX*NGLLY*nfaces_surface_glob_ext_mesh))
+ allocate(store_val_ux_all_external_mesh(NGLLX*NGLLY*nfaces_surface_glob_ext_mesh))
+ allocate(store_val_uy_all_external_mesh(NGLLX*NGLLY*nfaces_surface_glob_ext_mesh))
+ allocate(store_val_uz_all_external_mesh(NGLLX*NGLLY*nfaces_surface_glob_ext_mesh))
+ else
+ allocate(store_val_x_all_external_mesh(NGNOD2D*nfaces_surface_glob_ext_mesh))
+ allocate(store_val_y_all_external_mesh(NGNOD2D*nfaces_surface_glob_ext_mesh))
+ allocate(store_val_z_all_external_mesh(NGNOD2D*nfaces_surface_glob_ext_mesh))
+ allocate(store_val_ux_all_external_mesh(NGNOD2D*nfaces_surface_glob_ext_mesh))
+ allocate(store_val_uy_all_external_mesh(NGNOD2D*nfaces_surface_glob_ext_mesh))
+ allocate(store_val_uz_all_external_mesh(NGNOD2D*nfaces_surface_glob_ext_mesh))
+ endif
+ endif
+ call gather_all_i(nfaces_surface_ext_mesh,1,nfaces_perproc_surface_ext_mesh,1,NPROC)
+
+ ! array offsets
+ faces_surface_offset_ext_mesh(1) = 0
+ do i = 2, NPROC
+ faces_surface_offset_ext_mesh(i) = sum(nfaces_perproc_surface_ext_mesh(1:i-1))
+ enddo
+ if (USE_HIGHRES_FOR_MOVIES) then
+ faces_surface_offset_ext_mesh(:) = faces_surface_offset_ext_mesh(:)*NGLLX*NGLLY
+ else
+ faces_surface_offset_ext_mesh(:) = faces_surface_offset_ext_mesh(:)*NGNOD2D
+ endif
+
+! stores global indices of GLL points on the surface to array faces_surface_ext_mesh
+ if( EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP ) then
+
+ allocate( faces_surface_ext_mesh_ispec(nfaces_surface_ext_mesh))
+
+ ! stores global indices
+ nfaces_surface_ext_mesh = 0
+ do ispec = 1, NSPEC_AB
+
+ if (ispec_is_surface_external_mesh(ispec)) then
+
+ ! zmin face
+ iglob = ibool(2,2,1,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ faces_surface_ext_mesh_ispec(nfaces_surface_ext_mesh) = ispec
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do j = NGLLY, 1, -1
+ do i = 1, NGLLX
+ ipoin = ipoin+1
+ faces_surface_ext_mesh(ipoin,nfaces_surface_ext_mesh) = ibool(i,j,1,ispec)
+ enddo
+ enddo
+ else
+ faces_surface_ext_mesh(1,nfaces_surface_ext_mesh) = ibool(1,1,1,ispec)
+ faces_surface_ext_mesh(2,nfaces_surface_ext_mesh) = ibool(1,NGLLY,1,ispec)
+ faces_surface_ext_mesh(3,nfaces_surface_ext_mesh) = ibool(NGLLX,NGLLY,1,ispec)
+ faces_surface_ext_mesh(4,nfaces_surface_ext_mesh) = ibool(NGLLX,1,1,ispec)
+ endif
+ endif
+ ! zmax face
+ iglob = ibool(2,2,NGLLZ,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ faces_surface_ext_mesh_ispec(nfaces_surface_ext_mesh) = ispec
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ ipoin = ipoin+1
+ faces_surface_ext_mesh(ipoin,nfaces_surface_ext_mesh) = ibool(i,j,NGLLZ,ispec)
+ enddo
+ enddo
+ else
+ faces_surface_ext_mesh(1,nfaces_surface_ext_mesh) = ibool(1,1,NGLLZ,ispec)
+ faces_surface_ext_mesh(2,nfaces_surface_ext_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
+ faces_surface_ext_mesh(3,nfaces_surface_ext_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ faces_surface_ext_mesh(4,nfaces_surface_ext_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
+ endif
+ endif
+ ! ymin face
+ iglob = ibool(2,1,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ faces_surface_ext_mesh_ispec(nfaces_surface_ext_mesh) = ispec
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do k = 1, NGLLZ
+ do i = 1, NGLLX
+ ipoin = ipoin+1
+ faces_surface_ext_mesh(ipoin,nfaces_surface_ext_mesh) = ibool(i,1,k,ispec)
+ enddo
+ enddo
+ else
+ faces_surface_ext_mesh(1,nfaces_surface_ext_mesh) = ibool(1,1,1,ispec)
+ faces_surface_ext_mesh(2,nfaces_surface_ext_mesh) = ibool(NGLLX,1,1,ispec)
+ faces_surface_ext_mesh(3,nfaces_surface_ext_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
+ faces_surface_ext_mesh(4,nfaces_surface_ext_mesh) = ibool(1,1,NGLLZ,ispec)
+ endif
+ endif
+ ! ymax face
+ iglob = ibool(2,NGLLY,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ faces_surface_ext_mesh_ispec(nfaces_surface_ext_mesh) = ispec
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do k = 1, NGLLZ
+ do i = NGLLX, 1, -1
+ ipoin = ipoin+1
+ faces_surface_ext_mesh(ipoin,nfaces_surface_ext_mesh) = ibool(i,NGLLY,k,ispec)
+ enddo
+ enddo
+ else
+ faces_surface_ext_mesh(1,nfaces_surface_ext_mesh) = ibool(NGLLX,NGLLY,1,ispec)
+ faces_surface_ext_mesh(2,nfaces_surface_ext_mesh) = ibool(1,NGLLY,1,ispec)
+ faces_surface_ext_mesh(3,nfaces_surface_ext_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
+ faces_surface_ext_mesh(4,nfaces_surface_ext_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ endif
+ endif
+ ! xmin face
+ iglob = ibool(1,2,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ faces_surface_ext_mesh_ispec(nfaces_surface_ext_mesh) = ispec
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do k = 1, NGLLZ
+ do j = NGLLY, 1, -1
+ ipoin = ipoin+1
+ faces_surface_ext_mesh(ipoin,nfaces_surface_ext_mesh) = ibool(1,j,k,ispec)
+ enddo
+ enddo
+ else
+ faces_surface_ext_mesh(1,nfaces_surface_ext_mesh) = ibool(1,NGLLY,1,ispec)
+ faces_surface_ext_mesh(2,nfaces_surface_ext_mesh) = ibool(1,1,1,ispec)
+ faces_surface_ext_mesh(3,nfaces_surface_ext_mesh) = ibool(1,1,NGLLZ,ispec)
+ faces_surface_ext_mesh(4,nfaces_surface_ext_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
+ endif
+ endif
+ ! xmax face
+ iglob = ibool(NGLLX,2,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_ext_mesh = nfaces_surface_ext_mesh + 1
+ faces_surface_ext_mesh_ispec(nfaces_surface_ext_mesh) = ispec
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ ipoin = ipoin+1
+ faces_surface_ext_mesh(ipoin,nfaces_surface_ext_mesh) = ibool(NGLLX,j,k,ispec)
+ enddo
+ enddo
+ else
+ faces_surface_ext_mesh(1,nfaces_surface_ext_mesh) = ibool(NGLLX,1,1,ispec)
+ faces_surface_ext_mesh(2,nfaces_surface_ext_mesh) = ibool(NGLLX,NGLLY,1,ispec)
+ faces_surface_ext_mesh(3,nfaces_surface_ext_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ faces_surface_ext_mesh(4,nfaces_surface_ext_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
+ endif
+ endif
+ endif
+ enddo ! NSPEC_AB
+
+ ! checks number of faces
+ if( nfaces_surface_ext_mesh /= nfaces_org ) then
+ print*,'error number of movie faces: ',nfaces_surface_ext_mesh,nfaces_org
+ call exit_mpi(myrank,'error number of faces')
+ endif
+ endif
+
+ ! user output
+ if (myrank == 0) then
+ if( PLOT_CROSS_SECTIONS ) then
+ write(IMAIN,*) 'movie cross-sections:'
+ else
+ write(IMAIN,*) 'movie surface:'
+ endif
+ write(IMAIN,*) ' nfaces_surface_ext_mesh:',nfaces_surface_ext_mesh
+ write(IMAIN,*) ' nfaces_perproc_surface_ext_mesh:',nfaces_perproc_surface_ext_mesh
+ write(IMAIN,*) ' nfaces_surface_glob_ext_mesh:',nfaces_surface_glob_ext_mesh
+
+ ! updates number of surface elements in an include file for the movies
+ if( nfaces_surface_glob_ext_mesh > 0 ) then
+ filename = 'OUTPUT_FILES/surface_from_mesher.h'
+ open(unit=IOUT,file=trim(filename),status='unknown')
+ write(IOUT,*) '!'
+ write(IOUT,*) '! this is the parameter file for static compilation for movie creation'
+ write(IOUT,*) '!'
+ write(IOUT,*) '! number of elements containing surface faces '
+ write(IOUT,*) '! ---------------'
+ write(IOUT,*)
+ write(IOUT,*) 'integer,parameter :: NSPEC_SURFACE_EXT_MESH = ',nfaces_surface_glob_ext_mesh
+ write(IOUT,*)
+ close(IOUT)
+ endif
+
+ endif
+
+
+ end subroutine setup_movie_meshes
+
+
+
+
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/setup_sources_receivers.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/setup_sources_receivers.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/setup_sources_receivers.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,788 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+ subroutine setup_sources_receivers()
+
+ use specfem_par
+ implicit none
+
+! locates sources and determines simulation start time t0
+ call setup_sources()
+
+! reads in stations file and locates receivers
+ call setup_receivers()
+
+! pre-compute source arrays
+ call setup_sources_precompute_arrays()
+
+! pre-compute receiver interpolation factors
+ call setup_receivers_precompute_intp()
+
+! write source and receiver VTK files for Paraview
+ call setup_sources_receivers_VTKfile()
+
+! user output
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Total number of samples for seismograms = ',NSTEP
+ write(IMAIN,*)
+ write(IMAIN,*)
+ write(IMAIN,*) 'found a total of ',nrec_tot_found,' receivers in all the slices'
+ if(NSOURCES > 1) write(IMAIN,*) 'Using ',NSOURCES,' point sources'
+ endif
+
+end subroutine setup_sources_receivers
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine setup_sources()
+
+ use specfem_par
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ use specfem_par_movie
+ implicit none
+
+ double precision :: t0_ac
+ integer :: yr,jda,ho,mi
+ integer :: isource,ispec
+
+! allocate arrays for source
+ allocate(islice_selected_source(NSOURCES))
+ allocate(ispec_selected_source(NSOURCES))
+ allocate(Mxx(NSOURCES))
+ allocate(Myy(NSOURCES))
+ allocate(Mzz(NSOURCES))
+ allocate(Mxy(NSOURCES))
+ allocate(Mxz(NSOURCES))
+ allocate(Myz(NSOURCES))
+ allocate(xi_source(NSOURCES))
+ allocate(eta_source(NSOURCES))
+ allocate(gamma_source(NSOURCES))
+ allocate(t_cmt(NSOURCES))
+ allocate(hdur(NSOURCES))
+ allocate(hdur_gaussian(NSOURCES))
+ allocate(utm_x_source(NSOURCES))
+ allocate(utm_y_source(NSOURCES))
+ allocate(nu_source(3,3,NSOURCES))
+
+! locate sources in the mesh
+!
+! returns: islice_selected_source & ispec_selected_source,
+! xi_source, eta_source & gamma_source
+ call locate_source(ibool,NSOURCES,myrank,NSPEC_AB,NGLOB_AB, &
+ xstore,ystore,zstore,xigll,yigll,zigll,NPROC, &
+ t_cmt,yr,jda,ho,mi,utm_x_source,utm_y_source, &
+ DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ islice_selected_source,ispec_selected_source, &
+ xi_source,eta_source,gamma_source, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ PRINT_SOURCE_TIME_FUNCTION, &
+ nu_source,iglob_is_surface_external_mesh,ispec_is_surface_external_mesh,&
+ ispec_is_acoustic,ispec_is_elastic, &
+ num_free_surface_faces,free_surface_ispec,free_surface_ijk)
+
+ if(minval(t_cmt) /= 0.) call exit_MPI(myrank,'one t_cmt must be zero, others must be positive')
+
+! filter source time function by Gaussian with hdur = HDUR_MOVIE when outputing movies or shakemaps
+ if (MOVIE_SURFACE .or. MOVIE_VOLUME .or. CREATE_SHAKEMAP) then
+ hdur = sqrt(hdur**2 + HDUR_MOVIE**2)
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'Each source is being convolved with HDUR_MOVIE = ',HDUR_MOVIE
+ write(IMAIN,*)
+ endif
+ endif
+
+ ! convert the half duration for triangle STF to the one for gaussian STF
+ hdur_gaussian = hdur/SOURCE_DECAY_MIMIC_TRIANGLE
+
+ ! define t0 as the earliest start time
+ t0 = - 1.5d0 * minval(t_cmt-hdur)
+
+ ! uses an earlier start time if source is acoustic with a gaussian source time function
+ t0_ac = 0.0d0
+ do isource = 1,NSOURCES
+ if( myrank == islice_selected_source(isource) ) then
+ ispec = ispec_selected_source(isource)
+ if( ispec_is_acoustic(ispec) ) then
+ t0_ac = - 3.0d0 * ( t_cmt(isource) - hdur(isource) )
+ if( t0_ac > t0 ) t0 = t0_ac
+ endif
+ endif
+ enddo
+
+ ! passes maximum value to all processes
+ ! note: t0 is defined positive and will be subtracted from simulation time (it-1)*DT
+ t0_ac = t0
+ call max_all_all_dp(t0_ac,t0)
+
+ ! checks if source is in an acoustic element and exactly on the free surface because pressure is zero there
+ call setup_sources_check_acoustic()
+
+end subroutine setup_sources
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+subroutine setup_sources_check_acoustic()
+
+! checks if source is in an acoustic element and exactly on the free surface because pressure is zero there
+
+ use specfem_par
+ use specfem_par_acoustic
+ implicit none
+
+ integer :: isource,ixmin,ixmax,iymin,iymax,izmin,izmax,iface,ispec
+ logical :: is_on,is_on_all
+
+! outputs a warning in case of an acoustic source lying on the free surface
+ do isource = 1,NSOURCES
+ ! checks if source is close to face
+ is_on = .false.
+
+ ! only receivers in this process
+ if( myrank == islice_selected_source(isource) ) then
+
+ ispec = ispec_selected_source(isource)
+ ! only if receiver is in an acoustic element
+ if( ispec_is_acoustic(ispec) ) then
+
+ ! checks with free surface face
+ do iface = 1,num_free_surface_faces
+
+ if( ispec == free_surface_ispec(iface) ) then
+
+ ! determine face
+ ixmin = minval( free_surface_ijk(1,:,iface) )
+ ixmax = maxval( free_surface_ijk(1,:,iface) )
+
+ iymin = minval( free_surface_ijk(2,:,iface) )
+ iymax = maxval( free_surface_ijk(2,:,iface) )
+
+ izmin = minval( free_surface_ijk(3,:,iface) )
+ izmax = maxval( free_surface_ijk(3,:,iface) )
+
+ if( .not. USE_FORCE_POINT_SOURCE ) then
+ ! xmin face
+ if(ixmin==1 .and. ixmax==1) then
+ if( xi_source(isource) < -0.99d0) is_on = .true.
+ ! xmax face
+ else if(ixmin==NGLLX .and. ixmax==NGLLX) then
+ if( xi_source(isource) > 0.99d0) is_on = .true.
+ ! ymin face
+ else if(iymin==1 .and. iymax==1) then
+ if( eta_source(isource) < -0.99d0) is_on = .true.
+ ! ymax face
+ else if(iymin==NGLLY .and. iymax==NGLLY) then
+ if( eta_source(isource) > 0.99d0) is_on = .true.
+ ! zmin face
+ else if(izmin==1 .and. izmax==1 ) then
+ if( gamma_source(isource) < -0.99d0) is_on = .true.
+ ! zmax face
+ else if(izmin==NGLLZ .and. izmax==NGLLZ ) then
+ if( gamma_source(isource) > 0.99d0) is_on = .true.
+ endif
+ else
+ ! note: for use_force_point_source xi/eta/gamma_source values are in the range [1,NGLL*]
+ ! xmin face
+ if(ixmin==1 .and. ixmax==1) then
+ if( nint(xi_source(isource)) == 1) is_on = .true.
+ ! xmax face
+ else if(ixmin==NGLLX .and. ixmax==NGLLX) then
+ if( nint(xi_source(isource)) == NGLLX) is_on = .true.
+ ! ymin face
+ else if(iymin==1 .and. iymax==1) then
+ if( nint(eta_source(isource)) == 1) is_on = .true.
+ ! ymax face
+ else if(iymin==NGLLY .and. iymax==NGLLY) then
+ if( nint(eta_source(isource)) == NGLLY) is_on = .true.
+ ! zmin face
+ else if(izmin==1 .and. izmax==1 ) then
+ if( nint(gamma_source(isource)) == 1) is_on = .true.
+ ! zmax face
+ else if(izmin==NGLLZ .and. izmax==NGLLZ ) then
+ if( nint(gamma_source(isource)) ==NGLLZ) is_on = .true.
+ endif
+ endif
+
+ endif ! free_surface_ispec
+ enddo ! iface
+ endif ! ispec_is_acoustic
+ endif ! islice_selected_rec
+
+ ! user output
+ call any_all_l( is_on, is_on_all )
+ if( myrank == 0 .and. is_on_all ) then
+ write(IMAIN,*) '**********************************************************************'
+ write(IMAIN,*) '*** source: ',isource,' ***'
+ write(IMAIN,*) '*** Warning: acoustic source located exactly on the free surface ***'
+ write(IMAIN,*) '*** will be zeroed ***'
+ write(IMAIN,*) '**********************************************************************'
+ write(IMAIN,*)
+ endif
+
+ enddo ! num_free_surface_faces
+
+
+end subroutine setup_sources_check_acoustic
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine setup_receivers()
+
+ use specfem_par
+ use specfem_par_acoustic
+ implicit none
+
+ integer :: irec,isource !,ios
+
+! reads in station file
+ if (SIMULATION_TYPE == 1) then
+ call get_value_string(rec_filename, 'solver.STATIONS', 'DATA/STATIONS')
+ call get_value_string(filtered_rec_filename, 'solver.STATIONS_FILTERED', 'DATA/STATIONS_FILTERED')
+ call station_filter(SUPPRESS_UTM_PROJECTION,UTM_PROJECTION_ZONE,myrank,rec_filename,filtered_rec_filename,nrec, &
+ LATITUDE_MIN, LATITUDE_MAX, LONGITUDE_MIN, LONGITUDE_MAX)
+
+ ! 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)
+ if(nrec < 1) call exit_MPI(myrank,'need at least one receiver')
+ call sync_all()
+
+ else
+ call get_value_string(rec_filename, 'solver.STATIONS', 'DATA/STATIONS_ADJOINT')
+ call get_value_string(filtered_rec_filename, 'solver.STATIONS_FILTERED', 'DATA/STATIONS_ADJOINT_FILTERED')
+ call station_filter(SUPPRESS_UTM_PROJECTION,UTM_PROJECTION_ZONE,myrank,rec_filename,filtered_rec_filename,nrec, &
+ LATITUDE_MIN, LATITUDE_MAX, LONGITUDE_MIN, LONGITUDE_MAX)
+ if (nrec < 1) call exit_MPI(myrank, 'adjoint simulation needs at least one receiver')
+ call sync_all()
+ endif
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ write(IMAIN,*) 'Total number of receivers = ', nrec
+ else
+ write(IMAIN,*) 'Total number of adjoint sources = ', nrec
+ endif
+ write(IMAIN,*)
+ endif
+
+ if(nrec < 1) call exit_MPI(myrank,'need at least one receiver')
+
+! allocate memory for receiver arrays
+ allocate(islice_selected_rec(nrec))
+ allocate(ispec_selected_rec(nrec))
+ allocate(xi_receiver(nrec))
+ allocate(eta_receiver(nrec))
+ allocate(gamma_receiver(nrec))
+ allocate(station_name(nrec))
+ allocate(network_name(nrec))
+ allocate(nu(NDIM,NDIM,nrec))
+
+! locate receivers in the mesh
+ call locate_receivers(ibool,myrank,NSPEC_AB,NGLOB_AB, &
+ xstore,ystore,zstore,xigll,yigll,zigll,filtered_rec_filename, &
+ nrec,islice_selected_rec,ispec_selected_rec, &
+ xi_receiver,eta_receiver,gamma_receiver,station_name,network_name,nu, &
+ NPROC,utm_x_source(1),utm_y_source(1), &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ iglob_is_surface_external_mesh,ispec_is_surface_external_mesh, &
+ num_free_surface_faces,free_surface_ispec,free_surface_ijk)
+
+! count number of receivers located in this slice
+ nrec_local = 0
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ nrec_simulation = nrec
+ do irec = 1,nrec
+ if(myrank == islice_selected_rec(irec)) nrec_local = nrec_local + 1
+ enddo
+ else
+ ! adjoint simulation: receivers become adjoint sources
+ nrec_simulation = NSOURCES
+ do isource = 1, NSOURCES
+ if(myrank == islice_selected_source(isource)) nrec_local = nrec_local + 1
+ enddo
+ endif
+
+! checks if acoustic receiver is exactly on the free surface because pressure is zero there
+ call setup_receivers_check_acoustic()
+
+end subroutine setup_receivers
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine setup_receivers_check_acoustic()
+
+! checks if acoustic receiver is exactly on the free surface because pressure is zero there
+
+ use specfem_par
+ use specfem_par_acoustic
+ implicit none
+
+ integer :: irec,ixmin,ixmax,iymin,iymax,izmin,izmax,iface,ispec
+ logical :: is_on,is_on_all
+
+! outputs a warning in case the receiver is lying on the free surface
+ do irec = 1,nrec
+
+ ! checks if receiver is close to face
+ is_on = .false.
+
+ ! only receivers in this process
+ if( myrank == islice_selected_rec(irec) ) then
+
+ ispec = ispec_selected_rec(irec)
+ ! only if receiver is in an acoustic element
+ if( ispec_is_acoustic(ispec) ) then
+
+ ! checks with free surface face
+ do iface = 1,num_free_surface_faces
+
+ if( ispec == free_surface_ispec(iface) ) then
+
+ ! determine face
+ ixmin = minval( free_surface_ijk(1,:,iface) )
+ ixmax = maxval( free_surface_ijk(1,:,iface) )
+
+ iymin = minval( free_surface_ijk(2,:,iface) )
+ iymax = maxval( free_surface_ijk(2,:,iface) )
+
+ izmin = minval( free_surface_ijk(3,:,iface) )
+ izmax = maxval( free_surface_ijk(3,:,iface) )
+
+ ! xmin face
+ if(ixmin==1 .and. ixmax==1) then
+ if( xi_receiver(irec) < -0.99d0) is_on = .true.
+ ! xmax face
+ else if(ixmin==NGLLX .and. ixmax==NGLLX) then
+ if( xi_receiver(irec) > 0.99d0) is_on = .true.
+ ! ymin face
+ else if(iymin==1 .and. iymax==1) then
+ if( eta_receiver(irec) < -0.99d0) is_on = .true.
+ ! ymax face
+ else if(iymin==NGLLY .and. iymax==NGLLY) then
+ if( eta_receiver(irec) > 0.99d0) is_on = .true.
+ ! zmin face
+ else if(izmin==1 .and. izmax==1 ) then
+ if( gamma_receiver(irec) < -0.99d0) is_on = .true.
+ ! zmax face
+ else if(izmin==NGLLZ .and. izmax==NGLLZ ) then
+ if( gamma_receiver(irec) > 0.99d0) is_on = .true.
+ endif
+
+ endif ! free_surface_ispec
+ enddo ! iface
+ endif ! ispec_is_acoustic
+ endif ! islice_selected_rec
+
+ ! user output
+ call any_all_l( is_on, is_on_all )
+ if( myrank == 0 .and. is_on_all ) then
+ write(IMAIN,*) '**********************************************************************'
+ write(IMAIN,*) '*** station:',irec,' ***'
+ write(IMAIN,*) '*** Warning: acoustic receiver located exactly on the free surface ***'
+ write(IMAIN,*) '*** Warning: tangential component will be zero there ***'
+ write(IMAIN,*) '**********************************************************************'
+ write(IMAIN,*)
+ endif
+
+ enddo ! num_free_surface_faces
+
+end subroutine setup_receivers_check_acoustic
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine setup_sources_precompute_arrays()
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ implicit none
+
+ real(kind=CUSTOM_REAL) :: factor_source
+ real(kind=CUSTOM_REAL) :: junk
+ integer :: isource,ispec
+ integer :: irec,irec_local
+ integer :: icomp,itime,nadj_files_found,nadj_files_found_tot,ier
+ character(len=3),dimension(NDIM) :: comp = (/ "BHN", "BHE", "BHZ" /)
+ character(len=150) :: filename
+
+
+! forward simulations
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ allocate(sourcearray(NDIM,NGLLX,NGLLY,NGLLZ))
+ allocate(sourcearrays(NSOURCES,NDIM,NGLLX,NGLLY,NGLLZ))
+
+ ! compute source arrays
+ do isource = 1,NSOURCES
+
+ ! check that the source slice number is okay
+ if(islice_selected_source(isource) < 0 .or. islice_selected_source(isource) > NPROC-1) &
+ call exit_MPI(myrank,'something is wrong with the source slice number')
+
+ ! compute source arrays in source slice
+ if(myrank == islice_selected_source(isource)) then
+
+ ispec = ispec_selected_source(isource)
+
+ ! elastic moment tensor source
+ if( ispec_is_elastic(ispec) ) then
+ call compute_arrays_source(ispec, &
+ xi_source(isource),eta_source(isource),gamma_source(isource),sourcearray, &
+ Mxx(isource),Myy(isource),Mzz(isource),Mxy(isource),Mxz(isource),Myz(isource), &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ xigll,yigll,zigll,NSPEC_AB)
+ endif
+
+ ! acoustic case
+ if( ispec_is_acoustic(ispec) ) then
+ ! scalar moment of moment tensor values read in from CMTSOLUTION
+ ! note: M0 by Dahlen and Tromp, eq. 5.91
+ factor_source = 1.0/sqrt(2.0) * sqrt( Mxx(isource)**2 + Myy(isource)**2 + Mzz(isource)**2 &
+ + 2*( Myz(isource)**2 + Mxz(isource)**2 + Mxy(isource)**2 ) )
+
+ ! scales source such that it would be equivalent to explosion source moment tensor,
+ ! where Mxx=Myy=Mzz, others Mxy,.. = zero, in equivalent elastic media
+ ! (and getting rid of 1/sqrt(2) factor from scalar moment tensor definition above)
+ factor_source = factor_source * sqrt(2.0) / sqrt(3.0)
+
+ ! source array interpolated on all element gll points
+ call compute_arrays_source_acoustic(xi_source(isource),eta_source(isource),gamma_source(isource),&
+ sourcearray,xigll,yigll,zigll,factor_source)
+ endif
+
+ ! stores source excitations
+ sourcearrays(isource,:,:,:,:) = sourcearray(:,:,:,:)
+
+ endif
+ enddo
+ endif
+
+! ADJOINT simulations
+ if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
+
+ ! counts local receivers which become adjoint sources
+ nadj_rec_local = 0
+ ! temporary counter to check if any files are found at all
+ nadj_files_found = 0
+ do irec = 1,nrec
+ if( myrank == islice_selected_rec(irec) ) then
+ ! checks that the source slice number is okay
+ if(islice_selected_rec(irec) < 0 .or. islice_selected_rec(irec) > NPROC-1) &
+ call exit_MPI(myrank,'something is wrong with the source slice number in adjoint simulation')
+
+ ! updates counter
+ nadj_rec_local = nadj_rec_local + 1
+
+ ! checks **sta**.**net**.**BH**.adj files for correct number of time steps
+ adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
+ do icomp = 1,NDIM
+ filename = 'SEM/'//trim(adj_source_file) // '.'// comp(icomp) // '.adj'
+ open(unit=IIN,file=trim(filename),status='old',action='read',iostat=ier)
+ if( ier == 0 ) then
+ ! checks length of file
+ itime = 0
+ do while(ier == 0)
+ read(IIN,*,iostat=ier) junk,junk
+ if( ier == 0 ) itime = itime + 1
+ enddo
+ if( itime /= NSTEP) &
+ call exit_MPI(myrank,&
+ 'file '//trim(filename)//' has wrong length, please check with your simulation duration')
+ nadj_files_found = nadj_files_found + 1
+ endif
+ close(IIN)
+ enddo
+ endif
+ enddo
+ ! checks if any adjoint source files found at all
+ call sum_all_i(nadj_files_found,nadj_files_found_tot)
+ if( myrank == 0 ) then
+ write(IMAIN,*)
+ write(IMAIN,*) ' ',nadj_files_found_tot,' adjoint component traces found in all slices'
+ if(nadj_files_found_tot == 0) &
+ call exit_MPI(myrank,'no adjoint traces found, please check adjoint sources in directory SEM/')
+ endif
+
+ ! reads in adjoint source traces
+ allocate(adj_sourcearray(NSTEP,NDIM,NGLLX,NGLLY,NGLLZ))
+ allocate(adj_sourcearrays(nadj_rec_local,NSTEP,NDIM,NGLLX,NGLLY,NGLLZ))
+ adj_sourcearrays = 0._CUSTOM_REAL
+ adj_sourcearray = 0._CUSTOM_REAL
+
+ ! pre-computes adjoint source arrays
+ irec_local = 0
+ do irec = 1, nrec
+ ! computes only adjoint source arrays in the local slice
+ if( myrank == islice_selected_rec(irec) ) then
+ irec_local = irec_local + 1
+
+ ! reads in **sta**.**net**.**BH**.adj files
+ adj_source_file = trim(station_name(irec))//'.'//trim(network_name(irec))
+
+ call compute_arrays_adjoint_source(myrank, adj_source_file, &
+ xi_receiver(irec), eta_receiver(irec), gamma_receiver(irec), &
+ adj_sourcearray, xigll,yigll,zigll,NSTEP)
+
+ adj_sourcearrays(irec_local,:,:,:,:,:) = adj_sourcearray(:,:,:,:,:)
+
+ endif
+ enddo
+ ! frees temporary array
+ deallocate(adj_sourcearray)
+ endif
+
+end subroutine setup_sources_precompute_arrays
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine setup_receivers_precompute_intp()
+
+ use specfem_par
+ implicit none
+
+ integer :: irec,irec_local,isource
+
+! stores local receivers interpolation factors
+ if (nrec_local > 0) then
+ ! allocate Lagrange interpolators for receivers
+ allocate(hxir_store(nrec_local,NGLLX))
+ allocate(hetar_store(nrec_local,NGLLY))
+ allocate(hgammar_store(nrec_local,NGLLZ))
+
+ ! define local to global receiver numbering mapping
+ allocate(number_receiver_global(nrec_local))
+ irec_local = 0
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ do irec = 1,nrec
+ if(myrank == islice_selected_rec(irec)) then
+ irec_local = irec_local + 1
+ number_receiver_global(irec_local) = irec
+ endif
+ enddo
+ else
+ do isource = 1,NSOURCES
+ if(myrank == islice_selected_source(isource)) then
+ irec_local = irec_local + 1
+ number_receiver_global(irec_local) = isource
+ endif
+ enddo
+ endif
+
+ ! define and store Lagrange interpolators at all the receivers
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ do irec_local = 1,nrec_local
+ irec = number_receiver_global(irec_local)
+ call lagrange_any(xi_receiver(irec),NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(eta_receiver(irec),NGLLY,yigll,hetar,hpetar)
+ call lagrange_any(gamma_receiver(irec),NGLLZ,zigll,hgammar,hpgammar)
+ hxir_store(irec_local,:) = hxir(:)
+ hetar_store(irec_local,:) = hetar(:)
+ hgammar_store(irec_local,:) = hgammar(:)
+ enddo
+ else
+ allocate(hpxir_store(nrec_local,NGLLX))
+ allocate(hpetar_store(nrec_local,NGLLY))
+ allocate(hpgammar_store(nrec_local,NGLLZ))
+ do irec_local = 1,nrec_local
+ irec = number_receiver_global(irec_local)
+ call lagrange_any(xi_source(irec),NGLLX,xigll,hxir,hpxir)
+ call lagrange_any(eta_source(irec),NGLLY,yigll,hetar,hpetar)
+ call lagrange_any(gamma_source(irec),NGLLZ,zigll,hgammar,hpgammar)
+ hxir_store(irec_local,:) = hxir(:)
+ hetar_store(irec_local,:) = hetar(:)
+ hgammar_store(irec_local,:) = hgammar(:)
+ hpxir_store(irec_local,:) = hpxir(:)
+ hpetar_store(irec_local,:) = hpetar(:)
+ hpgammar_store(irec_local,:) = hpgammar(:)
+ enddo
+ endif
+ endif ! nrec_local > 0
+
+! check that the sum of the number of receivers in each slice is nrec
+ call sum_all_i(nrec_local,nrec_tot_found)
+ if( myrank == 0 ) then
+ if(nrec_tot_found /= nrec_simulation) then
+ call exit_MPI(myrank,'problem when dispatching the receivers')
+ endif
+ endif
+
+
+end subroutine setup_receivers_precompute_intp
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+subroutine setup_sources_receivers_VTKfile()
+
+ use specfem_par
+ implicit none
+
+ double precision :: shape3D(NGNOD)
+ double precision :: xil,etal,gammal
+ double precision :: xmesh,ymesh,zmesh
+
+ real(kind=CUSTOM_REAL),dimension(NGNOD) :: xelm,yelm,zelm
+
+ integer :: ia,ispec,isource,irec
+
+ if (myrank == 0) then
+ ! vtk file
+ open(IOVTK,file=trim(OUTPUT_FILES)//'/sr.vtk',status='unknown')
+ write(IOVTK,'(a)') '# vtk DataFile Version 2.0'
+ write(IOVTK,'(a)') 'Source and Receiver VTK file'
+ write(IOVTK,'(a)') 'ASCII'
+ write(IOVTK,'(a)') 'DATASET POLYDATA'
+ write(IOVTK, '(a,i6,a)') 'POINTS ', NSOURCES+nrec, ' float'
+ endif
+
+ ! sources
+ do isource=1,NSOURCES
+ ! spectral element id
+ ispec = ispec_selected_source(isource)
+
+ ! gets element ancor nodes
+ if( myrank == islice_selected_source(isource) ) then
+ ! find the coordinates of the eight corner nodes of the element
+ call get_shape3D_element_corners(xelm,yelm,zelm,ispec,&
+ ibool,xstore,ystore,zstore,NSPEC_AB,NGLOB_AB)
+
+ endif
+ ! master collects corner locations
+ if( islice_selected_source(isource) /= 0 ) then
+ if( myrank == 0 ) then
+ call recvv_cr(xelm,NGNOD,islice_selected_source(isource),0)
+ call recvv_cr(yelm,NGNOD,islice_selected_source(isource),0)
+ call recvv_cr(zelm,NGNOD,islice_selected_source(isource),0)
+ else if( myrank == islice_selected_source(isource) ) then
+ call sendv_cr(xelm,NGNOD,0,0)
+ call sendv_cr(yelm,NGNOD,0,0)
+ call sendv_cr(zelm,NGNOD,0,0)
+ endif
+ endif
+
+ if( myrank == 0 ) then
+ ! get the 3-D shape functions
+ xil = xi_source(isource)
+ etal = eta_source(isource)
+ gammal = gamma_source(isource)
+ call get_shape3D_single(myrank,shape3D,xil,etal,gammal)
+
+ ! interpolates source locations
+ xmesh = 0.0
+ ymesh = 0.0
+ zmesh = 0.0
+ do ia=1,NGNOD
+ xmesh = xmesh + shape3D(ia)*xelm(ia)
+ ymesh = ymesh + shape3D(ia)*yelm(ia)
+ zmesh = zmesh + shape3D(ia)*zelm(ia)
+ enddo
+
+ ! writes out to VTK file
+ write(IOVTK,*) xmesh,ymesh,zmesh
+ endif
+ enddo ! NSOURCES
+
+ ! receivers
+ do irec=1,nrec
+ ispec = ispec_selected_rec(irec)
+
+ ! find the coordinates of the eight corner nodes of the element
+ if( myrank == islice_selected_rec(irec) ) then
+ call get_shape3D_element_corners(xelm,yelm,zelm,ispec,&
+ ibool,xstore,ystore,zstore,NSPEC_AB,NGLOB_AB)
+ endif
+ ! master collects corner locations
+ if( islice_selected_rec(irec) /= 0 ) then
+ if( myrank == 0 ) then
+ call recvv_cr(xelm,NGNOD,islice_selected_rec(irec),0)
+ call recvv_cr(yelm,NGNOD,islice_selected_rec(irec),0)
+ call recvv_cr(zelm,NGNOD,islice_selected_rec(irec),0)
+ else if( myrank == islice_selected_rec(irec) ) then
+ call sendv_cr(xelm,NGNOD,0,0)
+ call sendv_cr(yelm,NGNOD,0,0)
+ call sendv_cr(zelm,NGNOD,0,0)
+ endif
+ endif
+
+ if( myrank == 0 ) then
+ ! get the 3-D shape functions
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ xil = xi_receiver(irec)
+ etal = eta_receiver(irec)
+ gammal = gamma_receiver(irec)
+ else
+ xil = xi_source(irec)
+ etal = eta_source(irec)
+ gammal = gamma_source(irec)
+ endif
+ call get_shape3D_single(myrank,shape3D,xil,etal,gammal)
+
+ ! interpolates receiver locations
+ xmesh = 0.0
+ ymesh = 0.0
+ zmesh = 0.0
+ do ia=1,NGNOD
+ xmesh = xmesh + shape3D(ia)*xelm(ia)
+ ymesh = ymesh + shape3D(ia)*yelm(ia)
+ zmesh = zmesh + shape3D(ia)*zelm(ia)
+ enddo
+
+ ! writes out to VTK file
+ write(IOVTK,*) xmesh,ymesh,zmesh
+ endif
+ enddo
+
+ ! closes vtk file
+ if( myrank == 0 ) then
+ write(IOVTK,*)
+ close(IOVTK)
+ endif
+
+end subroutine setup_sources_receivers_VTKfile
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/socal_model.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/socal_model.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/socal_model.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,63 @@
+!=====================================================================
+!
+! 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 socal_model(idoubling,rho,vp,vs)
+
+ implicit none
+
+ include "constants.h"
+ include "constants_gocad.h"
+
+ integer idoubling
+ double precision rho,vp,vs
+
+ if(idoubling == IFLAG_HALFSPACE_MOHO) then
+ vp=7.8d0
+ vs=4.5d0
+ rho=3.0d0
+
+ else if(idoubling == IFLAG_MOHO_16km) then
+ vp=6.7d0
+ vs=3.87d0
+ rho=2.8d0
+
+ else if(idoubling == IFLAG_ONE_LAYER_TOPOGRAPHY .or. idoubling == IFLAG_BASEMENT_TOPO) then
+ vp=5.5d0
+ vs=3.18d0
+ rho=2.4d0
+
+ else
+ vp=6.3d0
+ vs=3.64d0
+ rho=2.67d0
+ endif
+
+! scale to standard units
+ vp = vp * 1000.d0
+ vs = vs * 1000.d0
+ rho = rho * 1000.d0
+
+ end subroutine socal_model
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/sort_array_coordinates.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/sort_array_coordinates.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/sort_array_coordinates.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,237 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 4 . 0
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Seismological Laboratory, California Institute of Technology, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) California Institute of Technology and University of Pau / CNRS / INRIA
+! February 2008
+!
+! 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.
+!
+!=====================================================================
+
+! subroutines to sort MPI buffers to assemble between chunks
+
+ subroutine sort_array_coordinates(npointot,x,y,z,ibool,iglob,loc,ifseg,nglob,ind,ninseg,iwork,work)
+
+! this routine MUST be in double precision to avoid sensitivity
+! to roundoff errors in the coordinates of the points
+!
+! returns: sorted indexing array (ibool), reordering array (iglob) & number of global points (nglob)
+
+ implicit none
+
+ include "constants.h"
+
+ integer npointot,nglob
+
+ integer ibool(npointot),iglob(npointot),loc(npointot)
+ integer ind(npointot),ninseg(npointot)
+ logical ifseg(npointot)
+ double precision x(npointot),y(npointot),z(npointot)
+ integer iwork(npointot)
+ double precision work(npointot)
+
+ integer ipoin,i,j
+ integer nseg,ioff,iseg,ig
+ double precision xtol
+
+! establish initial pointers
+ do ipoin=1,npointot
+ loc(ipoin)=ipoin
+ enddo
+
+! define a tolerance, normalized radius is 1., so let's use a small value
+ xtol = SMALLVAL_TOL
+
+ ifseg(:)=.false.
+
+ nseg=1
+ ifseg(1)=.true.
+ ninseg(1)=npointot
+
+ do j=1,NDIM
+
+! sort within each segment
+ ioff=1
+ do iseg=1,nseg
+ if(j == 1) then
+
+ call rank_buffers(x(ioff),ind,ninseg(iseg))
+
+ else if(j == 2) then
+
+ call rank_buffers(y(ioff),ind,ninseg(iseg))
+
+ else
+
+ call rank_buffers(z(ioff),ind,ninseg(iseg))
+
+ endif
+
+ call swap_all_buffers(ibool(ioff),loc(ioff), &
+ x(ioff),y(ioff),z(ioff),iwork,work,ind,ninseg(iseg))
+
+ ioff=ioff+ninseg(iseg)
+ enddo
+
+! check for jumps in current coordinate
+ if(j == 1) then
+ do i=2,npointot
+ if(dabs(x(i)-x(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ else if(j == 2) then
+ do i=2,npointot
+ if(dabs(y(i)-y(i-1)) > xtol) ifseg(i)=.true.
+ enddo
+ else
+ do i=2,npointot
+ if(dabs(z(i)-z(i-1)) > xtol) 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
+ do i=1,npointot
+ if(ifseg(i)) ig=ig+1
+ iglob(loc(i))=ig
+ enddo
+
+ nglob=ig
+
+ end subroutine sort_array_coordinates
+
+! -------------------- library for sorting routine ------------------
+
+! sorting routines put here in same file to allow for inlining
+
+ subroutine rank_buffers(A,IND,N)
+!
+! Use Heap Sort (Numerical Recipes)
+!
+ implicit none
+
+ integer n
+ double precision A(n)
+ integer IND(n)
+
+ integer i,j,l,ir,indx
+ double precision q
+
+ do j=1,n
+ IND(j)=j
+ enddo
+
+ if(n == 1) return
+
+ L=n/2+1
+ ir=n
+ 100 CONTINUE
+ IF(l>1) THEN
+ l=l-1
+ indx=ind(l)
+ q=a(indx)
+ ELSE
+ indx=ind(ir)
+ q=a(indx)
+ ind(ir)=ind(1)
+ ir=ir-1
+ if (ir == 1) then
+ ind(1)=indx
+ return
+ endif
+ ENDIF
+ i=l
+ j=l+l
+ 200 CONTINUE
+ IF(J <= IR) THEN
+ IF(J < IR) THEN
+ IF(A(IND(j)) < A(IND(j+1))) j=j+1
+ ENDIF
+ IF (q < A(IND(j))) THEN
+ IND(I)=IND(J)
+ I=J
+ J=J+J
+ ELSE
+ J=IR+1
+ ENDIF
+ goto 200
+ ENDIF
+ IND(I)=INDX
+ goto 100
+ end subroutine rank_buffers
+
+! -------------------------------------------------------------------
+
+ subroutine swap_all_buffers(IA,IB,A,B,C,IW,W,ind,n)
+!
+! swap arrays IA, IB, A, B and C according to addressing in array IND
+!
+ implicit none
+
+ integer n
+
+ integer IND(n)
+ integer IA(n),IB(n),IW(n)
+ double precision A(n),B(n),C(n),W(n)
+
+ integer i
+
+ do i=1,n
+ W(i)=A(i)
+ IW(i)=IA(i)
+ enddo
+
+ do i=1,n
+ A(i)=W(ind(i))
+ IA(i)=IW(ind(i))
+ enddo
+
+ do i=1,n
+ W(i)=B(i)
+ IW(i)=IB(i)
+ enddo
+
+ do i=1,n
+ B(i)=W(ind(i))
+ IB(i)=IW(ind(i))
+ enddo
+
+ do i=1,n
+ W(i)=C(i)
+ enddo
+
+ do i=1,n
+ C(i)=W(ind(i))
+ enddo
+
+ end subroutine swap_all_buffers
+
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/specfem3D.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/specfem3D.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/specfem3D.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,226 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+ subroutine specfem3D
+
+ use specfem_par
+
+
+!=============================================================================!
+! !
+! specfem3D is a 3-D spectral-element solver for a local or regional model. !
+! It uses a mesh generated by program generate_databases !
+! !
+!=============================================================================!
+!
+! If you use this code for your own research, please cite at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @ARTICLE{LiPoKoTr04,
+! author = {Qinya Liu and Jascha Polet and Dimitri Komatitsch and Jeroen Tromp},
+! title = {Spectral-element moment tensor inversions for earthquakes in {S}outhern {C}alifornia},
+! journal={Bull. Seismol. Soc. Am.},
+! year = {2004},
+! volume = {94},
+! pages = {1748-1761},
+! number = {5},
+! doi = {10.1785/012004038}}
+!
+! @INCOLLECTION{ChKoViCaVaFe07,
+! author = {Emmanuel Chaljub and Dimitri Komatitsch and Jean-Pierre Vilotte and
+! Yann Capdeville and Bernard Valette and Gaetano Festa},
+! title = {Spectral Element Analysis in Seismology},
+! booktitle = {Advances in Wave Propagation in Heterogeneous Media},
+! publisher = {Elsevier - Academic Press},
+! year = {2007},
+! editor = {Ru-Shan Wu and Val\'erie Maupin},
+! volume = {48},
+! series = {Advances in Geophysics},
+! pages = {365-419}}
+!
+! @ARTICLE{KoVi98,
+! author={D. Komatitsch and J. P. Vilotte},
+! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
+! journal={Bull. Seismol. Soc. Am.},
+! year=1998,
+! volume=88,
+! number=2,
+! pages={368-392}}
+!
+! @ARTICLE{KoTr99,
+! author={D. Komatitsch and J. Tromp},
+! year=1999,
+! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
+! journal={Geophys. J. Int.},
+! volume=139,
+! number=3,
+! pages={806-822},
+! doi={10.1046/j.1365-246x.1999.00967.x}}
+!
+! @ARTICLE{KoLiTrSuStSh04,
+! author={Dimitri Komatitsch and Qinya Liu and Jeroen Tromp and Peter S\"{u}ss
+! and Christiane Stidham and John H. Shaw},
+! year=2004,
+! title={Simulations of Ground Motion in the {L}os {A}ngeles {B}asin
+! based upon the Spectral-Element Method},
+! journal={Bull. Seism. Soc. Am.},
+! volume=94,
+! number=1,
+! pages={187-206}}
+!
+! and/or another article from http://web.univ-pau.fr/~dkomati1/publications.html
+!
+!
+! If you use the kernel capabilities of the code, please cite at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @ARTICLE{LiTr06,
+! author={Qinya Liu and Jeroen Tromp},
+! title={Finite-frequency kernels based on adjoint methods},
+! journal={Bull. Seismol. Soc. Am.},
+! year=2006,
+! volume=96,
+! number=6,
+! pages={2383-2397},
+! doi={10.1785/0120060041}}
+!
+!
+! Reference frame - convention:
+! ----------------------------
+!
+! The code uses the following convention for the reference frame:
+!
+! - X axis is East
+! - Y axis is North
+! - Z axis is up
+!
+! Note that this convention is different from both the Aki-Richards convention
+! and the Harvard CMT convention.
+!
+! Let us recall that the Aki-Richards convention is:
+!
+! - X axis is North
+! - Y axis is East
+! - Z axis is down
+!
+! and that the Harvard CMT convention is:
+!
+! - X axis is South
+! - Y axis is East
+! - Z axis is up
+!
+! To report bugs or suggest improvements to the code, please send an email
+! to Jeroen Tromp <jtromp AT princeton.edu> and/or use our online
+! bug tracking system at http://www.geodynamics.org/roundup .
+!
+! Evolution of the code:
+! ---------------------
+!
+! MPI v. 2.0 "SESAME" (Spectral ElementS on Any MEsh), Fall 2009:
+! Dimitri Komatitsch, Nicolas Le Goff, Roland Martin and Pieyre Le Loher, University of Pau, France,
+! Jeroen Tromp and the Princeton group of developers, Princeton University, USA,
+! and Emanuele Casarotti, INGV Roma, Italy:
+! support for CUBIT meshes decomposed by SCOTCH, METIS or ZOLTAN;
+! much faster solver using Michel Deville's inlined matrix products.
+!
+! MPI v. 1.4 Dimitri Komatitsch, University of Pau, Qinya Liu and others, Caltech, September 2006:
+! better adjoint and kernel calculations, faster and better I/Os
+! on very large systems, many small improvements and bug fixes
+!
+! MPI v. 1.3 Dimitri Komatitsch, University of Pau, and Qinya Liu, Caltech, July 2005:
+! serial version, regular mesh, adjoint and kernel calculations, ParaView support
+!
+! MPI v. 1.2 Min Chen and Dimitri Komatitsch, Caltech, July 2004:
+! full anisotropy, volume movie
+!
+! MPI v. 1.1 Dimitri Komatitsch, Caltech, October 2002: Zhu's Moho map, scaling
+! of Vs with depth, Hauksson's regional model, attenuation, oceans, movies
+!
+! MPI v. 1.0 Dimitri Komatitsch, Caltech, May 2002: first MPI version based on global code
+
+! ************** PROGRAM STARTS HERE **************
+
+! reads in parameters
+ call initialize_simulation()
+
+
+! reads in external mesh
+ call read_mesh_databases()
+
+
+! sets up reference element GLL points/weights/derivatives
+ call setup_GLL_points()
+
+
+! detects surfaces
+ call detect_mesh_surfaces()
+
+
+! reads topography & bathymetry
+ call read_topography_bathymetry()
+
+
+! prepares sources and receivers
+ call setup_sources_receivers()
+
+
+! sets up and precomputes simulation array
+ call prepare_timerun()
+
+
+! steps through time iterations
+ call iterate_time()
+
+
+! saves last time frame and finishes kernel calculations
+ call finalize_simulation()
+
+
+ end subroutine specfem3D
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/specfem3D_par.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/specfem3D_par.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/specfem3D_par.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,460 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+module constants
+
+ include "constants.h"
+
+end module constants
+
+!=====================================================================
+
+module specfem_par
+
+! main parameter module for specfem simulations
+
+ use constants
+
+ implicit none
+
+! attenuation
+ integer :: NSPEC_ATTENUATION_AB
+ integer, dimension(:,:,:,:),allocatable :: iflag_attenuation_store
+
+! use integer array to store topography values
+ integer :: NX_TOPO,NY_TOPO
+ double precision :: ORIG_LAT_TOPO,ORIG_LONG_TOPO,DEGREES_PER_CELL_TOPO
+ character(len=100) :: topo_file
+ integer, dimension(:,:), allocatable :: itopo_bathy
+
+! absorbing boundary arrays (for all boundaries) - keeps all infos, allowing for irregular surfaces
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: abs_boundary_normal
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: abs_boundary_jacobian2Dw
+ integer, dimension(:,:,:), allocatable :: abs_boundary_ijk
+ integer, dimension(:), allocatable :: abs_boundary_ispec
+ integer :: num_abs_boundary_faces
+
+! free surface arrays
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: free_surface_normal
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: free_surface_jacobian2Dw
+ integer, dimension(:,:,:), allocatable :: free_surface_ijk
+ integer, dimension(:), allocatable :: free_surface_ispec
+ integer :: num_free_surface_faces
+
+! mesh parameters
+ integer, dimension(:,:,:,:), allocatable :: ibool
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: xstore,ystore,zstore
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,jacobian
+
+! material properties
+ ! isotropic
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: kappastore,mustore
+
+! additional mass matrix for ocean load
+! ocean load mass matrix is always allocated statically even if no oceans
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_ocean_load
+
+! time scheme
+ real(kind=CUSTOM_REAL) deltat,deltatover2,deltatsqover2
+
+! time loop step
+ integer :: it
+
+! parameters for the source
+ integer, dimension(:), allocatable :: islice_selected_source,ispec_selected_source
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: sourcearray
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: sourcearrays
+ double precision, dimension(:,:,:), allocatable :: nu_source
+ double precision, dimension(:), allocatable :: Mxx,Myy,Mzz,Mxy,Mxz,Myz
+ double precision, dimension(:), allocatable :: xi_source,eta_source,gamma_source
+ double precision, dimension(:), allocatable :: t_cmt,hdur,hdur_gaussian
+ double precision, dimension(:), allocatable :: utm_x_source,utm_y_source
+ double precision, external :: comp_source_time_function
+ double precision :: t0
+ real(kind=CUSTOM_REAL) :: stf_used_total
+ integer :: NSOURCES
+
+! receiver information
+ character(len=256) :: rec_filename,filtered_rec_filename,dummystring
+ integer :: nrec,nrec_local,nrec_tot_found
+ integer :: nrec_simulation
+ integer, allocatable, dimension(:) :: islice_selected_rec,ispec_selected_rec,number_receiver_global
+ double precision, allocatable, dimension(:) :: xi_receiver,eta_receiver,gamma_receiver
+ double precision, dimension(:,:), allocatable :: hpxir_store,hpetar_store,hpgammar_store
+
+! timing information for the stations
+ double precision, allocatable, dimension(:,:,:) :: nu
+ character(len=MAX_LENGTH_STATION_NAME), allocatable, dimension(:) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), allocatable, dimension(:) :: network_name
+
+! seismograms
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: seismograms_d,seismograms_v,seismograms_a
+
+! Gauss-Lobatto-Legendre points of integration and weights
+ double precision, dimension(NGLLX) :: xigll,wxgll
+ double precision, dimension(NGLLY) :: yigll,wygll
+ double precision, dimension(NGLLZ) :: zigll,wzgll
+
+! 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(NGLLY,NGLLY) :: hprime_yy,hprimewgll_yy
+ real(kind=CUSTOM_REAL), dimension(NGLLZ,NGLLZ) :: hprime_zz,hprimewgll_zz
+ 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
+
+! Lagrange interpolators at receivers
+ double precision, dimension(:), allocatable :: hxir,hetar,hpxir,hpetar,hgammar,hpgammar
+ double precision, dimension(:,:), allocatable :: hxir_store,hetar_store,hgammar_store
+
+! proc numbers for MPI
+ integer :: myrank
+
+! timer MPI
+ double precision, external :: wtime
+ double precision :: time_start
+
+! parameters read from parameter file
+ integer :: NPROC_XI,NPROC_ETA
+ integer :: NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE
+ integer :: SIMULATION_TYPE
+
+ double precision :: DT
+ double precision :: LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN,LONGITUDE_MAX
+
+ logical :: ATTENUATION,USE_OLSEN_ATTENUATION, &
+ OCEANS,ABSORBING_CONDITIONS,ANISOTROPY
+
+ logical :: SAVE_FORWARD,SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION
+
+ logical :: SUPPRESS_UTM_PROJECTION
+
+ integer :: NTSTEP_BETWEEN_OUTPUT_INFO
+
+ character(len=256) OUTPUT_FILES,LOCAL_PATH,prname,prname_Q
+
+! parameters deduced from parameters read from file
+ integer :: NPROC
+ integer :: NSPEC_AB, NGLOB_AB
+
+! names of the data files for all the processors in MPI
+ character(len=256) outputname
+
+! for assembling in case of external mesh
+ integer :: num_interfaces_ext_mesh
+ integer :: max_nibool_interfaces_ext_mesh
+ integer, dimension(:), allocatable :: my_neighbours_ext_mesh
+ integer, dimension(:), allocatable :: nibool_interfaces_ext_mesh
+ integer, dimension(:,:), allocatable :: ibool_interfaces_ext_mesh
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: buffer_send_vector_ext_mesh
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: buffer_recv_vector_ext_mesh
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_scalar_ext_mesh
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_scalar_ext_mesh
+ integer, dimension(:), allocatable :: request_send_scalar_ext_mesh
+ integer, dimension(:), allocatable :: request_recv_scalar_ext_mesh
+ integer, dimension(:), allocatable :: request_send_vector_ext_mesh
+ integer, dimension(:), allocatable :: request_recv_vector_ext_mesh
+
+! for detecting surface receivers and source in case of external mesh
+ logical, dimension(:), allocatable :: iglob_is_surface_external_mesh
+ logical, dimension(:), allocatable :: ispec_is_surface_external_mesh
+
+! MPI partition surfaces
+ logical, dimension(:), allocatable :: ispec_is_inner
+ logical, dimension(:), allocatable :: iglob_is_inner
+
+! maximum of the norm of the displacement
+ real(kind=CUSTOM_REAL) Usolidnorm,Usolidnorm_all
+ integer:: Usolidnorm_index(1)
+
+! maximum speed in velocity model
+ real(kind=CUSTOM_REAL):: model_speed_max
+
+!!!! NL NL REGOLITH : regolith layer for asteroid
+!!$ double precision, external :: materials_ext_mesh
+!!$ logical, dimension(:), allocatable :: ispec_is_regolith
+!!$ real(kind=CUSTOM_REAL) :: weight, jacobianl
+!!!! NL NL REGOLITH
+
+
+! ADJOINT parameters
+
+ ! time scheme
+ real(kind=CUSTOM_REAL) b_deltat, b_deltatover2, b_deltatsqover2
+
+ ! absorbing stacey wavefield parts
+ integer :: b_num_abs_boundary_faces
+
+ ! Moho mesh
+ real(CUSTOM_REAL), dimension(:,:,:),allocatable :: normal_moho_top
+ real(CUSTOM_REAL), dimension(:,:,:),allocatable :: normal_moho_bot
+ integer,dimension(:,:,:),allocatable :: ijk_moho_top, ijk_moho_bot
+ integer,dimension(:),allocatable :: ibelm_moho_top, ibelm_moho_bot
+ integer :: NSPEC_BOUN,NSPEC2D_MOHO
+ logical, dimension(:),allocatable :: is_moho_top, is_moho_bot
+
+ ! adjoint sources
+ character(len=256) adj_source_file
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: adj_sourcearray
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:,:), allocatable :: adj_sourcearrays
+ integer :: nadj_rec_local
+ ! adjoint source frechet derivatives
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: Mxx_der,Myy_der,&
+ Mzz_der,Mxy_der,Mxz_der,Myz_der
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: sloc_der
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: seismograms_eps
+
+ ! adjoint elements
+ integer :: NSPEC_ADJOINT, NGLOB_ADJOINT
+
+ ! norm of the backward displacement
+ real(kind=CUSTOM_REAL) b_Usolidnorm, b_Usolidnorm_all
+
+
+end module specfem_par
+
+
+!=====================================================================
+
+module specfem_par_elastic
+
+! parameter module for elastic solver
+
+ use constants,only: CUSTOM_REAL,N_SLS,NUM_REGIONS_ATTENUATION
+ implicit none
+
+! memory variables and standard linear solids for attenuation
+ double precision, dimension(N_SLS) :: tau_mu_dble,tau_sigma_dble,beta_dble
+ double precision factor_scale_dble,one_minus_sum_beta_dble
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: tau_mu,tau_sigma,beta
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION) :: factor_scale,one_minus_sum_beta
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: &
+ tauinv,factor_common, alphaval,betaval,gammaval
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: &
+ R_xx,R_yy,R_xy,R_xz,R_yz
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
+
+! displacement, velocity, acceleration
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: displ,veloc,accel
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass
+
+! Stacey
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_vp,rho_vs
+
+ ! anisotropic
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ c11store,c12store,c13store,c14store,c15store,c16store,&
+ c22store,c23store,c24store,c25store,c26store,c33store,&
+ c34store,c35store,c36store,c44store,c45store,c46store,&
+ c55store,c56store,c66store
+ integer :: NSPEC_ANISO
+
+! material flag
+ logical, dimension(:), allocatable :: ispec_is_elastic
+ integer, dimension(:,:), allocatable :: phase_ispec_inner_elastic
+ integer :: num_phase_ispec_elastic,nspec_inner_elastic,nspec_outer_elastic
+
+ logical :: ELASTIC_SIMULATION
+
+
+! ADJOINT elastic
+
+ ! (backward/reconstructed) wavefields
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_displ, b_veloc, b_accel
+
+ ! backward attenuation arrays
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: &
+ b_alphaval, b_betaval, b_gammaval
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: &
+ b_R_xx,b_R_yy,b_R_xy,b_R_xz,b_R_yz
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ b_epsilondev_xx,b_epsilondev_yy,b_epsilondev_xy,b_epsilondev_xz,b_epsilondev_yz
+ integer:: NSPEC_ATT_AND_KERNEL
+
+ ! adjoint kernels
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_kl, mu_kl, kappa_kl, &
+ rhop_kl, beta_kl, alpha_kl
+
+ ! topographic (Moho) kernel
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:,:),allocatable :: &
+ dsdx_top, dsdx_bot, b_dsdx_top, b_dsdx_bot
+ real(kind=CUSTOM_REAL), dimension(:,:),allocatable :: moho_kl
+ integer :: ispec2D_moho_top,ispec2D_moho_bot
+
+ ! absorbing stacey wavefield parts
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_absorb_field
+ integer :: b_reclen_field
+
+ ! for assembling backward field
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_buffer_send_vector_ext_mesh
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: b_buffer_recv_vector_ext_mesh
+ integer, dimension(:), allocatable :: b_request_send_vector_ext_mesh
+ integer, dimension(:), allocatable :: b_request_recv_vector_ext_mesh
+
+end module specfem_par_elastic
+
+!=====================================================================
+
+module specfem_par_acoustic
+
+! parameter module for elastic solver
+
+ use constants,only: CUSTOM_REAL
+ implicit none
+
+! potential
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: potential_acoustic, &
+ potential_dot_acoustic,potential_dot_dot_acoustic
+
+! density
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rhostore
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_acoustic
+
+! acoustic-elastic coupling surface
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: coupling_ac_el_normal
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: coupling_ac_el_jacobian2Dw
+ integer, dimension(:,:,:), allocatable :: coupling_ac_el_ijk
+ integer, dimension(:), allocatable :: coupling_ac_el_ispec
+ integer :: num_coupling_ac_el_faces
+
+! material flag
+ logical, dimension(:), allocatable :: ispec_is_acoustic
+ integer, dimension(:,:), allocatable :: phase_ispec_inner_acoustic
+ integer :: num_phase_ispec_acoustic,nspec_inner_acoustic,nspec_outer_acoustic
+
+ logical :: ACOUSTIC_SIMULATION
+
+! ADJOINT acoustic
+
+ ! (backward/reconstructed) wavefield potentials
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: b_potential_acoustic, &
+ b_potential_dot_acoustic,b_potential_dot_dot_acoustic
+ ! kernels
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_ac_kl, kappa_ac_kl, &
+ rhop_ac_kl, alpha_ac_kl
+
+ ! absorbing stacey wavefield parts
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_absorb_potential
+ integer :: b_reclen_potential
+
+ ! for assembling backward field
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_buffer_send_scalar_ext_mesh
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: b_buffer_recv_scalar_ext_mesh
+ integer, dimension(:), allocatable :: b_request_send_scalar_ext_mesh
+ integer, dimension(:), allocatable :: b_request_recv_scalar_ext_mesh
+
+end module specfem_par_acoustic
+
+!=====================================================================
+
+module specfem_par_poroelastic
+
+! parameter module for elastic solver
+
+ use constants,only: CUSTOM_REAL
+ implicit none
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_solid_poroelastic,&
+ rmass_fluid_poroelastic
+
+! material flag
+ logical, dimension(:), allocatable :: ispec_is_poroelastic
+
+ logical :: POROELASTIC_SIMULATION
+
+end module specfem_par_poroelastic
+
+
+!=====================================================================
+
+module specfem_par_movie
+
+! parameter module for movies/shakemovies
+
+ use constants,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,NGNOD2D
+
+ implicit none
+
+! to save full 3D snapshot of velocity (movie volume
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable:: div, curl_x, curl_y, curl_z
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable:: velocity_x,velocity_y,velocity_z
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dvxdxl,dvxdyl,&
+ dvxdzl,dvydxl,dvydyl,dvydzl,dvzdxl,dvzdyl,dvzdzl
+
+! shakemovies
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_x_external_mesh
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_y_external_mesh
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_z_external_mesh
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_x_all_external_mesh
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_y_all_external_mesh
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_z_all_external_mesh
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_ux_external_mesh
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_uy_external_mesh
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_uz_external_mesh
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_ux_all_external_mesh
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_uy_all_external_mesh
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: store_val_uz_all_external_mesh
+
+! movie volume
+ real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl
+
+ real(kind=CUSTOM_REAL) hp1,hp2,hp3
+
+ real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
+ real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
+ real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
+
+! for storing surface of external mesh
+ integer,dimension(:),allocatable :: nfaces_perproc_surface_ext_mesh
+ integer,dimension(:),allocatable :: faces_surface_offset_ext_mesh
+ integer,dimension(:,:),allocatable :: faces_surface_ext_mesh
+ integer,dimension(:),allocatable :: faces_surface_ext_mesh_ispec
+ integer :: nfaces_surface_ext_mesh
+ integer :: nfaces_surface_glob_ext_mesh
+ ! face corner indices
+ integer :: iorderi(NGNOD2D),iorderj(NGNOD2D)
+
+! movie parameters
+ double precision :: HDUR_MOVIE
+ integer :: NTSTEP_BETWEEN_FRAMES
+ logical :: MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ USE_HIGHRES_FOR_MOVIES
+
+ logical :: MOVIE_SIMULATION
+
+end module specfem_par_movie
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/utm_geo.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/utm_geo.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/utm_geo.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,198 @@
+!=====================================================================
+!
+! UTM (Universal Transverse Mercator) projection from the USGS
+!
+!=====================================================================
+
+ subroutine utm_geo(rlon,rlat,rx,ry,UTM_PROJECTION_ZONE,iway,SUPPRESS_UTM_PROJECTION)
+
+! convert geodetic longitude and latitude to UTM, and back
+! use iway = ILONGLAT2UTM for long/lat to UTM, IUTM2LONGLAT for UTM to lat/long
+! a list of UTM zones of the world is available at www.dmap.co.uk/utmworld.htm
+
+ implicit none
+
+ include "constants.h"
+
+!
+!-----CAMx v2.03
+!
+! UTM_GEO performs UTM to geodetic (long/lat) translation, and back.
+!
+! This is a Fortran version of the BASIC program "Transverse Mercator
+! Conversion", Copyright 1986, Norman J. Berls (Stefan Musarra, 2/94)
+! Based on algorithm taken from "Map Projections Used by the USGS"
+! by John P. Snyder, Geological Survey Bulletin 1532, USDI.
+!
+! Input/Output arguments:
+!
+! rlon Longitude (deg, negative for West)
+! rlat Latitude (deg)
+! rx UTM easting (m)
+! ry UTM northing (m)
+! UTM_PROJECTION_ZONE UTM zone
+! iway Conversion type
+! ILONGLAT2UTM = geodetic to UTM
+! IUTM2LONGLAT = UTM to geodetic
+!
+
+ integer UTM_PROJECTION_ZONE,iway
+ double precision rx,ry,rlon,rlat
+ logical SUPPRESS_UTM_PROJECTION
+
+ double precision, parameter :: degrad=PI/180.d0, raddeg=180.d0/PI
+ double precision, parameter :: semimaj=6378206.4d0, semimin=6356583.8d0
+ double precision, parameter :: scfa=0.9996d0
+ double precision, parameter :: north=0.d0, east=500000.d0
+
+ double precision e2,e4,e6,ep2,xx,yy,dlat,dlon,zone,cm,cmr,delam
+ double precision f1,f2,f3,f4,rm,rn,t,c,a,e1,u,rlat1,dlat1,c1,t1,rn1,r1,d
+ double precision rx_save,ry_save,rlon_save,rlat_save
+
+ if(SUPPRESS_UTM_PROJECTION) then
+ if (iway == ILONGLAT2UTM) then
+ rx = rlon
+ ry = rlat
+ else
+ rlon = rx
+ rlat = ry
+ endif
+ return
+ endif
+
+! save original parameters
+ rlon_save = rlon
+ rlat_save = rlat
+ rx_save = rx
+ ry_save = ry
+
+! define parameters of reference ellipsoid
+ e2=1.0-(semimin/semimaj)**2.0
+ e4=e2*e2
+ e6=e2*e4
+ ep2=e2/(1.-e2)
+
+ if (iway == IUTM2LONGLAT) then
+ xx = rx
+ yy = ry
+ else
+ dlon = rlon
+ dlat = rlat
+ endif
+!
+!----- Set Zone parameters
+!
+ zone = dble(UTM_PROJECTION_ZONE)
+ cm = zone*6.0 - 183.0
+ cmr = cm*degrad
+!
+!---- Lat/Lon to UTM conversion
+!
+ if (iway == ILONGLAT2UTM) then
+
+ rlon = degrad*dlon
+ rlat = degrad*dlat
+
+ delam = dlon - cm
+ if (delam < -180.) delam = delam + 360.
+ if (delam > 180.) delam = delam - 360.
+ delam = delam*degrad
+
+ f1 = (1. - e2/4. - 3.*e4/64. - 5.*e6/256)*rlat
+ f2 = 3.*e2/8. + 3.*e4/32. + 45.*e6/1024.
+ f2 = f2*sin(2.*rlat)
+ f3 = 15.*e4/256.*45.*e6/1024.
+ f3 = f3*sin(4.*rlat)
+ f4 = 35.*e6/3072.
+ f4 = f4*sin(6.*rlat)
+ rm = semimaj*(f1 - f2 + f3 - f4)
+ if (dlat == 90. .or. dlat == -90.) then
+ xx = 0.
+ yy = scfa*rm
+ else
+ rn = semimaj/sqrt(1. - e2*sin(rlat)**2)
+ t = tan(rlat)**2
+ c = ep2*cos(rlat)**2
+ a = cos(rlat)*delam
+
+ f1 = (1. - t + c)*a**3/6.
+ f2 = 5. - 18.*t + t**2 + 72.*c - 58.*ep2
+ f2 = f2*a**5/120.
+ xx = scfa*rn*(a + f1 + f2)
+ f1 = a**2/2.
+ f2 = 5. - t + 9.*c + 4.*c**2
+ f2 = f2*a**4/24.
+ f3 = 61. - 58.*t + t**2 + 600.*c - 330.*ep2
+ f3 = f3*a**6/720.
+ yy = scfa*(rm + rn*tan(rlat)*(f1 + f2 + f3))
+ endif
+ xx = xx + east
+ yy = yy + north
+
+!
+!---- UTM to Lat/Lon conversion
+!
+ else
+
+ xx = xx - east
+ yy = yy - north
+ e1 = sqrt(1. - e2)
+ e1 = (1. - e1)/(1. + e1)
+ rm = yy/scfa
+ u = 1. - e2/4. - 3.*e4/64. - 5.*e6/256.
+ u = rm/(semimaj*u)
+
+ f1 = 3.*e1/2. - 27.*e1**3./32.
+ f1 = f1*sin(2.*u)
+ f2 = 21.*e1**2/16. - 55.*e1**4/32.
+ f2 = f2*sin(4.*u)
+ f3 = 151.*e1**3./96.
+ f3 = f3*sin(6.*u)
+ rlat1 = u + f1 + f2 + f3
+ dlat1 = rlat1*raddeg
+ if (dlat1 >= 90. .or. dlat1 <= -90.) then
+ dlat1 = dmin1(dlat1,dble(90.) )
+ dlat1 = dmax1(dlat1,dble(-90.) )
+ dlon = cm
+ else
+ c1 = ep2*cos(rlat1)**2.
+ t1 = tan(rlat1)**2.
+ f1 = 1. - e2*sin(rlat1)**2.
+ rn1 = semimaj/sqrt(f1)
+ r1 = semimaj*(1. - e2)/sqrt(f1**3)
+ d = xx/(rn1*scfa)
+
+ f1 = rn1*tan(rlat1)/r1
+ f2 = d**2/2.
+ f3 = 5.*3.*t1 + 10.*c1 - 4.*c1**2 - 9.*ep2
+ f3 = f3*d**2*d**2/24.
+ f4 = 61. + 90.*t1 + 298.*c1 + 45.*t1**2. - 252.*ep2 - 3.*c1**2
+ f4 = f4*(d**2)**3./720.
+ rlat = rlat1 - f1*(f2 - f3 + f4)
+ dlat = rlat*raddeg
+
+ f1 = 1. + 2.*t1 + c1
+ f1 = f1*d**2*d/6.
+ f2 = 5. - 2.*c1 + 28.*t1 - 3.*c1**2 + 8.*ep2 + 24.*t1**2.
+ f2 = f2*(d**2)**2*d/120.
+ rlon = cmr + (d - f1 + f2)/cos(rlat1)
+ dlon = rlon*raddeg
+ if (dlon < -180.) dlon = dlon + 360.
+ if (dlon > 180.) dlon = dlon - 360.
+ endif
+ endif
+
+ if (iway == IUTM2LONGLAT) then
+ rlon = dlon
+ rlat = dlat
+ rx = rx_save
+ ry = ry_save
+ else
+ rx = xx
+ ry = yy
+ rlon = rlon_save
+ rlat = rlat_save
+ endif
+
+ end subroutine utm_geo
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_AVS_DX_global_data.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_AVS_DX_global_data.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_AVS_DX_global_data.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,196 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! create AVS or DX 3D data for the slice, to be recombined in postprocessing
+ subroutine write_AVS_DX_global_data(myrank,prname,nspec,ibool,idoubling, &
+ xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool,npointot)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer idoubling(nspec)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! logical mask used to output global points only once
+ integer npointot
+ logical mask_ibool(npointot)
+
+! numbering of global AVS or DX points
+ integer num_ibool_AVS_DX(npointot)
+
+ integer ispec
+ integer iglob1,iglob2,iglob3,iglob4,iglob5,iglob6,iglob7,iglob8
+ integer npoin,numpoin
+
+! processor identification
+ character(len=256) prname
+
+! ------------------------------------
+
+! writing points
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpoints.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+
+! mark global AVS or DX points
+ do ispec=1,nspec
+ 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)
+ mask_ibool(iglob1) = .true.
+ mask_ibool(iglob2) = .true.
+ mask_ibool(iglob3) = .true.
+ mask_ibool(iglob4) = .true.
+ mask_ibool(iglob5) = .true.
+ mask_ibool(iglob6) = .true.
+ mask_ibool(iglob7) = .true.
+ mask_ibool(iglob8) = .true.
+ enddo
+
+! count global number of AVS or DX points
+ npoin = count(mask_ibool(:))
+
+! number of points in AVS or DX file
+ write(10,*) npoin
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! output global AVS or DX points
+ numpoin = 0
+ do ispec=1,nspec
+ 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)
+ if(.not. mask_ibool(iglob1)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob1) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), &
+ sngl(ystore(1,1,1,ispec)),sngl(zstore(1,1,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob2)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob2) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), &
+ sngl(ystore(NGLLX,1,1,ispec)),sngl(zstore(NGLLX,1,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob3)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob3) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,1,ispec)),sngl(zstore(NGLLX,NGLLY,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob4)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob4) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), &
+ sngl(ystore(1,NGLLY,1,ispec)),sngl(zstore(1,NGLLY,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob5)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob5) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), &
+ sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec))
+ endif
+ if(.not. mask_ibool(iglob6)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob6) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec))
+ endif
+ if(.not. mask_ibool(iglob7)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob7) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
+ endif
+ if(.not. mask_ibool(iglob8)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob8) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(1,NGLLY,NGLLZ,ispec)),sngl(zstore(1,NGLLY,NGLLZ,ispec))
+ endif
+ mask_ibool(iglob1) = .true.
+ mask_ibool(iglob2) = .true.
+ mask_ibool(iglob3) = .true.
+ mask_ibool(iglob4) = .true.
+ mask_ibool(iglob5) = .true.
+ mask_ibool(iglob6) = .true.
+ mask_ibool(iglob7) = .true.
+ mask_ibool(iglob8) = .true.
+ enddo
+
+! check that number of global points output is okay
+ if(numpoin /= npoin) &
+ call exit_MPI(myrank,'incorrect number of global points in AVS or DX file creation')
+
+ close(10)
+
+! writing elements
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelements.txt',status='unknown')
+
+! number of elements in AVS or DX file
+ write(10,*) nspec
+
+! output global AVS or DX elements
+ do ispec=1,nspec
+ 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)
+ write(10,*) ispec,idoubling(ispec),num_ibool_AVS_DX(iglob1), &
+ num_ibool_AVS_DX(iglob2),num_ibool_AVS_DX(iglob3), &
+ num_ibool_AVS_DX(iglob4),num_ibool_AVS_DX(iglob5), &
+ num_ibool_AVS_DX(iglob6),num_ibool_AVS_DX(iglob7), &
+ num_ibool_AVS_DX(iglob8)
+ enddo
+
+ close(10)
+
+ end subroutine write_AVS_DX_global_data
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_AVS_DX_global_faces_data.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_AVS_DX_global_faces_data.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_AVS_DX_global_faces_data.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,349 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! create AVS or DX 2D data for the faces of the slice,
+! to be recombined in postprocessing
+
+ subroutine write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta, &
+ ibool,idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool, &
+ npointot)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer idoubling(nspec)
+
+ logical iMPIcut_xi(2,nspec)
+ logical iMPIcut_eta(2,nspec)
+
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+! logical mask used to output global points only once
+ integer npointot
+ logical mask_ibool(npointot)
+
+! numbering of global AVS or DX points
+ integer num_ibool_AVS_DX(npointot)
+
+ integer ispec
+ integer iglob1,iglob2,iglob3,iglob4,iglob5,iglob6,iglob7,iglob8
+ integer npoin,numpoin,nspecface,ispecface
+
+! processor identification
+ character(len=256) prname
+
+! writing points
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointsfaces.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+ nspecface = 0
+
+! mark global AVS or DX points
+ do ispec=1,nspec
+! only if on face
+ if(iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. &
+ iMPIcut_eta(1,ispec) .or. iMPIcut_eta(2,ispec)) then
+ 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)
+
+! face xi = xi_min
+ if(iMPIcut_xi(1,ispec)) then
+ nspecface = nspecface + 1
+ mask_ibool(iglob1) = .true.
+ mask_ibool(iglob4) = .true.
+ mask_ibool(iglob8) = .true.
+ mask_ibool(iglob5) = .true.
+ endif
+
+! face xi = xi_max
+ if(iMPIcut_xi(2,ispec)) then
+ nspecface = nspecface + 1
+ mask_ibool(iglob2) = .true.
+ mask_ibool(iglob3) = .true.
+ mask_ibool(iglob7) = .true.
+ mask_ibool(iglob6) = .true.
+ endif
+
+! face eta = eta_min
+ if(iMPIcut_eta(1,ispec)) then
+ nspecface = nspecface + 1
+ mask_ibool(iglob1) = .true.
+ mask_ibool(iglob2) = .true.
+ mask_ibool(iglob6) = .true.
+ mask_ibool(iglob5) = .true.
+ endif
+
+! face eta = eta_max
+ if(iMPIcut_eta(2,ispec)) then
+ nspecface = nspecface + 1
+ mask_ibool(iglob4) = .true.
+ mask_ibool(iglob3) = .true.
+ mask_ibool(iglob7) = .true.
+ mask_ibool(iglob8) = .true.
+ endif
+
+ endif
+ enddo
+
+! count global number of AVS or DX points
+ npoin = count(mask_ibool(:))
+
+! number of points in AVS or DX file
+ write(10,*) npoin
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! output global AVS or DX points
+ numpoin = 0
+ do ispec=1,nspec
+! only if on face
+ if(iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. &
+ iMPIcut_eta(1,ispec) .or. iMPIcut_eta(2,ispec)) then
+ 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)
+
+! face xi = xi_min
+ if(iMPIcut_xi(1,ispec)) then
+ if(.not. mask_ibool(iglob1)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob1) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), &
+ sngl(ystore(1,1,1,ispec)),sngl(zstore(1,1,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob4)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob4) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), &
+ sngl(ystore(1,NGLLY,1,ispec)),sngl(zstore(1,NGLLY,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob8)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob8) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(1,NGLLY,NGLLZ,ispec)),sngl(zstore(1,NGLLY,NGLLZ,ispec))
+ endif
+ if(.not. mask_ibool(iglob5)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob5) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), &
+ sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec))
+ endif
+ mask_ibool(iglob1) = .true.
+ mask_ibool(iglob4) = .true.
+ mask_ibool(iglob8) = .true.
+ mask_ibool(iglob5) = .true.
+ endif
+
+! face xi = xi_max
+ if(iMPIcut_xi(2,ispec)) then
+ if(.not. mask_ibool(iglob2)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob2) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), &
+ sngl(ystore(NGLLX,1,1,ispec)),sngl(zstore(NGLLX,1,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob3)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob3) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,1,ispec)),sngl(zstore(NGLLX,NGLLY,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob7)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob7) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
+ endif
+ if(.not. mask_ibool(iglob6)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob6) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec))
+ endif
+ mask_ibool(iglob2) = .true.
+ mask_ibool(iglob3) = .true.
+ mask_ibool(iglob7) = .true.
+ mask_ibool(iglob6) = .true.
+ endif
+
+! face eta = eta_min
+ if(iMPIcut_eta(1,ispec)) then
+ if(.not. mask_ibool(iglob1)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob1) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,1,ispec)), &
+ sngl(ystore(1,1,1,ispec)),sngl(zstore(1,1,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob2)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob2) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,1,ispec)), &
+ sngl(ystore(NGLLX,1,1,ispec)),sngl(zstore(NGLLX,1,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob6)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob6) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec))
+ endif
+ if(.not. mask_ibool(iglob5)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob5) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), &
+ sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec))
+ endif
+ mask_ibool(iglob1) = .true.
+ mask_ibool(iglob2) = .true.
+ mask_ibool(iglob6) = .true.
+ mask_ibool(iglob5) = .true.
+ endif
+
+! face eta = eta_max
+ if(iMPIcut_eta(2,ispec)) then
+ if(.not. mask_ibool(iglob4)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob4) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,1,ispec)), &
+ sngl(ystore(1,NGLLY,1,ispec)),sngl(zstore(1,NGLLY,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob3)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob3) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,1,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,1,ispec)),sngl(zstore(NGLLX,NGLLY,1,ispec))
+ endif
+ if(.not. mask_ibool(iglob7)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob7) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
+ endif
+ if(.not. mask_ibool(iglob8)) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglob8) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(1,NGLLY,NGLLZ,ispec)),sngl(zstore(1,NGLLY,NGLLZ,ispec))
+ endif
+ mask_ibool(iglob4) = .true.
+ mask_ibool(iglob3) = .true.
+ mask_ibool(iglob7) = .true.
+ mask_ibool(iglob8) = .true.
+ endif
+
+ endif
+ enddo
+
+! check that number of global points output is okay
+ if(numpoin /= npoin) &
+ call exit_MPI(myrank,'incorrect number of global points in AVS or DX file creation')
+
+ close(10)
+
+! output global AVS or DX elements
+
+! writing elements
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementsfaces.txt',status='unknown')
+
+! number of elements in AVS or DX file
+ write(10,*) nspecface
+
+ ispecface = 0
+ do ispec=1,nspec
+! only if on face
+ if(iMPIcut_xi(1,ispec) .or. iMPIcut_xi(2,ispec) .or. &
+ iMPIcut_eta(1,ispec) .or. iMPIcut_eta(2,ispec)) then
+ 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)
+
+! face xi = xi_min
+ if(iMPIcut_xi(1,ispec)) then
+ ispecface = ispecface + 1
+ write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglob1), &
+ num_ibool_AVS_DX(iglob4),num_ibool_AVS_DX(iglob8), &
+ num_ibool_AVS_DX(iglob5)
+ endif
+
+! face xi = xi_max
+ if(iMPIcut_xi(2,ispec)) then
+ ispecface = ispecface + 1
+ write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglob2), &
+ num_ibool_AVS_DX(iglob3),num_ibool_AVS_DX(iglob7), &
+ num_ibool_AVS_DX(iglob6)
+ endif
+
+! face eta = eta_min
+ if(iMPIcut_eta(1,ispec)) then
+ ispecface = ispecface + 1
+ write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglob1), &
+ num_ibool_AVS_DX(iglob2),num_ibool_AVS_DX(iglob6), &
+ num_ibool_AVS_DX(iglob5)
+ endif
+
+! face eta = eta_max
+ if(iMPIcut_eta(2,ispec)) then
+ ispecface = ispecface + 1
+ write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglob4), &
+ num_ibool_AVS_DX(iglob3),num_ibool_AVS_DX(iglob7), &
+ num_ibool_AVS_DX(iglob8)
+ endif
+
+ endif
+ enddo
+
+! check that number of surface elements output is okay
+ if(ispecface /= nspecface) &
+ call exit_MPI(myrank,'incorrect number of surface elements in AVS or DX file creation')
+
+ close(10)
+
+ end subroutine write_AVS_DX_global_faces_data
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_AVS_DX_surface_data.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_AVS_DX_surface_data.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_AVS_DX_surface_data.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,190 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+! create AVS or DX 2D data for the surface of the model
+! to be recombined in postprocessing
+ subroutine write_AVS_DX_surface_data(myrank,prname,nspec,iboun, &
+ ibool,idoubling,xstore,ystore,zstore,num_ibool_AVS_DX,mask_ibool, &
+ npointot)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nspec,myrank
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ integer idoubling(nspec)
+
+ 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)
+
+! logical mask used to output global points only once
+ integer npointot
+ logical mask_ibool(npointot)
+
+! numbering of global AVS or DX points
+ integer num_ibool_AVS_DX(npointot)
+
+ integer ispec
+ integer, dimension(8) :: iglobval
+ integer npoin,numpoin,nspecface,ispecface
+
+! processor identification
+ character(len=256) prname
+
+! writing points
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXpointssurface.txt',status='unknown')
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+ nspecface = 0
+
+! mark global AVS or DX points
+ do ispec=1,nspec
+! only if at the surface (top plane)
+ if(iboun(6,ispec)) then
+
+ iglobval(5)=ibool(1,1,NGLLZ,ispec)
+ iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
+ iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
+
+! element is at the surface
+ nspecface = nspecface + 1
+ mask_ibool(iglobval(5)) = .true.
+ mask_ibool(iglobval(6)) = .true.
+ mask_ibool(iglobval(7)) = .true.
+ mask_ibool(iglobval(8)) = .true.
+
+ endif
+ enddo
+
+! count global number of AVS or DX points
+ npoin = count(mask_ibool(:))
+
+! number of points in AVS or DX file
+ write(10,*) npoin
+
+! erase the logical mask used to mark points already found
+ mask_ibool(:) = .false.
+
+! output global AVS or DX points
+ numpoin = 0
+ do ispec=1,nspec
+! only if at the surface
+ if(iboun(6,ispec)) then
+
+ iglobval(5)=ibool(1,1,NGLLZ,ispec)
+ iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
+ iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
+
+! top face
+ if(iboun(6,ispec)) then
+
+ if(.not. mask_ibool(iglobval(5))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(5)) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,1,NGLLZ,ispec)), &
+ sngl(ystore(1,1,NGLLZ,ispec)),sngl(zstore(1,1,NGLLZ,ispec))
+ endif
+
+ if(.not. mask_ibool(iglobval(6))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(6)) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,1,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,1,NGLLZ,ispec)),sngl(zstore(NGLLX,1,NGLLZ,ispec))
+ endif
+
+ if(.not. mask_ibool(iglobval(7))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(7)) = numpoin
+ write(10,*) numpoin,sngl(xstore(NGLLX,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(NGLLX,NGLLY,NGLLZ,ispec)),sngl(zstore(NGLLX,NGLLY,NGLLZ,ispec))
+ endif
+
+ if(.not. mask_ibool(iglobval(8))) then
+ numpoin = numpoin + 1
+ num_ibool_AVS_DX(iglobval(8)) = numpoin
+ write(10,*) numpoin,sngl(xstore(1,NGLLY,NGLLZ,ispec)), &
+ sngl(ystore(1,NGLLY,NGLLZ,ispec)),sngl(zstore(1,NGLLY,NGLLZ,ispec))
+ endif
+
+ mask_ibool(iglobval(5)) = .true.
+ mask_ibool(iglobval(6)) = .true.
+ mask_ibool(iglobval(7)) = .true.
+ mask_ibool(iglobval(8)) = .true.
+
+ endif
+
+ endif
+ enddo
+
+! check that number of global points output is okay
+ if(numpoin /= npoin) &
+ call exit_MPI(myrank,'incorrect number of global points in AVS or DX file creation')
+
+ close(10)
+
+! output global AVS or DX elements
+
+! writing elements
+ open(unit=10,file=prname(1:len_trim(prname))//'AVS_DXelementssurface.txt',status='unknown')
+
+! number of elements in AVS or DX file
+ write(10,*) nspecface
+
+ ispecface = 0
+ do ispec=1,nspec
+! only if at the surface
+ if(iboun(6,ispec)) then
+
+ iglobval(5)=ibool(1,1,NGLLZ,ispec)
+ iglobval(6)=ibool(NGLLX,1,NGLLZ,ispec)
+ iglobval(7)=ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ iglobval(8)=ibool(1,NGLLY,NGLLZ,ispec)
+
+! top face
+ ispecface = ispecface + 1
+ write(10,*) ispecface,idoubling(ispec),num_ibool_AVS_DX(iglobval(5)), &
+ num_ibool_AVS_DX(iglobval(6)),num_ibool_AVS_DX(iglobval(7)), &
+ num_ibool_AVS_DX(iglobval(8))
+
+ endif
+ enddo
+
+! check that number of surface elements output is okay
+ if(ispecface /= nspecface) &
+ call exit_MPI(myrank,'incorrect number of surface elements in AVS or DX file creation')
+
+ close(10)
+
+ end subroutine write_AVS_DX_surface_data
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_PNM_GIF_data.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_PNM_GIF_data.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_PNM_GIF_data.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,854 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+ module image_PNM_GIF_par
+
+ use constants,only: CUSTOM_REAL,IMAIN
+ use specfem_par,only: myrank,NPROC,it
+
+ ! ----------------------------------------------
+ ! USER PARAMETER
+
+ ! image data output:
+ ! type = 1 : velocity V_x component
+ ! type = 2 : velocity V_y component
+ ! type = 3 : velocity V_z component
+ ! type = 4 : velocity V norm
+ integer,parameter:: IMAGE_TYPE = 2
+
+ ! cross-section surface
+ ! cross-section origin point
+ real(kind=CUSTOM_REAL),parameter:: section_xorg = 67000.0
+ real(kind=CUSTOM_REAL),parameter:: section_yorg = 0.0
+ real(kind=CUSTOM_REAL),parameter:: section_zorg = 0.0
+
+ ! cross-section surface normal
+ real(kind=CUSTOM_REAL),parameter:: section_nx = 1.0
+ real(kind=CUSTOM_REAL),parameter:: section_ny = 0.0
+ real(kind=CUSTOM_REAL),parameter:: section_nz = 0.0
+
+ ! cross-section (in-plane) horizontal-direction
+ real(kind=CUSTOM_REAL),parameter:: section_hdirx = 0.0
+ real(kind=CUSTOM_REAL),parameter:: section_hdiry = 1.0
+ real(kind=CUSTOM_REAL),parameter:: section_hdirz = 0.0
+
+ ! cross-section (in-plane) vertical-direction
+ real(kind=CUSTOM_REAL),parameter:: section_vdirx = 0.0
+ real(kind=CUSTOM_REAL),parameter:: section_vdiry = 0.0
+ real(kind=CUSTOM_REAL),parameter:: section_vdirz = 1.0
+
+ ! non linear display to enhance small amplitudes in color images
+ real(kind=CUSTOM_REAL), parameter :: POWER_DISPLAY_COLOR = 0.30_CUSTOM_REAL
+
+ ! amplitude threshold
+ real(kind=CUSTOM_REAL),parameter :: image_cutsnaps = 1.e-2
+
+ ! use vp as gray background
+ logical, parameter :: VP_BACKGROUND = .false.
+
+ ! create temporary image files in binary PNM P6 format (smaller)
+ ! or ASCII PNM P3 format (easier to edit)
+ logical, parameter :: BINARY_FILE = .true.
+
+ ! only keeps GIF file
+ logical, parameter :: REMOVE_PNM_FILE = .false.
+ ! ----------------------------------------------
+
+ ! image data
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable:: image_color_vp_display
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable:: image_color_data
+
+ integer,dimension(:,:),allocatable :: iglob_image_color
+ integer,dimension(:,:),allocatable :: ispec_image_color
+
+ ! pixel data
+ real(kind=CUSTOM_REAL),dimension(:),allocatable :: data_pixel_recv
+ real(kind=CUSTOM_REAL),dimension(:),allocatable :: data_pixel_send
+ integer,dimension(:),allocatable :: num_pixel_loc
+ integer,dimension(:),allocatable :: nb_pixel_per_proc
+ integer,dimension(:,:),allocatable :: num_pixel_recv
+ integer :: NX_IMAGE_color,NZ_IMAGE_color
+ integer :: nb_pixel_loc
+
+ end module image_PNM_GIF_par
+
+!=============================================================
+
+ subroutine write_PNM_GIF_initialize()
+
+ use image_PNM_GIF_par
+ use specfem_par,only: NGLOB_AB,NSPEC_AB,ibool,xstore,ystore,zstore,&
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,my_neighbours_ext_mesh, &
+ ibool_interfaces_ext_mesh,prname
+ use constants,only: HUGEVAL,NGLLX,NGLLY,NGLLZ
+ implicit none
+ ! local parameters
+ ! image sizes
+ real(kind=CUSTOM_REAL):: xmin_color_image_loc,xmax_color_image_loc
+ real(kind=CUSTOM_REAL):: xmin_color_image,xmax_color_image
+ real(kind=CUSTOM_REAL):: zmin_color_image_loc,zmax_color_image_loc
+ real(kind=CUSTOM_REAL):: zmin_color_image,zmax_color_image
+ ! image pixels
+ real(kind=CUSTOM_REAL):: size_pixel_horizontal,size_pixel_vertical
+ real(kind=CUSTOM_REAL):: dist_pixel,dist_min_pixel
+ real(kind=CUSTOM_REAL),dimension(:,:),allocatable :: dist_pixel_image,dist_pixel_recv
+ real(kind=CUSTOM_REAL):: pixel_midpoint_x,pixel_midpoint_z,x_loc,z_loc,xtmp,ztmp
+ real(kind=CUSTOM_REAL):: ratio
+ integer:: npgeo,npgeo_glob
+ integer:: i,j,k,iproc,iglob,ispec,ier
+ ! data from mesh
+ real(kind=CUSTOM_REAL),dimension(:),allocatable:: xcoord,zcoord
+ integer,dimension(:),allocatable :: iglob_coord,ispec_coord
+ logical,dimension(:),allocatable:: ispec_is_image_surface,iglob_is_image_surface
+ integer :: num_iglob_image_surface
+ integer :: count,loc(1),irank
+ !character(len=256) :: vtkfilename
+ integer :: zoom_factor = 4
+ logical :: zoom
+
+ ! checks image type
+ if(IMAGE_TYPE > 4 .or. IMAGE_TYPE < 1) then
+ call exit_MPI('GIF image type not implemented yet')
+ endif
+
+ ! user output
+ if( myrank == 0 ) then
+ write(IMAIN,*)
+ write(IMAIN,*) '********'
+ ! type = 1 : velocity V_x component
+ if( IMAGE_TYPE == 1 ) write(IMAIN,*) 'GIF image: velocity V_x component'
+ ! type = 2 : velocity V_y component
+ if( IMAGE_TYPE == 2 ) write(IMAIN,*) 'GIF image: velocity V_y component'
+ ! type = 3 : velocity V_z component
+ if( IMAGE_TYPE == 3 ) write(IMAIN,*) 'GIF image: velocity V_z component'
+ ! type = 4 : velocity V norm
+ if( IMAGE_TYPE == 4 ) write(IMAIN,*) 'GIF image: velocity norm'
+ endif
+
+ ! finds global points on image surface
+ allocate(ispec_is_image_surface(NSPEC_AB),iglob_is_image_surface(NGLOB_AB),stat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating image ispec & iglob ')
+
+ call detect_surface_PNM_GIF_image(NPROC,NGLOB_AB,NSPEC_AB,ibool,&
+ ispec_is_image_surface, &
+ iglob_is_image_surface, &
+ num_iglob_image_surface, &
+ num_interfaces_ext_mesh,max_nibool_interfaces_ext_mesh, &
+ nibool_interfaces_ext_mesh,my_neighbours_ext_mesh, &
+ ibool_interfaces_ext_mesh,&
+ section_xorg,section_yorg,section_zorg, &
+ section_nx,section_ny,section_nz, &
+ xstore,ystore,zstore,myrank)
+
+ ! extracts points on surface
+ allocate( xcoord(num_iglob_image_surface),&
+ zcoord(num_iglob_image_surface),&
+ iglob_coord(num_iglob_image_surface),&
+ ispec_coord(num_iglob_image_surface),stat=ier )
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating xyz image coordinates')
+
+ count=0
+ do ispec=1,NSPEC_AB
+ if( ispec_is_image_surface(ispec) ) then
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ if( iglob_is_image_surface(iglob) ) then
+ count = count+1
+ ! coordinates with respect to horizontal and vertical direction
+ xcoord(count)= xstore(iglob)*section_hdirx &
+ + ystore(iglob)*section_hdiry &
+ + zstore(iglob)*section_hdirz
+ zcoord(count)= xstore(iglob)*section_vdirx &
+ + ystore(iglob)*section_vdiry &
+ + zstore(iglob)*section_vdirz
+ iglob_coord(count) = iglob
+ ispec_coord(count) = ispec
+
+ ! reset iglob flag
+ iglob_is_image_surface(iglob) = .false.
+ endif
+ enddo
+ enddo
+ enddo
+ endif
+ enddo
+
+ if( count /= num_iglob_image_surface) call exit_mpi(myrank,'error image point number')
+
+ !daniel: outputs found global points into vtk file
+ !vtkfilename = prname(1:len_trim(prname))//'GIF_image_points'
+ !call write_VTK_data_points(NGLOB_AB,xstore,ystore,zstore, &
+ ! iglob_coord,count,vtkfilename)
+
+ ! horizontal size of the image
+ xmin_color_image_loc = minval( xcoord(:) )
+ xmax_color_image_loc = maxval( xcoord(:) )
+
+ ! vertical size
+ zmin_color_image_loc = minval( zcoord(:) )
+ zmax_color_image_loc = maxval( zcoord(:) )
+
+ ! global values
+ xmin_color_image = xmin_color_image_loc
+ xmax_color_image = xmax_color_image_loc
+ zmin_color_image = zmin_color_image_loc
+ zmax_color_image = zmax_color_image_loc
+
+ ! global number of points on image slice
+ npgeo = num_iglob_image_surface
+ npgeo_glob = npgeo
+
+ !MPI for all processes
+ ! takes minimum of all process and stores it in xmin_color_image
+ call min_all_all_cr(xmin_color_image_loc,xmin_color_image)
+ call min_all_all_cr(zmin_color_image_loc,zmin_color_image)
+ call max_all_all_cr(xmax_color_image_loc,xmax_color_image)
+ call max_all_all_cr(zmax_color_image_loc,zmax_color_image)
+ call sum_all_all_i(npgeo,npgeo_glob)
+
+ ! compute number of pixels in the horizontal direction and pixels in the vertical
+ ! direction based on ratio of sizes
+ ratio = abs(xmax_color_image - xmin_color_image)/abs(zmax_color_image - zmin_color_image)
+ NX_IMAGE_color = nint( sqrt( ratio * dble(npgeo_glob) ) )
+ NZ_IMAGE_color = nint( dble(npgeo_glob) / NX_IMAGE_color )
+
+ ! convert pixel sizes to even numbers because easier to reduce size,
+ ! create MPEG movies in postprocessing
+ NX_IMAGE_color = 2 * (NX_IMAGE_color / 2)
+ NZ_IMAGE_color = 2 * (NZ_IMAGE_color / 2)
+
+ ! check that image size is not too big
+ if( NX_IMAGE_color > 4096 .or. NZ_IMAGE_color > 4096 ) then
+ ! half of it
+ NX_IMAGE_color = NX_IMAGE_color / 2
+ NZ_IMAGE_color = NZ_IMAGE_color / 2
+ ! even numbers
+ NX_IMAGE_color = 2 * (NX_IMAGE_color / 2)
+ NZ_IMAGE_color = 2 * (NZ_IMAGE_color / 2)
+ endif
+
+ ! ...and not too small
+ zoom = .false.
+ if( NX_IMAGE_color < 200 .or. NZ_IMAGE_color < 200 ) then
+ ! increases it
+ NX_IMAGE_color = NX_IMAGE_color * zoom_factor
+ NZ_IMAGE_color = NZ_IMAGE_color * zoom_factor
+ zoom = .true.
+ endif
+
+ ! create all the pixels
+ size_pixel_horizontal = (xmax_color_image - xmin_color_image) / dble(NX_IMAGE_color)
+ size_pixel_vertical = (zmax_color_image - zmin_color_image) / dble(NZ_IMAGE_color)
+
+ if (myrank == 0) then
+ write(IMAIN,*) ' image points: ',npgeo_glob
+ write(IMAIN,*) ' xmin/xmax: ',xmin_color_image,'/',xmax_color_image
+ write(IMAIN,*) ' zmin/zmax: ',zmin_color_image,'/',zmax_color_image
+ write(IMAIN,*) ' pixel numbers: ',NX_IMAGE_color,' x ',NZ_IMAGE_color
+ write(IMAIN,*) ' pixel sizes : ',size_pixel_horizontal,' x ',size_pixel_vertical
+ endif
+
+ ! allocate an array for the grid point that corresponds to a given image data point
+ allocate(iglob_image_color(NX_IMAGE_color,NZ_IMAGE_color),&
+ ispec_image_color(NX_IMAGE_color,NZ_IMAGE_color),stat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating iglob_image_color')
+
+ allocate(dist_pixel_image(NX_IMAGE_color,NZ_IMAGE_color),stat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating dist pixel image')
+
+ iglob_image_color(:,:) = -1
+ ispec_image_color(:,:) = 0
+ dist_pixel_image(:,:) = HUGEVAL
+ do j=1,NZ_IMAGE_color
+ do i=1,NX_IMAGE_color
+ ! calculates midpoint of pixel
+ xtmp = xmin_color_image + (i-1)*size_pixel_horizontal
+ ztmp = zmin_color_image + (j-1)*size_pixel_vertical
+ pixel_midpoint_x = xtmp + 0.5*size_pixel_horizontal
+ pixel_midpoint_z = ztmp + 0.5*size_pixel_vertical
+
+ ! avoid points on image border rim
+ if( pixel_midpoint_x < xmin_color_image_loc &
+ .or. pixel_midpoint_x > xmax_color_image_loc ) cycle
+ if( pixel_midpoint_z < zmin_color_image_loc &
+ .or. pixel_midpoint_z > zmax_color_image_loc ) cycle
+
+ ! looks for closest point to midpoint of pixel
+ dist_min_pixel = HUGEVAL
+ do iglob=1,num_iglob_image_surface
+ ! point location with respect to image surface
+ x_loc = xcoord(iglob)
+ z_loc = zcoord(iglob)
+
+ ! checks if inside pixel range for larger numbers of points, minimizing computation time
+ if( zoom ) then
+ if( x_loc < xtmp-zoom_factor*size_pixel_horizontal .or. &
+ x_loc > xtmp + (zoom_factor+1)*size_pixel_horizontal ) cycle
+ if( z_loc < ztmp-zoom_factor*size_pixel_vertical .or. &
+ z_loc > ztmp + (zoom_factor+1)*size_pixel_vertical ) cycle
+ else
+ if( x_loc < xtmp .or. x_loc > xtmp + size_pixel_horizontal ) cycle
+ if( z_loc < ztmp .or. z_loc > ztmp + size_pixel_vertical ) cycle
+ endif
+
+ ! stores closest iglob
+ x_loc = pixel_midpoint_x - x_loc
+ z_loc = pixel_midpoint_z - z_loc
+ dist_pixel = x_loc*x_loc + z_loc*z_loc
+ if( dist_pixel < dist_min_pixel) then
+ dist_min_pixel = dist_pixel
+ dist_pixel_image(i,j) = dist_min_pixel
+ iglob_image_color(i,j) = iglob_coord(iglob)
+ ispec_image_color(i,j) = ispec_coord(iglob)
+ endif
+ enddo
+ enddo
+ enddo
+ deallocate(xcoord,zcoord,iglob_coord,ispec_coord)
+
+ ! gather info from other processes as well
+ allocate(dist_pixel_recv(NX_IMAGE_color,0:NPROC-1),stat=ier)
+ if(ier /= 0 ) call exit_mpi(myrank,'error allocating dist pixel recv')
+ dist_pixel_recv(:,:) = HUGEVAL
+ nb_pixel_loc = 0
+ do j=1,NZ_IMAGE_color
+ ! compares with other processes
+ call gather_all_all_cr(dist_pixel_image(:,j),dist_pixel_recv,NX_IMAGE_color,NPROC)
+
+ ! selects entries
+ do i=1,NX_IMAGE_color
+ ! note: minimum location will be between 1 and NPROC
+ loc = minloc(dist_pixel_recv(i,:))
+ irank = loc(1) - 1
+ ! store only own best points
+ if( irank == myrank .and. dist_pixel_recv(i,irank) < HUGEVAL) then
+ ! increases count
+ nb_pixel_loc = nb_pixel_loc + 1
+ else
+ ! resets index
+ iglob_image_color(i,j) = -1
+ ispec_image_color(i,j) = 0
+ endif
+ enddo
+ enddo
+ deallocate(dist_pixel_recv,dist_pixel_image)
+
+ ! creating and filling array num_pixel_loc with the positions of each colored
+ ! pixel owned by the local process (useful for parallel jobs)
+ allocate(num_pixel_loc(nb_pixel_loc))
+ nb_pixel_loc = 0
+ do i = 1, NX_IMAGE_color
+ do j = 1, NZ_IMAGE_color
+ if ( iglob_image_color(i,j) /= -1 ) then
+ nb_pixel_loc = nb_pixel_loc + 1
+ num_pixel_loc(nb_pixel_loc) = (j-1)*NX_IMAGE_color + i
+ endif
+ enddo
+ enddo
+
+ ! filling array iglob_image_color, containing info on which process owns which pixels.
+ allocate(nb_pixel_per_proc(0:NPROC-1))
+ call gather_all_i(nb_pixel_loc,1,nb_pixel_per_proc,1,NPROC)
+
+ ! allocates receiving array
+ if ( myrank == 0 ) then
+ allocate( num_pixel_recv(maxval(nb_pixel_per_proc(:)),0:NPROC-1) )
+ endif
+ ! fills iglob_image_color index array
+ if( NPROC > 1 ) then
+ if (myrank == 0) then
+ do iproc = 1, NPROC-1
+ call recv_i(num_pixel_recv(:,iproc),nb_pixel_per_proc(iproc),iproc,42)
+
+ ! stores proc number instead where iglob_image_color wouldn't be defined (=-1)
+ do k = 1, nb_pixel_per_proc(iproc)
+ j = ceiling(real(num_pixel_recv(k,iproc)) / real(NX_IMAGE_color))
+ i = num_pixel_recv(k,iproc) - (j-1)*NX_IMAGE_color
+ iglob_image_color(i,j) = iproc
+ enddo
+ enddo
+ else
+ call send_i(num_pixel_loc(:),nb_pixel_loc,0,42)
+ endif
+ endif
+
+ ! allocate an array for image data
+ allocate(image_color_data(NX_IMAGE_color,NZ_IMAGE_color), &
+ image_color_vp_display(NX_IMAGE_color,NZ_IMAGE_color),stat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating image data')
+
+ image_color_data(:,:) = 0._CUSTOM_REAL
+ image_color_vp_display(:,:) = 0._CUSTOM_REAL
+
+ if ( myrank == 0 ) then
+ allocate( data_pixel_recv(maxval(nb_pixel_per_proc(:))) )
+ data_pixel_recv(:) = 0._CUSTOM_REAL
+ endif
+ allocate(data_pixel_send(nb_pixel_loc),stat=ier)
+ if(ier /= 0 ) call exit_mpi(myrank,'error allocating image send data')
+ data_pixel_send(:) = 0._CUSTOM_REAL
+
+ ! handles vp background data
+ call write_PNM_GIF_vp_background()
+
+ ! user output
+ if( myrank == 0 ) then
+ write(IMAIN,*) '******** '
+ write(IMAIN,*)
+ endif
+
+
+ end subroutine write_PNM_GIF_initialize
+
+
+!=============================================================
+
+
+ subroutine write_PNM_GIF_vp_background
+
+ use image_PNM_GIF_par
+ use specfem_par,only:myrank
+ implicit none
+ ! local parameters
+ real(kind=CUSTOM_REAL) :: vp
+ integer :: i,j,k,iglob,ispec,iproc
+
+ ! getting velocity for each local pixels
+ image_color_vp_display(:,:) = 0.d0
+
+ do k = 1, nb_pixel_loc
+ j = ceiling(real(num_pixel_loc(k)) / real(NX_IMAGE_color))
+ i = num_pixel_loc(k) - (j-1)*NX_IMAGE_color
+
+ iglob = iglob_image_color(i,j)
+ ispec = ispec_image_color(i,j)
+ call get_iglob_vp(iglob,ispec,vp)
+
+ data_pixel_send(k) = vp
+ image_color_vp_display(i,j) = vp
+ enddo
+
+ ! MPI assembling array image_color_vp_display on process zero for color output
+ if (NPROC > 1) then
+ ! master collects
+ if (myrank == 0) then
+ do iproc = 1, NPROC-1
+ call recvv_cr(data_pixel_recv(1),nb_pixel_per_proc(iproc),iproc,43)
+ ! fills vp display array
+ do k = 1, nb_pixel_per_proc(iproc)
+ j = ceiling(real(num_pixel_recv(k,iproc)) / real(NX_IMAGE_color))
+ i = num_pixel_recv(k,iproc) - (j-1)*NX_IMAGE_color
+ image_color_vp_display(i,j) = data_pixel_recv(k)
+ enddo
+ enddo
+ else
+ ! slave processes send
+ call sendv_cr(data_pixel_send,nb_pixel_loc,0,43)
+ endif
+ endif
+
+ end subroutine write_PNM_GIF_vp_background
+
+
+!================================================================
+
+ subroutine write_PNM_GIF_create_image
+
+! creates color PNM/GIF image
+
+ use image_PNM_GIF_par
+ use constants,only: NDIM
+ implicit none
+
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(NDIM) :: veloc_val
+ real(kind=CUSTOM_REAL):: temp
+ integer :: i,j,k,iglob,ispec,iproc
+
+ ! initializes color data
+ image_color_data(:,:) = 0.d0
+
+ ! reads/retrieves color data
+ do k = 1, nb_pixel_loc
+ j = ceiling(real(num_pixel_loc(k)) / real(NX_IMAGE_color))
+ i = num_pixel_loc(k) - (j-1)*NX_IMAGE_color
+
+ ! global point and element indices of gll point in this pixel
+ iglob = iglob_image_color(i,j)
+ ispec = ispec_image_color(i,j)
+
+ ! gets velocity for point iglob
+ call get_iglob_veloc(iglob,ispec,veloc_val)
+
+ ! data type
+ if( IMAGE_TYPE == 4 ) then
+ ! velocity norm
+ temp = sqrt( veloc_val(1)**2 + veloc_val(2)**2 + veloc_val(3)**2 )
+ else
+ ! velocity component
+ temp = veloc_val(IMAGE_TYPE)
+ endif
+
+ ! stores data
+ image_color_data(i,j) = temp
+ data_pixel_send(k) = temp
+ enddo
+
+ ! MPI assembling array image_color_data on process zero for color output
+ if (NPROC > 1) then
+ if (myrank == 0) then
+ do iproc = 1, NPROC-1
+ call recvv_cr(data_pixel_recv(1),nb_pixel_per_proc(iproc),iproc,43)
+ ! distributes on image pixels
+ do k = 1, nb_pixel_per_proc(iproc)
+ j = ceiling(real(num_pixel_recv(k,iproc)) / real(NX_IMAGE_color))
+ i = num_pixel_recv(k,iproc) - (j-1)*NX_IMAGE_color
+ image_color_data(i,j) = data_pixel_recv(k)
+ enddo
+ enddo
+ else
+ ! slave processes send
+ call sendv_cr(data_pixel_send(1),nb_pixel_loc,0,43)
+ endif
+ endif
+
+ ! master process writes out file
+ if (myrank == 0) then
+ ! writes output file
+ call write_PNM_GIF_data(image_color_data,iglob_image_color,&
+ NX_IMAGE_color,NZ_IMAGE_color,it,image_cutsnaps,image_color_vp_display)
+ endif
+
+
+ end subroutine write_PNM_GIF_create_image
+
+
+!================================================================
+
+
+ subroutine write_PNM_GIF_data(color_image_2D_data,iglob_image_color_2D,&
+ NX,NY,it,cutsnaps,image_color_vp_display)
+
+! display a given field as a red and blue color image
+! to display the snapshots : display image*.gif
+! when compiling with Intel ifort, use " -assume byterecl " option to create binary PNM images
+ use constants,only: HUGEVAL,TINYVAL,CUSTOM_REAL
+ use image_PNM_GIF_par,only: BINARY_FILE,VP_BACKGROUND,&
+ POWER_DISPLAY_COLOR,REMOVE_PNM_FILE
+ implicit none
+
+ integer :: NX,NY,it
+ real(kind=CUSTOM_REAL) :: cutsnaps
+
+ integer, dimension(NX,NY) :: iglob_image_color_2D
+
+ real(kind=CUSTOM_REAL), dimension(NX,NY) :: color_image_2D_data
+ real(kind=CUSTOM_REAL), dimension(NX,NY) :: image_color_vp_display
+
+ ! local parameter
+ integer :: ix,iy,R,G,B,tenthousands,thousands,hundreds,tens,units,remainder,current_rec
+ real(kind=CUSTOM_REAL) :: amplitude_max,normalized_value,vpmin,vpmax,x1
+ character(len=256) :: file_name,system_command
+ ! ASCII code of character '0' and of carriage return character
+ integer, parameter :: ascii_code_of_zero = 48, ascii_code_of_carriage_return = 10
+
+ ! open the image file
+ write(file_name,"('OUTPUT_FILES/image',i7.7,'.pnm')") it
+
+ if(BINARY_FILE) then
+ open(unit=27,file=file_name,status='unknown',access='direct',recl=1)
+ write(27,rec=1) 'P'
+ write(27,rec=2) '6' ! write P6 = binary PNM image format
+ write(27,rec=3) char(ascii_code_of_carriage_return)
+
+ ! compute and write horizontal size
+ remainder = NX
+
+ tenthousands = remainder / 10000
+ remainder = remainder - 10000 * tenthousands
+
+ thousands = remainder / 1000
+ remainder = remainder - 1000 * thousands
+
+ hundreds = remainder / 100
+ remainder = remainder - 100 * hundreds
+
+ tens = remainder / 10
+ remainder = remainder - 10 * tens
+
+ units = remainder
+
+ write(27,rec=4) char(tenthousands + ascii_code_of_zero)
+ write(27,rec=5) char(thousands + ascii_code_of_zero)
+ write(27,rec=6) char(hundreds + ascii_code_of_zero)
+ write(27,rec=7) char(tens + ascii_code_of_zero)
+ write(27,rec=8) char(units + ascii_code_of_zero)
+ write(27,rec=9) ' '
+
+ ! compute and write vertical size
+ remainder = NY
+
+ tenthousands = remainder / 10000
+ remainder = remainder - 10000 * tenthousands
+
+ thousands = remainder / 1000
+ remainder = remainder - 1000 * thousands
+
+ hundreds = remainder / 100
+ remainder = remainder - 100 * hundreds
+
+ tens = remainder / 10
+ remainder = remainder - 10 * tens
+
+ units = remainder
+
+ write(27,rec=10) char(tenthousands + ascii_code_of_zero)
+ write(27,rec=11) char(thousands + ascii_code_of_zero)
+ write(27,rec=12) char(hundreds + ascii_code_of_zero)
+ write(27,rec=13) char(tens + ascii_code_of_zero)
+ write(27,rec=14) char(units + ascii_code_of_zero)
+ write(27,rec=15) char(ascii_code_of_carriage_return)
+
+ ! number of shades
+ write(27,rec=16) '2'
+ write(27,rec=17) '5'
+ write(27,rec=18) '5'
+ write(27,rec=19) char(ascii_code_of_carriage_return)
+
+ ! block of image data starts at sixteenth character
+ current_rec = 20
+ else
+ open(unit=27,file=file_name,status='unknown')
+ write(27,"('P3')") ! write P3 = ASCII PNM image format
+ write(27,*) NX,NY ! write image size
+ write(27,*) '255' ! number of shades
+ endif
+
+ ! compute maximum amplitude
+ vpmin = HUGEVAL
+ vpmax = TINYVAL
+ do iy=1,NY
+ do ix=1,NX
+ if ( iglob_image_color_2D(ix,iy) > -1 ) then
+ vpmin = min(vpmin,image_color_vp_display(ix,iy))
+ vpmax = max(vpmax,image_color_vp_display(ix,iy))
+ endif
+ enddo
+ enddo
+ amplitude_max = maxval(abs(color_image_2D_data))
+ if( amplitude_max < TINYVAL ) amplitude_max = HUGEVAL
+
+ ! in the PNM format, the image starts in the upper-left corner
+ do iy=NY,1,-1
+ do ix=1,NX
+ ! check if pixel is defined or not (can be above topography for instance)
+ if(iglob_image_color_2D(ix,iy) == -1) then
+ ! use black (/light blue) to display undefined region above topography
+ R = 0 !204
+ G = 0 !255
+ B = 0 !255
+
+ ! suppress small amplitudes considered as noise
+ else if (abs(color_image_2D_data(ix,iy)) < amplitude_max * cutsnaps) then
+
+ if( VP_BACKGROUND ) then
+ ! use P velocity model as background where amplitude is negligible
+ if((vpmax-vpmin)/vpmin > 0.02d0) then
+ x1 = (image_color_vp_display(ix,iy)-vpmin)/(vpmax-vpmin)
+ else
+ x1 = 0.5d0
+ endif
+
+ ! rescale to avoid very dark gray levels
+ x1 = x1*0.7 + 0.2
+ if(x1 > 1.d0) x1=1.d0
+
+ ! invert scale: white = vpmin, dark gray = vpmax
+ x1 = 1.d0 - x1
+
+ ! map to [0,255]
+ x1 = x1 * 255.d0
+
+ R = nint(x1)
+ if(R < 0) R = 0
+ if(R > 255) R = 255
+ G = R
+ B = R
+ else
+ ! white
+ R = 255
+ G = 255
+ B = 255
+ endif
+
+ else
+ ! define normalized image data in [-1:1] and convert to nearest integer
+ ! keeping in mind that data values can be negative
+ normalized_value = color_image_2D_data(ix,iy) / amplitude_max
+
+ ! suppress values outside of [-1:+1]
+ if(normalized_value < -1.d0) normalized_value = -1.d0
+ if(normalized_value > 1.d0) normalized_value = 1.d0
+
+ ! use red if positive value, blue if negative, no green
+ if(normalized_value >= 0.d0) then
+ R = nint(255.d0*normalized_value**POWER_DISPLAY_COLOR)
+ G = 0
+ B = 0
+ else
+ R = 0
+ G = 0
+ B = nint(255.d0*abs(normalized_value)**POWER_DISPLAY_COLOR)
+ endif
+ endif
+
+ ! write color image
+ if(BINARY_FILE) then
+ ! first write red
+ write(27,rec=current_rec) char(R)
+ current_rec = current_rec + 1
+ ! then write green
+ write(27,rec=current_rec) char(G)
+ current_rec = current_rec + 1
+ ! then write blue
+ write(27,rec=current_rec) char(B)
+ current_rec = current_rec + 1
+ else
+ write(27,"(i3,' ',i3,' ',i3)") R,G,B
+ endif
+ enddo
+ enddo
+
+ ! close the file
+ close(27)
+
+ ! open image file and create system command to convert image to more convenient format
+ write(system_command,"('cd OUTPUT_FILES ; convert image',i7.7,'.pnm image',i7.7,'.gif')") it,it
+
+ ! call the system to convert image to GIF
+ call system(system_command)
+
+ ! removes pnm file
+ if( REMOVE_PNM_FILE ) then
+ write(system_command,"('cd OUTPUT_FILES ; rm -f image',i7.7,'.pnm')") it
+ call system(system_command)
+ endif
+
+ end subroutine write_PNM_GIF_data
+
+!=============================================================
+
+ subroutine get_iglob_vp(iglob,ispec,vp)
+
+ use constants,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,FOUR_THIRDS
+ use specfem_par,only: mustore,kappastore,ibool,myrank,NSPEC_AB
+ use specfem_par_acoustic,only: ACOUSTIC_SIMULATION,rhostore
+ use specfem_par_elastic,only: ELASTIC_SIMULATION,rho_vp
+ implicit none
+
+ integer,intent(in) :: iglob,ispec
+ real(kind=CUSTOM_REAL),intent(out):: vp
+
+ !local parameters
+ integer :: i,j,k
+
+ ! returns first vp encountered for iglob index
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( ibool(i,j,k,ispec) == iglob ) then
+ ! calculates vp
+ if( ELASTIC_SIMULATION ) then
+ vp = (FOUR_THIRDS * mustore(i,j,k,ispec) + kappastore(i,j,k,ispec)) / rho_vp(i,j,k,ispec)
+ else if( ACOUSTIC_SIMULATION ) then
+ vp = sqrt( kappastore(i,j,k,ispec) / rhostore(i,j,k,ispec) )
+ else
+ call exit_mpi(myrank,'error vp not implemented')
+ endif
+ return
+ endif
+ enddo
+ enddo
+ enddo
+
+ end subroutine get_iglob_vp
+
+!=============================================================
+
+ subroutine get_iglob_veloc(iglob,ispec,veloc_val)
+
+ use constants,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,NDIM
+ use specfem_par_acoustic,only: ACOUSTIC_SIMULATION,potential_dot_acoustic,&
+ rhostore,ispec_is_acoustic
+ use specfem_par_elastic,only: ELASTIC_SIMULATION,veloc,ispec_is_elastic
+ use specfem_par,only: NSPEC_AB,NGLOB_AB,hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool
+ implicit none
+
+ integer,intent(in) :: iglob,ispec
+ real(kind=CUSTOM_REAL),dimension(NDIM),intent(out):: veloc_val
+
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: veloc_element
+ integer :: i,j,k
+
+ ! returns first element encountered for iglob index
+ if( ELASTIC_SIMULATION ) then
+ if( ispec_is_elastic(ispec) ) then
+ veloc_val(:) = veloc(:,iglob)
+ return
+ endif
+ endif
+ if( ACOUSTIC_SIMULATION ) then
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! returns corresponding iglob velocity entry
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( ibool(i,j,k,ispec) == iglob ) then
+ veloc_val(:) = veloc_element(:,i,j,k)
+ return
+ endif
+ enddo
+ enddo
+ enddo
+
+ endif
+ endif
+
+ ! should not reach this point
+ call exit_mpi(0,'error image velocity not found')
+
+ end subroutine get_iglob_veloc
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_VTK_data.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_VTK_data.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_VTK_data.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,394 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+
+
+! routine for saving vtk file holding integer flag on each spectral element
+
+ subroutine write_VTK_data_elem_i(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ elem_flag,prname_file)
+
+
+ implicit none
+
+ 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
+
+! element flag array
+ integer, dimension(nspec) :: elem_flag
+ integer :: ispec,i
+
+! file name
+ character(len=256) prname_file
+
+! write source and receiver VTK files for Paraview
+ write(IMAIN,*) ' vtk file: '
+ write(IMAIN,*) ' ',prname_file(1:len_trim(prname_file))//'.vtk'
+
+ open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
+ write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
+ write(IOVTK,'(a)') 'material model VTK file'
+ write(IOVTK,'(a)') 'ASCII'
+ write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
+ write(IOVTK, '(a,i12,a)') 'POINTS ', nglob, ' float'
+ do i=1,nglob
+ write(IOVTK,'(3e18.6)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
+ enddo
+ write(IOVTK,*) ""
+
+ ! note: indices for vtk start at 0
+ write(IOVTK,'(a,i12,i12)') "CELLS ",nspec,nspec*9
+ do ispec=1,nspec
+ write(IOVTK,'(9i12)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
+ ibool(1,1,NGLLZ,ispec)-1,ibool(NGLLX,1,NGLLZ,ispec)-1,ibool(NGLLX,NGLLY,NGLLZ,ispec)-1,ibool(1,NGLLY,NGLLZ,ispec)-1
+ enddo
+ write(IOVTK,*) ""
+
+ ! type: hexahedrons
+ write(IOVTK,'(a,i12)') "CELL_TYPES ",nspec
+ write(IOVTK,*) (12,ispec=1,nspec)
+ write(IOVTK,*) ""
+
+ write(IOVTK,'(a,i12)') "CELL_DATA ",nspec
+ write(IOVTK,'(a)') "SCALARS elem_flag integer"
+ write(IOVTK,'(a)') "LOOKUP_TABLE default"
+ do ispec = 1,nspec
+ write(IOVTK,*) elem_flag(ispec)
+ enddo
+ write(IOVTK,*) ""
+ close(IOVTK)
+
+
+ end subroutine write_VTK_data_elem_i
+
+
+!=============================================================
+
+! external mesh routine for saving vtk files for custom_real values on all gll points
+
+ subroutine write_VTK_data_gll_cr(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ gll_data,prname_file)
+
+ implicit none
+
+ 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
+
+! gll data values array
+ real(kind=CUSTOM_REAL), 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=256) prname_file
+
+ integer :: ispec,i,j,k,ier,iglob
+
+! write source and receiver VTK files for Paraview
+ write(IMAIN,*) ' vtk file: '
+ write(IMAIN,*) ' ',prname_file(1:len_trim(prname_file))//'.vtk'
+
+ open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
+ write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
+ write(IOVTK,'(a)') 'material model VTK file'
+ write(IOVTK,'(a)') 'ASCII'
+ write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
+ write(IOVTK, '(a,i12,a)') 'POINTS ', nglob, ' float'
+ do i=1,nglob
+ write(IOVTK,'(3e18.6)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
+ enddo
+ write(IOVTK,*) ""
+
+ ! note: indices for vtk start at 0
+ write(IOVTK,'(a,i12,i12)') "CELLS ",nspec,nspec*9
+ do ispec=1,nspec
+ write(IOVTK,'(9i12)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
+ ibool(1,1,NGLLZ,ispec)-1,ibool(NGLLX,1,NGLLZ,ispec)-1,ibool(NGLLX,NGLLY,NGLLZ,ispec)-1,ibool(1,NGLLY,NGLLZ,ispec)-1
+ enddo
+ write(IOVTK,*) ""
+
+ ! type: hexahedrons
+ write(IOVTK,'(a,i12)') "CELL_TYPES ",nspec
+ write(IOVTK,*) (12,ispec=1,nspec)
+ write(IOVTK,*) ""
+
+ ! iflag field on global nodeset
+ allocate(mask_ibool(nglob),flag_val(nglob),stat=ier)
+ if( ier /= 0 ) stop 'error allocating mask'
+
+ mask_ibool = .false.
+ do ispec=1,nspec
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ if( .not. mask_ibool(iglob) ) then
+ flag_val(iglob) = gll_data(i,j,k,ispec)
+ mask_ibool(iglob) = .true.
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+ write(IOVTK,'(a,i12)') "POINT_DATA ",nglob
+ write(IOVTK,'(a)') "SCALARS gll_data float"
+ write(IOVTK,'(a)') "LOOKUP_TABLE default"
+ do i = 1,nglob
+ write(IOVTK,*) flag_val(i)
+ enddo
+ write(IOVTK,*) ""
+
+ close(IOVTK)
+
+
+ end subroutine write_VTK_data_gll_cr
+
+!=============================================================
+
+! external mesh routine for saving vtk files for integer values on all gll points
+
+ subroutine write_VTK_data_gll_i(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ gll_data,prname_file)
+
+ implicit none
+
+ 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
+
+! 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=256) prname_file
+
+ integer :: ispec,i,j,k,ier,iglob
+
+! write source and receiver VTK files for Paraview
+ write(IMAIN,*) ' vtk file: '
+ write(IMAIN,*) ' ',prname_file(1:len_trim(prname_file))//'.vtk'
+
+ open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
+ write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
+ write(IOVTK,'(a)') 'material model VTK file'
+ write(IOVTK,'(a)') 'ASCII'
+ write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
+ write(IOVTK, '(a,i12,a)') 'POINTS ', nglob, ' float'
+ do i=1,nglob
+ write(IOVTK,'(3e18.6)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
+ enddo
+ write(IOVTK,*) ""
+
+ ! note: indices for vtk start at 0
+ write(IOVTK,'(a,i12,i12)') "CELLS ",nspec,nspec*9
+ do ispec=1,nspec
+ write(IOVTK,'(9i12)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
+ ibool(1,1,NGLLZ,ispec)-1,ibool(NGLLX,1,NGLLZ,ispec)-1,ibool(NGLLX,NGLLY,NGLLZ,ispec)-1,ibool(1,NGLLY,NGLLZ,ispec)-1
+ enddo
+ write(IOVTK,*) ""
+
+ ! type: hexahedrons
+ write(IOVTK,'(a,i12)') "CELL_TYPES ",nspec
+ write(IOVTK,*) (12,ispec=1,nspec)
+ write(IOVTK,*) ""
+
+ ! iflag field on global nodeset
+ allocate(mask_ibool(nglob),flag_val(nglob),stat=ier)
+ if( ier /= 0 ) stop 'error allocating mask'
+
+ mask_ibool = .false.
+ do ispec=1,nspec
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ if( .not. mask_ibool(iglob) ) then
+ flag_val(iglob) = gll_data(i,j,k,ispec)
+ mask_ibool(iglob) = .true.
+ endif
+ enddo
+ enddo
+ enddo
+ enddo
+
+ write(IOVTK,'(a,i12)') "POINT_DATA ",nglob
+ write(IOVTK,'(a)') "SCALARS gll_data float"
+ write(IOVTK,'(a)') "LOOKUP_TABLE default"
+ do i = 1,nglob
+ write(IOVTK,*) flag_val(i)
+ enddo
+ write(IOVTK,*) ""
+
+ close(IOVTK)
+
+
+ end subroutine write_VTK_data_gll_i
+
+!=============================================================
+
+! external mesh routine for saving vtk files for points locations
+
+ subroutine write_VTK_data_points(nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy, &
+ points_globalindices,num_points_globalindices, &
+ prname_file)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nglob
+
+! global coordinates
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
+
+! gll data values array
+ integer :: num_points_globalindices
+ integer, dimension(num_points_globalindices) :: points_globalindices
+
+! file name
+ character(len=256) prname_file
+
+ integer :: i,iglob
+
+! write source and receiver VTK files for Paraview
+ write(IMAIN,*) ' vtk file: '
+ write(IMAIN,*) ' ',prname_file(1:len_trim(prname_file))//'.vtk'
+
+ open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
+ write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
+ write(IOVTK,'(a)') 'material model VTK file'
+ write(IOVTK,'(a)') 'ASCII'
+ write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
+ write(IOVTK, '(a,i12,a)') 'POINTS ', num_points_globalindices, ' float'
+ do i=1,num_points_globalindices
+ iglob = points_globalindices(i)
+ if( iglob <= 0 .or. iglob > nglob ) then
+ print*,'error: '//prname_file(1:len_trim(prname_file))//'.vtk'
+ print*,'error global index: ',iglob,i
+ close(IOVTK)
+ stop 'error vtk points file'
+ endif
+
+ write(IOVTK,'(3e18.6)') xstore_dummy(iglob),ystore_dummy(iglob),zstore_dummy(iglob)
+ enddo
+ write(IOVTK,*) ""
+
+ close(IOVTK)
+
+
+ end subroutine write_VTK_data_points
+
+
+!=============================================================
+
+! external mesh routine for saving vtk files for points locations
+
+ subroutine write_VTK_data_elem_vectors(nspec,nglob, &
+ xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
+ elem_vector,prname_file)
+
+
+ implicit none
+
+ 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
+
+ ! element flag array
+ real(kind=CUSTOM_REAL), dimension(3,nspec) :: elem_vector
+ integer :: ispec,i
+
+ ! file name
+ character(len=256) prname_file
+
+ ! write source and receiver VTK files for Paraview
+ write(IMAIN,*) ' vtk file: '
+ write(IMAIN,*) ' ',prname_file(1:len_trim(prname_file))//'.vtk'
+
+ open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
+ write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
+ write(IOVTK,'(a)') 'material model VTK file'
+ write(IOVTK,'(a)') 'ASCII'
+ write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
+ write(IOVTK, '(a,i12,a)') 'POINTS ', nglob, ' float'
+ do i=1,nglob
+ write(IOVTK,'(3e18.6)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
+ enddo
+ write(IOVTK,*) ""
+
+ ! note: indices for vtk start at 0
+ write(IOVTK,'(a,i12,i12)') "CELLS ",nspec,nspec*9
+ do ispec=1,nspec
+ write(IOVTK,'(9i12)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
+ ibool(1,1,NGLLZ,ispec)-1,ibool(NGLLX,1,NGLLZ,ispec)-1,ibool(NGLLX,NGLLY,NGLLZ,ispec)-1,ibool(1,NGLLY,NGLLZ,ispec)-1
+ enddo
+ write(IOVTK,*) ""
+
+ ! type: hexahedrons
+ write(IOVTK,'(a,i12)') "CELL_TYPES ",nspec
+ write(IOVTK,*) (12,ispec=1,nspec)
+ write(IOVTK,*) ""
+
+ ! vector data for each cell
+ write(IOVTK,'(a,i12)') "CELL_DATA ",nspec
+ write(IOVTK,'(a)') "VECTORS _vectors_ float"
+ do i=1,nspec
+ write(IOVTK,*) elem_vector(1,i),elem_vector(2,i),elem_vector(3,i)
+ enddo
+
+ write(IOVTK,*) ""
+ close(IOVTK)
+
+
+ end subroutine write_VTK_data_elem_vectors
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_c_binary.c
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_c_binary.c (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_c_binary.c 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,65 @@
+/*
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+*/
+
+// after Brian's function
+
+#include "config.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include <unistd.h>
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+
+static int fd;
+
+void
+FC_FUNC_(open_file,OPEN_FILE)(char *file) {
+ /* fprintf(stderr, "Opening file: %s\n", file); */
+ fd = open(file, O_WRONLY | O_CREAT, 0644);
+ if(fd == -1) {
+ fprintf(stderr, "Error opening file: %s exiting\n", file);
+ exit(-1);
+ }
+}
+
+void
+FC_FUNC_(close_file,CLOSE_FILE)() {
+ /* fprintf(stderr, "Closing file\n"); */
+ close(fd);
+}
+
+void
+FC_FUNC_(write_integer,WRITE_INTEGER)(int *z) {
+ write(fd, z, sizeof(int));
+}
+
+void
+FC_FUNC_(write_real,WRITE_REAL)(float *z) {
+ write(fd, z, sizeof(float));
+}
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_movie_output.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_movie_output.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_movie_output.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,1155 @@
+!=====================================================================
+!
+! 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.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+ subroutine write_movie_output()
+
+ use specfem_par
+ use specfem_par_movie
+ implicit none
+
+ ! shakemap creation
+ if (EXTERNAL_MESH_CREATE_SHAKEMAP) then
+ call wmo_create_shakemap_em()
+ endif
+
+ ! movie file creation
+ if(EXTERNAL_MESH_MOVIE_SURFACE .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
+ call wmo_create_movie_surface_em()
+ endif
+
+ ! saves MOVIE on the SURFACE
+ if(MOVIE_SURFACE .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
+ call wmo_movie_surface_output_o()
+ endif
+
+ ! computes SHAKING INTENSITY MAP
+ if(CREATE_SHAKEMAP) then
+ call wmo_create_shakemap_o()
+ endif
+
+ ! saves MOVIE in full 3D MESH
+ if(MOVIE_VOLUME .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
+ call wmo_movie_volume_output()
+ endif
+
+ ! creates cross-section GIF image
+ if(PNM_GIF_IMAGE .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0 ) then
+ call write_PNM_GIF_create_image()
+ endif
+
+ end subroutine write_movie_output
+
+
+
+!================================================================
+
+ subroutine wmo_create_shakemap_em()
+
+! creation of shapemap file
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_movie
+ implicit none
+
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: &
+ displ_element,veloc_element,accel_element
+ integer :: ipoin,ispec,iglob,ispec2D
+ integer :: i,j,k
+ logical :: is_done
+
+! initializes arrays for point coordinates
+ if (it == 1) then
+ store_val_ux_external_mesh(:) = -HUGEVAL
+ store_val_uy_external_mesh(:) = -HUGEVAL
+ store_val_uz_external_mesh(:) = -HUGEVAL
+ do ispec2D = 1,nfaces_surface_ext_mesh
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do ipoin = 1, NGLLX*NGLLY
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
+ ! x,y,z coordinates
+ store_val_x_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = xstore(iglob)
+ store_val_y_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = ystore(iglob)
+ store_val_z_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = zstore(iglob)
+ enddo
+ else
+ do ipoin = 1, 4
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
+ ! x,y,z coordinates
+ store_val_x_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = xstore(iglob)
+ store_val_y_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = ystore(iglob)
+ store_val_z_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = zstore(iglob)
+ enddo
+ endif
+ enddo
+ endif
+
+! stores displacement, velocity and acceleration amplitudes
+ do ispec2D = 1,nfaces_surface_ext_mesh
+ ispec = faces_surface_ext_mesh_ispec(ispec2D)
+
+ if( ispec_is_acoustic(ispec) ) then
+ ! displacement vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_acoustic, displ_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! accel ?
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_dot_acoustic, accel_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ endif
+
+
+ ! high-resolution
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do ipoin = 1, NGLLX*NGLLY
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
+ ! saves norm of displacement,velocity and acceleration vector
+ if( ispec_is_elastic(ispec) ) then
+ ! norm of displacement
+ store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
+ max(store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
+ sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2))
+ ! norm of velocity
+ store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
+ max(store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
+ sqrt(veloc(1,iglob)**2 + veloc(2,iglob)**2 + veloc(3,iglob)**2))
+ ! norm of acceleration
+ store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
+ max(store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
+ sqrt(accel(1,iglob)**2 + accel(2,iglob)**2 + accel(3,iglob)**2))
+ endif
+
+ ! acoustic domains
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ ! norm of displacement
+ store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
+ max(store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
+ sqrt(displ_element(1,i,j,k)**2 &
+ + displ_element(2,i,j,k)**2 &
+ + displ_element(3,i,j,k)**2))
+ ! norm of velocity
+ store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
+ max(store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
+ sqrt(veloc_element(1,i,j,k)**2 &
+ + veloc_element(2,i,j,k)**2 &
+ + veloc_element(3,i,j,k)**2))
+ ! norm of acceleration
+ store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = &
+ max(store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin), &
+ sqrt(accel_element(1,i,j,k)**2 &
+ + accel_element(2,i,j,k)**2 &
+ + accel_element(3,i,j,k)**2))
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ endif
+
+ enddo
+ else
+ ! low-resolution: only corner points outputted
+ do ipoin = 1, 4
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
+ ! saves norm of displacement,velocity and acceleration vector
+ if( ispec_is_elastic(ispec) ) then
+ ! norm of displacement
+ store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
+ max(store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
+ sqrt(displ(1,iglob)**2 + displ(2,iglob)**2 + displ(3,iglob)**2))
+ ! norm of velocity
+ store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
+ max(store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
+ sqrt(veloc(1,iglob)**2 + veloc(2,iglob)**2 + veloc(3,iglob)**2))
+ ! norm of acceleration
+ store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
+ max(store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
+ sqrt(accel(1,iglob)**2 + accel(2,iglob)**2 + accel(3,iglob)**2))
+ endif
+
+ ! acoustic domains
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ ! norm of displacement
+ store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
+ max(store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
+ sqrt(displ_element(1,i,j,k)**2 &
+ + displ_element(2,i,j,k)**2 &
+ + displ_element(3,i,j,k)**2))
+ ! norm of velocity
+ store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
+ max(store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
+ sqrt(veloc_element(1,i,j,k)**2 &
+ + veloc_element(2,i,j,k)**2 &
+ + veloc_element(3,i,j,k)**2))
+ ! norm of acceleration
+ store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = &
+ max(store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin), &
+ sqrt(accel_element(1,i,j,k)**2 &
+ + accel_element(2,i,j,k)**2 &
+ + accel_element(3,i,j,k)**2))
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ endif
+ enddo
+ endif
+ enddo
+
+! finalizes shakemap: master process collects all info
+ if (it == NSTEP) then
+ if (USE_HIGHRES_FOR_MOVIES) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ else
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ endif
+
+! creates shakemap file
+ if(myrank == 0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/shakingdata',status='unknown',form='unformatted')
+ write(IOUT) store_val_x_all_external_mesh ! x coordinates
+ write(IOUT) store_val_y_all_external_mesh ! y coordinates
+ write(IOUT) store_val_z_all_external_mesh ! z coordinates
+ write(IOUT) store_val_ux_all_external_mesh ! norm of displacement vector
+ write(IOUT) store_val_uy_all_external_mesh ! norm of velocity vector
+ write(IOUT) store_val_uz_all_external_mesh ! norm of acceleration vector
+ close(IOUT)
+ endif
+ endif
+
+ end subroutine wmo_create_shakemap_em
+
+
+!================================================================
+
+ subroutine wmo_create_movie_surface_em()
+
+! creation of moviedata files
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_movie
+ implicit none
+
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: veloc_element
+ integer :: ispec2D,ispec,ipoin,iglob,i,j,k
+ logical :: is_done
+
+! initializes arrays for point coordinates
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ do ispec2D = 1,nfaces_surface_ext_mesh
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do ipoin = 1, NGLLX*NGLLY
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
+ ! x,y,z coordinates
+ store_val_x_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = xstore(iglob)
+ store_val_y_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = ystore(iglob)
+ store_val_z_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = zstore(iglob)
+ enddo
+ else
+ do ipoin = 1, 4
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
+ ! x,y,z coordinates
+ store_val_x_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = xstore(iglob)
+ store_val_y_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = ystore(iglob)
+ store_val_z_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = zstore(iglob)
+ enddo
+ endif
+ enddo
+ endif
+
+! saves surface velocities
+ do ispec2D = 1,nfaces_surface_ext_mesh
+ ispec = faces_surface_ext_mesh_ispec(ispec2D)
+
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ endif
+
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do ipoin = 1, NGLLX*NGLLY
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
+ ! saves velocity vector
+ if( ispec_is_elastic(ispec) ) then
+ ! velocity x,y,z-components
+ store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc(1,iglob)
+ store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc(2,iglob)
+ store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc(3,iglob)
+ endif
+
+ ! acoustic pressure potential
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ store_val_ux_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc_element(1,i,j,k)
+ store_val_uy_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc_element(2,i,j,k)
+ store_val_uz_external_mesh(NGLLX*NGLLY*(ispec2D-1)+ipoin) = veloc_element(3,i,j,k)
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ endif
+ enddo
+ else
+ do ipoin = 1, 4
+ iglob = faces_surface_ext_mesh(ipoin,ispec2D)
+ ! saves velocity vector
+ if( ispec_is_elastic(ispec) ) then
+ ! velocity x,y,z-components
+ store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc(1,iglob)
+ store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc(2,iglob)
+ store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc(3,iglob)
+ endif
+
+ ! acoustic pressure potential
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ store_val_ux_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc_element(1,i,j,k)
+ store_val_uy_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc_element(2,i,j,k)
+ store_val_uz_external_mesh(NGNOD2D*(ispec2D-1)+ipoin) = veloc_element(3,i,j,k)
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ endif
+ enddo
+ endif
+ enddo
+
+! master process collects all info
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ! collects locations only once
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ endif
+ ! updates/gathers velocity field (high-res)
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ else
+ ! collects locations only once
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ endif
+ ! updates/gathers velocity field (low-res)
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ endif
+
+! file output
+ if(myrank == 0) then
+ write(outputname,"('/moviedata',i6.6)") it
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='unknown',form='unformatted')
+ write(IOUT) store_val_x_all_external_mesh ! x coordinate
+ write(IOUT) store_val_y_all_external_mesh ! y coordinate
+ write(IOUT) store_val_z_all_external_mesh ! z coordinate
+ write(IOUT) store_val_ux_all_external_mesh ! velocity x-component
+ write(IOUT) store_val_uy_all_external_mesh ! velocity y-component
+ write(IOUT) store_val_uz_all_external_mesh ! velocity z-component
+ close(IOUT)
+ endif
+
+ end subroutine wmo_create_movie_surface_em
+
+
+!=====================================================================
+
+ subroutine wmo_movie_surface_output_o()
+
+! outputs moviedata files
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_movie
+ implicit none
+
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: val_element
+ integer :: ispec,ipoin,iglob,i,j,k
+ integer :: imin,imax,jmin,jmax,kmin,kmax,iface,igll,iloc
+ logical :: is_done
+
+ ! initializes arrays for point coordinates
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ ipoin = 0
+ do iface=1,num_free_surface_faces
+ ispec = free_surface_ispec(iface)
+ ! high_resolution
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do igll = 1, NGLLSQUARE
+ ipoin = ipoin + 1
+ i = free_surface_ijk(1,igll,iface)
+ j = free_surface_ijk(2,igll,iface)
+ k = free_surface_ijk(3,igll,iface)
+ iglob = ibool(i,j,k,ispec)
+ ! coordinates
+ store_val_x_external_mesh(ipoin) = xstore(iglob)
+ store_val_y_external_mesh(ipoin) = ystore(iglob)
+ store_val_z_external_mesh(ipoin) = zstore(iglob)
+ enddo
+ else
+ imin = minval( free_surface_ijk(1,:,iface) )
+ imax = maxval( free_surface_ijk(1,:,iface) )
+ jmin = minval( free_surface_ijk(2,:,iface) )
+ jmax = maxval( free_surface_ijk(2,:,iface) )
+ kmin = minval( free_surface_ijk(3,:,iface) )
+ kmax = maxval( free_surface_ijk(3,:,iface) )
+ do iloc = 1, NGNOD2D
+ ipoin = ipoin + 1
+ ! corner points
+ if( imin == imax ) then
+ iglob = ibool(imin,iorderi(iloc),iorderj(iloc),ispec)
+ else if( jmin == jmax ) then
+ iglob = ibool(iorderi(iloc),jmin,iorderj(iloc),ispec)
+ else
+ iglob = ibool(iorderi(iloc),iorderj(iloc),kmin,ispec)
+ endif
+ ! coordinates
+ store_val_x_external_mesh(ipoin) = xstore(iglob)
+ store_val_y_external_mesh(ipoin) = ystore(iglob)
+ store_val_z_external_mesh(ipoin) = zstore(iglob)
+ enddo
+ endif
+ enddo
+ endif
+
+
+ ! outputs values at free surface
+ ipoin = 0
+ do iface=1,num_free_surface_faces
+ ispec = free_surface_ispec(iface)
+
+ if( ispec_is_acoustic(ispec) ) then
+ if(SAVE_DISPLACEMENT) then
+ ! displacement vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_acoustic, val_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ else
+ ! velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, val_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ endif
+ endif
+
+
+ ! high_resolution
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do igll = 1, NGLLSQUARE
+ ipoin = ipoin + 1
+ i = free_surface_ijk(1,igll,iface)
+ j = free_surface_ijk(2,igll,iface)
+ k = free_surface_ijk(3,igll,iface)
+ iglob = ibool(i,j,k,ispec)
+ ! elastic displacement/velocity
+ if( ispec_is_elastic(ispec) ) then
+ if(SAVE_DISPLACEMENT) then
+ store_val_ux_external_mesh(ipoin) = displ(1,iglob)
+ store_val_uy_external_mesh(ipoin) = displ(2,iglob)
+ store_val_uz_external_mesh(ipoin) = displ(3,iglob)
+ else
+ store_val_ux_external_mesh(ipoin) = veloc(1,iglob)
+ store_val_uy_external_mesh(ipoin) = veloc(2,iglob)
+ store_val_uz_external_mesh(ipoin) = veloc(3,iglob)
+ endif
+ endif
+
+ ! acoustic pressure potential
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ store_val_ux_external_mesh(ipoin) = val_element(1,i,j,k)
+ store_val_uy_external_mesh(ipoin) = val_element(2,i,j,k)
+ store_val_uz_external_mesh(ipoin) = val_element(3,i,j,k)
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ endif
+
+ enddo
+ else
+ imin = minval( free_surface_ijk(1,:,iface) )
+ imax = maxval( free_surface_ijk(1,:,iface) )
+ jmin = minval( free_surface_ijk(2,:,iface) )
+ jmax = maxval( free_surface_ijk(2,:,iface) )
+ kmin = minval( free_surface_ijk(3,:,iface) )
+ kmax = maxval( free_surface_ijk(3,:,iface) )
+ do iloc = 1, NGNOD2D
+ ipoin = ipoin + 1
+ ! corner points
+ if( imin == imax ) then
+ iglob = ibool(imin,iorderi(iloc),iorderj(iloc),ispec)
+ else if( jmin == jmax ) then
+ iglob = ibool(iorderi(iloc),jmin,iorderj(iloc),ispec)
+ else
+ iglob = ibool(iorderi(iloc),iorderj(iloc),kmin,ispec)
+ endif
+
+ ! elastic displacement/velocity
+ if( ispec_is_elastic(ispec) ) then
+ if(SAVE_DISPLACEMENT) then
+ store_val_ux_external_mesh(ipoin) = displ(1,iglob)
+ store_val_uy_external_mesh(ipoin) = displ(2,iglob)
+ store_val_uz_external_mesh(ipoin) = displ(3,iglob)
+ else
+ store_val_ux_external_mesh(ipoin) = veloc(1,iglob)
+ store_val_uy_external_mesh(ipoin) = veloc(2,iglob)
+ store_val_uz_external_mesh(ipoin) = veloc(3,iglob)
+ endif
+ endif
+
+ ! acoustic pressure potential
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ store_val_ux_external_mesh(ipoin) = val_element(1,i,j,k)
+ store_val_uy_external_mesh(ipoin) = val_element(2,i,j,k)
+ store_val_uz_external_mesh(ipoin) = val_element(3,i,j,k)
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ endif
+
+ enddo ! iloc
+ endif
+ enddo ! iface
+
+! master process collects all info
+ if (USE_HIGHRES_FOR_MOVIES) then
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ endif
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ else
+ if (it == NTSTEP_BETWEEN_FRAMES ) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ endif
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ endif
+
+! file output: note that values are only stored on free surface
+ if(myrank == 0) then
+ write(outputname,"('/moviedata',i6.6)") it
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//outputname,status='unknown',form='unformatted')
+ write(IOUT) store_val_x_all_external_mesh ! x coordinate
+ write(IOUT) store_val_y_all_external_mesh ! y coordinate
+ write(IOUT) store_val_z_all_external_mesh ! z coordinate
+ write(IOUT) store_val_ux_all_external_mesh ! velocity x-component
+ write(IOUT) store_val_uy_all_external_mesh ! velocity y-component
+ write(IOUT) store_val_uz_all_external_mesh ! velocity z-component
+ close(IOUT)
+ endif
+
+ end subroutine wmo_movie_surface_output_o
+
+
+!=====================================================================
+
+ subroutine wmo_create_shakemap_o()
+
+! outputs shakemap file
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_movie
+
+ implicit none
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: &
+ displ_element,veloc_element,accel_element
+ integer :: ipoin,ispec,iglob
+ integer :: imin,imax,jmin,jmax,kmin,kmax,iface,igll,iloc
+ integer :: i,j,k
+ logical :: is_done
+
+ ! outputs values on free surface
+ ipoin = 0
+ do iface=1,num_free_surface_faces
+ ispec = free_surface_ispec(iface)
+
+ if( ispec_is_acoustic(ispec) ) then
+ ! displacement vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_acoustic, displ_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! accel ?
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_dot_acoustic, accel_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ endif
+
+
+ ! save all points for high resolution, or only four corners for low resolution
+ if(USE_HIGHRES_FOR_MOVIES) then
+ do igll = 1, NGLLSQUARE
+ ipoin = ipoin + 1
+ i = free_surface_ijk(1,igll,iface)
+ j = free_surface_ijk(2,igll,iface)
+ k = free_surface_ijk(3,igll,iface)
+ iglob = ibool(i,j,k,ispec)
+ store_val_x_external_mesh(ipoin) = xstore(iglob)
+ store_val_y_external_mesh(ipoin) = ystore(iglob)
+ store_val_z_external_mesh(ipoin) = zstore(iglob)
+ ! todo: are we only interested in the absolute maximum of horizontal (E,N) components?
+ if( ispec_is_elastic( ispec) ) then
+ ! horizontal displacement
+ store_val_ux_external_mesh(ipoin) = max(store_val_ux_external_mesh(ipoin),&
+ abs(displ(1,iglob)),abs(displ(2,iglob)))
+ ! horizontal velocity
+ store_val_uy_external_mesh(ipoin) = max(store_val_uy_external_mesh(ipoin),&
+ abs(veloc(1,iglob)),abs(veloc(2,iglob)))
+ ! horizontal acceleration
+ store_val_uz_external_mesh(ipoin) = max(store_val_uz_external_mesh(ipoin),&
+ abs(accel(1,iglob)),abs(accel(2,iglob)))
+ endif
+
+ ! acoustic domains
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ ! horizontal displacement
+ store_val_ux_external_mesh(ipoin) = max(store_val_ux_external_mesh(ipoin),&
+ abs(displ_element(1,i,j,k)),abs(displ_element(2,i,j,k)))
+ ! horizontal velocity
+ store_val_uy_external_mesh(ipoin) = max(store_val_uy_external_mesh(ipoin),&
+ abs(veloc_element(1,i,j,k)),abs(veloc_element(2,i,j,k)))
+ ! horizontal acceleration
+ store_val_uz_external_mesh(ipoin) = max(store_val_uz_external_mesh(ipoin),&
+ abs(accel_element(1,i,j,k)),abs(accel_element(2,i,j,k)))
+
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ endif
+
+ enddo
+ else
+ imin = minval( free_surface_ijk(1,:,iface) )
+ imax = maxval( free_surface_ijk(1,:,iface) )
+ jmin = minval( free_surface_ijk(2,:,iface) )
+ jmax = maxval( free_surface_ijk(2,:,iface) )
+ kmin = minval( free_surface_ijk(3,:,iface) )
+ kmax = maxval( free_surface_ijk(3,:,iface) )
+ do iloc = 1, NGNOD2D
+ ipoin = ipoin + 1
+ ! corner points
+ if( imin == imax ) then
+ iglob = ibool(imin,iorderi(iloc),iorderj(iloc),ispec)
+ else if( jmin == jmax ) then
+ iglob = ibool(iorderi(iloc),jmin,iorderj(iloc),ispec)
+ else
+ iglob = ibool(iorderi(iloc),iorderj(iloc),kmin,ispec)
+ endif
+ ! coordinates
+ store_val_x_external_mesh(ipoin) = xstore(iglob)
+ store_val_y_external_mesh(ipoin) = ystore(iglob)
+ store_val_z_external_mesh(ipoin) = zstore(iglob)
+ ! todo: are we only interested in the absolute maximum of horizontal (E,N) components?
+ if( ispec_is_elastic( ispec) ) then
+ store_val_ux_external_mesh(ipoin) = max(store_val_ux_external_mesh(ipoin),&
+ abs(displ(1,iglob)),abs(displ(2,iglob)))
+ store_val_uy_external_mesh(ipoin) = max(store_val_uy_external_mesh(ipoin),&
+ abs(veloc(1,iglob)),abs(veloc(2,iglob)))
+ store_val_uz_external_mesh(ipoin) = max(store_val_uz_external_mesh(ipoin),&
+ abs(accel(1,iglob)),abs(accel(2,iglob)))
+ endif
+
+ ! acoustic domains
+ if( ispec_is_acoustic(ispec) ) then
+ ! velocity vector
+ is_done = .false.
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ if( iglob == ibool(i,j,k,ispec) ) then
+ ! horizontal displacement
+ store_val_ux_external_mesh(ipoin) = max(store_val_ux_external_mesh(ipoin),&
+ abs(displ_element(1,i,j,k)),abs(displ_element(2,i,j,k)))
+ ! horizontal velocity
+ store_val_uy_external_mesh(ipoin) = max(store_val_uy_external_mesh(ipoin),&
+ abs(veloc_element(1,i,j,k)),abs(veloc_element(2,i,j,k)))
+ ! horizontal acceleration
+ store_val_uz_external_mesh(ipoin) = max(store_val_uz_external_mesh(ipoin),&
+ abs(accel_element(1,i,j,k)),abs(accel_element(2,i,j,k)))
+
+ is_done = .true.
+ exit
+ endif
+ enddo
+ if( is_done ) exit
+ enddo
+ if( is_done ) exit
+ enddo
+ endif
+
+ enddo
+ endif ! USE_HIGHRES_FOR_MOVIES
+ enddo
+
+ ! saves shakemap only at the end of the simulation
+ if(it == NSTEP) then
+ if (USE_HIGHRES_FOR_MOVIES) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGLLX*NGLLY,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGLLX*NGLLY,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGLLX*NGLLY,NPROC)
+ else
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_x_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_y_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_y_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_z_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_z_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_ux_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_ux_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uy_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_uy_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ call gatherv_all_cr(store_val_uz_external_mesh,nfaces_surface_ext_mesh*NGNOD2D,&
+ store_val_uz_all_external_mesh,nfaces_perproc_surface_ext_mesh*NGNOD2D,faces_surface_offset_ext_mesh,&
+ nfaces_surface_glob_ext_mesh*NGNOD2D,NPROC)
+ endif
+
+ ! creates shakemap file: note that values are only stored on free surface
+ if(myrank == 0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/shakingdata',status='unknown',form='unformatted')
+ write(IOUT) store_val_x_all_external_mesh ! x coordinates
+ write(IOUT) store_val_y_all_external_mesh ! y coordinates
+ write(IOUT) store_val_z_all_external_mesh ! z coordinates
+ write(IOUT) store_val_ux_all_external_mesh ! norm of displacement vector
+ write(IOUT) store_val_uy_all_external_mesh ! norm of velocity vector
+ write(IOUT) store_val_uz_all_external_mesh ! norm of acceleration vector
+ close(IOUT)
+ endif
+
+ endif ! NTSTEP
+
+ end subroutine wmo_create_shakemap_o
+
+
+!=====================================================================
+
+ subroutine wmo_movie_volume_output()
+
+! outputs movie files for div, curl and velocity
+
+ use specfem_par
+ use specfem_par_elastic
+ use specfem_par_acoustic
+ use specfem_par_movie
+ implicit none
+
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: veloc_element
+ real(kind=CUSTOM_REAL),dimension(NGLOB_AB):: div_glob,curl_glob ! divergence and curl only in the global nodes
+ integer :: ispec,i,j,k,l,iglob
+ integer,dimension(NGLOB_AB) :: valency
+
+ ! saves velocity here to avoid static offset on displacement for movies
+ velocity_x(:,:,:,:) = 0._CUSTOM_REAL
+ velocity_y(:,:,:,:) = 0._CUSTOM_REAL
+ velocity_z(:,:,:,:) = 0._CUSTOM_REAL
+
+ if( ACOUSTIC_SIMULATION ) then
+ ! uses div as temporary array to store velocity on all gll points
+ do ispec=1,NSPEC_AB
+ if( .not. ispec_is_acoustic(ispec) ) cycle
+
+ ! calculates velocity
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ velocity_x(:,:,:,ispec) = veloc_element(1,:,:,:)
+ velocity_y(:,:,:,ispec) = veloc_element(2,:,:,:)
+ velocity_z(:,:,:,ispec) = veloc_element(3,:,:,:)
+ enddo
+ endif ! acoustic
+
+ ! saves full snapshot data to local disk
+ if( ELASTIC_SIMULATION ) then
+ div_glob=0.0_CUSTOM_REAL
+ curl_glob=0.0_CUSTOM_REAL
+
+ do ispec=1,NSPEC_AB
+ if( .not. ispec_is_elastic(ispec) ) cycle
+
+ ! calculates divergence and curl of velocity field
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ tempx1l = 0._CUSTOM_REAL
+ tempx2l = 0._CUSTOM_REAL
+ tempx3l = 0._CUSTOM_REAL
+ tempy1l = 0._CUSTOM_REAL
+ tempy2l = 0._CUSTOM_REAL
+ tempy3l = 0._CUSTOM_REAL
+ tempz1l = 0._CUSTOM_REAL
+ tempz2l = 0._CUSTOM_REAL
+ tempz3l = 0._CUSTOM_REAL
+
+ do l=1,NGLLX
+ hp1 = hprime_xx(i,l)
+ iglob = ibool(l,j,k,ispec)
+ tempx1l = tempx1l + veloc(1,iglob)*hp1
+ tempy1l = tempy1l + veloc(2,iglob)*hp1
+ tempz1l = tempz1l + veloc(3,iglob)*hp1
+ hp2 = hprime_yy(j,l)
+ iglob = ibool(i,l,k,ispec)
+ tempx2l = tempx2l + veloc(1,iglob)*hp2
+ tempy2l = tempy2l + veloc(2,iglob)*hp2
+ tempz2l = tempz2l + veloc(3,iglob)*hp2
+ hp3 = hprime_zz(k,l)
+ iglob = ibool(i,j,l,ispec)
+ tempx3l = tempx3l + veloc(1,iglob)*hp3
+ tempy3l = tempy3l + veloc(2,iglob)*hp3
+ tempz3l = tempz3l + veloc(3,iglob)*hp3
+ enddo
+
+ ! 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)
+
+ dvxdxl(i,j,k) = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
+ dvxdyl(i,j,k) = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
+ dvxdzl(i,j,k) = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
+
+ dvydxl(i,j,k) = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
+ dvydyl(i,j,k) = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
+ dvydzl(i,j,k) = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
+
+ dvzdxl(i,j,k) = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
+ dvzdyl(i,j,k) = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
+ dvzdzl(i,j,k) = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
+
+ enddo
+ enddo
+ enddo
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ! divergence \nabla \cdot \bf{v}
+ div(i,j,k,ispec) = dvxdxl(i,j,k) + dvydyl(i,j,k) + dvzdzl(i,j,k)
+ ! curl
+ curl_x(i,j,k,ispec) = dvzdyl(i,j,k) - dvydzl(i,j,k)
+ curl_y(i,j,k,ispec) = dvxdzl(i,j,k) - dvzdxl(i,j,k)
+ curl_z(i,j,k,ispec) = dvydxl(i,j,k) - dvxdyl(i,j,k)
+ ! velocity field
+ iglob = ibool(i,j,k,ispec)
+ velocity_x(i,j,k,ispec) = veloc(1,iglob)
+ velocity_y(i,j,k,ispec) = veloc(2,iglob)
+ velocity_z(i,j,k,ispec) = veloc(3,iglob)
+
+ valency(iglob)=valency(iglob)+1
+
+ div_glob(iglob) = div_glob(iglob) + div(i,j,k,ispec)
+ curl_glob(iglob)=curl_glob(iglob)+0.5_CUSTOM_REAL*(curl_x(i,j,k,ispec)+curl_x(i,j,k,ispec)+curl_x(i,j,k,ispec))
+ enddo
+ enddo
+ enddo
+ enddo !NSPEC_AB
+
+ do i=1,NGLOB_AB
+ div_glob(i)=div_glob(i)/valency(i)
+ curl_glob(i)=curl_glob(i)/valency(i)
+ enddo
+
+ write(outputname,"('/proc',i6.6,'_div_glob_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) div_glob
+ close(27)
+ write(outputname,"('/proc',i6.6,'_curl_glob_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) curl_glob
+ close(27)
+
+ write(outputname,"('/proc',i6.6,'_div_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) div
+ close(27)
+ write(outputname,"('/proc',i6.6,'_curl_x_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) curl_x
+ close(27)
+ write(outputname,"('/proc',i6.6,'_curl_y_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) curl_y
+ close(27)
+ write(outputname,"('/proc',i6.6,'_curl_z_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) curl_z
+ close(27)
+
+ !write(outputname,"('veloc_proc',i6.6,'_it',i6.6,'.bin')") myrank,it
+ !open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ !write(27) veloc
+ !close(27)
+
+ endif ! elastic
+
+ if( ACOUSTIC_SIMULATION .or. ELASTIC_SIMULATION ) then
+ write(outputname,"('/proc',i6.6,'_velocity_N_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) velocity_x
+ close(27)
+
+ write(outputname,"('/proc',i6.6,'_velocity_E_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) velocity_y
+ close(27)
+
+ write(outputname,"('/proc',i6.6,'_velocity_Z_it',i6.6,'.bin')") myrank,it
+ open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ write(27) velocity_z
+ close(27)
+
+ !write(outputname,"('/proc',i6.6,'_veloc_it',i6.6,'.bin')") myrank,it
+ !open(unit=27,file=trim(LOCAL_PATH)//trim(outputname),status='unknown',form='unformatted')
+ !write(27) velocity_movie
+ !close(27)
+
+ endif
+
+ end subroutine wmo_movie_volume_output
+
Added: seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_seismograms.f90
===================================================================
--- seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_seismograms.f90 (rev 0)
+++ seismo/3D/FAULT_SOURCE/branches/new_fault_db/src/write_seismograms.f90 2011-05-04 21:26:06 UTC (rev 18316)
@@ -0,0 +1,738 @@
+!=====================================================================
+!
+! 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 write_seismograms()
+
+! writes the seismograms with time shift
+
+ use specfem_par
+ use specfem_par_acoustic
+ use specfem_par_elastic
+ use specfem_par_poroelastic
+ implicit none
+ ! local parameters
+ real(kind=CUSTOM_REAL),dimension(NDIM,NGLLX,NGLLY,NGLLZ):: displ_element,veloc_element
+ double precision :: dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd
+ integer :: irec_local,irec
+ integer :: iglob,ispec,i,j,k
+ ! adjoint locals
+ real(kind=CUSTOM_REAL),dimension(NDIM,NDIM):: eps_s
+ real(kind=CUSTOM_REAL),dimension(NDIM):: eps_m_s
+ real(kind=CUSTOM_REAL):: stf_deltat
+ double precision :: stf
+
+ do irec_local = 1,nrec_local
+
+ ! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+
+ ! forward simulations
+ if (SIMULATION_TYPE == 1) then
+
+ ! receiver's spectral element
+ ispec = ispec_selected_rec(irec)
+
+ ! elastic wave field
+ if( ispec_is_elastic(ispec) ) then
+ ! interpolates displ/veloc/accel at receiver locations
+ call compute_interpolated_dva(displ,veloc,accel,NGLOB_AB, &
+ ispec,NSPEC_AB,ibool, &
+ xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec), &
+ hxir_store(irec_local,:),hetar_store(irec_local,:), &
+ hgammar_store(irec_local,:), &
+ dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd)
+ endif !elastic
+
+ ! acoustic wave field
+ if( ispec_is_acoustic(ispec) ) then
+ ! displacement vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_acoustic, displ_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+
+ ! interpolates displ/veloc/pressure at receiver locations
+ call compute_interpolated_dva_ac(displ_element,veloc_element,&
+ potential_dot_dot_acoustic,NGLOB_AB, &
+ ispec,NSPEC_AB,ibool, &
+ xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec), &
+ hxir_store(irec_local,:),hetar_store(irec_local,:), &
+ hgammar_store(irec_local,:), &
+ dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd)
+ endif ! acoustic
+
+ !adjoint simulations
+ else if (SIMULATION_TYPE == 2) then
+
+ ! adjoint source is placed at receiver
+ ispec = ispec_selected_source(irec)
+
+ ! elastic wave field
+ if( ispec_is_elastic(ispec) ) then
+ ! interpolates displ/veloc/accel at receiver locations
+ call compute_interpolated_dva(displ,veloc,accel,NGLOB_AB, &
+ ispec,NSPEC_AB,ibool, &
+ xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec), &
+ hxir_store(irec_local,:),hetar_store(irec_local,:), &
+ hgammar_store(irec_local,:), &
+ dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd)
+
+ ! stores elements displacement field
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ iglob = ibool(i,j,k,ispec)
+ displ_element(:,i,j,k) = displ(:,iglob)
+ enddo
+ enddo
+ enddo
+
+ ! computes the integrated derivatives of source parameters (M_jk and X_s)
+ call compute_adj_source_frechet(displ_element,Mxx(irec),Myy(irec),Mzz(irec),&
+ Mxy(irec),Mxz(irec),Myz(irec),eps_s,eps_m_s, &
+ hxir_store(irec_local,:),hetar_store(irec_local,:),hgammar_store(irec_local,:), &
+ hpxir_store(irec_local,:),hpetar_store(irec_local,:),hpgammar_store(irec_local,:), &
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix(:,:,:,ispec),xiy(:,:,:,ispec),xiz(:,:,:,ispec), &
+ etax(:,:,:,ispec),etay(:,:,:,ispec),etaz(:,:,:,ispec), &
+ gammax(:,:,:,ispec),gammay(:,:,:,ispec),gammaz(:,:,:,ispec))
+
+ stf = comp_source_time_function(dble(NSTEP-it)*DT-t0-t_cmt(irec),hdur_gaussian(irec))
+ stf_deltat = stf * deltat
+ Mxx_der(irec_local) = Mxx_der(irec_local) + eps_s(1,1) * stf_deltat
+ Myy_der(irec_local) = Myy_der(irec_local) + eps_s(2,2) * stf_deltat
+ Mzz_der(irec_local) = Mzz_der(irec_local) + eps_s(3,3) * stf_deltat
+ Mxy_der(irec_local) = Mxy_der(irec_local) + 2 * eps_s(1,2) * stf_deltat
+ Mxz_der(irec_local) = Mxz_der(irec_local) + 2 * eps_s(1,3) * stf_deltat
+ Myz_der(irec_local) = Myz_der(irec_local) + 2 * eps_s(2,3) * stf_deltat
+
+ sloc_der(:,irec_local) = sloc_der(:,irec_local) + eps_m_s(:) * stf_deltat
+ endif ! elastic
+
+ ! acoustic wave field
+ if( ispec_is_acoustic(ispec) ) then
+ ! displacement vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_acoustic, displ_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_AB, &
+ potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+
+ ! interpolates displ/veloc/pressure at receiver locations
+ call compute_interpolated_dva_ac(displ_element,veloc_element,&
+ potential_dot_dot_acoustic,NGLOB_AB, &
+ ispec,NSPEC_AB,ibool, &
+ xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec), &
+ hxir_store(irec_local,:),hetar_store(irec_local,:), &
+ hgammar_store(irec_local,:), &
+ dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd)
+ endif ! acoustic
+
+ !adjoint simulations
+ else if (SIMULATION_TYPE == 3) then
+
+ ispec = ispec_selected_rec(irec)
+
+ ! elastic wave field
+ if( ispec_is_elastic(ispec) ) then
+ ! backward fields: interpolates displ/veloc/accel at receiver locations
+ call compute_interpolated_dva(b_displ,b_veloc,b_accel,NGLOB_ADJOINT,&
+ ispec,NSPEC_AB,ibool, &
+ xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec), &
+ hxir_store(irec_local,:),hetar_store(irec_local,:), &
+ hgammar_store(irec_local,:), &
+ dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd)
+ endif ! elastic
+
+ ! acoustic wave field
+ if( ispec_is_acoustic(ispec) ) then
+ ! backward fields: displacement vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_ADJOINT, &
+ b_potential_acoustic, displ_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+ ! backward fields: velocity vector
+ call compute_gradient(ispec,NSPEC_AB,NGLOB_ADJOINT, &
+ b_potential_dot_acoustic, veloc_element,&
+ hprime_xx,hprime_yy,hprime_zz, &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ ibool,rhostore)
+
+ ! backward fields: interpolates displ/veloc/pressure at receiver locations
+ call compute_interpolated_dva_ac(displ_element,veloc_element,&
+ b_potential_dot_dot_acoustic,NGLOB_ADJOINT, &
+ ispec,NSPEC_AB,ibool, &
+ xi_receiver(irec),eta_receiver(irec),gamma_receiver(irec), &
+ hxir_store(irec_local,:),hetar_store(irec_local,:), &
+ hgammar_store(irec_local,:), &
+ dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd)
+ endif ! acoustic
+
+ endif ! SIMULATION_TYPE
+
+! store North, East and Vertical components
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ seismograms_d(:,irec_local,it) = sngl((nu(:,1,irec)*dxd + nu(:,2,irec)*dyd + nu(:,3,irec)*dzd))
+ seismograms_v(:,irec_local,it) = sngl((nu(:,1,irec)*vxd + nu(:,2,irec)*vyd + nu(:,3,irec)*vzd))
+ seismograms_a(:,irec_local,it) = sngl((nu(:,1,irec)*axd + nu(:,2,irec)*ayd + nu(:,3,irec)*azd))
+ else
+ seismograms_d(:,irec_local,it) = (nu(:,1,irec)*dxd + nu(:,2,irec)*dyd + nu(:,3,irec)*dzd)
+ seismograms_v(:,irec_local,it) = (nu(:,1,irec)*vxd + nu(:,2,irec)*vyd + nu(:,3,irec)*vzd)
+ seismograms_a(:,irec_local,it) = (nu(:,1,irec)*axd + nu(:,2,irec)*ayd + nu(:,3,irec)*azd)
+ endif
+
+ !adjoint simulations
+ if (SIMULATION_TYPE == 2) seismograms_eps(:,:,irec_local,it) = eps_s(:,:)
+
+ enddo ! nrec_local
+
+! write the current or final seismograms
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_SEISMOS) == 0 .or. it == NSTEP) then
+ if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) then
+ call write_seismograms_to_file(myrank,seismograms_d,number_receiver_global,station_name, &
+ network_name,nrec,nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,1,SIMULATION_TYPE)
+ call write_seismograms_to_file(myrank,seismograms_v,number_receiver_global,station_name, &
+ network_name,nrec,nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,2,SIMULATION_TYPE)
+ call write_seismograms_to_file(myrank,seismograms_a,number_receiver_global,station_name, &
+ network_name,nrec,nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,3,SIMULATION_TYPE)
+ else
+ call write_adj_seismograms_to_file(myrank,seismograms_d,number_receiver_global, &
+ nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,1)
+ endif
+ endif
+
+ end subroutine write_seismograms
+
+
+!================================================================
+
+
+! write seismograms to text files
+
+ subroutine write_seismograms_to_file(myrank,seismograms,number_receiver_global, &
+ station_name,network_name,nrec,nrec_local, &
+ it,DT,NSTEP,t0,LOCAL_PATH,istore,SIMULATION_TYPE)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: nrec,nrec_local,NSTEP,it,myrank,istore
+ integer :: SIMULATION_TYPE
+ integer, dimension(nrec_local) :: number_receiver_global
+ real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local,NSTEP) :: seismograms
+ double precision t0,DT
+ character(len=256) LOCAL_PATH
+
+ character(len=MAX_LENGTH_STATION_NAME), dimension(nrec) :: station_name
+ character(len=MAX_LENGTH_NETWORK_NAME), dimension(nrec) :: network_name
+
+ integer irec,irec_local,length_station_name,length_network_name
+ integer iorientation,irecord,isample
+
+ character(len=4) chn
+ character(len=1) component
+ character(len=256) sisname,clean_LOCAL_PATH,final_LOCAL_PATH
+
+! parameters for master collects seismograms
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: one_seismogram
+ real(kind=CUSTOM_REAL) :: time_t
+ integer :: nrec_local_received,NPROCTOT,total_seismos,receiver,sender
+ integer :: iproc,ier
+
+! save displacement, velocity or acceleration
+ if(istore == 1) then
+ component = 'd'
+ else if(istore == 2) then
+ component = 'v'
+ else if(istore == 3) then
+ component = 'a'
+ else
+ call exit_MPI(myrank,'wrong component to save for seismograms')
+ endif
+
+! 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)
+
+ ! save three components of displacement vector
+ irecord = 1
+
+ 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
+
+ ! forward simulation
+ if( SIMULATION_TYPE == 1 ) then
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time_t = sngl( dble(isample-1)*DT - t0 )
+ else
+ time_t = dble(isample-1)*DT - t0
+ endif
+ endif
+
+ ! adjoint simulation: backward/reconstructed wavefields
+ if( SIMULATION_TYPE == 3 ) then
+ ! distinguish between single and double precision for reals
+ ! note: compare time_t with time used for source term
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time_t = sngl( dble(NSTEP-isample-1)*DT - t0 )
+ else
+ time_t = dble(NSTEP-isample-1)*DT - t0
+ endif
+ endif
+
+ write(IOUT,*) time_t,' ',seismograms(iorientation,irec_local,isample)
+
+ else
+ 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
+ nrec_local_received = nrec_local
+ endif
+
+ 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
+
+ total_seismos = total_seismos + 1
+
+ ! save three components of displacement vector
+ irecord = 1
+
+ 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 - t0),' ',one_seismogram(iorientation,isample)
+ !else
+ ! write(IOUT,*) dble(isample-1)*DT - t0,' ',one_seismogram(iorientation,isample)
+ !endif
+
+ ! forward simulation
+ if( SIMULATION_TYPE == 1 ) then
+ ! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time_t = sngl( dble(isample-1)*DT - t0 )
+ else
+ time_t = dble(isample-1)*DT - t0
+ endif
+ endif
+
+ ! adjoint simulation: backward/reconstructed wavefields
+ if( SIMULATION_TYPE == 3 ) then
+ ! distinguish between single and double precision for reals
+ ! note: compare time_t with time used for source term
+ if(CUSTOM_REAL == SIZE_REAL) then
+ time_t = sngl( dble(NSTEP-isample-1)*DT - t0 )
+ else
+ time_t = dble(NSTEP-isample-1)*DT - t0
+ endif
+ endif
+
+ write(IOUT,*) time_t,' ',one_seismogram(iorientation,isample)
+
+ 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_to_file
+
+!=====================================================================
+
+! write adjoint seismograms (displacement) to text files
+
+ subroutine write_adj_seismograms_to_file(myrank,seismograms,number_receiver_global, &
+ nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,istore)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nrec_local,NSTEP,it,myrank,istore
+ integer, dimension(nrec_local) :: number_receiver_global
+ real(kind=CUSTOM_REAL), dimension(NDIM,nrec_local,NSTEP) :: seismograms
+ double precision t0,DT
+ character(len=256) LOCAL_PATH
+
+
+ integer irec,irec_local
+ integer iorientation,irecord,isample
+
+ character(len=4) chn
+ character(len=1) component
+ character(len=256) sisname,clean_LOCAL_PATH,final_LOCAL_PATH
+
+! save displacement, velocity or acceleration
+ if(istore == 1) then
+ component = 'd'
+ else if(istore == 2) then
+ component = 'v'
+ else if(istore == 3) then
+ component = 'a'
+ else
+ call exit_MPI(myrank,'wrong component to save for seismograms')
+ endif
+
+ do irec_local = 1,nrec_local
+
+ ! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+
+ ! save three components of displacement vector
+ irecord = 1
+
+ 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
+
+ write(sisname,"(a,i5.5,'.',a,'.',a3,'.sem',a1)") 'S',irec_local,&
+ 'NT',chn,component
+
+ ! 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)) // '/'
+
+ ! 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 - t0),' ',seismograms(iorientation,irec_local,isample)
+ else
+ write(IOUT,*) dble(isample-1)*DT - t0,' ',seismograms(iorientation,irec_local,isample)
+ endif
+ else
+ call exit_MPI(myrank,'incorrect record label')
+ endif
+ enddo
+
+ close(IOUT)
+
+ enddo
+
+ enddo
+
+ end subroutine write_adj_seismograms_to_file
+
+!=====================================================================
+
+! write adjoint seismograms (strain) to text files
+
+ subroutine write_adj_seismograms2_to_file(myrank,seismograms,number_receiver_global, &
+ nrec_local,it,DT,NSTEP,t0,LOCAL_PATH)
+
+ implicit none
+
+ include "constants.h"
+
+ integer nrec_local,NSTEP,it,myrank
+ integer, dimension(nrec_local) :: number_receiver_global
+ real(kind=CUSTOM_REAL), dimension(NDIM,NDIM,nrec_local,NSTEP) :: seismograms
+ double precision t0,DT
+ character(len=256) LOCAL_PATH
+
+
+ integer irec,irec_local
+ integer idim,jdim,irecord,isample
+
+ character(len=4) chn
+ character(len=1) component
+ character(len=256) sisname,clean_LOCAL_PATH,final_LOCAL_PATH
+
+ do irec_local = 1,nrec_local
+
+ ! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+
+ ! save three components of displacement vector
+ irecord = 1
+
+ do idim = 1, 3
+ do jdim = idim, 3
+
+ if(idim == 1 .and. jdim == 1) then
+ chn = 'SNN'
+ else if(idim == 1 .and. jdim == 2) then
+ chn = 'SEN'
+ else if(idim == 1 .and. jdim == 3) then
+ chn = 'SEZ'
+ else if(idim == 2 .and. jdim == 2) then
+ chn = 'SEE'
+ else if(idim == 2 .and. jdim == 3) then
+ chn = 'SNZ'
+ else if(idim == 3 .and. jdim == 3) then
+ chn = 'SZZ'
+ 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
+ write(sisname,"(a,i5.5,'.',a,'.',a3,'.sem',a1)") 'S',irec_local,&
+ 'NT',chn,component
+
+ ! 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)) // '/'
+
+ ! 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 - t0),' ',seismograms(jdim,idim,irec_local,isample)
+ else
+ write(IOUT,*) dble(isample-1)*DT - t0,' ',seismograms(jdim,idim,irec_local,isample)
+ endif
+ else
+ call exit_MPI(myrank,'incorrect record label')
+ endif
+ enddo
+
+ close(IOUT)
+
+ enddo ! jdim
+ enddo ! idim
+ enddo ! irec_local
+
+end subroutine write_adj_seismograms2_to_file
More information about the CIG-COMMITS
mailing list