[cig-commits] r15636 - seismo/3D/SPECFEM3D_SESAME/trunk
danielpeter at geodynamics.org
danielpeter at geodynamics.org
Sat Aug 29 17:21:21 PDT 2009
Author: danielpeter
Date: 2009-08-29 17:21:20 -0700 (Sat, 29 Aug 2009)
New Revision: 15636
Added:
seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90
seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90
seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90
seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90
seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90
seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90
seismo/3D/SPECFEM3D_SESAME/trunk/read_topography_bathymetry.f90
seismo/3D/SPECFEM3D_SESAME/trunk/setup_GLL_points.f90
seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90
seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90
seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90
Modified:
seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in
seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90
seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D.f90
Log:
adding subroutines for structuring specfem3D.f90
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in 2009-08-29 16:59:10 UTC (rev 15635)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/Makefile.in 2009-08-30 00:21:20 UTC (rev 15636)
@@ -114,13 +114,25 @@
# solver objects with statically allocated arrays; dependent upon
# values_from_mesher.h
+#daniel: added files
SOLVER_ARRAY_OBJECTS = \
$O/assemble_MPI_scalar.o \
$O/assemble_MPI_vector.o \
$O/read_arrays_solver.o \
$O/compute_forces_no_Deville.o \
$O/compute_forces_with_Deville.o \
+ $O/specfem3D_par.o \
$O/specfem3D.o \
+ $O/initialize_simulation.o \
+ $O/read_mesh_databases.o \
+ $O/setup_GLL_points.o \
+ $O/detect_mesh_surfaces.o \
+ $O/setup_movie_meshes.o \
+ $O/read_topography_bathymetry.o \
+ $O/setup_sources_receivers.o \
+ $O/prepare_timerun.o \
+ $O/iterate_time.o \
+ $O/finalize_simulation.o \
$(EMPTY_MACRO)
# objects toggled between the parallel and serial version
@@ -203,8 +215,9 @@
xcombine_surf_data: $O/combine_surf_data.o $O/write_c_binary.o
${FCCOMPILE_CHECK} -o xcombine_surf_data $O/combine_surf_data.o $O/write_c_binary.o
+
clean:
- rm -f $O/* *.o *.gnu OUTPUT_FILES/timestamp* OUTPUT_FILES/starttime*txt work.pc* xgenerate_databases xspecfem3D xcombine_AVS_DX xcheck_buffers_2D xconvolve_source_timefunction xcreate_header_file xcreate_movie_shakemap_AVS_DX_GMT xcombine_vol_data xcombine_surf_data
+ rm -f $O/* *.o *.gnu *.mod OUTPUT_FILES/timestamp* OUTPUT_FILES/starttime*txt work.pc* xgenerate_databases xspecfem3D xcombine_AVS_DX xcheck_buffers_2D xconvolve_source_timefunction xcreate_header_file xcreate_movie_shakemap_AVS_DX_GMT xcombine_vol_data xcombine_surf_data
###
### rule for the archive library
@@ -226,6 +239,39 @@
$O/specfem3D.o: constants.h OUTPUT_FILES/values_from_mesher.h specfem3D.f90
${MPIFCCOMPILE_NO_CHECK} -c -o $O/specfem3D.o specfem3D.f90
+$O/specfem3D_par.o: constants.h OUTPUT_FILES/values_from_mesher.h specfem3D_par.f90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/specfem3D_par.o specfem3D_par.f90
+
+$O/initialize_simulation.o: constants.h OUTPUT_FILES/values_from_mesher.h initialize_simulation.f90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/initialize_simulation.o initialize_simulation.f90
+
+$O/read_mesh_databases.o: constants.h OUTPUT_FILES/values_from_mesher.h read_mesh_databases.f90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/read_mesh_databases.o read_mesh_databases.f90
+
+$O/setup_GLL_points.o: constants.h OUTPUT_FILES/values_from_mesher.h setup_GLL_points.f90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/setup_GLL_points.o setup_GLL_points.f90
+
+$O/detect_mesh_surfaces.o: constants.h OUTPUT_FILES/values_from_mesher.h detect_mesh_surfaces.f90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/detect_mesh_surfaces.o detect_mesh_surfaces.f90
+
+$O/setup_movie_meshes.o: constants.h OUTPUT_FILES/values_from_mesher.h setup_movie_meshes.f90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/setup_movie_meshes.o setup_movie_meshes.f90
+
+$O/read_topography_bathymetry.o: constants.h OUTPUT_FILES/values_from_mesher.h read_topography_bathymetry.f90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/read_topography_bathymetry.o read_topography_bathymetry.f90
+
+$O/setup_sources_receivers.o: constants.h OUTPUT_FILES/values_from_mesher.h setup_sources_receivers.f90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/setup_sources_receivers.o setup_sources_receivers.f90
+
+$O/prepare_timerun.o: constants.h OUTPUT_FILES/values_from_mesher.h prepare_timerun.f90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/prepare_timerun.o prepare_timerun.f90
+
+$O/iterate_time.o: constants.h OUTPUT_FILES/values_from_mesher.h iterate_time.f90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/iterate_time.o iterate_time.f90
+
+$O/finalize_simulation.o: constants.h OUTPUT_FILES/values_from_mesher.h finalize_simulation.f90
+ ${MPIFCCOMPILE_NO_CHECK} -c -o $O/finalize_simulation.o finalize_simulation.f90
+
$O/assemble_MPI_vector.o: constants.h OUTPUT_FILES/values_from_mesher.h assemble_MPI_vector.f90
${FCCOMPILE_NO_CHECK} -c -o $O/assemble_MPI_vector.o assemble_MPI_vector.f90
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90 2009-08-29 16:59:10 UTC (rev 15635)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/create_regions_mesh.f90 2009-08-30 00:21:20 UTC (rev 15636)
@@ -655,25 +655,25 @@
rmass(:) = 0._CUSTOM_REAL
do ispec=1,nspec
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- weight=wxgll(i)*wygll(j)*wzgll(k)
- iglobnum=ibool(i,j,k,ispec)
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ weight=wxgll(i)*wygll(j)*wzgll(k)
+ iglobnum=ibool(i,j,k,ispec)
- jacobianl=jacobianstore(i,j,k,ispec)
+ jacobianl=jacobianstore(i,j,k,ispec)
! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- rmass(iglobnum) = rmass(iglobnum) + &
- sngl((dble(rhostore(i,j,k,ispec))) * dble(jacobianl) * weight)
- else
- rmass(iglobnum) = rmass(iglobnum) + rhostore(i,j,k,ispec) * jacobianl * weight
- endif
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmass(iglobnum) = rmass(iglobnum) + &
+ sngl((dble(rhostore(i,j,k,ispec))) * dble(jacobianl) * weight)
+ else
+ rmass(iglobnum) = rmass(iglobnum) + rhostore(i,j,k,ispec) * jacobianl * weight
+ endif
+ enddo
enddo
enddo
- enddo
enddo
@@ -724,6 +724,23 @@
nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM)
+
+! 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
+
+
+
! sort ibool comm buffers lexicographically
allocate(nibool_interfaces_ext_mesh_true(ninterface_ext_mesh))
@@ -766,6 +783,8 @@
enddo
+
+
! save the binary files
call create_name_database(prname,myrank,LOCAL_PATH)
open(unit=IOUT,file=prname(1:len_trim(prname))//'external_mesh.bin',status='unknown',action='write',form='unformatted')
Added: seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/detect_mesh_surfaces.f90 2009-08-30 00:21:20 UTC (rev 15636)
@@ -0,0 +1,224 @@
+!=====================================================================
+!
+! 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
+
+! detecting surface points/elements (based on valence check on NGLL points) for external mesh
+ allocate(valence_external_mesh(NGLOB_AB))
+ allocate(ispec_is_surface_external_mesh(NSPEC_AB))
+ allocate(iglob_is_surface_external_mesh(NGLOB_AB))
+
+ if (.not. RECVS_CAN_BE_BURIED_EXT_MESH) then
+ valence_external_mesh(:) = 0
+ ispec_is_surface_external_mesh(:) = .false.
+ iglob_is_surface_external_mesh(:) = .false.
+ do ispec = 1, NSPEC_AB
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ iglob = ibool(i,j,k,ispec)
+ valence_external_mesh(iglob) = valence_external_mesh(iglob) + 1
+ enddo
+ enddo
+ enddo
+ enddo
+
+ allocate(buffer_send_scalar_i_ext_mesh(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
+ allocate(buffer_recv_scalar_i_ext_mesh(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
+
+ call assemble_MPI_scalar_i_ext_mesh(NPROC,NGLOB_AB,valence_external_mesh, &
+ buffer_send_scalar_i_ext_mesh,buffer_recv_scalar_i_ext_mesh, &
+ ninterfaces_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)
+
+ do ispec = 1, NSPEC_AB
+ 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.
+
+ 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
+
+ ! handles movies and shakemaps
+ call setup_movie_meshes()
+
+ endif ! .not. RECVS_CAN_BE_BURIED_EXT_MESH
+
+!!!! 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
+
+
+!!!! 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/SPECFEM3D_SESAME/trunk/finalize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/finalize_simulation.f90 2009-08-30 00:21:20 UTC (rev 15636)
@@ -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.
+!
+!=====================================================================
+!
+! United States and French Government Sponsorship Acknowledged.
+
+ subroutine finalize_simulation()
+
+ use specfem_par
+
+
+! 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')
+ write(27) displ
+ write(27) veloc
+ write(27) accel
+ 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)
+
+ else if (SIMULATION_TYPE == 3) then
+
+ ! rhop, beta, alpha kernels
+! save kernels to binary files
+!! DK DK removed kernels from here because not supported for CUBIT + SCOTCH yet
+
+ endif
+
+ if(ABSORBING_CONDITIONS .and. (SIMULATION_TYPE == 3 .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
+ if (nspec2D_xmin > 0) close(31)
+ if (nspec2D_xmax > 0) close(32)
+ if (nspec2D_ymin > 0) close(33)
+ if (nspec2D_ymax > 0) close(34)
+ if (NSPEC2D_BOTTOM > 0) close(35)
+ endif
+
+ if (nrec_local > 0) then
+ if (.not. (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3)) then
+! call write_adj_seismograms(myrank,seismograms_d,number_receiver_global, &
+! nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,1)
+ call write_adj_seismograms2(myrank,seismograms_eps,number_receiver_global, &
+ nrec_local,it,DT,NSTEP,t0,LOCAL_PATH)
+ 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
\ No newline at end of file
Added: seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/initialize_simulation.f90 2009-08-30 00:21:20 UTC (rev 15636)
@@ -0,0 +1,170 @@
+!=====================================================================
+!
+! 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
+
+! sizeprocs returns number of processes started
+! (should be equal to NPROC)
+! myrank is the rank of each process, between 0 and sizeprocs-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)
+
+! read the parameter file
+ call read_parameter_file( &
+ NPROC,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
+ UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
+ ATTENUATION,USE_OLSEN_ATTENUATION,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
+ OCEANS,ANISOTROPY,ABSORBING_CONDITIONS, &
+ MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
+ NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
+ SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
+
+ if (sizeprocs == 1 .and. (NPROC_XI /= 1 .or. NPROC_ETA /= 1)) then
+ stop 'must have NPROC_XI = NPROC_ETA = 1 for a serial run'
+ endif
+
+! 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 simulation parameters
+ if (SIMULATION_TYPE /= 1 .and. NSOURCES > 1000) call exit_mpi(myrank, 'for adjoint simulations, NSOURCES <= 1000')
+! LQY -- note: kernel simulations with attenuation turned on has been implemented
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! check that optimized routines from Deville et al. (2002) can be used
+ if(NGLLX /= 5 .or. NGLLY /= 5 .or. NGLLZ /= 5) &
+ stop 'optimized routines from Deville et al. (2002) such as mxm_m1_m2_5points can only be used if NGLL = 5'
+
+! info about external mesh simulation
+! nlegoff -- should be put in compute_parameters and read_parameter_file for clarity
+ NPROC = sizeprocs
+! chris: DT_ext_mesh & NSTE_ext_mesh were in constants.h, I suppressed it, now it is Par_file & read in
+! read_parameters_file.f90
+! DT = DT_ext_mesh
+! NSTEP = NSTEP_ext_mesh
+ call create_name_database(prname,myrank,LOCAL_PATH)
+ open(unit=27,file=prname(1:len_trim(prname))//'external_mesh.bin',status='old',action='read',form='unformatted')
+
+ read(27) NSPEC_AB
+ read(27) NGLOB_AB
+ !pll
+ NSPEC_ATTENUATION_AB = NSPEC_AB
+ close(27)
+
+! 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')
+
+ 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 ',sizeprocs,' MPI processes'
+ write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
+ write(IMAIN,*)
+
+ write(IMAIN,*) 'There are ',NPROC_XI,' slices along xi'
+ write(IMAIN,*) 'There are ',NPROC_ETA,' slices along eta'
+ 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
+
+! 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')
+
+
+! 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))
+ allocate(xstore(NGLOB_AB))
+ allocate(ystore(NGLOB_AB))
+ allocate(zstore(NGLOB_AB))
+ allocate(kappastore(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(mustore(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(not_fully_in_bedrock(NSPEC_AB))
+ allocate(flag_sediments(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+ allocate(idoubling(NSPEC_AB))
+ allocate(rmass(NGLOB_AB))
+ allocate(rmass_ocean_load(NGLOB_AB))
+ allocate(updated_dof_ocean_load(NGLOB_AB))
+ allocate(displ(NDIM,NGLOB_AB))
+ allocate(veloc(NDIM,NGLOB_AB))
+ allocate(accel(NDIM,NGLOB_AB))
+ allocate(iflag_attenuation_store(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
+
+
+
+
+ end subroutine
\ No newline at end of file
Added: seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/iterate_time.f90 2009-08-30 00:21:20 UTC (rev 15636)
@@ -0,0 +1,1046 @@
+!=====================================================================
+!
+! 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
+
+!
+! 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
+
+
+!check stability
+ do i=1,3
+ Usolidnorm = maxval(abs(displ(i,:)))
+ Usolidnorm_index = maxloc(abs(displ(i,:)))
+ if(Usolidnorm > 1.e+15 ) then
+ print*,' stability issue:',myrank
+ print*,' norm: ',Usolidnorm,displ(i,Usolidnorm_index(1)),i
+ print*,' index: ',Usolidnorm_index(1)
+ print*,' x/y/z: ',xstore(Usolidnorm_index(1)),ystore(Usolidnorm_index(1)),zstore(Usolidnorm_index(1))
+ print*,' time step: ',it
+ call exit_MPI(myrank,'forward simulation became unstable and blew up')
+ endif
+ enddo
+! compute 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
+ if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then
+
+! compute maximum of norm of displacement in each slice
+ Usolidnorm = maxval(sqrt(displ(1,:)**2 + displ(2,:)**2 + displ(3,:)**2))
+
+! compute the maximum of the maxima for all the slices using an MPI reduction
+ call max_all_cr(Usolidnorm,Usolidnorm_all)
+
+!! DK DK array not created yet for CUBIT
+! if (SIMULATION_TYPE == 3) then
+! b_Usolidnorm = maxval(sqrt(b_displ(1,:)**2 + b_displ(2,:)**2 + b_displ(3,:)**2))
+! call max_all_cr(b_Usolidnorm,b_Usolidnorm_all)
+! endif
+
+ 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)
+ write(IMAIN,*) 'Max norm displacement vector U in all slices (m) = ',Usolidnorm_all
+! if (SIMULATION_TYPE == 3) write(IMAIN,*) &
+! 'Max norm displacement vector U (backward) in all slices (m) = ',b_Usolidnorm_all
+ 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
+! if (SIMULATION_TYPE == 3) write(IOUT,*) &
+! 'Max norm displacement vector U (backward) in all slices (m) = ',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')
+! 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
+ endif
+
+
+
+
+
+! update displacement using finite difference time scheme
+ displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsqover2*accel(:,:)
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+ accel(:,:) = 0._CUSTOM_REAL
+
+!! DK DK array not created yet for CUBIT
+! if (SIMULATION_TYPE == 3) 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
+
+! if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
+! ispec2D_moho_top = 0
+! ispec2D_moho_bot = 0
+! endif
+
+! assemble all the contributions between slices using MPI
+
+
+ if(USE_DEVILLE_PRODUCTS) then
+ call compute_forces_with_Deville(NSPEC_AB,NGLOB_AB,ATTENUATION,displ,accel,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh,.false., &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,xi_source,eta_source,gamma_source,nu_source, &
+ hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
+ one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz,iflag_attenuation_store,ABSORBING_CONDITIONS, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom, &
+ nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
+ veloc,rho_vp,rho_vs,jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom, &
+ normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom)
+ else
+ call compute_forces_no_Deville(NSPEC_AB,NGLOB_AB,displ,accel,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh,.false., &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,xi_source,eta_source,gamma_source,nu_source,hdur,dt)
+ endif
+
+ call assemble_MPI_vector_ext_mesh_s(NPROC,NGLOB_AB,accel, &
+ buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh, &
+ ninterfaces_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)
+
+ if(USE_DEVILLE_PRODUCTS) then
+ call compute_forces_with_Deville(NSPEC_AB,NGLOB_AB,ATTENUATION,displ,accel,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh,.true., &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,xi_source,eta_source,gamma_source,nu_source, &
+ hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
+ one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,R_xx,R_yy,R_xy,R_xz,R_yz, &
+ epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz,iflag_attenuation_store,ABSORBING_CONDITIONS, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom, &
+ nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
+ veloc,rho_vp,rho_vs,jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom, &
+ normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom)
+ else
+ call compute_forces_no_Deville(NSPEC_AB,NGLOB_AB,displ,accel,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
+ hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
+ kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh,.true., &
+ NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,xi_source,eta_source,gamma_source,nu_source,hdur,dt)
+ endif
+
+ call assemble_MPI_vector_ext_mesh_w(NPROC,NGLOB_AB,accel, &
+ buffer_recv_vector_ext_mesh,ninterfaces_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)
+
+!! 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.
+! if (SIMULATION_TYPE == 3) call assemble_MPI_vector(b_accel,iproc_xi,iproc_eta,addressing, &
+! iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta, &
+! buffer_send_faces_vector,buffer_received_faces_vector,npoin2D_xi,npoin2D_eta, &
+! NPROC_XI,NPROC_ETA,NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,NPOIN2DMAX_XY)
+
+! multiply by the inverse of the mass matrix
+ accel(1,:) = accel(1,:)*rmass(:)
+ accel(2,:) = accel(2,:)*rmass(:)
+ accel(3,:) = accel(3,:)*rmass(:)
+
+!! DK DK array not created yet for CUBIT
+! 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
+
+ if(OCEANS) then
+
+ stop 'DK DK oceans have been removed for now because we need a flag to detect the surface elements'
+
+! initialize the updates
+ updated_dof_ocean_load(:) = .false.
+
+! for surface elements exactly at the top of the model (ocean bottom)
+ do ispec2D = 1,NSPEC2D_TOP
+
+!! DK DK array not created yet for CUBIT ispec = ibelm_top(ispec2D)
+
+! only for DOFs exactly at the top of the model (ocean bottom)
+ k = NGLLZ
+
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+! get global point number
+ iglob = ibool(i,j,k,ispec)
+
+! only update once
+ if(.not. updated_dof_ocean_load(iglob)) then
+
+! get normal
+!! DK DK array not created yet for CUBIT nx = normal_top(1,i,j,ispec2D)
+!! DK DK array not created yet for CUBIT ny = normal_top(2,i,j,ispec2D)
+!! DK DK array not created yet for CUBIT nz = normal_top(3,i,j,ispec2D)
+
+! 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
+
+ if (SIMULATION_TYPE == 3) then
+!! DK DK array not created yet for CUBIT
+! 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
+
+!! DK DK array not created yet for CUBIT
+! 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
+
+! done with this point
+ updated_dof_ocean_load(iglob) = .true.
+
+ endif
+
+ enddo
+ enddo
+ enddo
+ endif
+
+ veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
+
+!! DK DK array not created yet for CUBIT
+! if (SIMULATION_TYPE == 3) b_veloc(:,:) = b_veloc(:,:) + b_deltatover2*b_accel(:,:)
+
+! write the seismograms with time shift
+ if (nrec_local > 0) then
+ do irec_local = 1,nrec_local
+
+! get global number of that receiver
+ irec = number_receiver_global(irec_local)
+
+! perform the general interpolation using Lagrange polynomials
+ if(FASTER_RECEIVERS_POINTS_ONLY) then
+
+ iglob = ibool(nint(xi_receiver(irec)),nint(eta_receiver(irec)), &
+ nint(gamma_receiver(irec)),ispec_selected_rec(irec))
+ dxd = dble(displ(1,iglob))
+ dyd = dble(displ(2,iglob))
+ dzd = dble(displ(3,iglob))
+ vxd = dble(veloc(1,iglob))
+ vyd = dble(veloc(2,iglob))
+ vzd = dble(veloc(3,iglob))
+ axd = dble(accel(1,iglob))
+ ayd = dble(accel(2,iglob))
+ azd = dble(accel(3,iglob))
+
+ else
+
+ dxd = ZERO
+ dyd = ZERO
+ dzd = ZERO
+
+ vxd = ZERO
+ vyd = ZERO
+ vzd = ZERO
+
+ axd = ZERO
+ ayd = ZERO
+ azd = ZERO
+
+ if (SIMULATION_TYPE == 1) then
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+! receivers are always located at the surface of the mesh
+ iglob = ibool(i,j,k,ispec_selected_rec(irec))
+
+ hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
+
+
+! save displacement
+ dxd = dxd + dble(displ(1,iglob))*hlagrange
+ dyd = dyd + dble(displ(2,iglob))*hlagrange
+ dzd = dzd + dble(displ(3,iglob))*hlagrange
+
+! save velocity
+ vxd = vxd + dble(veloc(1,iglob))*hlagrange
+ vyd = vyd + dble(veloc(2,iglob))*hlagrange
+ vzd = vzd + dble(veloc(3,iglob))*hlagrange
+
+! save 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
+
+ else if (SIMULATION_TYPE == 2) then
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,k,ispec_selected_source(irec))
+
+ hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
+
+ dxd = dxd + dble(displ(1,iglob))*hlagrange
+ dyd = dyd + dble(displ(2,iglob))*hlagrange
+ dzd = dzd + dble(displ(3,iglob))*hlagrange
+ vxd = vxd + dble(veloc(1,iglob))*hlagrange
+ vyd = vyd + dble(veloc(2,iglob))*hlagrange
+ vzd = vzd + dble(veloc(3,iglob))*hlagrange
+ axd = axd + dble(accel(1,iglob))*hlagrange
+ ayd = ayd + dble(accel(2,iglob))*hlagrange
+ azd = azd + dble(accel(3,iglob))*hlagrange
+
+ displ_s(:,i,j,k) = displ(:,iglob)
+
+ enddo
+ enddo
+ enddo
+
+ ispec = ispec_selected_source(irec)
+
+ call compute_adj_source_frechet(displ_s,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
+
+ else if (SIMULATION_TYPE == 3) then
+
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ iglob = ibool(i,j,k,ispec_selected_rec(irec))
+
+ hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
+
+!! DK DK array not created yet for CUBIT
+! dxd = dxd + dble(b_displ(1,iglob))*hlagrange
+! dyd = dyd + dble(b_displ(2,iglob))*hlagrange
+! dzd = dzd + dble(b_displ(3,iglob))*hlagrange
+! vxd = vxd + dble(b_veloc(1,iglob))*hlagrange
+! vyd = vyd + dble(b_veloc(2,iglob))*hlagrange
+! vzd = vzd + dble(b_veloc(3,iglob))*hlagrange
+! axd = axd + dble(b_accel(1,iglob))*hlagrange
+! ayd = ayd + dble(b_accel(2,iglob))*hlagrange
+! azd = azd + dble(b_accel(3,iglob))*hlagrange
+ enddo
+ enddo
+ enddo
+ endif
+
+ endif ! end of if(FASTER_RECEIVERS_POINTS_ONLY)
+
+! 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
+
+ if (SIMULATION_TYPE == 2) seismograms_eps(:,:,irec_local,it) = eps_s(:,:)
+
+ enddo
+
+! 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(myrank,seismograms_d,number_receiver_global,station_name, &
+ network_name,nrec,nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,1)
+ call write_seismograms(myrank,seismograms_v,number_receiver_global,station_name, &
+ network_name,nrec,nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,2)
+ call write_seismograms(myrank,seismograms_a,number_receiver_global,station_name, &
+ network_name,nrec,nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,3)
+ else
+ call write_adj_seismograms(myrank,seismograms_d,number_receiver_global, &
+ nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,1)
+ endif
+ endif
+
+ endif ! nrec_local
+
+! resetting d/v/a/R/eps for the backward reconstruction with attenuation
+ if (ATTENUATION .and. it > 1 .and. it < NSTEP) then
+ if (SIMULATION_TYPE == 3 .and. mod(NSTEP-it,NSTEP_Q_SAVE) == 0) then
+ 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')
+!! DK DK array not created yet for CUBIT
+! 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
+ close(27)
+ else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. mod(it,NSTEP_Q_SAVE) == 0) then
+ write(outputname,"('save_Q_arrays_',i6.6,'.bin')") it
+ open(unit=27,file=trim(prname_Q)//trim(outputname),status='unknown',action='write',form='unformatted')
+ 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
+ close(27)
+ endif
+ endif
+
+ if (EXTERNAL_MESH_CREATE_SHAKEMAP) then
+ if (it == 1) then
+
+ store_val_ux_external_mesh(:) = -HUGEVAL
+ store_val_uy_external_mesh(:) = -HUGEVAL
+ store_val_uz_external_mesh(:) = -HUGEVAL
+ do ispec = 1,nfaces_surface_external_mesh
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do ipoin = 1, NGLLX*NGLLY
+ store_val_x_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = xstore(faces_surface_external_mesh(ipoin,ispec))
+ store_val_y_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = ystore(faces_surface_external_mesh(ipoin,ispec))
+ store_val_z_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = zstore(faces_surface_external_mesh(ipoin,ispec))
+ enddo
+ else
+ store_val_x_external_mesh(NGNOD2D*(ispec-1)+1) = xstore(faces_surface_external_mesh(1,ispec))
+ store_val_x_external_mesh(NGNOD2D*(ispec-1)+2) = xstore(faces_surface_external_mesh(2,ispec))
+ store_val_x_external_mesh(NGNOD2D*(ispec-1)+3) = xstore(faces_surface_external_mesh(3,ispec))
+ store_val_x_external_mesh(NGNOD2D*(ispec-1)+4) = xstore(faces_surface_external_mesh(4,ispec))
+ store_val_y_external_mesh(NGNOD2D*(ispec-1)+1) = ystore(faces_surface_external_mesh(1,ispec))
+ store_val_y_external_mesh(NGNOD2D*(ispec-1)+2) = ystore(faces_surface_external_mesh(2,ispec))
+ store_val_y_external_mesh(NGNOD2D*(ispec-1)+3) = ystore(faces_surface_external_mesh(3,ispec))
+ store_val_y_external_mesh(NGNOD2D*(ispec-1)+4) = ystore(faces_surface_external_mesh(4,ispec))
+ store_val_z_external_mesh(NGNOD2D*(ispec-1)+1) = zstore(faces_surface_external_mesh(1,ispec))
+ store_val_z_external_mesh(NGNOD2D*(ispec-1)+2) = zstore(faces_surface_external_mesh(2,ispec))
+ store_val_z_external_mesh(NGNOD2D*(ispec-1)+3) = zstore(faces_surface_external_mesh(3,ispec))
+ store_val_z_external_mesh(NGNOD2D*(ispec-1)+4) = zstore(faces_surface_external_mesh(4,ispec))
+ endif
+ enddo
+ endif
+
+ do ispec = 1,nfaces_surface_external_mesh
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do ipoin = 1, NGLLX*NGLLY
+ store_val_ux_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = &
+ max(store_val_ux_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin), &
+ sqrt(displ(1,faces_surface_external_mesh(ipoin,ispec))**2 + &
+ displ(2,faces_surface_external_mesh(ipoin,ispec))**2 + &
+ displ(3,faces_surface_external_mesh(ipoin,ispec))**2))
+ store_val_uy_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = &
+ max(store_val_uy_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin), &
+ sqrt(veloc(1,faces_surface_external_mesh(ipoin,ispec))**2 + &
+ veloc(2,faces_surface_external_mesh(ipoin,ispec))**2 + &
+ veloc(3,faces_surface_external_mesh(ipoin,ispec))**2))
+ store_val_uz_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = &
+ max(store_val_uz_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin), &
+ sqrt(accel(1,faces_surface_external_mesh(ipoin,ispec))**2 + &
+ accel(2,faces_surface_external_mesh(ipoin,ispec))**2 + &
+ accel(3,faces_surface_external_mesh(ipoin,ispec))**2))
+
+ enddo
+ else
+ store_val_ux_external_mesh(NGNOD2D*(ispec-1)+1) = &
+ max(store_val_ux_external_mesh(NGNOD2D*(ispec-1)+1), &
+ sqrt(displ(1,faces_surface_external_mesh(1,ispec))**2 + &
+ displ(2,faces_surface_external_mesh(1,ispec))**2 + &
+ displ(3,faces_surface_external_mesh(1,ispec))**2))
+ store_val_ux_external_mesh(NGNOD2D*(ispec-1)+2) = &
+ max(store_val_ux_external_mesh(NGNOD2D*(ispec-1)+2), &
+ sqrt(displ(1,faces_surface_external_mesh(2,ispec))**2 + &
+ displ(2,faces_surface_external_mesh(2,ispec))**2 + &
+ displ(3,faces_surface_external_mesh(2,ispec))**2))
+ store_val_ux_external_mesh(NGNOD2D*(ispec-1)+3) = &
+ max(store_val_ux_external_mesh(NGNOD2D*(ispec-1)+3), &
+ sqrt(displ(1,faces_surface_external_mesh(3,ispec))**2 + &
+ displ(2,faces_surface_external_mesh(3,ispec))**2 + &
+ displ(3,faces_surface_external_mesh(3,ispec))**2))
+ store_val_ux_external_mesh(NGNOD2D*(ispec-1)+4) = &
+ max(store_val_ux_external_mesh(NGNOD2D*(ispec-1)+4), &
+ sqrt(displ(1,faces_surface_external_mesh(4,ispec))**2 + &
+ displ(2,faces_surface_external_mesh(4,ispec))**2 + &
+ displ(3,faces_surface_external_mesh(4,ispec))**2))
+ store_val_uy_external_mesh(NGNOD2D*(ispec-1)+1) = &
+ max(store_val_uy_external_mesh(NGNOD2D*(ispec-1)+1), &
+ sqrt(veloc(1,faces_surface_external_mesh(1,ispec))**2 + &
+ veloc(2,faces_surface_external_mesh(1,ispec))**2 + &
+ veloc(3,faces_surface_external_mesh(1,ispec))**2))
+ store_val_uy_external_mesh(NGNOD2D*(ispec-1)+2) = &
+ max(store_val_uy_external_mesh(NGNOD2D*(ispec-1)+2), &
+ sqrt(veloc(1,faces_surface_external_mesh(2,ispec))**2 + &
+ veloc(2,faces_surface_external_mesh(2,ispec))**2 + &
+ veloc(3,faces_surface_external_mesh(2,ispec))**2))
+ store_val_uy_external_mesh(NGNOD2D*(ispec-1)+3) = &
+ max(store_val_uy_external_mesh(NGNOD2D*(ispec-1)+3), &
+ sqrt(veloc(1,faces_surface_external_mesh(3,ispec))**2 + &
+ veloc(2,faces_surface_external_mesh(3,ispec))**2 + &
+ veloc(3,faces_surface_external_mesh(3,ispec))**2))
+ store_val_uy_external_mesh(NGNOD2D*(ispec-1)+4) = &
+ max(store_val_uy_external_mesh(NGNOD2D*(ispec-1)+4), &
+ sqrt(veloc(1,faces_surface_external_mesh(4,ispec))**2 + &
+ veloc(2,faces_surface_external_mesh(4,ispec))**2 + &
+ veloc(3,faces_surface_external_mesh(4,ispec))**2))
+ store_val_uz_external_mesh(NGNOD2D*(ispec-1)+1) = &
+ max(store_val_uz_external_mesh(NGNOD2D*(ispec-1)+1), &
+ sqrt(accel(1,faces_surface_external_mesh(1,ispec))**2 + &
+ accel(2,faces_surface_external_mesh(1,ispec))**2 + &
+ accel(3,faces_surface_external_mesh(1,ispec))**2))
+ store_val_uz_external_mesh(NGNOD2D*(ispec-1)+2) = &
+ max(store_val_uz_external_mesh(NGNOD2D*(ispec-1)+2), &
+ sqrt(accel(1,faces_surface_external_mesh(2,ispec))**2 + &
+ accel(2,faces_surface_external_mesh(2,ispec))**2 + &
+ accel(3,faces_surface_external_mesh(2,ispec))**2))
+ store_val_uz_external_mesh(NGNOD2D*(ispec-1)+3) = &
+ max(store_val_uz_external_mesh(NGNOD2D*(ispec-1)+3), &
+ sqrt(accel(1,faces_surface_external_mesh(3,ispec))**2 + &
+ accel(2,faces_surface_external_mesh(3,ispec))**2 + &
+ accel(3,faces_surface_external_mesh(3,ispec))**2))
+ store_val_uz_external_mesh(NGNOD2D*(ispec-1)+4) = &
+ max(store_val_uz_external_mesh(NGNOD2D*(ispec-1)+4), &
+ sqrt(accel(1,faces_surface_external_mesh(4,ispec))**2 + &
+ accel(2,faces_surface_external_mesh(4,ispec))**2 + &
+ accel(3,faces_surface_external_mesh(4,ispec))**2))
+ endif
+ enddo
+
+ if (it == NSTEP) then
+ if (USE_HIGHRES_FOR_MOVIES) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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
+
+ if(myrank == 0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/shakingdata',status='unknown',form='unformatted')
+ write(IOUT) store_val_x_all_external_mesh
+ write(IOUT) store_val_y_all_external_mesh
+ write(IOUT) store_val_z_all_external_mesh
+ write(IOUT) store_val_ux_all_external_mesh
+ write(IOUT) store_val_uy_all_external_mesh
+ write(IOUT) store_val_uz_all_external_mesh
+ close(IOUT)
+ endif
+ endif
+
+ endif
+
+ if(EXTERNAL_MESH_MOVIE_SURFACE .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
+! get coordinates of surface mesh and surface displacement
+ do ispec = 1,nfaces_surface_external_mesh
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do ipoin = 1, NGLLX*NGLLY
+ store_val_x_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = xstore(faces_surface_external_mesh(ipoin,ispec))
+ store_val_y_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = ystore(faces_surface_external_mesh(ipoin,ispec))
+ store_val_z_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = zstore(faces_surface_external_mesh(ipoin,ispec))
+ store_val_ux_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = veloc(1,faces_surface_external_mesh(ipoin,ispec))
+ store_val_uy_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = veloc(2,faces_surface_external_mesh(ipoin,ispec))
+ store_val_uz_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = veloc(3,faces_surface_external_mesh(ipoin,ispec))
+ enddo
+ else
+ store_val_x_external_mesh(NGNOD2D*(ispec-1)+1) = xstore(faces_surface_external_mesh(1,ispec))
+ store_val_x_external_mesh(NGNOD2D*(ispec-1)+2) = xstore(faces_surface_external_mesh(2,ispec))
+ store_val_x_external_mesh(NGNOD2D*(ispec-1)+3) = xstore(faces_surface_external_mesh(3,ispec))
+ store_val_x_external_mesh(NGNOD2D*(ispec-1)+4) = xstore(faces_surface_external_mesh(4,ispec))
+ store_val_y_external_mesh(NGNOD2D*(ispec-1)+1) = ystore(faces_surface_external_mesh(1,ispec))
+ store_val_y_external_mesh(NGNOD2D*(ispec-1)+2) = ystore(faces_surface_external_mesh(2,ispec))
+ store_val_y_external_mesh(NGNOD2D*(ispec-1)+3) = ystore(faces_surface_external_mesh(3,ispec))
+ store_val_y_external_mesh(NGNOD2D*(ispec-1)+4) = ystore(faces_surface_external_mesh(4,ispec))
+ store_val_z_external_mesh(NGNOD2D*(ispec-1)+1) = zstore(faces_surface_external_mesh(1,ispec))
+ store_val_z_external_mesh(NGNOD2D*(ispec-1)+2) = zstore(faces_surface_external_mesh(2,ispec))
+ store_val_z_external_mesh(NGNOD2D*(ispec-1)+3) = zstore(faces_surface_external_mesh(3,ispec))
+ store_val_z_external_mesh(NGNOD2D*(ispec-1)+4) = zstore(faces_surface_external_mesh(4,ispec))
+ store_val_ux_external_mesh(NGNOD2D*(ispec-1)+1) = veloc(1,faces_surface_external_mesh(1,ispec))
+ store_val_ux_external_mesh(NGNOD2D*(ispec-1)+2) = veloc(1,faces_surface_external_mesh(2,ispec))
+ store_val_ux_external_mesh(NGNOD2D*(ispec-1)+3) = veloc(1,faces_surface_external_mesh(3,ispec))
+ store_val_ux_external_mesh(NGNOD2D*(ispec-1)+4) = veloc(1,faces_surface_external_mesh(4,ispec))
+ store_val_uy_external_mesh(NGNOD2D*(ispec-1)+1) = veloc(2,faces_surface_external_mesh(1,ispec))
+ store_val_uy_external_mesh(NGNOD2D*(ispec-1)+2) = veloc(2,faces_surface_external_mesh(2,ispec))
+ store_val_uy_external_mesh(NGNOD2D*(ispec-1)+3) = veloc(2,faces_surface_external_mesh(3,ispec))
+ store_val_uy_external_mesh(NGNOD2D*(ispec-1)+4) = veloc(2,faces_surface_external_mesh(4,ispec))
+ store_val_uz_external_mesh(NGNOD2D*(ispec-1)+1) = veloc(3,faces_surface_external_mesh(1,ispec))
+ store_val_uz_external_mesh(NGNOD2D*(ispec-1)+2) = veloc(3,faces_surface_external_mesh(2,ispec))
+ store_val_uz_external_mesh(NGNOD2D*(ispec-1)+3) = veloc(3,faces_surface_external_mesh(3,ispec))
+ store_val_uz_external_mesh(NGNOD2D*(ispec-1)+4) = veloc(3,faces_surface_external_mesh(4,ispec))
+ endif
+ enddo
+
+ if (USE_HIGHRES_FOR_MOVIES) then
+ call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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
+
+ 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
+ write(IOUT) store_val_y_all_external_mesh
+ write(IOUT) store_val_z_all_external_mesh
+ write(IOUT) store_val_ux_all_external_mesh
+ write(IOUT) store_val_uy_all_external_mesh
+ write(IOUT) store_val_uz_all_external_mesh
+ close(IOUT)
+ endif
+ endif
+
+! save MOVIE on the SURFACE
+ if(MOVIE_SURFACE .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
+
+ stop 'DK DK MOVIE_SURFACE has been removed for now because we need a flag to detect the surface elements'
+
+! get coordinates of surface mesh and surface displacement
+ ipoin = 0
+
+ k = NGLLZ
+ if (USE_HIGHRES_FOR_MOVIES) then
+ do ispec2D = 1,NSPEC2D_TOP
+!! DK DK array not created yet for CUBIT ispec = ibelm_top(ispec2D)
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ipoin = ipoin + 1
+ iglob = ibool(i,j,k,ispec)
+ store_val_x(ipoin) = xstore(iglob)
+ store_val_y(ipoin) = ystore(iglob)
+ store_val_z(ipoin) = zstore(iglob)
+ if(SAVE_DISPLACEMENT) then
+ store_val_ux(ipoin) = displ(1,iglob)
+ store_val_uy(ipoin) = displ(2,iglob)
+ store_val_uz(ipoin) = displ(3,iglob)
+ else
+ store_val_ux(ipoin) = veloc(1,iglob)
+ store_val_uy(ipoin) = veloc(2,iglob)
+ store_val_uz(ipoin) = veloc(3,iglob)
+ endif
+ enddo
+ enddo
+ enddo ! ispec_top
+ else
+ do ispec2D = 1,NSPEC2D_TOP
+!! DK DK array not created yet for CUBIT ispec = ibelm_top(ispec2D)
+ do iloc = 1, NGNOD2D
+ ipoin = ipoin + 1
+ iglob = ibool(iorderi(iloc),iorderj(iloc),k,ispec)
+ store_val_x(ipoin) = xstore(iglob)
+ store_val_y(ipoin) = ystore(iglob)
+ store_val_z(ipoin) = zstore(iglob)
+ if(SAVE_DISPLACEMENT) then
+ store_val_ux(ipoin) = displ(1,iglob)
+ store_val_uy(ipoin) = displ(2,iglob)
+ store_val_uz(ipoin) = displ(3,iglob)
+ else
+ store_val_ux(ipoin) = veloc(1,iglob)
+ store_val_uy(ipoin) = veloc(2,iglob)
+ store_val_uz(ipoin) = veloc(3,iglob)
+ endif
+ enddo
+ enddo ! ispec_top
+ endif
+
+ ispec = nmovie_points
+
+ call gather_all_cr(store_val_x,ispec,store_val_x_all,ispec,NPROC)
+ call gather_all_cr(store_val_y,ispec,store_val_y_all,ispec,NPROC)
+ call gather_all_cr(store_val_z,ispec,store_val_z_all,ispec,NPROC)
+ call gather_all_cr(store_val_ux,ispec,store_val_ux_all,ispec,NPROC)
+ call gather_all_cr(store_val_uy,ispec,store_val_uy_all,ispec,NPROC)
+ call gather_all_cr(store_val_uz,ispec,store_val_uz_all,ispec,NPROC)
+
+! save movie data to disk in home directory
+ 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
+ write(IOUT) store_val_y_all
+ write(IOUT) store_val_z_all
+ write(IOUT) store_val_ux_all
+ write(IOUT) store_val_uy_all
+ write(IOUT) store_val_uz_all
+ close(IOUT)
+ endif
+
+ endif
+
+! compute SHAKING INTENSITY MAP
+ if(CREATE_SHAKEMAP) then
+
+ stop 'DK DK CREATE_SHAKEMAP has been removed for now because we need a flag to detect the surface elements'
+
+ ipoin = 0
+ k = NGLLZ
+
+! save all points for high resolution, or only four corners for low resolution
+ if(USE_HIGHRES_FOR_MOVIES) then
+
+ do ispec2D = 1,NSPEC2D_TOP
+!! DK DK array not created yet for CUBIT ispec = ibelm_top(ispec2D)
+
+! loop on all the points inside the element
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+ ipoin = ipoin + 1
+ iglob = ibool(i,j,k,ispec)
+ store_val_x(ipoin) = xstore(iglob)
+ store_val_y(ipoin) = ystore(iglob)
+ store_val_z(ipoin) = zstore(iglob)
+ store_val_norm_displ(ipoin) = max(store_val_norm_displ(ipoin),abs(displ(1,iglob)),abs(displ(2,iglob)))
+ store_val_norm_veloc(ipoin) = max(store_val_norm_veloc(ipoin),abs(veloc(1,iglob)),abs(veloc(2,iglob)))
+ store_val_norm_accel(ipoin) = max(store_val_norm_accel(ipoin),abs(accel(1,iglob)),abs(accel(2,iglob)))
+ enddo
+ enddo
+ enddo
+
+ else
+ do ispec2D = 1,NSPEC2D_TOP
+!! DK DK array not created yet for CUBIT ispec = ibelm_top(ispec2D)
+ do iloc = 1, NGNOD2D
+ ipoin = ipoin + 1
+ iglob = ibool(iorderi(iloc),iorderj(iloc),k,ispec)
+ store_val_x(ipoin) = xstore(iglob)
+ store_val_y(ipoin) = ystore(iglob)
+ store_val_z(ipoin) = zstore(iglob)
+ store_val_norm_displ(ipoin) = max(store_val_norm_displ(ipoin),abs(displ(1,iglob)),abs(displ(2,iglob)))
+ store_val_norm_veloc(ipoin) = max(store_val_norm_veloc(ipoin),abs(veloc(1,iglob)),abs(veloc(2,iglob)))
+ store_val_norm_accel(ipoin) = max(store_val_norm_accel(ipoin),abs(accel(1,iglob)),abs(accel(2,iglob)))
+ enddo
+ enddo
+ endif
+
+! save shakemap only at the end of the simulation
+ if(it == NSTEP) then
+ ispec = nmovie_points
+ call gather_all_cr(store_val_x,ispec,store_val_x_all,ispec,NPROC)
+ call gather_all_cr(store_val_y,ispec,store_val_y_all,ispec,NPROC)
+ call gather_all_cr(store_val_z,ispec,store_val_z_all,ispec,NPROC)
+ call gather_all_cr(store_val_norm_displ,ispec,store_val_ux_all,ispec,NPROC)
+ call gather_all_cr(store_val_norm_veloc,ispec,store_val_uy_all,ispec,NPROC)
+ call gather_all_cr(store_val_norm_accel,ispec,store_val_uz_all,ispec,NPROC)
+
+! save movie data to disk in home directory
+ if(myrank == 0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/shakingdata',status='unknown',form='unformatted')
+ write(IOUT) store_val_x_all
+ write(IOUT) store_val_y_all
+ write(IOUT) store_val_z_all
+! this saves norm of displacement, velocity and acceleration
+! but we use the same ux, uy, uz arrays as for the movies to save memory
+ write(IOUT) store_val_ux_all
+ write(IOUT) store_val_uy_all
+ write(IOUT) store_val_uz_all
+ close(IOUT)
+ endif
+
+ endif
+ endif
+
+! save MOVIE in full 3D MESH
+ if(MOVIE_VOLUME .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
+
+! save velocity here to avoid static offset on displacement for movies
+
+! save full snapshot data to local disk
+
+! calculate strain div and curl
+ do ispec=1,NSPEC_AB
+
+ 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
+!!! 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)
+ iglob = ibool(i,l,k,ispec)
+ tempx2l = tempx2l + veloc(1,iglob)*hp2
+ tempy2l = tempy2l + veloc(2,iglob)*hp2
+ tempz2l = tempz2l + veloc(3,iglob)*hp2
+!!! 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)
+ 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
+ div(i,j,k,ispec) = dvxdxl(i,j,k) + dvydyl(i,j,k) + dvzdzl(i,j,k)
+ 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)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ write(outputname,"('div_proc',i6.6,'_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,"('curl_x_proc',i6.6,'_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,"('curl_y_proc',i6.6,'_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,"('curl_z_proc',i6.6,'_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
+
+!
+!---- end of time iteration loop
+!
+ enddo ! end of main time loop
+
+
+
+ end subroutine
\ No newline at end of file
Added: seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/prepare_timerun.f90 2009-08-30 00:21:20 UTC (rev 15636)
@@ -0,0 +1,385 @@
+!=====================================================================
+!
+! 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
+
+
+! synchronize all the processes before assembling the mass matrix
+! to make sure all the nodes have finished to read their databases
+ call sync_all()
+
+! the mass matrix needs to be assembled with MPI here once and for all
+ call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,rmass, &
+ buffer_send_scalar_ext_mesh,buffer_recv_scalar_ext_mesh, &
+ ninterfaces_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)
+
+ if(myrank == 0) write(IMAIN,*) 'end assembling MPI mass matrix'
+
+! check that mass matrix is positive
+ if(minval(rmass(:)) <= 0.) call exit_MPI(myrank,'negative mass matrix term')
+ if(OCEANS .and. minval(rmass_ocean_load(:)) <= 0.) &
+ call exit_MPI(myrank,'negative ocean load mass matrix term')
+
+! for efficiency, invert final mass matrix once and for all in each slice
+ if(OCEANS) rmass_ocean_load(:) = 1. / rmass_ocean_load(:)
+ rmass(:) = 1.0 / rmass(:)
+
+! 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
+
+!pll
+! do ispec = 1,NSPEC_AB
+! if(not_fully_in_bedrock(ispec)) then
+! do k=1,NGLLZ
+! do j=1,NGLLY
+! do i=1,NGLLX
+!
+!! distinguish attenuation factors
+! if(flag_sediments(i,j,k,ispec)) then
+!
+!! use constant attenuation of Q = 90
+!! or 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)
+!! 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
+!
+! else
+! iattenuation_sediments = IATTENUATION_SEDIMENTS_90
+! endif
+!
+! scale_factor = factor_scale(iattenuation_sediments)
+! else
+! scale_factor = factor_scale(IATTENUATION_BEDROCK)
+! endif
+!
+! mustore(i,j,k,ispec) = mustore(i,j,k,ispec) * scale_factor
+!
+! enddo
+! enddo
+! enddo
+! endif
+! enddo
+
+ !pll
+ do ispec = 1,NSPEC_AB
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ scale_factor = factor_scale(iflag_attenuation_store(i,j,k,ispec))
+ mustore(i,j,k,ispec) = mustore(i,j,k,ispec) * scale_factor
+ enddo
+ enddo
+ enddo
+ enddo
+
+ endif
+
+! allocate seismogram array
+ if (nrec_local > 0) then
+ 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
+ if (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
+ endif
+
+! initialize arrays to zero
+ 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
+
+!! DK DK array not created yet for CUBIT
+! if (SIMULATION_TYPE == 3) then ! kernel calculation, read in last frame
+
+! open(unit=27,file=trim(prname)//'save_forward_arrays.bin',status='old',action='read',form='unformatted')
+! read(27) b_displ
+! read(27) b_veloc
+! read(27) b_accel
+
+! rho_kl(:,:,:,:) = 0._CUSTOM_REAL
+! mu_kl(:,:,:,:) = 0._CUSTOM_REAL
+! kappa_kl(:,:,:,:) = 0._CUSTOM_REAL
+
+! endif
+
+! allocate files to save movies and shaking map
+ if(MOVIE_SURFACE .or. CREATE_SHAKEMAP) then
+ if (USE_HIGHRES_FOR_MOVIES) then
+ nmovie_points = NGLLX * NGLLY * NSPEC2D_TOP
+ else
+ nmovie_points = NGNOD2D * NSPEC2D_TOP
+ 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
+ allocate(store_val_x(nmovie_points))
+ allocate(store_val_y(nmovie_points))
+ allocate(store_val_z(nmovie_points))
+ allocate(store_val_ux(nmovie_points))
+ allocate(store_val_uy(nmovie_points))
+ allocate(store_val_uz(nmovie_points))
+ allocate(store_val_norm_displ(nmovie_points))
+ allocate(store_val_norm_veloc(nmovie_points))
+ allocate(store_val_norm_accel(nmovie_points))
+
+ allocate(store_val_x_all(nmovie_points,0:NPROC-1))
+ allocate(store_val_y_all(nmovie_points,0:NPROC-1))
+ allocate(store_val_z_all(nmovie_points,0:NPROC-1))
+ allocate(store_val_ux_all(nmovie_points,0:NPROC-1))
+ allocate(store_val_uy_all(nmovie_points,0:NPROC-1))
+ allocate(store_val_uz_all(nmovie_points,0:NPROC-1))
+
+! to compute max of norm for shaking map
+ store_val_norm_displ(:) = -1.
+ store_val_norm_veloc(:) = -1.
+ store_val_norm_accel(:) = -1.
+ else if (MOVIE_VOLUME) 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))
+ endif
+
+ 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
+
+! distinguish between single and double precision for reals
+ if(CUSTOM_REAL == SIZE_REAL) then
+ deltat = sngl(DT)
+ else
+ deltat = DT
+ endif
+ deltatover2 = deltat/2.
+ deltatsqover2 = deltat*deltat/2.
+ if (SIMULATION_TYPE == 3) then
+ if(CUSTOM_REAL == SIZE_REAL) then
+ b_deltat = - sngl(DT)
+ else
+ b_deltat = - DT
+ endif
+ b_deltatover2 = b_deltat/2.
+ b_deltatsqover2 = b_deltat*b_deltat/2.
+ endif
+
+! precompute Runge-Kutta coefficients if attenuation
+ if(ATTENUATION) then
+ tauinv(:,:) = - 1. / tau_sigma(:,:)
+ factor_common(:,:) = 2. * beta(:,:) * tauinv(:,:)
+ alphaval(:,:) = 1 + deltat*tauinv(:,:) + deltat**2*tauinv(:,:)**2 / 2. + &
+ deltat**3*tauinv(:,:)**3 / 6. + deltat**4*tauinv(:,:)**4 / 24.
+ betaval(:,:) = deltat / 2. + deltat**2*tauinv(:,:) / 3. + deltat**3*tauinv(:,:)**2 / 8. + deltat**4*tauinv(:,:)**3 / 24.
+ gammaval(:,:) = deltat / 2. + deltat**2*tauinv(:,:) / 6. + deltat**3*tauinv(:,:)**2 / 24.
+ if (SIMULATION_TYPE == 3) then
+ b_alphaval(:,:) = 1 + b_deltat*tauinv(:,:) + b_deltat**2*tauinv(:,:)**2 / 2. + &
+ b_deltat**3*tauinv(:,:)**3 / 6. + b_deltat**4*tauinv(:,:)**4 / 24.
+ b_betaval(:,:) = b_deltat / 2. + b_deltat**2*tauinv(:,:) / 3. + &
+ b_deltat**3*tauinv(:,:)**2 / 8. + b_deltat**4*tauinv(:,:)**3 / 24.
+ b_gammaval(:,:) = b_deltat / 2. + b_deltat**2*tauinv(:,:) / 6. + &
+ b_deltat**3*tauinv(:,:)**2 / 24.
+ endif
+ endif
+
+
+ !pll, to put elsewhere
+ 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
+
+!! DK DK array not created yet for CUBIT
+! if (SIMULATION_TYPE == 3) 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
+
+ endif
+ close(27)
+
+! initialize Moho boundary index
+! if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
+! ispec2D_moho_top = 0
+! ispec2D_moho_bot = 0
+! k_top = 1
+! k_bot = NGLLZ
+! 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 MPI_REDUCE(NSPEC_AB,NSPEC_AB_global_min,1,MPI_INTEGER,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call MPI_REDUCE(NSPEC_AB,NSPEC_AB_global_max,1,MPI_INTEGER,MPI_MAX,0,MPI_COMM_WORLD,ier)
+ call MPI_REDUCE(NSPEC_AB,NSPEC_AB_global_sum,1,MPI_INTEGER,MPI_SUM,0,MPI_COMM_WORLD,ier)
+
+ call MPI_REDUCE(NGLOB_AB,NGLOB_AB_global_min,1,MPI_INTEGER,MPI_MIN,0,MPI_COMM_WORLD,ier)
+ call MPI_REDUCE(NGLOB_AB,NGLOB_AB_global_max,1,MPI_INTEGER,MPI_MAX,0,MPI_COMM_WORLD,ier)
+
+ if(myrank == 0) then
+ 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,*)
+ write(IMAIN,*) 'NGLOB_AB_global_min = ',NGLOB_AB_global_min
+ write(IMAIN,*) 'NGLOB_AB_global_max = ',NGLOB_AB_global_max
+ write(IMAIN,*)
+ endif
+
+
+ end subroutine
\ No newline at end of file
Added: seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/read_mesh_databases.f90 2009-08-30 00:21:20 UTC (rev 15636)
@@ -0,0 +1,165 @@
+!=====================================================================
+!
+! 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
+
+! start reading the databasesa
+
+! info about external mesh simulation
+! nlegoff -- should be put in read_arrays_solver and read_arrays_buffer_solver for clarity
+ call create_name_database(prname,myrank,LOCAL_PATH)
+ open(unit=27,file=prname(1:len_trim(prname))//'external_mesh.bin',status='old',action='read',form='unformatted')
+ read(27) NSPEC_AB
+ read(27) NGLOB_AB
+ 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
+
+ !pll
+ read(27) rho_vp
+ read(27) rho_vs
+ read(27) iflag_attenuation_store
+ read(27) NSPEC2DMAX_XMIN_XMAX_ext
+ read(27) NSPEC2DMAX_YMIN_YMAX_ext
+ allocate(nimin(2,NSPEC2DMAX_YMIN_YMAX_ext),nimax(2,NSPEC2DMAX_YMIN_YMAX_ext),nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX_ext))
+ allocate(njmin(2,NSPEC2DMAX_XMIN_XMAX_ext),njmax(2,NSPEC2DMAX_XMIN_XMAX_ext),nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX_ext))
+ read(27) nimin
+ read(27) nimax
+ read(27) njmin
+ read(27) njmax
+ read(27) nkmin_xi
+ read(27) nkmin_eta
+ !end pll
+
+ read(27) kappastore
+ read(27) mustore
+ read(27) rmass
+ read(27) ibool
+ read(27) xstore
+ read(27) ystore
+ read(27) zstore
+
+ !pll
+ read(27) nspec2D_xmin
+ read(27) nspec2D_xmax
+ read(27) nspec2D_ymin
+ read(27) nspec2D_ymax
+ read(27) NSPEC2D_BOTTOM
+ read(27) NSPEC2D_TOP
+ allocate(ibelm_xmin(nspec2D_xmin))
+ allocate(ibelm_xmax(nspec2D_xmax))
+ allocate(ibelm_ymin(nspec2D_ymin))
+ allocate(ibelm_ymax(nspec2D_ymax))
+ allocate(ibelm_bottom(NSPEC2D_BOTTOM))
+ allocate(ibelm_top(NSPEC2D_TOP))
+ allocate(jacobian2D_xmin(NGLLY,NGLLZ,nspec2D_xmin))
+ allocate(jacobian2D_xmax(NGLLY,NGLLZ,nspec2D_xmax))
+ allocate(jacobian2D_ymin(NGLLX,NGLLZ,nspec2D_ymin))
+ allocate(jacobian2D_ymax(NGLLX,NGLLZ,nspec2D_ymax))
+ allocate(jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM))
+ allocate(jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP))
+ allocate(normal_xmin(NDIM,NGLLY,NGLLZ,nspec2D_xmin))
+ allocate(normal_xmax(NDIM,NGLLY,NGLLZ,nspec2D_xmax))
+ allocate(normal_ymin(NDIM,NGLLX,NGLLZ,nspec2D_ymin))
+ allocate(normal_ymax(NDIM,NGLLX,NGLLZ,nspec2D_ymax))
+ allocate(normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM))
+ allocate(normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP))
+ read(27) ibelm_xmin
+ read(27) ibelm_xmax
+ read(27) ibelm_ymin
+ read(27) ibelm_ymax
+ read(27) ibelm_bottom
+ read(27) ibelm_top
+ read(27) normal_xmin
+ read(27) normal_xmax
+ read(27) normal_ymin
+ read(27) normal_ymax
+ read(27) normal_bottom
+ read(27) normal_top
+ read(27) jacobian2D_xmin
+ read(27) jacobian2D_xmax
+ read(27) jacobian2D_ymin
+ read(27) jacobian2D_ymax
+ read(27) jacobian2D_bottom
+ read(27) jacobian2D_top
+ !end pll
+
+ read(27) ninterfaces_ext_mesh
+ read(27) max_nibool_interfaces_ext_mesh
+ allocate(my_neighbours_ext_mesh(ninterfaces_ext_mesh))
+ allocate(nibool_interfaces_ext_mesh(ninterfaces_ext_mesh))
+ allocate(ibool_interfaces_ext_mesh(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
+ read(27) my_neighbours_ext_mesh
+ read(27) nibool_interfaces_ext_mesh
+ read(27) ibool_interfaces_ext_mesh
+
+ allocate(buffer_send_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
+ allocate(buffer_recv_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
+ allocate(buffer_send_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
+ allocate(buffer_recv_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
+ allocate(request_send_vector_ext_mesh(ninterfaces_ext_mesh))
+ allocate(request_recv_vector_ext_mesh(ninterfaces_ext_mesh))
+ allocate(request_send_scalar_ext_mesh(ninterfaces_ext_mesh))
+ allocate(request_recv_scalar_ext_mesh(ninterfaces_ext_mesh))
+ close(27)
+
+! locate inner and outer elements
+ allocate(ispec_is_inner_ext_mesh(NSPEC_AB))
+ allocate(iglob_is_inner_ext_mesh(NGLOB_AB))
+ ispec_is_inner_ext_mesh(:) = .true.
+ iglob_is_inner_ext_mesh(:) = .true.
+ do iinterface = 1, ninterfaces_ext_mesh
+ do i = 1, nibool_interfaces_ext_mesh(iinterface)
+ iglob = ibool_interfaces_ext_mesh(i,iinterface)
+ iglob_is_inner_ext_mesh(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_ext_mesh(ispec) = iglob_is_inner_ext_mesh(iglob) .and. ispec_is_inner_ext_mesh(ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+
+
+ end subroutine
\ No newline at end of file
Added: seismo/3D/SPECFEM3D_SESAME/trunk/read_topography_bathymetry.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/read_topography_bathymetry.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/read_topography_bathymetry.f90 2009-08-30 00:21:20 UTC (rev 15636)
@@ -0,0 +1,62 @@
+!=====================================================================
+!
+! 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
+
+! read topography and bathymetry file
+ if(TOPOGRAPHY .or. 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
\ No newline at end of file
Added: seismo/3D/SPECFEM3D_SESAME/trunk/setup_GLL_points.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/setup_GLL_points.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/setup_GLL_points.f90 2009-08-30 00:21:20 UTC (rev 15636)
@@ -0,0 +1,68 @@
+!=====================================================================
+!
+! 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
+
+
+ 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
+ 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)
+ if (ATTENUATION .and. ((SIMULATION_TYPE == 1 .and. SAVE_FORWARD) .or. SIMULATION_TYPE == 3)) &
+ call create_name_database(prname_Q,myrank,LOCAL_PATH_Q)
+
+
+ end subroutine
\ No newline at end of file
Added: seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/setup_movie_meshes.f90 2009-08-30 00:21:20 UTC (rev 15636)
@@ -0,0 +1,253 @@
+!=====================================================================
+!
+! 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_movie_meshes()
+
+ use specfem_par
+
+ if (EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP) then
+
+ nfaces_surface_external_mesh = 0
+ do ispec = 1, NSPEC_AB
+ iglob = ibool(2,2,1,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ iglob = ibool(2,2,NGLLZ,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ iglob = ibool(2,1,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ iglob = ibool(2,NGLLY,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ iglob = ibool(1,2,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ iglob = ibool(NGLLX,2,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ endif
+ enddo ! NSPEC_AB
+
+ allocate(nfaces_perproc_surface_ext_mesh(NPROC))
+ allocate(faces_surface_offset_ext_mesh(NPROC))
+ if (nfaces_surface_external_mesh == 0) then
+ if (USE_HIGHRES_FOR_MOVIES) then
+ allocate(faces_surface_external_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_external_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_external_mesh(NGLLX*NGLLY,nfaces_surface_external_mesh))
+ allocate(store_val_x_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
+ allocate(store_val_y_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
+ allocate(store_val_z_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
+ allocate(store_val_ux_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
+ allocate(store_val_uy_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
+ allocate(store_val_uz_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
+ else
+ allocate(faces_surface_external_mesh(NGNOD2D,nfaces_surface_external_mesh))
+ allocate(store_val_x_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
+ allocate(store_val_y_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
+ allocate(store_val_z_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
+ allocate(store_val_ux_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
+ allocate(store_val_uy_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
+ allocate(store_val_uz_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
+ endif
+ endif
+ call sum_all_i(nfaces_surface_external_mesh,nfaces_surface_glob_ext_mesh)
+ 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_external_mesh,1,nfaces_perproc_surface_ext_mesh,1,NPROC)
+
+ 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
+
+ nfaces_surface_external_mesh = 0
+ do ispec = 1, NSPEC_AB
+ if (ispec_is_surface_external_mesh(ispec)) then
+ iglob = ibool(2,2,1,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do j = NGLLY, 1, -1
+ do i = 1, NGLLX
+ ipoin = ipoin+1
+ faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,j,1,ispec)
+ enddo
+ enddo
+ else
+ faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,1,1,ispec)
+ faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(1,NGLLY,1,ispec)
+ faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,1,ispec)
+ faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(NGLLX,1,1,ispec)
+ endif
+ endif
+ iglob = ibool(2,2,NGLLZ,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do j = 1, NGLLY
+ do i = 1, NGLLX
+ ipoin = ipoin+1
+ faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,j,NGLLZ,ispec)
+ enddo
+ enddo
+ else
+ faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,1,NGLLZ,ispec)
+ faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
+ faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
+ endif
+ endif
+ iglob = ibool(2,1,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do k = 1, NGLLZ
+ do i = 1, NGLLX
+ ipoin = ipoin+1
+ faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,1,k,ispec)
+ enddo
+ enddo
+ else
+ faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,1,1,ispec)
+ faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(NGLLX,1,1,ispec)
+ faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
+ faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(1,1,NGLLZ,ispec)
+ endif
+ endif
+ iglob = ibool(2,NGLLY,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do k = 1, NGLLZ
+ do i = NGLLX, 1, -1
+ ipoin = ipoin+1
+ faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,NGLLY,k,ispec)
+ enddo
+ enddo
+ else
+ faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,1,ispec)
+ faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(1,NGLLY,1,ispec)
+ faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
+ faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ endif
+ endif
+ iglob = ibool(1,2,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do k = 1, NGLLZ
+ do j = NGLLY, 1, -1
+ ipoin = ipoin+1
+ faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(1,j,k,ispec)
+ enddo
+ enddo
+ else
+ faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,NGLLY,1,ispec)
+ faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(1,1,1,ispec)
+ faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(1,1,NGLLZ,ispec)
+ faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
+ endif
+ endif
+ iglob = ibool(NGLLX,2,2,ispec)
+ if (iglob_is_surface_external_mesh(iglob)) then
+ nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
+ if (USE_HIGHRES_FOR_MOVIES) then
+ ipoin =0
+ do k = 1, NGLLZ
+ do j = 1, NGLLY
+ ipoin = ipoin+1
+ faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(NGLLX,j,k,ispec)
+ enddo
+ enddo
+ else
+ faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(NGLLX,1,1,ispec)
+ faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,1,ispec)
+ faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
+ faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
+ endif
+ endif
+
+ endif
+ enddo ! NSPEC_AB
+
+ if (myrank == 0) then
+ print *, nfaces_perproc_surface_ext_mesh
+ print *, nfaces_surface_glob_ext_mesh
+ endif
+
+ endif
+
+ end subroutine
\ No newline at end of file
Added: seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/setup_sources_receivers.f90 2009-08-30 00:21:20 UTC (rev 15636)
@@ -0,0 +1,323 @@
+!=====================================================================
+!
+! 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
+
+
+! write source and receiver VTK files for Paraview
+ if (myrank == 0) then
+ 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'
+ ! LQY -- cannot figure out NSOURCES+nrec at this point
+ write(IOVTK, '(a,i6,a)') 'POINTS ', 2, ' float'
+ endif
+
+! 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
+ call locate_source(ibool,NSOURCES,myrank,NSPEC_AB,NGLOB_AB, &
+ xstore,ystore,zstore,xigll,yigll,zigll,NPROC, &
+ sec,t_cmt,yr,jda,ho,mi,utm_x_source,utm_y_source, &
+ NSTEP,DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
+ islice_selected_source,ispec_selected_source, &
+ xi_source,eta_source,gamma_source, &
+ TOPOGRAPHY,UTM_PROJECTION_ZONE, &
+ PRINT_SOURCE_TIME_FUNCTION, &
+ nu_source,iglob_is_surface_external_mesh,ispec_is_surface_external_mesh)
+
+ 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)
+
+!$$$$$$$$$$$$$$$$$$ RECEIVERS $$$$$$$$$$$$$$$$$$$$$
+
+ if (SIMULATION_TYPE == 1) then
+ call get_value_string(rec_filename, 'solver.STATIONS', 'DATA/STATIONS')
+
+! 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')
+
+ 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(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,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), &
+ TOPOGRAPHY,UTM_PROJECTION_ZONE, &
+ iglob_is_surface_external_mesh,ispec_is_surface_external_mesh )
+
+
+!###################### SOURCE ARRAYS ################
+
+ 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
+ call compute_arrays_source(ispec_selected_source(isource), &
+ 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)
+ sourcearrays(isource,:,:,:,:) = sourcearray(:,:,:,:)
+ endif
+ enddo
+ endif
+
+ if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
+ nadj_rec_local = 0
+ do irec = 1,nrec
+ if(myrank == islice_selected_rec(irec))then
+! check 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')
+ nadj_rec_local = nadj_rec_local + 1
+ endif
+ enddo
+ allocate(adj_sourcearray(NSTEP,NDIM,NGLLX,NGLLY,NGLLZ))
+ if (nadj_rec_local > 0) allocate(adj_sourcearrays(nadj_rec_local,NSTEP,NDIM,NGLLX,NGLLY,NGLLZ))
+ irec_local = 0
+ do irec = 1, nrec
+! compute only adjoint source arrays in the local slice
+ if(myrank == islice_selected_rec(irec)) then
+ irec_local = irec_local + 1
+ 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
+ endif
+
+!--- select local receivers
+
+! 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
+ nrec_simulation = NSOURCES
+ do isource = 1, NSOURCES
+ if(myrank == islice_selected_source(isource)) nrec_local = nrec_local + 1
+ enddo
+ endif
+
+ 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
+
+ close(IOVTK)
+
+ 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(nrec_tot_found /= nrec_simulation) then
+ call exit_MPI(myrank,'problem when dispatching the receivers')
+ else
+ write(IMAIN,*) 'this total is okay'
+ endif
+ endif
+
+ if(myrank == 0) then
+
+ if(NSOURCES > 1) write(IMAIN,*) 'Using ',NSOURCES,' point sources'
+
+ write(IMAIN,*)
+ if(TOPOGRAPHY) then
+ write(IMAIN,*) 'incorporating surface topography'
+ else
+ write(IMAIN,*) 'no surface topography'
+ 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(OCEANS) then
+ write(IMAIN,*) 'incorporating the oceans using equivalent load'
+ else
+ write(IMAIN,*) 'no oceans'
+ endif
+
+ endif
+
+
+
+ end subroutine
\ No newline at end of file
Modified: seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D.f90 2009-08-29 16:59:10 UTC (rev 15635)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D.f90 2009-08-30 00:21:20 UTC (rev 15636)
@@ -27,16 +27,9 @@
subroutine specfem3D
- implicit none
+ use specfem_par
+
- include "constants.h"
-
-! include values created by the mesher
- include "OUTPUT_FILES/values_from_mesher.h"
-
-! standard include of the MPI library
- include 'mpif.h'
-
!=============================================================================!
! !
! specfem3D is a 3-D spectral-element solver for a local or regional model. !
@@ -191,2820 +184,43 @@
!
! MPI v. 1.0 Dimitri Komatitsch, Caltech, May 2002: first MPI version based on global code
-! 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
- integer iattenuation
- double precision scale_factor
-
- 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
-
- integer :: NSPEC_ATTENUATION_AB
- integer, dimension(:,:,:,:),allocatable :: iflag_attenuation_store
-
-! ADJOINT
- real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: b_alphaval, b_betaval, b_gammaval
-!! DK DK array not created yet for CUBIT
-! 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
-! ADJOINT
-
-! 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
-
- integer :: NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext
- integer, dimension(:), allocatable :: ibelm_xmin,ibelm_xmax
- integer, dimension(:), allocatable :: ibelm_ymin,ibelm_ymax
- integer, dimension(:), allocatable :: ibelm_bottom
- integer, dimension(:), allocatable :: ibelm_top
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_xmin,jacobian2D_xmax
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_ymin,jacobian2D_ymax
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_bottom
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_top
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_xmin,normal_xmax
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_ymin,normal_ymax
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_bottom
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_top
-
-!! DK DK array not created yet for CUBIT
-! integer, dimension(NSPEC2D_TOP_VAL) :: ibelm_top
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_VAL) :: normal_top
-
-!! DK DK array not created yet for CUBIT
-! Moho mesh
-! integer,dimension(NSPEC2D_MOHO_BOUN) :: ibelm_moho_top, ibelm_moho_bot
-! real(CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO_BOUN) :: normal_moho
-! integer :: nspec2D_moho
-
-!! DK DK array not created yet for CUBIT
-! buffers for send and receive between faces of the slices and the chunks
-! real(kind=CUSTOM_REAL), dimension(NDIM,NPOIN2DMAX_XY_VAL) :: buffer_send_faces_vector,buffer_received_faces_vector
-
-! -----------------
-
-! mesh parameters
- integer, dimension(:,:,:,:), allocatable :: ibool
-
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
- xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,jacobian
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: xstore,ystore,zstore
-
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
- kappastore,mustore
-
-! flag for sediments
- logical, dimension(:), allocatable :: not_fully_in_bedrock
- logical, dimension(:,:,:,:), allocatable :: flag_sediments
-
-! Stacey
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_vp,rho_vs
-
-! local to global mapping
- integer, dimension(:), allocatable :: idoubling
-
-! mass matrix
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass
-
-! 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
- logical, dimension(:), allocatable :: updated_dof_ocean_load
- real(kind=CUSTOM_REAL) additional_term,force_normal_comp
-
-! displacement, velocity, acceleration
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: displ,veloc,accel
-
- 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
-
-! time scheme
- real(kind=CUSTOM_REAL) deltat,deltatover2,deltatsqover2
-
-! ADJOINT
- real(kind=CUSTOM_REAL) b_additional_term,b_force_normal_comp
-!! DK DK array not created yet for CUBIT
-! real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_ADJOINT) :: b_displ, b_veloc, b_accel
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT) :: rho_kl, mu_kl, kappa_kl, &
-! rhop_kl, beta_kl, alpha_kl
-! real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: absorb_xmin, absorb_xmax, &
-! absorb_ymin, absorb_ymax, absorb_zmin ! for absorbing b.c.
-! integer reclen_xmin, reclen_xmax, reclen_ymin, reclen_ymax, reclen_zmin
-
- real(kind=CUSTOM_REAL) b_deltat, b_deltatover2, b_deltatsqover2
-! ADJOINT
-
- integer l
-
-! Moho kernel
-! integer ispec2D_moho_top, ispec2D_moho_bot, k_top, k_bot, ispec_top, ispec_bot, iglob_top, iglob_bot
-!! DK DK array not created yet for CUBIT
-! real(kind=CUSTOM_REAL), dimension(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO_BOUN) :: dsdx_top, dsdx_bot, b_dsdx_top, b_dsdx_bot
-! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_MOHO_BOUN) :: moho_kl
-! real(kind=CUSTOM_REAL) :: kernel_moho_top, kernel_moho_bot
-
-! --------
-
-! parameters for the source
- integer it,isource
- integer, dimension(:), allocatable :: islice_selected_source,ispec_selected_source
- integer yr,jda,ho,mi
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: sourcearray
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: sourcearrays
- double precision, dimension(:,:,:), allocatable :: nu_source
-!ADJOINT
- character(len=150) adj_source_file
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: adj_sourcearray
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:,:), allocatable :: adj_sourcearrays
-!ADJOINT
- double precision sec,stf
- 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
-
-! receiver information
- character(len=150) rec_filename,filtered_rec_filename,dummystring
- integer nrec,nrec_local,nrec_tot_found,irec_local,ios
- integer, allocatable, dimension(:) :: islice_selected_rec,ispec_selected_rec,number_receiver_global
- double precision, allocatable, dimension(:) :: xi_receiver,eta_receiver,gamma_receiver
- double precision hlagrange
-! ADJOINT
- integer nrec_simulation, nadj_rec_local
-! source frechet derivatives
- real(kind=CUSTOM_REAL) :: displ_s(NDIM,NGLLX,NGLLY,NGLLZ), eps_s(NDIM,NDIM), eps_m_s(NDIM), stf_deltat
- 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
- double precision, dimension(:,:), allocatable :: hpxir_store,hpetar_store,hpgammar_store
-! ADJOINT
-
-! 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
- double precision dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: seismograms_d,seismograms_v,seismograms_a
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: seismograms_eps
-
- integer i,j,k,ispec,irec,iglob
-
-! 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
-
-! 2-D addressing and buffers for summation between slices
-! integer, dimension(NPOIN2DMAX_XMIN_XMAX_VAL) :: iboolleft_xi,iboolright_xi
-! integer, dimension(NPOIN2DMAX_YMIN_YMAX_VAL) :: iboolleft_eta,iboolright_eta
-
-! for addressing of the slices
-! integer, dimension(0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL) :: addressing
-
-! proc numbers for MPI
- integer myrank,sizeprocs
-
-! integer npoin2D_xi,npoin2D_eta
-
-! integer iproc_xi,iproc_eta
-
-! maximum of the norm of the displacement
- real(kind=CUSTOM_REAL) Usolidnorm,Usolidnorm_all
- integer:: Usolidnorm_index(1)
-! ADJOINT
-! real(kind=CUSTOM_REAL) b_Usolidnorm, b_Usolidnorm_all
-! ADJOINT
-
-! timer MPI
- double precision, external :: wtime
- integer ihours,iminutes,iseconds,int_tCPU
- double precision time_start,tCPU
-
-! parameters read from parameter file
- integer NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE,SIMULATION_TYPE
- integer NSOURCES
-
- double precision DT,LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN,LONGITUDE_MAX,HDUR_MOVIE
-
- logical TOPOGRAPHY,ATTENUATION,USE_OLSEN_ATTENUATION, &
- OCEANS,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
- integer NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
-
- character(len=150) OUTPUT_FILES,LOCAL_PATH,prname,prname_Q
-
-! parameters deduced from parameters read from file
- integer NPROC
-
- integer NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC_AB, NGLOB_AB
-
-! names of the data files for all the processors in MPI
- character(len=150) outputname
-
-! Stacey conditions put back
- integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,ispec2D
- real(kind=CUSTOM_REAL) nx,ny,nz
- integer, dimension(:,:),allocatable :: nimin,nimax,nkmin_eta
- integer, dimension(:,:),allocatable :: njmin,njmax,nkmin_xi
-
-! to save movie frames
- integer ipoin, nmovie_points, iloc, iorderi(NGNOD2D), iorderj(NGNOD2D)
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
- store_val_x,store_val_y,store_val_z, &
- store_val_ux,store_val_uy,store_val_uz, &
- store_val_norm_displ,store_val_norm_veloc,store_val_norm_accel
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
- store_val_x_all,store_val_y_all,store_val_z_all, &
- store_val_ux_all,store_val_uy_all,store_val_uz_all
-
-! to save full 3D snapshot of velocity
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dvxdxl,dvxdyl,dvxdzl,dvydxl,dvydyl,dvydzl,dvzdxl,dvzdyl,dvzdzl
- real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable:: div, curl_x, curl_y, curl_z
-
-! for assembling in case of external mesh
- integer :: ninterfaces_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
- integer, dimension(:), allocatable :: valence_external_mesh
- logical, dimension(:), allocatable :: iglob_is_surface_external_mesh
- logical, dimension(:), allocatable :: ispec_is_surface_external_mesh
- integer, dimension(:,:), allocatable :: buffer_send_scalar_i_ext_mesh
- integer, dimension(:,:), allocatable :: buffer_recv_scalar_i_ext_mesh
- integer :: nfaces_surface_external_mesh
- integer :: nfaces_surface_glob_ext_mesh
- integer,dimension(:),allocatable :: nfaces_perproc_surface_ext_mesh
- integer,dimension(:),allocatable :: faces_surface_offset_ext_mesh
- integer,dimension(:,:),allocatable :: faces_surface_external_mesh
- 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
- integer :: ii,jj,kk
-
-! for communications overlapping
- logical, dimension(:), allocatable :: ispec_is_inner_ext_mesh
- logical, dimension(:), allocatable :: iglob_is_inner_ext_mesh
- integer :: iinterface
-
-!!!! 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
-
-!! 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
- integer :: NSPEC_AB_global_min,NSPEC_AB_global_max,NSPEC_AB_global_sum
- integer :: NGLOB_AB_global_min,NGLOB_AB_global_max
- integer :: ier
-
! ************** PROGRAM STARTS HERE **************
+! reads in parameters
+ call initialize_simulation()
-! sizeprocs returns number of processes started
-! (should be equal to NPROC)
-! myrank is the rank of each process, between 0 and sizeprocs-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)
+! reads in external mesh
+ call read_mesh_databases()
-! read the parameter file
- call read_parameter_file( &
- NPROC,NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,DT, &
- UTM_PROJECTION_ZONE,SUPPRESS_UTM_PROJECTION, &
- ATTENUATION,USE_OLSEN_ATTENUATION,TOPOGRAPHY,LOCAL_PATH,NSOURCES, &
- OCEANS,ANISOTROPY,ABSORBING_CONDITIONS, &
- MOVIE_SURFACE,MOVIE_VOLUME,CREATE_SHAKEMAP,SAVE_DISPLACEMENT, &
- NTSTEP_BETWEEN_FRAMES,USE_HIGHRES_FOR_MOVIES,HDUR_MOVIE, &
- SAVE_MESH_FILES,PRINT_SOURCE_TIME_FUNCTION, &
- NTSTEP_BETWEEN_OUTPUT_INFO,SIMULATION_TYPE,SAVE_FORWARD)
- if (sizeprocs == 1 .and. (NPROC_XI /= 1 .or. NPROC_ETA /= 1)) then
- stop 'must have NPROC_XI = NPROC_ETA = 1 for a serial run'
- endif
+! creates GLL points
+ call setup_GLL_points()
-! 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 simulation parameters
- if (SIMULATION_TYPE /= 1 .and. NSOURCES > 1000) call exit_mpi(myrank, 'for adjoint simulations, NSOURCES <= 1000')
-! LQY -- note: kernel simulations with attenuation turned on has been implemented
+! detects surfaces
+ call detect_mesh_surfaces()
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-! check that optimized routines from Deville et al. (2002) can be used
- if(NGLLX /= 5 .or. NGLLY /= 5 .or. NGLLZ /= 5) &
- stop 'optimized routines from Deville et al. (2002) such as mxm_m1_m2_5points can only be used if NGLL = 5'
+! reads topography & bathymetry
+ call read_topography_bathymetry()
-! info about external mesh simulation
-! nlegoff -- should be put in compute_parameters and read_parameter_file for clarity
- NPROC = sizeprocs
-! chris: DT_ext_mesh & NSTE_ext_mesh were in constants.h, I suppressed it, now it is Par_file & read in
-! read_parameters_file.f90
-! DT = DT_ext_mesh
-! NSTEP = NSTEP_ext_mesh
- 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')
+
+! prepares sources and receivers
+ call setup_sources_receivers()
- read(27) NSPEC_AB
- read(27) NGLOB_AB
- !pll
- NSPEC_ATTENUATION_AB = NSPEC_AB
- close(27)
-! 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')
+! sets up and precomputes simulation arrays
+ call prepare_timerun()
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) '**********************************************'
- write(IMAIN,*) '**** Specfem 3-D Solver - MPI version f90 ****'
- write(IMAIN,*) '**********************************************'
- write(IMAIN,*)
- write(IMAIN,*)
+! steps through time iterations
+ call iterate_time()
- if(FIX_UNDERFLOW_PROBLEM) write(IMAIN,*) 'Fixing slow underflow trapping problem using small initial field'
- write(IMAIN,*)
- write(IMAIN,*) 'There are ',sizeprocs,' MPI processes'
- write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
- write(IMAIN,*)
+! saves last time frame and finishes kernel calculations
+ call finalize_simulation()
- write(IMAIN,*) 'There are ',NPROC_XI,' slices along xi'
- write(IMAIN,*) 'There are ',NPROC_ETA,' slices along eta'
- 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
-
-! 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')
-
-
-
-! start reading the databases
-
-! 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))
- allocate(xstore(NGLOB_AB))
- allocate(ystore(NGLOB_AB))
- allocate(zstore(NGLOB_AB))
- allocate(kappastore(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(mustore(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(not_fully_in_bedrock(NSPEC_AB))
- allocate(flag_sediments(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(rho_vp(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(rho_vs(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
- allocate(idoubling(NSPEC_AB))
- allocate(rmass(NGLOB_AB))
- allocate(rmass_ocean_load(NGLOB_AB))
- allocate(updated_dof_ocean_load(NGLOB_AB))
- allocate(displ(NDIM,NGLOB_AB))
- allocate(veloc(NDIM,NGLOB_AB))
- allocate(accel(NDIM,NGLOB_AB))
- allocate(iflag_attenuation_store(NGLLX,NGLLY,NGLLZ,NSPEC_AB))
-
-
-
-
-! info about external mesh simulation
-! nlegoff -- should be put in read_arrays_solver and read_arrays_buffer_solver for clarity
- call create_name_database(prname,myrank,LOCAL_PATH)
- open(unit=27,file=prname(1:len_trim(prname))//'external_mesh.bin',status='old',action='read',form='unformatted')
- read(27) NSPEC_AB
- read(27) NGLOB_AB
- 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
-
- !pll
- read(27) rho_vp
- read(27) rho_vs
- read(27) iflag_attenuation_store
- read(27) NSPEC2DMAX_XMIN_XMAX_ext
- read(27) NSPEC2DMAX_YMIN_YMAX_ext
- allocate(nimin(2,NSPEC2DMAX_YMIN_YMAX_ext),nimax(2,NSPEC2DMAX_YMIN_YMAX_ext),nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX_ext))
- allocate(njmin(2,NSPEC2DMAX_XMIN_XMAX_ext),njmax(2,NSPEC2DMAX_XMIN_XMAX_ext),nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX_ext))
- read(27) nimin
- read(27) nimax
- read(27) njmin
- read(27) njmax
- read(27) nkmin_xi
- read(27) nkmin_eta
- !end pll
-
- read(27) kappastore
- read(27) mustore
- read(27) rmass
- read(27) ibool
- read(27) xstore
- read(27) ystore
- read(27) zstore
-
- !pll
- read(27) nspec2D_xmin
- read(27) nspec2D_xmax
- read(27) nspec2D_ymin
- read(27) nspec2D_ymax
- read(27) NSPEC2D_BOTTOM
- read(27) NSPEC2D_TOP
- allocate(ibelm_xmin(nspec2D_xmin))
- allocate(ibelm_xmax(nspec2D_xmax))
- allocate(ibelm_ymin(nspec2D_ymin))
- allocate(ibelm_ymax(nspec2D_ymax))
- allocate(ibelm_bottom(NSPEC2D_BOTTOM))
- allocate(ibelm_top(NSPEC2D_TOP))
- allocate(jacobian2D_xmin(NGLLY,NGLLZ,nspec2D_xmin))
- allocate(jacobian2D_xmax(NGLLY,NGLLZ,nspec2D_xmax))
- allocate(jacobian2D_ymin(NGLLX,NGLLZ,nspec2D_ymin))
- allocate(jacobian2D_ymax(NGLLX,NGLLZ,nspec2D_ymax))
- allocate(jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM))
- allocate(jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP))
- allocate(normal_xmin(NDIM,NGLLY,NGLLZ,nspec2D_xmin))
- allocate(normal_xmax(NDIM,NGLLY,NGLLZ,nspec2D_xmax))
- allocate(normal_ymin(NDIM,NGLLX,NGLLZ,nspec2D_ymin))
- allocate(normal_ymax(NDIM,NGLLX,NGLLZ,nspec2D_ymax))
- allocate(normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM))
- allocate(normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP))
- read(27) ibelm_xmin
- read(27) ibelm_xmax
- read(27) ibelm_ymin
- read(27) ibelm_ymax
- read(27) ibelm_bottom
- read(27) ibelm_top
- read(27) normal_xmin
- read(27) normal_xmax
- read(27) normal_ymin
- read(27) normal_ymax
- read(27) normal_bottom
- read(27) normal_top
- read(27) jacobian2D_xmin
- read(27) jacobian2D_xmax
- read(27) jacobian2D_ymin
- read(27) jacobian2D_ymax
- read(27) jacobian2D_bottom
- read(27) jacobian2D_top
- !end pll
-
- read(27) ninterfaces_ext_mesh
- read(27) max_nibool_interfaces_ext_mesh
- allocate(my_neighbours_ext_mesh(ninterfaces_ext_mesh))
- allocate(nibool_interfaces_ext_mesh(ninterfaces_ext_mesh))
- allocate(ibool_interfaces_ext_mesh(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
- read(27) my_neighbours_ext_mesh
- read(27) nibool_interfaces_ext_mesh
- read(27) ibool_interfaces_ext_mesh
-
- allocate(buffer_send_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
- allocate(buffer_recv_vector_ext_mesh(NDIM,max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
- allocate(buffer_send_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
- allocate(buffer_recv_scalar_ext_mesh(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
- allocate(request_send_vector_ext_mesh(ninterfaces_ext_mesh))
- allocate(request_recv_vector_ext_mesh(ninterfaces_ext_mesh))
- allocate(request_send_scalar_ext_mesh(ninterfaces_ext_mesh))
- allocate(request_recv_scalar_ext_mesh(ninterfaces_ext_mesh))
- close(27)
-
-! locate inner and outer elements
- allocate(ispec_is_inner_ext_mesh(NSPEC_AB))
- allocate(iglob_is_inner_ext_mesh(NGLOB_AB))
- ispec_is_inner_ext_mesh(:) = .true.
- iglob_is_inner_ext_mesh(:) = .true.
- do iinterface = 1, ninterfaces_ext_mesh
- do i = 1, nibool_interfaces_ext_mesh(iinterface)
- iglob = ibool_interfaces_ext_mesh(i,iinterface)
- iglob_is_inner_ext_mesh(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_ext_mesh(ispec) = iglob_is_inner_ext_mesh(iglob) .and. ispec_is_inner_ext_mesh(ispec)
- enddo
- enddo
- enddo
- enddo
-
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-
-
-
- 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
- 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)
- if (ATTENUATION .and. ((SIMULATION_TYPE == 1 .and. SAVE_FORWARD) .or. SIMULATION_TYPE == 3)) &
- call create_name_database(prname_Q,myrank,LOCAL_PATH_Q)
-
-! detecting surface points/elements (based on valence check on NGLL points) for external mesh
- allocate(valence_external_mesh(NGLOB_AB))
- allocate(ispec_is_surface_external_mesh(NSPEC_AB))
- allocate(iglob_is_surface_external_mesh(NGLOB_AB))
-
- if (.not. RECVS_CAN_BE_BURIED_EXT_MESH) then
- valence_external_mesh(:) = 0
- ispec_is_surface_external_mesh(:) = .false.
- iglob_is_surface_external_mesh(:) = .false.
- do ispec = 1, NSPEC_AB
- do k = 1, NGLLZ
- do j = 1, NGLLY
- do i = 1, NGLLX
- iglob = ibool(i,j,k,ispec)
- valence_external_mesh(iglob) = valence_external_mesh(iglob) + 1
- enddo
- enddo
- enddo
- enddo
-
- allocate(buffer_send_scalar_i_ext_mesh(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
- allocate(buffer_recv_scalar_i_ext_mesh(max_nibool_interfaces_ext_mesh,ninterfaces_ext_mesh))
-
- call assemble_MPI_scalar_i_ext_mesh(NPROC,NGLOB_AB,valence_external_mesh, &
- buffer_send_scalar_i_ext_mesh,buffer_recv_scalar_i_ext_mesh, &
- ninterfaces_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)
-
- do ispec = 1, NSPEC_AB
- 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.
-
- 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
-
-
- if (EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP) then
- nfaces_surface_external_mesh = 0
- do ispec = 1, NSPEC_AB
- iglob = ibool(2,2,1,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- endif
- iglob = ibool(2,2,NGLLZ,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- endif
- iglob = ibool(2,1,2,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- endif
- iglob = ibool(2,NGLLY,2,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- endif
- iglob = ibool(1,2,2,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- endif
- iglob = ibool(NGLLX,2,2,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- endif
- enddo ! NSPEC_AB
-
- allocate(nfaces_perproc_surface_ext_mesh(NPROC))
- allocate(faces_surface_offset_ext_mesh(NPROC))
- if (nfaces_surface_external_mesh == 0) then
- if (USE_HIGHRES_FOR_MOVIES) then
- allocate(faces_surface_external_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_external_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_external_mesh(NGLLX*NGLLY,nfaces_surface_external_mesh))
- allocate(store_val_x_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
- allocate(store_val_y_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
- allocate(store_val_z_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
- allocate(store_val_ux_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
- allocate(store_val_uy_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
- allocate(store_val_uz_external_mesh(NGLLX*NGLLY*nfaces_surface_external_mesh))
- else
- allocate(faces_surface_external_mesh(NGNOD2D,nfaces_surface_external_mesh))
- allocate(store_val_x_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
- allocate(store_val_y_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
- allocate(store_val_z_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
- allocate(store_val_ux_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
- allocate(store_val_uy_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
- allocate(store_val_uz_external_mesh(NGNOD2D*nfaces_surface_external_mesh))
- endif
- endif
- call sum_all_i(nfaces_surface_external_mesh,nfaces_surface_glob_ext_mesh)
- 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_external_mesh,1,nfaces_perproc_surface_ext_mesh,1,NPROC)
-
- 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
-
- nfaces_surface_external_mesh = 0
- do ispec = 1, NSPEC_AB
- if (ispec_is_surface_external_mesh(ispec)) then
- iglob = ibool(2,2,1,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- if (USE_HIGHRES_FOR_MOVIES) then
- ipoin =0
- do j = NGLLY, 1, -1
- do i = 1, NGLLX
- ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,j,1,ispec)
- enddo
- enddo
- else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,1,1,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(1,NGLLY,1,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,1,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(NGLLX,1,1,ispec)
- endif
- endif
- iglob = ibool(2,2,NGLLZ,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- if (USE_HIGHRES_FOR_MOVIES) then
- ipoin =0
- do j = 1, NGLLY
- do i = 1, NGLLX
- ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,j,NGLLZ,ispec)
- enddo
- enddo
- else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,1,NGLLZ,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
- endif
- endif
- iglob = ibool(2,1,2,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- if (USE_HIGHRES_FOR_MOVIES) then
- ipoin =0
- do k = 1, NGLLZ
- do i = 1, NGLLX
- ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,1,k,ispec)
- enddo
- enddo
- else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,1,1,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(NGLLX,1,1,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(1,1,NGLLZ,ispec)
- endif
- endif
- iglob = ibool(2,NGLLY,2,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- if (USE_HIGHRES_FOR_MOVIES) then
- ipoin =0
- do k = 1, NGLLZ
- do i = NGLLX, 1, -1
- ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(i,NGLLY,k,ispec)
- enddo
- enddo
- else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,1,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(1,NGLLY,1,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
- endif
- endif
- iglob = ibool(1,2,2,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- if (USE_HIGHRES_FOR_MOVIES) then
- ipoin =0
- do k = 1, NGLLZ
- do j = NGLLY, 1, -1
- ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(1,j,k,ispec)
- enddo
- enddo
- else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(1,NGLLY,1,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(1,1,1,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(1,1,NGLLZ,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(1,NGLLY,NGLLZ,ispec)
- endif
- endif
- iglob = ibool(NGLLX,2,2,ispec)
- if (iglob_is_surface_external_mesh(iglob)) then
- nfaces_surface_external_mesh = nfaces_surface_external_mesh + 1
- if (USE_HIGHRES_FOR_MOVIES) then
- ipoin =0
- do k = 1, NGLLZ
- do j = 1, NGLLY
- ipoin = ipoin+1
- faces_surface_external_mesh(ipoin,nfaces_surface_external_mesh) = ibool(NGLLX,j,k,ispec)
- enddo
- enddo
- else
- faces_surface_external_mesh(1,nfaces_surface_external_mesh) = ibool(NGLLX,1,1,ispec)
- faces_surface_external_mesh(2,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,1,ispec)
- faces_surface_external_mesh(3,nfaces_surface_external_mesh) = ibool(NGLLX,NGLLY,NGLLZ,ispec)
- faces_surface_external_mesh(4,nfaces_surface_external_mesh) = ibool(NGLLX,1,NGLLZ,ispec)
- endif
- endif
-
- endif
- enddo ! NSPEC_AB
-
- if (myrank == 0) then
- print *, nfaces_perproc_surface_ext_mesh
- print *, nfaces_surface_glob_ext_mesh
- endif
-
- endif ! EXTERNAL_MESH_MOVIE_SURFACE .or. EXTERNAL_MESH_CREATE_SHAKEMAP
-
- endif ! .not. RECVS_CAN_BE_BURIED_EXT_MESH
-
-!!!! 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
-
-! $$$$$$$$$$$$$$$$$$$$$$$$ SOURCES $$$$$$$$$$$$$$$$$
-
-! read topography and bathymetry file
- if(TOPOGRAPHY .or. 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
-
-
-
-! write source and receiver VTK files for Paraview
- if (myrank == 0) then
- 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'
- ! LQY -- cannot figure out NSOURCES+nrec at this point
- write(IOVTK, '(a,i6,a)') 'POINTS ', 2, ' float'
- endif
-
-! 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
- call locate_source(ibool,NSOURCES,myrank,NSPEC_AB,NGLOB_AB, &
- xstore,ystore,zstore,xigll,yigll,zigll,NPROC, &
- sec,t_cmt,yr,jda,ho,mi,utm_x_source,utm_y_source, &
- NSTEP,DT,hdur,Mxx,Myy,Mzz,Mxy,Mxz,Myz, &
- islice_selected_source,ispec_selected_source, &
- xi_source,eta_source,gamma_source, &
- TOPOGRAPHY,UTM_PROJECTION_ZONE, &
- PRINT_SOURCE_TIME_FUNCTION, &
- nu_source,iglob_is_surface_external_mesh,ispec_is_surface_external_mesh)
-
- 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)
-
-!$$$$$$$$$$$$$$$$$$ RECEIVERS $$$$$$$$$$$$$$$$$$$$$
-
- if (SIMULATION_TYPE == 1) then
- call get_value_string(rec_filename, 'solver.STATIONS', 'DATA/STATIONS')
-
-! 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')
-
- 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(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,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), &
- TOPOGRAPHY,UTM_PROJECTION_ZONE, &
- iglob_is_surface_external_mesh,ispec_is_surface_external_mesh &
-)
-
-
-!###################### SOURCE ARRAYS ################
-
- 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
- call compute_arrays_source(ispec_selected_source(isource), &
- 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)
- sourcearrays(isource,:,:,:,:) = sourcearray(:,:,:,:)
- endif
- enddo
- endif
-
- if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
- nadj_rec_local = 0
- do irec = 1,nrec
- if(myrank == islice_selected_rec(irec))then
-! check 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')
- nadj_rec_local = nadj_rec_local + 1
- endif
- enddo
- allocate(adj_sourcearray(NSTEP,NDIM,NGLLX,NGLLY,NGLLZ))
- if (nadj_rec_local > 0) allocate(adj_sourcearrays(nadj_rec_local,NSTEP,NDIM,NGLLX,NGLLY,NGLLZ))
- irec_local = 0
- do irec = 1, nrec
-! compute only adjoint source arrays in the local slice
- if(myrank == islice_selected_rec(irec)) then
- irec_local = irec_local + 1
- 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
- endif
-
-!--- select local receivers
-
-! 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
- nrec_simulation = NSOURCES
- do isource = 1, NSOURCES
- if(myrank == islice_selected_source(isource)) nrec_local = nrec_local + 1
- enddo
- endif
-
- 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
-
- close(IOVTK)
-
- 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(nrec_tot_found /= nrec_simulation) then
- call exit_MPI(myrank,'problem when dispatching the receivers')
- else
- write(IMAIN,*) 'this total is okay'
- endif
- endif
-
- if(myrank == 0) then
-
- if(NSOURCES > 1) write(IMAIN,*) 'Using ',NSOURCES,' point sources'
-
- write(IMAIN,*)
- if(TOPOGRAPHY) then
- write(IMAIN,*) 'incorporating surface topography'
- else
- write(IMAIN,*) 'no surface topography'
- 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(OCEANS) then
- write(IMAIN,*) 'incorporating the oceans using equivalent load'
- else
- write(IMAIN,*) 'no oceans'
- endif
-
- 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()
-
-! the mass matrix needs to be assembled with MPI here once and for all
- call assemble_MPI_scalar_ext_mesh(NPROC,NGLOB_AB,rmass, &
- buffer_send_scalar_ext_mesh,buffer_recv_scalar_ext_mesh, &
- ninterfaces_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)
-
- if(myrank == 0) write(IMAIN,*) 'end assembling MPI mass matrix'
-
-! check that mass matrix is positive
- if(minval(rmass(:)) <= 0.) call exit_MPI(myrank,'negative mass matrix term')
- if(OCEANS .and. minval(rmass_ocean_load(:)) <= 0.) &
- call exit_MPI(myrank,'negative ocean load mass matrix term')
-
-! for efficiency, invert final mass matrix once and for all in each slice
- if(OCEANS) rmass_ocean_load(:) = 1. / rmass_ocean_load(:)
- rmass(:) = 1.0 / rmass(:)
-
-! 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
-
-!pll
-! do ispec = 1,NSPEC_AB
-! if(not_fully_in_bedrock(ispec)) then
-! do k=1,NGLLZ
-! do j=1,NGLLY
-! do i=1,NGLLX
-!
-!! distinguish attenuation factors
-! if(flag_sediments(i,j,k,ispec)) then
-!
-!! use constant attenuation of Q = 90
-!! or 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)
-!! 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
-!
-! else
-! iattenuation_sediments = IATTENUATION_SEDIMENTS_90
-! endif
-!
-! scale_factor = factor_scale(iattenuation_sediments)
-! else
-! scale_factor = factor_scale(IATTENUATION_BEDROCK)
-! endif
-!
-! mustore(i,j,k,ispec) = mustore(i,j,k,ispec) * scale_factor
-!
-! enddo
-! enddo
-! enddo
-! endif
-! enddo
-
- !pll
- do ispec = 1,NSPEC_AB
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- scale_factor = factor_scale(iflag_attenuation_store(i,j,k,ispec))
- mustore(i,j,k,ispec) = mustore(i,j,k,ispec) * scale_factor
- enddo
- enddo
- enddo
- enddo
-
- endif
-
-! allocate seismogram array
- if (nrec_local > 0) then
- 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
- if (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
- endif
-
-! initialize arrays to zero
- 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
-
-!! DK DK array not created yet for CUBIT
-! if (SIMULATION_TYPE == 3) then ! kernel calculation, read in last frame
-
-! open(unit=27,file=trim(prname)//'save_forward_arrays.bin',status='old',action='read',form='unformatted')
-! read(27) b_displ
-! read(27) b_veloc
-! read(27) b_accel
-
-! rho_kl(:,:,:,:) = 0._CUSTOM_REAL
-! mu_kl(:,:,:,:) = 0._CUSTOM_REAL
-! kappa_kl(:,:,:,:) = 0._CUSTOM_REAL
-
-! endif
-
-! allocate files to save movies and shaking map
- if(MOVIE_SURFACE .or. CREATE_SHAKEMAP) then
- if (USE_HIGHRES_FOR_MOVIES) then
- nmovie_points = NGLLX * NGLLY * NSPEC2D_TOP
- else
- nmovie_points = NGNOD2D * NSPEC2D_TOP
- 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
- allocate(store_val_x(nmovie_points))
- allocate(store_val_y(nmovie_points))
- allocate(store_val_z(nmovie_points))
- allocate(store_val_ux(nmovie_points))
- allocate(store_val_uy(nmovie_points))
- allocate(store_val_uz(nmovie_points))
- allocate(store_val_norm_displ(nmovie_points))
- allocate(store_val_norm_veloc(nmovie_points))
- allocate(store_val_norm_accel(nmovie_points))
-
- allocate(store_val_x_all(nmovie_points,0:NPROC-1))
- allocate(store_val_y_all(nmovie_points,0:NPROC-1))
- allocate(store_val_z_all(nmovie_points,0:NPROC-1))
- allocate(store_val_ux_all(nmovie_points,0:NPROC-1))
- allocate(store_val_uy_all(nmovie_points,0:NPROC-1))
- allocate(store_val_uz_all(nmovie_points,0:NPROC-1))
-
-! to compute max of norm for shaking map
- store_val_norm_displ(:) = -1.
- store_val_norm_veloc(:) = -1.
- store_val_norm_accel(:) = -1.
- else if (MOVIE_VOLUME) 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))
- endif
-
- 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
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- deltat = sngl(DT)
- else
- deltat = DT
- endif
- deltatover2 = deltat/2.
- deltatsqover2 = deltat*deltat/2.
- if (SIMULATION_TYPE == 3) then
- if(CUSTOM_REAL == SIZE_REAL) then
- b_deltat = - sngl(DT)
- else
- b_deltat = - DT
- endif
- b_deltatover2 = b_deltat/2.
- b_deltatsqover2 = b_deltat*b_deltat/2.
- endif
-
-! precompute Runge-Kutta coefficients if attenuation
- if(ATTENUATION) then
- tauinv(:,:) = - 1. / tau_sigma(:,:)
- factor_common(:,:) = 2. * beta(:,:) * tauinv(:,:)
- alphaval(:,:) = 1 + deltat*tauinv(:,:) + deltat**2*tauinv(:,:)**2 / 2. + &
- deltat**3*tauinv(:,:)**3 / 6. + deltat**4*tauinv(:,:)**4 / 24.
- betaval(:,:) = deltat / 2. + deltat**2*tauinv(:,:) / 3. + deltat**3*tauinv(:,:)**2 / 8. + deltat**4*tauinv(:,:)**3 / 24.
- gammaval(:,:) = deltat / 2. + deltat**2*tauinv(:,:) / 6. + deltat**3*tauinv(:,:)**2 / 24.
- if (SIMULATION_TYPE == 3) then
- b_alphaval(:,:) = 1 + b_deltat*tauinv(:,:) + b_deltat**2*tauinv(:,:)**2 / 2. + &
- b_deltat**3*tauinv(:,:)**3 / 6. + b_deltat**4*tauinv(:,:)**4 / 24.
- b_betaval(:,:) = b_deltat / 2. + b_deltat**2*tauinv(:,:) / 3. + &
- b_deltat**3*tauinv(:,:)**2 / 8. + b_deltat**4*tauinv(:,:)**3 / 24.
- b_gammaval(:,:) = b_deltat / 2. + b_deltat**2*tauinv(:,:) / 6. + &
- b_deltat**3*tauinv(:,:)**2 / 24.
- endif
- endif
-
-
- !pll, to put elsewhere
- 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
-
-!! DK DK array not created yet for CUBIT
-! if (SIMULATION_TYPE == 3) 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
-
- endif
- close(27)
-
-! initialize Moho boundary index
-! if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
-! ispec2D_moho_top = 0
-! ispec2D_moho_bot = 0
-! k_top = 1
-! k_bot = NGLLZ
-! 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 MPI_REDUCE(NSPEC_AB,NSPEC_AB_global_min,1,MPI_INTEGER,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call MPI_REDUCE(NSPEC_AB,NSPEC_AB_global_max,1,MPI_INTEGER,MPI_MAX,0,MPI_COMM_WORLD,ier)
- call MPI_REDUCE(NSPEC_AB,NSPEC_AB_global_sum,1,MPI_INTEGER,MPI_SUM,0,MPI_COMM_WORLD,ier)
-
- call MPI_REDUCE(NGLOB_AB,NGLOB_AB_global_min,1,MPI_INTEGER,MPI_MIN,0,MPI_COMM_WORLD,ier)
- call MPI_REDUCE(NGLOB_AB,NGLOB_AB_global_max,1,MPI_INTEGER,MPI_MAX,0,MPI_COMM_WORLD,ier)
-
- if(myrank == 0) then
- 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,*)
- write(IMAIN,*) 'NGLOB_AB_global_min = ',NGLOB_AB_global_min
- write(IMAIN,*) 'NGLOB_AB_global_max = ',NGLOB_AB_global_max
- write(IMAIN,*)
- endif
-
-
-
-
-!
-! 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
-
-
-!check stability
- do i=1,3
- Usolidnorm = maxval(abs(displ(i,:)))
- Usolidnorm_index = maxloc(abs(displ(i,:)))
- if(Usolidnorm > 1.e+15 ) then
- print*,' stability issue:',myrank
- print*,' norm: ',Usolidnorm,displ(i,Usolidnorm_index(1)),i
- print*,' index: ',Usolidnorm_index(1)
- print*,' x/y/z: ',xstore(Usolidnorm_index(1)),ystore(Usolidnorm_index(1)),zstore(Usolidnorm_index(1))
- print*,' time step: ',it
- call exit_MPI(myrank,'forward simulation became unstable and blew up')
- endif
- enddo
-
-! compute 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
- if(mod(it,NTSTEP_BETWEEN_OUTPUT_INFO) == 0 .or. it == 5) then
-
-! compute maximum of norm of displacement in each slice
- Usolidnorm = maxval(sqrt(displ(1,:)**2 + displ(2,:)**2 + displ(3,:)**2))
-
-! compute the maximum of the maxima for all the slices using an MPI reduction
- call max_all_cr(Usolidnorm,Usolidnorm_all)
-
-!! DK DK array not created yet for CUBIT
-! if (SIMULATION_TYPE == 3) then
-! b_Usolidnorm = maxval(sqrt(b_displ(1,:)**2 + b_displ(2,:)**2 + b_displ(3,:)**2))
-! call max_all_cr(b_Usolidnorm,b_Usolidnorm_all)
-! endif
-
- 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)
- write(IMAIN,*) 'Max norm displacement vector U in all slices (m) = ',Usolidnorm_all
-! if (SIMULATION_TYPE == 3) write(IMAIN,*) &
-! 'Max norm displacement vector U (backward) in all slices (m) = ',b_Usolidnorm_all
- 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
-! if (SIMULATION_TYPE == 3) write(IOUT,*) &
-! 'Max norm displacement vector U (backward) in all slices (m) = ',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')
-! 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
- endif
-
-
-
-
-
-! update displacement using finite difference time scheme
- displ(:,:) = displ(:,:) + deltat*veloc(:,:) + deltatsqover2*accel(:,:)
- veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
- accel(:,:) = 0._CUSTOM_REAL
-
-!! DK DK array not created yet for CUBIT
-! if (SIMULATION_TYPE == 3) 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
-
-! if (SAVE_MOHO_MESH .and. SIMULATION_TYPE == 3) then
-! ispec2D_moho_top = 0
-! ispec2D_moho_bot = 0
-! endif
-
-! assemble all the contributions between slices using MPI
-
-
- if(USE_DEVILLE_PRODUCTS) then
- call compute_forces_with_Deville(NSPEC_AB,NGLOB_AB,ATTENUATION,displ,accel,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh,.false., &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,xi_source,eta_source,gamma_source,nu_source, &
- hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
- one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,R_xx,R_yy,R_xy,R_xz,R_yz, &
- epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz,iflag_attenuation_store,ABSORBING_CONDITIONS, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom, &
- nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
- veloc,rho_vp,rho_vs,jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom, &
- normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom)
- else
- call compute_forces_no_Deville(NSPEC_AB,NGLOB_AB,displ,accel,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh,.false., &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,xi_source,eta_source,gamma_source,nu_source,hdur,dt)
- endif
-
- call assemble_MPI_vector_ext_mesh_s(NPROC,NGLOB_AB,accel, &
- buffer_send_vector_ext_mesh,buffer_recv_vector_ext_mesh, &
- ninterfaces_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)
-
- if(USE_DEVILLE_PRODUCTS) then
- call compute_forces_with_Deville(NSPEC_AB,NGLOB_AB,ATTENUATION,displ,accel,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_xxT,hprimewgll_xx,hprimewgll_xxT,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh,.true., &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,xi_source,eta_source,gamma_source,nu_source, &
- hdur,hdur_gaussian,t_cmt,dt,stf,t0,sourcearrays, &
- one_minus_sum_beta,factor_common,alphaval,betaval,gammaval,R_xx,R_yy,R_xy,R_xz,R_yz, &
- epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz,iflag_attenuation_store,ABSORBING_CONDITIONS, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,NSPEC2D_BOTTOM,NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom, &
- nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
- veloc,rho_vp,rho_vs,jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom, &
- normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom)
- else
- call compute_forces_no_Deville(NSPEC_AB,NGLOB_AB,displ,accel,xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz, &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz,wgllwgll_xy,wgllwgll_xz,wgllwgll_yz, &
- kappastore,mustore,jacobian,ibool,ispec_is_inner_ext_mesh,.true., &
- NSOURCES,myrank,it,islice_selected_source,ispec_selected_source,xi_source,eta_source,gamma_source,nu_source,hdur,dt)
- endif
-
- call assemble_MPI_vector_ext_mesh_w(NPROC,NGLOB_AB,accel, &
- buffer_recv_vector_ext_mesh,ninterfaces_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)
-
-!! 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.
-! if (SIMULATION_TYPE == 3) call assemble_MPI_vector(b_accel,iproc_xi,iproc_eta,addressing, &
-! iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta, &
-! buffer_send_faces_vector,buffer_received_faces_vector,npoin2D_xi,npoin2D_eta, &
-! NPROC_XI,NPROC_ETA,NPOIN2DMAX_XMIN_XMAX,NPOIN2DMAX_YMIN_YMAX,NPOIN2DMAX_XY)
-
-! multiply by the inverse of the mass matrix
- accel(1,:) = accel(1,:)*rmass(:)
- accel(2,:) = accel(2,:)*rmass(:)
- accel(3,:) = accel(3,:)*rmass(:)
-
-!! DK DK array not created yet for CUBIT
-! 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
-
- if(OCEANS) then
-
- stop 'DK DK oceans have been removed for now because we need a flag to detect the surface elements'
-
-! initialize the updates
- updated_dof_ocean_load(:) = .false.
-
-! for surface elements exactly at the top of the model (ocean bottom)
- do ispec2D = 1,NSPEC2D_TOP
-
-!! DK DK array not created yet for CUBIT ispec = ibelm_top(ispec2D)
-
-! only for DOFs exactly at the top of the model (ocean bottom)
- k = NGLLZ
-
- do j = 1,NGLLY
- do i = 1,NGLLX
-
-! get global point number
- iglob = ibool(i,j,k,ispec)
-
-! only update once
- if(.not. updated_dof_ocean_load(iglob)) then
-
-! get normal
-!! DK DK array not created yet for CUBIT nx = normal_top(1,i,j,ispec2D)
-!! DK DK array not created yet for CUBIT ny = normal_top(2,i,j,ispec2D)
-!! DK DK array not created yet for CUBIT nz = normal_top(3,i,j,ispec2D)
-
-! 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
-
- if (SIMULATION_TYPE == 3) then
-!! DK DK array not created yet for CUBIT
-! 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
-
-!! DK DK array not created yet for CUBIT
-! 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
-
-! done with this point
- updated_dof_ocean_load(iglob) = .true.
-
- endif
-
- enddo
- enddo
- enddo
- endif
-
- veloc(:,:) = veloc(:,:) + deltatover2*accel(:,:)
-
-!! DK DK array not created yet for CUBIT
-! if (SIMULATION_TYPE == 3) b_veloc(:,:) = b_veloc(:,:) + b_deltatover2*b_accel(:,:)
-
-! write the seismograms with time shift
- if (nrec_local > 0) then
- do irec_local = 1,nrec_local
-
-! get global number of that receiver
- irec = number_receiver_global(irec_local)
-
-! perform the general interpolation using Lagrange polynomials
- if(FASTER_RECEIVERS_POINTS_ONLY) then
-
- iglob = ibool(nint(xi_receiver(irec)),nint(eta_receiver(irec)), &
- nint(gamma_receiver(irec)),ispec_selected_rec(irec))
- dxd = dble(displ(1,iglob))
- dyd = dble(displ(2,iglob))
- dzd = dble(displ(3,iglob))
- vxd = dble(veloc(1,iglob))
- vyd = dble(veloc(2,iglob))
- vzd = dble(veloc(3,iglob))
- axd = dble(accel(1,iglob))
- ayd = dble(accel(2,iglob))
- azd = dble(accel(3,iglob))
-
- else
-
- dxd = ZERO
- dyd = ZERO
- dzd = ZERO
-
- vxd = ZERO
- vyd = ZERO
- vzd = ZERO
-
- axd = ZERO
- ayd = ZERO
- azd = ZERO
-
- if (SIMULATION_TYPE == 1) then
-
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
-! receivers are always located at the surface of the mesh
- iglob = ibool(i,j,k,ispec_selected_rec(irec))
-
- hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
-
-
-! save displacement
- dxd = dxd + dble(displ(1,iglob))*hlagrange
- dyd = dyd + dble(displ(2,iglob))*hlagrange
- dzd = dzd + dble(displ(3,iglob))*hlagrange
-
-! save velocity
- vxd = vxd + dble(veloc(1,iglob))*hlagrange
- vyd = vyd + dble(veloc(2,iglob))*hlagrange
- vzd = vzd + dble(veloc(3,iglob))*hlagrange
-
-! save 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
-
- else if (SIMULATION_TYPE == 2) then
-
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- iglob = ibool(i,j,k,ispec_selected_source(irec))
-
- hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
-
- dxd = dxd + dble(displ(1,iglob))*hlagrange
- dyd = dyd + dble(displ(2,iglob))*hlagrange
- dzd = dzd + dble(displ(3,iglob))*hlagrange
- vxd = vxd + dble(veloc(1,iglob))*hlagrange
- vyd = vyd + dble(veloc(2,iglob))*hlagrange
- vzd = vzd + dble(veloc(3,iglob))*hlagrange
- axd = axd + dble(accel(1,iglob))*hlagrange
- ayd = ayd + dble(accel(2,iglob))*hlagrange
- azd = azd + dble(accel(3,iglob))*hlagrange
-
- displ_s(:,i,j,k) = displ(:,iglob)
-
- enddo
- enddo
- enddo
-
- ispec = ispec_selected_source(irec)
-
- call compute_adj_source_frechet(displ_s,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
-
- else if (SIMULATION_TYPE == 3) then
-
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- iglob = ibool(i,j,k,ispec_selected_rec(irec))
-
- hlagrange = hxir_store(irec_local,i)*hetar_store(irec_local,j)*hgammar_store(irec_local,k)
-
-!! DK DK array not created yet for CUBIT
-! dxd = dxd + dble(b_displ(1,iglob))*hlagrange
-! dyd = dyd + dble(b_displ(2,iglob))*hlagrange
-! dzd = dzd + dble(b_displ(3,iglob))*hlagrange
-! vxd = vxd + dble(b_veloc(1,iglob))*hlagrange
-! vyd = vyd + dble(b_veloc(2,iglob))*hlagrange
-! vzd = vzd + dble(b_veloc(3,iglob))*hlagrange
-! axd = axd + dble(b_accel(1,iglob))*hlagrange
-! ayd = ayd + dble(b_accel(2,iglob))*hlagrange
-! azd = azd + dble(b_accel(3,iglob))*hlagrange
- enddo
- enddo
- enddo
- endif
-
- endif ! end of if(FASTER_RECEIVERS_POINTS_ONLY)
-
-! 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
-
- if (SIMULATION_TYPE == 2) seismograms_eps(:,:,irec_local,it) = eps_s(:,:)
-
- enddo
-
-! 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(myrank,seismograms_d,number_receiver_global,station_name, &
- network_name,nrec,nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,1)
- call write_seismograms(myrank,seismograms_v,number_receiver_global,station_name, &
- network_name,nrec,nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,2)
- call write_seismograms(myrank,seismograms_a,number_receiver_global,station_name, &
- network_name,nrec,nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,3)
- else
- call write_adj_seismograms(myrank,seismograms_d,number_receiver_global, &
- nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,1)
- endif
- endif
-
- endif ! nrec_local
-
-! resetting d/v/a/R/eps for the backward reconstruction with attenuation
- if (ATTENUATION .and. it > 1 .and. it < NSTEP) then
- if (SIMULATION_TYPE == 3 .and. mod(NSTEP-it,NSTEP_Q_SAVE) == 0) then
- 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')
-!! DK DK array not created yet for CUBIT
-! 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
- close(27)
- else if (SIMULATION_TYPE == 1 .and. SAVE_FORWARD .and. mod(it,NSTEP_Q_SAVE) == 0) then
- write(outputname,"('save_Q_arrays_',i6.6,'.bin')") it
- open(unit=27,file=trim(prname_Q)//trim(outputname),status='unknown',action='write',form='unformatted')
- 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
- close(27)
- endif
- endif
-
- if (EXTERNAL_MESH_CREATE_SHAKEMAP) then
- if (it == 1) then
-
- store_val_ux_external_mesh(:) = -HUGEVAL
- store_val_uy_external_mesh(:) = -HUGEVAL
- store_val_uz_external_mesh(:) = -HUGEVAL
- do ispec = 1,nfaces_surface_external_mesh
- if (USE_HIGHRES_FOR_MOVIES) then
- do ipoin = 1, NGLLX*NGLLY
- store_val_x_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = xstore(faces_surface_external_mesh(ipoin,ispec))
- store_val_y_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = ystore(faces_surface_external_mesh(ipoin,ispec))
- store_val_z_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = zstore(faces_surface_external_mesh(ipoin,ispec))
- enddo
- else
- store_val_x_external_mesh(NGNOD2D*(ispec-1)+1) = xstore(faces_surface_external_mesh(1,ispec))
- store_val_x_external_mesh(NGNOD2D*(ispec-1)+2) = xstore(faces_surface_external_mesh(2,ispec))
- store_val_x_external_mesh(NGNOD2D*(ispec-1)+3) = xstore(faces_surface_external_mesh(3,ispec))
- store_val_x_external_mesh(NGNOD2D*(ispec-1)+4) = xstore(faces_surface_external_mesh(4,ispec))
- store_val_y_external_mesh(NGNOD2D*(ispec-1)+1) = ystore(faces_surface_external_mesh(1,ispec))
- store_val_y_external_mesh(NGNOD2D*(ispec-1)+2) = ystore(faces_surface_external_mesh(2,ispec))
- store_val_y_external_mesh(NGNOD2D*(ispec-1)+3) = ystore(faces_surface_external_mesh(3,ispec))
- store_val_y_external_mesh(NGNOD2D*(ispec-1)+4) = ystore(faces_surface_external_mesh(4,ispec))
- store_val_z_external_mesh(NGNOD2D*(ispec-1)+1) = zstore(faces_surface_external_mesh(1,ispec))
- store_val_z_external_mesh(NGNOD2D*(ispec-1)+2) = zstore(faces_surface_external_mesh(2,ispec))
- store_val_z_external_mesh(NGNOD2D*(ispec-1)+3) = zstore(faces_surface_external_mesh(3,ispec))
- store_val_z_external_mesh(NGNOD2D*(ispec-1)+4) = zstore(faces_surface_external_mesh(4,ispec))
- endif
- enddo
- endif
-
- do ispec = 1,nfaces_surface_external_mesh
- if (USE_HIGHRES_FOR_MOVIES) then
- do ipoin = 1, NGLLX*NGLLY
- store_val_ux_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = &
- max(store_val_ux_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin), &
- sqrt(displ(1,faces_surface_external_mesh(ipoin,ispec))**2 + &
- displ(2,faces_surface_external_mesh(ipoin,ispec))**2 + &
- displ(3,faces_surface_external_mesh(ipoin,ispec))**2))
- store_val_uy_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = &
- max(store_val_uy_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin), &
- sqrt(veloc(1,faces_surface_external_mesh(ipoin,ispec))**2 + &
- veloc(2,faces_surface_external_mesh(ipoin,ispec))**2 + &
- veloc(3,faces_surface_external_mesh(ipoin,ispec))**2))
- store_val_uz_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = &
- max(store_val_uz_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin), &
- sqrt(accel(1,faces_surface_external_mesh(ipoin,ispec))**2 + &
- accel(2,faces_surface_external_mesh(ipoin,ispec))**2 + &
- accel(3,faces_surface_external_mesh(ipoin,ispec))**2))
-
- enddo
- else
- store_val_ux_external_mesh(NGNOD2D*(ispec-1)+1) = &
- max(store_val_ux_external_mesh(NGNOD2D*(ispec-1)+1), &
- sqrt(displ(1,faces_surface_external_mesh(1,ispec))**2 + &
- displ(2,faces_surface_external_mesh(1,ispec))**2 + &
- displ(3,faces_surface_external_mesh(1,ispec))**2))
- store_val_ux_external_mesh(NGNOD2D*(ispec-1)+2) = &
- max(store_val_ux_external_mesh(NGNOD2D*(ispec-1)+2), &
- sqrt(displ(1,faces_surface_external_mesh(2,ispec))**2 + &
- displ(2,faces_surface_external_mesh(2,ispec))**2 + &
- displ(3,faces_surface_external_mesh(2,ispec))**2))
- store_val_ux_external_mesh(NGNOD2D*(ispec-1)+3) = &
- max(store_val_ux_external_mesh(NGNOD2D*(ispec-1)+3), &
- sqrt(displ(1,faces_surface_external_mesh(3,ispec))**2 + &
- displ(2,faces_surface_external_mesh(3,ispec))**2 + &
- displ(3,faces_surface_external_mesh(3,ispec))**2))
- store_val_ux_external_mesh(NGNOD2D*(ispec-1)+4) = &
- max(store_val_ux_external_mesh(NGNOD2D*(ispec-1)+4), &
- sqrt(displ(1,faces_surface_external_mesh(4,ispec))**2 + &
- displ(2,faces_surface_external_mesh(4,ispec))**2 + &
- displ(3,faces_surface_external_mesh(4,ispec))**2))
- store_val_uy_external_mesh(NGNOD2D*(ispec-1)+1) = &
- max(store_val_uy_external_mesh(NGNOD2D*(ispec-1)+1), &
- sqrt(veloc(1,faces_surface_external_mesh(1,ispec))**2 + &
- veloc(2,faces_surface_external_mesh(1,ispec))**2 + &
- veloc(3,faces_surface_external_mesh(1,ispec))**2))
- store_val_uy_external_mesh(NGNOD2D*(ispec-1)+2) = &
- max(store_val_uy_external_mesh(NGNOD2D*(ispec-1)+2), &
- sqrt(veloc(1,faces_surface_external_mesh(2,ispec))**2 + &
- veloc(2,faces_surface_external_mesh(2,ispec))**2 + &
- veloc(3,faces_surface_external_mesh(2,ispec))**2))
- store_val_uy_external_mesh(NGNOD2D*(ispec-1)+3) = &
- max(store_val_uy_external_mesh(NGNOD2D*(ispec-1)+3), &
- sqrt(veloc(1,faces_surface_external_mesh(3,ispec))**2 + &
- veloc(2,faces_surface_external_mesh(3,ispec))**2 + &
- veloc(3,faces_surface_external_mesh(3,ispec))**2))
- store_val_uy_external_mesh(NGNOD2D*(ispec-1)+4) = &
- max(store_val_uy_external_mesh(NGNOD2D*(ispec-1)+4), &
- sqrt(veloc(1,faces_surface_external_mesh(4,ispec))**2 + &
- veloc(2,faces_surface_external_mesh(4,ispec))**2 + &
- veloc(3,faces_surface_external_mesh(4,ispec))**2))
- store_val_uz_external_mesh(NGNOD2D*(ispec-1)+1) = &
- max(store_val_uz_external_mesh(NGNOD2D*(ispec-1)+1), &
- sqrt(accel(1,faces_surface_external_mesh(1,ispec))**2 + &
- accel(2,faces_surface_external_mesh(1,ispec))**2 + &
- accel(3,faces_surface_external_mesh(1,ispec))**2))
- store_val_uz_external_mesh(NGNOD2D*(ispec-1)+2) = &
- max(store_val_uz_external_mesh(NGNOD2D*(ispec-1)+2), &
- sqrt(accel(1,faces_surface_external_mesh(2,ispec))**2 + &
- accel(2,faces_surface_external_mesh(2,ispec))**2 + &
- accel(3,faces_surface_external_mesh(2,ispec))**2))
- store_val_uz_external_mesh(NGNOD2D*(ispec-1)+3) = &
- max(store_val_uz_external_mesh(NGNOD2D*(ispec-1)+3), &
- sqrt(accel(1,faces_surface_external_mesh(3,ispec))**2 + &
- accel(2,faces_surface_external_mesh(3,ispec))**2 + &
- accel(3,faces_surface_external_mesh(3,ispec))**2))
- store_val_uz_external_mesh(NGNOD2D*(ispec-1)+4) = &
- max(store_val_uz_external_mesh(NGNOD2D*(ispec-1)+4), &
- sqrt(accel(1,faces_surface_external_mesh(4,ispec))**2 + &
- accel(2,faces_surface_external_mesh(4,ispec))**2 + &
- accel(3,faces_surface_external_mesh(4,ispec))**2))
- endif
- enddo
-
- if (it == NSTEP) then
- if (USE_HIGHRES_FOR_MOVIES) then
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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
-
- if(myrank == 0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//'/shakingdata',status='unknown',form='unformatted')
- write(IOUT) store_val_x_all_external_mesh
- write(IOUT) store_val_y_all_external_mesh
- write(IOUT) store_val_z_all_external_mesh
- write(IOUT) store_val_ux_all_external_mesh
- write(IOUT) store_val_uy_all_external_mesh
- write(IOUT) store_val_uz_all_external_mesh
- close(IOUT)
- endif
- endif
-
- endif
-
- if(EXTERNAL_MESH_MOVIE_SURFACE .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
-! get coordinates of surface mesh and surface displacement
- do ispec = 1,nfaces_surface_external_mesh
- if (USE_HIGHRES_FOR_MOVIES) then
- do ipoin = 1, NGLLX*NGLLY
- store_val_x_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = xstore(faces_surface_external_mesh(ipoin,ispec))
- store_val_y_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = ystore(faces_surface_external_mesh(ipoin,ispec))
- store_val_z_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = zstore(faces_surface_external_mesh(ipoin,ispec))
- store_val_ux_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = veloc(1,faces_surface_external_mesh(ipoin,ispec))
- store_val_uy_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = veloc(2,faces_surface_external_mesh(ipoin,ispec))
- store_val_uz_external_mesh(NGLLX*NGLLY*(ispec-1)+ipoin) = veloc(3,faces_surface_external_mesh(ipoin,ispec))
- enddo
- else
- store_val_x_external_mesh(NGNOD2D*(ispec-1)+1) = xstore(faces_surface_external_mesh(1,ispec))
- store_val_x_external_mesh(NGNOD2D*(ispec-1)+2) = xstore(faces_surface_external_mesh(2,ispec))
- store_val_x_external_mesh(NGNOD2D*(ispec-1)+3) = xstore(faces_surface_external_mesh(3,ispec))
- store_val_x_external_mesh(NGNOD2D*(ispec-1)+4) = xstore(faces_surface_external_mesh(4,ispec))
- store_val_y_external_mesh(NGNOD2D*(ispec-1)+1) = ystore(faces_surface_external_mesh(1,ispec))
- store_val_y_external_mesh(NGNOD2D*(ispec-1)+2) = ystore(faces_surface_external_mesh(2,ispec))
- store_val_y_external_mesh(NGNOD2D*(ispec-1)+3) = ystore(faces_surface_external_mesh(3,ispec))
- store_val_y_external_mesh(NGNOD2D*(ispec-1)+4) = ystore(faces_surface_external_mesh(4,ispec))
- store_val_z_external_mesh(NGNOD2D*(ispec-1)+1) = zstore(faces_surface_external_mesh(1,ispec))
- store_val_z_external_mesh(NGNOD2D*(ispec-1)+2) = zstore(faces_surface_external_mesh(2,ispec))
- store_val_z_external_mesh(NGNOD2D*(ispec-1)+3) = zstore(faces_surface_external_mesh(3,ispec))
- store_val_z_external_mesh(NGNOD2D*(ispec-1)+4) = zstore(faces_surface_external_mesh(4,ispec))
- store_val_ux_external_mesh(NGNOD2D*(ispec-1)+1) = veloc(1,faces_surface_external_mesh(1,ispec))
- store_val_ux_external_mesh(NGNOD2D*(ispec-1)+2) = veloc(1,faces_surface_external_mesh(2,ispec))
- store_val_ux_external_mesh(NGNOD2D*(ispec-1)+3) = veloc(1,faces_surface_external_mesh(3,ispec))
- store_val_ux_external_mesh(NGNOD2D*(ispec-1)+4) = veloc(1,faces_surface_external_mesh(4,ispec))
- store_val_uy_external_mesh(NGNOD2D*(ispec-1)+1) = veloc(2,faces_surface_external_mesh(1,ispec))
- store_val_uy_external_mesh(NGNOD2D*(ispec-1)+2) = veloc(2,faces_surface_external_mesh(2,ispec))
- store_val_uy_external_mesh(NGNOD2D*(ispec-1)+3) = veloc(2,faces_surface_external_mesh(3,ispec))
- store_val_uy_external_mesh(NGNOD2D*(ispec-1)+4) = veloc(2,faces_surface_external_mesh(4,ispec))
- store_val_uz_external_mesh(NGNOD2D*(ispec-1)+1) = veloc(3,faces_surface_external_mesh(1,ispec))
- store_val_uz_external_mesh(NGNOD2D*(ispec-1)+2) = veloc(3,faces_surface_external_mesh(2,ispec))
- store_val_uz_external_mesh(NGNOD2D*(ispec-1)+3) = veloc(3,faces_surface_external_mesh(3,ispec))
- store_val_uz_external_mesh(NGNOD2D*(ispec-1)+4) = veloc(3,faces_surface_external_mesh(4,ispec))
- endif
- enddo
-
- if (USE_HIGHRES_FOR_MOVIES) then
- call gatherv_all_cr(store_val_x_external_mesh,nfaces_surface_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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_external_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
-
- 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
- write(IOUT) store_val_y_all_external_mesh
- write(IOUT) store_val_z_all_external_mesh
- write(IOUT) store_val_ux_all_external_mesh
- write(IOUT) store_val_uy_all_external_mesh
- write(IOUT) store_val_uz_all_external_mesh
- close(IOUT)
- endif
- endif
-
-! save MOVIE on the SURFACE
- if(MOVIE_SURFACE .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
-
- stop 'DK DK MOVIE_SURFACE has been removed for now because we need a flag to detect the surface elements'
-
-! get coordinates of surface mesh and surface displacement
- ipoin = 0
-
- k = NGLLZ
- if (USE_HIGHRES_FOR_MOVIES) then
- do ispec2D = 1,NSPEC2D_TOP
-!! DK DK array not created yet for CUBIT ispec = ibelm_top(ispec2D)
- do j = 1,NGLLY
- do i = 1,NGLLX
- ipoin = ipoin + 1
- iglob = ibool(i,j,k,ispec)
- store_val_x(ipoin) = xstore(iglob)
- store_val_y(ipoin) = ystore(iglob)
- store_val_z(ipoin) = zstore(iglob)
- if(SAVE_DISPLACEMENT) then
- store_val_ux(ipoin) = displ(1,iglob)
- store_val_uy(ipoin) = displ(2,iglob)
- store_val_uz(ipoin) = displ(3,iglob)
- else
- store_val_ux(ipoin) = veloc(1,iglob)
- store_val_uy(ipoin) = veloc(2,iglob)
- store_val_uz(ipoin) = veloc(3,iglob)
- endif
- enddo
- enddo
- enddo ! ispec_top
- else
- do ispec2D = 1,NSPEC2D_TOP
-!! DK DK array not created yet for CUBIT ispec = ibelm_top(ispec2D)
- do iloc = 1, NGNOD2D
- ipoin = ipoin + 1
- iglob = ibool(iorderi(iloc),iorderj(iloc),k,ispec)
- store_val_x(ipoin) = xstore(iglob)
- store_val_y(ipoin) = ystore(iglob)
- store_val_z(ipoin) = zstore(iglob)
- if(SAVE_DISPLACEMENT) then
- store_val_ux(ipoin) = displ(1,iglob)
- store_val_uy(ipoin) = displ(2,iglob)
- store_val_uz(ipoin) = displ(3,iglob)
- else
- store_val_ux(ipoin) = veloc(1,iglob)
- store_val_uy(ipoin) = veloc(2,iglob)
- store_val_uz(ipoin) = veloc(3,iglob)
- endif
- enddo
- enddo ! ispec_top
- endif
-
- ispec = nmovie_points
-
- call gather_all_cr(store_val_x,ispec,store_val_x_all,ispec,NPROC)
- call gather_all_cr(store_val_y,ispec,store_val_y_all,ispec,NPROC)
- call gather_all_cr(store_val_z,ispec,store_val_z_all,ispec,NPROC)
- call gather_all_cr(store_val_ux,ispec,store_val_ux_all,ispec,NPROC)
- call gather_all_cr(store_val_uy,ispec,store_val_uy_all,ispec,NPROC)
- call gather_all_cr(store_val_uz,ispec,store_val_uz_all,ispec,NPROC)
-
-! save movie data to disk in home directory
- 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
- write(IOUT) store_val_y_all
- write(IOUT) store_val_z_all
- write(IOUT) store_val_ux_all
- write(IOUT) store_val_uy_all
- write(IOUT) store_val_uz_all
- close(IOUT)
- endif
-
- endif
-
-! compute SHAKING INTENSITY MAP
- if(CREATE_SHAKEMAP) then
-
- stop 'DK DK CREATE_SHAKEMAP has been removed for now because we need a flag to detect the surface elements'
-
- ipoin = 0
- k = NGLLZ
-
-! save all points for high resolution, or only four corners for low resolution
- if(USE_HIGHRES_FOR_MOVIES) then
-
- do ispec2D = 1,NSPEC2D_TOP
-!! DK DK array not created yet for CUBIT ispec = ibelm_top(ispec2D)
-
-! loop on all the points inside the element
- do j = 1,NGLLY
- do i = 1,NGLLX
- ipoin = ipoin + 1
- iglob = ibool(i,j,k,ispec)
- store_val_x(ipoin) = xstore(iglob)
- store_val_y(ipoin) = ystore(iglob)
- store_val_z(ipoin) = zstore(iglob)
- store_val_norm_displ(ipoin) = max(store_val_norm_displ(ipoin),abs(displ(1,iglob)),abs(displ(2,iglob)))
- store_val_norm_veloc(ipoin) = max(store_val_norm_veloc(ipoin),abs(veloc(1,iglob)),abs(veloc(2,iglob)))
- store_val_norm_accel(ipoin) = max(store_val_norm_accel(ipoin),abs(accel(1,iglob)),abs(accel(2,iglob)))
- enddo
- enddo
- enddo
-
- else
- do ispec2D = 1,NSPEC2D_TOP
-!! DK DK array not created yet for CUBIT ispec = ibelm_top(ispec2D)
- do iloc = 1, NGNOD2D
- ipoin = ipoin + 1
- iglob = ibool(iorderi(iloc),iorderj(iloc),k,ispec)
- store_val_x(ipoin) = xstore(iglob)
- store_val_y(ipoin) = ystore(iglob)
- store_val_z(ipoin) = zstore(iglob)
- store_val_norm_displ(ipoin) = max(store_val_norm_displ(ipoin),abs(displ(1,iglob)),abs(displ(2,iglob)))
- store_val_norm_veloc(ipoin) = max(store_val_norm_veloc(ipoin),abs(veloc(1,iglob)),abs(veloc(2,iglob)))
- store_val_norm_accel(ipoin) = max(store_val_norm_accel(ipoin),abs(accel(1,iglob)),abs(accel(2,iglob)))
- enddo
- enddo
- endif
-
-! save shakemap only at the end of the simulation
- if(it == NSTEP) then
- ispec = nmovie_points
- call gather_all_cr(store_val_x,ispec,store_val_x_all,ispec,NPROC)
- call gather_all_cr(store_val_y,ispec,store_val_y_all,ispec,NPROC)
- call gather_all_cr(store_val_z,ispec,store_val_z_all,ispec,NPROC)
- call gather_all_cr(store_val_norm_displ,ispec,store_val_ux_all,ispec,NPROC)
- call gather_all_cr(store_val_norm_veloc,ispec,store_val_uy_all,ispec,NPROC)
- call gather_all_cr(store_val_norm_accel,ispec,store_val_uz_all,ispec,NPROC)
-
-! save movie data to disk in home directory
- if(myrank == 0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//'/shakingdata',status='unknown',form='unformatted')
- write(IOUT) store_val_x_all
- write(IOUT) store_val_y_all
- write(IOUT) store_val_z_all
-! this saves norm of displacement, velocity and acceleration
-! but we use the same ux, uy, uz arrays as for the movies to save memory
- write(IOUT) store_val_ux_all
- write(IOUT) store_val_uy_all
- write(IOUT) store_val_uz_all
- close(IOUT)
- endif
-
- endif
- endif
-
-! save MOVIE in full 3D MESH
- if(MOVIE_VOLUME .and. mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
-
-! save velocity here to avoid static offset on displacement for movies
-
-! save full snapshot data to local disk
-
-! calculate strain div and curl
- do ispec=1,NSPEC_AB
-
- 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
-!!! 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)
- iglob = ibool(i,l,k,ispec)
- tempx2l = tempx2l + veloc(1,iglob)*hp2
- tempy2l = tempy2l + veloc(2,iglob)*hp2
- tempz2l = tempz2l + veloc(3,iglob)*hp2
-!!! 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)
- 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
- div(i,j,k,ispec) = dvxdxl(i,j,k) + dvydyl(i,j,k) + dvzdzl(i,j,k)
- 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)
- enddo
- enddo
- enddo
- enddo
-
- write(outputname,"('div_proc',i6.6,'_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,"('curl_x_proc',i6.6,'_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,"('curl_y_proc',i6.6,'_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,"('curl_z_proc',i6.6,'_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
-
-!
-!---- end of time iteration loop
-!
- enddo ! end of main time loop
-
-! 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')
- write(27) displ
- write(27) veloc
- write(27) accel
- 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)
-
- else if (SIMULATION_TYPE == 3) then
-
- ! rhop, beta, alpha kernels
-! save kernels to binary files
-!! DK DK removed kernels from here because not supported for CUBIT + SCOTCH yet
-
- endif
-
- if(ABSORBING_CONDITIONS .and. (SIMULATION_TYPE == 3 .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- if (nspec2D_xmin > 0) close(31)
- if (nspec2D_xmax > 0) close(32)
- if (nspec2D_ymin > 0) close(33)
- if (nspec2D_ymax > 0) close(34)
- if (NSPEC2D_BOTTOM > 0) close(35)
- endif
-
- if (nrec_local > 0) then
- if (.not. (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3)) then
-! call write_adj_seismograms(myrank,seismograms_d,number_receiver_global, &
-! nrec_local,it,DT,NSTEP,t0,LOCAL_PATH,1)
- call write_adj_seismograms2(myrank,seismograms_eps,number_receiver_global, &
- nrec_local,it,DT,NSTEP,t0,LOCAL_PATH)
- 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 specfem3D
-
-!!!! 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/SPECFEM3D_SESAME/trunk/specfem3D_par.f90
===================================================================
--- seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_SESAME/trunk/specfem3D_par.f90 2009-08-30 00:21:20 UTC (rev 15636)
@@ -0,0 +1,364 @@
+!=====================================================================
+!
+! 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 specfem_par
+
+ implicit none
+
+ include "constants.h"
+
+! include values created by the mesher
+ include "OUTPUT_FILES/values_from_mesher.h"
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+
+
+! 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
+ integer iattenuation
+ double precision scale_factor
+
+ 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
+
+ integer :: NSPEC_ATTENUATION_AB
+ integer, dimension(:,:,:,:),allocatable :: iflag_attenuation_store
+
+! ADJOINT
+ real(kind=CUSTOM_REAL), dimension(NUM_REGIONS_ATTENUATION,N_SLS) :: b_alphaval, b_betaval, b_gammaval
+!! DK DK array not created yet for CUBIT
+! 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
+! ADJOINT
+
+! 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
+
+ integer :: NSPEC2DMAX_XMIN_XMAX_ext,NSPEC2DMAX_YMIN_YMAX_ext
+ integer, dimension(:), allocatable :: ibelm_xmin,ibelm_xmax
+ integer, dimension(:), allocatable :: ibelm_ymin,ibelm_ymax
+ integer, dimension(:), allocatable :: ibelm_bottom
+ integer, dimension(:), allocatable :: ibelm_top
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_xmin,jacobian2D_xmax
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_ymin,jacobian2D_ymax
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_bottom
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_top
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_xmin,normal_xmax
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_ymin,normal_ymax
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_bottom
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_top
+
+!! DK DK array not created yet for CUBIT
+! integer, dimension(NSPEC2D_TOP_VAL) :: ibelm_top
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_TOP_VAL) :: normal_top
+
+!! DK DK array not created yet for CUBIT
+! Moho mesh
+! integer,dimension(NSPEC2D_MOHO_BOUN) :: ibelm_moho_top, ibelm_moho_bot
+! real(CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO_BOUN) :: normal_moho
+! integer :: nspec2D_moho
+
+!! DK DK array not created yet for CUBIT
+! buffers for send and receive between faces of the slices and the chunks
+! real(kind=CUSTOM_REAL), dimension(NDIM,NPOIN2DMAX_XY_VAL) :: buffer_send_faces_vector,buffer_received_faces_vector
+
+! -----------------
+
+! mesh parameters
+ integer, dimension(:,:,:,:), allocatable :: ibool
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ xix,xiy,xiz,etax,etay,etaz,gammax,gammay,gammaz,jacobian
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: xstore,ystore,zstore
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ kappastore,mustore
+
+! flag for sediments
+ logical, dimension(:), allocatable :: not_fully_in_bedrock
+ logical, dimension(:,:,:,:), allocatable :: flag_sediments
+
+! Stacey
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_vp,rho_vs
+
+! local to global mapping
+ integer, dimension(:), allocatable :: idoubling
+
+! mass matrix
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass
+
+! 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
+ logical, dimension(:), allocatable :: updated_dof_ocean_load
+ real(kind=CUSTOM_REAL) additional_term,force_normal_comp
+
+! displacement, velocity, acceleration
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: displ,veloc,accel
+
+ 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
+
+! time scheme
+ real(kind=CUSTOM_REAL) deltat,deltatover2,deltatsqover2
+
+! ADJOINT
+ real(kind=CUSTOM_REAL) b_additional_term,b_force_normal_comp
+!! DK DK array not created yet for CUBIT
+! real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_ADJOINT) :: b_displ, b_veloc, b_accel
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_ADJOINT) :: rho_kl, mu_kl, kappa_kl, &
+! rhop_kl, beta_kl, alpha_kl
+! real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: absorb_xmin, absorb_xmax, &
+! absorb_ymin, absorb_ymax, absorb_zmin ! for absorbing b.c.
+! integer reclen_xmin, reclen_xmax, reclen_ymin, reclen_ymax, reclen_zmin
+
+ real(kind=CUSTOM_REAL) b_deltat, b_deltatover2, b_deltatsqover2
+! ADJOINT
+
+ integer l
+
+! Moho kernel
+! integer ispec2D_moho_top, ispec2D_moho_bot, k_top, k_bot, ispec_top, ispec_bot, iglob_top, iglob_bot
+!! DK DK array not created yet for CUBIT
+! real(kind=CUSTOM_REAL), dimension(NDIM,NDIM,NGLLX,NGLLY,NGLLZ,NSPEC2D_MOHO_BOUN) :: dsdx_top, dsdx_bot, b_dsdx_top, b_dsdx_bot
+! real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_MOHO_BOUN) :: moho_kl
+! real(kind=CUSTOM_REAL) :: kernel_moho_top, kernel_moho_bot
+
+! --------
+
+! parameters for the source
+ integer it,isource
+ integer, dimension(:), allocatable :: islice_selected_source,ispec_selected_source
+ integer yr,jda,ho,mi
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: sourcearray
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: sourcearrays
+ double precision, dimension(:,:,:), allocatable :: nu_source
+!ADJOINT
+ character(len=150) adj_source_file
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: adj_sourcearray
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:,:), allocatable :: adj_sourcearrays
+!ADJOINT
+ double precision sec,stf
+ 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
+
+! receiver information
+ character(len=150) rec_filename,filtered_rec_filename,dummystring
+ integer nrec,nrec_local,nrec_tot_found,irec_local,ios
+ integer, allocatable, dimension(:) :: islice_selected_rec,ispec_selected_rec,number_receiver_global
+ double precision, allocatable, dimension(:) :: xi_receiver,eta_receiver,gamma_receiver
+ double precision hlagrange
+! ADJOINT
+ integer nrec_simulation, nadj_rec_local
+! source frechet derivatives
+ real(kind=CUSTOM_REAL) :: displ_s(NDIM,NGLLX,NGLLY,NGLLZ), eps_s(NDIM,NDIM), eps_m_s(NDIM), stf_deltat
+ 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
+ double precision, dimension(:,:), allocatable :: hpxir_store,hpetar_store,hpgammar_store
+! ADJOINT
+
+! 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
+ double precision dxd,dyd,dzd,vxd,vyd,vzd,axd,ayd,azd
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: seismograms_d,seismograms_v,seismograms_a
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: seismograms_eps
+
+ integer i,j,k,ispec,irec,iglob
+
+! 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
+
+! 2-D addressing and buffers for summation between slices
+! integer, dimension(NPOIN2DMAX_XMIN_XMAX_VAL) :: iboolleft_xi,iboolright_xi
+! integer, dimension(NPOIN2DMAX_YMIN_YMAX_VAL) :: iboolleft_eta,iboolright_eta
+
+! for addressing of the slices
+! integer, dimension(0:NPROC_XI_VAL-1,0:NPROC_ETA_VAL) :: addressing
+
+! proc numbers for MPI
+ integer myrank,sizeprocs
+
+! integer npoin2D_xi,npoin2D_eta
+
+! integer iproc_xi,iproc_eta
+
+! maximum of the norm of the displacement
+ real(kind=CUSTOM_REAL) Usolidnorm,Usolidnorm_all
+ integer:: Usolidnorm_index(1)
+! ADJOINT
+! real(kind=CUSTOM_REAL) b_Usolidnorm, b_Usolidnorm_all
+! ADJOINT
+
+! timer MPI
+ double precision, external :: wtime
+ integer ihours,iminutes,iseconds,int_tCPU
+ double precision time_start,tCPU
+
+! parameters read from parameter file
+ integer NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS,NSTEP,UTM_PROJECTION_ZONE,SIMULATION_TYPE
+ integer NSOURCES
+
+ double precision DT,LATITUDE_MIN,LATITUDE_MAX,LONGITUDE_MIN,LONGITUDE_MAX,HDUR_MOVIE
+
+ logical TOPOGRAPHY,ATTENUATION,USE_OLSEN_ATTENUATION, &
+ OCEANS,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
+ integer NTSTEP_BETWEEN_FRAMES,NTSTEP_BETWEEN_OUTPUT_INFO
+
+ character(len=150) OUTPUT_FILES,LOCAL_PATH,prname,prname_Q
+
+! parameters deduced from parameters read from file
+ integer NPROC
+
+ integer NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC_AB, NGLOB_AB
+
+! names of the data files for all the processors in MPI
+ character(len=150) outputname
+
+! Stacey conditions put back
+ integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax,ispec2D
+ real(kind=CUSTOM_REAL) nx,ny,nz
+ integer, dimension(:,:),allocatable :: nimin,nimax,nkmin_eta
+ integer, dimension(:,:),allocatable :: njmin,njmax,nkmin_xi
+
+! to save movie frames
+ integer ipoin, nmovie_points, iloc, iorderi(NGNOD2D), iorderj(NGNOD2D)
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: &
+ store_val_x,store_val_y,store_val_z, &
+ store_val_ux,store_val_uy,store_val_uz, &
+ store_val_norm_displ,store_val_norm_veloc,store_val_norm_accel
+ real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: &
+ store_val_x_all,store_val_y_all,store_val_z_all, &
+ store_val_ux_all,store_val_uy_all,store_val_uz_all
+
+! to save full 3D snapshot of velocity
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: dvxdxl,dvxdyl,dvxdzl,dvydxl,dvydyl,dvydzl,dvzdxl,dvzdyl,dvzdzl
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:),allocatable:: div, curl_x, curl_y, curl_z
+
+! for assembling in case of external mesh
+ integer :: ninterfaces_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
+ integer, dimension(:), allocatable :: valence_external_mesh
+ logical, dimension(:), allocatable :: iglob_is_surface_external_mesh
+ logical, dimension(:), allocatable :: ispec_is_surface_external_mesh
+ integer, dimension(:,:), allocatable :: buffer_send_scalar_i_ext_mesh
+ integer, dimension(:,:), allocatable :: buffer_recv_scalar_i_ext_mesh
+ integer :: nfaces_surface_external_mesh
+ integer :: nfaces_surface_glob_ext_mesh
+ integer,dimension(:),allocatable :: nfaces_perproc_surface_ext_mesh
+ integer,dimension(:),allocatable :: faces_surface_offset_ext_mesh
+ integer,dimension(:,:),allocatable :: faces_surface_external_mesh
+ 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
+ integer :: ii,jj,kk
+
+! for communications overlapping
+ logical, dimension(:), allocatable :: ispec_is_inner_ext_mesh
+ logical, dimension(:), allocatable :: iglob_is_inner_ext_mesh
+ integer :: iinterface
+
+!!!! 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
+
+!! 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
+ integer :: NSPEC_AB_global_min,NSPEC_AB_global_max,NSPEC_AB_global_sum
+ integer :: NGLOB_AB_global_min,NGLOB_AB_global_max
+ integer :: ier
+
+end module
More information about the CIG-COMMITS
mailing list