[cig-commits] r20176 - in seismo/3D/SPECFEM3D_GLOBE/trunk: . doc/USER_MANUAL src/meshfem3D src/shared src/specfem3D
dkomati1 at geodynamics.org
dkomati1 at geodynamics.org
Sat May 19 09:33:10 PDT 2012
Author: dkomati1
Date: 2012-05-19 09:33:09 -0700 (Sat, 19 May 2012)
New Revision: 20176
Added:
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regions_mesh.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D.f90
Removed:
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regions_mesh.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D.f90
Modified:
seismo/3D/SPECFEM3D_GLOBE/trunk/doc/USER_MANUAL/manual_SPECFEM3D_GLOBE.pdf
seismo/3D/SPECFEM3D_GLOBE/trunk/doc/USER_MANUAL/manual_SPECFEM3D_GLOBE.tex
seismo/3D/SPECFEM3D_GLOBE/trunk/flags.guess
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/Makefile.in
seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/save_header_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/assemble_MPI_vector.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/assemble_MPI_vector_block.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle_Dev.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core_Dev.F90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_outer_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_outer_core_Dev.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/prepare_timerun.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_mesh_databases.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/specfem3D.F90
Log:
more precise definition of the size of some MPI buffers; also made some of these array sizes static.
Also added option -DUSE_SERIAL_CASCADE_FOR_IOs for slow or not very powerful shared file systems.
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/doc/USER_MANUAL/manual_SPECFEM3D_GLOBE.pdf
===================================================================
(Binary files differ)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/doc/USER_MANUAL/manual_SPECFEM3D_GLOBE.tex
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/doc/USER_MANUAL/manual_SPECFEM3D_GLOBE.tex 2012-05-19 14:09:44 UTC (rev 20175)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/doc/USER_MANUAL/manual_SPECFEM3D_GLOBE.tex 2012-05-19 16:33:09 UTC (rev 20176)
@@ -369,6 +369,13 @@
flags can make a tremendous difference in terms of performance. We
welcome feedback on your experience with various compilers and flags.\\
+When using a slow or not too powerful shared disk system or when running extremely large simulations
+(on tens of thousands of processor cores), one can add \texttt{-DUSE\_SERIAL\_CASCADE\_FOR\_IOs} to the compiler flags
+in file \texttt{flags.guess} before running \texttt{configure} to make the mesher output mesh data
+to the disk for one MPI slice after the other, and to make the solver do the same thing when reading the files back from disk.
+Do not use this option if you do not need it because it will slow down the mesher and the beginning of the solver if your
+shared file system is fast and reliable.
+
If you run scaling benchmarks of the code, for instance to measure its performance on a new machine, and are not interested in the physical results
(the seismograms) for these runs, you can set \texttt{DO\_BENCHMARK\_RUN\_ONLY} to \texttt{.true.} in file \texttt{setup/constants.h.in} before running the \texttt{configure} script.
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/flags.guess
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/flags.guess 2012-05-19 14:09:44 UTC (rev 20175)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/flags.guess 2012-05-19 16:33:09 UTC (rev 20176)
@@ -2,6 +2,9 @@
# Attempt to guess suitable flags for the Fortran compiler.
+# can add -DUSE_SERIAL_CASCADE_FOR_IOs to the compiler options to make the mesher output mesh data
+# to the disk for one MPI slice after the other, and to make the solver do the same thing when reading the files back from disk.
+
# Use AC_CANONICAL_BUILD (and package config.guess, etc.) in the future?
if test x"$UNAME_MS" = x; then
UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/Makefile.in
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/Makefile.in 2012-05-19 14:09:44 UTC (rev 20175)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/Makefile.in 2012-05-19 16:33:09 UTC (rev 20176)
@@ -349,8 +349,8 @@
$O/create_mass_matrices.o: ${SETUP}/constants.h $S/create_mass_matrices.f90
${FCCOMPILE_CHECK} -c -o $O/create_mass_matrices.o ${FCFLAGS_f90} $S/create_mass_matrices.f90
-$O/create_regions_mesh.o: ${SETUP}/constants.h $S/create_regions_mesh.f90
- ${MPIFCCOMPILE_CHECK} -c -o $O/create_regions_mesh.o ${FCFLAGS_f90} $S/create_regions_mesh.f90
+$O/create_regions_mesh.o: ${SETUP}/constants.h $S/create_regions_mesh.F90
+ ${MPIFCCOMPILE_CHECK} -c -o $O/create_regions_mesh.o ${FCFLAGS_f90} $S/create_regions_mesh.F90
$O/get_perm_color.o: ${SETUP}/constants.h $S/get_perm_color.f90
${FCCOMPILE_CHECK} -c -o $O/get_perm_color.o ${FCFLAGS_f90} $S/get_perm_color.f90
Copied: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regions_mesh.F90 (from rev 20175, seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regions_mesh.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regions_mesh.F90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regions_mesh.F90 2012-05-19 16:33:09 UTC (rev 20176)
@@ -0,0 +1,1395 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! April 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine create_regions_mesh(iregion_code,ibool,idoubling,is_on_a_slice_edge, &
+ xstore,ystore,zstore,rmins,rmaxs, &
+ iproc_xi,iproc_eta,ichunk,nspec,nspec_tiso, &
+ volume_local,area_local_bottom,area_local_top, &
+ nglob_theor,npointot, &
+ NSTEP,DT, &
+ NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE, &
+ NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
+ myrank,LOCAL_PATH,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,&
+ SAVE_MESH_FILES,NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
+ R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,&
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ ner,ratio_sampling_array,doubling_index,r_bottom,r_top, &
+ this_region_has_a_doubling,ipass,ratio_divide_central_cube, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,offset_proc_xi,offset_proc_eta)
+
+! creates the different regions of the mesh
+
+ use meshfem3D_models_par
+
+ implicit none
+
+!****************************************************************************************************
+! Mila
+
+! include "constants.h"
+! standard include of the MPI library
+ include 'mpif.h'
+
+!****************************************************************************************************
+
+ ! this to cut the doubling brick
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer :: offset_proc_xi,offset_proc_eta
+
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+
+ integer :: ner_without_doubling,ilayer,ilayer_loop, &
+ ifirst_region,ilast_region,ratio_divide_central_cube
+ integer, dimension(:), allocatable :: perm_layer
+
+ ! correct number of spectral elements in each block depending on chunk type
+ integer nspec,nspec_tiso,nspec_stacey,nspec_actually,nspec_att
+
+ integer NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NCHUNKS
+
+ integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP
+
+ integer NPROC_XI,NPROC_ETA
+
+ integer npointot
+
+ logical SAVE_MESH_FILES
+
+ logical INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS
+
+ double precision R_CENTRAL_CUBE,RICB,RCMB,R670,RMOHO, &
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ RMOHO_FICTITIOUS_IN_MESHER
+
+ double precision RHO_OCEANS
+
+ character(len=150) LOCAL_PATH,errmsg
+
+ ! arrays with the mesh in double precision
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+
+ ! meshing parameters
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+
+ ! topology of the elements
+ integer, dimension(NGNOD) :: iaddx,iaddy,iaddz
+
+ ! code for the four regions of the mesh
+ integer iregion_code
+
+ ! Gauss-Lobatto-Legendre points and weights of integration
+ double precision, dimension(:), allocatable :: xigll,yigll,zigll,wxgll,wygll,wzgll
+
+ ! 3D shape functions and their derivatives
+ double precision, dimension(:,:,:,:), allocatable :: shape3D
+ double precision, dimension(:,:,:,:,:), allocatable :: dershape3D
+
+ ! 2D shape functions and their derivatives
+ double precision, dimension(:,:,:), allocatable :: shape2D_x,shape2D_y, &
+ shape2D_bottom,shape2D_top
+ double precision, dimension(:,:,:,:), allocatable :: dershape2D_x,dershape2D_y, &
+ dershape2D_bottom,dershape2D_top
+
+ integer, dimension(nspec) :: idoubling
+
+! this for non blocking MPI
+ logical, dimension(nspec) :: is_on_a_slice_edge
+
+ ! parameters needed to store the radii of the grid points in the spherically symmetric Earth
+ double precision rmin,rmax
+
+ ! for model density and anisotropy
+ integer nspec_ani
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rhostore,dvpstore, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore
+
+ ! the 21 coefficients for an anisotropic medium in reduced notation
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store
+
+ ! boundary locator
+ logical, dimension(:,:), allocatable :: iboun
+
+ ! arrays with mesh parameters
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+
+ ! proc numbers for MPI
+ integer myrank
+
+ ! check area and volume of the final mesh
+ double precision area_local_bottom,area_local_top
+ double precision volume_local
+
+ ! variables for creating array ibool (some arrays also used for AVS or DX files)
+ integer, dimension(:), allocatable :: locval
+ logical, dimension(:), allocatable :: ifseg
+ double precision, dimension(:), allocatable :: xp,yp,zp
+
+ integer nglob,nglob_theor,ieoff,ilocnum,ier
+
+ ! mass matrix
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass
+
+ ! mass matrix and bathymetry for ocean load
+ integer nglob_oceans
+ real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_ocean_load
+
+ ! boundary parameters locator
+ integer, dimension(:), allocatable :: ibelm_xmin,ibelm_xmax, &
+ ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top
+
+ ! 2-D jacobians and normals
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: &
+ jacobian2D_xmin,jacobian2D_xmax, &
+ jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom,jacobian2D_top
+
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
+ normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top
+
+ ! MPI cut-planes parameters along xi and along eta
+ logical, dimension(:,:), allocatable :: iMPIcut_xi,iMPIcut_eta
+
+ ! Stacey, indices for Clayton-Engquist absorbing conditions
+ integer, dimension(:,:), allocatable :: nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_vp,rho_vs
+
+ ! name of the database file
+ character(len=150) prname
+
+ ! number of elements on the boundaries
+ integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
+
+ integer i,j,k,ispec
+ integer iproc_xi,iproc_eta,ichunk
+
+ double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
+
+ ! rotation matrix from Euler angles
+ double precision, dimension(NDIM,NDIM) :: rotation_matrix
+
+ ! attenuation
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: Qmu_store
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: tau_e_store
+ double precision, dimension(N_SLS) :: tau_s
+ double precision T_c_source
+
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ logical :: USE_ONE_LAYER_SB
+
+ integer NUMBER_OF_MESH_LAYERS,layer_shift,cpt, &
+ first_layer_aniso,last_layer_aniso,FIRST_ELT_NON_ANISO
+
+ double precision, dimension(:,:), allocatable :: stretch_tab
+
+ integer :: nb_layer_above_aniso,FIRST_ELT_ABOVE_ANISO
+
+ ! now perform two passes in this part to be able to save memory
+ integer :: ipass
+
+ logical :: ACTUALLY_STORE_ARRAYS
+
+!****************************************************************************************************
+! Mila
+
+! added for color permutation
+ integer :: nb_colors_outer_elements,nb_colors_inner_elements,nspec_outer
+ integer, dimension(:), allocatable :: perm
+ integer, dimension(:), allocatable :: first_elem_number_in_this_color
+ integer, dimension(:), allocatable :: num_of_elems_in_this_color
+
+ integer :: icolor,ispec_counter
+ integer :: nspec_outer_min_global,nspec_outer_max_global
+
+!****************************************************************************************************
+
+!///////////////////////////////////////////////////////////////////////////////
+! Manh Ha - 18-11-2011
+! Adding new variables
+
+ integer :: NSTEP
+ integer, save :: npoin2D_xi,npoin2D_eta
+ double precision :: DT
+
+!///////////////////////////////////////////////////////////////////////////////
+
+ ! Boundary Mesh
+ integer NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho
+ integer, dimension(:), allocatable :: ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot, &
+ ibelm_670_top,ibelm_670_bot
+ real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_moho,normal_400,normal_670
+ real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_moho,jacobian2D_400,jacobian2D_670
+ integer ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot, &
+ ispec2D_670_top,ispec2D_670_bot
+ double precision r_moho,r_400,r_670
+
+ ! flags for transverse isotropic elements
+ logical, dimension(:), allocatable :: ispec_is_tiso
+
+#ifdef USE_SERIAL_CASCADE_FOR_IOs
+ logical :: you_can_start_doing_IOs
+ integer msg_status(MPI_STATUS_SIZE)
+#endif
+
+ ! create the name for the database of the current slide and region
+ call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
+
+ ! New Attenuation definition on all GLL points
+ ! Attenuation
+ if (ATTENUATION) then
+ T_c_source = AM_V%QT_c_source
+ tau_s(:) = AM_V%Qtau_s(:)
+ nspec_att = nspec
+ else
+ nspec_att = 1
+ end if
+ allocate(Qmu_store(NGLLX,NGLLY,NGLLZ,nspec_att), &
+ tau_e_store(N_SLS,NGLLX,NGLLY,NGLLZ,nspec_att),stat=ier)
+ if(ier /= 0) stop 'error in allocate 1'
+
+ ! Gauss-Lobatto-Legendre points of integration
+ allocate(xigll(NGLLX), &
+ yigll(NGLLY), &
+ zigll(NGLLZ),stat=ier)
+ if(ier /= 0) stop 'error in allocate 2'
+
+ ! Gauss-Lobatto-Legendre weights of integration
+ allocate(wxgll(NGLLX), &
+ wygll(NGLLY), &
+ wzgll(NGLLZ),stat=ier)
+ if(ier /= 0) stop 'error in allocate 3'
+
+ ! 3D shape functions and their derivatives
+ allocate(shape3D(NGNOD,NGLLX,NGLLY,NGLLZ), &
+ dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ),stat=ier)
+ if(ier /= 0) stop 'error in allocat 4'
+
+ ! 2D shape functions and their derivatives
+ allocate(shape2D_x(NGNOD2D,NGLLY,NGLLZ), &
+ shape2D_y(NGNOD2D,NGLLX,NGLLZ), &
+ shape2D_bottom(NGNOD2D,NGLLX,NGLLY), &
+ shape2D_top(NGNOD2D,NGLLX,NGLLY), &
+ dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ), &
+ dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ), &
+ dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY), &
+ dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY),stat=ier)
+ if(ier /= 0) stop 'error in allocate 5'
+
+ ! array with model density
+ allocate(rhostore(NGLLX,NGLLY,NGLLZ,nspec), &
+ dvpstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier)
+ if(ier /= 0) stop 'error in allocate 6'
+
+ ! for anisotropy
+ allocate(kappavstore(NGLLX,NGLLY,NGLLZ,nspec), &
+ muvstore(NGLLX,NGLLY,NGLLZ,nspec), &
+ kappahstore(NGLLX,NGLLY,NGLLZ,nspec), &
+ muhstore(NGLLX,NGLLY,NGLLZ,nspec), &
+ eta_anisostore(NGLLX,NGLLY,NGLLZ,nspec), &
+ ispec_is_tiso(nspec),stat=ier)
+ if(ier /= 0) stop 'error in allocate 7'
+
+ ! initializes flags for transverse isotropic elements
+ ispec_is_tiso(:) = .false.
+
+ ! Stacey absorbing boundaries
+ if(NCHUNKS /= 6) then
+ nspec_stacey = nspec
+ else
+ nspec_stacey = 1
+ endif
+ allocate(rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey), &
+ rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey),stat=ier)
+ if(ier /= 0) stop 'error in allocate 8'
+
+ ! anisotropy
+ if((ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) .or. &
+ (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE)) then
+ nspec_ani = nspec
+ else
+ nspec_ani = 1
+ endif
+ allocate(c11store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c12store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c13store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c14store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c15store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c16store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c22store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c23store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c24store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c25store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c26store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c33store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c34store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c35store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c36store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c44store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c45store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c46store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c55store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c56store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
+ c66store(NGLLX,NGLLY,NGLLZ,nspec_ani),stat=ier)
+ if(ier /= 0) stop 'error in allocate 9'
+
+ ! boundary locator
+ allocate(iboun(6,nspec),stat=ier)
+ if(ier /= 0) stop 'error in allocate 10'
+
+ ! boundary parameters locator
+ allocate(ibelm_xmin(NSPEC2DMAX_XMIN_XMAX), &
+ ibelm_xmax(NSPEC2DMAX_XMIN_XMAX), &
+ ibelm_ymin(NSPEC2DMAX_YMIN_YMAX), &
+ ibelm_ymax(NSPEC2DMAX_YMIN_YMAX), &
+ ibelm_bottom(NSPEC2D_BOTTOM), &
+ ibelm_top(NSPEC2D_TOP),stat=ier)
+ if(ier /= 0) stop 'error in allocate 11'
+
+ ! 2-D jacobians and normals
+ allocate(jacobian2D_xmin(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX), &
+ jacobian2D_xmax(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX), &
+ jacobian2D_ymin(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX), &
+ jacobian2D_ymax(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX), &
+ jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM), &
+ jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP),stat=ier)
+ if(ier /= 0) stop 'error in allocate 12'
+
+ allocate(normal_xmin(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX), &
+ normal_xmax(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX), &
+ normal_ymin(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX), &
+ normal_ymax(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX), &
+ normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM), &
+ normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP),stat=ier)
+ if(ier /= 0) stop 'error in allocate 13'
+
+ ! Stacey
+ allocate(nimin(2,NSPEC2DMAX_YMIN_YMAX), &
+ nimax(2,NSPEC2DMAX_YMIN_YMAX), &
+ njmin(2,NSPEC2DMAX_XMIN_XMAX), &
+ njmax(2,NSPEC2DMAX_XMIN_XMAX), &
+ nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX), &
+ nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX),stat=ier)
+ if(ier /= 0) stop 'error in allocate 14'
+
+ ! MPI cut-planes parameters along xi and along eta
+ allocate(iMPIcut_xi(2,nspec), &
+ iMPIcut_eta(2,nspec),stat=ier)
+ if(ier /= 0) stop 'error in allocate 15'
+
+ ! store and save the final arrays only in the second pass
+ ! therefore in the first pass some arrays can be allocated with a dummy size
+ if(ipass == 1) then
+ ACTUALLY_STORE_ARRAYS = .false.
+ nspec_actually = 1
+ else
+ ACTUALLY_STORE_ARRAYS = .true.
+ nspec_actually = nspec
+ endif
+ allocate(xixstore(NGLLX,NGLLY,NGLLZ,nspec_actually), &
+ xiystore(NGLLX,NGLLY,NGLLZ,nspec_actually), &
+ xizstore(NGLLX,NGLLY,NGLLZ,nspec_actually), &
+ etaxstore(NGLLX,NGLLY,NGLLZ,nspec_actually), &
+ etaystore(NGLLX,NGLLY,NGLLZ,nspec_actually), &
+ etazstore(NGLLX,NGLLY,NGLLZ,nspec_actually), &
+ gammaxstore(NGLLX,NGLLY,NGLLZ,nspec_actually), &
+ gammaystore(NGLLX,NGLLY,NGLLZ,nspec_actually), &
+ gammazstore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier)
+ if(ier /= 0) stop 'error in allocate 16'
+
+ ! boundary mesh
+ if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
+ NSPEC2D_MOHO = NSPEC2D_TOP
+ NSPEC2D_400 = NSPEC2D_MOHO / 4
+ NSPEC2D_670 = NSPEC2D_400
+ else
+ NSPEC2D_MOHO = 1
+ NSPEC2D_400 = 1
+ NSPEC2D_670 = 1
+ endif
+ allocate(ibelm_moho_top(NSPEC2D_MOHO),ibelm_moho_bot(NSPEC2D_MOHO), &
+ ibelm_400_top(NSPEC2D_400),ibelm_400_bot(NSPEC2D_400), &
+ ibelm_670_top(NSPEC2D_670),ibelm_670_bot(NSPEC2D_670), &
+ normal_moho(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO), &
+ normal_400(NDIM,NGLLX,NGLLY,NSPEC2D_400), &
+ normal_670(NDIM,NGLLX,NGLLY,NSPEC2D_670), &
+ jacobian2D_moho(NGLLX,NGLLY,NSPEC2D_MOHO), &
+ jacobian2D_400(NGLLX,NGLLY,NSPEC2D_400), &
+ jacobian2D_670(NGLLX,NGLLY,NSPEC2D_670),stat=ier)
+ if(ier /= 0) stop 'error in allocate 17'
+
+ ! initialize number of layers
+ call crm_initialize_layers(myrank,ipass,xigll,yigll,zigll,wxgll,wygll,wzgll, &
+ shape3D,dershape3D,shape2D_x,shape2D_y,shape2D_bottom,shape2D_top, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ iaddx,iaddy,iaddz,nspec,xstore,ystore,zstore,ibool,idoubling, &
+ iboun,iMPIcut_xi,iMPIcut_eta,ispec2D_moho_top,ispec2D_moho_bot, &
+ ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot, &
+ NEX_PER_PROC_ETA,nex_eta_moho,RMOHO,R400,R670,r_moho,r_400,r_670, &
+ ONE_CRUST,NUMBER_OF_MESH_LAYERS,layer_shift, &
+ iregion_code,ifirst_region,ilast_region, &
+ first_layer_aniso,last_layer_aniso,nb_layer_above_aniso,is_on_a_slice_edge)
+
+ ! to consider anisotropic elements first and to build the mesh from the bottom to the top of the region
+ allocate (perm_layer(ifirst_region:ilast_region),stat=ier)
+ if(ier /= 0) stop 'error in allocate 18'
+ perm_layer = (/ (i, i=ilast_region,ifirst_region,-1) /)
+
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+ cpt=3
+ perm_layer(1)=first_layer_aniso
+ perm_layer(2)=last_layer_aniso
+ do i = ilast_region,ifirst_region,-1
+ if (i/=first_layer_aniso .and. i/=last_layer_aniso) then
+ perm_layer(cpt) = i
+ cpt=cpt+1
+ endif
+ enddo
+ endif
+
+ ! crustal layer stretching: element layer's top and bottom radii will get stretched when in crust
+ ! (number of element layers in crust can vary for different resolutions and 1chunk simulations)
+ allocate(stretch_tab(2,ner(1)),stat=ier)
+ if(ier /= 0) stop 'error in allocate 19'
+ if (CASE_3D .and. iregion_code == IREGION_CRUST_MANTLE .and. .not. SUPPRESS_CRUSTAL_MESH) then
+ ! stretching function determines top and bottom of each element layer in the
+ ! crust region (between r_top(1) and r_bottom(1)), where ner(1) is the
+ ! number of element layers in this crust region
+
+ ! differentiate between regional meshes or global meshes
+ if( REGIONAL_MOHO_MESH ) then
+ call stretching_function_regional(r_top(1),r_bottom(1),ner(1),stretch_tab)
+ else
+ call stretching_function(r_top(1),r_bottom(1),ner(1),stretch_tab)
+ endif
+
+ ! RMIDDLE_CRUST so far is only used for 1D - models with two layers in the crust
+ ! (i.e. ONE_CRUST is set to .false.), those models do not use CASE_3D
+
+ ! all 3D models use this stretching function to honor a 3D crustal model
+ ! for those models, we set RMIDDLE_CRUST to the bottom of the first element layer
+ ! this value will be used in moho_stretching.f90 to decide whether or not elements
+ ! have to be stretched under oceanic crust.
+ !
+ ! note: stretch_tab uses (dimensionalized) radii from r_top and r_bottom
+ !(with stretch_tab( index_radius(1=top,2=bottom), index_layer( 1=first layer, 2=second layer, 3= ...) )
+ RMIDDLE_CRUST = stretch_tab(2,1)
+
+ endif
+
+!----
+!---- creates mesh elements
+!----
+
+ ! loop on all the layers in this region of the mesh
+ ispec = 0 ! counts all the elements in this region of the mesh
+ do ilayer_loop = ifirst_region,ilast_region
+
+ ilayer = perm_layer(ilayer_loop)
+
+ ! determine the radii that define the shell
+ rmin = rmins(ilayer)
+ rmax = rmaxs(ilayer)
+
+ if(iregion_code == IREGION_CRUST_MANTLE .and. ilayer_loop==3) then
+ FIRST_ELT_NON_ANISO = ispec+1
+ endif
+ if(iregion_code == IREGION_CRUST_MANTLE &
+ .and. ilayer_loop==(ilast_region-nb_layer_above_aniso+1)) then
+ FIRST_ELT_ABOVE_ANISO = ispec+1
+ endif
+
+ ner_without_doubling = ner(ilayer)
+
+ ! if there is a doubling at the top of this region, we implement it in the last two layers of elements
+ ! and therefore we suppress two layers of regular elements here
+ USE_ONE_LAYER_SB = .false.
+ if(this_region_has_a_doubling(ilayer)) then
+ if (ner(ilayer) == 1) then
+ ner_without_doubling = ner_without_doubling - 1
+ USE_ONE_LAYER_SB = .true.
+ else
+ ner_without_doubling = ner_without_doubling - 2
+ USE_ONE_LAYER_SB = .false.
+ endif
+ endif
+
+ ! regular mesh elements
+ call create_regular_elements(myrank,ilayer,ichunk,ispec,ipass, &
+ ifirst_region,ilast_region,iregion_code, &
+ nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS, &
+ NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ ner_without_doubling,ner,ratio_sampling_array,r_top,r_bottom, &
+ xstore,ystore,zstore, &
+ iaddx,iaddy,iaddz,xigll,yigll,zigll, &
+ shape3D,dershape2D_bottom, &
+ INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
+ RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
+ R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ rmin,rmax,r_moho,r_400,r_670, &
+ rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ nspec_ani,c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ nspec_actually,xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore,&
+ nspec_stacey,rho_vp,rho_vs,iboun,iMPIcut_xi,iMPIcut_eta, &
+ ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
+ nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
+ rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB, &
+ stretch_tab,ACTUALLY_STORE_ARRAYS, &
+ NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho, &
+ ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot,ibelm_670_top,ibelm_670_bot, &
+ normal_moho,normal_400,normal_670,jacobian2D_moho,jacobian2D_400,jacobian2D_670, &
+ ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,&
+ ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot,&
+ ispec_is_tiso)
+
+
+ ! mesh doubling elements
+ if( this_region_has_a_doubling(ilayer) ) &
+ call create_doubling_elements(myrank,ilayer,ichunk,ispec,ipass, &
+ ifirst_region,ilast_region,iregion_code, &
+ nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS, &
+ NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ ner,ratio_sampling_array,r_top,r_bottom, &
+ xstore,ystore,zstore,xigll,yigll,zigll, &
+ shape3D,dershape2D_bottom, &
+ INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
+ RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
+ R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ rmin,rmax,r_moho,r_400,r_670, &
+ rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ nspec_ani,c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ nspec_actually,xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore,&
+ nspec_stacey,rho_vp,rho_vs,iboun,iMPIcut_xi,iMPIcut_eta, &
+ ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
+ nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
+ rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB,ACTUALLY_STORE_ARRAYS, &
+ NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho, &
+ ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot,ibelm_670_top,ibelm_670_bot, &
+ normal_moho,normal_400,normal_670,jacobian2D_moho,jacobian2D_400,jacobian2D_670, &
+ ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,&
+ ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,offset_proc_xi,offset_proc_eta, &
+ ispec_is_tiso)
+
+ enddo !ilayer_loop
+
+ ! define central cube in inner core
+ if(INCLUDE_CENTRAL_CUBE .and. iregion_code == IREGION_INNER_CORE) &
+ call create_central_cube(myrank,ichunk,ispec,iaddx,iaddy,iaddz, &
+ nspec,NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,R_CENTRAL_CUBE, &
+ iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,ratio_divide_central_cube, &
+ iMPIcut_xi,iMPIcut_eta,iboun, &
+ idoubling,iregion_code,xstore,ystore,zstore, &
+ RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME,&
+ R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ shape3D,rmin,rmax,rhostore,dvpstore,&
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
+ gammaxstore,gammaystore,gammazstore,nspec_actually, &
+ c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ nspec_ani,nspec_stacey,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
+ rho_vp,rho_vs,ABSORBING_CONDITIONS,ACTUALLY_STORE_ARRAYS,xigll,yigll,zigll, &
+ ispec_is_tiso)
+
+
+ ! check total number of spectral elements created
+ if(ispec /= nspec) call exit_MPI(myrank,'ispec should equal nspec')
+
+! if any of these flags is true, the element is on a communication edge
+! this is not enough because it can also be in contact by an edge or a corner but not a full face
+! therefore we will have to fix array "is_on_a_slice_edge" later in the solver to take this into account
+ is_on_a_slice_edge(:) = &
+ iMPIcut_xi(1,:) .or. iMPIcut_xi(2,:) .or. &
+ iMPIcut_eta(1,:) .or. iMPIcut_eta(2,:) .or. &
+ iboun(1,:) .or. iboun(2,:) .or. &
+ iboun(3,:) .or. iboun(4,:) .or. &
+ iboun(5,:) .or. iboun(6,:)
+
+! no need to count fictitious elements on the edges
+! for which communications cannot be overlapped with calculations
+ where(idoubling == IFLAG_IN_FICTITIOUS_CUBE) is_on_a_slice_edge = .false.
+
+ ! only create global addressing and the MPI buffers in the first pass
+ if(ipass == 1) then
+
+ !uncomment: adds model smoothing for point profile models
+ ! if( THREE_D_MODEL == THREE_D_MODEL_PPM ) then
+ ! call smooth_model(myrank, nproc_xi,nproc_eta,&
+ ! rho_vp,rho_vs,nspec_stacey, &
+ ! iregion_code,xixstore,xiystore,xizstore, &
+ ! etaxstore,etaystore,etazstore, &
+ ! gammaxstore,gammaystore,gammazstore, &
+ ! xstore,ystore,zstore,rhostore,dvpstore, &
+ ! kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,&
+ ! nspec,HETEROGEN_3D_MANTLE, &
+ ! NEX_XI,NCHUNKS,ABSORBING_CONDITIONS,PPM_V )
+
+ ! allocate memory for arrays
+ allocate(locval(npointot), &
+ ifseg(npointot), &
+ xp(npointot), &
+ yp(npointot), &
+ zp(npointot),stat=ier)
+ if(ier /= 0) stop 'error in allocate 20'
+
+ locval = 0
+ ifseg = .false.
+ xp = 0.d0
+ yp = 0.d0
+ zp = 0.d0
+
+ ! we need to create a copy of the x, y and z arrays because sorting in get_global will swap
+ ! these arrays and therefore destroy them
+ do ispec=1,nspec
+ ieoff = NGLLX * NGLLY * NGLLZ * (ispec-1)
+ ilocnum = 0
+ do k=1,NGLLZ
+ do j=1,NGLLY
+ do i=1,NGLLX
+ ilocnum = ilocnum + 1
+ xp(ilocnum+ieoff) = xstore(i,j,k,ispec)
+ yp(ilocnum+ieoff) = ystore(i,j,k,ispec)
+ zp(ilocnum+ieoff) = zstore(i,j,k,ispec)
+ enddo
+ enddo
+ enddo
+ enddo
+
+ call get_global(nspec,xp,yp,zp,ibool,locval,ifseg,nglob,npointot)
+
+ deallocate(xp,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(yp,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(zp,stat=ier); if(ier /= 0) stop 'error in deallocate'
+
+ ! check that number of points found equals theoretical value
+ if(nglob /= nglob_theor) then
+ write(errmsg,*) 'incorrect total number of points found: myrank,nglob,nglob_theor,ipass,iregion_code = ',&
+ myrank,nglob,nglob_theor,ipass,iregion_code
+ call exit_MPI(myrank,errmsg)
+ endif
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) call exit_MPI(myrank,'incorrect global numbering')
+
+ ! creates a new indirect addressing to reduce cache misses in memory access in the solver
+ ! this is *critical* to improve performance in the solver
+ call get_global_indirect_addressing(nspec,nglob,ibool)
+
+ ! checks again
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) call exit_MPI(myrank,'incorrect global numbering after sorting')
+
+ ! create MPI buffers
+ ! arrays locval(npointot) and ifseg(npointot) used to save memory
+ call get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, &
+ xstore,ystore,zstore,ifseg,npointot, &
+ NSPEC2D_ETA_FACE,iregion_code,npoin2D_xi)
+
+ call get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, &
+ xstore,ystore,zstore,ifseg,npointot, &
+ NSPEC2D_XI_FACE,iregion_code,npoin2D_eta)
+
+!! DK DK suppressed useless small files for ARM version for Tibidabo filesystem because we use a single chunk
+! call get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool,idoubling, &
+! xstore,ystore,zstore,ifseg,npointot, &
+! NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion_code)
+
+ ! Stacey
+ if(NCHUNKS /= 6) &
+ call get_absorb(myrank,prname,iboun,nspec,nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM)
+
+ ! create AVS or DX mesh data for the slices
+ if(SAVE_MESH_FILES) then
+ call write_AVS_DX_global_data(myrank,prname,nspec,ibool,idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
+
+ call write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, &
+ idoubling,xstore,ystore,zstore,locval,ifseg,npointot, &
+ rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
+ ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
+ RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
+ RMIDDLE_CRUST,ROCEAN,iregion_code)
+
+ call write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun,ibool, &
+ idoubling,xstore,ystore,zstore,locval,ifseg,npointot, &
+ rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
+ ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
+ RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
+ RMIDDLE_CRUST,ROCEAN,iregion_code)
+
+ call write_AVS_DX_surface_data(myrank,prname,nspec,iboun,ibool, &
+ idoubling,xstore,ystore,zstore,locval,ifseg,npointot, &
+ rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
+ ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
+ RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
+ RMIDDLE_CRUST,ROCEAN,iregion_code)
+
+ !> Hejun
+ ! Output material information for all GLL points
+ ! Can be use to check the mesh
+ ! call write_AVS_DX_global_data_gll(prname,nspec,xstore,ystore,zstore,&
+ ! rhostore,kappavstore,muvstore,Qmu_store,ATTENUATION)
+ endif
+
+ deallocate(locval,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(ifseg,stat=ier); if(ier /= 0) stop 'error in deallocate'
+
+! only create mass matrix and save all the final arrays in the second pass
+ else if(ipass == 2) then
+
+ ! copy the theoretical number of points for the second pass
+ nglob = nglob_theor
+
+ ! count number of anisotropic elements in current region
+ ! should be zero in all the regions except in the mantle
+ ! (used only for checks in meshfem3D() routine)
+ !nspec_tiso = count(idoubling(1:nspec) == IFLAG_220_80) + count(idoubling(1:nspec) == IFLAG_80_MOHO)
+ nspec_tiso = count(ispec_is_tiso(:))
+
+!****************************************************************************************************
+! Mila
+
+ if(SORT_MESH_INNER_OUTER) then
+
+!!!! David Michea: detection of the edges, coloring and permutation separately
+ allocate(perm(nspec))
+
+! implement mesh coloring for GPUs if needed, to create subsets of disconnected elements
+! to remove dependencies and the need for atomic operations in the sum of elemental contributions in the solver
+ if(USE_MESH_COLORING_GPU) then
+
+ allocate(first_elem_number_in_this_color(MAX_NUMBER_OF_COLORS + 1))
+
+ call get_perm_color_faster(is_on_a_slice_edge,ibool,perm,nspec,nglob, &
+ nb_colors_outer_elements,nb_colors_inner_elements,nspec_outer,first_elem_number_in_this_color,myrank)
+
+! for the last color, the next color is fictitious and its first (fictitious) element number is nspec + 1
+ first_elem_number_in_this_color(nb_colors_outer_elements + nb_colors_inner_elements + 1) = nspec + 1
+
+ allocate(num_of_elems_in_this_color(nb_colors_outer_elements + nb_colors_inner_elements))
+
+! save mesh coloring
+ open(unit=99,file=prname(1:len_trim(prname))//'num_of_elems_in_this_color.dat',status='unknown')
+
+! number of colors for outer elements
+ write(99,*) nb_colors_outer_elements
+
+! number of colors for inner elements
+ write(99,*) nb_colors_inner_elements
+
+! number of elements in each color
+ do icolor = 1, nb_colors_outer_elements + nb_colors_inner_elements
+ num_of_elems_in_this_color(icolor) = first_elem_number_in_this_color(icolor+1) - first_elem_number_in_this_color(icolor)
+ write(99,*) num_of_elems_in_this_color(icolor)
+ enddo
+ close(99)
+
+! check that the sum of all the numbers of elements found in each color is equal
+! to the total number of elements in the mesh
+ if(sum(num_of_elems_in_this_color) /= nspec) then
+ print *,'nspec = ',nspec
+ print *,'total number of elements in all the colors of the mesh = ',sum(num_of_elems_in_this_color)
+ stop 'incorrect total number of elements in all the colors of the mesh'
+ endif
+
+! check that the sum of all the numbers of elements found in each color for the outer elements is equal
+! to the total number of outer elements found in the mesh
+ if(sum(num_of_elems_in_this_color(1:nb_colors_outer_elements)) /= nspec_outer) then
+ print *,'nspec_outer = ',nspec_outer
+ print *,'total number of elements in all the colors of the mesh for outer elements = ',sum(num_of_elems_in_this_color)
+ stop 'incorrect total number of elements in all the colors of the mesh for outer elements'
+ endif
+
+ call MPI_ALLREDUCE(nspec_outer,nspec_outer_min_global,1,MPI_INTEGER,MPI_MIN,MPI_COMM_WORLD,ier)
+ call MPI_ALLREDUCE(nspec_outer,nspec_outer_max_global,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+
+ deallocate(first_elem_number_in_this_color)
+ deallocate(num_of_elems_in_this_color)
+
+ else
+
+!! DK DK for regular C + MPI version for CPUs: do not use colors but nonetheless put all the outer elements
+!! DK DK first in order to be able to overlap non-blocking MPI communications with calculations
+
+!! DK DK nov 2010, for Rosa Badia / StarSs:
+!! no need for mesh coloring, but need to implement inner/outer subsets for non blocking MPI for StarSs
+ ispec_counter = 0
+ perm(:) = 0
+
+! first generate all the outer elements
+ do ispec = 1,nspec
+ if(is_on_a_slice_edge(ispec)) then
+ ispec_counter = ispec_counter + 1
+ perm(ispec) = ispec_counter
+ endif
+ enddo
+
+! make sure we have detected some outer elements
+ if(ispec_counter <= 0) stop 'fatal error: no outer elements detected!'
+
+! store total number of outer elements
+ nspec_outer = ispec_counter
+
+! then generate all the inner elements
+ do ispec = 1,nspec
+ if(.not. is_on_a_slice_edge(ispec)) then
+ ispec_counter = ispec_counter + 1
+ perm(ispec) = ispec_counter
+ endif
+ enddo
+
+! test that all the elements have been used once and only once
+ if(ispec_counter /= nspec) stop 'fatal error: ispec_counter not equal to nspec'
+
+! do basic checks
+ if(minval(perm) /= 1) stop 'minval(perm) should be 1'
+ if(maxval(perm) /= nspec) stop 'maxval(perm) should be nspec'
+
+ call MPI_ALLREDUCE(nspec_outer,nspec_outer_min_global,1,MPI_INTEGER,MPI_MIN,MPI_COMM_WORLD,ier)
+ call MPI_ALLREDUCE(nspec_outer,nspec_outer_max_global,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
+
+ endif
+
+!! DK DK and Manh Ha, Nov 2011: added this to use the new mesher in the CUDA or C / StarSs test codes
+
+ if (myrank == 0 .and. iregion_code == IREGION_CRUST_MANTLE) then
+
+! write a header file for the Fortran version of the solver
+ open(unit=99,file=prname(1:len_trim(prname))//'values_from_mesher_f90.h',status='unknown')
+ write(99,*) 'integer, parameter :: NSPEC = ',nspec
+ write(99,*) 'integer, parameter :: NGLOB = ',nglob
+!!! DK DK use 1000 time steps only for the scaling tests
+ write(99,*) 'integer, parameter :: NSTEP = 1000 !!!!!!!!!!! ',nstep
+ write(99,*) 'real(kind=4), parameter :: deltat = ',DT
+ write(99,*)
+ write(99,*) 'integer, parameter :: NGLOB2DMAX_XMIN_XMAX = ',npoin2D_xi
+ write(99,*) 'integer, parameter :: NGLOB2DMAX_YMIN_YMAX = ',npoin2D_eta
+ write(99,*) 'integer, parameter :: NGLOB2DMAX_ALL = ',max(npoin2D_xi,npoin2D_eta)
+ write(99,*) 'integer, parameter :: NPROC_XI = ',NPROC_XI
+ write(99,*) 'integer, parameter :: NPROC_ETA = ',NPROC_ETA
+ write(99,*)
+ write(99,*) '! element number of the source and of the station'
+ write(99,*) '! after permutation of the elements by mesh coloring'
+ write(99,*) '! and inner/outer set splitting in the mesher'
+ write(99,*) 'integer, parameter :: NSPEC_SOURCE = ',perm(NSPEC/3)
+ write(99,*) 'integer, parameter :: RANK_SOURCE = 0'
+ write(99,*)
+ write(99,*) 'integer, parameter :: RANK_STATION = (NPROC_XI*NPROC_ETA - 1)'
+ write(99,*) 'integer, parameter :: NSPEC_STATION = ',perm(2*NSPEC/3)
+
+! save coordinates of the seismic source
+! write(99,*) xstore(2,2,2,10);
+! write(99,*) ystore(2,2,2,10);
+! write(99,*) zstore(2,2,2,10);
+
+! save coordinates of the seismic station
+! write(99,*) xstore(2,2,2,nspec-10);
+! write(99,*) ystore(2,2,2,nspec-10);
+! write(99,*) zstore(2,2,2,nspec-10);
+ close(99)
+
+!! write a header file for the C version of the solver
+ open(unit=99,file=prname(1:len_trim(prname))//'values_from_mesher_C.h',status='unknown')
+ write(99,*) '#define NSPEC ',nspec
+ write(99,*) '#define NGLOB ',nglob
+!! write(99,*) '#define NSTEP ',nstep
+!!! DK DK use 1000 time steps only for the scaling tests
+ write(99,*) '// #define NSTEP ',nstep
+ write(99,*) '#define NSTEP 1000'
+! put an "f" at the end to force single precision
+ write(99,"('#define deltat ',e18.10,'f')") DT
+ write(99,*) '#define NGLOB2DMAX_XMIN_XMAX ',npoin2D_xi
+ write(99,*) '#define NGLOB2DMAX_YMIN_YMAX ',npoin2D_eta
+ write(99,*) '#define NGLOB2DMAX_ALL ',max(npoin2D_xi,npoin2D_eta)
+ write(99,*) '#define NPROC_XI ',NPROC_XI
+ write(99,*) '#define NPROC_ETA ',NPROC_ETA
+ write(99,*)
+ write(99,*) '// element and MPI slice number of the source and the station'
+ write(99,*) '// after permutation of the elements by mesh coloring'
+ write(99,*) '// and inner/outer set splitting in the mesher'
+ write(99,*) '#define RANK_SOURCE 0'
+ write(99,*) '#define NSPEC_SOURCE ',perm(NSPEC/3)
+ write(99,*)
+ write(99,*) '#define RANK_STATION (NPROC_XI*NPROC_ETA - 1)'
+ write(99,*) '#define NSPEC_STATION ',perm(2*NSPEC/3)
+ close(99)
+
+ open(unit=99,file=prname(1:len_trim(prname))//'values_from_mesher_nspec_outer.h',status='unknown')
+ write(99,*) '#define NSPEC_OUTER ',nspec_outer_max_global
+ write(99,*) '// NSPEC_OUTER_min = ',nspec_outer_min_global
+ write(99,*) '// NSPEC_OUTER_max = ',nspec_outer_max_global
+ close(99)
+
+ endif
+
+!! DK DK and Manh Ha, Nov 2011: added this to use the new mesher in the CUDA or C / StarSs test codes
+
+ deallocate(perm)
+
+ else
+!
+ print *,'SORT_MESH_INNER_OUTER must always been set to .true. even for the regular C version for CPUs'
+ print *,'in order to be able to use non blocking MPI to overlap communications'
+! print *,'generating identity permutation'
+! do ispec = 1,nspec
+! perm(ispec) = ispec
+! enddo
+ stop 'please set SORT_MESH_INNER_OUTER to .true. and recompile the whole code'
+
+ endif
+
+!!!! David Michea: end of mesh coloring
+
+!****************************************************************************************************
+
+ ! precomputes jacobian for 2d absorbing boundary surfaces
+ call get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ jacobian2D_xmin,jacobian2D_xmax, &
+ jacobian2D_ymin,jacobian2D_ymax, &
+ jacobian2D_bottom,jacobian2D_top, &
+ normal_xmin,normal_xmax, &
+ normal_ymin,normal_ymax, &
+ normal_bottom,normal_top, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,&
+ xigll,yigll,zigll)
+
+ ! allocates mass matrix in this slice (will be fully assembled in the solver)
+ allocate(rmass(nglob),stat=ier)
+ if(ier /= 0) stop 'error in allocate 21'
+ ! allocates ocean load mass matrix as well if oceans
+ if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) then
+ nglob_oceans = nglob
+ else
+ ! allocate dummy array if no oceans
+ nglob_oceans = 1
+ endif
+ allocate(rmass_ocean_load(nglob_oceans),stat=ier)
+ if(ier /= 0) stop 'error in allocate 22'
+
+ ! creating mass matrix in this slice (will be fully assembled in the solver)
+ call create_mass_matrices(myrank,nspec,idoubling,wxgll,wygll,wzgll,ibool, &
+ nspec_actually,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore, &
+ gammaxstore,gammaystore,gammazstore, &
+ iregion_code,nglob,rmass,rhostore,kappavstore, &
+ nglob_oceans,rmass_ocean_load,NSPEC2D_TOP,ibelm_top,jacobian2D_top, &
+ xstore,ystore,zstore,RHO_OCEANS)
+
+ ! save the binary files
+#ifdef USE_SERIAL_CASCADE_FOR_IOs
+ you_can_start_doing_IOs = .false.
+ if (myrank > 0) call MPI_RECV(you_can_start_doing_IOs, 1, MPI_LOGICAL, myrank-1, itag, MPI_COMM_WORLD, msg_status,ier)
+!!!! print *,'starting doing serialized I/Os on rank ',myrank
+ print *,'starting doing serialized I/Os on rank ',myrank
+#endif
+ call save_arrays_solver(rho_vp,rho_vs,nspec_stacey, &
+ prname,iregion_code,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ xstore,ystore,zstore,rhostore,dvpstore, &
+ kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
+ nspec_ani,c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
+ c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
+ c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
+ ibool,idoubling,is_on_a_slice_edge,rmass,rmass_ocean_load,nglob_oceans, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top, &
+ jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax, &
+ jacobian2D_bottom,jacobian2D_top,nspec,nglob, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ TRANSVERSE_ISOTROPY,HETEROGEN_3D_MANTLE,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,OCEANS, &
+ tau_s,tau_e_store,Qmu_store,T_c_source,ATTENUATION, &
+ size(tau_e_store,2),size(tau_e_store,3),size(tau_e_store,4),size(tau_e_store,5),&
+ ABSORBING_CONDITIONS,SAVE_MESH_FILES,ispec_is_tiso)
+#ifdef USE_SERIAL_CASCADE_FOR_IOs
+ you_can_start_doing_IOs = .true.
+ if (myrank < NPROC_XI*NPROC_ETA-1) call MPI_SEND(you_can_start_doing_IOs, 1, MPI_LOGICAL, myrank+1, itag, MPI_COMM_WORLD, ier)
+#endif
+
+ deallocate(rmass,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(rmass_ocean_load,stat=ier); if(ier /= 0) stop 'error in deallocate'
+
+ ! boundary mesh
+ if (SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
+ ! first check the number of surface elements are the same for Moho, 400, 670
+ if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
+ if (ispec2D_moho_top /= NSPEC2D_MOHO .or. ispec2D_moho_bot /= NSPEC2D_MOHO) &
+ call exit_mpi(myrank, 'Not the same number of Moho surface elements')
+ endif
+ if (ispec2D_400_top /= NSPEC2D_400 .or. ispec2D_400_bot /= NSPEC2D_400) &
+ call exit_mpi(myrank,'Not the same number of 400 surface elements')
+ if (ispec2D_670_top /= NSPEC2D_670 .or. ispec2D_670_bot /= NSPEC2D_670) &
+ call exit_mpi(myrank,'Not the same number of 670 surface elements')
+
+ ! writing surface topology databases
+ open(unit=27,file=prname(1:len_trim(prname))//'boundary_disc.bin',status='unknown',form='unformatted')
+ write(27) NSPEC2D_MOHO, NSPEC2D_400, NSPEC2D_670
+ write(27) ibelm_moho_top
+ write(27) ibelm_moho_bot
+ write(27) ibelm_400_top
+ write(27) ibelm_400_bot
+ write(27) ibelm_670_top
+ write(27) ibelm_670_bot
+ write(27) normal_moho
+ write(27) normal_400
+ write(27) normal_670
+ close(27)
+ endif
+
+ ! compute volume, bottom and top area of that part of the slice
+ call crm_compute_volumes(volume_local,area_local_bottom,area_local_top, &
+ nspec,wxgll,wygll,wzgll,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ NSPEC2D_BOTTOM,jacobian2D_bottom,NSPEC2D_TOP,jacobian2D_top)
+
+
+ else
+ stop 'there cannot be more than two passes in mesh creation'
+
+ endif ! end of test if first or second pass
+
+ deallocate(stretch_tab)
+ deallocate(perm_layer)
+
+ ! deallocate these arrays after each pass because they have a different size in each pass to save memory
+ deallocate(xixstore,xiystore,xizstore,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(etaxstore,etaystore,etazstore,stat=ier); if(ier /= 0) stop 'error in deallocate'
+ deallocate(gammaxstore,gammaystore,gammazstore,stat=ier); if(ier /= 0) stop 'error in deallocate'
+
+ ! deallocate arrays
+ deallocate(rhostore,dvpstore,kappavstore,kappahstore)
+ deallocate(muvstore,muhstore)
+ deallocate(eta_anisostore)
+ deallocate(ispec_is_tiso)
+ deallocate(c11store)
+ deallocate(c12store)
+ deallocate(c13store)
+ deallocate(c14store)
+ deallocate(c15store)
+ deallocate(c16store)
+ deallocate(c22store)
+ deallocate(c23store)
+ deallocate(c24store)
+ deallocate(c25store)
+ deallocate(c26store)
+ deallocate(c33store)
+ deallocate(c34store)
+ deallocate(c35store)
+ deallocate(c36store)
+ deallocate(c44store)
+ deallocate(c45store)
+ deallocate(c46store)
+ deallocate(c55store)
+ deallocate(c56store)
+ deallocate(c66store)
+ deallocate(iboun)
+ deallocate(xigll,yigll,zigll)
+ deallocate(wxgll,wygll,wzgll)
+ deallocate(shape3D,dershape3D)
+ deallocate(shape2D_x,shape2D_y,shape2D_bottom,shape2D_top)
+ deallocate(dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top)
+ deallocate(ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax)
+ deallocate(ibelm_bottom,ibelm_top)
+ deallocate(jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax)
+ deallocate(jacobian2D_bottom,jacobian2D_top)
+ deallocate(normal_xmin,normal_xmax,normal_ymin,normal_ymax)
+ deallocate(normal_bottom,normal_top)
+ deallocate(iMPIcut_xi,iMPIcut_eta)
+ deallocate(nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta)
+ deallocate(rho_vp,rho_vs)
+ deallocate(Qmu_store)
+ deallocate(tau_e_store)
+ deallocate(ibelm_moho_top,ibelm_moho_bot)
+ deallocate(ibelm_400_top,ibelm_400_bot)
+ deallocate(ibelm_670_top,ibelm_670_bot)
+ deallocate(normal_moho,normal_400,normal_670)
+ deallocate(jacobian2D_moho,jacobian2D_400,jacobian2D_670)
+
+ end subroutine create_regions_mesh
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine crm_initialize_layers(myrank,ipass,xigll,yigll,zigll,wxgll,wygll,wzgll, &
+ shape3D,dershape3D,shape2D_x,shape2D_y,shape2D_bottom,shape2D_top, &
+ dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
+ iaddx,iaddy,iaddz,nspec,xstore,ystore,zstore,ibool,idoubling, &
+ iboun,iMPIcut_xi,iMPIcut_eta,ispec2D_moho_top,ispec2D_moho_bot, &
+ ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot, &
+ NEX_PER_PROC_ETA,nex_eta_moho,RMOHO,R400,R670,r_moho,r_400,r_670, &
+ ONE_CRUST,NUMBER_OF_MESH_LAYERS,layer_shift, &
+ iregion_code,ifirst_region,ilast_region, &
+ first_layer_aniso,last_layer_aniso,nb_layer_above_aniso,is_on_a_slice_edge)
+
+! create the different regions of the mesh
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: myrank,ipass
+
+ double precision xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ)
+ double precision wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ)
+
+ double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ),dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ)
+
+ double precision shape2D_x(NGNOD2D,NGLLY,NGLLZ),shape2D_y(NGNOD2D,NGLLX,NGLLZ)
+ double precision shape2D_bottom(NGNOD2D,NGLLX,NGLLY),shape2D_top(NGNOD2D,NGLLX,NGLLY)
+ double precision dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ),dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ)
+ double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY),dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY)
+
+ integer, dimension(NGNOD) :: iaddx,iaddy,iaddz
+
+ integer nspec
+ double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+ integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+ integer idoubling(nspec)
+
+ logical iboun(6,nspec)
+ logical iMPIcut_xi(2,nspec),iMPIcut_eta(2,nspec)
+
+ integer ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot, &
+ ispec2D_670_top,ispec2D_670_bot
+ integer NEX_PER_PROC_ETA,nex_eta_moho
+ double precision RMOHO,R400,R670
+ double precision r_moho,r_400,r_670
+
+ logical ONE_CRUST
+ integer NUMBER_OF_MESH_LAYERS,layer_shift
+
+ ! code for the four regions of the mesh
+ integer iregion_code,ifirst_region,ilast_region
+ integer first_layer_aniso,last_layer_aniso,nb_layer_above_aniso
+
+! this for non blocking MPI
+ logical, dimension(nspec) :: is_on_a_slice_edge
+
+! set up coordinates of the Gauss-Lobatto-Legendre points
+ call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
+ call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
+
+! if number of points is odd, the middle abscissa is exactly zero
+ if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO
+ if(mod(NGLLY,2) /= 0) yigll((NGLLY-1)/2+1) = ZERO
+ if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO
+
+! get the 3-D shape functions
+ call get_shape3D(myrank,shape3D,dershape3D,xigll,yigll,zigll)
+
+! get the 2-D shape functions
+ call get_shape2D(myrank,shape2D_x,dershape2D_x,yigll,zigll,NGLLY,NGLLZ)
+ call get_shape2D(myrank,shape2D_y,dershape2D_y,xigll,zigll,NGLLX,NGLLZ)
+ call get_shape2D(myrank,shape2D_bottom,dershape2D_bottom,xigll,yigll,NGLLX,NGLLY)
+ call get_shape2D(myrank,shape2D_top,dershape2D_top,xigll,yigll,NGLLX,NGLLY)
+
+! create the shape of the corner nodes of a regular mesh element
+ call hex_nodes(iaddx,iaddy,iaddz)
+
+! reference element has size one here, not two
+ iaddx(:) = iaddx(:) / 2
+ iaddy(:) = iaddy(:) / 2
+ iaddz(:) = iaddz(:) / 2
+
+! sets number of layers
+ if (ONE_CRUST) then
+ NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS - 1
+ layer_shift = 0
+ else
+ NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS
+ layer_shift = 1
+ endif
+
+ if (.not. ADD_4TH_DOUBLING) NUMBER_OF_MESH_LAYERS = NUMBER_OF_MESH_LAYERS - 1
+
+! define the first and last layers that define this region
+ if(iregion_code == IREGION_CRUST_MANTLE) then
+ ifirst_region = 1
+ ilast_region = 10 + layer_shift
+
+ else if(iregion_code == IREGION_OUTER_CORE) then
+ ifirst_region = 11 + layer_shift
+ ilast_region = NUMBER_OF_MESH_LAYERS - 1
+
+ else if(iregion_code == IREGION_INNER_CORE) then
+ ifirst_region = NUMBER_OF_MESH_LAYERS
+ ilast_region = NUMBER_OF_MESH_LAYERS
+
+ else
+ call exit_MPI(myrank,'incorrect region code detected')
+ endif
+
+! to consider anisotropic elements first and to build the mesh from the bottom to the top of the region
+ if (ONE_CRUST) then
+ first_layer_aniso=2
+ last_layer_aniso=3
+ nb_layer_above_aniso = 1
+ else
+ first_layer_aniso=3
+ last_layer_aniso=4
+ nb_layer_above_aniso = 2
+ endif
+
+! initialize mesh arrays
+ idoubling(:) = 0
+
+ xstore(:,:,:,:) = 0.d0
+ ystore(:,:,:,:) = 0.d0
+ zstore(:,:,:,:) = 0.d0
+
+ if(ipass == 1) ibool(:,:,:,:) = 0
+
+ ! initialize boundary arrays
+ iboun(:,:) = .false.
+ iMPIcut_xi(:,:) = .false.
+ iMPIcut_eta(:,:) = .false.
+ is_on_a_slice_edge(:) = .false.
+
+ ! boundary mesh
+ ispec2D_moho_top = 0; ispec2D_moho_bot = 0
+ ispec2D_400_top = 0; ispec2D_400_bot = 0
+ ispec2D_670_top = 0; ispec2D_670_bot = 0
+
+ nex_eta_moho = NEX_PER_PROC_ETA
+
+ r_moho = RMOHO/R_EARTH; r_400 = R400 / R_EARTH; r_670 = R670/R_EARTH
+
+ end subroutine crm_initialize_layers
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine crm_compute_volumes(volume_local,area_local_bottom,area_local_top, &
+ nspec,wxgll,wygll,wzgll,xixstore,xiystore,xizstore, &
+ etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
+ NSPEC2D_BOTTOM,jacobian2D_bottom,NSPEC2D_TOP,jacobian2D_top)
+
+ implicit none
+
+ include "constants.h"
+
+ double precision :: volume_local,area_local_bottom,area_local_top
+
+ integer :: nspec
+ double precision :: wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ)
+
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
+ xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
+
+ integer :: NSPEC2D_BOTTOM,NSPEC2D_TOP
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM) :: jacobian2D_bottom
+ real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP) :: jacobian2D_top
+
+ ! local parameters
+ double precision :: weight
+ real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
+ integer :: i,j,k,ispec
+
+ ! initializes
+ volume_local = ZERO
+ area_local_bottom = ZERO
+ area_local_top = ZERO
+
+ do ispec = 1,nspec
+ do k = 1,NGLLZ
+ do j = 1,NGLLY
+ do i = 1,NGLLX
+
+ weight = wxgll(i)*wygll(j)*wzgll(k)
+
+ ! compute the jacobian
+ xixl = xixstore(i,j,k,ispec)
+ xiyl = xiystore(i,j,k,ispec)
+ xizl = xizstore(i,j,k,ispec)
+ etaxl = etaxstore(i,j,k,ispec)
+ etayl = etaystore(i,j,k,ispec)
+ etazl = etazstore(i,j,k,ispec)
+ gammaxl = gammaxstore(i,j,k,ispec)
+ gammayl = gammaystore(i,j,k,ispec)
+ gammazl = gammazstore(i,j,k,ispec)
+
+ jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
+ - xiyl*(etaxl*gammazl-etazl*gammaxl) &
+ + xizl*(etaxl*gammayl-etayl*gammaxl))
+
+ volume_local = volume_local + dble(jacobianl)*weight
+
+ enddo
+ enddo
+ enddo
+ enddo
+
+ do ispec = 1,NSPEC2D_BOTTOM
+ do i=1,NGLLX
+ do j=1,NGLLY
+ weight=wxgll(i)*wygll(j)
+ area_local_bottom = area_local_bottom + dble(jacobian2D_bottom(i,j,ispec))*weight
+ enddo
+ enddo
+ enddo
+
+ do ispec = 1,NSPEC2D_TOP
+ do i=1,NGLLX
+ do j=1,NGLLY
+ weight=wxgll(i)*wygll(j)
+ area_local_top = area_local_top + dble(jacobian2D_top(i,j,ispec))*weight
+ enddo
+ enddo
+ enddo
+
+
+ end subroutine crm_compute_volumes
+
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regions_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regions_mesh.f90 2012-05-19 14:09:44 UTC (rev 20175)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_regions_mesh.f90 2012-05-19 16:33:09 UTC (rev 20176)
@@ -1,1379 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine create_regions_mesh(iregion_code,ibool,idoubling,is_on_a_slice_edge, &
- xstore,ystore,zstore,rmins,rmaxs, &
- iproc_xi,iproc_eta,ichunk,nspec,nspec_tiso, &
- volume_local,area_local_bottom,area_local_top, &
- nglob_theor,npointot, &
- NSTEP,DT, &
- NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE, &
- NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
- myrank,LOCAL_PATH,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,&
- SAVE_MESH_FILES,NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
- R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,&
- RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- ner,ratio_sampling_array,doubling_index,r_bottom,r_top, &
- this_region_has_a_doubling,ipass,ratio_divide_central_cube, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,offset_proc_xi,offset_proc_eta)
-
-! creates the different regions of the mesh
-
- use meshfem3D_models_par
-
- implicit none
-
-!****************************************************************************************************
-! Mila
-
-! include "constants.h"
-! standard include of the MPI library
- include 'mpif.h'
-
-!****************************************************************************************************
-
- ! this to cut the doubling brick
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
- integer :: offset_proc_xi,offset_proc_eta
-
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
-
- integer :: ner_without_doubling,ilayer,ilayer_loop, &
- ifirst_region,ilast_region,ratio_divide_central_cube
- integer, dimension(:), allocatable :: perm_layer
-
- ! correct number of spectral elements in each block depending on chunk type
- integer nspec,nspec_tiso,nspec_stacey,nspec_actually,nspec_att
-
- integer NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,NCHUNKS
-
- integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP
-
- integer NPROC_XI,NPROC_ETA
-
- integer npointot
-
- logical SAVE_MESH_FILES
-
- logical INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS
-
- double precision R_CENTRAL_CUBE,RICB,RCMB,R670,RMOHO, &
- RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- RMOHO_FICTITIOUS_IN_MESHER
-
- double precision RHO_OCEANS
-
- character(len=150) LOCAL_PATH,errmsg
-
- ! arrays with the mesh in double precision
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- ! meshing parameters
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
-
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
-
- ! topology of the elements
- integer, dimension(NGNOD) :: iaddx,iaddy,iaddz
-
- ! code for the four regions of the mesh
- integer iregion_code
-
- ! Gauss-Lobatto-Legendre points and weights of integration
- double precision, dimension(:), allocatable :: xigll,yigll,zigll,wxgll,wygll,wzgll
-
- ! 3D shape functions and their derivatives
- double precision, dimension(:,:,:,:), allocatable :: shape3D
- double precision, dimension(:,:,:,:,:), allocatable :: dershape3D
-
- ! 2D shape functions and their derivatives
- double precision, dimension(:,:,:), allocatable :: shape2D_x,shape2D_y, &
- shape2D_bottom,shape2D_top
- double precision, dimension(:,:,:,:), allocatable :: dershape2D_x,dershape2D_y, &
- dershape2D_bottom,dershape2D_top
-
- integer, dimension(nspec) :: idoubling
-
-! this for non blocking MPI
- logical, dimension(nspec) :: is_on_a_slice_edge
-
- ! parameters needed to store the radii of the grid points in the spherically symmetric Earth
- double precision rmin,rmax
-
- ! for model density and anisotropy
- integer nspec_ani
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rhostore,dvpstore, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore
-
- ! the 21 coefficients for an anisotropic medium in reduced notation
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store
-
- ! boundary locator
- logical, dimension(:,:), allocatable :: iboun
-
- ! arrays with mesh parameters
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
-
- ! proc numbers for MPI
- integer myrank
-
- ! check area and volume of the final mesh
- double precision area_local_bottom,area_local_top
- double precision volume_local
-
- ! variables for creating array ibool (some arrays also used for AVS or DX files)
- integer, dimension(:), allocatable :: locval
- logical, dimension(:), allocatable :: ifseg
- double precision, dimension(:), allocatable :: xp,yp,zp
-
- integer nglob,nglob_theor,ieoff,ilocnum,ier
-
- ! mass matrix
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass
-
- ! mass matrix and bathymetry for ocean load
- integer nglob_oceans
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_ocean_load
-
- ! boundary parameters locator
- integer, dimension(:), allocatable :: ibelm_xmin,ibelm_xmax, &
- ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top
-
- ! 2-D jacobians and normals
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: &
- jacobian2D_xmin,jacobian2D_xmax, &
- jacobian2D_ymin,jacobian2D_ymax,jacobian2D_bottom,jacobian2D_top
-
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: &
- normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top
-
- ! MPI cut-planes parameters along xi and along eta
- logical, dimension(:,:), allocatable :: iMPIcut_xi,iMPIcut_eta
-
- ! Stacey, indices for Clayton-Engquist absorbing conditions
- integer, dimension(:,:), allocatable :: nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_vp,rho_vs
-
- ! name of the database file
- character(len=150) prname
-
- ! number of elements on the boundaries
- integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
-
- integer i,j,k,ispec
- integer iproc_xi,iproc_eta,ichunk
-
- double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
-
- ! rotation matrix from Euler angles
- double precision, dimension(NDIM,NDIM) :: rotation_matrix
-
- ! attenuation
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: Qmu_store
- real(kind=CUSTOM_REAL), dimension(:,:,:,:,:), allocatable :: tau_e_store
- double precision, dimension(N_SLS) :: tau_s
- double precision T_c_source
-
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- logical :: USE_ONE_LAYER_SB
-
- integer NUMBER_OF_MESH_LAYERS,layer_shift,cpt, &
- first_layer_aniso,last_layer_aniso,FIRST_ELT_NON_ANISO
-
- double precision, dimension(:,:), allocatable :: stretch_tab
-
- integer :: nb_layer_above_aniso,FIRST_ELT_ABOVE_ANISO
-
- ! now perform two passes in this part to be able to save memory
- integer :: ipass
-
- logical :: ACTUALLY_STORE_ARRAYS
-
-!****************************************************************************************************
-! Mila
-
-! added for color permutation
- integer :: nb_colors_outer_elements,nb_colors_inner_elements,nspec_outer
- integer, dimension(:), allocatable :: perm
- integer, dimension(:), allocatable :: first_elem_number_in_this_color
- integer, dimension(:), allocatable :: num_of_elems_in_this_color
-
- integer :: icolor,ispec_counter
- integer :: nspec_outer_min_global,nspec_outer_max_global
-
-!****************************************************************************************************
-
-!///////////////////////////////////////////////////////////////////////////////
-! Manh Ha - 18-11-2011
-! Adding new variables
-
- integer :: NSTEP
- integer, save :: npoin2D_xi,npoin2D_eta
- double precision :: DT
-
-!///////////////////////////////////////////////////////////////////////////////
-
- ! Boundary Mesh
- integer NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho
- integer, dimension(:), allocatable :: ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot, &
- ibelm_670_top,ibelm_670_bot
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: normal_moho,normal_400,normal_670
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: jacobian2D_moho,jacobian2D_400,jacobian2D_670
- integer ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot, &
- ispec2D_670_top,ispec2D_670_bot
- double precision r_moho,r_400,r_670
-
- ! flags for transverse isotropic elements
- logical, dimension(:), allocatable :: ispec_is_tiso
-
- ! create the name for the database of the current slide and region
- call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
-
- ! New Attenuation definition on all GLL points
- ! Attenuation
- if (ATTENUATION) then
- T_c_source = AM_V%QT_c_source
- tau_s(:) = AM_V%Qtau_s(:)
- nspec_att = nspec
- else
- nspec_att = 1
- end if
- allocate(Qmu_store(NGLLX,NGLLY,NGLLZ,nspec_att), &
- tau_e_store(N_SLS,NGLLX,NGLLY,NGLLZ,nspec_att),stat=ier)
- if(ier /= 0) stop 'error in allocate 1'
-
- ! Gauss-Lobatto-Legendre points of integration
- allocate(xigll(NGLLX), &
- yigll(NGLLY), &
- zigll(NGLLZ),stat=ier)
- if(ier /= 0) stop 'error in allocate 2'
-
- ! Gauss-Lobatto-Legendre weights of integration
- allocate(wxgll(NGLLX), &
- wygll(NGLLY), &
- wzgll(NGLLZ),stat=ier)
- if(ier /= 0) stop 'error in allocate 3'
-
- ! 3D shape functions and their derivatives
- allocate(shape3D(NGNOD,NGLLX,NGLLY,NGLLZ), &
- dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ),stat=ier)
- if(ier /= 0) stop 'error in allocat 4'
-
- ! 2D shape functions and their derivatives
- allocate(shape2D_x(NGNOD2D,NGLLY,NGLLZ), &
- shape2D_y(NGNOD2D,NGLLX,NGLLZ), &
- shape2D_bottom(NGNOD2D,NGLLX,NGLLY), &
- shape2D_top(NGNOD2D,NGLLX,NGLLY), &
- dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ), &
- dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ), &
- dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY), &
- dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY),stat=ier)
- if(ier /= 0) stop 'error in allocate 5'
-
- ! array with model density
- allocate(rhostore(NGLLX,NGLLY,NGLLZ,nspec), &
- dvpstore(NGLLX,NGLLY,NGLLZ,nspec),stat=ier)
- if(ier /= 0) stop 'error in allocate 6'
-
- ! for anisotropy
- allocate(kappavstore(NGLLX,NGLLY,NGLLZ,nspec), &
- muvstore(NGLLX,NGLLY,NGLLZ,nspec), &
- kappahstore(NGLLX,NGLLY,NGLLZ,nspec), &
- muhstore(NGLLX,NGLLY,NGLLZ,nspec), &
- eta_anisostore(NGLLX,NGLLY,NGLLZ,nspec), &
- ispec_is_tiso(nspec),stat=ier)
- if(ier /= 0) stop 'error in allocate 7'
-
- ! initializes flags for transverse isotropic elements
- ispec_is_tiso(:) = .false.
-
- ! Stacey absorbing boundaries
- if(NCHUNKS /= 6) then
- nspec_stacey = nspec
- else
- nspec_stacey = 1
- endif
- allocate(rho_vp(NGLLX,NGLLY,NGLLZ,nspec_stacey), &
- rho_vs(NGLLX,NGLLY,NGLLZ,nspec_stacey),stat=ier)
- if(ier /= 0) stop 'error in allocate 8'
-
- ! anisotropy
- if((ANISOTROPIC_INNER_CORE .and. iregion_code == IREGION_INNER_CORE) .or. &
- (ANISOTROPIC_3D_MANTLE .and. iregion_code == IREGION_CRUST_MANTLE)) then
- nspec_ani = nspec
- else
- nspec_ani = 1
- endif
- allocate(c11store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c12store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c13store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c14store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c15store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c16store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c22store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c23store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c24store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c25store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c26store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c33store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c34store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c35store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c36store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c44store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c45store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c46store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c55store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c56store(NGLLX,NGLLY,NGLLZ,nspec_ani), &
- c66store(NGLLX,NGLLY,NGLLZ,nspec_ani),stat=ier)
- if(ier /= 0) stop 'error in allocate 9'
-
- ! boundary locator
- allocate(iboun(6,nspec),stat=ier)
- if(ier /= 0) stop 'error in allocate 10'
-
- ! boundary parameters locator
- allocate(ibelm_xmin(NSPEC2DMAX_XMIN_XMAX), &
- ibelm_xmax(NSPEC2DMAX_XMIN_XMAX), &
- ibelm_ymin(NSPEC2DMAX_YMIN_YMAX), &
- ibelm_ymax(NSPEC2DMAX_YMIN_YMAX), &
- ibelm_bottom(NSPEC2D_BOTTOM), &
- ibelm_top(NSPEC2D_TOP),stat=ier)
- if(ier /= 0) stop 'error in allocate 11'
-
- ! 2-D jacobians and normals
- allocate(jacobian2D_xmin(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX), &
- jacobian2D_xmax(NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX), &
- jacobian2D_ymin(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX), &
- jacobian2D_ymax(NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX), &
- jacobian2D_bottom(NGLLX,NGLLY,NSPEC2D_BOTTOM), &
- jacobian2D_top(NGLLX,NGLLY,NSPEC2D_TOP),stat=ier)
- if(ier /= 0) stop 'error in allocate 12'
-
- allocate(normal_xmin(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX), &
- normal_xmax(NDIM,NGLLY,NGLLZ,NSPEC2DMAX_XMIN_XMAX), &
- normal_ymin(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX), &
- normal_ymax(NDIM,NGLLX,NGLLZ,NSPEC2DMAX_YMIN_YMAX), &
- normal_bottom(NDIM,NGLLX,NGLLY,NSPEC2D_BOTTOM), &
- normal_top(NDIM,NGLLX,NGLLY,NSPEC2D_TOP),stat=ier)
- if(ier /= 0) stop 'error in allocate 13'
-
- ! Stacey
- allocate(nimin(2,NSPEC2DMAX_YMIN_YMAX), &
- nimax(2,NSPEC2DMAX_YMIN_YMAX), &
- njmin(2,NSPEC2DMAX_XMIN_XMAX), &
- njmax(2,NSPEC2DMAX_XMIN_XMAX), &
- nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX), &
- nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX),stat=ier)
- if(ier /= 0) stop 'error in allocate 14'
-
- ! MPI cut-planes parameters along xi and along eta
- allocate(iMPIcut_xi(2,nspec), &
- iMPIcut_eta(2,nspec),stat=ier)
- if(ier /= 0) stop 'error in allocate 15'
-
- ! store and save the final arrays only in the second pass
- ! therefore in the first pass some arrays can be allocated with a dummy size
- if(ipass == 1) then
- ACTUALLY_STORE_ARRAYS = .false.
- nspec_actually = 1
- else
- ACTUALLY_STORE_ARRAYS = .true.
- nspec_actually = nspec
- endif
- allocate(xixstore(NGLLX,NGLLY,NGLLZ,nspec_actually), &
- xiystore(NGLLX,NGLLY,NGLLZ,nspec_actually), &
- xizstore(NGLLX,NGLLY,NGLLZ,nspec_actually), &
- etaxstore(NGLLX,NGLLY,NGLLZ,nspec_actually), &
- etaystore(NGLLX,NGLLY,NGLLZ,nspec_actually), &
- etazstore(NGLLX,NGLLY,NGLLZ,nspec_actually), &
- gammaxstore(NGLLX,NGLLY,NGLLZ,nspec_actually), &
- gammaystore(NGLLX,NGLLY,NGLLZ,nspec_actually), &
- gammazstore(NGLLX,NGLLY,NGLLZ,nspec_actually),stat=ier)
- if(ier /= 0) stop 'error in allocate 16'
-
- ! boundary mesh
- if (ipass == 2 .and. SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
- NSPEC2D_MOHO = NSPEC2D_TOP
- NSPEC2D_400 = NSPEC2D_MOHO / 4
- NSPEC2D_670 = NSPEC2D_400
- else
- NSPEC2D_MOHO = 1
- NSPEC2D_400 = 1
- NSPEC2D_670 = 1
- endif
- allocate(ibelm_moho_top(NSPEC2D_MOHO),ibelm_moho_bot(NSPEC2D_MOHO), &
- ibelm_400_top(NSPEC2D_400),ibelm_400_bot(NSPEC2D_400), &
- ibelm_670_top(NSPEC2D_670),ibelm_670_bot(NSPEC2D_670), &
- normal_moho(NDIM,NGLLX,NGLLY,NSPEC2D_MOHO), &
- normal_400(NDIM,NGLLX,NGLLY,NSPEC2D_400), &
- normal_670(NDIM,NGLLX,NGLLY,NSPEC2D_670), &
- jacobian2D_moho(NGLLX,NGLLY,NSPEC2D_MOHO), &
- jacobian2D_400(NGLLX,NGLLY,NSPEC2D_400), &
- jacobian2D_670(NGLLX,NGLLY,NSPEC2D_670),stat=ier)
- if(ier /= 0) stop 'error in allocate 17'
-
- ! initialize number of layers
- call crm_initialize_layers(myrank,ipass,xigll,yigll,zigll,wxgll,wygll,wzgll, &
- shape3D,dershape3D,shape2D_x,shape2D_y,shape2D_bottom,shape2D_top, &
- dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
- iaddx,iaddy,iaddz,nspec,xstore,ystore,zstore,ibool,idoubling, &
- iboun,iMPIcut_xi,iMPIcut_eta,ispec2D_moho_top,ispec2D_moho_bot, &
- ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot, &
- NEX_PER_PROC_ETA,nex_eta_moho,RMOHO,R400,R670,r_moho,r_400,r_670, &
- ONE_CRUST,NUMBER_OF_MESH_LAYERS,layer_shift, &
- iregion_code,ifirst_region,ilast_region, &
- first_layer_aniso,last_layer_aniso,nb_layer_above_aniso,is_on_a_slice_edge)
-
- ! to consider anisotropic elements first and to build the mesh from the bottom to the top of the region
- allocate (perm_layer(ifirst_region:ilast_region),stat=ier)
- if(ier /= 0) stop 'error in allocate 18'
- perm_layer = (/ (i, i=ilast_region,ifirst_region,-1) /)
-
- if(iregion_code == IREGION_CRUST_MANTLE) then
- cpt=3
- perm_layer(1)=first_layer_aniso
- perm_layer(2)=last_layer_aniso
- do i = ilast_region,ifirst_region,-1
- if (i/=first_layer_aniso .and. i/=last_layer_aniso) then
- perm_layer(cpt) = i
- cpt=cpt+1
- endif
- enddo
- endif
-
- ! crustal layer stretching: element layer's top and bottom radii will get stretched when in crust
- ! (number of element layers in crust can vary for different resolutions and 1chunk simulations)
- allocate(stretch_tab(2,ner(1)),stat=ier)
- if(ier /= 0) stop 'error in allocate 19'
- if (CASE_3D .and. iregion_code == IREGION_CRUST_MANTLE .and. .not. SUPPRESS_CRUSTAL_MESH) then
- ! stretching function determines top and bottom of each element layer in the
- ! crust region (between r_top(1) and r_bottom(1)), where ner(1) is the
- ! number of element layers in this crust region
-
- ! differentiate between regional meshes or global meshes
- if( REGIONAL_MOHO_MESH ) then
- call stretching_function_regional(r_top(1),r_bottom(1),ner(1),stretch_tab)
- else
- call stretching_function(r_top(1),r_bottom(1),ner(1),stretch_tab)
- endif
-
- ! RMIDDLE_CRUST so far is only used for 1D - models with two layers in the crust
- ! (i.e. ONE_CRUST is set to .false.), those models do not use CASE_3D
-
- ! all 3D models use this stretching function to honor a 3D crustal model
- ! for those models, we set RMIDDLE_CRUST to the bottom of the first element layer
- ! this value will be used in moho_stretching.f90 to decide whether or not elements
- ! have to be stretched under oceanic crust.
- !
- ! note: stretch_tab uses (dimensionalized) radii from r_top and r_bottom
- !(with stretch_tab( index_radius(1=top,2=bottom), index_layer( 1=first layer, 2=second layer, 3= ...) )
- RMIDDLE_CRUST = stretch_tab(2,1)
-
- endif
-
-!----
-!---- creates mesh elements
-!----
-
- ! loop on all the layers in this region of the mesh
- ispec = 0 ! counts all the elements in this region of the mesh
- do ilayer_loop = ifirst_region,ilast_region
-
- ilayer = perm_layer(ilayer_loop)
-
- ! determine the radii that define the shell
- rmin = rmins(ilayer)
- rmax = rmaxs(ilayer)
-
- if(iregion_code == IREGION_CRUST_MANTLE .and. ilayer_loop==3) then
- FIRST_ELT_NON_ANISO = ispec+1
- endif
- if(iregion_code == IREGION_CRUST_MANTLE &
- .and. ilayer_loop==(ilast_region-nb_layer_above_aniso+1)) then
- FIRST_ELT_ABOVE_ANISO = ispec+1
- endif
-
- ner_without_doubling = ner(ilayer)
-
- ! if there is a doubling at the top of this region, we implement it in the last two layers of elements
- ! and therefore we suppress two layers of regular elements here
- USE_ONE_LAYER_SB = .false.
- if(this_region_has_a_doubling(ilayer)) then
- if (ner(ilayer) == 1) then
- ner_without_doubling = ner_without_doubling - 1
- USE_ONE_LAYER_SB = .true.
- else
- ner_without_doubling = ner_without_doubling - 2
- USE_ONE_LAYER_SB = .false.
- endif
- endif
-
- ! regular mesh elements
- call create_regular_elements(myrank,ilayer,ichunk,ispec,ipass, &
- ifirst_region,ilast_region,iregion_code, &
- nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS, &
- NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- ner_without_doubling,ner,ratio_sampling_array,r_top,r_bottom, &
- xstore,ystore,zstore, &
- iaddx,iaddy,iaddz,xigll,yigll,zigll, &
- shape3D,dershape2D_bottom, &
- INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- rmin,rmax,r_moho,r_400,r_670, &
- rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- nspec_ani,c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- nspec_actually,xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
- gammaxstore,gammaystore,gammazstore,&
- nspec_stacey,rho_vp,rho_vs,iboun,iMPIcut_xi,iMPIcut_eta, &
- ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
- nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
- rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB, &
- stretch_tab,ACTUALLY_STORE_ARRAYS, &
- NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho, &
- ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot,ibelm_670_top,ibelm_670_bot, &
- normal_moho,normal_400,normal_670,jacobian2D_moho,jacobian2D_400,jacobian2D_670, &
- ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,&
- ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot,&
- ispec_is_tiso)
-
-
- ! mesh doubling elements
- if( this_region_has_a_doubling(ilayer) ) &
- call create_doubling_elements(myrank,ilayer,ichunk,ispec,ipass, &
- ifirst_region,ilast_region,iregion_code, &
- nspec,NCHUNKS,NUMBER_OF_MESH_LAYERS, &
- NPROC_XI,NPROC_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- ner,ratio_sampling_array,r_top,r_bottom, &
- xstore,ystore,zstore,xigll,yigll,zigll, &
- shape3D,dershape2D_bottom, &
- INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME, &
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- rmin,rmax,r_moho,r_400,r_670, &
- rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- nspec_ani,c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- nspec_actually,xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
- gammaxstore,gammaystore,gammazstore,&
- nspec_stacey,rho_vp,rho_vs,iboun,iMPIcut_xi,iMPIcut_eta, &
- ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD,iproc_xi,iproc_eta, &
- nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source, &
- rotation_matrix,idoubling,doubling_index,USE_ONE_LAYER_SB,ACTUALLY_STORE_ARRAYS, &
- NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho, &
- ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot,ibelm_670_top,ibelm_670_bot, &
- normal_moho,normal_400,normal_670,jacobian2D_moho,jacobian2D_400,jacobian2D_670, &
- ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,&
- ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,offset_proc_xi,offset_proc_eta, &
- ispec_is_tiso)
-
- enddo !ilayer_loop
-
- ! define central cube in inner core
- if(INCLUDE_CENTRAL_CUBE .and. iregion_code == IREGION_INNER_CORE) &
- call create_central_cube(myrank,ichunk,ispec,iaddx,iaddy,iaddz, &
- nspec,NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,R_CENTRAL_CUBE, &
- iproc_xi,iproc_eta,NPROC_XI,NPROC_ETA,ratio_divide_central_cube, &
- iMPIcut_xi,iMPIcut_eta,iboun, &
- idoubling,iregion_code,xstore,ystore,zstore, &
- RICB,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,RTOPDDOUBLEPRIME,&
- R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- shape3D,rmin,rmax,rhostore,dvpstore,&
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,&
- gammaxstore,gammaystore,gammazstore,nspec_actually, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- nspec_ani,nspec_stacey,nspec_att,Qmu_store,tau_e_store,tau_s,T_c_source,&
- rho_vp,rho_vs,ABSORBING_CONDITIONS,ACTUALLY_STORE_ARRAYS,xigll,yigll,zigll, &
- ispec_is_tiso)
-
-
- ! check total number of spectral elements created
- if(ispec /= nspec) call exit_MPI(myrank,'ispec should equal nspec')
-
-! if any of these flags is true, the element is on a communication edge
-! this is not enough because it can also be in contact by an edge or a corner but not a full face
-! therefore we will have to fix array "is_on_a_slice_edge" later in the solver to take this into account
- is_on_a_slice_edge(:) = &
- iMPIcut_xi(1,:) .or. iMPIcut_xi(2,:) .or. &
- iMPIcut_eta(1,:) .or. iMPIcut_eta(2,:) .or. &
- iboun(1,:) .or. iboun(2,:) .or. &
- iboun(3,:) .or. iboun(4,:) .or. &
- iboun(5,:) .or. iboun(6,:)
-
-! no need to count fictitious elements on the edges
-! for which communications cannot be overlapped with calculations
- where(idoubling == IFLAG_IN_FICTITIOUS_CUBE) is_on_a_slice_edge = .false.
-
- ! only create global addressing and the MPI buffers in the first pass
- if(ipass == 1) then
-
- !uncomment: adds model smoothing for point profile models
- ! if( THREE_D_MODEL == THREE_D_MODEL_PPM ) then
- ! call smooth_model(myrank, nproc_xi,nproc_eta,&
- ! rho_vp,rho_vs,nspec_stacey, &
- ! iregion_code,xixstore,xiystore,xizstore, &
- ! etaxstore,etaystore,etazstore, &
- ! gammaxstore,gammaystore,gammazstore, &
- ! xstore,ystore,zstore,rhostore,dvpstore, &
- ! kappavstore,kappahstore,muvstore,muhstore,eta_anisostore,&
- ! nspec,HETEROGEN_3D_MANTLE, &
- ! NEX_XI,NCHUNKS,ABSORBING_CONDITIONS,PPM_V )
-
- ! allocate memory for arrays
- allocate(locval(npointot), &
- ifseg(npointot), &
- xp(npointot), &
- yp(npointot), &
- zp(npointot),stat=ier)
- if(ier /= 0) stop 'error in allocate 20'
-
- locval = 0
- ifseg = .false.
- xp = 0.d0
- yp = 0.d0
- zp = 0.d0
-
- ! we need to create a copy of the x, y and z arrays because sorting in get_global will swap
- ! these arrays and therefore destroy them
- do ispec=1,nspec
- ieoff = NGLLX * NGLLY * NGLLZ * (ispec-1)
- ilocnum = 0
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- ilocnum = ilocnum + 1
- xp(ilocnum+ieoff) = xstore(i,j,k,ispec)
- yp(ilocnum+ieoff) = ystore(i,j,k,ispec)
- zp(ilocnum+ieoff) = zstore(i,j,k,ispec)
- enddo
- enddo
- enddo
- enddo
-
- call get_global(nspec,xp,yp,zp,ibool,locval,ifseg,nglob,npointot)
-
- deallocate(xp,stat=ier); if(ier /= 0) stop 'error in deallocate'
- deallocate(yp,stat=ier); if(ier /= 0) stop 'error in deallocate'
- deallocate(zp,stat=ier); if(ier /= 0) stop 'error in deallocate'
-
- ! check that number of points found equals theoretical value
- if(nglob /= nglob_theor) then
- write(errmsg,*) 'incorrect total number of points found: myrank,nglob,nglob_theor,ipass,iregion_code = ',&
- myrank,nglob,nglob_theor,ipass,iregion_code
- call exit_MPI(myrank,errmsg)
- endif
- if(minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) call exit_MPI(myrank,'incorrect global numbering')
-
- ! creates a new indirect addressing to reduce cache misses in memory access in the solver
- ! this is *critical* to improve performance in the solver
- call get_global_indirect_addressing(nspec,nglob,ibool)
-
- ! checks again
- if(minval(ibool) /= 1 .or. maxval(ibool) /= nglob_theor) call exit_MPI(myrank,'incorrect global numbering after sorting')
-
- ! create MPI buffers
- ! arrays locval(npointot) and ifseg(npointot) used to save memory
- call get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, &
- xstore,ystore,zstore,ifseg,npointot, &
- NSPEC2D_ETA_FACE,iregion_code,npoin2D_xi)
-
- call get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, &
- xstore,ystore,zstore,ifseg,npointot, &
- NSPEC2D_XI_FACE,iregion_code,npoin2D_eta)
-
- call get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool,idoubling, &
- xstore,ystore,zstore,ifseg,npointot, &
- NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion_code)
-
- ! Stacey
- if(NCHUNKS /= 6) &
- call get_absorb(myrank,prname,iboun,nspec,nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM)
-
- ! create AVS or DX mesh data for the slices
- if(SAVE_MESH_FILES) then
- call write_AVS_DX_global_data(myrank,prname,nspec,ibool,idoubling,xstore,ystore,zstore,locval,ifseg,npointot)
-
- call write_AVS_DX_global_faces_data(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, &
- idoubling,xstore,ystore,zstore,locval,ifseg,npointot, &
- rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code)
-
- call write_AVS_DX_global_chunks_data(myrank,prname,nspec,iboun,ibool, &
- idoubling,xstore,ystore,zstore,locval,ifseg,npointot, &
- rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code)
-
- call write_AVS_DX_surface_data(myrank,prname,nspec,iboun,ibool, &
- idoubling,xstore,ystore,zstore,locval,ifseg,npointot, &
- rhostore,kappavstore,muvstore,nspl,rspl,espl,espl2, &
- ELLIPTICITY,ISOTROPIC_3D_MANTLE, &
- RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
- RMIDDLE_CRUST,ROCEAN,iregion_code)
-
- !> Hejun
- ! Output material information for all GLL points
- ! Can be use to check the mesh
- ! call write_AVS_DX_global_data_gll(prname,nspec,xstore,ystore,zstore,&
- ! rhostore,kappavstore,muvstore,Qmu_store,ATTENUATION)
- endif
-
- deallocate(locval,stat=ier); if(ier /= 0) stop 'error in deallocate'
- deallocate(ifseg,stat=ier); if(ier /= 0) stop 'error in deallocate'
-
-! only create mass matrix and save all the final arrays in the second pass
- else if(ipass == 2) then
-
- ! copy the theoretical number of points for the second pass
- nglob = nglob_theor
-
- ! count number of anisotropic elements in current region
- ! should be zero in all the regions except in the mantle
- ! (used only for checks in meshfem3D() routine)
- !nspec_tiso = count(idoubling(1:nspec) == IFLAG_220_80) + count(idoubling(1:nspec) == IFLAG_80_MOHO)
- nspec_tiso = count(ispec_is_tiso(:))
-
-!****************************************************************************************************
-! Mila
-
- if(SORT_MESH_INNER_OUTER) then
-
-!!!! David Michea: detection of the edges, coloring and permutation separately
- allocate(perm(nspec))
-
-! implement mesh coloring for GPUs if needed, to create subsets of disconnected elements
-! to remove dependencies and the need for atomic operations in the sum of elemental contributions in the solver
- if(USE_MESH_COLORING_GPU) then
-
- allocate(first_elem_number_in_this_color(MAX_NUMBER_OF_COLORS + 1))
-
- call get_perm_color_faster(is_on_a_slice_edge,ibool,perm,nspec,nglob, &
- nb_colors_outer_elements,nb_colors_inner_elements,nspec_outer,first_elem_number_in_this_color,myrank)
-
-! for the last color, the next color is fictitious and its first (fictitious) element number is nspec + 1
- first_elem_number_in_this_color(nb_colors_outer_elements + nb_colors_inner_elements + 1) = nspec + 1
-
- allocate(num_of_elems_in_this_color(nb_colors_outer_elements + nb_colors_inner_elements))
-
-! save mesh coloring
- open(unit=99,file=prname(1:len_trim(prname))//'num_of_elems_in_this_color.dat',status='unknown')
-
-! number of colors for outer elements
- write(99,*) nb_colors_outer_elements
-
-! number of colors for inner elements
- write(99,*) nb_colors_inner_elements
-
-! number of elements in each color
- do icolor = 1, nb_colors_outer_elements + nb_colors_inner_elements
- num_of_elems_in_this_color(icolor) = first_elem_number_in_this_color(icolor+1) - first_elem_number_in_this_color(icolor)
- write(99,*) num_of_elems_in_this_color(icolor)
- enddo
- close(99)
-
-! check that the sum of all the numbers of elements found in each color is equal
-! to the total number of elements in the mesh
- if(sum(num_of_elems_in_this_color) /= nspec) then
- print *,'nspec = ',nspec
- print *,'total number of elements in all the colors of the mesh = ',sum(num_of_elems_in_this_color)
- stop 'incorrect total number of elements in all the colors of the mesh'
- endif
-
-! check that the sum of all the numbers of elements found in each color for the outer elements is equal
-! to the total number of outer elements found in the mesh
- if(sum(num_of_elems_in_this_color(1:nb_colors_outer_elements)) /= nspec_outer) then
- print *,'nspec_outer = ',nspec_outer
- print *,'total number of elements in all the colors of the mesh for outer elements = ',sum(num_of_elems_in_this_color)
- stop 'incorrect total number of elements in all the colors of the mesh for outer elements'
- endif
-
- call MPI_ALLREDUCE(nspec_outer,nspec_outer_min_global,1,MPI_INTEGER,MPI_MIN,MPI_COMM_WORLD,ier)
- call MPI_ALLREDUCE(nspec_outer,nspec_outer_max_global,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
-
- deallocate(first_elem_number_in_this_color)
- deallocate(num_of_elems_in_this_color)
-
- else
-
-!! DK DK for regular C + MPI version for CPUs: do not use colors but nonetheless put all the outer elements
-!! DK DK first in order to be able to overlap non-blocking MPI communications with calculations
-
-!! DK DK nov 2010, for Rosa Badia / StarSs:
-!! no need for mesh coloring, but need to implement inner/outer subsets for non blocking MPI for StarSs
- ispec_counter = 0
- perm(:) = 0
-
-! first generate all the outer elements
- do ispec = 1,nspec
- if(is_on_a_slice_edge(ispec)) then
- ispec_counter = ispec_counter + 1
- perm(ispec) = ispec_counter
- endif
- enddo
-
-! make sure we have detected some outer elements
- if(ispec_counter <= 0) stop 'fatal error: no outer elements detected!'
-
-! store total number of outer elements
- nspec_outer = ispec_counter
-
-! then generate all the inner elements
- do ispec = 1,nspec
- if(.not. is_on_a_slice_edge(ispec)) then
- ispec_counter = ispec_counter + 1
- perm(ispec) = ispec_counter
- endif
- enddo
-
-! test that all the elements have been used once and only once
- if(ispec_counter /= nspec) stop 'fatal error: ispec_counter not equal to nspec'
-
-! do basic checks
- if(minval(perm) /= 1) stop 'minval(perm) should be 1'
- if(maxval(perm) /= nspec) stop 'maxval(perm) should be nspec'
-
- call MPI_ALLREDUCE(nspec_outer,nspec_outer_min_global,1,MPI_INTEGER,MPI_MIN,MPI_COMM_WORLD,ier)
- call MPI_ALLREDUCE(nspec_outer,nspec_outer_max_global,1,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,ier)
-
- endif
-
-!! DK DK and Manh Ha, Nov 2011: added this to use the new mesher in the CUDA or C / StarSs test codes
-
- if (myrank == 0 .and. iregion_code == IREGION_CRUST_MANTLE) then
-
-! write a header file for the Fortran version of the solver
- open(unit=99,file=prname(1:len_trim(prname))//'values_from_mesher_f90.h',status='unknown')
- write(99,*) 'integer, parameter :: NSPEC = ',nspec
- write(99,*) 'integer, parameter :: NGLOB = ',nglob
-!!! DK DK use 1000 time steps only for the scaling tests
- write(99,*) 'integer, parameter :: NSTEP = 1000 !!!!!!!!!!! ',nstep
- write(99,*) 'real(kind=4), parameter :: deltat = ',DT
- write(99,*)
- write(99,*) 'integer, parameter :: NGLOB2DMAX_XMIN_XMAX = ',npoin2D_xi
- write(99,*) 'integer, parameter :: NGLOB2DMAX_YMIN_YMAX = ',npoin2D_eta
- write(99,*) 'integer, parameter :: NGLOB2DMAX_ALL = ',max(npoin2D_xi,npoin2D_eta)
- write(99,*) 'integer, parameter :: NPROC_XI = ',NPROC_XI
- write(99,*) 'integer, parameter :: NPROC_ETA = ',NPROC_ETA
- write(99,*)
- write(99,*) '! element number of the source and of the station'
- write(99,*) '! after permutation of the elements by mesh coloring'
- write(99,*) '! and inner/outer set splitting in the mesher'
- write(99,*) 'integer, parameter :: NSPEC_SOURCE = ',perm(NSPEC/3)
- write(99,*) 'integer, parameter :: RANK_SOURCE = 0'
- write(99,*)
- write(99,*) 'integer, parameter :: RANK_STATION = (NPROC_XI*NPROC_ETA - 1)'
- write(99,*) 'integer, parameter :: NSPEC_STATION = ',perm(2*NSPEC/3)
-
-! save coordinates of the seismic source
-! write(99,*) xstore(2,2,2,10);
-! write(99,*) ystore(2,2,2,10);
-! write(99,*) zstore(2,2,2,10);
-
-! save coordinates of the seismic station
-! write(99,*) xstore(2,2,2,nspec-10);
-! write(99,*) ystore(2,2,2,nspec-10);
-! write(99,*) zstore(2,2,2,nspec-10);
- close(99)
-
-!! write a header file for the C version of the solver
- open(unit=99,file=prname(1:len_trim(prname))//'values_from_mesher_C.h',status='unknown')
- write(99,*) '#define NSPEC ',nspec
- write(99,*) '#define NGLOB ',nglob
-!! write(99,*) '#define NSTEP ',nstep
-!!! DK DK use 1000 time steps only for the scaling tests
- write(99,*) '// #define NSTEP ',nstep
- write(99,*) '#define NSTEP 1000'
-! put an "f" at the end to force single precision
- write(99,"('#define deltat ',e18.10,'f')") DT
- write(99,*) '#define NGLOB2DMAX_XMIN_XMAX ',npoin2D_xi
- write(99,*) '#define NGLOB2DMAX_YMIN_YMAX ',npoin2D_eta
- write(99,*) '#define NGLOB2DMAX_ALL ',max(npoin2D_xi,npoin2D_eta)
- write(99,*) '#define NPROC_XI ',NPROC_XI
- write(99,*) '#define NPROC_ETA ',NPROC_ETA
- write(99,*)
- write(99,*) '// element and MPI slice number of the source and the station'
- write(99,*) '// after permutation of the elements by mesh coloring'
- write(99,*) '// and inner/outer set splitting in the mesher'
- write(99,*) '#define RANK_SOURCE 0'
- write(99,*) '#define NSPEC_SOURCE ',perm(NSPEC/3)
- write(99,*)
- write(99,*) '#define RANK_STATION (NPROC_XI*NPROC_ETA - 1)'
- write(99,*) '#define NSPEC_STATION ',perm(2*NSPEC/3)
- close(99)
-
- open(unit=99,file=prname(1:len_trim(prname))//'values_from_mesher_nspec_outer.h',status='unknown')
- write(99,*) '#define NSPEC_OUTER ',nspec_outer_max_global
- write(99,*) '// NSPEC_OUTER_min = ',nspec_outer_min_global
- write(99,*) '// NSPEC_OUTER_max = ',nspec_outer_max_global
- close(99)
-
- endif
-
-!! DK DK and Manh Ha, Nov 2011: added this to use the new mesher in the CUDA or C / StarSs test codes
-
- deallocate(perm)
-
- else
-!
- print *,'SORT_MESH_INNER_OUTER must always been set to .true. even for the regular C version for CPUs'
- print *,'in order to be able to use non blocking MPI to overlap communications'
-! print *,'generating identity permutation'
-! do ispec = 1,nspec
-! perm(ispec) = ispec
-! enddo
- stop 'please set SORT_MESH_INNER_OUTER to .true. and recompile the whole code'
-
- endif
-
-!!!! David Michea: end of mesh coloring
-
-!****************************************************************************************************
-
- ! precomputes jacobian for 2d absorbing boundary surfaces
- call get_jacobian_boundaries(myrank,iboun,nspec,xstore,ystore,zstore, &
- dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
- jacobian2D_xmin,jacobian2D_xmax, &
- jacobian2D_ymin,jacobian2D_ymax, &
- jacobian2D_bottom,jacobian2D_top, &
- normal_xmin,normal_xmax, &
- normal_ymin,normal_ymax, &
- normal_bottom,normal_top, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,&
- xigll,yigll,zigll)
-
- ! allocates mass matrix in this slice (will be fully assembled in the solver)
- allocate(rmass(nglob),stat=ier)
- if(ier /= 0) stop 'error in allocate 21'
- ! allocates ocean load mass matrix as well if oceans
- if(OCEANS .and. iregion_code == IREGION_CRUST_MANTLE) then
- nglob_oceans = nglob
- else
- ! allocate dummy array if no oceans
- nglob_oceans = 1
- endif
- allocate(rmass_ocean_load(nglob_oceans),stat=ier)
- if(ier /= 0) stop 'error in allocate 22'
-
- ! creating mass matrix in this slice (will be fully assembled in the solver)
- call create_mass_matrices(myrank,nspec,idoubling,wxgll,wygll,wzgll,ibool, &
- nspec_actually,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore, &
- iregion_code,nglob,rmass,rhostore,kappavstore, &
- nglob_oceans,rmass_ocean_load,NSPEC2D_TOP,ibelm_top,jacobian2D_top, &
- xstore,ystore,zstore,RHO_OCEANS)
-
- ! save the binary files
- call save_arrays_solver(rho_vp,rho_vs,nspec_stacey, &
- prname,iregion_code,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
- xstore,ystore,zstore,rhostore,dvpstore, &
- kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- nspec_ani,c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- ibool,idoubling,is_on_a_slice_edge,rmass,rmass_ocean_load,nglob_oceans, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
- normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top, &
- jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax, &
- jacobian2D_bottom,jacobian2D_top,nspec,nglob, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- TRANSVERSE_ISOTROPY,HETEROGEN_3D_MANTLE,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,OCEANS, &
- tau_s,tau_e_store,Qmu_store,T_c_source,ATTENUATION, &
- size(tau_e_store,2),size(tau_e_store,3),size(tau_e_store,4),size(tau_e_store,5),&
- ABSORBING_CONDITIONS,SAVE_MESH_FILES,ispec_is_tiso)
-
- deallocate(rmass,stat=ier); if(ier /= 0) stop 'error in deallocate'
- deallocate(rmass_ocean_load,stat=ier); if(ier /= 0) stop 'error in deallocate'
-
- ! boundary mesh
- if (SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
- ! first check the number of surface elements are the same for Moho, 400, 670
- if (.not. SUPPRESS_CRUSTAL_MESH .and. HONOR_1D_SPHERICAL_MOHO) then
- if (ispec2D_moho_top /= NSPEC2D_MOHO .or. ispec2D_moho_bot /= NSPEC2D_MOHO) &
- call exit_mpi(myrank, 'Not the same number of Moho surface elements')
- endif
- if (ispec2D_400_top /= NSPEC2D_400 .or. ispec2D_400_bot /= NSPEC2D_400) &
- call exit_mpi(myrank,'Not the same number of 400 surface elements')
- if (ispec2D_670_top /= NSPEC2D_670 .or. ispec2D_670_bot /= NSPEC2D_670) &
- call exit_mpi(myrank,'Not the same number of 670 surface elements')
-
- ! writing surface topology databases
- open(unit=27,file=prname(1:len_trim(prname))//'boundary_disc.bin',status='unknown',form='unformatted')
- write(27) NSPEC2D_MOHO, NSPEC2D_400, NSPEC2D_670
- write(27) ibelm_moho_top
- write(27) ibelm_moho_bot
- write(27) ibelm_400_top
- write(27) ibelm_400_bot
- write(27) ibelm_670_top
- write(27) ibelm_670_bot
- write(27) normal_moho
- write(27) normal_400
- write(27) normal_670
- close(27)
- endif
-
- ! compute volume, bottom and top area of that part of the slice
- call crm_compute_volumes(volume_local,area_local_bottom,area_local_top, &
- nspec,wxgll,wygll,wzgll,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
- NSPEC2D_BOTTOM,jacobian2D_bottom,NSPEC2D_TOP,jacobian2D_top)
-
-
- else
- stop 'there cannot be more than two passes in mesh creation'
-
- endif ! end of test if first or second pass
-
- deallocate(stretch_tab)
- deallocate(perm_layer)
-
- ! deallocate these arrays after each pass because they have a different size in each pass to save memory
- deallocate(xixstore,xiystore,xizstore,stat=ier); if(ier /= 0) stop 'error in deallocate'
- deallocate(etaxstore,etaystore,etazstore,stat=ier); if(ier /= 0) stop 'error in deallocate'
- deallocate(gammaxstore,gammaystore,gammazstore,stat=ier); if(ier /= 0) stop 'error in deallocate'
-
- ! deallocate arrays
- deallocate(rhostore,dvpstore,kappavstore,kappahstore)
- deallocate(muvstore,muhstore)
- deallocate(eta_anisostore)
- deallocate(ispec_is_tiso)
- deallocate(c11store)
- deallocate(c12store)
- deallocate(c13store)
- deallocate(c14store)
- deallocate(c15store)
- deallocate(c16store)
- deallocate(c22store)
- deallocate(c23store)
- deallocate(c24store)
- deallocate(c25store)
- deallocate(c26store)
- deallocate(c33store)
- deallocate(c34store)
- deallocate(c35store)
- deallocate(c36store)
- deallocate(c44store)
- deallocate(c45store)
- deallocate(c46store)
- deallocate(c55store)
- deallocate(c56store)
- deallocate(c66store)
- deallocate(iboun)
- deallocate(xigll,yigll,zigll)
- deallocate(wxgll,wygll,wzgll)
- deallocate(shape3D,dershape3D)
- deallocate(shape2D_x,shape2D_y,shape2D_bottom,shape2D_top)
- deallocate(dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top)
- deallocate(ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax)
- deallocate(ibelm_bottom,ibelm_top)
- deallocate(jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax)
- deallocate(jacobian2D_bottom,jacobian2D_top)
- deallocate(normal_xmin,normal_xmax,normal_ymin,normal_ymax)
- deallocate(normal_bottom,normal_top)
- deallocate(iMPIcut_xi,iMPIcut_eta)
- deallocate(nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta)
- deallocate(rho_vp,rho_vs)
- deallocate(Qmu_store)
- deallocate(tau_e_store)
- deallocate(ibelm_moho_top,ibelm_moho_bot)
- deallocate(ibelm_400_top,ibelm_400_bot)
- deallocate(ibelm_670_top,ibelm_670_bot)
- deallocate(normal_moho,normal_400,normal_670)
- deallocate(jacobian2D_moho,jacobian2D_400,jacobian2D_670)
-
- end subroutine create_regions_mesh
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine crm_initialize_layers(myrank,ipass,xigll,yigll,zigll,wxgll,wygll,wzgll, &
- shape3D,dershape3D,shape2D_x,shape2D_y,shape2D_bottom,shape2D_top, &
- dershape2D_x,dershape2D_y,dershape2D_bottom,dershape2D_top, &
- iaddx,iaddy,iaddz,nspec,xstore,ystore,zstore,ibool,idoubling, &
- iboun,iMPIcut_xi,iMPIcut_eta,ispec2D_moho_top,ispec2D_moho_bot, &
- ispec2D_400_top,ispec2D_400_bot,ispec2D_670_top,ispec2D_670_bot, &
- NEX_PER_PROC_ETA,nex_eta_moho,RMOHO,R400,R670,r_moho,r_400,r_670, &
- ONE_CRUST,NUMBER_OF_MESH_LAYERS,layer_shift, &
- iregion_code,ifirst_region,ilast_region, &
- first_layer_aniso,last_layer_aniso,nb_layer_above_aniso,is_on_a_slice_edge)
-
-! create the different regions of the mesh
-
- implicit none
-
- include "constants.h"
-
- integer :: myrank,ipass
-
- double precision xigll(NGLLX),yigll(NGLLY),zigll(NGLLZ)
- double precision wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ)
-
- double precision shape3D(NGNOD,NGLLX,NGLLY,NGLLZ),dershape3D(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ)
-
- double precision shape2D_x(NGNOD2D,NGLLY,NGLLZ),shape2D_y(NGNOD2D,NGLLX,NGLLZ)
- double precision shape2D_bottom(NGNOD2D,NGLLX,NGLLY),shape2D_top(NGNOD2D,NGLLX,NGLLY)
- double precision dershape2D_x(NDIM2D,NGNOD2D,NGLLY,NGLLZ),dershape2D_y(NDIM2D,NGNOD2D,NGLLX,NGLLZ)
- double precision dershape2D_bottom(NDIM2D,NGNOD2D,NGLLX,NGLLY),dershape2D_top(NDIM2D,NGNOD2D,NGLLX,NGLLY)
-
- integer, dimension(NGNOD) :: iaddx,iaddy,iaddz
-
- integer nspec
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
- integer idoubling(nspec)
-
- logical iboun(6,nspec)
- logical iMPIcut_xi(2,nspec),iMPIcut_eta(2,nspec)
-
- integer ispec2D_moho_top,ispec2D_moho_bot,ispec2D_400_top,ispec2D_400_bot, &
- ispec2D_670_top,ispec2D_670_bot
- integer NEX_PER_PROC_ETA,nex_eta_moho
- double precision RMOHO,R400,R670
- double precision r_moho,r_400,r_670
-
- logical ONE_CRUST
- integer NUMBER_OF_MESH_LAYERS,layer_shift
-
- ! code for the four regions of the mesh
- integer iregion_code,ifirst_region,ilast_region
- integer first_layer_aniso,last_layer_aniso,nb_layer_above_aniso
-
-! this for non blocking MPI
- logical, dimension(nspec) :: is_on_a_slice_edge
-
-! set up coordinates of the Gauss-Lobatto-Legendre points
- call zwgljd(xigll,wxgll,NGLLX,GAUSSALPHA,GAUSSBETA)
- call zwgljd(yigll,wygll,NGLLY,GAUSSALPHA,GAUSSBETA)
- call zwgljd(zigll,wzgll,NGLLZ,GAUSSALPHA,GAUSSBETA)
-
-! if number of points is odd, the middle abscissa is exactly zero
- if(mod(NGLLX,2) /= 0) xigll((NGLLX-1)/2+1) = ZERO
- if(mod(NGLLY,2) /= 0) yigll((NGLLY-1)/2+1) = ZERO
- if(mod(NGLLZ,2) /= 0) zigll((NGLLZ-1)/2+1) = ZERO
-
-! get the 3-D shape functions
- call get_shape3D(myrank,shape3D,dershape3D,xigll,yigll,zigll)
-
-! get the 2-D shape functions
- call get_shape2D(myrank,shape2D_x,dershape2D_x,yigll,zigll,NGLLY,NGLLZ)
- call get_shape2D(myrank,shape2D_y,dershape2D_y,xigll,zigll,NGLLX,NGLLZ)
- call get_shape2D(myrank,shape2D_bottom,dershape2D_bottom,xigll,yigll,NGLLX,NGLLY)
- call get_shape2D(myrank,shape2D_top,dershape2D_top,xigll,yigll,NGLLX,NGLLY)
-
-! create the shape of the corner nodes of a regular mesh element
- call hex_nodes(iaddx,iaddy,iaddz)
-
-! reference element has size one here, not two
- iaddx(:) = iaddx(:) / 2
- iaddy(:) = iaddy(:) / 2
- iaddz(:) = iaddz(:) / 2
-
-! sets number of layers
- if (ONE_CRUST) then
- NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS - 1
- layer_shift = 0
- else
- NUMBER_OF_MESH_LAYERS = MAX_NUMBER_OF_MESH_LAYERS
- layer_shift = 1
- endif
-
- if (.not. ADD_4TH_DOUBLING) NUMBER_OF_MESH_LAYERS = NUMBER_OF_MESH_LAYERS - 1
-
-! define the first and last layers that define this region
- if(iregion_code == IREGION_CRUST_MANTLE) then
- ifirst_region = 1
- ilast_region = 10 + layer_shift
-
- else if(iregion_code == IREGION_OUTER_CORE) then
- ifirst_region = 11 + layer_shift
- ilast_region = NUMBER_OF_MESH_LAYERS - 1
-
- else if(iregion_code == IREGION_INNER_CORE) then
- ifirst_region = NUMBER_OF_MESH_LAYERS
- ilast_region = NUMBER_OF_MESH_LAYERS
-
- else
- call exit_MPI(myrank,'incorrect region code detected')
- endif
-
-! to consider anisotropic elements first and to build the mesh from the bottom to the top of the region
- if (ONE_CRUST) then
- first_layer_aniso=2
- last_layer_aniso=3
- nb_layer_above_aniso = 1
- else
- first_layer_aniso=3
- last_layer_aniso=4
- nb_layer_above_aniso = 2
- endif
-
-! initialize mesh arrays
- idoubling(:) = 0
-
- xstore(:,:,:,:) = 0.d0
- ystore(:,:,:,:) = 0.d0
- zstore(:,:,:,:) = 0.d0
-
- if(ipass == 1) ibool(:,:,:,:) = 0
-
- ! initialize boundary arrays
- iboun(:,:) = .false.
- iMPIcut_xi(:,:) = .false.
- iMPIcut_eta(:,:) = .false.
- is_on_a_slice_edge(:) = .false.
-
- ! boundary mesh
- ispec2D_moho_top = 0; ispec2D_moho_bot = 0
- ispec2D_400_top = 0; ispec2D_400_bot = 0
- ispec2D_670_top = 0; ispec2D_670_bot = 0
-
- nex_eta_moho = NEX_PER_PROC_ETA
-
- r_moho = RMOHO/R_EARTH; r_400 = R400 / R_EARTH; r_670 = R670/R_EARTH
-
- end subroutine crm_initialize_layers
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine crm_compute_volumes(volume_local,area_local_bottom,area_local_top, &
- nspec,wxgll,wygll,wzgll,xixstore,xiystore,xizstore, &
- etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore, &
- NSPEC2D_BOTTOM,jacobian2D_bottom,NSPEC2D_TOP,jacobian2D_top)
-
- implicit none
-
- include "constants.h"
-
- double precision :: volume_local,area_local_bottom,area_local_top
-
- integer :: nspec
- double precision :: wxgll(NGLLX),wygll(NGLLY),wzgll(NGLLZ)
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,nspec) :: &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore,gammaxstore,gammaystore,gammazstore
-
- integer :: NSPEC2D_BOTTOM,NSPEC2D_TOP
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_BOTTOM) :: jacobian2D_bottom
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NSPEC2D_TOP) :: jacobian2D_top
-
- ! local parameters
- double precision :: weight
- real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- integer :: i,j,k,ispec
-
- ! initializes
- volume_local = ZERO
- area_local_bottom = ZERO
- area_local_top = ZERO
-
- do ispec = 1,nspec
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
-
- weight = wxgll(i)*wygll(j)*wzgll(k)
-
- ! compute the jacobian
- xixl = xixstore(i,j,k,ispec)
- xiyl = xiystore(i,j,k,ispec)
- xizl = xizstore(i,j,k,ispec)
- etaxl = etaxstore(i,j,k,ispec)
- etayl = etaystore(i,j,k,ispec)
- etazl = etazstore(i,j,k,ispec)
- gammaxl = gammaxstore(i,j,k,ispec)
- gammayl = gammaystore(i,j,k,ispec)
- gammazl = gammazstore(i,j,k,ispec)
-
- jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
- - xiyl*(etaxl*gammazl-etazl*gammaxl) &
- + xizl*(etaxl*gammayl-etayl*gammaxl))
-
- volume_local = volume_local + dble(jacobianl)*weight
-
- enddo
- enddo
- enddo
- enddo
-
- do ispec = 1,NSPEC2D_BOTTOM
- do i=1,NGLLX
- do j=1,NGLLY
- weight=wxgll(i)*wygll(j)
- area_local_bottom = area_local_bottom + dble(jacobian2D_bottom(i,j,ispec))*weight
- enddo
- enddo
- enddo
-
- do ispec = 1,NSPEC2D_TOP
- do i=1,NGLLX
- do j=1,NGLLY
- weight=wxgll(i)*wygll(j)
- area_local_top = area_local_top + dble(jacobian2D_top(i,j,ispec))*weight
- enddo
- enddo
- enddo
-
-
- end subroutine crm_compute_volumes
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D.f90 2012-05-19 14:09:44 UTC (rev 20175)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D.f90 2012-05-19 16:33:09 UTC (rev 20176)
@@ -1,1253 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! April 2011
-!
-! 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.
-
- program xmeshfem3D
-
- use meshfem3D_models_par
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- !include "constants.h"
- include "precision.h"
-
-!=====================================================================!
-! !
-! meshfem3D produces a spectral element grid for the Earth. !
-! This is accomplished based upon a mapping of the face of a cube !
-! to a portion of the sphere (Ronchi et al., The Cubed Sphere). !
-! Grid density is decreased by a factor of two !
-! three times in the radial direction. !
-! !
-!=====================================================================!
-!
-! If you use this code for your own research, please cite at least one article
-! written by the developers of the package, for instance:
-!
-! @ARTICLE{TrKoLi08,
-! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
-! title = {Spectral-Element and Adjoint Methods in Seismology},
-! journal = {Communications in Computational Physics},
-! year = {2008},
-! volume = {3},
-! pages = {1-32},
-! number = {1}}
-!
-! or
-!
-! @INCOLLECTION{ChKoViCaVaFe07,
-! author = {Emmanuel Chaljub and Dimitri Komatitsch and Jean-Pierre Vilotte and
-! Yann Capdeville and Bernard Valette and Gaetano Festa},
-! title = {Spectral Element Analysis in Seismology},
-! booktitle = {Advances in Wave Propagation in Heterogeneous Media},
-! publisher = {Elsevier - Academic Press},
-! year = {2007},
-! editor = {Ru-Shan Wu and Val\'erie Maupin},
-! volume = {48},
-! series = {Advances in Geophysics},
-! pages = {365-419}}
-!
-! @ARTICLE{KoVi98,
-! author={D. Komatitsch and J. P. Vilotte},
-! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
-! journal={Bull. Seismol. Soc. Am.},
-! year=1998,
-! volume=88,
-! number=2,
-! pages={368-392}}
-!
-! @ARTICLE{KoTr99,
-! author={D. Komatitsch and J. Tromp},
-! year=1999,
-! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
-! journal={Geophys. J. Int.},
-! volume=139,
-! number=3,
-! pages={806-822},
-! doi={10.1046/j.1365-246x.1999.00967.x}}
-!
-! @ARTICLE{KoRiTr02,
-! author={D. Komatitsch and J. Ritsema and J. Tromp},
-! year=2002,
-! title={The Spectral-Element Method, {B}eowulf Computing, and Global Seismology},
-! journal={Science},
-! volume=298,
-! number=5599,
-! pages={1737-1742},
-! doi={10.1126/science.1076024}}
-!
-! @ARTICLE{KoTr02a,
-! author={D. Komatitsch and J. Tromp},
-! year=2002,
-! title={Spectral-Element Simulations of Global Seismic Wave Propagation{-I. V}alidation},
-! journal={Geophys. J. Int.},
-! volume=149,
-! number=2,
-! pages={390-412},
-! doi={10.1046/j.1365-246X.2002.01653.x}}
-!
-! @ARTICLE{KoTr02b,
-! author={D. Komatitsch and J. Tromp},
-! year=2002,
-! title={Spectral-Element Simulations of Global Seismic Wave Propagation{-II. 3-D} Models, Oceans, Rotation, and Self-Gravitation},
-! journal={Geophys. J. Int.},
-! volume=150,
-! pages={303-318},
-! number=1,
-! doi={10.1046/j.1365-246X.2002.01716.x}}
-!
-! and/or another article from http://web.univ-pau.fr/~dkomati1/publications.html
-!
-!
-! If you use the kernel capabilities of the code, please cite at least one article
-! written by the developers of the package, for instance:
-!
-! @ARTICLE{TrKoLi08,
-! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
-! title = {Spectral-Element and Adjoint Methods in Seismology},
-! journal = {Communications in Computational Physics},
-! year = {2008},
-! volume = {3},
-! pages = {1-32},
-! number = {1}}
-!
-! or
-!
-! @ARTICLE{LiTr06,
-! author={Qinya Liu and Jeroen Tromp},
-! title={Finite-frequency kernels based on adjoint methods},
-! journal={Bull. Seismol. Soc. Am.},
-! year=2006,
-! volume=96,
-! number=6,
-! pages={2383-2397},
-! doi={10.1785/0120060041}}
-!
-! If you use 3-D model S20RTS, please cite:
-!
-! @ARTICLE{RiVa00,
-! author={J. Ritsema and H. J. {Van Heijst}},
-! year=2000,
-! title={Seismic imaging of structural heterogeneity in {E}arth's mantle: Evidence for large-scale mantle flow},
-! journal={Science Progress},
-! volume=83,
-! pages={243-259}}
-!
-! Reference frame - convention:
-! ----------------------------
-!
-! The code uses the following convention for the reference frame:
-!
-! - X axis is East
-! - Y axis is North
-! - Z axis is up
-!
-! Note that this convention is different from both the Aki-Richards convention
-! and the Harvard CMT convention.
-!
-! Let us recall that the Aki-Richards convention is:
-!
-! - X axis is North
-! - Y axis is East
-! - Z axis is down
-!
-! and that the Harvard CMT convention is:
-!
-! - X axis is South
-! - Y axis is East
-! - Z axis is up
-!
-! To report bugs or suggest improvements to the code, please send an email
-! to Jeroen Tromp <jtromp AT princeton.edu> and/or use our online
-! bug tracking system at http://www.geodynamics.org/roundup .
-!
-! Evolution of the code:
-! ---------------------
-!
-! v. 5.1, Dimitri Komatitsch, University of Toulouse, France and Ebru Bozdag, Princeton University, USA, February 2011:
-! non blocking MPI for much better scaling on large clusters;
-! new convention for the name of seismograms, to conform to the IRIS standard;
-! new directory structure
-!
-! v. 5.0 aka Tiger, many developers some with Princeton Tiger logo on their shirts, February 2010:
-! new moho mesh stretching honoring crust2.0 moho depths,
-! new attenuation assignment, new SAC headers, new general crustal models,
-! faster performance due to Deville routines and enhanced loop unrolling,
-! slight changes in code structure
-!
-! v. 4.0 David Michea and Dimitri Komatitsch, University of Pau, France, February 2008:
-! new doubling brick in the mesh, new perfectly load-balanced mesh,
-! more flexible routines for mesh design, new inflated central cube
-! with optimized shape, far fewer mesh files saved by the mesher,
-! global arrays sorted to speed up the simulation, seismos can be
-! written by the master, one more doubling level at the bottom
-! of the outer core if needed (off by default)
-!
-! v. 3.6 Many people, many affiliations, September 2006:
-! adjoint and kernel calculations, fixed IASP91 model,
-! added AK135 and 1066a, fixed topography/bathymetry routine,
-! new attenuation routines, faster and better I/Os on very large
-! systems, many small improvements and bug fixes, new "configure"
-! script, new user's manual etc.
-!
-! v. 3.5 Dimitri Komatitsch, Brian Savage and Jeroen Tromp, Caltech, July 2004:
-! any size of chunk, 3D attenuation, case of two chunks,
-! more precise topography/bathymetry model, new Par_file structure
-!
-! v. 3.4 Dimitri Komatitsch and Jeroen Tromp, Caltech, August 2003:
-! merged global and regional codes, no iterations in fluid, better movies
-!
-! v. 3.3 Dimitri Komatitsch, Caltech, September 2002:
-! flexible mesh doubling in outer core, inlined code, OpenDX support
-!
-! v. 3.2 Jeroen Tromp, Caltech, July 2002:
-! multiple sources and flexible PREM reading
-!
-! v. 3.1 Dimitri Komatitsch, Caltech, June 2002:
-! vectorized loops in solver and merged central cube
-!
-! v. 3.0 Dimitri Komatitsch and Jeroen Tromp, Caltech, May 2002:
-! ported to SGI and Compaq, double precision solver, more general anisotropy
-!
-! v. 2.3 Dimitri Komatitsch and Jeroen Tromp, Caltech, August 2001:
-! gravity, rotation, oceans and 3-D models
-!
-! v. 2.2 Dimitri Komatitsch and Jeroen Tromp, Caltech, USA, March 2001:
-! final MPI package
-!
-! v. 2.0 Dimitri Komatitsch, Harvard, USA, January 2000: MPI code for the globe
-!
-! v. 1.0 Dimitri Komatitsch, UNAM, Mexico, June 1999: first MPI code for a chunk
-!
-! Jeroen Tromp and Dimitri Komatitsch, Harvard, USA, July 1998: first chunk solver using OpenMP on a Sun machine
-!
-! Dimitri Komatitsch, IPG Paris, France, December 1996: first 3-D solver for the CM-5 Connection Machine,
-! parallelized on 128 processors using Connection Machine Fortran
-!
-! From Dahlen and Tromp (1998):
-! ----------------------------
-!
-! Gravity is approximated by solving eq (3.259) without the Phi_E' term
-! The ellipsoidal reference model is that of section 14.1
-! The transversely isotropic expression for PREM is that of eq (8.190)
-!
-! Formulation in the fluid (acoustic) outer core:
-! -----------------------------------------------
-!
-! In case of an acoustic medium, a displacement potential Chi is used
-! as in Chaljub and Valette, Geophysical Journal International, vol. 158,
-! p. 131-141 (2004) and *NOT* a velocity potential as in Komatitsch and Tromp,
-! Geophysical Journal International, vol. 150, p. 303-318 (2002).
-! This permits acoustic-elastic coupling based on a non-iterative time scheme.
-! Displacement if we ignore gravity is then: u = grad(Chi)
-! (In the context of the Cowling approximation displacement is
-! u = grad(rho * Chi) / rho, *not* u = grad(Chi).)
-! Velocity is then: v = grad(Chi_dot) (Chi_dot being the time derivative of Chi)
-! and pressure is: p = - rho * Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
-! The source in an acoustic element is a pressure source.
-! The potential in the outer core is called displ_outer_core for simplicity.
-! Its first time derivative is called veloc_outer_core.
-! Its second time derivative is called accel_outer_core.
-
-
-! correct number of spectral elements in each block depending on chunk type
- integer nspec_tiso,npointot
-
-! parameters needed to store the radii of the grid points
-! in the spherically symmetric Earth
- integer, dimension(:), allocatable :: idoubling
- integer, dimension(:,:,:,:), allocatable :: ibool
-
-! arrays with the mesh in double precision
- double precision, dimension(:,:,:,:), allocatable :: xstore,ystore,zstore
-
-! proc numbers for MPI
- integer myrank,sizeprocs,ier
-
-! check area and volume of the final mesh
- double precision area_local_bottom
- double precision area_local_top
- double precision volume_local,volume_total
-
- !integer iprocnum
-
-! for loop on all the slices
- integer iregion_code
- integer iproc_xi,iproc_eta,ichunk
-
-! rotation matrix from Euler angles
- double precision, dimension(NDIM,NDIM) :: rotation_matrix
-
- double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
-
-! for some statistics for the mesh
- integer numelem_crust_mantle,numelem_outer_core,numelem_inner_core
- integer numelem_total
-
-! timer MPI
- double precision time_start,tCPU
-
-! addressing for all the slices
- integer, dimension(:), allocatable :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
- integer, dimension(:,:,:), allocatable :: addressing
-
-! parameters read from parameter file
- integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
-
- double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
- RMOHO_FICTITIOUS_IN_MESHER
-
- logical MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
- RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
- SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
-
- character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL
-
-! parameters deduced from parameters read from file
- integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
-
- integer, external :: err_occurred
-
-! this for all the regions
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP,NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- NGLOB
-
-! computed in read_compute_parameters
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
-
-! memory size of all the static arrays
- double precision :: static_memory_size
-
- integer :: ipass
-
- integer :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
- NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
- NSPEC_INNER_CORE_ATTENUATION, &
- NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
- NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
- NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
- NSPEC_CRUST_MANTLE_ADJOINT, &
- NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
- NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
- NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
- NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
- NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION
-
-! this for the different corners of the slice (which are different if the superbrick is cut)
-! 1 : xi_min, eta_min
-! 2 : xi_max, eta_min
-! 3 : xi_max, eta_max
-! 4 : xi_min, eta_max
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
-
-! 1 -> min, 2 -> max
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE
-
- integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
- integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
- integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL_TEMP
-
-! this for non blocking MPI
- logical, dimension(:), allocatable :: is_on_a_slice_edge
-
-! ************** PROGRAM STARTS HERE **************
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-! trivia about the programming style adopted here
-!
-! note 1: in general, we do not use modules in the fortran codes. this seems to
-! be mainly a performance reason. changing the codes to adopt modules
-! will have to prove that it performs as fast as it does without now.
-!
-! another reason why modules are avoided, is to make the code thread safe.
-! having different threads access the same data structure and modifying it at the same time
-! would lead to problems. passing arguments is a way to avoid such complications.
-!
-! however, the mesher makes one exception here: it uses the
-! module "meshfem3D_models_par" defined in the 'meshfem3D_models.f90' file.
-! the exception is based on the fact, that when one wants to incorporate
-! a new 3D/1D velocity model, it became tedious to change so many routines hardly
-! related to any model specific need.
-!
-! note 2: adding a new velocity model should become easier. the module tries to help with
-! that task. basically, you would follow the comments "ADD YOUR MODEL HERE"
-! to have an idea where you will have to put some new code:
-!
-! - meshfem3D_models.f90: main file for models
-! put your model structure into the module "meshfem3D_models_par"
-! and add your specific routine calls to get 1D/3D/attenuation values.
-!
-! - get_model_parameters.f90:
-! set your specific model flags and radii
-!
-! - read_compute_parameters.f90:
-! some models need to explicitly set smaller time steps which
-! can be done in routine rcp_set_timestep_and_layers()
-!
-! - add your model implementation into a new file named model_***.f90:
-! in general, this file should have as first routine the model_***_broadcast() routine
-! implemented which deals with passing the model structure to all processes.
-! this involves reading in model specific data which is normally put in directory DATA/
-! then follows a routine that returns the velocity values
-! (as perturbation to the associated 1D reference model) for a given point location.
-!
-! finally, in order to compile the new mesher with your new file(s),
-! you will add it to the list in the 'Makefile.in' file and run
-! `configure` to recreate a new Makefile.
-!
-!
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-
-! initialize the MPI communicator and start the NPROCTOT MPI processes.
- call MPI_INIT(ier)
-
-! sizeprocs returns number of processes started (should be equal to NPROCTOT).
-! myrank is the rank of each process, between 0 and NPROCTOT-1.
-! as usual in MPI, process 0 is in charge of coordinating everything
-! and also takes care of the main output
-! do not create anything for the inner core here, will be done in solver
- call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
- call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
-! open main output file, only written to by process 0
- if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) &
- open(unit=IMAIN,file=trim(OUTPUT_FILES)//'/output_mesher.txt',status='unknown')
-
-! get MPI starting time
- time_start = MPI_WTIME()
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) '****************************'
- write(IMAIN,*) '*** Specfem3D MPI Mesher ***'
- write(IMAIN,*) '****************************'
- write(IMAIN,*)
- endif
-
- if (myrank==0) then
- ! reads the parameter file and computes additional parameters
- call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
- TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
- ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
- MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
- PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
- ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC,NSPEC2D_XI,NSPEC2D_ETA,NSPEC2DMAX_XMIN_XMAX, &
- NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top,&
- this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
- OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube, &
- HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE, &
- USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
-
- if(err_occurred() /= 0) &
- call exit_MPI(myrank,'an error occurred while reading the parameter file')
-
- endif
-
- ! distributes parameters from master to all processes
- call broadcast_compute_parameters(myrank,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
- NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
- NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
- NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
- NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
- NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
- MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
- DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
- RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
- MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
- RMOHO_FICTITIOUS_IN_MESHER, &
- MOVIE_SURFACE,MOVIE_VOLUME,RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
- SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
- SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT, &
- OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
- ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE, &
- LOCAL_PATH,MODEL, &
- NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
- ratio_sampling_array, ner, doubling_index,r_bottom,r_top, &
- this_region_has_a_doubling,rmins,rmaxs, &
- ratio_divide_central_cube,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
- REFERENCE_1D_MODEL,THREE_D_MODEL,ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
- HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
- ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
- ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE,NOISE_TOMOGRAPHY)
-
- ! check that the code is running with the requested number of processes
- if(sizeprocs /= NPROCTOT) call exit_MPI(myrank,'wrong number of MPI processes')
-
- ! compute rotation matrix from Euler angles
- ANGULAR_WIDTH_XI_RAD = ANGULAR_WIDTH_XI_IN_DEGREES * PI / 180.d0
- ANGULAR_WIDTH_ETA_RAD = ANGULAR_WIDTH_ETA_IN_DEGREES * PI / 180.d0
- if(NCHUNKS /= 6) call euler_angles(rotation_matrix,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH)
-
- ! dynamic allocation of mesh arrays
- allocate(addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1))
- allocate(ichunk_slice(0:NPROCTOT-1))
- allocate(iproc_xi_slice(0:NPROCTOT-1))
- allocate(iproc_eta_slice(0:NPROCTOT-1))
-
- ! creates global slice addressing for solver
- call meshfem3D_create_addressing(myrank,NCHUNKS,NPROC,NPROC_ETA,NPROC_XI,NPROCTOT, &
- addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice, &
- OUTPUT_FILES)
-
-
- ! this for the different counters (which are now different if the superbrick is cut in the outer core)
- call meshfem3D_setup_counters(myrank, &
- NSPEC1D_RADIAL,NSPEC2D_XI,NSPEC2D_ETA,NGLOB1D_RADIAL, &
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
- NPROCTOT,iproc_xi_slice,iproc_eta_slice, &
- NSPEC1D_RADIAL_CORNER,NSPEC2D_XI_FACE, &
- NSPEC2D_ETA_FACE,NGLOB1D_RADIAL_CORNER)
-
- ! user output
- if(myrank == 0) call meshfem3D_output_info(myrank,sizeprocs,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT, &
- R_CENTRAL_CUBE)
-
- ! distributes 3D models
- call meshfem3D_models_broadcast(myrank,NSPEC, &
- MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,&
- R80,R220,R670,RCMB,RICB)
-
-
- if(myrank == 0 ) then
- write(IMAIN,*)
- write(IMAIN,*) 'model setup successfully read in'
- write(IMAIN,*)
- endif
-
- ! get addressing for this process
- ichunk = ichunk_slice(myrank)
- iproc_xi = iproc_xi_slice(myrank)
- iproc_eta = iproc_eta_slice(myrank)
-
- ! volume of the slice
- volume_total = ZERO
-
- ! make sure everybody is synchronized
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
-!----
-!---- loop on all the regions of the mesh
-!----
-
- ! number of regions in full Earth
- do iregion_code = 1,MAX_NUM_REGIONS
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) '*******************************************'
- write(IMAIN,*) 'creating mesh in region ',iregion_code
- select case(iregion_code)
- case(IREGION_CRUST_MANTLE)
- write(IMAIN,*) 'this region is the crust and mantle'
- case(IREGION_OUTER_CORE)
- write(IMAIN,*) 'this region is the outer core'
- case(IREGION_INNER_CORE)
- write(IMAIN,*) 'this region is the inner core'
- case default
- call exit_MPI(myrank,'incorrect region code')
- end select
- write(IMAIN,*) '*******************************************'
- write(IMAIN,*)
- endif
-
- ! compute maximum number of points
- npointot = NSPEC(iregion_code) * NGLLX * NGLLY * NGLLZ
-
- ! use dynamic allocation to allocate memory for arrays
- allocate(idoubling(NSPEC(iregion_code)))
- allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)))
- allocate(xstore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)))
- allocate(ystore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)))
- allocate(zstore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)))
-
-! this for non blocking MPI
- allocate(is_on_a_slice_edge(NSPEC(iregion_code)))
-
- ! create all the regions of the mesh
- ! perform two passes in this part to be able to save memory
- do ipass = 1,2
-
- call create_regions_mesh(iregion_code,ibool,idoubling,is_on_a_slice_edge, &
- xstore,ystore,zstore,rmins,rmaxs, &
- iproc_xi,iproc_eta,ichunk,NSPEC(iregion_code),nspec_tiso, &
- volume_local,area_local_bottom,area_local_top, &
- nglob(iregion_code),npointot, &
- NSTEP,DT, &
- NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- NSPEC2DMAX_XMIN_XMAX(iregion_code),NSPEC2DMAX_YMIN_YMAX(iregion_code), &
- NSPEC2D_BOTTOM(iregion_code),NSPEC2D_TOP(iregion_code), &
- NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE, &
- NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
- myrank,LOCAL_PATH,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD, &
- SAVE_MESH_FILES,NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
- R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,&
- RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
- ner,ratio_sampling_array,doubling_index,r_bottom,r_top,&
- this_region_has_a_doubling,ipass,ratio_divide_central_cube, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
- mod(iproc_xi_slice(myrank),2),mod(iproc_eta_slice(myrank),2))
-
- enddo
-
- ! checks number of anisotropic elements found in the mantle
- if(iregion_code /= IREGION_CRUST_MANTLE .and. nspec_tiso /= 0 ) &
- call exit_MPI(myrank,'found anisotropic elements outside of the mantle')
-
- if( TRANSVERSE_ISOTROPY ) then
- if(iregion_code == IREGION_CRUST_MANTLE .and. nspec_tiso == 0) &
- call exit_MPI(myrank,'found no anisotropic elements in the mantle')
- endif
-
- ! computes total area and volume
- call meshfem3D_compute_area(myrank,NCHUNKS,iregion_code, &
- area_local_bottom,area_local_top,&
- volume_local,volume_total, &
- RCMB,RICB,R_CENTRAL_CUBE,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES)
-
- ! create chunk buffers if more than one chunk
- if(NCHUNKS > 1) then
- call create_chunk_buffers(iregion_code,NSPEC(iregion_code),ibool,idoubling, &
- xstore,ystore,zstore, &
- nglob(iregion_code), &
- NSPEC2DMAX_XMIN_XMAX(iregion_code),NSPEC2DMAX_YMIN_YMAX(iregion_code), &
- NPROC_XI,NPROC_ETA,NPROC,NPROCTOT, &
- NGLOB1D_RADIAL_CORNER,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
- NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code), &
- myrank,LOCAL_PATH,addressing, &
- ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS)
- else
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'only one chunk, no need to create chunk buffers'
- write(IMAIN,*)
- endif
- endif
-
- ! deallocate arrays used for that region
- deallocate(idoubling)
- deallocate(ibool)
- deallocate(xstore)
- deallocate(ystore)
- deallocate(zstore)
-
-! this for non blocking MPI
- deallocate(is_on_a_slice_edge)
-
- ! make sure everybody is synchronized
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
-! end of loop on all the regions
- enddo
-
- if(myrank == 0) then
- ! check volume of chunk
- write(IMAIN,*)
- write(IMAIN,*) 'calculated volume: ',volume_total
- if((NCHUNKS == 6 .or. (abs(ANGULAR_WIDTH_XI_IN_DEGREES - 90.d0) < TINYVAL .and. &
- abs(ANGULAR_WIDTH_ETA_IN_DEGREES - 90.d0) < TINYVAL)) .and. .not. TOPOGRAPHY) then
- ! take the central cube into account
- ! it is counted 6 times because of the fictitious elements
- if(INCLUDE_CENTRAL_CUBE) then
- write(IMAIN,*) ' similar volume: ', &
- dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)+5.*(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0
- else
- write(IMAIN,*) ' similar volume: ', &
- dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)-(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0
- endif
- write(IMAIN,*) ' (but not exact because the central cube is purposely inflated)'
- endif
- endif
-
-
-!--- print number of points and elements in the mesh for each region
-
- if(myrank == 0) then
-
- numelem_crust_mantle = NSPEC(IREGION_CRUST_MANTLE)
- numelem_outer_core = NSPEC(IREGION_OUTER_CORE)
- numelem_inner_core = NSPEC(IREGION_INNER_CORE)
-
- numelem_total = numelem_crust_mantle + numelem_outer_core + numelem_inner_core
-
- write(IMAIN,*)
- write(IMAIN,*) 'Repartition of elements in regions:'
- write(IMAIN,*) '----------------------------------'
- write(IMAIN,*)
- write(IMAIN,*) 'total number of elements in each slice: ',numelem_total
- write(IMAIN,*)
- write(IMAIN,*) ' - crust and mantle: ',sngl(100.d0*dble(numelem_crust_mantle)/dble(numelem_total)),' %'
- write(IMAIN,*) ' - outer core: ',sngl(100.d0*dble(numelem_outer_core)/dble(numelem_total)),' %'
- write(IMAIN,*) ' - inner core: ',sngl(100.d0*dble(numelem_inner_core)/dble(numelem_total)),' %'
- write(IMAIN,*)
- write(IMAIN,*) 'for some mesh statistics, see comments in file OUTPUT_FILES/values_from_mesher.h'
- write(IMAIN,*)
-
- ! load balancing
- write(IMAIN,*) 'Load balancing = 100 % by definition'
- write(IMAIN,*)
-
- write(IMAIN,*)
- write(IMAIN,*) 'total number of time steps in the solver will be: ',NSTEP
- write(IMAIN,*)
-
- write(IMAIN,*)
- write(IMAIN,*) 'time-stepping of the solver will be: ',DT
- 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,*)
-
- ! evaluate the amount of static memory needed by the solver
- call memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MANTLE,&
- TRANSVERSE_ISOTROPY,ANISOTROPIC_INNER_CORE,ROTATION,&
- ONE_CRUST,doubling_index,this_region_has_a_doubling,&
- ner,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_sampling_array,&
- NSPEC,nglob,SIMULATION_TYPE,MOVIE_VOLUME,SAVE_FORWARD, &
- NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
- NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
- NSPEC_INNER_CORE_ATTENUATION, &
- NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
- NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
- NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
- NSPEC_CRUST_MANTLE_ADJOINT, &
- NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
- NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
- NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
- NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
- NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION,static_memory_size)
-
- NGLOB1D_RADIAL_TEMP(:) = &
- (/maxval(NGLOB1D_RADIAL_CORNER(1,:)),maxval(NGLOB1D_RADIAL_CORNER(2,:)),maxval(NGLOB1D_RADIAL_CORNER(3,:))/)
-
- ! create include file for the solver
- call save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, &
- TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
- ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS,ATTENUATION,ATTENUATION_3D, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,NCHUNKS, &
- INCLUDE_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,&
- CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,NSOURCES,NSTEP, &
- static_memory_size,NGLOB1D_RADIAL_TEMP, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NSPEC2D_TOP,NSPEC2D_BOTTOM, &
- NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX, &
- NPROC_XI,NPROC_ETA, &
- NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
- NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
- NSPEC_INNER_CORE_ATTENUATION, &
- NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
- NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
- NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
- NSPEC_CRUST_MANTLE_ADJOINT, &
- NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
- NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
- NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
- NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
- NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION, &
- SIMULATION_TYPE,SAVE_FORWARD,MOVIE_VOLUME,NOISE_TOMOGRAPHY)
-
- endif ! end of section executed by main process only
-
- ! deallocate arrays used for mesh generation
- deallocate(addressing)
- deallocate(ichunk_slice)
- deallocate(iproc_xi_slice)
- deallocate(iproc_eta_slice)
-
- ! elapsed time since beginning of mesh generation
- if(myrank == 0) then
- tCPU = MPI_WTIME() - time_start
- write(IMAIN,*)
- write(IMAIN,*) 'Elapsed time for mesh generation and buffer creation in seconds = ',tCPU
- write(IMAIN,*) 'End of mesh generation'
- write(IMAIN,*)
- ! close main output file
- close(IMAIN)
- endif
-
- ! synchronize all the processes to make sure everybody has finished
- call MPI_BARRIER(MPI_COMM_WORLD,ier)
-
- ! stop all the MPI processes, and exit
- call MPI_FINALIZE(ier)
-
- end program xmeshfem3D
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine meshfem3D_create_addressing(myrank,NCHUNKS,NPROC,NPROC_ETA,NPROC_XI,NPROCTOT, &
- addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice, &
- OUTPUT_FILES)
-
- implicit none
-
- include "constants.h"
-
- integer :: myrank,NCHUNKS,NPROC,NPROC_ETA,NPROC_XI,NPROCTOT
-
- integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1) :: addressing
- integer, dimension(0:NPROCTOT-1) :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
-
- character(len=150) OUTPUT_FILES
-
- ! local parameters
- integer ichunk,iproc_eta,iproc_xi,iprocnum,ier
-
- ! initializes
- addressing(:,:,:) = 0
- ichunk_slice(:) = 0
- iproc_xi_slice(:) = 0
- iproc_eta_slice(:) = 0
-
- ! loop on all the chunks to create global slice addressing for solver
- if(myrank == 0) then
- open(unit=IOUT,file=trim(OUTPUT_FILES)//'/addressing.txt',status='unknown',iostat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error opening addressing.txt')
- write(IMAIN,*) 'creating global slice addressing'
- write(IMAIN,*)
- endif
-
- do ichunk = 1,NCHUNKS
- do iproc_eta=0,NPROC_ETA-1
- do iproc_xi=0,NPROC_XI-1
- iprocnum = (ichunk-1)*NPROC + iproc_eta * NPROC_XI + iproc_xi
- addressing(ichunk,iproc_xi,iproc_eta) = iprocnum
- ichunk_slice(iprocnum) = ichunk
- iproc_xi_slice(iprocnum) = iproc_xi
- iproc_eta_slice(iprocnum) = iproc_eta
- if(myrank == 0) write(IOUT,*) iprocnum,ichunk,iproc_xi,iproc_eta
- enddo
- enddo
- enddo
-
- if(myrank == 0) close(IOUT)
-
- end subroutine meshfem3D_create_addressing
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine meshfem3D_setup_counters(myrank, &
- NSPEC1D_RADIAL,NSPEC2D_XI,NSPEC2D_ETA,NGLOB1D_RADIAL, &
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
- NPROCTOT,iproc_xi_slice,iproc_eta_slice, &
- NSPEC1D_RADIAL_CORNER,NSPEC2D_XI_FACE, &
- NSPEC2D_ETA_FACE,NGLOB1D_RADIAL_CORNER)
-
-! returns: NSPEC1D_RADIAL_CORNER,NSPEC2D_XI_FACE,
-! NSPEC2D_ETA_FACE,NGLOB1D_RADIAL_CORNER
-
- implicit none
-
- include "constants.h"
-
- integer myrank
-
-! this for all the regions
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC2D_XI,NSPEC2D_ETA, &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL
-
- integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
- integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
-
- ! addressing for all the slices
- integer :: NPROCTOT
- integer, dimension(0:NPROCTOT-1) :: iproc_xi_slice,iproc_eta_slice
-
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
-
-! this for the different corners of the slice (which are different if the superbrick is cut)
-! 1 : xi_min, eta_min
-! 2 : xi_max, eta_min
-! 3 : xi_max, eta_max
-! 4 : xi_min, eta_max
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: &
- NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
-! 1 -> min, 2 -> max
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE
-
-
- ! local parameters
- integer :: iregion
-
- do iregion=1,MAX_NUM_REGIONS
- NSPEC1D_RADIAL_CORNER(iregion,:) = NSPEC1D_RADIAL(iregion)
- NSPEC2D_XI_FACE(iregion,:) = NSPEC2D_XI(iregion)
- NSPEC2D_ETA_FACE(iregion,:) = NSPEC2D_ETA(iregion)
- NGLOB1D_RADIAL_CORNER(iregion,:) = NGLOB1D_RADIAL(iregion)
- enddo
-
- if (CUT_SUPERBRICK_XI) then
- if (CUT_SUPERBRICK_ETA) then
- if (mod(iproc_xi_slice(myrank),2) == 0) then
- if (mod(iproc_eta_slice(myrank),2) == 0) then
- NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
- NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
- NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) &
- + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
- NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
- NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) &
- + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- else
- if (mod(iproc_eta_slice(myrank),2) == 0) then
- NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,3)
- NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,3)
- NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,3)
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) &
- + (DIFF_NSPEC1D_RADIAL(:,3)*(NGLLZ-1))
- else
- NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,4)
- NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,4)
- NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,4)
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) &
- + (DIFF_NSPEC1D_RADIAL(:,4)*(NGLLZ-1))
- endif
- endif
- else
- if (mod(iproc_xi_slice(myrank),2) == 0) then
- NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
- NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
- NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) &
- + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
- NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
- NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) &
- + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- endif
- else
- if (CUT_SUPERBRICK_ETA) then
- if (mod(iproc_eta_slice(myrank),2) == 0) then
- NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
- NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
- NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) &
- + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
- else
- NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
- NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
- NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
- NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) &
- + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
- endif
- endif
- endif
-
- end subroutine meshfem3D_setup_counters
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine meshfem3D_output_info(myrank,sizeprocs,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT,&
- R_CENTRAL_CUBE)
-
- use meshfem3D_models_par
-
- implicit none
-
- integer :: myrank,sizeprocs,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT
- double precision :: R_CENTRAL_CUBE
-
- write(IMAIN,*) 'This is process ',myrank
- write(IMAIN,*) 'There are ',sizeprocs,' MPI processes'
- write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
- write(IMAIN,*)
- write(IMAIN,*) 'There are ',NEX_XI,' elements along xi in each chunk'
- write(IMAIN,*) 'There are ',NEX_ETA,' elements along eta in each chunk'
- write(IMAIN,*)
- write(IMAIN,*) 'There are ',NPROC_XI,' slices along xi in each chunk'
- write(IMAIN,*) 'There are ',NPROC_ETA,' slices along eta in each chunk'
- write(IMAIN,*) 'There is a total of ',NPROC,' slices in each chunk'
- write(IMAIN,*) 'There are ',NCHUNKS,' chunks in the global mesh'
- write(IMAIN,*) 'There is a total of ',NPROCTOT,' slices in the global mesh'
- write(IMAIN,*)
- write(IMAIN,*) 'NGLLX = ',NGLLX
- write(IMAIN,*) 'NGLLY = ',NGLLY
- write(IMAIN,*) 'NGLLZ = ',NGLLZ
- write(IMAIN,*)
- write(IMAIN,*) 'Shape functions defined by NGNOD = ',NGNOD,' control nodes'
- write(IMAIN,*) 'Surface shape functions defined by NGNOD2D = ',NGNOD2D,' control nodes'
- write(IMAIN,*)
- write(IMAIN,*)
- write(IMAIN,*)
- if(ELLIPTICITY) then
- write(IMAIN,*) 'incorporating ellipticity'
- else
- write(IMAIN,*) 'no ellipticity'
- endif
- write(IMAIN,*)
- if(TOPOGRAPHY) then
- write(IMAIN,*) 'incorporating surface topography'
- else
- write(IMAIN,*) 'no surface topography'
- endif
- write(IMAIN,*)
- if(ISOTROPIC_3D_MANTLE) then
- write(IMAIN,*) 'incorporating 3-D lateral variations'
- else
- write(IMAIN,*) 'no 3-D lateral variations'
- endif
- write(IMAIN,*)
- if(HETEROGEN_3D_MANTLE) then
- write(IMAIN,*) 'incorporating heterogeneities in the mantle'
- else
- write(IMAIN,*) 'no heterogeneities in the mantle'
- endif
- write(IMAIN,*)
- if(CRUSTAL) then
- write(IMAIN,*) 'incorporating crustal variations'
- else
- write(IMAIN,*) 'no crustal variations'
- endif
- write(IMAIN,*)
- if(ONE_CRUST) then
- write(IMAIN,*) 'using one layer only in PREM crust'
- else
- write(IMAIN,*) 'using unmodified 1D crustal model with two layers'
- endif
- write(IMAIN,*)
- if(GRAVITY) then
- write(IMAIN,*) 'incorporating self-gravitation (Cowling approximation)'
- else
- write(IMAIN,*) 'no self-gravitation'
- endif
- write(IMAIN,*)
- if(ROTATION) then
- write(IMAIN,*) 'incorporating rotation'
- else
- write(IMAIN,*) 'no rotation'
- endif
- write(IMAIN,*)
- if(TRANSVERSE_ISOTROPY) then
- write(IMAIN,*) 'incorporating anisotropy'
- else
- write(IMAIN,*) 'no anisotropy'
- endif
- write(IMAIN,*)
- if(ATTENUATION) then
- write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids'
- if(ATTENUATION_3D) write(IMAIN,*)'using 3D attenuation'
- 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
- write(IMAIN,*)
- if(ANISOTROPIC_INNER_CORE) then
- write(IMAIN,*) 'incorporating anisotropic inner core'
- else
- write(IMAIN,*) 'no inner-core anisotropy'
- endif
- write(IMAIN,*)
- if(ANISOTROPIC_3D_MANTLE) then
- write(IMAIN,*) 'incorporating anisotropic mantle'
- else
- write(IMAIN,*) 'no general mantle anisotropy'
- endif
- write(IMAIN,*)
- write(IMAIN,*) 'Reference radius of the Earth used is ',R_EARTH_KM,' km'
- write(IMAIN,*)
- write(IMAIN,*) 'Central cube is at a radius of ',R_CENTRAL_CUBE/1000.d0,' km'
-
- end subroutine meshfem3D_output_info
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine meshfem3D_compute_area(myrank,NCHUNKS,iregion_code, &
- area_local_bottom,area_local_top,&
- volume_local,volume_total, &
- RCMB,RICB,R_CENTRAL_CUBE,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES)
-
- use meshfem3D_models_par
-
- implicit none
-
- include 'mpif.h'
-
- integer :: myrank,NCHUNKS,iregion_code
-
- double precision :: area_local_bottom,area_local_top,volume_local,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES
- double precision :: volume_total
- double precision :: RCMB,RICB,R_CENTRAL_CUBE
-
- ! local parameters
- double precision :: volume_total_region,area_total_bottom,area_total_top
- integer :: ier
-
- ! use MPI reduction to compute total area and volume
- volume_total_region = ZERO
- area_total_bottom = ZERO
- area_total_top = ZERO
- call MPI_REDUCE(area_local_bottom,area_total_bottom,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
- MPI_COMM_WORLD,ier)
- call MPI_REDUCE(area_local_top,area_total_top,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
- MPI_COMM_WORLD,ier)
- call MPI_REDUCE(volume_local,volume_total_region,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
- MPI_COMM_WORLD,ier)
-
- if(myrank == 0) then
- ! sum volume over all the regions
- volume_total = volume_total + volume_total_region
-
- ! check volume of chunk, and bottom and top area
- write(IMAIN,*)
- write(IMAIN,*) ' calculated top area: ',area_total_top
-
- ! compare to exact theoretical value
- if((NCHUNKS == 6 .or. (abs(ANGULAR_WIDTH_XI_IN_DEGREES - 90.d0) < TINYVAL .and. &
- abs(ANGULAR_WIDTH_ETA_IN_DEGREES - 90.d0) < TINYVAL)) .and. .not. TOPOGRAPHY) then
- select case(iregion_code)
- case(IREGION_CRUST_MANTLE)
- write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*R_UNIT_SPHERE**2
- case(IREGION_OUTER_CORE)
- write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RCMB/R_EARTH)**2
- case(IREGION_INNER_CORE)
- write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RICB/R_EARTH)**2
- case default
- call exit_MPI(myrank,'incorrect region code')
- end select
- endif
-
- write(IMAIN,*)
- write(IMAIN,*) 'calculated bottom area: ',area_total_bottom
-
- ! compare to exact theoretical value
- if((NCHUNKS == 6 .or. (abs(ANGULAR_WIDTH_XI_IN_DEGREES - 90.d0) < TINYVAL .and. &
- abs(ANGULAR_WIDTH_ETA_IN_DEGREES - 90.d0) < TINYVAL)) .and. .not. TOPOGRAPHY) then
- select case(iregion_code)
- case(IREGION_CRUST_MANTLE)
- write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RCMB/R_EARTH)**2
- case(IREGION_OUTER_CORE)
- write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RICB/R_EARTH)**2
- case(IREGION_INNER_CORE)
- write(IMAIN,*) ' similar (but not exact) area (central cube): ', &
- dble(NCHUNKS)*(2.*(R_CENTRAL_CUBE / R_EARTH)/sqrt(3.))**2
- case default
- call exit_MPI(myrank,'incorrect region code')
- end select
- endif
-
- endif
-
- end subroutine meshfem3D_compute_area
-
Added: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D.f90 2012-05-19 16:33:09 UTC (rev 20176)
@@ -0,0 +1,1253 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! April 2011
+!
+! 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.
+
+ program xmeshfem3D
+
+ use meshfem3D_models_par
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ !include "constants.h"
+ include "precision.h"
+
+!=====================================================================!
+! !
+! meshfem3D produces a spectral element grid for the Earth. !
+! This is accomplished based upon a mapping of the face of a cube !
+! to a portion of the sphere (Ronchi et al., The Cubed Sphere). !
+! Grid density is decreased by a factor of two !
+! three times in the radial direction. !
+! !
+!=====================================================================!
+!
+! If you use this code for your own research, please cite at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @INCOLLECTION{ChKoViCaVaFe07,
+! author = {Emmanuel Chaljub and Dimitri Komatitsch and Jean-Pierre Vilotte and
+! Yann Capdeville and Bernard Valette and Gaetano Festa},
+! title = {Spectral Element Analysis in Seismology},
+! booktitle = {Advances in Wave Propagation in Heterogeneous Media},
+! publisher = {Elsevier - Academic Press},
+! year = {2007},
+! editor = {Ru-Shan Wu and Val\'erie Maupin},
+! volume = {48},
+! series = {Advances in Geophysics},
+! pages = {365-419}}
+!
+! @ARTICLE{KoVi98,
+! author={D. Komatitsch and J. P. Vilotte},
+! title={The spectral-element method: an efficient tool to simulate the seismic response of 2{D} and 3{D} geological structures},
+! journal={Bull. Seismol. Soc. Am.},
+! year=1998,
+! volume=88,
+! number=2,
+! pages={368-392}}
+!
+! @ARTICLE{KoTr99,
+! author={D. Komatitsch and J. Tromp},
+! year=1999,
+! title={Introduction to the spectral-element method for 3-{D} seismic wave propagation},
+! journal={Geophys. J. Int.},
+! volume=139,
+! number=3,
+! pages={806-822},
+! doi={10.1046/j.1365-246x.1999.00967.x}}
+!
+! @ARTICLE{KoRiTr02,
+! author={D. Komatitsch and J. Ritsema and J. Tromp},
+! year=2002,
+! title={The Spectral-Element Method, {B}eowulf Computing, and Global Seismology},
+! journal={Science},
+! volume=298,
+! number=5599,
+! pages={1737-1742},
+! doi={10.1126/science.1076024}}
+!
+! @ARTICLE{KoTr02a,
+! author={D. Komatitsch and J. Tromp},
+! year=2002,
+! title={Spectral-Element Simulations of Global Seismic Wave Propagation{-I. V}alidation},
+! journal={Geophys. J. Int.},
+! volume=149,
+! number=2,
+! pages={390-412},
+! doi={10.1046/j.1365-246X.2002.01653.x}}
+!
+! @ARTICLE{KoTr02b,
+! author={D. Komatitsch and J. Tromp},
+! year=2002,
+! title={Spectral-Element Simulations of Global Seismic Wave Propagation{-II. 3-D} Models, Oceans, Rotation, and Self-Gravitation},
+! journal={Geophys. J. Int.},
+! volume=150,
+! pages={303-318},
+! number=1,
+! doi={10.1046/j.1365-246X.2002.01716.x}}
+!
+! and/or another article from http://web.univ-pau.fr/~dkomati1/publications.html
+!
+!
+! If you use the kernel capabilities of the code, please cite at least one article
+! written by the developers of the package, for instance:
+!
+! @ARTICLE{TrKoLi08,
+! author = {Jeroen Tromp and Dimitri Komatitsch and Qinya Liu},
+! title = {Spectral-Element and Adjoint Methods in Seismology},
+! journal = {Communications in Computational Physics},
+! year = {2008},
+! volume = {3},
+! pages = {1-32},
+! number = {1}}
+!
+! or
+!
+! @ARTICLE{LiTr06,
+! author={Qinya Liu and Jeroen Tromp},
+! title={Finite-frequency kernels based on adjoint methods},
+! journal={Bull. Seismol. Soc. Am.},
+! year=2006,
+! volume=96,
+! number=6,
+! pages={2383-2397},
+! doi={10.1785/0120060041}}
+!
+! If you use 3-D model S20RTS, please cite:
+!
+! @ARTICLE{RiVa00,
+! author={J. Ritsema and H. J. {Van Heijst}},
+! year=2000,
+! title={Seismic imaging of structural heterogeneity in {E}arth's mantle: Evidence for large-scale mantle flow},
+! journal={Science Progress},
+! volume=83,
+! pages={243-259}}
+!
+! Reference frame - convention:
+! ----------------------------
+!
+! The code uses the following convention for the reference frame:
+!
+! - X axis is East
+! - Y axis is North
+! - Z axis is up
+!
+! Note that this convention is different from both the Aki-Richards convention
+! and the Harvard CMT convention.
+!
+! Let us recall that the Aki-Richards convention is:
+!
+! - X axis is North
+! - Y axis is East
+! - Z axis is down
+!
+! and that the Harvard CMT convention is:
+!
+! - X axis is South
+! - Y axis is East
+! - Z axis is up
+!
+! To report bugs or suggest improvements to the code, please send an email
+! to Jeroen Tromp <jtromp AT princeton.edu> and/or use our online
+! bug tracking system at http://www.geodynamics.org/roundup .
+!
+! Evolution of the code:
+! ---------------------
+!
+! v. 5.1, Dimitri Komatitsch, University of Toulouse, France and Ebru Bozdag, Princeton University, USA, February 2011:
+! non blocking MPI for much better scaling on large clusters;
+! new convention for the name of seismograms, to conform to the IRIS standard;
+! new directory structure
+!
+! v. 5.0 aka Tiger, many developers some with Princeton Tiger logo on their shirts, February 2010:
+! new moho mesh stretching honoring crust2.0 moho depths,
+! new attenuation assignment, new SAC headers, new general crustal models,
+! faster performance due to Deville routines and enhanced loop unrolling,
+! slight changes in code structure
+!
+! v. 4.0 David Michea and Dimitri Komatitsch, University of Pau, France, February 2008:
+! new doubling brick in the mesh, new perfectly load-balanced mesh,
+! more flexible routines for mesh design, new inflated central cube
+! with optimized shape, far fewer mesh files saved by the mesher,
+! global arrays sorted to speed up the simulation, seismos can be
+! written by the master, one more doubling level at the bottom
+! of the outer core if needed (off by default)
+!
+! v. 3.6 Many people, many affiliations, September 2006:
+! adjoint and kernel calculations, fixed IASP91 model,
+! added AK135 and 1066a, fixed topography/bathymetry routine,
+! new attenuation routines, faster and better I/Os on very large
+! systems, many small improvements and bug fixes, new "configure"
+! script, new user's manual etc.
+!
+! v. 3.5 Dimitri Komatitsch, Brian Savage and Jeroen Tromp, Caltech, July 2004:
+! any size of chunk, 3D attenuation, case of two chunks,
+! more precise topography/bathymetry model, new Par_file structure
+!
+! v. 3.4 Dimitri Komatitsch and Jeroen Tromp, Caltech, August 2003:
+! merged global and regional codes, no iterations in fluid, better movies
+!
+! v. 3.3 Dimitri Komatitsch, Caltech, September 2002:
+! flexible mesh doubling in outer core, inlined code, OpenDX support
+!
+! v. 3.2 Jeroen Tromp, Caltech, July 2002:
+! multiple sources and flexible PREM reading
+!
+! v. 3.1 Dimitri Komatitsch, Caltech, June 2002:
+! vectorized loops in solver and merged central cube
+!
+! v. 3.0 Dimitri Komatitsch and Jeroen Tromp, Caltech, May 2002:
+! ported to SGI and Compaq, double precision solver, more general anisotropy
+!
+! v. 2.3 Dimitri Komatitsch and Jeroen Tromp, Caltech, August 2001:
+! gravity, rotation, oceans and 3-D models
+!
+! v. 2.2 Dimitri Komatitsch and Jeroen Tromp, Caltech, USA, March 2001:
+! final MPI package
+!
+! v. 2.0 Dimitri Komatitsch, Harvard, USA, January 2000: MPI code for the globe
+!
+! v. 1.0 Dimitri Komatitsch, UNAM, Mexico, June 1999: first MPI code for a chunk
+!
+! Jeroen Tromp and Dimitri Komatitsch, Harvard, USA, July 1998: first chunk solver using OpenMP on a Sun machine
+!
+! Dimitri Komatitsch, IPG Paris, France, December 1996: first 3-D solver for the CM-5 Connection Machine,
+! parallelized on 128 processors using Connection Machine Fortran
+!
+! From Dahlen and Tromp (1998):
+! ----------------------------
+!
+! Gravity is approximated by solving eq (3.259) without the Phi_E' term
+! The ellipsoidal reference model is that of section 14.1
+! The transversely isotropic expression for PREM is that of eq (8.190)
+!
+! Formulation in the fluid (acoustic) outer core:
+! -----------------------------------------------
+!
+! In case of an acoustic medium, a displacement potential Chi is used
+! as in Chaljub and Valette, Geophysical Journal International, vol. 158,
+! p. 131-141 (2004) and *NOT* a velocity potential as in Komatitsch and Tromp,
+! Geophysical Journal International, vol. 150, p. 303-318 (2002).
+! This permits acoustic-elastic coupling based on a non-iterative time scheme.
+! Displacement if we ignore gravity is then: u = grad(Chi)
+! (In the context of the Cowling approximation displacement is
+! u = grad(rho * Chi) / rho, *not* u = grad(Chi).)
+! Velocity is then: v = grad(Chi_dot) (Chi_dot being the time derivative of Chi)
+! and pressure is: p = - rho * Chi_dot_dot (Chi_dot_dot being the time second derivative of Chi).
+! The source in an acoustic element is a pressure source.
+! The potential in the outer core is called displ_outer_core for simplicity.
+! Its first time derivative is called veloc_outer_core.
+! Its second time derivative is called accel_outer_core.
+
+
+! correct number of spectral elements in each block depending on chunk type
+ integer nspec_tiso,npointot
+
+! parameters needed to store the radii of the grid points
+! in the spherically symmetric Earth
+ integer, dimension(:), allocatable :: idoubling
+ integer, dimension(:,:,:,:), allocatable :: ibool
+
+! arrays with the mesh in double precision
+ double precision, dimension(:,:,:,:), allocatable :: xstore,ystore,zstore
+
+! proc numbers for MPI
+ integer myrank,sizeprocs,ier
+
+! check area and volume of the final mesh
+ double precision area_local_bottom
+ double precision area_local_top
+ double precision volume_local,volume_total
+
+ !integer iprocnum
+
+! for loop on all the slices
+ integer iregion_code
+ integer iproc_xi,iproc_eta,ichunk
+
+! rotation matrix from Euler angles
+ double precision, dimension(NDIM,NDIM) :: rotation_matrix
+
+ double precision ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD
+
+! for some statistics for the mesh
+ integer numelem_crust_mantle,numelem_outer_core,numelem_inner_core
+ integer numelem_total
+
+! timer MPI
+ double precision time_start,tCPU
+
+! addressing for all the slices
+ integer, dimension(:), allocatable :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
+ integer, dimension(:,:,:), allocatable :: addressing
+
+! parameters read from parameter file
+ integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP,NOISE_TOMOGRAPHY
+
+ double precision DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
+ RMOHO_FICTITIOUS_IN_MESHER
+
+ logical MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
+ RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
+
+ character(len=150) OUTPUT_FILES,LOCAL_PATH,MODEL
+
+! parameters deduced from parameters read from file
+ integer NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
+
+ integer, external :: err_occurred
+
+! this for all the regions
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP,NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NGLOB
+
+! computed in read_compute_parameters
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
+ integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: r_bottom,r_top
+ logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
+ double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
+
+! memory size of all the static arrays
+ double precision :: static_memory_size
+
+ integer :: ipass
+
+ integer :: NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION
+
+! this for the different corners of the slice (which are different if the superbrick is cut)
+! 1 : xi_min, eta_min
+! 2 : xi_max, eta_min
+! 3 : xi_max, eta_max
+! 4 : xi_min, eta_max
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
+
+! 1 -> min, 2 -> max
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE
+
+ integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+ integer, dimension(MAX_NUM_REGIONS) :: NGLOB1D_RADIAL_TEMP
+
+! this for non blocking MPI
+ logical, dimension(:), allocatable :: is_on_a_slice_edge
+
+! ************** PROGRAM STARTS HERE **************
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+! trivia about the programming style adopted here
+!
+! note 1: in general, we do not use modules in the fortran codes. this seems to
+! be mainly a performance reason. changing the codes to adopt modules
+! will have to prove that it performs as fast as it does without now.
+!
+! another reason why modules are avoided, is to make the code thread safe.
+! having different threads access the same data structure and modifying it at the same time
+! would lead to problems. passing arguments is a way to avoid such complications.
+!
+! however, the mesher makes one exception here: it uses the
+! module "meshfem3D_models_par" defined in the 'meshfem3D_models.f90' file.
+! the exception is based on the fact, that when one wants to incorporate
+! a new 3D/1D velocity model, it became tedious to change so many routines hardly
+! related to any model specific need.
+!
+! note 2: adding a new velocity model should become easier. the module tries to help with
+! that task. basically, you would follow the comments "ADD YOUR MODEL HERE"
+! to have an idea where you will have to put some new code:
+!
+! - meshfem3D_models.f90: main file for models
+! put your model structure into the module "meshfem3D_models_par"
+! and add your specific routine calls to get 1D/3D/attenuation values.
+!
+! - get_model_parameters.f90:
+! set your specific model flags and radii
+!
+! - read_compute_parameters.f90:
+! some models need to explicitly set smaller time steps which
+! can be done in routine rcp_set_timestep_and_layers()
+!
+! - add your model implementation into a new file named model_***.f90:
+! in general, this file should have as first routine the model_***_broadcast() routine
+! implemented which deals with passing the model structure to all processes.
+! this involves reading in model specific data which is normally put in directory DATA/
+! then follows a routine that returns the velocity values
+! (as perturbation to the associated 1D reference model) for a given point location.
+!
+! finally, in order to compile the new mesher with your new file(s),
+! you will add it to the list in the 'Makefile.in' file and run
+! `configure` to recreate a new Makefile.
+!
+!
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------------------------
+
+! initialize the MPI communicator and start the NPROCTOT MPI processes.
+ call MPI_INIT(ier)
+
+! sizeprocs returns number of processes started (should be equal to NPROCTOT).
+! myrank is the rank of each process, between 0 and NPROCTOT-1.
+! as usual in MPI, process 0 is in charge of coordinating everything
+! and also takes care of the main output
+! do not create anything for the inner core here, will be done in solver
+ call MPI_COMM_SIZE(MPI_COMM_WORLD,sizeprocs,ier)
+ call MPI_COMM_RANK(MPI_COMM_WORLD,myrank,ier)
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! open main output file, only written to by process 0
+ if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) &
+ open(unit=IMAIN,file=trim(OUTPUT_FILES)//'/output_mesher.txt',status='unknown')
+
+! get MPI starting time
+ time_start = MPI_WTIME()
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '****************************'
+ write(IMAIN,*) '*** Specfem3D MPI Mesher ***'
+ write(IMAIN,*) '****************************'
+ write(IMAIN,*)
+ endif
+
+ if (myrank==0) then
+ ! reads the parameter file and computes additional parameters
+ call read_compute_parameters(MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA,RMOHO_FICTITIOUS_IN_MESHER, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,DT, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE,MOVIE_VOLUME_TYPE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH,MOVIE_START,MOVIE_STOP, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE, &
+ ANISOTROPIC_INNER_CORE,CRUSTAL,ELLIPTICITY,GRAVITY,ONE_CRUST, &
+ ROTATION,ISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE,TOPOGRAPHY,OCEANS,MOVIE_SURFACE, &
+ MOVIE_VOLUME,MOVIE_COARSE,ATTENUATION_3D,RECEIVERS_CAN_BE_BURIED, &
+ PRINT_SOURCE_TIME_FUNCTION,SAVE_MESH_FILES, &
+ ATTENUATION,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
+ INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,LOCAL_PATH,MODEL,SIMULATION_TYPE,SAVE_FORWARD, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC,NSPEC2D_XI,NSPEC2D_ETA,NSPEC2DMAX_XMIN_XMAX, &
+ NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top,&
+ this_region_has_a_doubling,rmins,rmaxs,CASE_3D, &
+ OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,ratio_divide_central_cube, &
+ HONOR_1D_SPHERICAL_MOHO,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,&
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
+ WRITE_SEISMOGRAMS_BY_MASTER,SAVE_ALL_SEISMOS_IN_ONE_FILE, &
+ USE_BINARY_FOR_LARGE_FILE,.false.,NOISE_TOMOGRAPHY)
+
+ if(err_occurred() /= 0) &
+ call exit_MPI(myrank,'an error occurred while reading the parameter file')
+
+ endif
+
+ ! distributes parameters from master to all processes
+ call broadcast_compute_parameters(myrank,MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,NER_CRUST, &
+ NER_80_MOHO,NER_220_80,NER_400_220,NER_600_400,NER_670_600,NER_771_670, &
+ NER_TOPDDOUBLEPRIME_771,NER_CMB_TOPDDOUBLEPRIME,NER_OUTER_CORE, &
+ NER_TOP_CENTRAL_CUBE_ICB,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NTSTEP_BETWEEN_OUTPUT_SEISMOS, &
+ NTSTEP_BETWEEN_READ_ADJSRC,NSTEP,NSOURCES,NTSTEP_BETWEEN_FRAMES, &
+ NTSTEP_BETWEEN_OUTPUT_INFO,NUMBER_OF_RUNS,NUMBER_OF_THIS_RUN,NCHUNKS,SIMULATION_TYPE, &
+ MOVIE_VOLUME_TYPE,MOVIE_START,MOVIE_STOP, &
+ DT,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,CENTER_LONGITUDE_IN_DEGREES, &
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,ROCEAN,RMIDDLE_CRUST, &
+ RMOHO,R80,R120,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
+ R_CENTRAL_CUBE,RHO_TOP_OC,RHO_BOTTOM_OC,RHO_OCEANS,HDUR_MOVIE, &
+ MOVIE_TOP,MOVIE_BOTTOM,MOVIE_WEST,MOVIE_EAST,MOVIE_NORTH,MOVIE_SOUTH, &
+ RMOHO_FICTITIOUS_IN_MESHER, &
+ MOVIE_SURFACE,MOVIE_VOLUME,RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
+ SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
+ SAVE_ALL_SEISMOS_IN_ONE_FILE,MOVIE_COARSE,OUTPUT_SEISMOS_ASCII_TEXT, &
+ OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
+ ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,USE_BINARY_FOR_LARGE_FILE, &
+ LOCAL_PATH,MODEL, &
+ NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB, &
+ ratio_sampling_array, ner, doubling_index,r_bottom,r_top, &
+ this_region_has_a_doubling,rmins,rmaxs, &
+ ratio_divide_central_cube,CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
+ REFERENCE_1D_MODEL,THREE_D_MODEL,ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS, &
+ HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY, &
+ ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE, &
+ ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE,NOISE_TOMOGRAPHY)
+
+ ! check that the code is running with the requested number of processes
+ if(sizeprocs /= NPROCTOT) call exit_MPI(myrank,'wrong number of MPI processes')
+
+ ! compute rotation matrix from Euler angles
+ ANGULAR_WIDTH_XI_RAD = ANGULAR_WIDTH_XI_IN_DEGREES * PI / 180.d0
+ ANGULAR_WIDTH_ETA_RAD = ANGULAR_WIDTH_ETA_IN_DEGREES * PI / 180.d0
+ if(NCHUNKS /= 6) call euler_angles(rotation_matrix,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH)
+
+ ! dynamic allocation of mesh arrays
+ allocate(addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1))
+ allocate(ichunk_slice(0:NPROCTOT-1))
+ allocate(iproc_xi_slice(0:NPROCTOT-1))
+ allocate(iproc_eta_slice(0:NPROCTOT-1))
+
+ ! creates global slice addressing for solver
+ call meshfem3D_create_addressing(myrank,NCHUNKS,NPROC,NPROC_ETA,NPROC_XI,NPROCTOT, &
+ addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice, &
+ OUTPUT_FILES)
+
+
+ ! this for the different counters (which are now different if the superbrick is cut in the outer core)
+ call meshfem3D_setup_counters(myrank, &
+ NSPEC1D_RADIAL,NSPEC2D_XI,NSPEC2D_ETA,NGLOB1D_RADIAL, &
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ NPROCTOT,iproc_xi_slice,iproc_eta_slice, &
+ NSPEC1D_RADIAL_CORNER,NSPEC2D_XI_FACE, &
+ NSPEC2D_ETA_FACE,NGLOB1D_RADIAL_CORNER)
+
+ ! user output
+ if(myrank == 0) call meshfem3D_output_info(myrank,sizeprocs,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT, &
+ R_CENTRAL_CUBE)
+
+ ! distributes 3D models
+ call meshfem3D_models_broadcast(myrank,NSPEC, &
+ MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,&
+ R80,R220,R670,RCMB,RICB)
+
+
+ if(myrank == 0 ) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'model setup successfully read in'
+ write(IMAIN,*)
+ endif
+
+ ! get addressing for this process
+ ichunk = ichunk_slice(myrank)
+ iproc_xi = iproc_xi_slice(myrank)
+ iproc_eta = iproc_eta_slice(myrank)
+
+ ! volume of the slice
+ volume_total = ZERO
+
+ ! make sure everybody is synchronized
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+!----
+!---- loop on all the regions of the mesh
+!----
+
+ ! number of regions in full Earth
+ do iregion_code = 1,MAX_NUM_REGIONS
+
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) '*******************************************'
+ write(IMAIN,*) 'creating mesh in region ',iregion_code
+ select case(iregion_code)
+ case(IREGION_CRUST_MANTLE)
+ write(IMAIN,*) 'this region is the crust and mantle'
+ case(IREGION_OUTER_CORE)
+ write(IMAIN,*) 'this region is the outer core'
+ case(IREGION_INNER_CORE)
+ write(IMAIN,*) 'this region is the inner core'
+ case default
+ call exit_MPI(myrank,'incorrect region code')
+ end select
+ write(IMAIN,*) '*******************************************'
+ write(IMAIN,*)
+ endif
+
+ ! compute maximum number of points
+ npointot = NSPEC(iregion_code) * NGLLX * NGLLY * NGLLZ
+
+ ! use dynamic allocation to allocate memory for arrays
+ allocate(idoubling(NSPEC(iregion_code)))
+ allocate(ibool(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)))
+ allocate(xstore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)))
+ allocate(ystore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)))
+ allocate(zstore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)))
+
+! this for non blocking MPI
+ allocate(is_on_a_slice_edge(NSPEC(iregion_code)))
+
+ ! create all the regions of the mesh
+ ! perform two passes in this part to be able to save memory
+ do ipass = 1,2
+
+ call create_regions_mesh(iregion_code,ibool,idoubling,is_on_a_slice_edge, &
+ xstore,ystore,zstore,rmins,rmaxs, &
+ iproc_xi,iproc_eta,ichunk,NSPEC(iregion_code),nspec_tiso, &
+ volume_local,area_local_bottom,area_local_top, &
+ nglob(iregion_code),npointot, &
+ NSTEP,DT, &
+ NEX_XI,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ NSPEC2DMAX_XMIN_XMAX(iregion_code),NSPEC2DMAX_YMIN_YMAX(iregion_code), &
+ NSPEC2D_BOTTOM(iregion_code),NSPEC2D_TOP(iregion_code), &
+ NPROC_XI,NPROC_ETA,NSPEC2D_XI_FACE, &
+ NSPEC2D_ETA_FACE,NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
+ myrank,LOCAL_PATH,rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD, &
+ SAVE_MESH_FILES,NCHUNKS,INCLUDE_CENTRAL_CUBE,ABSORBING_CONDITIONS, &
+ R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB,R670,RMOHO,RMOHO_FICTITIOUS_IN_MESHER,&
+ RTOPDDOUBLEPRIME,R600,R220,R771,R400,R120,R80,RMIDDLE_CRUST,ROCEAN, &
+ ner,ratio_sampling_array,doubling_index,r_bottom,r_top,&
+ this_region_has_a_doubling,ipass,ratio_divide_central_cube, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ mod(iproc_xi_slice(myrank),2),mod(iproc_eta_slice(myrank),2))
+
+ enddo
+
+ ! checks number of anisotropic elements found in the mantle
+ if(iregion_code /= IREGION_CRUST_MANTLE .and. nspec_tiso /= 0 ) &
+ call exit_MPI(myrank,'found anisotropic elements outside of the mantle')
+
+ if( TRANSVERSE_ISOTROPY ) then
+ if(iregion_code == IREGION_CRUST_MANTLE .and. nspec_tiso == 0) &
+ call exit_MPI(myrank,'found no anisotropic elements in the mantle')
+ endif
+
+ ! computes total area and volume
+ call meshfem3D_compute_area(myrank,NCHUNKS,iregion_code, &
+ area_local_bottom,area_local_top,&
+ volume_local,volume_total, &
+ RCMB,RICB,R_CENTRAL_CUBE,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES)
+
+ ! create chunk buffers if more than one chunk
+ if(NCHUNKS > 1) then
+ call create_chunk_buffers(iregion_code,NSPEC(iregion_code),ibool,idoubling, &
+ xstore,ystore,zstore, &
+ nglob(iregion_code), &
+ NSPEC2DMAX_XMIN_XMAX(iregion_code),NSPEC2DMAX_YMIN_YMAX(iregion_code), &
+ NPROC_XI,NPROC_ETA,NPROC,NPROCTOT, &
+ NGLOB1D_RADIAL_CORNER,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
+ NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code), &
+ myrank,LOCAL_PATH,addressing, &
+ ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS)
+ else
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'only one chunk, no need to create chunk buffers'
+ write(IMAIN,*)
+ endif
+ endif
+
+ ! deallocate arrays used for that region
+ deallocate(idoubling)
+ deallocate(ibool)
+ deallocate(xstore)
+ deallocate(ystore)
+ deallocate(zstore)
+
+! this for non blocking MPI
+ deallocate(is_on_a_slice_edge)
+
+ ! make sure everybody is synchronized
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+! end of loop on all the regions
+ enddo
+
+ if(myrank == 0) then
+ ! check volume of chunk
+ write(IMAIN,*)
+ write(IMAIN,*) 'calculated volume: ',volume_total
+ if((NCHUNKS == 6 .or. (abs(ANGULAR_WIDTH_XI_IN_DEGREES - 90.d0) < TINYVAL .and. &
+ abs(ANGULAR_WIDTH_ETA_IN_DEGREES - 90.d0) < TINYVAL)) .and. .not. TOPOGRAPHY) then
+ ! take the central cube into account
+ ! it is counted 6 times because of the fictitious elements
+ if(INCLUDE_CENTRAL_CUBE) then
+ write(IMAIN,*) ' similar volume: ', &
+ dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)+5.*(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0
+ else
+ write(IMAIN,*) ' similar volume: ', &
+ dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)-(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0
+ endif
+ write(IMAIN,*) ' (but not exact because the central cube is purposely inflated)'
+ endif
+ endif
+
+
+!--- print number of points and elements in the mesh for each region
+
+ if(myrank == 0) then
+
+ numelem_crust_mantle = NSPEC(IREGION_CRUST_MANTLE)
+ numelem_outer_core = NSPEC(IREGION_OUTER_CORE)
+ numelem_inner_core = NSPEC(IREGION_INNER_CORE)
+
+ numelem_total = numelem_crust_mantle + numelem_outer_core + numelem_inner_core
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'Repartition of elements in regions:'
+ write(IMAIN,*) '----------------------------------'
+ write(IMAIN,*)
+ write(IMAIN,*) 'total number of elements in each slice: ',numelem_total
+ write(IMAIN,*)
+ write(IMAIN,*) ' - crust and mantle: ',sngl(100.d0*dble(numelem_crust_mantle)/dble(numelem_total)),' %'
+ write(IMAIN,*) ' - outer core: ',sngl(100.d0*dble(numelem_outer_core)/dble(numelem_total)),' %'
+ write(IMAIN,*) ' - inner core: ',sngl(100.d0*dble(numelem_inner_core)/dble(numelem_total)),' %'
+ write(IMAIN,*)
+ write(IMAIN,*) 'for some mesh statistics, see comments in file OUTPUT_FILES/values_from_mesher.h'
+ write(IMAIN,*)
+
+ ! load balancing
+ write(IMAIN,*) 'Load balancing = 100 % by definition'
+ write(IMAIN,*)
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'total number of time steps in the solver will be: ',NSTEP
+ write(IMAIN,*)
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'time-stepping of the solver will be: ',DT
+ 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,*)
+
+ ! evaluate the amount of static memory needed by the solver
+ call memory_eval(OCEANS,ABSORBING_CONDITIONS,ATTENUATION,ANISOTROPIC_3D_MANTLE,&
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_INNER_CORE,ROTATION,&
+ ONE_CRUST,doubling_index,this_region_has_a_doubling,&
+ ner,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_sampling_array,&
+ NSPEC,nglob,SIMULATION_TYPE,MOVIE_VOLUME,SAVE_FORWARD, &
+ NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION,static_memory_size)
+
+ NGLOB1D_RADIAL_TEMP(:) = &
+ (/maxval(NGLOB1D_RADIAL_CORNER(1,:)),maxval(NGLOB1D_RADIAL_CORNER(2,:)),maxval(NGLOB1D_RADIAL_CORNER(3,:))/)
+
+ ! create include file for the solver
+ call save_header_file(NSPEC,nglob,NEX_XI,NEX_ETA,NPROC,NPROCTOT, &
+ TRANSVERSE_ISOTROPY,ANISOTROPIC_3D_MANTLE,ANISOTROPIC_INNER_CORE, &
+ ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS,ATTENUATION,ATTENUATION_3D, &
+ ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,NCHUNKS, &
+ INCLUDE_CENTRAL_CUBE,CENTER_LONGITUDE_IN_DEGREES,&
+ CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH,NSOURCES,NSTEP, &
+ static_memory_size,NGLOB1D_RADIAL_TEMP, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NSPEC2D_TOP,NSPEC2D_BOTTOM, &
+ NSPEC2DMAX_YMIN_YMAX,NSPEC2DMAX_XMIN_XMAX, &
+ NPROC_XI,NPROC_ETA, &
+ NSPECMAX_ANISO_IC,NSPECMAX_ISO_MANTLE,NSPECMAX_TISO_MANTLE, &
+ NSPECMAX_ANISO_MANTLE,NSPEC_CRUST_MANTLE_ATTENUAT, &
+ NSPEC_INNER_CORE_ATTENUATION, &
+ NSPEC_CRUST_MANTLE_STR_OR_ATT,NSPEC_INNER_CORE_STR_OR_ATT, &
+ NSPEC_CRUST_MANTLE_STR_AND_ATT,NSPEC_INNER_CORE_STR_AND_ATT, &
+ NSPEC_CRUST_MANTLE_STRAIN_ONLY,NSPEC_INNER_CORE_STRAIN_ONLY, &
+ NSPEC_CRUST_MANTLE_ADJOINT, &
+ NSPEC_OUTER_CORE_ADJOINT,NSPEC_INNER_CORE_ADJOINT, &
+ NGLOB_CRUST_MANTLE_ADJOINT,NGLOB_OUTER_CORE_ADJOINT, &
+ NGLOB_INNER_CORE_ADJOINT,NSPEC_OUTER_CORE_ROT_ADJOINT, &
+ NSPEC_CRUST_MANTLE_STACEY,NSPEC_OUTER_CORE_STACEY, &
+ NGLOB_CRUST_MANTLE_OCEANS,NSPEC_OUTER_CORE_ROTATION, &
+ SIMULATION_TYPE,SAVE_FORWARD,MOVIE_VOLUME,NOISE_TOMOGRAPHY)
+
+ endif ! end of section executed by main process only
+
+ ! deallocate arrays used for mesh generation
+ deallocate(addressing)
+ deallocate(ichunk_slice)
+ deallocate(iproc_xi_slice)
+ deallocate(iproc_eta_slice)
+
+ ! elapsed time since beginning of mesh generation
+ if(myrank == 0) then
+ tCPU = MPI_WTIME() - time_start
+ write(IMAIN,*)
+ write(IMAIN,*) 'Elapsed time for mesh generation and buffer creation in seconds = ',tCPU
+ write(IMAIN,*) 'End of mesh generation'
+ write(IMAIN,*)
+ ! close main output file
+ close(IMAIN)
+ endif
+
+ ! synchronize all the processes to make sure everybody has finished
+ call MPI_BARRIER(MPI_COMM_WORLD,ier)
+
+ ! stop all the MPI processes, and exit
+ call MPI_FINALIZE(ier)
+
+ end program xmeshfem3D
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine meshfem3D_create_addressing(myrank,NCHUNKS,NPROC,NPROC_ETA,NPROC_XI,NPROCTOT, &
+ addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice, &
+ OUTPUT_FILES)
+
+ implicit none
+
+ include "constants.h"
+
+ integer :: myrank,NCHUNKS,NPROC,NPROC_ETA,NPROC_XI,NPROCTOT
+
+ integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1) :: addressing
+ integer, dimension(0:NPROCTOT-1) :: ichunk_slice,iproc_xi_slice,iproc_eta_slice
+
+ character(len=150) OUTPUT_FILES
+
+ ! local parameters
+ integer ichunk,iproc_eta,iproc_xi,iprocnum,ier
+
+ ! initializes
+ addressing(:,:,:) = 0
+ ichunk_slice(:) = 0
+ iproc_xi_slice(:) = 0
+ iproc_eta_slice(:) = 0
+
+ ! loop on all the chunks to create global slice addressing for solver
+ if(myrank == 0) then
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/addressing.txt',status='unknown',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error opening addressing.txt')
+ write(IMAIN,*) 'creating global slice addressing'
+ write(IMAIN,*)
+ endif
+
+ do ichunk = 1,NCHUNKS
+ do iproc_eta=0,NPROC_ETA-1
+ do iproc_xi=0,NPROC_XI-1
+ iprocnum = (ichunk-1)*NPROC + iproc_eta * NPROC_XI + iproc_xi
+ addressing(ichunk,iproc_xi,iproc_eta) = iprocnum
+ ichunk_slice(iprocnum) = ichunk
+ iproc_xi_slice(iprocnum) = iproc_xi
+ iproc_eta_slice(iprocnum) = iproc_eta
+ if(myrank == 0) write(IOUT,*) iprocnum,ichunk,iproc_xi,iproc_eta
+ enddo
+ enddo
+ enddo
+
+ if(myrank == 0) close(IOUT)
+
+ end subroutine meshfem3D_create_addressing
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine meshfem3D_setup_counters(myrank, &
+ NSPEC1D_RADIAL,NSPEC2D_XI,NSPEC2D_ETA,NGLOB1D_RADIAL, &
+ DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA, &
+ CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
+ NPROCTOT,iproc_xi_slice,iproc_eta_slice, &
+ NSPEC1D_RADIAL_CORNER,NSPEC2D_XI_FACE, &
+ NSPEC2D_ETA_FACE,NGLOB1D_RADIAL_CORNER)
+
+! returns: NSPEC1D_RADIAL_CORNER,NSPEC2D_XI_FACE,
+! NSPEC2D_ETA_FACE,NGLOB1D_RADIAL_CORNER
+
+ implicit none
+
+ include "constants.h"
+
+ integer myrank
+
+! this for all the regions
+ integer, dimension(MAX_NUM_REGIONS) :: NSPEC2D_XI,NSPEC2D_ETA, &
+ NSPEC1D_RADIAL,NGLOB1D_RADIAL
+
+ integer, dimension(NB_SQUARE_CORNERS,NB_CUT_CASE) :: DIFF_NSPEC1D_RADIAL
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR,NB_CUT_CASE) :: DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA
+
+ ! addressing for all the slices
+ integer :: NPROCTOT
+ integer, dimension(0:NPROCTOT-1) :: iproc_xi_slice,iproc_eta_slice
+
+ logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
+
+! this for the different corners of the slice (which are different if the superbrick is cut)
+! 1 : xi_min, eta_min
+! 2 : xi_max, eta_min
+! 3 : xi_max, eta_max
+! 4 : xi_min, eta_max
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: &
+ NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
+! 1 -> min, 2 -> max
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE
+
+
+ ! local parameters
+ integer :: iregion
+
+ do iregion=1,MAX_NUM_REGIONS
+ NSPEC1D_RADIAL_CORNER(iregion,:) = NSPEC1D_RADIAL(iregion)
+ NSPEC2D_XI_FACE(iregion,:) = NSPEC2D_XI(iregion)
+ NSPEC2D_ETA_FACE(iregion,:) = NSPEC2D_ETA(iregion)
+ NGLOB1D_RADIAL_CORNER(iregion,:) = NGLOB1D_RADIAL(iregion)
+ enddo
+
+ if (CUT_SUPERBRICK_XI) then
+ if (CUT_SUPERBRICK_ETA) then
+ if (mod(iproc_xi_slice(myrank),2) == 0) then
+ if (mod(iproc_eta_slice(myrank),2) == 0) then
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) &
+ + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) &
+ + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ else
+ if (mod(iproc_eta_slice(myrank),2) == 0) then
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,3)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,3)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,3)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) &
+ + (DIFF_NSPEC1D_RADIAL(:,3)*(NGLLZ-1))
+ else
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,4)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,4)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,4)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) &
+ + (DIFF_NSPEC1D_RADIAL(:,4)*(NGLLZ-1))
+ endif
+ endif
+ else
+ if (mod(iproc_xi_slice(myrank),2) == 0) then
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) &
+ + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) &
+ + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ endif
+ else
+ if (CUT_SUPERBRICK_ETA) then
+ if (mod(iproc_eta_slice(myrank),2) == 0) then
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,1)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,1)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,1)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) &
+ + (DIFF_NSPEC1D_RADIAL(:,1)*(NGLLZ-1))
+ else
+ NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NSPEC1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) + DIFF_NSPEC1D_RADIAL(:,2)
+ NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_XI_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_XI(:,2)
+ NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) = NSPEC2D_ETA_FACE(IREGION_OUTER_CORE,:) + DIFF_NSPEC2D_ETA(:,2)
+ NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) = NGLOB1D_RADIAL_CORNER(IREGION_OUTER_CORE,:) &
+ + (DIFF_NSPEC1D_RADIAL(:,2)*(NGLLZ-1))
+ endif
+ endif
+ endif
+
+ end subroutine meshfem3D_setup_counters
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine meshfem3D_output_info(myrank,sizeprocs,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT,&
+ R_CENTRAL_CUBE)
+
+ use meshfem3D_models_par
+
+ implicit none
+
+ integer :: myrank,sizeprocs,NEX_XI,NEX_ETA, &
+ NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT
+ double precision :: R_CENTRAL_CUBE
+
+ write(IMAIN,*) 'This is process ',myrank
+ write(IMAIN,*) 'There are ',sizeprocs,' MPI processes'
+ write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',NEX_XI,' elements along xi in each chunk'
+ write(IMAIN,*) 'There are ',NEX_ETA,' elements along eta in each chunk'
+ write(IMAIN,*)
+ write(IMAIN,*) 'There are ',NPROC_XI,' slices along xi in each chunk'
+ write(IMAIN,*) 'There are ',NPROC_ETA,' slices along eta in each chunk'
+ write(IMAIN,*) 'There is a total of ',NPROC,' slices in each chunk'
+ write(IMAIN,*) 'There are ',NCHUNKS,' chunks in the global mesh'
+ write(IMAIN,*) 'There is a total of ',NPROCTOT,' slices in the global mesh'
+ write(IMAIN,*)
+ write(IMAIN,*) 'NGLLX = ',NGLLX
+ write(IMAIN,*) 'NGLLY = ',NGLLY
+ write(IMAIN,*) 'NGLLZ = ',NGLLZ
+ write(IMAIN,*)
+ write(IMAIN,*) 'Shape functions defined by NGNOD = ',NGNOD,' control nodes'
+ write(IMAIN,*) 'Surface shape functions defined by NGNOD2D = ',NGNOD2D,' control nodes'
+ write(IMAIN,*)
+ write(IMAIN,*)
+ write(IMAIN,*)
+ if(ELLIPTICITY) then
+ write(IMAIN,*) 'incorporating ellipticity'
+ else
+ write(IMAIN,*) 'no ellipticity'
+ endif
+ write(IMAIN,*)
+ if(TOPOGRAPHY) then
+ write(IMAIN,*) 'incorporating surface topography'
+ else
+ write(IMAIN,*) 'no surface topography'
+ endif
+ write(IMAIN,*)
+ if(ISOTROPIC_3D_MANTLE) then
+ write(IMAIN,*) 'incorporating 3-D lateral variations'
+ else
+ write(IMAIN,*) 'no 3-D lateral variations'
+ endif
+ write(IMAIN,*)
+ if(HETEROGEN_3D_MANTLE) then
+ write(IMAIN,*) 'incorporating heterogeneities in the mantle'
+ else
+ write(IMAIN,*) 'no heterogeneities in the mantle'
+ endif
+ write(IMAIN,*)
+ if(CRUSTAL) then
+ write(IMAIN,*) 'incorporating crustal variations'
+ else
+ write(IMAIN,*) 'no crustal variations'
+ endif
+ write(IMAIN,*)
+ if(ONE_CRUST) then
+ write(IMAIN,*) 'using one layer only in PREM crust'
+ else
+ write(IMAIN,*) 'using unmodified 1D crustal model with two layers'
+ endif
+ write(IMAIN,*)
+ if(GRAVITY) then
+ write(IMAIN,*) 'incorporating self-gravitation (Cowling approximation)'
+ else
+ write(IMAIN,*) 'no self-gravitation'
+ endif
+ write(IMAIN,*)
+ if(ROTATION) then
+ write(IMAIN,*) 'incorporating rotation'
+ else
+ write(IMAIN,*) 'no rotation'
+ endif
+ write(IMAIN,*)
+ if(TRANSVERSE_ISOTROPY) then
+ write(IMAIN,*) 'incorporating anisotropy'
+ else
+ write(IMAIN,*) 'no anisotropy'
+ endif
+ write(IMAIN,*)
+ if(ATTENUATION) then
+ write(IMAIN,*) 'incorporating attenuation using ',N_SLS,' standard linear solids'
+ if(ATTENUATION_3D) write(IMAIN,*)'using 3D attenuation'
+ 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
+ write(IMAIN,*)
+ if(ANISOTROPIC_INNER_CORE) then
+ write(IMAIN,*) 'incorporating anisotropic inner core'
+ else
+ write(IMAIN,*) 'no inner-core anisotropy'
+ endif
+ write(IMAIN,*)
+ if(ANISOTROPIC_3D_MANTLE) then
+ write(IMAIN,*) 'incorporating anisotropic mantle'
+ else
+ write(IMAIN,*) 'no general mantle anisotropy'
+ endif
+ write(IMAIN,*)
+ write(IMAIN,*) 'Reference radius of the Earth used is ',R_EARTH_KM,' km'
+ write(IMAIN,*)
+ write(IMAIN,*) 'Central cube is at a radius of ',R_CENTRAL_CUBE/1000.d0,' km'
+
+ end subroutine meshfem3D_output_info
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine meshfem3D_compute_area(myrank,NCHUNKS,iregion_code, &
+ area_local_bottom,area_local_top,&
+ volume_local,volume_total, &
+ RCMB,RICB,R_CENTRAL_CUBE,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES)
+
+ use meshfem3D_models_par
+
+ implicit none
+
+ include 'mpif.h'
+
+ integer :: myrank,NCHUNKS,iregion_code
+
+ double precision :: area_local_bottom,area_local_top,volume_local,ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES
+ double precision :: volume_total
+ double precision :: RCMB,RICB,R_CENTRAL_CUBE
+
+ ! local parameters
+ double precision :: volume_total_region,area_total_bottom,area_total_top
+ integer :: ier
+
+ ! use MPI reduction to compute total area and volume
+ volume_total_region = ZERO
+ area_total_bottom = ZERO
+ area_total_top = ZERO
+ call MPI_REDUCE(area_local_bottom,area_total_bottom,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
+ MPI_COMM_WORLD,ier)
+ call MPI_REDUCE(area_local_top,area_total_top,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
+ MPI_COMM_WORLD,ier)
+ call MPI_REDUCE(volume_local,volume_total_region,1,MPI_DOUBLE_PRECISION,MPI_SUM,0, &
+ MPI_COMM_WORLD,ier)
+
+ if(myrank == 0) then
+ ! sum volume over all the regions
+ volume_total = volume_total + volume_total_region
+
+ ! check volume of chunk, and bottom and top area
+ write(IMAIN,*)
+ write(IMAIN,*) ' calculated top area: ',area_total_top
+
+ ! compare to exact theoretical value
+ if((NCHUNKS == 6 .or. (abs(ANGULAR_WIDTH_XI_IN_DEGREES - 90.d0) < TINYVAL .and. &
+ abs(ANGULAR_WIDTH_ETA_IN_DEGREES - 90.d0) < TINYVAL)) .and. .not. TOPOGRAPHY) then
+ select case(iregion_code)
+ case(IREGION_CRUST_MANTLE)
+ write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*R_UNIT_SPHERE**2
+ case(IREGION_OUTER_CORE)
+ write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RCMB/R_EARTH)**2
+ case(IREGION_INNER_CORE)
+ write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RICB/R_EARTH)**2
+ case default
+ call exit_MPI(myrank,'incorrect region code')
+ end select
+ endif
+
+ write(IMAIN,*)
+ write(IMAIN,*) 'calculated bottom area: ',area_total_bottom
+
+ ! compare to exact theoretical value
+ if((NCHUNKS == 6 .or. (abs(ANGULAR_WIDTH_XI_IN_DEGREES - 90.d0) < TINYVAL .and. &
+ abs(ANGULAR_WIDTH_ETA_IN_DEGREES - 90.d0) < TINYVAL)) .and. .not. TOPOGRAPHY) then
+ select case(iregion_code)
+ case(IREGION_CRUST_MANTLE)
+ write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RCMB/R_EARTH)**2
+ case(IREGION_OUTER_CORE)
+ write(IMAIN,*) ' exact area: ',dble(NCHUNKS)*(4.0d0/6.0d0)*PI*(RICB/R_EARTH)**2
+ case(IREGION_INNER_CORE)
+ write(IMAIN,*) ' similar (but not exact) area (central cube): ', &
+ dble(NCHUNKS)*(2.*(R_CENTRAL_CUBE / R_EARTH)/sqrt(3.))**2
+ case default
+ call exit_MPI(myrank,'incorrect region code')
+ end select
+ endif
+
+ endif
+
+ end subroutine meshfem3D_compute_area
+
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/save_header_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/save_header_file.f90 2012-05-19 14:09:44 UTC (rev 20175)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/save_header_file.f90 2012-05-19 16:33:09 UTC (rev 20176)
@@ -440,8 +440,12 @@
write(IOUT,*) 'integer, parameter :: NCHUNKS_VAL = ',NCHUNKS
write(IOUT,*) 'integer, parameter :: NPROCTOT_VAL = ',NPROCTOT
- write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XY_VAL = ', &
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XY_CM_VAL = ', &
max(NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE))
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XY_OC_VAL = ', &
+ max(NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE))
+ write(IOUT,*) 'integer, parameter :: NGLOB2DMAX_XY_IC_VAL = ', &
+ max(NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE))
if(NCHUNKS == 1 .or. NCHUNKS == 2) then
NCORNERSCHUNKS = 1
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/assemble_MPI_vector.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/assemble_MPI_vector.f90 2012-05-19 14:09:44 UTC (rev 20175)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/assemble_MPI_vector.f90 2012-05-19 16:33:09 UTC (rev 20176)
@@ -89,8 +89,8 @@
integer icount_corners
integer, intent(in) :: npoin2D_max_all_CM_IC
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED), intent(in) :: iboolfaces_crust_mantle
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED), intent(in) :: iboolfaces_inner_core
+ integer, dimension(NGLOB2DMAX_XY_CM_VAL,NUMFACES_SHARED), intent(in) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_IC_VAL,NUMFACES_SHARED), intent(in) :: iboolfaces_inner_core
real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED), intent(inout) :: &
buffer_send_faces_vector,buffer_received_faces_vector
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/assemble_MPI_vector_block.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/assemble_MPI_vector_block.f90 2012-05-19 14:09:44 UTC (rev 20175)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/assemble_MPI_vector_block.f90 2012-05-19 16:33:09 UTC (rev 20176)
@@ -32,8 +32,7 @@
!----
subroutine assemble_MPI_vector_block(myrank, &
- accel_crust_mantle,NGLOB_CRUST_MANTLE, &
- accel_inner_core,NGLOB_INNER_CORE, &
+ accel_crust_mantle,accel_inner_core, &
iproc_xi,iproc_eta,ichunk,addressing, &
iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
npoin2D_faces_crust_mantle,npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
@@ -47,10 +46,7 @@
buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
NPROC_XI,NPROC_ETA, &
- NGLOB1D_RADIAL_crust_mantle, &
- NGLOB2DMAX_XMIN_XMAX_CM,NGLOB2DMAX_YMIN_YMAX_CM, &
- NGLOB1D_RADIAL_inner_core, &
- NGLOB2DMAX_XMIN_XMAX_IC,NGLOB2DMAX_YMIN_YMAX_IC, &
+ NGLOB1D_RADIAL_crust_mantle,NGLOB1D_RADIAL_inner_core, &
NGLOB2DMAX_XY,NCHUNKS)
! this version of the routine is based on blocking MPI calls
@@ -63,8 +59,11 @@
include "constants.h"
include "precision.h"
- integer myrank,NGLOB_CRUST_MANTLE,NGLOB_INNER_CORE,NCHUNKS
+! include values created by the mesher
+ include "OUTPUT_FILES/values_from_mesher.h"
+ integer myrank,NCHUNKS
+
! the two arrays to assemble
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_CRUST_MANTLE) :: accel_crust_mantle
real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_INNER_CORE) :: accel_inner_core
@@ -75,8 +74,7 @@
integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_inner_core,npoin2D_eta_inner_core
integer npoin2D_faces_inner_core(NUMFACES_SHARED)
- integer NGLOB2DMAX_XMIN_XMAX_CM,NGLOB2DMAX_YMIN_YMAX_CM,NGLOB1D_RADIAL_crust_mantle
- integer NGLOB2DMAX_XMIN_XMAX_IC,NGLOB2DMAX_YMIN_YMAX_IC,NGLOB1D_RADIAL_inner_core
+ integer NGLOB1D_RADIAL_crust_mantle,NGLOB1D_RADIAL_inner_core
integer NPROC_XI,NPROC_ETA,NGLOB2DMAX_XY
integer NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS
@@ -94,7 +92,8 @@
integer, dimension(NGLOB1D_RADIAL_inner_core,NUMCORNERS_SHARED) :: iboolcorner_inner_core
integer icount_corners
- integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces_crust_mantle,iboolfaces_inner_core
+ integer, dimension(NGLOB2DMAX_XY_CM_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_IC_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
! size of buffers is multiplied by 2 because we handle two regions in the same MPI call
real(kind=CUSTOM_REAL), dimension(NDIM,2*NGLOB2DMAX_XY) :: buffer_send_faces_vector,buffer_received_faces_vector
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle.f90 2012-05-19 14:09:44 UTC (rev 20175)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle.f90 2012-05-19 16:33:09 UTC (rev 20176)
@@ -234,8 +234,8 @@
integer, dimension(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
+ integer, dimension(NGLOB2DMAX_XY_CM_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_IC_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
integer :: npoin2D_max_all_CM_IC
real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC) :: buffer_send_faces,buffer_received_faces
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle_Dev.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle_Dev.F90 2012-05-19 14:09:44 UTC (rev 20175)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle_Dev.F90 2012-05-19 16:33:09 UTC (rev 20176)
@@ -222,8 +222,8 @@
integer, dimension(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
+ integer, dimension(NGLOB2DMAX_XY_CM_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_IC_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
integer :: npoin2D_max_all_CM_IC
real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC) :: buffer_send_faces,buffer_received_faces
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core.f90 2012-05-19 14:09:44 UTC (rev 20175)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core.f90 2012-05-19 16:33:09 UTC (rev 20176)
@@ -187,8 +187,8 @@
integer, dimension(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
+ integer, dimension(NGLOB2DMAX_XY_CM_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_IC_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
integer :: npoin2D_max_all_CM_IC
real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC) :: buffer_send_faces,buffer_received_faces
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core_Dev.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core_Dev.F90 2012-05-19 14:09:44 UTC (rev 20175)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core_Dev.F90 2012-05-19 16:33:09 UTC (rev 20176)
@@ -231,8 +231,8 @@
integer, dimension(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED) :: iboolcorner_crust_mantle
integer, dimension(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED) :: iboolcorner_inner_core
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
+ integer, dimension(NGLOB2DMAX_XY_CM_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_IC_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
integer :: npoin2D_max_all_CM_IC
real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC) :: buffer_send_faces,buffer_received_faces
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_outer_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_outer_core.f90 2012-05-19 14:09:44 UTC (rev 20175)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_outer_core.f90 2012-05-19 16:33:09 UTC (rev 20176)
@@ -124,13 +124,12 @@
! indirect addressing for each message for faces and corners of the chunks
! a given slice can belong to at most one corner and at most two faces
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_outer_core
+ integer, dimension(NGLOB2DMAX_XY_OC_VAL,NUMFACES_SHARED) :: iboolfaces_outer_core
! buffers for send and receive between faces of the slices and the chunks
! we use the same buffers to assemble scalars and vectors because vectors are
! always three times bigger and therefore scalars can use the first part
! of the vector buffer in memory even if it has an additional index here
-! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
integer :: npoin2D_max_all_CM_IC
real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED) :: buffer_send_faces,buffer_received_faces
@@ -172,7 +171,7 @@
buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
NUMMSGS_FACES_VAL,NCORNERSCHUNKS_VAL, &
NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL_OC, &
- NGLOB2DMAX_XMIN_XMAX_OC,NGLOB2DMAX_YMIN_YMAX_OC,NGLOB2DMAX_XY_VAL,NCHUNKS_VAL,iphase)
+ NGLOB2DMAX_XMIN_XMAX_OC,NGLOB2DMAX_YMIN_YMAX_OC,NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
do k=1,NGLLZ
do j=1,NGLLY
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_outer_core_Dev.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_outer_core_Dev.f90 2012-05-19 14:09:44 UTC (rev 20175)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_outer_core_Dev.f90 2012-05-19 16:33:09 UTC (rev 20176)
@@ -147,13 +147,12 @@
! indirect addressing for each message for faces and corners of the chunks
! a given slice can belong to at most one corner and at most two faces
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_outer_core
+ integer, dimension(NGLOB2DMAX_XY_OC_VAL,NUMFACES_SHARED) :: iboolfaces_outer_core
! buffers for send and receive between faces of the slices and the chunks
! we use the same buffers to assemble scalars and vectors because vectors are
! always three times bigger and therefore scalars can use the first part
! of the vector buffer in memory even if it has an additional index here
-! allocate these automatic arrays in the memory stack to avoid memory fragmentation with "allocate()"
integer :: npoin2D_max_all_CM_IC
real(kind=CUSTOM_REAL), dimension(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED) :: buffer_send_faces,buffer_received_faces
@@ -195,7 +194,7 @@
buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
NUMMSGS_FACES_VAL,NCORNERSCHUNKS_VAL, &
NPROC_XI_VAL,NPROC_ETA_VAL,NGLOB1D_RADIAL_OC, &
- NGLOB2DMAX_XMIN_XMAX_OC,NGLOB2DMAX_YMIN_YMAX_OC,NGLOB2DMAX_XY_VAL,NCHUNKS_VAL,iphase)
+ NGLOB2DMAX_XMIN_XMAX_OC,NGLOB2DMAX_YMIN_YMAX_OC,NGLOB2DMAX_XY_OC_VAL,NCHUNKS_VAL,iphase)
do k=1,NGLLZ
do j=1,NGLLY
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/prepare_timerun.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/prepare_timerun.f90 2012-05-19 14:09:44 UTC (rev 20175)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/prepare_timerun.f90 2012-05-19 16:33:09 UTC (rev 20176)
@@ -77,8 +77,9 @@
integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_outer_core,npoin2D_eta_outer_core
integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_inner_core,npoin2D_eta_inner_core
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle, &
- iboolfaces_outer_core,iboolfaces_inner_core
+ integer, dimension(NGLOB2DMAX_XY_CM_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_OC_VAL,NUMFACES_SHARED) :: iboolfaces_outer_core
+ integer, dimension(NGLOB2DMAX_XY_IC_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
integer npoin2D_faces_outer_core(NUMFACES_SHARED)
@@ -95,7 +96,7 @@
integer, dimension(NCORNERSCHUNKS_VAL) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
! buffers for send and receive between faces of the slices and the chunks
- real(kind=CUSTOM_REAL), dimension(NGLOB2DMAX_XY_VAL) :: &
+ real(kind=CUSTOM_REAL), dimension(NGLOB2DMAX_XY_CM_VAL) :: &
buffer_send_faces_scalar,buffer_received_faces_scalar
! buffers for send and receive between corners of the chunks
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_mesh_databases.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_mesh_databases.f90 2012-05-19 14:09:44 UTC (rev 20175)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_mesh_databases.f90 2012-05-19 16:33:09 UTC (rev 20176)
@@ -339,8 +339,9 @@
integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_outer_core,npoin2D_eta_outer_core
integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_inner_core,npoin2D_eta_inner_core
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle, &
- iboolfaces_outer_core,iboolfaces_inner_core
+ integer, dimension(NGLOB2DMAX_XY_CM_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_OC_VAL,NUMFACES_SHARED) :: iboolfaces_outer_core
+ integer, dimension(NGLOB2DMAX_XY_IC_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
integer npoin2D_faces_crust_mantle(NUMFACES_SHARED)
integer npoin2D_faces_outer_core(NUMFACES_SHARED)
Modified: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/specfem3D.F90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/specfem3D.F90 2012-05-19 14:09:44 UTC (rev 20175)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/specfem3D.F90 2012-05-19 16:33:09 UTC (rev 20176)
@@ -665,8 +665,9 @@
! indirect addressing for each message for faces and corners of the chunks
! a given slice can belong to at most one corner and at most two faces
integer NGLOB2DMAX_XY
- integer, dimension(NGLOB2DMAX_XY_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle, &
- iboolfaces_outer_core,iboolfaces_inner_core
+ integer, dimension(NGLOB2DMAX_XY_CM_VAL,NUMFACES_SHARED) :: iboolfaces_crust_mantle
+ integer, dimension(NGLOB2DMAX_XY_OC_VAL,NUMFACES_SHARED) :: iboolfaces_outer_core
+ integer, dimension(NGLOB2DMAX_XY_IC_VAL,NUMFACES_SHARED) :: iboolfaces_inner_core
! this for non blocking MPI
@@ -903,6 +904,11 @@
imodulo_NGLOB_INNER_CORE
#endif
+#ifdef USE_SERIAL_CASCADE_FOR_IOs
+ logical :: you_can_start_doing_IOs
+ integer msg_status(MPI_STATUS_SIZE)
+#endif
+
! ************** PROGRAM STARTS HERE **************
!
!-------------------------------------------------------------------------------------------------
@@ -1022,6 +1028,12 @@
!-------------------------------------------------------------------------------------------------
!
! starts reading the databases
+#ifdef USE_SERIAL_CASCADE_FOR_IOs
+ you_can_start_doing_IOs = .false.
+ if (myrank > 0) call MPI_RECV(you_can_start_doing_IOs, 1, MPI_LOGICAL, myrank-1, itag, MPI_COMM_WORLD, msg_status,ier)
+!!!!!!! print *,'starting doing serialized I/Os on rank ',myrank
+#endif
+
call read_mesh_databases(myrank,rho_vp_crust_mantle,rho_vs_crust_mantle, &
xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
xix_crust_mantle,xiy_crust_mantle,xiz_crust_mantle, &
@@ -1057,7 +1069,7 @@
ibool_inner_core,idoubling_inner_core,ispec_is_tiso_inner_core, &
is_on_a_slice_edge_inner_core,rmass_inner_core, &
ABSORBING_CONDITIONS,LOCAL_PATH)
-
+
! read 2-D addressing for summation between slices with MPI
call read_mesh_databases_addressing(myrank, &
iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, &
@@ -1116,11 +1128,17 @@
maxval(npoin2D_eta_crust_mantle(:) + npoin2D_eta_inner_core(:)))
allocate(buffer_send_faces(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED), &
- buffer_received_faces(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED),stat=ier)
+ buffer_received_faces(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED),stat=ier)
if( ier /= 0 ) call exit_MPI(myrank,'error allocating mpi buffer')
- allocate(b_buffer_send_faces(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED), &
- b_buffer_received_faces(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED),stat=ier)
+ if(SIMULATION_TYPE > 1) then
+ allocate(b_buffer_send_faces(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED), &
+ b_buffer_received_faces(NDIM,npoin2D_max_all_CM_IC,NUMFACES_SHARED),stat=ier)
+ else
+! dummy allocation of unusued arrays
+ allocate(b_buffer_send_faces(1,1,1), &
+ b_buffer_received_faces(1,1,1),stat=ier)
+ endif
if( ier /= 0 ) call exit_MPI(myrank,'error allocating mpi b_buffer')
call fix_non_blocking_slices(is_on_a_slice_edge_crust_mantle,iboolright_xi_crust_mantle, &
@@ -1242,6 +1260,12 @@
endif
+#ifdef USE_SERIAL_CASCADE_FOR_IOs
+ you_can_start_doing_IOs = .true.
+ if (myrank < NPROC_XI_VAL*NPROC_ETA_VAL-1) &
+ call MPI_SEND(you_can_start_doing_IOs, 1, MPI_LOGICAL, myrank+1, itag, MPI_COMM_WORLD, ier)
+#endif
+
!
!-------------------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------------------
@@ -1531,13 +1555,21 @@
! allocate buffers for cube and slices
allocate(sender_from_slices_to_cube(non_zero_nb_msgs_theor_in_cube), &
buffer_all_cube_from_slices(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM), &
- b_buffer_all_cube_from_slices(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM), &
buffer_slices(npoin2D_cube_from_slices,NDIM), &
- b_buffer_slices(npoin2D_cube_from_slices,NDIM), &
buffer_slices2(npoin2D_cube_from_slices,NDIM), &
ibool_central_cube(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices),stat=ier)
if( ier /= 0 ) call exit_MPI(myrank,'error allocating cube buffers')
+ if(SIMULATION_TYPE > 1) then
+ allocate(b_buffer_all_cube_from_slices(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM), &
+ b_buffer_slices(npoin2D_cube_from_slices,NDIM))
+ else
+! dummy allocation of unusued arrays
+ allocate(b_buffer_all_cube_from_slices(1,1,1), &
+ b_buffer_slices(1,1))
+ endif
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating backward cube buffers')
+
! handles the communications with the central cube if it was included in the mesh
call prepare_timerun_centralcube(myrank,rmass_inner_core, &
iproc_xi,iproc_eta,ichunk, &
@@ -3328,8 +3360,7 @@
! crust/mantle and inner core handled in the same call
! in order to reduce the number of MPI messages by 2
call assemble_MPI_vector_block(myrank, &
- accel_crust_mantle,NGLOB_CRUST_MANTLE, &
- accel_inner_core,NGLOB_INNER_CORE, &
+ accel_crust_mantle,accel_inner_core, &
iproc_xi,iproc_eta,ichunk,addressing, &
iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, &
iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
@@ -3345,10 +3376,7 @@
buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector, &
NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
NPROC_XI_VAL,NPROC_ETA_VAL, &
- NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE), &
+ NGLOB1D_RADIAL(IREGION_CRUST_MANTLE),NGLOB1D_RADIAL(IREGION_INNER_CORE), &
NGLOB2DMAX_XY,NCHUNKS_VAL)
endif
@@ -3645,8 +3673,7 @@
! crust/mantle and inner core handled in the same call
! in order to reduce the number of MPI messages by 2
call assemble_MPI_vector_block(myrank, &
- b_accel_crust_mantle,NGLOB_CRUST_MANTLE, &
- b_accel_inner_core,NGLOB_INNER_CORE, &
+ b_accel_crust_mantle,b_accel_inner_core, &
iproc_xi,iproc_eta,ichunk,addressing, &
iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, &
iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
@@ -3662,10 +3689,7 @@
b_buffer_send_chunkcorn_vector,b_buffer_recv_chunkcorn_vector, &
NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
NPROC_XI_VAL,NPROC_ETA_VAL, &
- NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE), &
+ NGLOB1D_RADIAL(IREGION_CRUST_MANTLE),NGLOB1D_RADIAL(IREGION_INNER_CORE), &
NGLOB2DMAX_XY,NCHUNKS_VAL)
endif
More information about the CIG-COMMITS
mailing list