[cig-commits] r22487 - in seismo/3D/SPECFEM3D_GLOBE/trunk/src: . auxiliaries meshfem3D shared specfem3D
dkomati1 at geodynamics.org
dkomati1 at geodynamics.org
Tue Jul 2 08:58:13 PDT 2013
Author: dkomati1
Date: 2013-07-02 08:58:12 -0700 (Tue, 02 Jul 2013)
New Revision: 22487
Removed:
seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/combine_vol_data_vtk.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/cuda/
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/assemble_MPI_central_cube_mesh.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/assemble_MPI_scalar_mesh.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/assemble_MPI_vector_mesh.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/compute_area.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/compute_volumes.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_MPI_interfaces.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_addressing.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_central_cube_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_meshes.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/finalize_mesher.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/fix_non_blocking_flags.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_MPI_interfaces.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/heap_sort.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/initialize_layers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/initialize_mesher.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D_par.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_MPI_interfaces.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_color_perm.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_counters.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_inner_outer.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_model.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/test_MPI_interfaces.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/count_elements.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/count_points.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/define_all_layers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/get_timestep_and_layers.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/write_VTK_file.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_outer_core.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/finalize_simulation.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_topography_bathymetry.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/setup_GLL_points.f90
seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_movie_output.f90
Log:
removed all new files specific to the branch that I had erroneously added to the trunk (all the files that appeared in green in "meld")
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/combine_vol_data_vtk.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/combine_vol_data_vtk.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/auxiliaries/combine_vol_data_vtk.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,1160 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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.
-!
-!=====================================================================
-
-program combine_vol_data_vtk
-
- ! outputs vtk-files (ascii format)
-
- ! combines the database files on several slices.
- ! the local database file needs to have been collected onto the frontend (copy_local_database.pl)
-
- implicit none
-
- include 'constants.h'
- include 'OUTPUT_FILES/values_from_mesher.h'
-
- integer,parameter :: MAX_NUM_NODES = 2000
- integer iregion, ir, irs, ire, ires
- character(len=256) :: sline, arg(7), filename, in_topo_dir, in_file_dir, outdir
- character(len=256) :: prname_topo, prname_file, dimension_file
- character(len=256) :: mesh_file
- character(len=256) :: data_file, topo_file
- integer, dimension(MAX_NUM_NODES) :: node_list, nspec, nglob, npoint, nelement
- integer iproc, num_node, i,j,k,ispec, ios, it, di, dj, dk
- integer np, ne, njunk
-
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE) :: data
- real(kind=CUSTOM_REAL),dimension(NGLOB_CRUST_MANTLE) :: xstore, ystore, zstore
- integer ibool(NGLLX,NGLLY,NGLLZ,NSPEC_CRUST_MANTLE)
-
- integer num_ibool(NGLOB_CRUST_MANTLE)
- logical mask_ibool(NGLOB_CRUST_MANTLE), HIGH_RESOLUTION_MESH
-
- real x, y, z, dat
- integer numpoin, iglob, n1, n2, n3, n4, n5, n6, n7, n8
- integer iglob1, iglob2, iglob3, iglob4, iglob5, iglob6, iglob7, iglob8
- integer ier
- ! instead of taking the first value which appears for a global point, average the values
- ! if there are more than one gll points for a global point (points on element corners, edges, faces)
- logical,parameter:: AVERAGE_GLOBALPOINTS = .false.
- integer:: ibool_count(NGLOB_CRUST_MANTLE)
- real(kind=CUSTOM_REAL):: ibool_dat(NGLOB_CRUST_MANTLE)
-
- ! note:
- ! if one wants to remove the topography and ellipticity distortion, you would run the mesher again
- ! but turning the flags: TOPOGRAPHY and ELLIPTICITY to .false.
- ! then, use those as topo files: proc***_solver_data.bin
- ! of course, this would also work by just turning ELLIPTICITY to .false. so that the CORRECT_ELLIPTICITY below
- ! becomes unneccessary
- !
- ! puts point locations back into a perfectly spherical shape by removing the ellipticity factor;
- ! useful for plotting spherical cuts at certain depths
- logical,parameter:: CORRECT_ELLIPTICITY = .false.
- integer :: nspl
- double precision :: rspl(NR),espl(NR),espl2(NR)
- logical,parameter :: ONE_CRUST = .false. ! if you want to correct a model with one layer only in PREM crust
-
- integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core ! to get rid of fictitious elements in central cube
-
- ! global point data
- real,dimension(:),allocatable :: total_dat
- real,dimension(:,:),allocatable :: total_dat_xyz
- integer,dimension(:,:),allocatable :: total_dat_con
-
- ! starts here--------------------------------------------------------------------------------------------------
- do i = 1, 7
- call getarg(i,arg(i))
- if (i < 7 .and. trim(arg(i)) == '') then
- print *, ' '
- print *, ' Usage: xcombine_vol_data slice_list filename input_topo_dir input_file_dir '
- print *, ' output_dir high/low-resolution [region]'
- print *, ' ***** Notice: now allow different input dir for topo and kernel files ******** '
- print *, ' expect to have the topology and filename.bin(NGLLX,NGLLY,NGLLZ,nspec) '
- print *, ' already collected to input_topo_dir and input_file_dir'
- print *, ' output mesh files (filename_points.mesh, filename_elements.mesh) go to output_dir '
- print *, ' give 0 for low resolution and 1 for high resolution'
- print *, ' if region is not specified, all 3 regions will be collected, otherwise, only collect regions specified'
- stop ' Reenter command line options'
- endif
- enddo
-
- if (NSPEC_CRUST_MANTLE < NSPEC_OUTER_CORE .or. NSPEC_CRUST_MANTLE < NSPEC_INNER_CORE) &
- stop 'This program needs that NSPEC_CRUST_MANTLE > NSPEC_OUTER_CORE and NSPEC_INNER_CORE'
-
- ! get region id
- if (trim(arg(7)) == '') then
- iregion = 0
- else
- read(arg(7),*) iregion
- endif
- if (iregion > 3 .or. iregion < 0) stop 'Iregion = 0,1,2,3'
- if (iregion == 0) then
- irs = 1
- ire = 3
- else
- irs = iregion
- ire = irs
- endif
-
- ! get slices id
- num_node = 0
- open(unit = 20, file = trim(arg(1)), status = 'old',iostat = ios)
- if (ios /= 0) then
- print*,'no file: ',trim(arg(1))
- stop 'Error opening slices file'
- endif
-
- do while (1 == 1)
- read(20,'(a)',iostat=ios) sline
- if (ios /= 0) exit
- read(sline,*,iostat=ios) njunk
- if (ios /= 0) exit
- num_node = num_node + 1
- node_list(num_node) = njunk
- enddo
- close(20)
- print *, 'slice list: '
- print *, node_list(1:num_node)
- print *, ' '
-
- ! file to collect
- filename = arg(2)
-
- ! input and output dir
- in_topo_dir= arg(3)
- in_file_dir= arg(4)
- outdir = arg(5)
-
- ! resolution
- read(arg(6),*) ires
- di = 0; dj = 0; dk = 0
- if (ires == 0) then
- HIGH_RESOLUTION_MESH = .false.
- di = NGLLX-1; dj = NGLLY-1; dk = NGLLZ-1
- else if( ires == 1 ) then
- HIGH_RESOLUTION_MESH = .true.
- di = 1; dj = 1; dk = 1
- else if( ires == 2 ) then
- HIGH_RESOLUTION_MESH = .false.
- di = (NGLLX-1)/2.0; dj = (NGLLY-1)/2.0; dk = (NGLLZ-1)/2.0
- endif
- if( HIGH_RESOLUTION_MESH ) then
- print *, ' high resolution ', HIGH_RESOLUTION_MESH
- else
- print *, ' low resolution ', HIGH_RESOLUTION_MESH
- endif
-
- ! sets up ellipticity splines in order to remove ellipticity from point coordinates
- if( CORRECT_ELLIPTICITY ) call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
-
-
- do ir = irs, ire
- print *, '----------- Region ', ir, '----------------'
-
- ! figure out total number of points and elements for high-res mesh
-
- do it = 1, num_node
-
- iproc = node_list(it)
-
- print *, 'Reading slice ', iproc
- write(prname_topo,'(a,i6.6,a,i1,a)') trim(in_topo_dir)//'/proc',iproc,'_reg',ir,'_'
- write(prname_file,'(a,i6.6,a,i1,a)') trim(in_file_dir)//'/proc',iproc,'_reg',ir,'_'
-
-
- dimension_file = trim(prname_topo) //'solver_data.bin'
- open(unit = 27,file = trim(dimension_file),status='old',action='read', iostat = ios, form='unformatted')
- if (ios /= 0) then
- print*,'error ',ios
- print*,'file:',trim(dimension_file)
- stop 'Error opening file'
- endif
- read(27) nspec(it)
- read(27) nglob(it)
- close(27)
-
- ! check
- if( nspec(it) > NSPEC_CRUST_MANTLE ) stop 'error file nspec too big, please check compilation'
- if( nglob(it) > NGLOB_CRUST_MANTLE ) stop 'error file nglob too big, please check compilation'
-
- if (HIGH_RESOLUTION_MESH) then
- npoint(it) = nglob(it)
- nelement(it) = nspec(it) * (NGLLX-1) * (NGLLY-1) * (NGLLZ-1)
- else if( ires == 0 ) then
- npoint(it) = nglob(it)
- nelement(it) = nspec(it)
- else if (ires == 2 ) then
- npoint(it) = nglob(it)
- nelement(it) = nspec(it) * (NGLLX-1) * (NGLLY-1) * (NGLLZ-1) / 8
- endif
-
- enddo
-
- print *, 'nspec(it) = ', nspec(1:num_node)
- print *, 'nglob(it) = ', nglob(1:num_node)
-
- !call write_integer_fd(efd,sum(nelement(1:num_node)))
-
- ! VTK
- print *
- print *,'vtk inital total points: ',sum(npoint(1:num_node))
- print *,'vkt inital total elements: ',sum(nelement(1:num_node))
- print *
-
- ! creates array to hold point data
- allocate(total_dat(sum(npoint(1:num_node))),stat=ier)
- if( ier /= 0 ) stop 'error allocating total_dat array'
- total_dat(:) = 0.0
- allocate(total_dat_xyz(3,sum(npoint(1:num_node))),stat=ier)
- if( ier /= 0 ) stop 'error allocating total_dat_xyz array'
- total_dat_xyz(:,:) = 0.0
- allocate(total_dat_con(8,sum(nelement(1:num_node))),stat=ier)
- if( ier /= 0 ) stop 'error allocating total_dat_con array'
- total_dat_con(:,:) = 0
-
- np = 0
- ne = 0
-
- ! write points information
- do it = 1, num_node
-
- iproc = node_list(it)
-
- data(:,:,:,:) = -1.e10
-
- print *, ' '
- print *, 'Reading slice ', iproc
- write(prname_topo,'(a,i6.6,a,i1,a)') trim(in_topo_dir)//'/proc',iproc,'_reg',ir,'_'
- write(prname_file,'(a,i6.6,a,i1,a)') trim(in_file_dir)//'/proc',iproc,'_reg',ir,'_'
-
- ! filename.bin
- data_file = trim(prname_file) // trim(filename) // '.bin'
- open(unit = 27,file = trim(data_file),status='old',action='read', iostat = ios,form ='unformatted')
- if (ios /= 0) then
- print*,'error ',ios
- print*,'file:',trim(data_file)
- stop 'Error opening file'
- endif
- read(27,iostat=ios) data(:,:,:,1:nspec(it))
- if( ios /= 0 ) then
- print*,'read error ',ios
- print*,'file:',trim(data_file)
- stop 'error reading data'
- endif
- close(27)
-
- print *,trim(data_file)
- print *,' min/max value: ',minval(data(:,:,:,1:nspec(it))),maxval(data(:,:,:,1:nspec(it)))
- print *
-
- ! topology file
- topo_file = trim(prname_topo) // 'solver_data.bin'
- open(unit = 28,file = trim(topo_file),status='old',action='read', iostat = ios, form='unformatted')
- if (ios /= 0) then
- print*,'error ',ios
- print*,'file:',trim(topo_file)
- stop 'Error opening file'
- endif
- xstore(:) = 0.0
- ystore(:) = 0.0
- zstore(:) = 0.0
- ibool(:,:,:,:) = -1
- read(28) nspec(it)
- read(28) nglob(it)
- read(28) xstore(1:nglob(it))
- read(28) ystore(1:nglob(it))
- read(28) zstore(1:nglob(it))
- read(28) ibool(:,:,:,1:nspec(it))
- if (ir==3) read(28) idoubling_inner_core(1:nspec(it)) ! flag that can indicate fictitious elements
- close(28)
-
- print *, trim(topo_file)
-
-
- !average data on global points
- ibool_count(:) = 0
- ibool_dat(:) = 0.0
- if( AVERAGE_GLOBALPOINTS ) then
- do ispec=1,nspec(it)
- ! checks if element counts
- if (ir==3 ) then
- ! inner core
- ! nothing to do for fictitious elements in central cube
- if( idoubling_inner_core(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
- endif
- ! counts and sums global point data
- do k = 1, NGLLZ, dk
- do j = 1, NGLLY, dj
- do i = 1, NGLLX, di
- iglob = ibool(i,j,k,ispec)
-
- dat = data(i,j,k,ispec)
-
- ibool_dat(iglob) = ibool_dat(iglob) + dat
- ibool_count(iglob) = ibool_count(iglob) + 1
- enddo
- enddo
- enddo
- enddo
- do iglob=1,nglob(it)
- if( ibool_count(iglob) > 0 ) then
- ibool_dat(iglob) = ibool_dat(iglob)/ibool_count(iglob)
- endif
- enddo
- endif
-
- mask_ibool(:) = .false.
- num_ibool(:) = 0
- numpoin = 0
-
-
- ! write point file
- do ispec=1,nspec(it)
- ! checks if element counts
- if (ir==3 ) then
- ! inner core
- ! nothing to do for fictitious elements in central cube
- if( idoubling_inner_core(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
- endif
-
- ! writes out global point data
- do k = 1, NGLLZ, dk
- do j = 1, NGLLY, dj
- do i = 1, NGLLX, di
- iglob = ibool(i,j,k,ispec)
- if( iglob == -1 ) cycle
-
- ! takes the averaged data value for mesh
- if( AVERAGE_GLOBALPOINTS ) then
- if(.not. mask_ibool(iglob)) then
- numpoin = numpoin + 1
- x = xstore(iglob)
- y = ystore(iglob)
- z = zstore(iglob)
-
- ! remove ellipticity
- if( CORRECT_ELLIPTICITY ) call reverse_ellipticity(x,y,z,nspl,rspl,espl,espl2)
-
- !dat = data(i,j,k,ispec)
- dat = ibool_dat(iglob)
-
- !call write_real_fd(pfd,x)
- !call write_real_fd(pfd,y)
- !call write_real_fd(pfd,z)
- !call write_real_fd(pfd,dat)
-
- ! VTK
- total_dat(np+numpoin) = dat
- total_dat_xyz(1,np+numpoin) = x
- total_dat_xyz(2,np+numpoin) = y
- total_dat_xyz(3,np+numpoin) = z
-
- mask_ibool(iglob) = .true.
- num_ibool(iglob) = numpoin
- endif
- else
- if(.not. mask_ibool(iglob)) then
- numpoin = numpoin + 1
- x = xstore(iglob)
- y = ystore(iglob)
- z = zstore(iglob)
-
- ! remove ellipticity
- if( CORRECT_ELLIPTICITY ) call reverse_ellipticity(x,y,z,nspl,rspl,espl,espl2)
-
- dat = data(i,j,k,ispec)
-
- !call write_real_fd(pfd,x)
- !call write_real_fd(pfd,y)
- !call write_real_fd(pfd,z)
- !call write_real_fd(pfd,dat)
-
- ! VTK
- total_dat(np+numpoin) = dat
- total_dat_xyz(1,np+numpoin) = x
- total_dat_xyz(2,np+numpoin) = y
- total_dat_xyz(3,np+numpoin) = z
-
- mask_ibool(iglob) = .true.
- num_ibool(iglob) = numpoin
- endif
- endif
- enddo ! i
- enddo ! j
- enddo ! k
- enddo !ispec
-
-
- ! no way to check the number of points for low-res
- if (HIGH_RESOLUTION_MESH ) then
- if( ir==3 ) then
- npoint(it) = numpoin
- else if( numpoin /= npoint(it)) then
- print*,'region:',ir
- print*,'error number of points:',numpoin,npoint(it)
- stop 'different number of points (high-res)'
- endif
- else if (.not. HIGH_RESOLUTION_MESH) then
- npoint(it) = numpoin
- endif
-
- ! write elements file
- numpoin = 0
- do ispec = 1, nspec(it)
- ! checks if element counts
- if (ir==3 ) then
- ! inner core
- ! fictitious elements in central cube
- if( idoubling_inner_core(ispec) == IFLAG_IN_FICTITIOUS_CUBE) then
- ! connectivity must be given, otherwise element count would be wrong
- ! maps "fictitious" connectivity, element is all with iglob = 1
- !do k = 1, NGLLZ-1, dk
- ! do j = 1, NGLLY-1, dj
- ! do i = 1, NGLLX-1, di
- !call write_integer_fd(efd,1)
- !call write_integer_fd(efd,1)
- !call write_integer_fd(efd,1)
- !call write_integer_fd(efd,1)
- !call write_integer_fd(efd,1)
- !call write_integer_fd(efd,1)
- !call write_integer_fd(efd,1)
- !call write_integer_fd(efd,1)
- ! enddo ! i
- ! enddo ! j
- !enddo ! k
- ! takes next element
- cycle
- endif
- endif
-
- ! writes out element connectivity
- do k = 1, NGLLZ-1, dk
- do j = 1, NGLLY-1, dj
- do i = 1, NGLLX-1, di
-
- numpoin = numpoin + 1 ! counts elements
-
- iglob1 = ibool(i,j,k,ispec)
- iglob2 = ibool(i+di,j,k,ispec)
- iglob3 = ibool(i+di,j+dj,k,ispec)
- iglob4 = ibool(i,j+dj,k,ispec)
- iglob5 = ibool(i,j,k+dk,ispec)
- iglob6 = ibool(i+di,j,k+dk,ispec)
- iglob7 = ibool(i+di,j+dj,k+dk,ispec)
- iglob8 = ibool(i,j+dj,k+dk,ispec)
-
- n1 = num_ibool(iglob1)+np-1
- n2 = num_ibool(iglob2)+np-1
- n3 = num_ibool(iglob3)+np-1
- n4 = num_ibool(iglob4)+np-1
- n5 = num_ibool(iglob5)+np-1
- n6 = num_ibool(iglob6)+np-1
- n7 = num_ibool(iglob7)+np-1
- n8 = num_ibool(iglob8)+np-1
-
- !call write_integer_fd(efd,n1)
- !call write_integer_fd(efd,n2)
- !call write_integer_fd(efd,n3)
- !call write_integer_fd(efd,n4)
- !call write_integer_fd(efd,n5)
- !call write_integer_fd(efd,n6)
- !call write_integer_fd(efd,n7)
- !call write_integer_fd(efd,n8)
-
- ! VTK
- ! note: indices for vtk start at 0
- total_dat_con(1,numpoin + ne) = n1
- total_dat_con(2,numpoin + ne) = n2
- total_dat_con(3,numpoin + ne) = n3
- total_dat_con(4,numpoin + ne) = n4
- total_dat_con(5,numpoin + ne) = n5
- total_dat_con(6,numpoin + ne) = n6
- total_dat_con(7,numpoin + ne) = n7
- total_dat_con(8,numpoin + ne) = n8
-
- enddo ! i
- enddo ! j
- enddo ! k
- enddo ! ispec
-
- np = np + npoint(it)
- ne = ne + nelement(it)
-
- enddo ! all slices for points
-
- if (np /= sum(npoint(1:num_node))) stop 'Error: Number of total points are not consistent'
- if (ne /= sum(nelement(1:num_node))) stop 'Error: Number of total elements are not consistent'
-
- print *
- print *, 'Total number of points: ', np
- print *, 'Total number of elements: ', ne
- print *
-
- ! VTK
- ! opens unstructured grid file
- write(mesh_file,'(a,i1,a)') trim(outdir)//'/' // 'reg_',ir,'_'//trim(filename)//'.vtk'
- open(IOVTK,file=mesh_file(1:len_trim(mesh_file)),status='unknown',iostat=ios)
- if( ios /= 0 ) stop 'error opening vtk output file'
- write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
- write(IOVTK,'(a)') 'material model VTK file'
- write(IOVTK,'(a)') 'ASCII'
- write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
-
- ! points
- write(IOVTK, '(a,i16,a)') 'POINTS ', np, ' float'
- do i = 1,np
- write(IOVTK,'(3e18.6)') total_dat_xyz(1,i),total_dat_xyz(2,i),total_dat_xyz(3,i)
- enddo
- write(IOVTK,*) ""
-
- ! cells
- ! note: indices for vtk start at 0
- write(IOVTK,'(a,i12,i12)') "CELLS ",ne,ne*9
- do i = 1,ne
- write(IOVTK,'(9i12)') 8,total_dat_con(1,i),total_dat_con(2,i),total_dat_con(3,i),total_dat_con(4,i), &
- total_dat_con(5,i),total_dat_con(6,i),total_dat_con(7,i),total_dat_con(8,i)
- enddo
- write(IOVTK,*) ""
-
- !call close_file_fd(pfd)
- !call close_file_fd(efd)
-
- ! add the critical piece: total number of points
- !call open_file_fd(trim(pt_mesh_file2)//char(0),pfd)
- !call write_integer_fd(pfd,np)
- !call close_file_fd(pfd)
-
- !command_name='cat '//trim(pt_mesh_file2)//' '//trim(pt_mesh_file1)//' '//trim(em_mesh_file)//' > '//trim(mesh_file)
- !print *, ' '
- !print *, 'cat mesh files: '
- !print *, trim(command_name)
- !call system(trim(command_name))
-
- ! VTK
- ! type: hexahedrons
- write(IOVTK,'(a,i12)') "CELL_TYPES ",ne
- write(IOVTK,*) (12,it=1,ne)
- write(IOVTK,*) ""
-
- write(IOVTK,'(a,i12)') "POINT_DATA ",np
- write(IOVTK,'(a)') "SCALARS "//trim(filename)//" float"
- write(IOVTK,'(a)') "LOOKUP_TABLE default"
- do i = 1,np
- write(IOVTK,*) total_dat(i)
- enddo
- write(IOVTK,*) ""
- close(IOVTK)
-
- ! free arrays for this region
- deallocate(total_dat,total_dat_xyz,total_dat_con)
-
-
- print *,'written: ',trim(mesh_file)
- print *
- enddo
-
- print *, 'Done writing mesh files'
- print *, ' '
-
-
-end program combine_vol_data_vtk
-
-!
-! ------------------------------------------------------------------------------------------------
-!
-
-
- subroutine reverse_ellipticity(x,y,z,nspl,rspl,espl,espl2)
-
- implicit none
-
- include "constants.h"
-
- real(kind=CUSTOM_REAL) :: x,y,z
- integer nspl
- double precision rspl(NR),espl(NR),espl2(NR)
- double precision x1,y1,z1
-
- double precision ell
- double precision r,theta,phi,factor
- double precision cost,p20
-
- ! gets spherical coordinates
- x1 = x
- y1 = y
- z1 = z
- call xyz_2_rthetaphi_dble(x1,y1,z1,r,theta,phi)
-
- cost=dcos(theta)
- p20=0.5d0*(3.0d0*cost*cost-1.0d0)
-
- ! get ellipticity using spline evaluation
- call spline_evaluation(rspl,espl,espl2,nspl,r,ell)
-
- factor=ONE-(TWO/3.0d0)*ell*p20
-
- ! removes ellipticity factor
- x = x / factor
- y = y / factor
- z = z / factor
-
- end subroutine reverse_ellipticity
-
-!
-! ------------------------------------------------------------------------------------------------
-!
-
-! copy from make_ellipticity.f90 to avoid compiling issues
-
- subroutine make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
-
-! creates a spline for the ellipticity profile in PREM
-! radius and density are non-dimensional
-
- implicit none
-
- include "constants.h"
-
- integer nspl
-
- logical ONE_CRUST
-
-! radius of the Earth for gravity calculation
- double precision, parameter :: R_EARTH_ELLIPTICITY = 6371000.d0
-! radius of the ocean floor for gravity calculation
- double precision, parameter :: ROCEAN_ELLIPTICITY = 6368000.d0
-
- double precision rspl(NR),espl(NR),espl2(NR)
-
- integer i
- double precision ROCEAN,RMIDDLE_CRUST,RMOHO,R80,R220,R400,R600,R670, &
- R771,RTOPDDOUBLEPRIME,RCMB,RICB
- double precision r_icb,r_cmb,r_topddoubleprime,r_771,r_670,r_600
- double precision r_400,r_220,r_80,r_moho,r_middle_crust,r_ocean,r_0
- double precision r(NR),rho(NR),epsilonval(NR),eta(NR)
- double precision radau(NR),z,k(NR),g_a,bom,exponentval,i_rho,i_radau
- double precision s1(NR),s2(NR),s3(NR)
- double precision yp1,ypn
-
-! PREM
- ROCEAN = 6368000.d0
- RMIDDLE_CRUST = 6356000.d0
- RMOHO = 6346600.d0
- R80 = 6291000.d0
- R220 = 6151000.d0
- R400 = 5971000.d0
- R600 = 5771000.d0
- R670 = 5701000.d0
- R771 = 5600000.d0
- RTOPDDOUBLEPRIME = 3630000.d0
- RCMB = 3480000.d0
- RICB = 1221000.d0
-
-! non-dimensionalize
- r_icb = RICB/R_EARTH_ELLIPTICITY
- r_cmb = RCMB/R_EARTH_ELLIPTICITY
- r_topddoubleprime = RTOPDDOUBLEPRIME/R_EARTH_ELLIPTICITY
- r_771 = R771/R_EARTH_ELLIPTICITY
- r_670 = R670/R_EARTH_ELLIPTICITY
- r_600 = R600/R_EARTH_ELLIPTICITY
- r_400 = R400/R_EARTH_ELLIPTICITY
- r_220 = R220/R_EARTH_ELLIPTICITY
- r_80 = R80/R_EARTH_ELLIPTICITY
- r_moho = RMOHO/R_EARTH_ELLIPTICITY
- r_middle_crust = RMIDDLE_CRUST/R_EARTH_ELLIPTICITY
- r_ocean = ROCEAN_ELLIPTICITY/R_EARTH_ELLIPTICITY
- r_0 = 1.d0
-
- do i=1,163
- r(i) = r_icb*dble(i-1)/dble(162)
- enddo
- do i=164,323
- r(i) = r_icb+(r_cmb-r_icb)*dble(i-164)/dble(159)
- enddo
- do i=324,336
- r(i) = r_cmb+(r_topddoubleprime-r_cmb)*dble(i-324)/dble(12)
- enddo
- do i=337,517
- r(i) = r_topddoubleprime+(r_771-r_topddoubleprime)*dble(i-337)/dble(180)
- enddo
- do i=518,530
- r(i) = r_771+(r_670-r_771)*dble(i-518)/dble(12)
- enddo
- do i=531,540
- r(i) = r_670+(r_600-r_670)*dble(i-531)/dble(9)
- enddo
- do i=541,565
- r(i) = r_600+(r_400-r_600)*dble(i-541)/dble(24)
- enddo
- do i=566,590
- r(i) = r_400+(r_220-r_400)*dble(i-566)/dble(24)
- enddo
- do i=591,609
- r(i) = r_220+(r_80-r_220)*dble(i-591)/dble(18)
- enddo
- do i=610,619
- r(i) = r_80+(r_moho-r_80)*dble(i-610)/dble(9)
- enddo
- do i=620,626
- r(i) = r_moho+(r_middle_crust-r_moho)*dble(i-620)/dble(6)
- enddo
- do i=627,633
- r(i) = r_middle_crust+(r_ocean-r_middle_crust)*dble(i-627)/dble(6)
- enddo
- do i=634,NR
- r(i) = r_ocean+(r_0-r_ocean)*dble(i-634)/dble(6)
- enddo
-
-
-! use PREM to get the density profile for ellipticity (fine for other 1D reference models)
- do i=1,NR
- call prem_density(r(i),rho(i),ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
- radau(i)=rho(i)*r(i)*r(i)
- enddo
-
- eta(1)=0.0d0
-
- k(1)=0.0d0
-
- do i=2,NR
- call intgrl(i_rho,r,1,i,rho,s1,s2,s3)
- call intgrl(i_radau,r,1,i,radau,s1,s2,s3)
- z=(2.0d0/3.0d0)*i_radau/(i_rho*r(i)*r(i))
- eta(i)=(25.0d0/4.0d0)*((1.0d0-(3.0d0/2.0d0)*z)**2.0d0)-1.0d0
- k(i)=eta(i)/(r(i)**3.0d0)
- enddo
-
- g_a=4.0D0*i_rho
- bom=TWO_PI/(24.0d0*3600.0d0)
- bom=bom/sqrt(PI*GRAV*RHOAV)
- epsilonval(NR)=15.0d0*(bom**2.0d0)/(24.0d0*i_rho*(eta(NR)+2.0d0))
-
- do i=1,NR-1
- call intgrl(exponentval,r,i,NR,k,s1,s2,s3)
- epsilonval(i)=epsilonval(NR)*exp(-exponentval)
- enddo
-
-! get ready to spline epsilonval
- nspl=1
- rspl(1)=r(1)
- espl(1)=epsilonval(1)
- do i=2,NR
- if(r(i) /= r(i-1)) then
- nspl=nspl+1
- rspl(nspl)=r(i)
- espl(nspl)=epsilonval(i)
- endif
- enddo
-
-! spline epsilonval
- yp1=0.0d0
- ypn=(5.0d0/2.0d0)*(bom**2)/g_a-2.0d0*epsilonval(NR)
- call spline_construction(rspl,espl,nspl,yp1,ypn,espl2)
-
- end subroutine make_ellipticity
-
-!
-! ------------------------------------------------------------------------------------------------
-!
-
-! copy from model_prem.f90 to avoid compiling issues
-
- subroutine prem_density(x,rho,ONE_CRUST,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN)
-
- implicit none
-
- include "constants.h"
-
- double precision x,rho,RICB,RCMB,RTOPDDOUBLEPRIME, &
- R600,R670,R220,R771,R400,R80,RMOHO,RMIDDLE_CRUST,ROCEAN
-
- logical ONE_CRUST
-
- double precision r
-
- ! compute real physical radius in meters
- r = x * R_EARTH
-
- ! calculates density according to radius
- if(r <= RICB) then
- rho=13.0885d0-8.8381d0*x*x
- else if(r > RICB .and. r <= RCMB) then
- rho=12.5815d0-1.2638d0*x-3.6426d0*x*x-5.5281d0*x*x*x
- else if(r > RCMB .and. r <= RTOPDDOUBLEPRIME) then
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- else if(r > RTOPDDOUBLEPRIME .and. r <= R771) then
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- else if(r > R771 .and. r <= R670) then
- rho=7.9565d0-6.4761d0*x+5.5283d0*x*x-3.0807d0*x*x*x
- else if(r > R670 .and. r <= R600) then
- rho=5.3197d0-1.4836d0*x
- else if(r > R600 .and. r <= R400) then
- rho=11.2494d0-8.0298d0*x
- else if(r > R400 .and. r <= R220) then
- rho=7.1089d0-3.8045d0*x
- else if(r > R220 .and. r <= R80) then
- rho=2.6910d0+0.6924d0*x
- else
- if(r > R80 .and. r <= RMOHO) then
- rho=2.6910d0+0.6924d0*x
- else if(r > RMOHO .and. r <= RMIDDLE_CRUST) then
- if(ONE_CRUST) then
- rho=2.6d0
- else
- rho=2.9d0
- endif
- else if(r > RMIDDLE_CRUST .and. r <= ROCEAN) then
- rho=2.6d0
- else if(r > ROCEAN) then
- rho=2.6d0
- endif
- endif
-
- rho=rho*1000.0d0/RHOAV
-
- end subroutine prem_density
-
-!
-! ------------------------------------------------------------------------------------------------
-!
-
-! copy from intgrl.f90 to avoid compiling issues
-
-
- subroutine intgrl(sum,r,nir,ner,f,s1,s2,s3)
-
-! Computes the integral of f[i]*r[i]*r[i] from i=nir to i=ner for
-! radii values as in model PREM_an640
-
- implicit none
-
-! Argument variables
- integer ner,nir
- double precision f(640),r(640),s1(640),s2(640)
- double precision s3(640),sum
-
-! Local variables
- double precision, parameter :: third = 1.0d0/3.0d0
- double precision, parameter :: fifth = 1.0d0/5.0d0
- double precision, parameter :: sixth = 1.0d0/6.0d0
-
- double precision rji,yprime(640)
- double precision s1l,s2l,s3l
-
- integer i,j,n,kdis(28)
- integer ndis,nir1
-
-
-
- data kdis/163,323,336,517,530,540,565,590,609,619,626,633,16*0/
-
- ndis = 12
- n = 640
-
- call deriv(f,yprime,n,r,ndis,kdis,s1,s2,s3)
- nir1 = nir + 1
- sum = 0.0d0
- do i=nir1,ner
- j = i-1
- rji = r(i) - r(j)
- s1l = s1(j)
- s2l = s2(j)
- s3l = s3(j)
- sum = sum + r(j)*r(j)*rji*(f(j) &
- + rji*(0.5d0*s1l + rji*(third*s2l + rji*0.25d0*s3l))) &
- + 2.0d0*r(j)*rji*rji*(0.5d0*f(j) + rji*(third*s1l + rji*(0.25d0*s2l + rji*fifth*s3l))) &
- + rji*rji*rji*(third*f(j) + rji*(0.25d0*s1l + rji*(fifth*s2l + rji*sixth*s3l)))
- enddo
-
- end subroutine intgrl
-
-! -------------------------------
-
- subroutine deriv(y,yprime,n,r,ndis,kdis,s1,s2,s3)
-
- implicit none
-
-! Argument variables
- integer kdis(28),n,ndis
- double precision r(n),s1(n),s2(n),s3(n)
- double precision y(n),yprime(n)
-
-! Local variables
- integer i,j,j1,j2
- integer k,nd,ndp
- double precision a0,b0,b1
- double precision f(3,1000),h,h2,h2a
- double precision h2b,h3a,ha,s13
- double precision s21,s32,yy(3)
-
- yy(1) = 0.d0
- yy(2) = 0.d0
- yy(3) = 0.d0
-
- ndp=ndis+1
- do 3 nd=1,ndp
- if(nd == 1) goto 4
- if(nd == ndp) goto 5
- j1=kdis(nd-1)+1
- j2=kdis(nd)-2
- goto 6
- 4 j1=1
- j2=kdis(1)-2
- goto 6
- 5 j1=kdis(ndis)+1
- j2=n-2
- 6 if((j2+1-j1)>0) goto 11
- j2=j2+2
- yy(1)=(y(j2)-y(j1))/(r(j2)-r(j1))
- s1(j1)=yy(1)
- s1(j2)=yy(1)
- s2(j1)=yy(2)
- s2(j2)=yy(2)
- s3(j1)=yy(3)
- s3(j2)=yy(3)
- goto 3
- 11 a0=0.0d0
- if(j1 == 1) goto 7
- h=r(j1+1)-r(j1)
- h2=r(j1+2)-r(j1)
- yy(1)=h*h2*(h2-h)
- h=h*h
- h2=h2*h2
- b0=(y(j1)*(h-h2)+y(j1+1)*h2-y(j1+2)*h)/yy(1)
- goto 8
- 7 b0=0.0d0
- 8 b1=b0
-
- if(j2 > 1000) stop 'error in subroutine deriv for j2'
-
- do i=j1,j2
- h=r(i+1)-r(i)
- yy(1)=y(i+1)-y(i)
- h2=h*h
- ha=h-a0
- h2a=h-2.0d0*a0
- h3a=2.0d0*h-3.0d0*a0
- h2b=h2*b0
- s1(i)=h2/ha
- s2(i)=-ha/(h2a*h2)
- s3(i)=-h*h2a/h3a
- f(1,i)=(yy(1)-h*b0)/(h*ha)
- f(2,i)=(h2b-yy(1)*(2.0d0*h-a0))/(h*h2*h2a)
- f(3,i)=-(h2b-3.0d0*yy(1)*ha)/(h*h3a)
- a0=s3(i)
- b0=f(3,i)
- enddo
-
- i=j2+1
- h=r(i+1)-r(i)
- yy(1)=y(i+1)-y(i)
- h2=h*h
- ha=h-a0
- h2a=h*ha
- h2b=h2*b0-yy(1)*(2.d0*h-a0)
- s1(i)=h2/ha
- f(1,i)=(yy(1)-h*b0)/h2a
- ha=r(j2)-r(i+1)
- yy(1)=-h*ha*(ha+h)
- ha=ha*ha
- yy(1)=(y(i+1)*(h2-ha)+y(i)*ha-y(j2)*h2)/yy(1)
- s3(i)=(yy(1)*h2a+h2b)/(h*h2*(h-2.0d0*a0))
- s13=s1(i)*s3(i)
- s2(i)=f(1,i)-s13
-
- do j=j1,j2
- k=i-1
- s32=s3(k)*s2(i)
- s1(i)=f(3,k)-s32
- s21=s2(k)*s1(i)
- s3(k)=f(2,k)-s21
- s13=s1(k)*s3(k)
- s2(k)=f(1,k)-s13
- i=k
- enddo
-
- s1(i)=b1
- j2=j2+2
- s1(j2)=yy(1)
- s2(j2)=yy(2)
- s3(j2)=yy(3)
- 3 continue
-
- do i=1,n
- yprime(i)=s1(i)
- enddo
-
- end subroutine deriv
-
-!
-! ------------------------------------------------------------------------------------------------
-!
-
-! copy from spline_routines.f90 to avoid compiling issues
-
-! compute spline coefficients
-
- subroutine spline_construction(xpoint,ypoint,npoint,tangent_first_point,tangent_last_point,spline_coefficients)
-
- implicit none
-
-! tangent to the spline imposed at the first and last points
- double precision, intent(in) :: tangent_first_point,tangent_last_point
-
-! number of input points and coordinates of the input points
- integer, intent(in) :: npoint
- double precision, dimension(npoint), intent(in) :: xpoint,ypoint
-
-! spline coefficients output by the routine
- double precision, dimension(npoint), intent(out) :: spline_coefficients
-
- integer :: i
-
- double precision, dimension(:), allocatable :: temporary_array
-
- allocate(temporary_array(npoint))
-
- spline_coefficients(1) = - 1.d0 / 2.d0
-
- temporary_array(1) = (3.d0/(xpoint(2)-xpoint(1)))*((ypoint(2)-ypoint(1))/(xpoint(2)-xpoint(1))-tangent_first_point)
-
- do i = 2,npoint-1
-
- spline_coefficients(i) = ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))-1.d0) &
- / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)
-
- temporary_array(i) = (6.d0*((ypoint(i+1)-ypoint(i))/(xpoint(i+1)-xpoint(i)) &
- - (ypoint(i)-ypoint(i-1))/(xpoint(i)-xpoint(i-1)))/(xpoint(i+1)-xpoint(i-1)) &
- - (xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*temporary_array(i-1)) &
- / ((xpoint(i)-xpoint(i-1))/(xpoint(i+1)-xpoint(i-1))*spline_coefficients(i-1)+2.d0)
-
- enddo
-
- spline_coefficients(npoint) = ((3.d0/(xpoint(npoint)-xpoint(npoint-1))) &
- * (tangent_last_point-(ypoint(npoint)-ypoint(npoint-1))/(xpoint(npoint)-xpoint(npoint-1))) &
- - 1.d0/2.d0*temporary_array(npoint-1))/(1.d0/2.d0*spline_coefficients(npoint-1)+1.d0)
-
- do i = npoint-1,1,-1
- spline_coefficients(i) = spline_coefficients(i)*spline_coefficients(i+1) + temporary_array(i)
- enddo
-
- deallocate(temporary_array)
-
- end subroutine spline_construction
-
-! --------------
-
-! evaluate a spline
-
- subroutine spline_evaluation(xpoint,ypoint,spline_coefficients,npoint,x_evaluate_spline,y_spline_obtained)
-
- implicit none
-
-! number of input points and coordinates of the input points
- integer, intent(in) :: npoint
- double precision, dimension(npoint), intent(in) :: xpoint,ypoint
-
-! spline coefficients to use
- double precision, dimension(npoint), intent(in) :: spline_coefficients
-
-! abscissa at which we need to evaluate the value of the spline
- double precision, intent(in):: x_evaluate_spline
-
-! ordinate evaluated by the routine for the spline at this abscissa
- double precision, intent(out):: y_spline_obtained
-
- integer :: index_loop,index_lower,index_higher
-
- double precision :: coef1,coef2
-
-! initialize to the whole interval
- index_lower = 1
- index_higher = npoint
-
-! determine the right interval to use, by dichotomy
- do while (index_higher - index_lower > 1)
-! compute the middle of the interval
- index_loop = (index_higher + index_lower) / 2
- if(xpoint(index_loop) > x_evaluate_spline) then
- index_higher = index_loop
- else
- index_lower = index_loop
- endif
- enddo
-
-! test that the interval obtained does not have a size of zero
-! (this could happen for instance in the case of duplicates in the input list of points)
- if(xpoint(index_higher) == xpoint(index_lower)) stop 'incorrect interval found in spline evaluation'
-
- coef1 = (xpoint(index_higher) - x_evaluate_spline) / (xpoint(index_higher) - xpoint(index_lower))
- coef2 = (x_evaluate_spline - xpoint(index_lower)) / (xpoint(index_higher) - xpoint(index_lower))
-
- y_spline_obtained = coef1*ypoint(index_lower) + coef2*ypoint(index_higher) + &
- ((coef1**3 - coef1)*spline_coefficients(index_lower) + &
- (coef2**3 - coef2)*spline_coefficients(index_higher))*((xpoint(index_higher) - xpoint(index_lower))**2)/6.d0
-
- end subroutine spline_evaluation
-
-
-!
-! ------------------------------------------------------------------------------------------------
-!
-
-! copy from rthetaphi_xyz.f90 to avoid compiling issues
-
-
- subroutine xyz_2_rthetaphi_dble(x,y,z,r,theta,phi)
-
-! convert x y z to r theta phi, double precision call
-
- implicit none
-
- include "constants.h"
-
- double precision x,y,z,r,theta,phi
- double precision xmesh,ymesh,zmesh
-
- xmesh = x
- ymesh = y
- zmesh = z
-
- if(zmesh > -SMALL_VAL_ANGLE .and. zmesh <= ZERO) zmesh = -SMALL_VAL_ANGLE
- if(zmesh < SMALL_VAL_ANGLE .and. zmesh >= ZERO) zmesh = SMALL_VAL_ANGLE
-
- theta = datan2(dsqrt(xmesh*xmesh+ymesh*ymesh),zmesh)
-
- if(xmesh > -SMALL_VAL_ANGLE .and. xmesh <= ZERO) xmesh = -SMALL_VAL_ANGLE
- if(xmesh < SMALL_VAL_ANGLE .and. xmesh >= ZERO) xmesh = SMALL_VAL_ANGLE
-
- phi = datan2(ymesh,xmesh)
-
- r = dsqrt(xmesh*xmesh + ymesh*ymesh + zmesh*zmesh)
-
- end subroutine xyz_2_rthetaphi_dble
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/assemble_MPI_central_cube_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/assemble_MPI_central_cube_mesh.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/assemble_MPI_central_cube_mesh.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,330 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 assemble_MPI_central_cube_block(ichunk,nb_msgs_theor_in_cube, sender_from_slices_to_cube, &
- npoin2D_cube_from_slices, &
- buffer_all_cube_from_slices, buffer_slices, buffer_slices2, &
- ibool_central_cube, &
- receiver_cube_from_slices, ibool_inner_core, &
- idoubling_inner_core, NSPEC_INNER_CORE, &
- ibelm_bottom_inner_core, NSPEC2D_BOTTOM_INNER_CORE,NGLOB_INNER_CORE, &
- vector_assemble,ndim_assemble, &
- iproc_eta,addressing,NCHUNKS,NPROC_XI,NPROC_ETA)
-
- ! this version of the routine is based on blocking MPI calls
-
- implicit none
-
- ! standard include of the MPI library
- include 'mpif.h'
- include 'constants.h'
-
- ! for matching with central cube in inner core
- integer ichunk, nb_msgs_theor_in_cube, npoin2D_cube_from_slices
- integer, dimension(nb_msgs_theor_in_cube) :: sender_from_slices_to_cube
- double precision, dimension(npoin2D_cube_from_slices,NDIM) :: &
- buffer_slices,buffer_slices2
- double precision, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM) :: &
- buffer_all_cube_from_slices
- integer, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices):: ibool_central_cube
- integer receiver_cube_from_slices
-
- ! local to global mapping
- integer NSPEC_INNER_CORE,NSPEC2D_BOTTOM_INNER_CORE, NGLOB_INNER_CORE
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE) :: ibool_inner_core
- integer, dimension(NSPEC_INNER_CORE) :: idoubling_inner_core
- integer, dimension(NSPEC2D_BOTTOM_INNER_CORE) :: ibelm_bottom_inner_core
-
- ! vector
- integer ndim_assemble
- real(kind=CUSTOM_REAL), dimension(ndim_assemble,NGLOB_INNER_CORE) :: vector_assemble
-
- !for addressing of the slices
- integer, intent(in) :: NCHUNKS,NPROC_XI,NPROC_ETA
- integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1), intent(in) :: addressing
- integer, intent(in) :: iproc_eta
-
- integer ipoin,idimension, ispec2D, ispec
- integer i,j,k
- integer sender,receiver,imsg
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE) :: array_central_cube
-
- ! MPI status of messages to be received
- integer msg_status(MPI_STATUS_SIZE), ier
-
- ! mask
- logical, dimension(NGLOB_INNER_CORE) :: mask
-
- !---
- !--- now use buffers to assemble mass matrix with central cube once and for all
- !---
-
- ! on chunks AB and AB_ANTIPODE, receive all the messages from slices
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
-
- do imsg = 1,nb_msgs_theor_in_cube-1
-
- ! receive buffers from slices
- sender = sender_from_slices_to_cube(imsg)
- call MPI_RECV(buffer_slices, &
- ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
- ! copy buffer in 2D array for each slice
- buffer_all_cube_from_slices(imsg,:,1:ndim_assemble) = buffer_slices(:,1:ndim_assemble)
-
- enddo
- endif
-
- ! send info to central cube from all the slices except those in CHUNK_AB & CHUNK_AB_ANTIPODE
- if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE) then
- ! for bottom elements in contact with central cube from the slices side
- ipoin = 0
- do ispec2D = 1,NSPEC2D_BOTTOM_INNER_CORE
-
- ispec = ibelm_bottom_inner_core(ispec2D)
-
- ! only for DOFs exactly on surface of central cube (bottom of these elements)
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
- ipoin = ipoin + 1
- buffer_slices(ipoin,1:ndim_assemble) = dble(vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)))
- enddo
- enddo
- enddo
-
- ! send buffer to central cube
- receiver = receiver_cube_from_slices
- call MPI_SEND(buffer_slices,ndim_assemble*npoin2D_cube_from_slices, &
- MPI_DOUBLE_PRECISION,receiver,itag,MPI_COMM_WORLD,ier)
-
- ! in case NPROC_XI == 1, the other chunks exchange all bottom points with
- ! CHUNK_AB **and** CHUNK_AB_ANTIPODE
- if(NPROC_XI==1) then
- call MPI_SEND(buffer_slices,ndim_assemble*npoin2D_cube_from_slices, &
- MPI_DOUBLE_PRECISION, &
- addressing(CHUNK_AB_ANTIPODE,0,iproc_eta), &
- itag,MPI_COMM_WORLD,ier)
- endif
-
- endif ! end sending info to central cube
-
-
- ! exchange of their bottom faces between chunks AB and AB_ANTIPODE
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
-
- ipoin = 0
- do ispec = NSPEC_INNER_CORE, 1, -1
- if (idoubling_inner_core(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE) then
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
- ipoin = ipoin + 1
- buffer_slices(ipoin,1:ndim_assemble) = dble(vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)))
- enddo
- enddo
- endif
- enddo
-
- sender = sender_from_slices_to_cube(nb_msgs_theor_in_cube)
-
- call MPI_SENDRECV(buffer_slices,ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,receiver_cube_from_slices, &
- itag,buffer_slices2,ndim_assemble*npoin2D_cube_from_slices,&
- MPI_DOUBLE_PRECISION,sender,itag,MPI_COMM_WORLD,msg_status,ier)
-
- buffer_all_cube_from_slices(nb_msgs_theor_in_cube,:,1:ndim_assemble) = buffer_slices2(:,1:ndim_assemble)
-
- endif
-
- !--- now we need to assemble the contributions
-
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
-
- do idimension = 1,ndim_assemble
- ! erase contributions to central cube array
- array_central_cube(:) = 0._CUSTOM_REAL
-
- ! use indirect addressing to store contributions only once
- ! distinguish between single and double precision for reals
- do imsg = 1,nb_msgs_theor_in_cube-1
- do ipoin = 1,npoin2D_cube_from_slices
- if(NPROC_XI==1) then
- if(ibool_central_cube(imsg,ipoin) > 0 ) then
- if(CUSTOM_REAL == SIZE_REAL) then
- array_central_cube(ibool_central_cube(imsg,ipoin)) = sngl(buffer_all_cube_from_slices(imsg,ipoin,idimension))
- else
- array_central_cube(ibool_central_cube(imsg,ipoin)) = buffer_all_cube_from_slices(imsg,ipoin,idimension)
- endif
- endif
- else
- if(CUSTOM_REAL == SIZE_REAL) then
- array_central_cube(ibool_central_cube(imsg,ipoin)) = sngl(buffer_all_cube_from_slices(imsg,ipoin,idimension))
- else
- array_central_cube(ibool_central_cube(imsg,ipoin)) = buffer_all_cube_from_slices(imsg,ipoin,idimension)
- endif
- endif
- enddo
- enddo
- ! add the constribution of AB or AB_ANTIPODE to sum with the external slices on the edges
- ! use a mask to avoid taking the same point into account several times.
- mask(:) = .false.
- do ipoin = 1,npoin2D_cube_from_slices
- if(NPROC_XI==1) then
- if( ibool_central_cube(nb_msgs_theor_in_cube,ipoin) > 0 ) then
- if (.not. mask(ibool_central_cube(nb_msgs_theor_in_cube,ipoin))) then
- if(CUSTOM_REAL == SIZE_REAL) then
- array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) = &
- array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) + &
- sngl(buffer_all_cube_from_slices(nb_msgs_theor_in_cube,ipoin,idimension))
- else
- array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) = &
- array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) + &
- buffer_all_cube_from_slices(nb_msgs_theor_in_cube,ipoin,idimension)
- endif
- endif
- mask(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) = .true.
- endif
- else
- if (.not. mask(ibool_central_cube(nb_msgs_theor_in_cube,ipoin))) then
- if(CUSTOM_REAL == SIZE_REAL) then
- array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) = &
- array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) + &
- sngl(buffer_all_cube_from_slices(nb_msgs_theor_in_cube,ipoin,idimension))
- else
- array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) = &
- array_central_cube(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) + &
- buffer_all_cube_from_slices(nb_msgs_theor_in_cube,ipoin,idimension)
- endif
- endif
- mask(ibool_central_cube(nb_msgs_theor_in_cube,ipoin)) = .true.
- endif
- enddo
-
- ! suppress degrees of freedom already assembled at top of cube on edges
- do ispec = 1,NSPEC_INNER_CORE
- if(idoubling_inner_core(ispec) == IFLAG_TOP_CENTRAL_CUBE) then
- k = NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- array_central_cube(ibool_inner_core(i,j,k,ispec)) = 0._CUSTOM_REAL
- enddo
- enddo
- endif
- enddo
-
- ! assemble contributions
- vector_assemble(idimension,:) = vector_assemble(idimension,:) + array_central_cube(:)
-
- ! copy sum back
- do imsg = 1,nb_msgs_theor_in_cube-1
- do ipoin = 1,npoin2D_cube_from_slices
- if(NPROC_XI==1) then
- if( ibool_central_cube(imsg,ipoin) > 0 ) then
- buffer_all_cube_from_slices(imsg,ipoin,idimension) = &
- vector_assemble(idimension,ibool_central_cube(imsg,ipoin))
- else
- buffer_all_cube_from_slices(imsg,ipoin,idimension) = 0._CUSTOM_REAL
- endif
- else
- buffer_all_cube_from_slices(imsg,ipoin,idimension) = &
- vector_assemble(idimension,ibool_central_cube(imsg,ipoin))
- endif
- enddo
- enddo
-
- enddo
-
- endif
-
- !----------
-
- ! receive info from central cube on all the slices except those in CHUNK_AB & CHUNK_AB_ANTIPODE
- if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE) then
- ! receive buffers from slices
- sender = receiver_cube_from_slices
- call MPI_RECV(buffer_slices, &
- ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
- ! in case NPROC_XI == 1, the other chunks exchange all bottom points with
- ! CHUNK_AB **and** CHUNK_AB_ANTIPODE
- if(NPROC_XI==1) then
- call MPI_RECV(buffer_slices2, &
- ndim_assemble*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION, &
- addressing(CHUNK_AB_ANTIPODE,0,iproc_eta), &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
- buffer_slices = buffer_slices + buffer_slices2
- endif
-
- ! for bottom elements in contact with central cube from the slices side
- ipoin = 0
- do ispec2D = 1,NSPEC2D_BOTTOM_INNER_CORE
-
- ispec = ibelm_bottom_inner_core(ispec2D)
-
- ! only for DOFs exactly on surface of central cube (bottom of these elements)
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
- ipoin = ipoin + 1
-
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)) = sngl(buffer_slices(ipoin,1:ndim_assemble))
- else
- vector_assemble(1:ndim_assemble,ibool_inner_core(i,j,k,ispec)) = buffer_slices(ipoin,1:ndim_assemble)
- endif
-
- enddo
- enddo
- enddo
-
- endif ! end receiving info from central cube
-
- !------- send info back from central cube to slices
-
- ! on chunk AB & CHUNK_AB_ANTIPODE, send all the messages to slices
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
-
- do imsg = 1,nb_msgs_theor_in_cube-1
-
- ! copy buffer in 2D array for each slice
- buffer_slices(:,1:ndim_assemble) = buffer_all_cube_from_slices(imsg,:,1:ndim_assemble)
-
- ! send buffers to slices
- receiver = sender_from_slices_to_cube(imsg)
- call MPI_SEND(buffer_slices,ndim_assemble*npoin2D_cube_from_slices, &
- MPI_DOUBLE_PRECISION,receiver,itag,MPI_COMM_WORLD,ier)
-
- enddo
- endif
-
- end subroutine assemble_MPI_central_cube_block
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/assemble_MPI_scalar_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/assemble_MPI_scalar_mesh.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/assemble_MPI_scalar_mesh.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,539 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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.
-!
-!=====================================================================
-
-!----
-!---- assemble the contributions between slices and chunks using MPI
-!----
-
- subroutine assemble_MPI_scalar_block(myrank,array_val,nglob, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta, &
- npoin2D_faces,npoin2D_xi,npoin2D_eta, &
- iboolfaces,iboolcorner, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces_scalar,buffer_received_faces_scalar,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NCHUNKS)
-
-! this version of the routine is based on blocking MPI calls
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
- include "precision.h"
-
- integer myrank,nglob,NCHUNKS
-
-! array to assemble
- real(kind=CUSTOM_REAL), dimension(nglob) :: array_val
-
- integer iproc_xi,iproc_eta,ichunk
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi,npoin2D_eta
- integer npoin2D_faces(NUMFACES_SHARED)
-
- integer NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY
- integer NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL
- integer NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS
-
-! for addressing of the slices
- integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1) :: addressing
-
-! 2-D addressing and buffers for summation between slices
- integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
- integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
-
-! indirect addressing for each corner of the chunks
- integer, dimension(NGLOB1D_RADIAL,NUMCORNERS_SHARED) :: iboolcorner
- integer icount_corners
-
- integer :: npoin2D_max_all_CM_IC
- integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces
- real(kind=CUSTOM_REAL), dimension(npoin2D_max_all_CM_IC) :: buffer_send_faces_scalar,buffer_received_faces_scalar
-
-! buffers for send and receive between corners of the chunks
- real(kind=CUSTOM_REAL), dimension(NGLOB1D_RADIAL) :: buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar
-
-! ---- arrays to assemble between chunks
-
-! communication pattern for faces between chunks
- integer, dimension(NUMMSGS_FACES) :: iprocfrom_faces,iprocto_faces,imsg_type
-
-! communication pattern for corners between chunks
- integer, dimension(NCORNERSCHUNKS) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
-
-! MPI status of messages to be received
- integer msg_status(MPI_STATUS_SIZE)
-
- integer ipoin,ipoin2D,ipoin1D
- integer sender,receiver,ier
- integer imsg,imsg_loop
- integer icount_faces,npoin2D_chunks
-
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-! check flag to see if we need to assemble (might be turned off when debugging)
- if (.not. ACTUALLY_ASSEMBLE_MPI_SLICES) return
-
-! here we have to assemble all the contributions between slices using MPI
-
-!----
-!---- assemble the contributions between slices using MPI
-!----
-
-!----
-!---- first assemble along xi using the 2-D topology
-!----
-
-! assemble along xi only if more than one slice
- if(NPROC_XI > 1) then
-
- ! slices copy the right face into the buffer
- do ipoin=1,npoin2D_xi(2)
- buffer_send_faces_scalar(ipoin) = array_val(iboolright_xi(ipoin))
- enddo
-
- ! send messages forward along each row
- if(iproc_xi == 0) then
- sender = MPI_PROC_NULL
- else
- sender = addressing(ichunk,iproc_xi - 1,iproc_eta)
- endif
- if(iproc_xi == NPROC_XI-1) then
- receiver = MPI_PROC_NULL
- else
- receiver = addressing(ichunk,iproc_xi + 1,iproc_eta)
- endif
- call MPI_SENDRECV(buffer_send_faces_scalar,npoin2D_xi(2),CUSTOM_MPI_TYPE,receiver, &
- itag2,buffer_received_faces_scalar,npoin2D_xi(1),CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
- ! all slices add the buffer received to the contributions on the left face
- if(iproc_xi > 0) then
- do ipoin=1,npoin2D_xi(1)
- array_val(iboolleft_xi(ipoin)) = array_val(iboolleft_xi(ipoin)) + &
- buffer_received_faces_scalar(ipoin)
- enddo
- endif
-
- ! the contributions are correctly assembled on the left side of each slice
- ! now we have to send the result back to the sender
- ! all slices copy the left face into the buffer
- do ipoin=1,npoin2D_xi(1)
- buffer_send_faces_scalar(ipoin) = array_val(iboolleft_xi(ipoin))
- enddo
-
- ! send messages backward along each row
- if(iproc_xi == NPROC_XI-1) then
- sender = MPI_PROC_NULL
- else
- sender = addressing(ichunk,iproc_xi + 1,iproc_eta)
- endif
- if(iproc_xi == 0) then
- receiver = MPI_PROC_NULL
- else
- receiver = addressing(ichunk,iproc_xi - 1,iproc_eta)
- endif
- call MPI_SENDRECV(buffer_send_faces_scalar,npoin2D_xi(1),CUSTOM_MPI_TYPE,receiver, &
- itag2,buffer_received_faces_scalar,npoin2D_xi(2),CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
- ! all slices copy the buffer received to the contributions on the right face
- if(iproc_xi < NPROC_XI-1) then
- do ipoin=1,npoin2D_xi(2)
- array_val(iboolright_xi(ipoin)) = buffer_received_faces_scalar(ipoin)
- enddo
- endif
-
- endif
-
-!----
-!---- then assemble along eta using the 2-D topology
-!----
-
-! assemble along eta only if more than one slice
- if(NPROC_ETA > 1) then
-
- ! slices copy the right face into the buffer
- do ipoin=1,npoin2D_eta(2)
- buffer_send_faces_scalar(ipoin) = array_val(iboolright_eta(ipoin))
- enddo
-
- ! send messages forward along each row
- if(iproc_eta == 0) then
- sender = MPI_PROC_NULL
- else
- sender = addressing(ichunk,iproc_xi,iproc_eta - 1)
- endif
- if(iproc_eta == NPROC_ETA-1) then
- receiver = MPI_PROC_NULL
- else
- receiver = addressing(ichunk,iproc_xi,iproc_eta + 1)
- endif
- call MPI_SENDRECV(buffer_send_faces_scalar,npoin2D_eta(2),CUSTOM_MPI_TYPE,receiver, &
- itag2,buffer_received_faces_scalar,npoin2D_eta(1),CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
- ! all slices add the buffer received to the contributions on the left face
- if(iproc_eta > 0) then
- do ipoin=1,npoin2D_eta(1)
- array_val(iboolleft_eta(ipoin)) = array_val(iboolleft_eta(ipoin)) + &
- buffer_received_faces_scalar(ipoin)
- enddo
- endif
-
- ! the contributions are correctly assembled on the left side of each slice
- ! now we have to send the result back to the sender
- ! all slices copy the left face into the buffer
- do ipoin=1,npoin2D_eta(1)
- buffer_send_faces_scalar(ipoin) = array_val(iboolleft_eta(ipoin))
- enddo
-
- ! send messages backward along each row
- if(iproc_eta == NPROC_ETA-1) then
- sender = MPI_PROC_NULL
- else
- sender = addressing(ichunk,iproc_xi,iproc_eta + 1)
- endif
- if(iproc_eta == 0) then
- receiver = MPI_PROC_NULL
- else
- receiver = addressing(ichunk,iproc_xi,iproc_eta - 1)
- endif
- call MPI_SENDRECV(buffer_send_faces_scalar,npoin2D_eta(1),CUSTOM_MPI_TYPE,receiver, &
- itag2,buffer_received_faces_scalar,npoin2D_eta(2),CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
- ! all slices copy the buffer received to the contributions on the right face
- if(iproc_eta < NPROC_ETA-1) then
- do ipoin=1,npoin2D_eta(2)
- array_val(iboolright_eta(ipoin)) = buffer_received_faces_scalar(ipoin)
- enddo
- endif
-
- endif
-
-!----
-!---- start MPI assembling phase between chunks
-!----
-
-! check flag to see if we need to assemble (might be turned off when debugging)
-! and do not assemble if only one chunk
- if (.not. ACTUALLY_ASSEMBLE_MPI_CHUNKS .or. NCHUNKS == 1) return
-
-! ***************************************************************
-! transmit messages in forward direction (iprocfrom -> iprocto)
-! ***************************************************************
-
-!---- put slices in receive mode
-!---- a given slice can belong to at most two faces
-
-! use three step scheme that can never deadlock
-! scheme for faces cannot deadlock even if NPROC_XI = NPROC_ETA = 1
- do imsg_loop = 1,NUM_MSG_TYPES
-
- icount_faces = 0
- do imsg = 1,NUMMSGS_FACES
- if(myrank==iprocfrom_faces(imsg) .or. &
- myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
- if(myrank==iprocto_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
- sender = iprocfrom_faces(imsg)
- npoin2D_chunks = npoin2D_faces(icount_faces)
- call MPI_RECV(buffer_received_faces_scalar, &
- npoin2D_chunks,CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
- do ipoin2D=1,npoin2D_chunks
- array_val(iboolfaces(ipoin2D,icount_faces)) = &
- array_val(iboolfaces(ipoin2D,icount_faces)) + buffer_received_faces_scalar(ipoin2D)
- enddo
- endif
- enddo
-
- !---- put slices in send mode
- !---- a given slice can belong to at most two faces
- icount_faces = 0
- do imsg = 1,NUMMSGS_FACES
- if(myrank==iprocfrom_faces(imsg) .or. &
- myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
- if(myrank==iprocfrom_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
- receiver = iprocto_faces(imsg)
- npoin2D_chunks = npoin2D_faces(icount_faces)
- do ipoin2D=1,npoin2D_chunks
- buffer_send_faces_scalar(ipoin2D) = array_val(iboolfaces(ipoin2D,icount_faces))
- enddo
- call MPI_SEND(buffer_send_faces_scalar,npoin2D_chunks, &
- CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
- endif
- enddo
-
- ! *********************************************************************
- ! transmit messages back in opposite direction (iprocto -> iprocfrom)
- ! *********************************************************************
-
- !---- put slices in receive mode
- !---- a given slice can belong to at most two faces
-
- icount_faces = 0
- do imsg = 1,NUMMSGS_FACES
- if(myrank==iprocfrom_faces(imsg) .or. &
- myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
- if(myrank==iprocfrom_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
- sender = iprocto_faces(imsg)
- npoin2D_chunks = npoin2D_faces(icount_faces)
- call MPI_RECV(buffer_received_faces_scalar, &
- npoin2D_chunks,CUSTOM_MPI_TYPE,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
- do ipoin2D=1,npoin2D_chunks
- array_val(iboolfaces(ipoin2D,icount_faces)) = buffer_received_faces_scalar(ipoin2D)
- enddo
- endif
- enddo
-
- !---- put slices in send mode
- !---- a given slice can belong to at most two faces
- icount_faces = 0
- do imsg = 1,NUMMSGS_FACES
- if(myrank==iprocfrom_faces(imsg) .or. &
- myrank==iprocto_faces(imsg)) icount_faces = icount_faces + 1
- if(myrank==iprocto_faces(imsg) .and. imsg_type(imsg) == imsg_loop) then
- receiver = iprocfrom_faces(imsg)
- npoin2D_chunks = npoin2D_faces(icount_faces)
- do ipoin2D=1,npoin2D_chunks
- buffer_send_faces_scalar(ipoin2D) = array_val(iboolfaces(ipoin2D,icount_faces))
- enddo
- call MPI_SEND(buffer_send_faces_scalar,npoin2D_chunks, &
- CUSTOM_MPI_TYPE,receiver,itag,MPI_COMM_WORLD,ier)
- endif
- enddo
-
-! end of anti-deadlocking loop
- enddo
-
-!----
-!---- start MPI assembling corners
-!----
-
-! scheme for corners cannot deadlock even if NPROC_XI = NPROC_ETA = 1
-
-! ***************************************************************
-! transmit messages in forward direction (two workers -> master)
-! ***************************************************************
-
- icount_corners = 0
-
- do imsg = 1,NCORNERSCHUNKS
-
- if(myrank == iproc_master_corners(imsg) .or. &
- myrank == iproc_worker1_corners(imsg) .or. &
- (NCHUNKS /= 2 .and. myrank == iproc_worker2_corners(imsg))) icount_corners = icount_corners + 1
-
- !---- receive messages from the two workers on the master
- if(myrank==iproc_master_corners(imsg)) then
-
- ! receive from worker #1 and add to local array
- sender = iproc_worker1_corners(imsg)
- call MPI_RECV(buffer_recv_chunkcorn_scalar,NGLOB1D_RADIAL, &
- CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
- do ipoin1D=1,NGLOB1D_RADIAL
- array_val(iboolcorner(ipoin1D,icount_corners)) = array_val(iboolcorner(ipoin1D,icount_corners)) + &
- buffer_recv_chunkcorn_scalar(ipoin1D)
- enddo
-
- ! receive from worker #2 and add to local array
- if(NCHUNKS /= 2) then
- sender = iproc_worker2_corners(imsg)
- call MPI_RECV(buffer_recv_chunkcorn_scalar,NGLOB1D_RADIAL, &
- CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
- do ipoin1D=1,NGLOB1D_RADIAL
- array_val(iboolcorner(ipoin1D,icount_corners)) = array_val(iboolcorner(ipoin1D,icount_corners)) + &
- buffer_recv_chunkcorn_scalar(ipoin1D)
- enddo
- endif
-
- endif
-
- !---- send messages from the two workers to the master
- if(myrank==iproc_worker1_corners(imsg) .or. &
- (NCHUNKS /= 2 .and. myrank==iproc_worker2_corners(imsg))) then
-
- receiver = iproc_master_corners(imsg)
- do ipoin1D=1,NGLOB1D_RADIAL
- buffer_send_chunkcorn_scalar(ipoin1D) = array_val(iboolcorner(ipoin1D,icount_corners))
- enddo
- call MPI_SEND(buffer_send_chunkcorn_scalar,NGLOB1D_RADIAL,CUSTOM_MPI_TYPE, &
- receiver,itag,MPI_COMM_WORLD,ier)
-
- endif
-
- ! *********************************************************************
- ! transmit messages back in opposite direction (master -> two workers)
- ! *********************************************************************
-
- !---- receive messages from the master on the two workers
- if(myrank==iproc_worker1_corners(imsg) .or. &
- (NCHUNKS /= 2 .and. myrank==iproc_worker2_corners(imsg))) then
-
- ! receive from master and copy to local array
- sender = iproc_master_corners(imsg)
- call MPI_RECV(buffer_recv_chunkcorn_scalar,NGLOB1D_RADIAL, &
- CUSTOM_MPI_TYPE,sender,itag,MPI_COMM_WORLD,msg_status,ier)
- do ipoin1D=1,NGLOB1D_RADIAL
- array_val(iboolcorner(ipoin1D,icount_corners)) = buffer_recv_chunkcorn_scalar(ipoin1D)
- enddo
-
- endif
-
- !---- send messages from the master to the two workers
- if(myrank==iproc_master_corners(imsg)) then
-
- do ipoin1D=1,NGLOB1D_RADIAL
- buffer_send_chunkcorn_scalar(ipoin1D) = array_val(iboolcorner(ipoin1D,icount_corners))
- enddo
-
- ! send to worker #1
- receiver = iproc_worker1_corners(imsg)
- call MPI_SEND(buffer_send_chunkcorn_scalar,NGLOB1D_RADIAL,CUSTOM_MPI_TYPE, &
- receiver,itag,MPI_COMM_WORLD,ier)
-
- ! send to worker #2
- if(NCHUNKS /= 2) then
- receiver = iproc_worker2_corners(imsg)
- call MPI_SEND(buffer_send_chunkcorn_scalar,NGLOB1D_RADIAL,CUSTOM_MPI_TYPE, &
- receiver,itag,MPI_COMM_WORLD,ier)
- endif
-
- endif
-
- enddo
-
- end subroutine assemble_MPI_scalar_block
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine assemble_MPI_scalar(NPROC,NGLOB_AB,array_val, &
- num_interfaces,max_nibool_interfaces, &
- nibool_interfaces,ibool_interfaces, &
- my_neighbours)
-
-! blocking send/receive
-
- implicit none
-
- include "constants.h"
-
- integer :: NPROC
- integer :: NGLOB_AB
-
- ! array to assemble
- real(kind=CUSTOM_REAL), dimension(NGLOB_AB) :: array_val
-
- integer :: num_interfaces,max_nibool_interfaces
- integer, dimension(num_interfaces) :: nibool_interfaces,my_neighbours
- integer, dimension(max_nibool_interfaces,num_interfaces) :: ibool_interfaces
-
- ! local parameters
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_send_scalar
- real(kind=CUSTOM_REAL), dimension(:,:), allocatable :: buffer_recv_scalar
- integer, dimension(:), allocatable :: request_send_scalar
- integer, dimension(:), allocatable :: request_recv_scalar
-
-
- integer ipoin,iinterface,ier
-
-! here we have to assemble all the contributions between partitions using MPI
-
- ! assemble only if more than one partition
- if(NPROC > 1) then
-
- allocate(buffer_send_scalar(max_nibool_interfaces,num_interfaces),stat=ier)
- if( ier /= 0 ) stop 'error allocating array buffer_send_scalar'
- allocate(buffer_recv_scalar(max_nibool_interfaces,num_interfaces),stat=ier)
- if( ier /= 0 ) stop 'error allocating array buffer_recv_scalar'
- allocate(request_send_scalar(num_interfaces),stat=ier)
- if( ier /= 0 ) stop 'error allocating array request_send_scalar'
- allocate(request_recv_scalar(num_interfaces),stat=ier)
- if( ier /= 0 ) stop 'error allocating array request_recv_scalar'
-
- ! partition border copy into the buffer
- do iinterface = 1, num_interfaces
- do ipoin = 1, nibool_interfaces(iinterface)
- buffer_send_scalar(ipoin,iinterface) = array_val(ibool_interfaces(ipoin,iinterface))
- enddo
- enddo
-
- ! send messages
- do iinterface = 1, num_interfaces
- ! non-blocking synchronous send request
- call isend_cr(buffer_send_scalar(1:nibool_interfaces(iinterface),iinterface), &
- nibool_interfaces(iinterface), &
- my_neighbours(iinterface), &
- itag, &
- request_send_scalar(iinterface) &
- )
- ! receive request
- call irecv_cr(buffer_recv_scalar(1:nibool_interfaces(iinterface),iinterface), &
- nibool_interfaces(iinterface), &
- my_neighbours(iinterface), &
- itag, &
- request_recv_scalar(iinterface) &
- )
- enddo
-
- ! wait for communications completion (recv)
- do iinterface = 1, num_interfaces
- call wait_req(request_recv_scalar(iinterface))
- enddo
-
- ! adding contributions of neighbours
- do iinterface = 1, num_interfaces
- do ipoin = 1, nibool_interfaces(iinterface)
- array_val(ibool_interfaces(ipoin,iinterface)) = &
- array_val(ibool_interfaces(ipoin,iinterface)) + buffer_recv_scalar(ipoin,iinterface)
- enddo
- enddo
-
- ! wait for communications completion (send)
- do iinterface = 1, num_interfaces
- call wait_req(request_send_scalar(iinterface))
- enddo
-
- deallocate(buffer_send_scalar)
- deallocate(buffer_recv_scalar)
- deallocate(request_send_scalar)
- deallocate(request_recv_scalar)
-
- endif
-
- end subroutine assemble_MPI_scalar
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/assemble_MPI_vector_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/assemble_MPI_vector_mesh.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/assemble_MPI_vector_mesh.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,125 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 assemble_MPI_vector(NPROC,NGLOB_AB,array_val, &
- num_interfaces,max_nibool_interfaces, &
- nibool_interfaces,ibool_interfaces, &
- my_neighbours)
-
- implicit none
-
- include "constants.h"
-
- integer :: NPROC
- integer :: NGLOB_AB
-
-! array to assemble
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB_AB) :: array_val
-
- integer :: num_interfaces,max_nibool_interfaces
- integer, dimension(num_interfaces) :: nibool_interfaces,my_neighbours
- integer, dimension(max_nibool_interfaces,num_interfaces) :: ibool_interfaces
-
- ! local parameters
-
- ! send/receive temporary buffers
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: buffer_send_vector
- real(kind=CUSTOM_REAL), dimension(:,:,:), allocatable :: buffer_recv_vector
-
- ! requests
- integer, dimension(:), allocatable :: request_send_vector
- integer, dimension(:), allocatable :: request_recv_vector
-
- integer ipoin,iinterface,ier
-
-
-! here we have to assemble all the contributions between partitions using MPI
-
- ! assemble only if more than one partition
- if(NPROC > 1) then
-
- allocate(buffer_send_vector(NDIM,max_nibool_interfaces,num_interfaces),stat=ier)
- if( ier /= 0 ) stop 'error allocating array buffer_send_vector'
- allocate(buffer_recv_vector(NDIM,max_nibool_interfaces,num_interfaces),stat=ier)
- if( ier /= 0 ) stop 'error allocating array buffer_recv_vector'
- allocate(request_send_vector(num_interfaces),stat=ier)
- if( ier /= 0 ) stop 'error allocating array request_send_vector'
- allocate(request_recv_vector(num_interfaces),stat=ier)
- if( ier /= 0 ) stop 'error allocating array request_recv_vector'
-
- ! partition border copy into the buffer
- do iinterface = 1, num_interfaces
- do ipoin = 1, nibool_interfaces(iinterface)
- buffer_send_vector(:,ipoin,iinterface) = &
- array_val(:,ibool_interfaces(ipoin,iinterface))
- enddo
- enddo
-
- ! send messages
- do iinterface = 1, num_interfaces
- call isend_cr(buffer_send_vector(1,1,iinterface), &
- NDIM*nibool_interfaces(iinterface), &
- my_neighbours(iinterface), &
- itag, &
- request_send_vector(iinterface) &
- )
- call irecv_cr(buffer_recv_vector(1,1,iinterface), &
- NDIM*nibool_interfaces(iinterface), &
- my_neighbours(iinterface), &
- itag, &
- request_recv_vector(iinterface) &
- )
- enddo
-
- ! wait for communications completion (recv)
- do iinterface = 1, num_interfaces
- call wait_req(request_recv_vector(iinterface))
- enddo
-
- ! adding contributions of neighbours
- do iinterface = 1, num_interfaces
- do ipoin = 1, nibool_interfaces(iinterface)
- array_val(:,ibool_interfaces(ipoin,iinterface)) = &
- array_val(:,ibool_interfaces(ipoin,iinterface)) &
- + buffer_recv_vector(:,ipoin,iinterface)
- enddo
- enddo
-
- ! wait for communications completion (send)
- do iinterface = 1, num_interfaces
- call wait_req(request_send_vector(iinterface))
- enddo
-
- deallocate(buffer_send_vector)
- deallocate(buffer_recv_vector)
- deallocate(request_send_vector)
- deallocate(request_recv_vector)
-
- endif
-
- end subroutine assemble_MPI_vector
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/compute_area.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/compute_area.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/compute_area.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,97 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 compute_area(myrank,NCHUNKS,iregion_code, &
- area_local_bottom,area_local_top,&
- volume_local,volume_total, &
- RCMB,RICB,R_CENTRAL_CUBE)
-
- use meshfem3D_models_par
-
- implicit none
-
- integer :: myrank,NCHUNKS,iregion_code
-
- double precision :: area_local_bottom,area_local_top,volume_local
- double precision :: volume_total
- double precision :: RCMB,RICB,R_CENTRAL_CUBE
-
- ! local parameters
- double precision :: volume_total_region,area_total_bottom,area_total_top
-
- ! use MPI reduction to compute total area and volume
- volume_total_region = ZERO
- area_total_bottom = ZERO
- area_total_top = ZERO
-
- call sum_all_dp(area_local_bottom,area_total_bottom)
- call sum_all_dp(area_local_top,area_total_top)
- call sum_all_dp(volume_local,volume_total_region)
-
- 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 .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 .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 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 compute_area
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/compute_volumes.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/compute_volumes.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/compute_volumes.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,111 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 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
-
- ! calculates volume of all elements in mesh
- 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
-
- ! area of bottom surface
- 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
-
- ! area of top surface
- 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 compute_volumes
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_MPI_interfaces.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_MPI_interfaces.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_MPI_interfaces.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,670 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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_MPI_interfaces(iregion_code)
-
- implicit none
-
- integer,intent(in):: iregion_code
-
- ! sets up arrays
- call cmi_allocate_addressing(iregion_code)
-
- ! gets in arrays
- call cmi_get_addressing(iregion_code)
-
- ! reads "iboolleft_..txt", "iboolright_..txt" (and "list_messages_..txt", "buffer_...txt") files and sets up MPI buffers
- call cmi_get_buffers(iregion_code)
-
- end subroutine create_MPI_interfaces
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine cmi_allocate_addressing(iregion_code)
-
- use meshfem3D_par,only: &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP,NSPEC,NGLOB, &
- myrank,NGLOB1D_RADIAL,NUMCORNERS_SHARED,NGLLX,NGLLY,NGLLZ
-
- use create_MPI_interfaces_par
-
- use MPI_crust_mantle_par
- use MPI_outer_core_par
- use MPI_inner_core_par
-
- implicit none
-
- integer,intent(in):: iregion_code
-
- ! local parameters
- integer :: ier
-
- ! parameters from header file
- NGLOB1D_RADIAL_CM = NGLOB1D_RADIAL(IREGION_CRUST_MANTLE)
- NGLOB1D_RADIAL_OC = NGLOB1D_RADIAL(IREGION_OUTER_CORE)
- NGLOB1D_RADIAL_IC = NGLOB1D_RADIAL(IREGION_INNER_CORE)
-
- ! initializes
- NSPEC_CRUST_MANTLE = 0
- NGLOB_CRUST_MANTLE = 0
-
- NSPEC_OUTER_CORE = 0
- NGLOB_OUTER_CORE = 0
-
- NSPEC_INNER_CORE = 0
- NGLOB_INNER_CORE = 0
-
- select case( iregion_code )
- case( IREGION_CRUST_MANTLE )
- NGLOB2DMAX_XMIN_XMAX_CM = NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE)
- NGLOB2DMAX_YMIN_YMAX_CM = NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE)
-
- NSPEC2DMAX_XMIN_XMAX_CM = NSPEC2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE)
- NSPEC2DMAX_YMIN_YMAX_CM = NSPEC2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE)
- NSPEC2D_BOTTOM_CM = NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE)
- NSPEC2D_TOP_CM = NSPEC2D_TOP(IREGION_CRUST_MANTLE)
-
- NSPEC_CRUST_MANTLE = NSPEC(IREGION_CRUST_MANTLE)
- NGLOB_CRUST_MANTLE = NGLOB(IREGION_CRUST_MANTLE)
-
- case( IREGION_OUTER_CORE )
- NGLOB2DMAX_XMIN_XMAX_OC = NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE)
- NGLOB2DMAX_YMIN_YMAX_OC = NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE)
-
- NSPEC2DMAX_XMIN_XMAX_OC = NSPEC2DMAX_XMIN_XMAX(IREGION_OUTER_CORE)
- NSPEC2DMAX_YMIN_YMAX_OC = NSPEC2DMAX_YMIN_YMAX(IREGION_OUTER_CORE)
- NSPEC2D_BOTTOM_OC = NSPEC2D_BOTTOM(IREGION_OUTER_CORE)
- NSPEC2D_TOP_OC = NSPEC2D_TOP(IREGION_OUTER_CORE)
-
- NSPEC_OUTER_CORE = NSPEC(IREGION_OUTER_CORE)
- NGLOB_OUTER_CORE = NGLOB(IREGION_OUTER_CORE)
-
- case( IREGION_INNER_CORE )
- NGLOB2DMAX_XMIN_XMAX_IC = NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE)
- NGLOB2DMAX_YMIN_YMAX_IC = NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE)
-
- NSPEC2DMAX_XMIN_XMAX_IC = NSPEC2DMAX_XMIN_XMAX(IREGION_INNER_CORE)
- NSPEC2DMAX_YMIN_YMAX_IC = NSPEC2DMAX_YMIN_YMAX(IREGION_INNER_CORE)
- NSPEC2D_BOTTOM_IC = NSPEC2D_BOTTOM(IREGION_INNER_CORE)
- NSPEC2D_TOP_IC = NSPEC2D_TOP(IREGION_INNER_CORE)
-
- NSPEC_INNER_CORE = NSPEC(IREGION_INNER_CORE)
- NGLOB_INNER_CORE = NGLOB(IREGION_INNER_CORE)
-
- case default
- stop 'error iregion_code value not recognized'
- end select
-
- ! allocates arrays
- allocate(buffer_send_chunkcorn_scalar(NGLOB1D_RADIAL_CM), &
- buffer_recv_chunkcorn_scalar(NGLOB1D_RADIAL_CM))
-
- allocate(buffer_send_chunkcorn_vector(NDIM,NGLOB1D_RADIAL_CM + NGLOB1D_RADIAL_IC), &
- buffer_recv_chunkcorn_vector(NDIM,NGLOB1D_RADIAL_CM + NGLOB1D_RADIAL_IC))
-
- select case( iregion_code )
- case( IREGION_CRUST_MANTLE )
- ! crust mantle
- allocate(iboolcorner_crust_mantle(NGLOB1D_RADIAL_CM,NUMCORNERS_SHARED))
- allocate(iboolleft_xi_crust_mantle(NGLOB2DMAX_XMIN_XMAX_CM), &
- iboolright_xi_crust_mantle(NGLOB2DMAX_XMIN_XMAX_CM))
- allocate(iboolleft_eta_crust_mantle(NGLOB2DMAX_YMIN_YMAX_CM), &
- iboolright_eta_crust_mantle(NGLOB2DMAX_YMIN_YMAX_CM))
- allocate(iboolfaces_crust_mantle(NGLOB2DMAX_XY,NUMFACES_SHARED))
-
- ! crust mantle mesh
- allocate(xstore_crust_mantle(NGLOB_CRUST_MANTLE), &
- ystore_crust_mantle(NGLOB_CRUST_MANTLE), &
- zstore_crust_mantle(NGLOB_CRUST_MANTLE), &
- stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating temporary crust mantle arrays')
-
- case( IREGION_OUTER_CORE )
- ! outer core
- allocate(iboolcorner_outer_core(NGLOB1D_RADIAL_OC,NUMCORNERS_SHARED))
- allocate(iboolleft_xi_outer_core(NGLOB2DMAX_XMIN_XMAX_OC), &
- iboolright_xi_outer_core(NGLOB2DMAX_XMIN_XMAX_OC))
- allocate(iboolleft_eta_outer_core(NGLOB2DMAX_YMIN_YMAX_OC), &
- iboolright_eta_outer_core(NGLOB2DMAX_YMIN_YMAX_OC))
- allocate(iboolfaces_outer_core(NGLOB2DMAX_XY,NUMFACES_SHARED))
-
- ! outer core mesh
- allocate(xstore_outer_core(NGLOB_OUTER_CORE), &
- ystore_outer_core(NGLOB_OUTER_CORE), &
- zstore_outer_core(NGLOB_OUTER_CORE), &
- stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating temporary outer core arrays')
-
- case( IREGION_INNER_CORE )
- ! inner core
- allocate(iboolcorner_inner_core(NGLOB1D_RADIAL_IC,NUMCORNERS_SHARED))
- allocate(iboolleft_xi_inner_core(NGLOB2DMAX_XMIN_XMAX_IC), &
- iboolright_xi_inner_core(NGLOB2DMAX_XMIN_XMAX_IC))
- allocate(iboolleft_eta_inner_core(NGLOB2DMAX_YMIN_YMAX_IC), &
- iboolright_eta_inner_core(NGLOB2DMAX_YMIN_YMAX_IC))
- allocate(iboolfaces_inner_core(NGLOB2DMAX_XY,NUMFACES_SHARED))
-
- ! inner core mesh
- allocate(xstore_inner_core(NGLOB_INNER_CORE), &
- ystore_inner_core(NGLOB_INNER_CORE), &
- zstore_inner_core(NGLOB_INNER_CORE), &
- stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating temporary inner core arrays')
-
- end select
-
- ! synchronize processes
- call sync_all()
-
- end subroutine cmi_allocate_addressing
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine cmi_get_addressing(iregion_code)
-
- use meshfem3D_par,only: &
- myrank
-
- use meshfem3D_par,only: &
- ibool
-
- use create_MPI_interfaces_par
- use MPI_crust_mantle_par
- use MPI_outer_core_par
- use MPI_inner_core_par
- implicit none
-
- integer,intent(in):: iregion_code
-
- ! read coordinates of the mesh
- select case( iregion_code )
- case( IREGION_CRUST_MANTLE )
- ! crust mantle
-! ibool_crust_mantle(:,:,:,:) = -1
- call cmi_read_solver_data(NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle)
-
- ! check that the number of points in this slice is correct
- if(minval(ibool(:,:,:,:)) /= 1 .or. &
- maxval(ibool(:,:,:,:)) /= NGLOB_CRUST_MANTLE) &
- call exit_MPI(myrank,'incorrect global numbering: iboolmax does not equal nglob in crust and mantle')
-
- case( IREGION_OUTER_CORE )
- ! outer core
-! ibool_outer_core(:,:,:,:) = -1
- call cmi_read_solver_data(NSPEC_OUTER_CORE,NGLOB_OUTER_CORE, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core)
-
- ! check that the number of points in this slice is correct
- if(minval(ibool(:,:,:,:)) /= 1 .or. &
- maxval(ibool(:,:,:,:)) /= NGLOB_OUTER_CORE) &
- call exit_MPI(myrank,'incorrect global numbering: iboolmax does not equal nglob in outer core')
-
- case( IREGION_INNER_CORE )
- ! inner core
-! ibool_inner_core(:,:,:,:) = -1
- call cmi_read_solver_data(NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core)
-
- ! check that the number of points in this slice is correct
- if(minval(ibool(:,:,:,:)) /= 1 .or. &
- maxval(ibool(:,:,:,:)) /= NGLOB_INNER_CORE) &
- call exit_MPI(myrank,'incorrect global numbering: iboolmax does not equal nglob in inner core')
-
- end select
-
- ! synchronize processes
- call sync_all()
-
- end subroutine cmi_get_addressing
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine cmi_get_buffers(iregion_code)
-
- use meshfem3D_par,only: myrank,&
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- NGLOB1D_RADIAL,NSPEC2D_BOTTOM, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NPROC_XI,NPROC_ETA,NCHUNKS,OUTPUT_FILES,IIN,INCLUDE_CENTRAL_CUBE, &
- iproc_xi,iproc_eta,ichunk,addressing
-
- use meshfem3D_par,only: &
- ibool,idoubling,is_on_a_slice_edge
-
- use create_regions_mesh_par2,only: &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
-
- use create_MPI_interfaces_par
-
- use MPI_crust_mantle_par
- use MPI_outer_core_par
- use MPI_inner_core_par
-
- implicit none
-
- integer,intent(in):: iregion_code
-
- ! local parameters
- integer :: ier
- ! for central cube buffers
- integer :: nspec2D_xmin_inner_core,nspec2D_xmax_inner_core, &
- nspec2D_ymin_inner_core,nspec2D_ymax_inner_core
- integer, dimension(:),allocatable :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
- integer, dimension(:),allocatable :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
- integer, dimension(:),allocatable :: ibelm_top_inner_core
-
- ! debug file output
- character(len=150) :: filename
- logical,parameter :: DEBUG = .false.
-
- ! gets 2-D addressing for summation between slices with MPI
-
- select case( iregion_code )
- case( IREGION_CRUST_MANTLE )
- ! mantle and crust
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'crust/mantle region:'
- endif
- call cmi_read_buffer_data(IREGION_CRUST_MANTLE, &
- NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE), &
- NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE), &
- NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle, &
- iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iboolfaces_crust_mantle,npoin2D_faces_crust_mantle, &
- iboolcorner_crust_mantle)
-
- ! note: fix_... routines below update is_on_a_slice_edge_.. arrays:
- ! assign flags for each element which is on a rim of the slice
- ! thus, they include elements on top and bottom not shared with other MPI partitions
- !
- ! we will re-set these flags when setting up inner/outer elements, but will
- ! use these arrays for now as initial guess for the search for elements which share a global point
- ! between different MPI processes
- call fix_non_blocking_slices(is_on_a_slice_edge, &
- iboolright_xi_crust_mantle,iboolleft_xi_crust_mantle, &
- iboolright_eta_crust_mantle,iboolleft_eta_crust_mantle, &
- npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- ibool, &
- NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE,NGLOB2DMAX_XMIN_XMAX_CM,NGLOB2DMAX_YMIN_YMAX_CM)
-
- ! debug: saves element flags
- if( DEBUG ) then
- write(filename,'(a,i6.6)') trim(OUTPUT_FILES)//'/MPI_is_on_a_slice_edge_crust_mantle_proc',myrank
- call write_VTK_data_elem_l(NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- ibool,is_on_a_slice_edge,filename)
- endif
-
- ! added this to reduce the size of the buffers
- ! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
- !npoin2D_max_all_CM_IC = max(maxval(npoin2D_xi_crust_mantle(:) + npoin2D_xi_inner_core(:)), &
- ! maxval(npoin2D_eta_crust_mantle(:) + npoin2D_eta_inner_core(:)))
- npoin2D_max_all_CM_IC = max(maxval(npoin2D_xi_crust_mantle(:)), &
- maxval(npoin2D_eta_crust_mantle(:)))
-
- case( IREGION_OUTER_CORE )
- ! outer core
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'outer core region:'
- endif
- call cmi_read_buffer_data(IREGION_OUTER_CORE, &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- iboolleft_xi_outer_core,iboolright_xi_outer_core, &
- iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,npoin2D_faces_outer_core, &
- iboolcorner_outer_core)
-
- ! note: fix_... routines below update is_on_a_slice_edge_.. arrays:
- ! assign flags for each element which is on a rim of the slice
- ! thus, they include elements on top and bottom not shared with other MPI partitions
- !
- ! we will re-set these flags when setting up inner/outer elements, but will
- ! use these arrays for now as initial guess for the search for elements which share a global point
- ! between different MPI processes
- call fix_non_blocking_slices(is_on_a_slice_edge, &
- iboolright_xi_outer_core,iboolleft_xi_outer_core, &
- iboolright_eta_outer_core,iboolleft_eta_outer_core, &
- npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- ibool, &
- NSPEC_OUTER_CORE,NGLOB_OUTER_CORE,NGLOB2DMAX_XMIN_XMAX_OC,NGLOB2DMAX_YMIN_YMAX_OC)
-
- ! debug: saves element flags
- if( DEBUG ) then
- write(filename,'(a,i6.6)') trim(OUTPUT_FILES)//'/MPI_is_on_a_slice_edge_outer_core_proc',myrank
- call write_VTK_data_elem_l(NSPEC_OUTER_CORE,NGLOB_OUTER_CORE, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- ibool,is_on_a_slice_edge,filename)
- endif
-
- ! added this to reduce the size of the buffers
- ! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
- npoin2D_max_all_CM_IC = max(maxval(npoin2D_xi_outer_core(:)), &
- maxval(npoin2D_eta_outer_core(:)))
-
- case( IREGION_INNER_CORE )
- ! inner core
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'inner core region:'
- endif
- call cmi_read_buffer_data(IREGION_INNER_CORE, &
- NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE), &
- NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE), &
- NGLOB1D_RADIAL(IREGION_INNER_CORE), &
- iboolleft_xi_inner_core,iboolright_xi_inner_core, &
- iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,npoin2D_faces_inner_core, &
- iboolcorner_inner_core)
-
- ! central cube buffers
- if(INCLUDE_CENTRAL_CUBE) then
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'including central cube'
- endif
- call sync_all()
-
- ! allocates boundary indexing arrays for central cube
- allocate(ibelm_xmin_inner_core(NSPEC2DMAX_XMIN_XMAX_IC), &
- ibelm_xmax_inner_core(NSPEC2DMAX_XMIN_XMAX_IC), &
- ibelm_ymin_inner_core(NSPEC2DMAX_YMIN_YMAX_IC), &
- ibelm_ymax_inner_core(NSPEC2DMAX_YMIN_YMAX_IC), &
- ibelm_top_inner_core(NSPEC2D_TOP_IC), &
- ibelm_bottom_inner_core(NSPEC2D_BOTTOM_IC), &
- stat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error allocating central cube index arrays')
-
- ! gets coupling arrays for inner core
- nspec2D_xmin_inner_core = nspec2D_xmin
- nspec2D_xmax_inner_core = nspec2D_xmax
- nspec2D_ymin_inner_core = nspec2D_ymin
- nspec2D_ymax_inner_core = nspec2D_ymax
-
- ibelm_xmin_inner_core(:) = ibelm_xmin(:)
- ibelm_xmax_inner_core(:) = ibelm_xmax(:)
- ibelm_ymin_inner_core(:) = ibelm_ymin(:)
- ibelm_ymax_inner_core(:) = ibelm_ymax(:)
- ibelm_bottom_inner_core(:) = ibelm_bottom(:)
- ibelm_top_inner_core(:) = ibelm_top(:)
-
- ! compute number of messages to expect in cube as well as their size
- call comp_central_cube_buffer_size(iproc_xi,iproc_eta,ichunk, &
- NPROC_XI,NPROC_ETA,NSPEC2D_BOTTOM(IREGION_INNER_CORE), &
- nb_msgs_theor_in_cube,npoin2D_cube_from_slices)
-
- ! this value is used for dynamic memory allocation, therefore make sure it is never zero
- if(nb_msgs_theor_in_cube > 0) then
- non_zero_nb_msgs_theor_in_cube = nb_msgs_theor_in_cube
- else
- non_zero_nb_msgs_theor_in_cube = 1
- endif
-
- ! 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), &
- 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')
-
- ! handles the communications with the central cube if it was included in the mesh
- ! create buffers to assemble with the central cube
- call create_central_cube_buffers(myrank,iproc_xi,iproc_eta,ichunk, &
- NPROC_XI,NPROC_ETA,NCHUNKS, &
- NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
- NSPEC2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NSPEC2DMAX_YMIN_YMAX(IREGION_INNER_CORE), &
- NSPEC2D_BOTTOM(IREGION_INNER_CORE), &
- addressing,ibool,idoubling, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- nspec2D_xmin_inner_core,nspec2D_xmax_inner_core, &
- nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
- ibelm_xmin_inner_core,ibelm_xmax_inner_core, &
- ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
- nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices, &
- receiver_cube_from_slices,sender_from_slices_to_cube,ibool_central_cube, &
- buffer_slices,buffer_slices2,buffer_all_cube_from_slices)
-
- if(myrank == 0) write(IMAIN,*) ''
-
- ! frees memory
- deallocate(ibelm_xmin_inner_core,ibelm_xmax_inner_core)
- deallocate(ibelm_ymin_inner_core,ibelm_ymax_inner_core)
- deallocate(ibelm_top_inner_core)
-
- else
-
- ! allocate fictitious buffers for cube and slices with a dummy size
- ! just to be able to use them as arguments in subroutine calls
- allocate(sender_from_slices_to_cube(1), &
- buffer_all_cube_from_slices(1,1,1), &
- buffer_slices(1,1), &
- buffer_slices2(1,1), &
- ibool_central_cube(1,1),stat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error allocating dummy buffers')
-
- endif
-
- ! note: fix_... routines below update is_on_a_slice_edge_.. arrays:
- ! assign flags for each element which is on a rim of the slice
- ! thus, they include elements on top and bottom not shared with other MPI partitions
- !
- ! we will re-set these flags when setting up inner/outer elements, but will
- ! use these arrays for now as initial guess for the search for elements which share a global point
- ! between different MPI processes
- call fix_non_blocking_slices(is_on_a_slice_edge, &
- iboolright_xi_inner_core,iboolleft_xi_inner_core, &
- iboolright_eta_inner_core,iboolleft_eta_inner_core, &
- npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- ibool, &
- NSPEC_INNER_CORE,NGLOB_INNER_CORE,NGLOB2DMAX_XMIN_XMAX_IC,NGLOB2DMAX_YMIN_YMAX_IC)
-
- if(INCLUDE_CENTRAL_CUBE) then
- ! updates flags for elements on slice boundaries
- call fix_non_blocking_central_cube(is_on_a_slice_edge, &
- ibool,NSPEC_INNER_CORE,NGLOB_INNER_CORE,nb_msgs_theor_in_cube,ibelm_bottom_inner_core, &
- idoubling,npoin2D_cube_from_slices, &
- ibool_central_cube,NSPEC2D_BOTTOM(IREGION_INNER_CORE), &
- ichunk,NPROC_XI)
- endif
-
- ! debug: saves element flags
- if( DEBUG ) then
- write(filename,'(a,i6.6)') trim(OUTPUT_FILES)//'/MPI_is_on_a_slice_edge_inner_core_proc',myrank
- call write_VTK_data_elem_l(NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- ibool,is_on_a_slice_edge,filename)
- endif
-
- ! added this to reduce the size of the buffers
- ! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
- npoin2D_max_all_CM_IC = max(maxval(npoin2D_xi_inner_core(:)), &
- maxval(npoin2D_eta_inner_core(:)))
-
- end select
-
-
- end subroutine cmi_get_buffers
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine cmi_read_solver_data(nspec,nglob,xstore_s,ystore_s,zstore_s)
-
-
- use meshfem3D_par,only: &
- xstore,ystore,zstore,ibool
-
- implicit none
-
- include "constants.h"
-
- integer :: nspec,nglob
-
- ! global mesh points
- real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_s,ystore_s,zstore_s
-
- ! local parameters
- integer :: i,j,k,ispec,iglob
-
- ! fill custom_real arrays
- do ispec = 1,nspec
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- iglob = ibool(i,j,k,ispec)
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- xstore_s(iglob) = sngl(xstore(i,j,k,ispec))
- ystore_s(iglob) = sngl(ystore(i,j,k,ispec))
- zstore_s(iglob) = sngl(zstore(i,j,k,ispec))
- else
- xstore_s(iglob) = xstore(i,j,k,ispec)
- ystore_s(iglob) = ystore(i,j,k,ispec)
- zstore_s(iglob) = zstore(i,j,k,ispec)
- endif
- enddo
- enddo
- enddo
- enddo
-
- end subroutine cmi_read_solver_data
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine cmi_read_buffer_data(iregion_code, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- NGLOB1D_RADIAL, &
- iboolleft_xi_s,iboolright_xi_s, &
- iboolleft_eta_s,iboolright_eta_s, &
- npoin2D_xi_s,npoin2D_eta_s, &
- iboolfaces_s,npoin2D_faces_s, &
- iboolcorner_s)
-
- use meshfem3D_par,only: &
- myrank,IMAIN,NDIM,NUMFACES_SHARED,NUMCORNERS_SHARED,NPROC_XI,NPROC_ETA
-
- use create_MPI_interfaces_par
-
- implicit none
-
- integer :: iregion_code
-
- integer :: NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
- integer :: NGLOB1D_RADIAL
-
- integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi_s,iboolright_xi_s
- integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta_s,iboolright_eta_s
-
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_s,npoin2D_eta_s
-
- integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces_s
- integer, dimension(NUMFACES_SHARED) :: npoin2D_faces_s
-
- integer, dimension(NGLOB1D_RADIAL,NUMCORNERS_SHARED) :: iboolcorner_s
-
- ! local parameters
- integer :: icount_faces,imsg
-
- ! gets 2-D arrays
- npoin2D_xi_s(:) = npoin2D_xi_all(:)
- npoin2D_eta_s(:) = npoin2D_eta_all(:)
-
- ! gets mpi buffers on sides
- iboolleft_xi_s(:) = iboolleft_xi(:)
- iboolright_xi_s(:) = iboolright_xi(:)
- iboolleft_eta_s(:) = iboolleft_eta(:)
- iboolright_eta_s(:) = iboolright_eta(:)
-
- ! gets corner infos
- iboolcorner_s(:,:) = iboolcorner(:,:)
-
- ! gets face infos
- npoin2D_faces_s(:) = npoin2D_faces(:)
- iboolfaces_s(:,:) = iboolfaces(:,:)
-
- ! checks indirect addressing for each message for faces of the chunks
- ! a given slice can belong to at most two faces
- icount_faces = 0
- do imsg = 1,NUMMSGS_FACES
- if(myrank == iprocfrom_faces(imsg) .or. myrank == iprocto_faces(imsg)) then
- icount_faces = icount_faces + 1
-
- if(icount_faces > NUMFACES_SHARED) then
- print*,'error ',myrank,' icount_faces: ',icount_faces,'NUMFACES_SHARED:',NUMFACES_SHARED
- print*,'iregion_code:',iregion_code
- call exit_MPI(myrank,'more than NUMFACES_SHARED faces for this slice')
- endif
- if(icount_faces > 2 .and. (NPROC_XI > 1 .or. NPROC_ETA > 1)) then
- print*,'error ',myrank,' icount_faces: ',icount_faces,'NPROC_XI:',NPROC_XI,'NPROC_ETA:',NPROC_ETA
- print*,'iregion_code:',iregion_code
- call exit_MPI(myrank,'more than two faces for this slice')
- endif
- endif
- enddo
-
- ! user output
- if(myrank == 0) then
- write(IMAIN,*) ' #max of points in MPI buffers along xi npoin2D_xi = ', &
- maxval(npoin2D_xi_s(:))
- write(IMAIN,*) ' #max of array elements transferred npoin2D_xi*NDIM = ', &
- maxval(npoin2D_xi_s(:))*NDIM
- write(IMAIN,*)
- write(IMAIN,*) ' #max of points in MPI buffers along eta npoin2D_eta = ', &
- maxval(npoin2D_eta_s(:))
- write(IMAIN,*) ' #max of array elements transferred npoin2D_eta*NDIM = ', &
- maxval(npoin2D_eta_s(:))*NDIM
- write(IMAIN,*)
- endif
-
- end subroutine cmi_read_buffer_data
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_addressing.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_addressing.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_addressing.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,129 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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_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)
-
- ! output a topology map of slices - fix 20x by nproc
- if (myrank == 0 ) then
- if( NCHUNKS == 6 .and. NPROCTOT < 1000 ) then
- write(IMAIN,*) 'Spatial distribution of the slices'
- do iproc_xi = NPROC_XI-1, 0, -1
- write(IMAIN,'(20x)',advance='no')
- do iproc_eta = NPROC_ETA -1, 0, -1
- ichunk = CHUNK_AB
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(1x)',advance='yes')
- enddo
- write(IMAIN, *) ' '
- do iproc_xi = NPROC_XI-1, 0, -1
- write(IMAIN,'(1x)',advance='no')
- do iproc_eta = NPROC_ETA -1, 0, -1
- ichunk = CHUNK_BC
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(3x)',advance='no')
- do iproc_eta = NPROC_ETA -1, 0, -1
- ichunk = CHUNK_AC
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(3x)',advance='no')
- do iproc_eta = NPROC_ETA -1, 0, -1
- ichunk = CHUNK_BC_ANTIPODE
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(1x)',advance='yes')
- enddo
- write(IMAIN, *) ' '
- do iproc_xi = NPROC_XI-1, 0, -1
- write(IMAIN,'(20x)',advance='no')
- do iproc_eta = NPROC_ETA -1, 0, -1
- ichunk = CHUNK_AB_ANTIPODE
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(1x)',advance='yes')
- enddo
- write(IMAIN, *) ' '
- do iproc_xi = NPROC_XI-1, 0, -1
- write(IMAIN,'(20x)',advance='no')
- do iproc_eta = NPROC_ETA -1, 0, -1
- ichunk = CHUNK_AC_ANTIPODE
- write(IMAIN,'(i5)',advance='no') addressing(ichunk,iproc_xi,iproc_eta)
- enddo
- write(IMAIN,'(1x)',advance='yes')
- enddo
- write(IMAIN, *) ' '
- endif
- endif
-
- end subroutine create_addressing
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_central_cube_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_central_cube_buffers.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_central_cube_buffers.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,633 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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.
-!
-!=====================================================================
-
-!
-!--- create buffers to assemble with central cube
-!
-
- subroutine create_central_cube_buffers(myrank,iproc_xi,iproc_eta,ichunk, &
- NPROC_XI,NPROC_ETA,NCHUNKS, &
- NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
- NSPEC2DMAX_XMIN_XMAX_INNER_CORE,NSPEC2DMAX_YMIN_YMAX_INNER_CORE, &
- NSPEC2D_BOTTOM_INNER_CORE, &
- addressing,ibool_inner_core,idoubling_inner_core, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- nspec2D_xmin_inner_core,nspec2D_xmax_inner_core, &
- nspec2D_ymin_inner_core,nspec2D_ymax_inner_core, &
- ibelm_xmin_inner_core,ibelm_xmax_inner_core, &
- ibelm_ymin_inner_core,ibelm_ymax_inner_core,ibelm_bottom_inner_core, &
- nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices, &
- receiver_cube_from_slices,sender_from_slices_to_cube,ibool_central_cube, &
- buffer_slices,buffer_slices2,buffer_all_cube_from_slices)
-
- implicit none
-
- ! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
-
- integer, intent(in) :: myrank,iproc_xi,iproc_eta,ichunk, &
- NPROC_XI,NPROC_ETA,NCHUNKS,NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
- NSPEC2DMAX_XMIN_XMAX_INNER_CORE,NSPEC2DMAX_YMIN_YMAX_INNER_CORE,NSPEC2D_BOTTOM_INNER_CORE
-
- ! for addressing of the slices
- integer, dimension(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1), intent(in) :: addressing
-
- ! mesh parameters
- integer, dimension(NGLLX,NGLLY,NGLLZ,NSPEC_INNER_CORE), intent(in) :: ibool_inner_core
-
- ! local to global mapping
- integer, dimension(NSPEC_INNER_CORE), intent(in) :: idoubling_inner_core
-
- real(kind=CUSTOM_REAL), dimension(NGLOB_INNER_CORE), intent(in) :: xstore_inner_core,ystore_inner_core,zstore_inner_core
-
- ! boundary parameters locator
- integer, intent(in) :: nspec2D_xmin_inner_core,nspec2D_xmax_inner_core,nspec2D_ymin_inner_core,nspec2D_ymax_inner_core
- integer, dimension(NSPEC2DMAX_XMIN_XMAX_INNER_CORE), intent(in) :: ibelm_xmin_inner_core,ibelm_xmax_inner_core
- integer, dimension(NSPEC2DMAX_YMIN_YMAX_INNER_CORE), intent(in) :: ibelm_ymin_inner_core,ibelm_ymax_inner_core
- integer, dimension(NSPEC2D_BOTTOM_INNER_CORE), intent(in) :: ibelm_bottom_inner_core
-
- integer, intent(in) :: nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices
-
- ! for matching with central cube in inner core
- integer, intent(out) :: receiver_cube_from_slices
-
- integer, dimension(non_zero_nb_msgs_theor_in_cube), intent(out) :: sender_from_slices_to_cube
- integer, dimension(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices), intent(out) :: ibool_central_cube
- double precision, dimension(npoin2D_cube_from_slices,NDIM), intent(out) :: buffer_slices,buffer_slices2
- double precision, dimension(non_zero_nb_msgs_theor_in_cube,npoin2D_cube_from_slices,NDIM), intent(out) :: &
- buffer_all_cube_from_slices
-
- ! local variables below
- integer i,j,k,ispec,ispec2D,iglob,ier
- integer sender,receiver,imsg,ipoin,iproc_xi_loop
-
- double precision x_target,y_target,z_target
- double precision x_current,y_current,z_current
-
- ! MPI status of messages to be received
- integer msg_status(MPI_STATUS_SIZE)
-
- integer :: nproc_xi_half_floor,nproc_xi_half_ceil
-
- if( mod(NPROC_XI,2) /= 0 ) then
- nproc_xi_half_floor = floor(NPROC_XI/2.d0)
- nproc_xi_half_ceil = ceiling(NPROC_XI/2.d0)
- else
- nproc_xi_half_floor = NPROC_XI/2
- nproc_xi_half_ceil = NPROC_XI/2
- endif
-
- ! check that the number of points in this slice is correct
- if(minval(ibool_inner_core(:,:,:,:)) /= 1 .or. maxval(ibool_inner_core(:,:,:,:)) /= NGLOB_INNER_CORE) &
- call exit_MPI(myrank,'incorrect global numbering: iboolmax does not equal nglob in inner core')
-
-
-!--- processor to send information to in cube from slices
-
-! four vertical sides first
- if(ichunk == CHUNK_AC) then
- if (iproc_xi < nproc_xi_half_floor) then
- receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1,iproc_eta)
- else
- receiver_cube_from_slices = addressing(CHUNK_AB,0,iproc_eta)
- endif
- else if(ichunk == CHUNK_BC) then
- if (iproc_xi < nproc_xi_half_floor) then
- receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1-iproc_eta,NPROC_ETA-1)
- else
- receiver_cube_from_slices = addressing(CHUNK_AB,iproc_eta,NPROC_ETA-1)
- endif
- else if(ichunk == CHUNK_AC_ANTIPODE) then
- if (iproc_xi <= ceiling((NPROC_XI/2.d0)-1)) then
- receiver_cube_from_slices = addressing(CHUNK_AB,NPROC_XI-1,iproc_eta)
- else
- receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,0,iproc_eta)
- endif
- else if(ichunk == CHUNK_BC_ANTIPODE) then
- if (iproc_xi < nproc_xi_half_floor) then
- receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,iproc_eta,0)
- else
- receiver_cube_from_slices = addressing(CHUNK_AB,NPROC_XI-1-iproc_eta,0)
- endif
-! bottom of cube, direct correspondance but with inverted xi axis
- else if(ichunk == CHUNK_AB_ANTIPODE) then
- receiver_cube_from_slices = addressing(CHUNK_AB,NPROC_XI-1-iproc_xi,iproc_eta)
- else if(ichunk == CHUNK_AB) then
- receiver_cube_from_slices = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1-iproc_xi,iproc_eta)
- endif
-
-
-!--- list of processors to receive information from in cube
-
-! only for slices in central cube
- if(ichunk == CHUNK_AB) then
- ! initialize index of sender
- imsg = 0
-
- ! define sender for xi = xi_min edge
- if(iproc_xi == 0) then
- do iproc_xi_loop = nproc_xi_half_floor,NPROC_XI-1
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC,iproc_xi_loop,iproc_eta)
- enddo
- endif
-
- ! define sender for xi = xi_max edge
- if(iproc_xi == NPROC_XI-1) then
- do iproc_xi_loop = 0, floor((NPROC_XI-1)/2.d0)
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC_ANTIPODE,iproc_xi_loop,iproc_eta)
- enddo
- endif
-
- ! define sender for eta = eta_min edge
- if(iproc_eta == 0) then
- do iproc_xi_loop = nproc_xi_half_floor,NPROC_XI-1
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC_ANTIPODE,iproc_xi_loop,NPROC_ETA-1-iproc_xi)
- enddo
- endif
-
- ! define sender for eta = eta_max edge
- if(iproc_eta == NPROC_ETA-1) then
- do iproc_xi_loop = nproc_xi_half_floor,NPROC_XI-1
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC,iproc_xi_loop,iproc_xi)
- enddo
- endif
-
- ! define sender for bottom edge
- ! bottom of cube, direct correspondence but with inverted xi axis
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AB_ANTIPODE,NPROC_XI-1-iproc_xi,iproc_eta)
-
- ! check that total number of faces found is correct
- if(imsg /= nb_msgs_theor_in_cube) then
- print*,'error ',myrank,'nb_msgs_theor_in_cube:',nb_msgs_theor_in_cube,imsg
- call exit_MPI(myrank,'wrong number of faces found for central cube')
- endif
-
- else if(ichunk == CHUNK_AB_ANTIPODE) then
- ! initialize index of sender
- imsg = 0
-
- ! define sender for xi = xi_min edge
- if(iproc_xi == 0) then
- do iproc_xi_loop = nproc_xi_half_ceil,NPROC_XI-1
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC_ANTIPODE,iproc_xi_loop,iproc_eta)
- enddo
- endif
-
- ! define sender for xi = xi_max edge
- if(iproc_xi == NPROC_XI-1) then
- do iproc_xi_loop = 0, floor((NPROC_XI/2.d0)-1.d0)
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC,iproc_xi_loop,iproc_eta)
- enddo
- endif
-
- ! define sender for eta = eta_min edge
- if(iproc_eta == 0) then
- do iproc_xi_loop = 0, floor((NPROC_XI/2.d0)-1.d0)
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC_ANTIPODE,iproc_xi_loop,iproc_xi)
- enddo
- endif
-
- ! define sender for eta = eta_max edge
- if(iproc_eta == NPROC_ETA-1) then
- do iproc_xi_loop = 0, floor((NPROC_XI/2.d0)-1.d0)
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC,iproc_xi_loop,NPROC_ETA-1-iproc_xi)
- enddo
- endif
-
- ! in case NPROC_XI == 1, the other chunks exchange all bottom points with
- ! CHUNK_AB **and** CHUNK_AB_ANTIPODE
- if(NPROC_XI==1) then
- ! define sender for xi = xi_min edge
- if(iproc_xi == 0) then
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC_ANTIPODE,0,iproc_eta)
- endif
-
- ! define sender for xi = xi_max edge
- if(iproc_xi == NPROC_XI-1) then
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AC,0,iproc_eta)
- endif
-
- ! define sender for eta = eta_min edge
- if(iproc_eta == 0) then
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC_ANTIPODE,0,iproc_xi)
- endif
-
- ! define sender for eta = eta_max edge
- if(iproc_eta == NPROC_ETA-1) then
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_BC,0,NPROC_ETA-1-iproc_xi)
- endif
- endif
-
- ! define sender for bottom edge
- ! bottom of cube, direct correspondence but with inverted xi axis
- imsg = imsg + 1
- sender_from_slices_to_cube(imsg) = addressing(CHUNK_AB,NPROC_XI-1-iproc_xi,iproc_eta)
-
- ! check that total number of faces found is correct
- if(imsg /= nb_msgs_theor_in_cube) then
- print*,'error ',myrank,'nb_msgs_theor_in_cube:',nb_msgs_theor_in_cube,imsg
- call exit_MPI(myrank,'wrong number of faces found for central cube')
- endif
-
- else
-
- ! dummy value in slices
- sender_from_slices_to_cube(1) = -1
-
- endif
-
-
-! on chunk AB & AB ANTIPODE, receive all (except bottom) the messages from slices
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
- do imsg = 1,nb_msgs_theor_in_cube-1
-
- ! receive buffers from slices
- sender = sender_from_slices_to_cube(imsg)
- call MPI_RECV(buffer_slices, &
- NDIM*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
- ! copy buffer in 2D array for each slice
- buffer_all_cube_from_slices(imsg,:,:) = buffer_slices(:,:)
-
- enddo
- endif
-
- ! send info to central cube from all the slices except those in CHUNK_AB & CHUNK_AB_ANTIPODE
- if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE ) then
- ! for bottom elements in contact with central cube from the slices side
- ipoin = 0
- do ispec2D = 1,NSPEC2D_BOTTOM_INNER_CORE
-
- ispec = ibelm_bottom_inner_core(ispec2D)
-
- ! only for DOFs exactly on surface of central cube (bottom of these elements)
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
- ipoin = ipoin + 1
- iglob = ibool_inner_core(i,j,k,ispec)
- buffer_slices(ipoin,1) = dble(xstore_inner_core(iglob))
- buffer_slices(ipoin,2) = dble(ystore_inner_core(iglob))
- buffer_slices(ipoin,3) = dble(zstore_inner_core(iglob))
- enddo
- enddo
- enddo
-
- ! send buffer to central cube
- receiver = receiver_cube_from_slices
- call MPI_SEND(buffer_slices,NDIM*npoin2D_cube_from_slices, &
- MPI_DOUBLE_PRECISION,receiver,itag,MPI_COMM_WORLD,ier)
-
- ! in case NPROC_XI == 1, the other chunks exchange all bottom points with
- ! CHUNK_AB **and** CHUNK_AB_ANTIPODE
- if(NPROC_XI==1) then
- call MPI_SEND(buffer_slices,NDIM*npoin2D_cube_from_slices, &
- MPI_DOUBLE_PRECISION, &
- addressing(CHUNK_AB_ANTIPODE,0,iproc_eta), &
- itag,MPI_COMM_WORLD,ier)
- endif
-
- endif ! end sending info to central cube
-
-
- ! exchange of their bottom faces between chunks AB and AB_ANTIPODE
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
- ipoin = 0
- do ispec = NSPEC_INNER_CORE, 1, -1
- if (idoubling_inner_core(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE) then
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
- ipoin = ipoin + 1
- iglob = ibool_inner_core(i,j,k,ispec)
- buffer_slices(ipoin,1) = dble(xstore_inner_core(iglob))
- buffer_slices(ipoin,2) = dble(ystore_inner_core(iglob))
- buffer_slices(ipoin,3) = dble(zstore_inner_core(iglob))
- enddo
- enddo
- endif
- enddo
- if (ipoin /= npoin2D_cube_from_slices) then
- print*,'error',myrank,'bottom points:',npoin2D_cube_from_slices,ipoin
- call exit_MPI(myrank,'wrong number of points found for bottom CC AB or !AB')
- endif
-
- sender = sender_from_slices_to_cube(nb_msgs_theor_in_cube)
-
- call MPI_SENDRECV(buffer_slices,NDIM*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,receiver_cube_from_slices, &
- itag,buffer_slices2,NDIM*npoin2D_cube_from_slices,MPI_DOUBLE_PRECISION,sender, &
- itag,MPI_COMM_WORLD,msg_status,ier)
-
- buffer_all_cube_from_slices(nb_msgs_theor_in_cube,:,:) = buffer_slices2(:,:)
-
- endif
-
- !--- now we need to find the points received and create indirect addressing
- ibool_central_cube(:,:) = -1
-
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
-
- do imsg = 1,nb_msgs_theor_in_cube
-
- do ipoin = 1,npoin2D_cube_from_slices
-
- x_target = buffer_all_cube_from_slices(imsg,ipoin,1)
- y_target = buffer_all_cube_from_slices(imsg,ipoin,2)
- z_target = buffer_all_cube_from_slices(imsg,ipoin,3)
-
- ! x = x_min
- do ispec2D = 1,nspec2D_xmin_inner_core
- ispec = ibelm_xmin_inner_core(ispec2D)
- ! do not loop on elements outside of the central cube
- if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
- ! check
- if(idoubling_inner_core(ispec) == IFLAG_IN_FICTITIOUS_CUBE ) stop 'error xmin ibelm'
- i = 1
- do k = 1,NGLLZ
- do j = 1,NGLLY
- iglob = ibool_inner_core(i,j,k,ispec)
- x_current = dble(xstore_inner_core(iglob))
- y_current = dble(ystore_inner_core(iglob))
- z_current = dble(zstore_inner_core(iglob))
- ! look for matching point
- if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
- ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
- goto 100
- endif
- enddo
- enddo
- enddo
-
- ! x = x_max
- do ispec2D = 1,nspec2D_xmax_inner_core
- ispec = ibelm_xmax_inner_core(ispec2D)
- ! do not loop on elements outside of the central cube
- if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
- !check
- if(idoubling_inner_core(ispec) == IFLAG_IN_FICTITIOUS_CUBE ) stop 'error xmax ibelm'
- i = NGLLX
- do k = 1,NGLLZ
- do j = 1,NGLLY
- iglob = ibool_inner_core(i,j,k,ispec)
- x_current = dble(xstore_inner_core(iglob))
- y_current = dble(ystore_inner_core(iglob))
- z_current = dble(zstore_inner_core(iglob))
- ! look for matching point
- if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
- ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
- goto 100
- endif
- enddo
- enddo
- enddo
-
- ! y = y_min
- do ispec2D = 1,nspec2D_ymin_inner_core
- ispec = ibelm_ymin_inner_core(ispec2D)
- ! do not loop on elements outside of the central cube
- if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
- !check
- if(idoubling_inner_core(ispec) == IFLAG_IN_FICTITIOUS_CUBE ) stop 'error ymin ibelm'
- j = 1
- do k = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool_inner_core(i,j,k,ispec)
- x_current = dble(xstore_inner_core(iglob))
- y_current = dble(ystore_inner_core(iglob))
- z_current = dble(zstore_inner_core(iglob))
- ! look for matching point
- if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
- ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
- goto 100
- endif
- enddo
- enddo
- enddo
-
- ! y = y_max
- do ispec2D = 1,nspec2D_ymax_inner_core
- ispec = ibelm_ymax_inner_core(ispec2D)
- ! do not loop on elements outside of the central cube
- if(idoubling_inner_core(ispec) /= IFLAG_MIDDLE_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE .and. &
- idoubling_inner_core(ispec) /= IFLAG_TOP_CENTRAL_CUBE) cycle
- !check
- if(idoubling_inner_core(ispec) == IFLAG_IN_FICTITIOUS_CUBE ) stop 'error ymax ibelm'
- j = NGLLY
- do k = 1,NGLLZ
- do i = 1,NGLLX
- iglob = ibool_inner_core(i,j,k,ispec)
- x_current = dble(xstore_inner_core(iglob))
- y_current = dble(ystore_inner_core(iglob))
- z_current = dble(zstore_inner_core(iglob))
- ! look for matching point
- if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
- ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
- goto 100
- endif
- enddo
- enddo
- enddo
-
- ! bottom of cube
- do ispec = 1,NSPEC_INNER_CORE
- ! loop on elements at the bottom of the cube only
- if(idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE) cycle
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
- iglob = ibool_inner_core(i,j,k,ispec)
- x_current = dble(xstore_inner_core(iglob))
- y_current = dble(ystore_inner_core(iglob))
- z_current = dble(zstore_inner_core(iglob))
- ! look for matching point
- if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
- ibool_central_cube(imsg,ipoin) = ibool_inner_core(i,j,k,ispec)
- goto 100
- endif
- enddo
- enddo
- enddo
-
- ! point not found so far
- if(NPROC_XI==1) then
- ! ignores point
- ibool_central_cube(imsg,ipoin) = 0
- else
- ! check that a matching point is found in all cases
- call exit_MPI(myrank,'point never found in central cube')
- endif
-
- 100 continue
-
- enddo ! ipoin
-
- ! checks ibool array
- if(NPROC_XI==1) then
- if( minval(ibool_central_cube(imsg,:)) < 0 ) call exit_mpi(myrank,'error ibool_central_cube point not found')
-
- ! removes points on bottom surface in antipode chunk for other chunks than its AB sharing chunk
- ! (to avoid adding the same point twice from other chunks)
- if( ichunk == CHUNK_AB_ANTIPODE .and. imsg < nb_msgs_theor_in_cube ) then
- do ipoin = 1,npoin2D_cube_from_slices
- x_target = buffer_all_cube_from_slices(imsg,ipoin,1)
- y_target = buffer_all_cube_from_slices(imsg,ipoin,2)
- z_target = buffer_all_cube_from_slices(imsg,ipoin,3)
-
- ! bottom of cube
- do ispec = 1,NSPEC_INNER_CORE
- ! loop on elements at the bottom of the cube only
- if(idoubling_inner_core(ispec) /= IFLAG_BOTTOM_CENTRAL_CUBE) cycle
- k = 1
- do j = 1,NGLLY
- do i = 1,NGLLX
- iglob = ibool_inner_core(i,j,k,ispec)
- x_current = dble(xstore_inner_core(iglob))
- y_current = dble(ystore_inner_core(iglob))
- z_current = dble(zstore_inner_core(iglob))
- ! look for matching point
- if(dsqrt((x_current-x_target)**2 + (y_current-y_target)**2 + (z_current-z_target)**2) < SMALLVALTOL) then
- ibool_central_cube(imsg,ipoin) = 0
- goto 200
- endif
- enddo
- enddo
- enddo
-
- 200 continue
-
- enddo ! ipoin
- endif
-
- endif ! NPROC_XI==1
-
- enddo ! imsg
- endif
-
- end subroutine create_central_cube_buffers
-
-!
-!----------------------------------
-!
-
- subroutine comp_central_cube_buffer_size(iproc_xi,iproc_eta,ichunk,NPROC_XI,NPROC_ETA,NSPEC2D_BOTTOM_INNER_CORE, &
- nb_msgs_theor_in_cube,npoin2D_cube_from_slices)
-
-!--- compute number of messages to expect in cube as well as their size
-!--- take into account vertical sides and bottom side
-
- implicit none
-
- include "constants.h"
-
- integer, intent(in) :: iproc_xi,iproc_eta,ichunk,NPROC_XI,NPROC_ETA,NSPEC2D_BOTTOM_INNER_CORE
-
- integer, intent(out) :: nb_msgs_theor_in_cube,npoin2D_cube_from_slices
-
- integer :: nproc_xi_half_floor,nproc_xi_half_ceil
-
- if( mod(NPROC_XI,2) /= 0 ) then
- nproc_xi_half_floor = floor(NPROC_XI/2.d0)
- nproc_xi_half_ceil = ceiling(NPROC_XI/2.d0)
- else
- nproc_xi_half_floor = NPROC_XI/2
- nproc_xi_half_ceil = NPROC_XI/2
- endif
-
-! only for slices in central cube
- if(ichunk == CHUNK_AB) then
- if(NPROC_XI == 1) then
- ! five sides if only one processor in cube
- nb_msgs_theor_in_cube = 5
- else
- ! case of a corner
- if((iproc_xi == 0 .or. iproc_xi == NPROC_XI-1).and. &
- (iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1)) then
- ! slices on both "vertical" faces plus one slice at the bottom
- nb_msgs_theor_in_cube = 2*(nproc_xi_half_ceil) + 1
- ! case of an edge
- else if(iproc_xi == 0 .or. iproc_xi == NPROC_XI-1 .or. &
- iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1) then
- ! slices on the "vertical" face plus one slice at the bottom
- nb_msgs_theor_in_cube = nproc_xi_half_ceil + 1
- else
- ! bottom element only
- nb_msgs_theor_in_cube = 1
- endif
- endif
- else if(ichunk == CHUNK_AB_ANTIPODE) then
- if(NPROC_XI == 1) then
- ! five sides if only one processor in cube
- nb_msgs_theor_in_cube = 5
- else
- ! case of a corner
- if((iproc_xi == 0 .or. iproc_xi == NPROC_XI-1).and. &
- (iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1)) then
- ! slices on both "vertical" faces plus one slice at the bottom
- nb_msgs_theor_in_cube = 2*(nproc_xi_half_floor) + 1
- ! case of an edge
- else if(iproc_xi == 0 .or. iproc_xi == NPROC_XI-1 .or. &
- iproc_eta == 0 .or. iproc_eta == NPROC_ETA-1) then
- ! slices on the "vertical" face plus one slice at the bottom
- nb_msgs_theor_in_cube = nproc_xi_half_floor + 1
- else
- ! bottom element only
- nb_msgs_theor_in_cube = 1
- endif
- endif
- else
- ! not in chunk AB
- nb_msgs_theor_in_cube = 0
- endif
-
- ! number of points to send or receive (bottom of slices)
- npoin2D_cube_from_slices = NSPEC2D_BOTTOM_INNER_CORE * NGLLX * NGLLY
-
- end subroutine comp_central_cube_buffer_size
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_meshes.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_meshes.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/create_meshes.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,120 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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_meshes()
-
- use meshfem3D_par
- implicit none
-
- ! local parameters
- integer :: ipass
- integer :: ier
-
- ! 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 sync_all()
-
- !----
- !---- 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)), &
- ibool(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)), &
- xstore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)), &
- ystore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)), &
- zstore(NGLLX,NGLLY,NGLLZ,NSPEC(iregion_code)), &
- stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating memory for arrays')
-
- ! this for non blocking MPI
- allocate(is_on_a_slice_edge(NSPEC(iregion_code)), &
- stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating is_on_a_slice_edge array')
-
-
- ! 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, &
- NSPEC(iregion_code),NGLOB(iregion_code),npointot, &
- 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), &
- mod(iproc_xi_slice(myrank),2),mod(iproc_eta_slice(myrank),2), &
- ipass)
- enddo
-
- ! 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 sync_all()
-
- ! end of loop on all the regions
- enddo
-
- end subroutine create_meshes
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/finalize_mesher.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/finalize_mesher.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/finalize_mesher.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,178 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 finalize_mesher()
-
- use meshfem3D_par
- use meshfem3D_models_par
-
- implicit none
-
- ! local parameters
- ! timing
- double precision, external :: wtime
-
- !--- print number of points and elements in the mesh for each region
- if(myrank == 0) then
-
- ! check volume of chunk
- write(IMAIN,*)
- write(IMAIN,*) 'calculated volume: ',volume_total
- if(.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,*) ' exact 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,*) ' exact volume: ', &
- dble(NCHUNKS)*((4.0d0/3.0d0)*PI*(R_UNIT_SPHERE**3)-(2.*(R_CENTRAL_CUBE/R_EARTH)/sqrt(3.))**3)/6.d0
- endif
- endif
-
- ! infos output
- 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,TOPOGRAPHY, &
- ONE_CRUST,doubling_index,this_region_has_a_doubling,NCHUNKS, &
- ner,NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- ratio_sampling_array,NPROCTOT, &
- 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, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- static_memory_size)
-
- ! 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, &
- OCEANS,ATTENUATION,ATTENUATION_NEW,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, &
- 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)
-
- 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 = wtime() - time_start
- write(IMAIN,*)
- write(IMAIN,*) 'Elapsed time for mesh generation and buffer creation in seconds = ',tCPU
- write(IMAIN,"(' Elapsed time for mesh generation and buffer creation in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") &
- int(tCPU/3600),int( (tCPU - int(tCPU/3600)*3600)/60 ),int(tCPU - int(tCPU/60) * 60)
- write(IMAIN,*)
- 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 sync_all()
-
- if (ADIOS_ENABLED) then
- call adios_cleanup()
- endif
-
- end subroutine finalize_mesher
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/fix_non_blocking_flags.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/fix_non_blocking_flags.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/fix_non_blocking_flags.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,184 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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.
-!
-!=====================================================================
-
-! fix the non blocking arrays to assemble the slices inside each chunk: elements
-! in contact with the MPI faces by an edge or a corner only but not
-! a full face are missing, therefore let us add them
- subroutine fix_non_blocking_slices(is_on_a_slice_edge,iboolright_xi, &
- iboolleft_xi,iboolright_eta,iboolleft_eta, &
- npoin2D_xi,npoin2D_eta,ibool, &
- nspec,nglob,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX)
-
- implicit none
-
- include "constants.h"
-
- integer :: nspec,nglob,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
-
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi,npoin2D_eta
-
- logical, dimension(nspec) :: is_on_a_slice_edge
-
- integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
- integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
-
- ! local parameters
- logical, dimension(nglob) :: mask_ibool
- integer :: ipoin,ispec,i,j,k
-
-! clean the mask
- mask_ibool(:) = .false.
-
-! mark all the points that are in the MPI buffers to assemble inside each chunk
- do ipoin = 1,npoin2D_xi(1)
- mask_ibool(iboolleft_xi(ipoin)) = .true.
- enddo
-
- do ipoin = 1,npoin2D_eta(1)
- mask_ibool(iboolleft_eta(ipoin)) = .true.
- enddo
-
- do ipoin = 1,npoin2D_xi(2)
- mask_ibool(iboolright_xi(ipoin)) = .true.
- enddo
-
- do ipoin = 1,npoin2D_eta(2)
- mask_ibool(iboolright_eta(ipoin)) = .true.
- enddo
-
-! now label all the elements that have at least one corner belonging
-! to any of these buffers as elements that must contribute to the
-! first step of the calculations (performed on the edges before starting
-! the non blocking communications); there is no need to examine the inside
-! of the elements, checking their eight corners is sufficient
- do ispec = 1,nspec
- do k = 1,NGLLZ,NGLLZ-1
- do j = 1,NGLLY,NGLLY-1
- do i = 1,NGLLX,NGLLX-1
- if(mask_ibool(ibool(i,j,k,ispec))) then
- is_on_a_slice_edge(ispec) = .true.
- goto 888
- endif
- enddo
- enddo
- enddo
- 888 continue
- enddo
-
- end subroutine fix_non_blocking_slices
-
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-!-------------------------------------------------------------------------------------------------
-
-! fix the non blocking arrays to assemble the central cube: elements
-! in contact with the MPI faces by an edge or a corner only but not
-! a full face are missing, therefore let us add them
- subroutine fix_non_blocking_central_cube(is_on_a_slice_edge, &
- ibool,nspec,nglob,nb_msgs_theor_in_cube,ibelm_bottom_inner_core, &
- idoubling_inner_core,npoin2D_cube_from_slices, &
- ibool_central_cube,NSPEC2D_BOTTOM_INNER_CORE, &
- ichunk,NPROC_XI)
-
- implicit none
-
- include "constants.h"
-
- integer :: nspec,nglob,nb_msgs_theor_in_cube,NSPEC2D_BOTTOM_INNER_CORE
- integer :: ichunk,npoin2D_cube_from_slices,NPROC_XI
-
- logical, dimension(nspec) :: is_on_a_slice_edge
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
-
- integer, dimension(nb_msgs_theor_in_cube,npoin2D_cube_from_slices) :: ibool_central_cube
-
- integer, dimension(NSPEC2D_BOTTOM_INNER_CORE) :: ibelm_bottom_inner_core
-
- integer, dimension(nspec) :: idoubling_inner_core
-
- ! local parameters
- logical, dimension(nglob) :: mask_ibool
- integer :: ipoin,ispec,i,j,k,imsg,ispec2D
-
- if(ichunk /= CHUNK_AB .and. ichunk /= CHUNK_AB_ANTIPODE) then
- do ispec2D = 1,NSPEC2D_BOTTOM_INNER_CORE
- ispec = ibelm_bottom_inner_core(ispec2D)
- is_on_a_slice_edge(ispec) = .true.
- enddo
- endif
-
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
- do ispec = 1,nspec
- if(idoubling_inner_core(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
- idoubling_inner_core(ispec) == IFLAG_TOP_CENTRAL_CUBE) &
- is_on_a_slice_edge(ispec) = .true.
- enddo
- endif
-
- if(ichunk == CHUNK_AB .or. ichunk == CHUNK_AB_ANTIPODE) then
-
- ! clean the mask
- mask_ibool(:) = .false.
-
- do imsg = 1,nb_msgs_theor_in_cube
- do ipoin = 1,npoin2D_cube_from_slices
- if(NPROC_XI==1) then
- if(ibool_central_cube(imsg,ipoin) > 0 ) then
- mask_ibool(ibool_central_cube(imsg,ipoin)) = .true.
- endif
- else
- mask_ibool(ibool_central_cube(imsg,ipoin)) = .true.
- endif
- enddo
- enddo
-
- ! now label all the elements that have at least one corner belonging
- ! to any of these buffers as elements that must contribute to the
- ! first step of the calculations (performed on the edges before starting
- ! the non blocking communications); there is no need to examine the inside
- ! of the elements, checking their eight corners is sufficient
- do ispec = 1,nspec
- do k = 1,NGLLZ,NGLLZ-1
- do j = 1,NGLLY,NGLLY-1
- do i = 1,NGLLX,NGLLX-1
- if(mask_ibool(ibool(i,j,k,ispec))) then
- is_on_a_slice_edge(ispec) = .true.
- goto 888
- endif
- enddo
- enddo
- enddo
- 888 continue
- enddo
-
- endif
-
- end subroutine fix_non_blocking_central_cube
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_MPI_interfaces.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_MPI_interfaces.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/get_MPI_interfaces.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,746 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 get_MPI_interfaces(myrank,NGLOB,NSPEC, &
- test_flag,my_neighbours,nibool_neighbours,ibool_neighbours, &
- num_interfaces,max_nibool_interfaces, &
- max_nibool,MAX_NEIGHBOURS, &
- ibool,&
- is_on_a_slice_edge, &
- IREGION,add_central_cube,idoubling,INCLUDE_CENTRAL_CUBE, &
- xstore,ystore,zstore,NPROCTOT)
-
- use constants,only: CUSTOM_REAL,NGLLX,NGLLY,NGLLZ,IREGION_INNER_CORE,IFLAG_IN_FICTITIOUS_CUBE
- implicit none
-
- integer,intent(in) :: myrank,NGLOB,NSPEC
-
- real(kind=CUSTOM_REAL),dimension(NGLOB),intent(in) :: test_flag
-
- integer,intent(in) :: max_nibool
- integer,intent(in) :: MAX_NEIGHBOURS
- integer, dimension(MAX_NEIGHBOURS),intent(inout) :: my_neighbours,nibool_neighbours
- integer, dimension(max_nibool,MAX_NEIGHBOURS),intent(inout) :: ibool_neighbours
-
- integer,intent(inout) :: num_interfaces,max_nibool_interfaces
-
- integer,dimension(NGLLX,NGLLY,NGLLZ,NSPEC),intent(in) :: ibool
-
- logical,dimension(NSPEC),intent(inout) :: is_on_a_slice_edge
-
- integer,intent(in) :: IREGION
- logical,intent(in) :: add_central_cube
- integer,dimension(NSPEC),intent(in) :: idoubling
-
- logical,intent(in) :: INCLUDE_CENTRAL_CUBE
-
- real(kind=CUSTOM_REAL),dimension(NGLOB),intent(in) :: xstore,ystore,zstore
-
- integer :: NPROCTOT
-
- ! local parameters
- integer :: ispec,iglob,j,k
- integer :: iface,iedge,icorner
- integer :: ii,iinterface,icurrent,rank
- integer :: npoin
- logical :: is_done,ispec_is_outer
- integer,dimension(NGLOB) :: work_test_flag
- logical,dimension(NSPEC) :: work_ispec_is_outer
-
- integer,parameter :: MID = (NGLLX+1)/2
-
- ! initializes
- if( add_central_cube) then
- ! adds points to existing inner_core interfaces
- iinterface = num_interfaces
- work_ispec_is_outer(:) = is_on_a_slice_edge(:)
- else
- ! creates new interfaces
- iinterface = 0
- num_interfaces = 0
- max_nibool_interfaces = 0
- my_neighbours(:) = -1
- nibool_neighbours(:) = 0
- ibool_neighbours(:,:) = 0
- work_ispec_is_outer(:) = .false.
- endif
-
- ! makes working copy (converted to nearest integers)
- work_test_flag(:) = nint( test_flag(:) )
-
- ! loops over all elements
- do ispec = 1,NSPEC
-
- ! exclude elements in inner part of slice
- !if( .not. is_on_a_slice_edge(ispec) ) cycle
-
- ! exclude elements in fictitious core
- if( IREGION == IREGION_INNER_CORE) then
- if( idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE ) cycle
- endif
-
- ! sets flag if element has global points shared with other processes
- ispec_is_outer = .false.
-
- ! 1. finds neighbours which share a whole face with this process
- ! (faces are shared only with 1 other neighbour process)
-
- ! loops over all faces of element
- do iface = 1, 6
-
- ! chooses a point inside face
- select case( iface )
- case( 1 )
- ! face I == 1
- iglob = ibool(1,MID,MID,ispec)
- case( 2 )
- ! face I == NGLLX
- iglob = ibool(NGLLX,MID,MID,ispec)
- case( 3 )
- ! face J == 1
- iglob = ibool(MID,1,MID,ispec)
- case( 4 )
- ! face J == NGLLY
- iglob = ibool(MID,NGLLY,MID,ispec)
- case( 5 )
- ! face K == 1
- iglob = ibool(MID,MID,1,ispec)
- case( 6 )
- ! face K == NGLLZ
- iglob = ibool(MID,MID,NGLLZ,ispec)
- end select
-
- ! checks assembled flag on global point
- if( work_test_flag(iglob) > 0 ) then
- ispec_is_outer = .true.
-
- ! rank of neighbor process
- rank = work_test_flag(iglob) - 1
-
- ! checks ranks range
- if( rank < 0 .or. rank >= NPROCTOT ) then
- print*,'error face rank: ',myrank,'ispec=',ispec
- print*,' neighbor rank = ',rank,'exceeds total nproc:',NPROCTOT
- print*,' face ',iface
- call exit_mpi(myrank,'error face neighbor mpi rank')
- endif
-
- ! checks if already stored
- icurrent = 0
- is_done = .false.
- do ii = 1,iinterface
- if( rank == my_neighbours(ii) ) then
- icurrent = ii
- is_done = .true.
- exit
- endif
- enddo
-
- ! updates interfaces array
- if( .not. is_done ) then
- iinterface = iinterface + 1
- if( iinterface > MAX_NEIGHBOURS ) then
- print*,'error interfaces rank:',myrank,'iinterface = ',iinterface,MAX_NEIGHBOURS
- call exit_mpi(myrank,'interface face exceeds MAX_NEIGHBOURS range')
- endif
- ! adds as neighbor new interface
- my_neighbours(iinterface) = rank
- icurrent = iinterface
- endif
- if( icurrent == 0 ) &
- call exit_mpi(myrank,'could not find current interface for this neighbor, please check my_neighbours')
-
- ! adds interface points and removes neighbor flag from face
- ! assumes NGLLX == NGLLY == NGLLZ
- do k=1,NGLLX
- do j=1,NGLLX
- select case( iface )
- case( 1 )
- ! face I == 1
- iglob = ibool(1,j,k,ispec)
- case( 2 )
- ! face I == NGLLX
- iglob = ibool(NGLLX,j,k,ispec)
- case( 3 )
- ! face J == 1
- iglob = ibool(j,1,k,ispec)
- case( 4 )
- ! face J == NGLLY
- iglob = ibool(j,NGLLY,k,ispec)
- case( 5 )
- ! face K == 1
- iglob = ibool(j,k,1,ispec)
- case( 6 )
- ! face K == NGLLZ
- iglob = ibool(j,k,NGLLZ,ispec)
- end select
-
- ! checks that we take each global point (on edges and corners) only once
- call add_interface_point(iglob,rank,icurrent, &
- nibool_neighbours,MAX_NEIGHBOURS, &
- ibool_neighbours,max_nibool, &
- work_test_flag,NGLOB,myrank, &
- .true.,add_central_cube)
- ! debug
- if( work_test_flag(iglob) < 0 ) then
- if( IREGION == IREGION_INNER_CORE .and. INCLUDE_CENTRAL_CUBE ) then
- ! we might have missed an interface point on an edge, just re-set to missing value
- print*,'warning face flag:',myrank,'ispec=',ispec,'rank=',rank
- print*,' flag=',work_test_flag(iglob),'iface jk=',iface,j,k,'missed iglob=',iglob
- !work_test_flag(iglob) = 0
- else
- print*,'error face flag:',myrank,'ispec=',ispec,'rank=',rank
- print*,' flag=',work_test_flag(iglob),'iface jk=',iface,j,k,'iglob=',iglob
- call exit_mpi(myrank,'error face flag')
- endif
- endif
-
- enddo
- enddo
- endif
- enddo ! iface
-
- ! 2. finds neighbours which share a single edge with this process
- ! note: by now, faces have subtracted their neighbours, edges can hold only one more process info
-
- ! loops over all edges of element
- do iedge = 1, 12
-
- ! chooses a point inside edge but not corner
- select case( iedge )
- case( 1 )
- ! face I == 1, J == 1
- iglob = ibool(1,1,MID,ispec)
- case( 2 )
- ! face I == 1, J == NGLLY
- iglob = ibool(1,NGLLY,MID,ispec)
- case( 3 )
- ! face I == 1, K == 1
- iglob = ibool(1,MID,1,ispec)
- case( 4 )
- ! face I == 1, K == NGLLZ
- iglob = ibool(1,MID,NGLLZ,ispec)
- case( 5 )
- ! face I == NGLLX, J == 1
- iglob = ibool(NGLLX,1,MID,ispec)
- case( 6 )
- ! face I == NGLLX, J == NGLLY
- iglob = ibool(NGLLX,NGLLY,MID,ispec)
- case( 7 )
- ! face I == NGLLX, K == 1
- iglob = ibool(NGLLX,MID,1,ispec)
- case( 8 )
- ! face I == NGLLX, K == NGLLZ
- iglob = ibool(NGLLX,MID,NGLLZ,ispec)
- case( 9 )
- ! face J == 1, K == 1
- iglob = ibool(MID,1,1,ispec)
- case( 10 )
- ! face J == 1, K == NGLLZ
- iglob = ibool(MID,1,NGLLZ,ispec)
- case( 11 )
- ! face J == NGLLY, K == 1
- iglob = ibool(MID,NGLLY,1,ispec)
- case( 12 )
- ! face J == NGLLY, K == NGLLZ
- iglob = ibool(MID,NGLLY,NGLLZ,ispec)
- end select
-
- ! checks assembled flag on global point
- if( work_test_flag(iglob) > 0 ) then
- ispec_is_outer = .true.
-
- ! rank of neighbor process
- rank = work_test_flag(iglob) - 1
-
- ! checks ranks range
- if( rank < 0 .or. rank >= NPROCTOT ) then
- print*,'error egde rank: ',myrank
- print*,' neighbor rank = ',rank,'exceeds total nproc:',NPROCTOT
- print*,' edge ',iedge
- call exit_mpi(myrank,'error edge neighbor mpi rank')
- endif
-
- ! checks if already stored
- icurrent = 0
- is_done = .false.
- do ii = 1,iinterface
- if( rank == my_neighbours(ii) ) then
- icurrent = ii
- is_done = .true.
- exit
- endif
- enddo
-
- ! updates interfaces array
- if( .not. is_done ) then
- iinterface = iinterface + 1
- if( iinterface > MAX_NEIGHBOURS ) then
- print*,'error interfaces rank:',myrank,'iinterface = ',iinterface,MAX_NEIGHBOURS
- call exit_mpi(myrank,'interface edge exceeds MAX_NEIGHBOURS range')
- endif
- ! adds as neighbor new interface
- my_neighbours(iinterface) = rank
- icurrent = iinterface
- endif
- if( icurrent == 0 ) &
- call exit_mpi(myrank,'could not find current interface for this neighbor, please check my_neighbours')
-
- ! adds interface points and removes neighbor flag from edge
- ! assumes NGLLX == NGLLY == NGLLZ
- do k = 1,NGLLX
- select case( iedge )
- case( 1 )
- ! face I == 1, J == 1
- iglob = ibool(1,1,k,ispec)
- case( 2 )
- ! face I == 1, J == NGLLY
- iglob = ibool(1,NGLLY,k,ispec)
- case( 3 )
- ! face I == 1, K == 1
- iglob = ibool(1,k,1,ispec)
- case( 4 )
- ! face I == 1, K == NGLLZ
- iglob = ibool(1,k,NGLLZ,ispec)
- case( 5 )
- ! face I == NGLLX, J == 1
- iglob = ibool(NGLLX,1,k,ispec)
- case( 6 )
- ! face I == NGLLX, J == NGLLY
- iglob = ibool(NGLLX,NGLLY,k,ispec)
- case( 7 )
- ! face I == NGLLX, K == 1
- iglob = ibool(NGLLX,k,1,ispec)
- case( 8 )
- ! face I == NGLLX, K == NGLLZ
- iglob = ibool(NGLLX,k,NGLLZ,ispec)
- case( 9 )
- ! face J == 1, K == 1
- iglob = ibool(k,1,1,ispec)
- case( 10 )
- ! face J == 1, K == NGLLZ
- iglob = ibool(k,1,NGLLZ,ispec)
- case( 11 )
- ! face J == NGLLY, K == 1
- iglob = ibool(k,NGLLY,1,ispec)
- case( 12 )
- ! face J == NGLLY, K == NGLLZ
- iglob = ibool(k,NGLLY,NGLLZ,ispec)
- end select
-
- ! checks that we take each global point (on edges and corners) only once
- call add_interface_point(iglob,rank,icurrent, &
- nibool_neighbours,MAX_NEIGHBOURS, &
- ibool_neighbours,max_nibool, &
- work_test_flag,NGLOB,myrank, &
- .true.,add_central_cube)
-
- ! debug
- if( work_test_flag(iglob) < 0 ) then
- if( IREGION == IREGION_INNER_CORE .and. INCLUDE_CENTRAL_CUBE ) then
- ! we might have missed an interface point on an edge, just re-set to missing value
- print*,'warning edge flag:',myrank,'ispec=',ispec,'rank=',rank
- print*,' flag=',work_test_flag(iglob),'iedge jk=',iedge,k,'missed iglob=',iglob
- !work_test_flag(iglob) = 0
- else
- print*,'error edge flag:',myrank,'ispec=',ispec,'rank=',rank
- print*,' flag=',work_test_flag(iglob),'iedge jk=',iedge,k,'iglob=',iglob
- call exit_mpi(myrank,'error edge flag')
- endif
- endif
-
- enddo
- endif
- enddo ! iedge
-
-
- ! 3. finds neighbours which share a single corner with this process
- ! note: faces and edges have subtracted their neighbors, only one more process left possible
-
- ! loops over all corners of element
- do icorner = 1, 8
-
- ! chooses a corner point
- select case( icorner )
- case( 1 )
- ! face I == 1
- iglob = ibool(1,1,1,ispec)
- case( 2 )
- ! face I == 1
- iglob = ibool(1,NGLLY,1,ispec)
- case( 3 )
- ! face I == 1
- iglob = ibool(1,1,NGLLZ,ispec)
- case( 4 )
- ! face I == 1
- iglob = ibool(1,NGLLY,NGLLZ,ispec)
- case( 5 )
- ! face I == NGLLX
- iglob = ibool(NGLLX,1,1,ispec)
- case( 6 )
- ! face I == NGLLX
- iglob = ibool(NGLLX,NGLLY,1,ispec)
- case( 7 )
- ! face I == NGLLX
- iglob = ibool(NGLLX,1,NGLLZ,ispec)
- case( 8 )
- ! face I == NGLLX
- iglob = ibool(NGLLX,NGLLY,NGLLZ,ispec)
- end select
-
- ! makes sure that all elements on mpi interfaces are included
- ! uses original test_flag array, since the working copy reduces values
- ! note: there can be elements which have an edge or corner shared with
- ! other mpi partitions, but have the work_test_flag value already set to zero
- ! since the iglob point was found before.
- ! also, this check here would suffice to determine the outer flag, but we also include the
- ! check everywhere we encounter it too
- if( test_flag(iglob) > 0.5 ) then
- ispec_is_outer = .true.
- endif
-
- ! checks assembled flag on global point
- if( work_test_flag(iglob) > 0 ) then
- ispec_is_outer = .true.
-
- ! rank of neighbor process
- rank = work_test_flag(iglob) - 1
-
- ! checks ranks range
- if( rank < 0 .or. rank >= NPROCTOT ) then
- print*,'error corner: ',myrank
- print*,' neighbor rank = ',rank,'exceeds total nproc:',NPROCTOT
- print*,' corner ',icorner
- call exit_mpi(myrank,'error corner neighbor mpi rank')
- endif
-
- ! checks if already stored
- icurrent = 0
- is_done = .false.
- do ii = 1,iinterface
- if( rank == my_neighbours(ii) ) then
- icurrent = ii
- is_done = .true.
- exit
- endif
- enddo
-
- ! updates interfaces array
- if( .not. is_done ) then
- iinterface = iinterface + 1
- if( iinterface > MAX_NEIGHBOURS ) then
- print*,'error interfaces rank:',myrank,'iinterface = ',iinterface,MAX_NEIGHBOURS
- call exit_mpi(myrank,'interface corner exceed MAX_NEIGHBOURS range')
- endif
- ! adds as neighbor new interface
- my_neighbours(iinterface) = rank
- icurrent = iinterface
- endif
- if( icurrent == 0 ) &
- call exit_mpi(myrank,'could not find current interface for this neighbor, please check my_neighbours')
-
- ! adds this corner as interface point and removes neighbor flag from face,
- ! checks that we take each global point (on edges and corners) only once
- call add_interface_point(iglob,rank,icurrent, &
- nibool_neighbours,MAX_NEIGHBOURS, &
- ibool_neighbours,max_nibool, &
- work_test_flag,NGLOB,myrank, &
- .false.,add_central_cube)
-
- ! debug
- if( work_test_flag(iglob) < 0 ) call exit_mpi(myrank,'error corner flag')
-
- endif
-
- enddo ! icorner
-
- ! stores flags for outer elements when recognized as such
- ! (inner/outer elements separated for non-blocking mpi communications)
- if( ispec_is_outer ) then
- work_ispec_is_outer(ispec) = .true.
- endif
-
- enddo
-
- ! number of outer elements (on MPI interfaces)
- npoin = count( work_ispec_is_outer )
-
- ! debug: user output
- if( add_central_cube ) then
- print*, 'rank',myrank,'interfaces : ',iinterface
- do j=1,iinterface
- print*, ' my_neighbours: ',my_neighbours(j),nibool_neighbours(j)
- enddo
- print*, ' test flag min/max: ',minval(work_test_flag),maxval(work_test_flag)
- print*, ' outer elements: ',npoin
- print*
- endif
-
- ! checks if all points were recognized
- if( minval(work_test_flag) < 0 .or. maxval(work_test_flag) > 0 ) then
- print*,'error mpi interface rank: ',myrank
- print*,' work_test_flag min/max :',minval(work_test_flag),maxval(work_test_flag)
- call exit_mpi(myrank,'error: mpi points remain unrecognized, please check mesh interfaces')
- endif
-
- ! sets interfaces infos
- num_interfaces = iinterface
- max_nibool_interfaces = maxval( nibool_neighbours(1:num_interfaces) )
-
- ! checks if unique set of neighbours
- do ii = 1,num_interfaces-1
- rank = my_neighbours(ii)
- do j = ii+1,num_interfaces
- if( rank == my_neighbours(j) ) then
- print*,'test MPI: rank ',myrank,'my_neighbours:',rank,my_neighbours(j),'interfaces:',ii,j
- call exit_mpi(myrank,'error test my_neighbours not unique')
- endif
- enddo
- enddo
-
- ! sorts buffers obtained to be conforming with neighbors in other slices
- do iinterface = 1,num_interfaces
- ! sorts ibool values in increasing order
- ! used to check if we have duplicates in array
- npoin = nibool_neighbours(iinterface)
- call heap_sort( npoin, ibool_neighbours(1:npoin,iinterface) )
-
- ! checks if unique set of iglob values
- do j=1,npoin-1
- if( ibool_neighbours(j,iinterface) == ibool_neighbours(j+1,iinterface) ) then
- if( IREGION == IREGION_INNER_CORE .and. INCLUDE_CENTRAL_CUBE ) then
- ! missing points might have been counted more than once
- if( ibool_neighbours(j,iinterface) > 0 ) then
- print*,'warning mpi interface rank:',myrank
- print*,' interface: ',my_neighbours(iinterface),'point: ',j,'of',npoin,'iglob=',ibool_neighbours(j,iinterface)
- ! decrease number of points
- nibool_neighbours(iinterface) = nibool_neighbours(iinterface) - 1
- if( nibool_neighbours(iinterface) <= 0 ) then
- print*,'error zero mpi interface rank:',myrank,'interface=',my_neighbours(iinterface)
- call exit_mpi(myrank,'error: zero mpi points on interface')
- endif
- ! shift values
- do k = j+1,npoin-1
- ii = ibool_neighbours(k+1,iinterface)
- ibool_neighbours(k,iinterface) = ii
- enddo
- ! re-sets values
- ibool_neighbours(npoin,iinterface) = 0
- npoin = nibool_neighbours(iinterface)
- max_nibool_interfaces = maxval( nibool_neighbours(1:num_interfaces) )
- endif
- else
- print*,'error mpi interface rank:',myrank
- print*,' interface: ',my_neighbours(iinterface),'point: ',j,'of',npoin,'iglob=',ibool_neighbours(j,iinterface)
- call exit_mpi(myrank,'error: mpi points not unique on interface')
- endif
- endif
- enddo
-
- ! sort buffer obtained to be conforming with neighbor in other chunk
- npoin = nibool_neighbours(iinterface)
- call sort_MPI_interface(myrank,npoin,ibool_neighbours(1:npoin,iinterface), &
- NGLOB,xstore,ystore,zstore)
-
- enddo
-
- ! re-sets flags for outer elements
- is_on_a_slice_edge(:) = work_ispec_is_outer(:)
-
- end subroutine get_MPI_interfaces
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine sort_MPI_interface(myrank,npoin,ibool_n, &
- NGLOB,xstore,ystore,zstore)
-
- use constants,only: CUSTOM_REAL,SIZE_REAL
-
- implicit none
-
- integer,intent(in) :: myrank,npoin
- integer,dimension(npoin),intent(inout) :: ibool_n
-
- integer,intent(in) :: NGLOB
- real(kind=CUSTOM_REAL), dimension(NGLOB) :: xstore,ystore,zstore
-
- ! local parameters
- ! arrays for sorting routine
- double precision, dimension(:), allocatable :: work
- double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
- integer, dimension(:), allocatable :: ibool_selected
- integer, dimension(:), allocatable :: ind,ninseg,iglob,locval,iwork
- logical, dimension(:), allocatable :: ifseg
- integer :: nglob_selected,i,ipoin,ier
-
- ! allocate arrays for buffers with maximum size
- allocate(ibool_selected(npoin), &
- xstore_selected(npoin), &
- ystore_selected(npoin), &
- zstore_selected(npoin), &
- ind(npoin), &
- ninseg(npoin), &
- iglob(npoin), &
- locval(npoin), &
- ifseg(npoin), &
- iwork(npoin), &
- work(npoin),stat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error sort MPI interface: allocating temporary sorting arrays')
-
- ! sets up working arrays
- do i=1,npoin
- ipoin = ibool_n(i)
-
- ibool_selected(i) = ipoin
-
- if( CUSTOM_REAL == SIZE_REAL ) then
- xstore_selected(i) = dble(xstore(ipoin))
- ystore_selected(i) = dble(ystore(ipoin))
- zstore_selected(i) = dble(zstore(ipoin))
- else
- xstore_selected(i) = xstore(ipoin)
- ystore_selected(i) = ystore(ipoin)
- zstore_selected(i) = zstore(ipoin)
- endif
- enddo
-
- ! sort buffer obtained to be conforming with neighbor in other chunk
- ! sort on x, y and z, the other arrays will be swapped as well
- call sort_array_coordinates(npoin,xstore_selected,ystore_selected,zstore_selected, &
- ibool_selected,iglob,locval,ifseg,nglob_selected, &
- ind,ninseg,iwork,work)
-
- ! check that no duplicate has been detected
- if(nglob_selected /= npoin) call exit_MPI(myrank,'error sort MPI interface: duplicates detected in buffer')
-
- ! stores new ibool ordering
- ibool_n(1:npoin) = ibool_selected(1:npoin)
-
- ! frees array memory
- deallocate(ibool_selected,xstore_selected,ystore_selected,zstore_selected, &
- ind,ninseg,iglob,locval,ifseg,iwork,work)
-
-
- end subroutine sort_MPI_interface
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine add_interface_point(iglob,rank,icurrent, &
- nibool_neighbours,MAX_NEIGHBOURS, &
- ibool_neighbours,max_nibool, &
- work_test_flag,NGLOB,myrank, &
- is_face_edge,add_central_cube)
-
-
- implicit none
-
- integer,intent(in) :: iglob,rank,icurrent
- integer,intent(in) :: myrank
-
- integer,intent(in) :: MAX_NEIGHBOURS,max_nibool
- integer, dimension(MAX_NEIGHBOURS),intent(inout) :: nibool_neighbours
- integer, dimension(max_nibool,MAX_NEIGHBOURS),intent(inout) :: ibool_neighbours
-
- integer,intent(in) :: NGLOB
- integer,dimension(NGLOB) :: work_test_flag
-
- logical,intent(in) :: is_face_edge,add_central_cube
-
- ! local parameters
- integer :: i
- logical :: is_done
-
- ! let's check and be sure for central cube
- !if( work_test_flag(iglob) <= 0 ) cycle ! continues to next point
-
- ! checks that we take each global point (on edges and corners) only once
- is_done = .false.
- do i=1,nibool_neighbours(icurrent)
- if( ibool_neighbours(i,icurrent) == iglob ) then
- is_done = .true.
- exit
- endif
- enddo
-
- ! checks if anything to do
- if( is_done ) then
- ! special handling for central cube: removes rank if already added in inner core
- if( add_central_cube ) then
- if( is_face_edge .and. work_test_flag(iglob) < (rank + 1) ) then
- ! re-sets if we missed this rank number
- work_test_flag(iglob) = work_test_flag(iglob) + (rank + 1)
- endif
- ! re-sets flag
- work_test_flag(iglob) = work_test_flag(iglob) - ( rank + 1 )
- if( is_face_edge .and. work_test_flag(iglob) < 0 ) then
- ! re-sets to zero if we missed this rank number
- if( work_test_flag(iglob) == - (rank + 1 ) ) work_test_flag(iglob) = 0
- endif
- endif
- return
- endif
-
- ! checks if flag was set correctly
- if( work_test_flag(iglob) <= 0 ) then
- ! we might have missed an interface point on an edge, just re-set to missing value
- print*,'warning ',myrank,' flag: missed rank=',rank
- print*,' flag=',work_test_flag(iglob),'missed iglob=',iglob,'interface=',icurrent
- print*
- endif
- ! we might have missed an interface point on an edge, just re-set to missing value
- if( is_face_edge ) then
- if( work_test_flag(iglob) < (rank + 1) ) then
- ! re-sets if we missed this rank number
- work_test_flag(iglob) = work_test_flag(iglob) + (rank + 1)
- endif
- endif
-
- ! adds point
- ! increases number of total points on this interface
- nibool_neighbours(icurrent) = nibool_neighbours(icurrent) + 1
- if( nibool_neighbours(icurrent) > max_nibool) &
- call exit_mpi(myrank,'interface face exceeds max_nibool range')
-
- ! stores interface iglob index
- ibool_neighbours( nibool_neighbours(icurrent),icurrent ) = iglob
-
- ! re-sets flag
- work_test_flag(iglob) = work_test_flag(iglob) - ( rank + 1 )
-
- ! checks
- if( is_face_edge .and. work_test_flag(iglob) < 0 ) then
- ! re-sets to zero if we missed this rank number
- if( work_test_flag(iglob) == - (rank + 1 ) ) work_test_flag(iglob) = 0
- endif
-
- end subroutine add_interface_point
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/heap_sort.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/heap_sort.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/heap_sort.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,98 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 heap_sort( N, array )
-
-! heap sort algorithm
-! sorts integer array (in increasing order, like 1 - 5 - 6 - 9 - 12 - 13 - 14 -...)
-
- implicit none
- integer,intent(in) :: N
- integer,dimension(N),intent(inout) :: array
-
- ! local parameters
- integer :: tmp
- integer :: i
-
- ! checks if anything to do
- if( N < 2 ) return
-
- ! builds heap
- do i = N/2, 1, -1
- call heap_sort_siftdown(N,array,i,N)
- enddo
-
- ! sorts array
- do i = N, 2, -1
- ! swaps last and first entry in this section
- tmp = array(1)
- array(1) = array(i)
- array(i) = tmp
- call heap_sort_siftdown(N,array,1,i-1)
- enddo
-
- end subroutine heap_sort
-
-!
-!----
-!
-
- subroutine heap_sort_siftdown(N,array,start,bottom)
-
- implicit none
-
- integer,intent(in):: N
- integer,dimension(N),intent(inout) :: array
- integer :: start,bottom
-
- ! local parameters
- integer :: i,j
- integer :: tmp
-
- i = start
- tmp = array(i)
- j = 2*i
- do while( j <= bottom )
- ! chooses larger value first in this section
- if( j < bottom ) then
- if( array(j) <= array(j+1) ) j = j + 1
- endif
-
- ! checks if section already smaller than inital value
- if( array(j) < tmp ) exit
-
- array(i) = array(j)
- i = j
- j = 2*i
- enddo
-
- array(i) = tmp
- return
-
- end subroutine heap_sort_siftdown
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/initialize_layers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/initialize_layers.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/initialize_layers.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,176 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 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 initialize_layers
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/initialize_mesher.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/initialize_mesher.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/initialize_mesher.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,163 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 initialize_mesher()
-
- use meshfem3D_par
- use meshfem3D_models_par
-
- implicit none
-
- ! local parameters
- integer, external :: err_occurred
- ! timing
- double precision, external :: wtime
-
-! 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 world_size(sizeprocs)
- call world_rank(myrank)
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
-! open main output file, only written to by process 0
- if(myrank == 0 .and. IMAIN /= ISTANDARD_OUTPUT) &
- open(unit=IMAIN,file=trim(OUTPUT_FILES)//'/output_mesher.txt',status='unknown')
-
-! get MPI starting time
- time_start = wtime()
-
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) '****************************'
- write(IMAIN,*) '*** Specfem3D MPI Mesher ***'
- 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,ATTENUATION_NEW,REFERENCE_1D_MODEL,THREE_D_MODEL,ABSORBING_CONDITIONS, &
- INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE, &
- LOCAL_PATH,LOCAL_TMP_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')
-
- ! ADIOS_ENABLED: parameter is optional, may not be in the Par_file
- call read_adios_parameters(ADIOS_ENABLED, ADIOS_FOR_FORWARD_ARRAYS, &
- ADIOS_FOR_MPI_ARRAYS, ADIOS_FOR_ARRAYS_SOLVER, &
- ADIOS_FOR_SOLVER_MESHFILES, ADIOS_FOR_AVS_DX)
-
- 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,LOCAL_TMP_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_NEW,ATTENUATION_3D,ANISOTROPIC_INNER_CORE,NOISE_TOMOGRAPHY)
- ! broadcasts optional ADIOS_ENABLED
- call broadcast_adios_parameters(myrank,ADIOS_ENABLED, &
- ADIOS_FOR_FORWARD_ARRAYS, ADIOS_FOR_MPI_ARRAYS, ADIOS_FOR_ARRAYS_SOLVER, &
- ADIOS_FOR_SOLVER_MESHFILES, ADIOS_FOR_AVS_DX)
-
- ! 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 * DEGREES_TO_RADIANS
- ANGULAR_WIDTH_ETA_RAD = ANGULAR_WIDTH_ETA_IN_DEGREES * DEGREES_TO_RADIANS
-
- if(NCHUNKS /= 6) call euler_angles(rotation_matrix,CENTER_LONGITUDE_IN_DEGREES,CENTER_LATITUDE_IN_DEGREES,GAMMA_ROTATION_AZIMUTH)
-
- if (ADIOS_ENABLED) then
- call adios_setup()
- endif
-
- end subroutine initialize_mesher
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D_par.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D_par.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/meshfem3D_par.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,667 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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.
-
- module constants
-
- include "constants.h"
-
- end module constants
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- module meshfem3D_models_par
-
-!---
-!
-! ADD YOUR MODEL HERE
-!
-!---
-
- use constants
-
- implicit none
-
-! model_attenuation_variables
- type model_attenuation_variables
- sequence
- double precision min_period, max_period
- double precision :: QT_c_source ! Source Frequency
- double precision, dimension(:), pointer :: Qtau_s ! tau_sigma
- double precision, dimension(:), pointer :: QrDisc ! Discontinutitues Defined
- double precision, dimension(:), pointer :: Qr ! Radius
- double precision, dimension(:), pointer :: Qmu ! Shear Attenuation
- double precision, dimension(:,:), pointer :: Qtau_e ! tau_epsilon
- double precision, dimension(:), pointer :: Qomsb, Qomsb2 ! one_minus_sum_beta
- double precision, dimension(:,:), pointer :: Qfc, Qfc2 ! factor_common
- double precision, dimension(:), pointer :: Qsf, Qsf2 ! scale_factor
- integer, dimension(:), pointer :: Qrmin ! Max and Mins of idoubling
- integer, dimension(:), pointer :: Qrmax ! Max and Mins of idoubling
- integer, dimension(:), pointer :: interval_Q ! Steps
- integer :: Qn ! Number of points
- integer dummy_pad ! padding 4 bytes to align the structure
- end type model_attenuation_variables
- type (model_attenuation_variables) AM_V
-! model_attenuation_variables
-
-! model_attenuation_storage_var
- type model_attenuation_storage_var
- sequence
- double precision, dimension(:,:), pointer :: tau_e_storage
- double precision, dimension(:), pointer :: Qmu_storage
- integer Q_resolution
- integer Q_max
- end type model_attenuation_storage_var
- type (model_attenuation_storage_var) AM_S
-! model_attenuation_storage_var
-
-! attenuation_simplex_variables
- type attenuation_simplex_variables
- sequence
- double precision Q ! Q = Desired Value of Attenuation or Q
- double precision iQ ! iQ = 1/Q
- double precision, dimension(:), pointer :: f
- ! f = Frequencies at which to evaluate the solution
- double precision, dimension(:), pointer :: tau_s
- ! tau_s = Tau_sigma defined by the frequency range and
- ! number of standard linear solids
- integer nf ! nf = Number of Frequencies
- integer nsls ! nsls = Number of Standard Linear Solids
- end type attenuation_simplex_variables
- type(attenuation_simplex_variables) AS_V
-! attenuation_simplex_variables
-
-! GLL model_variables
- type model_gll_variables
- sequence
- ! tomographic iteration model on GLL points
- double precision :: scale_velocity,scale_density
- ! isotropic model
- real(kind=CUSTOM_REAL),dimension(:,:,:,:),pointer :: vs_new,vp_new,rho_new
- ! transverse isotropic model
- real(kind=CUSTOM_REAL),dimension(:,:,:,:),pointer :: vsv_new,vpv_new, &
- vsh_new,vph_new,eta_new
- logical :: MODEL_GLL
- logical,dimension(3) :: dummy_pad ! padding 3 bytes to align the structure
- end type model_gll_variables
- type (model_gll_variables) MGLL_V
-
-! bathymetry and topography: use integer array to store values
- integer, dimension(NX_BATHY,NY_BATHY) :: ibathy_topo
-
-! for ellipticity
- double precision,dimension(NR) :: rspl,espl,espl2
- integer :: nspl
-
-! model parameter and flags
- integer :: REFERENCE_1D_MODEL,THREE_D_MODEL
-
- logical :: ELLIPTICITY,GRAVITY,ROTATION,TOPOGRAPHY,OCEANS
-
- logical :: HONOR_1D_SPHERICAL_MOHO,CRUSTAL,ONE_CRUST,CASE_3D,TRANSVERSE_ISOTROPY
-
- logical :: ISOTROPIC_3D_MANTLE,ANISOTROPIC_3D_MANTLE,HETEROGEN_3D_MANTLE
-
- logical :: ATTENUATION,ATTENUATION_NEW,ATTENUATION_3D
-
- logical :: ANISOTROPIC_INNER_CORE
-
-! to create a reference model based on 1D_REF but with 3D crust and 410/660 topography
- logical,parameter :: USE_1D_REFERENCE = .false.
-
- end module meshfem3D_models_par
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- module meshfem3D_par
-
-! main parameter module for specfem simulations
-
- use constants
-
- implicit none
-
- ! correct number of spectral elements in each block depending on chunk type
- integer :: npointot
-
- ! proc numbers for MPI
- integer :: myrank,sizeprocs
-
- ! check area and volume of the final mesh
- double precision :: volume_total
-
- ! 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
- character(len=150) :: LOCAL_PATH,LOCAL_TMP_PATH,MODEL
-
- ! parameters deduced from parameters read from file
- integer :: NPROC,NPROCTOT,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
-
- ! 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 :: 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
-
- ! arrays with the mesh in double precision
- double precision, dimension(:,:,:,:), allocatable :: xstore,ystore,zstore
- ! parameters needed to store the radii of the grid points
- ! in the spherically symmetric Earth
- integer, dimension(:), allocatable :: idoubling
- integer, dimension(:,:,:,:), allocatable :: ibool
-
- ! this for non blocking MPI
- logical, dimension(:), allocatable :: is_on_a_slice_edge
- !-----------------------------------------------------------------
- ! ADIOS
- !-----------------------------------------------------------------
-
- logical :: ADIOS_ENABLED, ADIOS_FOR_FORWARD_ARRAYS, ADIOS_FOR_MPI_ARRAYS, &
- ADIOS_FOR_ARRAYS_SOLVER, ADIOS_FOR_SOLVER_MESHFILES, &
- ADIOS_FOR_AVS_DX
-
- end module meshfem3D_par
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- module create_regions_mesh_par
-
- use constants,only: NGLLX,NGLLY,NGLLZ,NGNOD,NGNOD2D,NDIM,NDIM2D
-
- implicit none
-
- ! topology of the elements
- integer, dimension(NGNOD) :: iaddx,iaddy,iaddz
-
- ! Gauss-Lobatto-Legendre points and weights of integration
- double precision, dimension(NGLLX) :: xigll,wxgll
- double precision, dimension(NGLLY) :: yigll,wygll
- double precision, dimension(NGLLZ) :: zigll,wzgll
-
- ! 3D shape functions and their derivatives
- double precision, dimension(NGNOD,NGLLX,NGLLY,NGLLZ) :: shape3D
- double precision, dimension(NDIM,NGNOD,NGLLX,NGLLY,NGLLZ) :: dershape3D
-
- ! 2D shape functions and their derivatives
- double precision, dimension(NGNOD2D,NGLLY,NGLLZ) :: shape2D_x
- double precision, dimension(NGNOD2D,NGLLX,NGLLZ) :: shape2D_y
- double precision, dimension(NGNOD2D,NGLLX,NGLLY) :: shape2D_bottom,shape2D_top
- double precision, dimension(NDIM2D,NGNOD2D,NGLLY,NGLLZ) :: dershape2D_x
- double precision, dimension(NDIM2D,NGNOD2D,NGLLX,NGLLZ) :: dershape2D_y
- double precision, dimension(NDIM2D,NGNOD2D,NGLLX,NGLLY) :: dershape2D_bottom,dershape2D_top
-
- end module create_regions_mesh_par
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- module create_regions_mesh_par2
-
- use constants,only: CUSTOM_REAL,N_SLS
-
- implicit none
-
- integer :: nspec_stacey,nspec_actually,nspec_att
-
- integer :: ifirst_region,ilast_region
- integer, dimension(:), allocatable :: perm_layer
-
- ! 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
-
- ! mass matrices
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmassx,rmassy,rmassz
- integer :: nglob_xy
-
- ! mass matrix and bathymetry for ocean load
- integer :: nglob_oceans
- real(kind=CUSTOM_REAL), dimension(:), allocatable :: rmass_ocean_load
-
- ! number of elements on the boundaries
- integer :: nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
-
- ! 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
-
- ! attenuation
- double precision, dimension(:,:,:,:), allocatable :: Qmu_store
- double precision, dimension(:,:,:,:,:), allocatable :: tau_e_store
- double precision, dimension(N_SLS) :: tau_s
- double precision :: T_c_source
-
- ! element layers
- integer :: NUMBER_OF_MESH_LAYERS,layer_shift,cpt, &
- first_layer_aniso,last_layer_aniso,FIRST_ELT_NON_ANISO
- logical :: USE_ONE_LAYER_SB
-
- ! layer stretching
- double precision, dimension(:,:), allocatable :: stretch_tab
- integer :: nb_layer_above_aniso,FIRST_ELT_ABOVE_ANISO
-
- ! 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
-
- ! name of the database file
- character(len=150) :: prname, prname_adios
-
- end module create_regions_mesh_par2
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- module create_MPI_interfaces_par
-
- use constants,only: &
- CUSTOM_REAL,NDIM,IMAIN, &
- IREGION_CRUST_MANTLE,IREGION_OUTER_CORE,IREGION_INNER_CORE, &
- NUMFACES_SHARED,NB_SQUARE_EDGES_ONEDIR
-
- implicit none
-
- ! 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
-
- ! number of faces between chunks
- integer :: NUMMSGS_FACES
-
- ! number of corners between chunks
- integer :: NCORNERSCHUNKS
-
- ! number of message types
- integer :: NUM_MSG_TYPES
-
- !-----------------------------------------------------------------
- ! assembly
- !-----------------------------------------------------------------
-
- ! ---- arrays to assemble between chunks
- ! communication pattern for faces between chunks
- integer, dimension(:),allocatable :: iprocfrom_faces,iprocto_faces,imsg_type
- ! communication pattern for corners between chunks
- integer, dimension(:),allocatable :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
-
- ! indirect addressing for each corner of the chunks
- integer, dimension(:,:),allocatable :: iboolcorner
-
- ! chunk faces
- integer, dimension(:,:),allocatable :: iboolfaces
- integer, dimension(NUMFACES_SHARED) :: npoin2D_faces
- integer :: NGLOB2DMAX_XY
-
- ! 2-D addressing and buffers for summation between slices
- integer, dimension(:),allocatable :: iboolleft_xi,iboolright_xi
- integer, dimension(:),allocatable :: iboolleft_eta,iboolright_eta
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_all,npoin2D_eta_all
- integer :: npoin2D_xi,npoin2D_eta
-
- ! 1-D addressing
- integer :: NGLOB1D_RADIAL_MAX
- integer,dimension(:),allocatable :: ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
- ibool1D_leftxi_righteta,ibool1D_rightxi_righteta
-
- double precision,dimension(:,:),allocatable :: xyz1D_leftxi_lefteta,xyz1D_rightxi_lefteta, &
- xyz1D_leftxi_righteta,xyz1D_rightxi_righteta
-
- ! this for non blocking MPI
-
- ! 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
- integer :: npoin2D_max_all_CM_IC
-
- ! buffers for send and receive between corners of the chunks
- real(kind=CUSTOM_REAL), dimension(:),allocatable :: &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar
-
- ! size of buffers is the sum of two sizes because we handle two regions in the same MPI call
- real(kind=CUSTOM_REAL), dimension(:,:),allocatable :: &
- buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector
-
- end module create_MPI_interfaces_par
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- module MPI_crust_mantle_par
-
- use constants,only: CUSTOM_REAL,NUMFACES_SHARED,NB_SQUARE_EDGES_ONEDIR
-
- implicit none
-
- ! collected MPI interfaces
- !--------------------------------------
- ! MPI crust/mantle mesh
- !--------------------------------------
- integer :: num_interfaces_crust_mantle
- integer :: max_nibool_interfaces_cm
- integer, dimension(:), allocatable :: my_neighbours_crust_mantle,nibool_interfaces_crust_mantle
- integer, dimension(:,:), allocatable :: ibool_interfaces_crust_mantle
-
- !--------------------------------------
- ! crust mantle
- !--------------------------------------
- integer :: NSPEC_CRUST_MANTLE
- integer :: NGLOB_CRUST_MANTLE
-
- integer :: NGLOB1D_RADIAL_CM
- integer :: NGLOB2DMAX_XMIN_XMAX_CM
- integer :: NGLOB2DMAX_YMIN_YMAX_CM
- integer :: NSPEC2DMAX_XMIN_XMAX_CM
- integer :: NSPEC2DMAX_YMIN_YMAX_CM
- integer :: NSPEC2D_BOTTOM_CM
- integer :: NSPEC2D_TOP_CM
-
- real(kind=CUSTOM_REAL), dimension(:),allocatable :: &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
-
- ! assembly
- integer, dimension(NUMFACES_SHARED) :: npoin2D_faces_crust_mantle
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle
-
- ! indirect addressing for each corner of the chunks
- integer, dimension(:,:),allocatable :: iboolcorner_crust_mantle
-
- ! 2-D addressing and buffers for summation between slices
- integer, dimension(:),allocatable :: iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle
- integer, dimension(:),allocatable :: iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle
-
- integer, dimension(:,:),allocatable :: iboolfaces_crust_mantle
-
- ! inner / outer elements crust/mantle region
- integer :: num_phase_ispec_crust_mantle
- integer :: nspec_inner_crust_mantle,nspec_outer_crust_mantle
- integer, dimension(:,:), allocatable :: phase_ispec_inner_crust_mantle
-
- ! mesh coloring
- integer :: num_colors_outer_crust_mantle,num_colors_inner_crust_mantle
- integer,dimension(:),allocatable :: num_elem_colors_crust_mantle
-
- end module MPI_crust_mantle_par
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- module MPI_inner_core_par
-
- use constants,only: CUSTOM_REAL,NUMFACES_SHARED,NB_SQUARE_EDGES_ONEDIR
-
- implicit none
-
- !--------------------------------------
- ! MPI inner core mesh
- !--------------------------------------
- integer :: num_interfaces_inner_core
- integer :: max_nibool_interfaces_ic
- integer, dimension(:), allocatable :: my_neighbours_inner_core,nibool_interfaces_inner_core
- integer, dimension(:,:), allocatable :: ibool_interfaces_inner_core
-
- !--------------------------------------
- ! inner core
- !--------------------------------------
- integer :: NSPEC_INNER_CORE
- integer :: NGLOB_INNER_CORE
-
- integer :: NGLOB1D_RADIAL_IC
- integer :: NGLOB2DMAX_XMIN_XMAX_IC
- integer :: NGLOB2DMAX_YMIN_YMAX_IC
- integer :: NSPEC2DMAX_XMIN_XMAX_IC
- integer :: NSPEC2DMAX_YMIN_YMAX_IC
- integer :: NSPEC2D_BOTTOM_IC
- integer :: NSPEC2D_TOP_IC
-
- real(kind=CUSTOM_REAL), dimension(:),allocatable :: &
- xstore_inner_core,ystore_inner_core,zstore_inner_core
-
- ! for matching with central cube in inner core
- integer, dimension(:), allocatable :: sender_from_slices_to_cube
- integer, dimension(:,:), allocatable :: ibool_central_cube
- double precision, dimension(:,:), allocatable :: buffer_slices,buffer_slices2
- double precision, dimension(:,:,:), allocatable :: buffer_all_cube_from_slices
- integer :: nb_msgs_theor_in_cube,non_zero_nb_msgs_theor_in_cube, &
- npoin2D_cube_from_slices,receiver_cube_from_slices
-
- ! bottom inner core / top central cube
- integer, dimension(:),allocatable :: ibelm_bottom_inner_core
-
- integer, dimension(NUMFACES_SHARED) :: npoin2D_faces_inner_core
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_inner_core,npoin2D_eta_inner_core
-
- ! indirect addressing for each corner of the chunks
- integer, dimension(:,:),allocatable :: iboolcorner_inner_core
-
- ! 2-D addressing and buffers for summation between slices
- integer, dimension(:),allocatable :: iboolleft_xi_inner_core,iboolright_xi_inner_core
- integer, dimension(:),allocatable :: iboolleft_eta_inner_core,iboolright_eta_inner_core
-
- integer, dimension(:,:),allocatable :: iboolfaces_inner_core
-
- ! inner / outer elements inner core region
- integer :: num_phase_ispec_inner_core
- integer :: nspec_inner_inner_core,nspec_outer_inner_core
- integer, dimension(:,:), allocatable :: phase_ispec_inner_inner_core
-
- ! mesh coloring
- integer :: num_colors_outer_inner_core,num_colors_inner_inner_core
- integer,dimension(:),allocatable :: num_elem_colors_inner_core
-
- end module MPI_inner_core_par
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- module MPI_outer_core_par
-
- use constants,only: CUSTOM_REAL,NUMFACES_SHARED,NB_SQUARE_EDGES_ONEDIR
-
- implicit none
-
- !--------------------------------------
- ! MPI outer core mesh
- !--------------------------------------
- integer :: num_interfaces_outer_core
- integer :: max_nibool_interfaces_oc
- integer, dimension(:), allocatable :: my_neighbours_outer_core,nibool_interfaces_outer_core
- integer, dimension(:,:), allocatable :: ibool_interfaces_outer_core
-
- !--------------------------------------
- ! outer core
- !--------------------------------------
- integer :: NSPEC_OUTER_CORE
- integer :: NGLOB_OUTER_CORE
-
- integer :: NGLOB1D_RADIAL_OC
- integer :: NGLOB2DMAX_XMIN_XMAX_OC
- integer :: NGLOB2DMAX_YMIN_YMAX_OC
- integer :: NSPEC2DMAX_XMIN_XMAX_OC
- integer :: NSPEC2DMAX_YMIN_YMAX_OC
- integer :: NSPEC2D_BOTTOM_OC
- integer :: NSPEC2D_TOP_OC
-
- real(kind=CUSTOM_REAL), dimension(:),allocatable :: &
- xstore_outer_core,ystore_outer_core,zstore_outer_core
-
- ! assembly
- integer, dimension(NUMFACES_SHARED) :: npoin2D_faces_outer_core
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_outer_core,npoin2D_eta_outer_core
-
- ! indirect addressing for each corner of the chunks
- integer, dimension(:,:),allocatable :: iboolcorner_outer_core
-
- ! 2-D addressing and buffers for summation between slices
- integer, dimension(:),allocatable :: iboolleft_xi_outer_core,iboolright_xi_outer_core
- integer, dimension(:),allocatable :: iboolleft_eta_outer_core,iboolright_eta_outer_core
-
- integer, dimension(:,:),allocatable :: iboolfaces_outer_core
-
- ! inner / outer elements outer core region
- integer :: num_phase_ispec_outer_core
- integer :: nspec_inner_outer_core,nspec_outer_outer_core
- integer, dimension(:,:), allocatable :: phase_ispec_inner_outer_core
-
- ! mesh coloring
- integer :: num_colors_outer_outer_core,num_colors_inner_outer_core
- integer,dimension(:),allocatable :: num_elem_colors_outer_core
-
- end module MPI_outer_core_par
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_MPI_interfaces.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_MPI_interfaces.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_MPI_interfaces.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,572 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 setup_MPI_interfaces(iregion_code)
-
- use meshfem3D_par,only: &
- INCLUDE_CENTRAL_CUBE,myrank,NUMFACES_SHARED
-
- use create_MPI_interfaces_par
-
- use MPI_crust_mantle_par
- use MPI_outer_core_par
- use MPI_inner_core_par
-
- implicit none
-
- integer,intent(in):: iregion_code
-
- ! local parameters
- ! assigns initial maximum arrays
- ! for global slices, maximum number of neighbor is around 17 ( 8 horizontal, max of 8 on bottom )
- integer :: MAX_NEIGHBOURS,max_nibool
- integer, dimension(:),allocatable :: my_neighbours,nibool_neighbours
- integer, dimension(:,:),allocatable :: ibool_neighbours
- integer :: ier
-
- ! allocates temporary arrays for setup routines
- ! estimates a maximum size of needed arrays
- MAX_NEIGHBOURS = 8 + NCORNERSCHUNKS
- if( INCLUDE_CENTRAL_CUBE ) MAX_NEIGHBOURS = MAX_NEIGHBOURS + NUMMSGS_FACES
-
- allocate(my_neighbours(MAX_NEIGHBOURS), &
- nibool_neighbours(MAX_NEIGHBOURS),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating my_neighbours array')
-
- ! estimates initial maximum ibool array
- max_nibool = npoin2D_max_all_CM_IC * NUMFACES_SHARED &
- + non_zero_nb_msgs_theor_in_cube*npoin2D_cube_from_slices
-
- allocate(ibool_neighbours(max_nibool,MAX_NEIGHBOURS), stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating ibool_neighbours')
-
- ! sets up MPI interfaces between different processes
- select case( iregion_code )
- case( IREGION_CRUST_MANTLE )
- ! crust/mantle
- call setup_MPI_interfaces_cm(MAX_NEIGHBOURS,my_neighbours,nibool_neighbours, &
- max_nibool,ibool_neighbours)
-
- case( IREGION_OUTER_CORE )
- ! outer core
- call setup_MPI_interfaces_oc(MAX_NEIGHBOURS,my_neighbours,nibool_neighbours, &
- max_nibool,ibool_neighbours)
-
- case( IREGION_INNER_CORE )
- ! inner core
- call setup_MPI_interfaces_ic(MAX_NEIGHBOURS,my_neighbours,nibool_neighbours, &
- max_nibool,ibool_neighbours)
- end select
-
- ! frees temporary array
- deallocate(ibool_neighbours)
- deallocate(my_neighbours,nibool_neighbours)
-
- ! frees arrays not needed any further
- deallocate(iprocfrom_faces,iprocto_faces,imsg_type)
- deallocate(iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners)
- deallocate(buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar)
- deallocate(buffer_send_chunkcorn_vector,buffer_recv_chunkcorn_vector)
- select case( iregion_code )
- case( IREGION_CRUST_MANTLE )
- ! crust mantle
- deallocate(iboolcorner_crust_mantle)
- deallocate(iboolleft_xi_crust_mantle,iboolright_xi_crust_mantle)
- deallocate(iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle)
- deallocate(iboolfaces_crust_mantle)
- case( IREGION_OUTER_CORE )
- ! outer core
- deallocate(iboolcorner_outer_core)
- deallocate(iboolleft_xi_outer_core,iboolright_xi_outer_core)
- deallocate(iboolleft_eta_outer_core,iboolright_eta_outer_core)
- deallocate(iboolfaces_outer_core)
- case( IREGION_INNER_CORE )
- ! inner core
- deallocate(iboolcorner_inner_core)
- deallocate(iboolleft_xi_inner_core,iboolright_xi_inner_core)
- deallocate(iboolleft_eta_inner_core,iboolright_eta_inner_core)
- deallocate(iboolfaces_inner_core)
- end select
-
- ! synchronizes MPI processes
- call sync_all()
-
- end subroutine setup_MPI_interfaces
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine setup_MPI_interfaces_cm(MAX_NEIGHBOURS,my_neighbours,nibool_neighbours, &
- max_nibool,ibool_neighbours)
-
- use meshfem3D_par,only: &
- myrank,iproc_xi,iproc_eta,ichunk,addressing,INCLUDE_CENTRAL_CUBE, &
- NPROC_XI,NPROC_ETA,NPROCTOT, &
- NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NCHUNKS, &
- OUTPUT_FILES
-
- use meshfem3D_par,only: ibool,is_on_a_slice_edge
-
- use create_MPI_interfaces_par
- use MPI_crust_mantle_par
- implicit none
-
- integer :: MAX_NEIGHBOURS,max_nibool
- integer, dimension(MAX_NEIGHBOURS) :: my_neighbours,nibool_neighbours
- integer, dimension(max_nibool,MAX_NEIGHBOURS) :: ibool_neighbours
-
- ! local parameters
- ! temporary buffers for send and receive between faces of the slices and the chunks
- real(kind=CUSTOM_REAL), dimension(npoin2D_max_all_CM_IC) :: &
- buffer_send_faces_scalar,buffer_received_faces_scalar
- real(kind=CUSTOM_REAL),dimension(:),allocatable :: test_flag
- integer,dimension(:),allocatable :: dummy_i
- integer :: i,ier
- ! debug file output
- character(len=150) :: filename
- logical,parameter :: DEBUG = .false.
-
- ! sets up MPI interfaces
- ! crust mantle region
- if( myrank == 0 ) write(IMAIN,*) 'crust mantle mpi:'
- allocate(test_flag(NGLOB_CRUST_MANTLE), &
- stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating test_flag')
-
- ! sets flag to rank id (+1 to avoid problems with zero rank)
- test_flag(:) = myrank + 1.0
-
- ! assembles values
- call assemble_MPI_scalar_block(myrank,test_flag, &
- NGLOB_CRUST_MANTLE, &
- 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, &
- iboolfaces_crust_mantle,iboolcorner_crust_mantle, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces_scalar,buffer_received_faces_scalar,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE), &
- NGLOB2DMAX_XY,NCHUNKS)
-
- ! removes own myrank id (+1)
- test_flag(:) = test_flag(:) - ( myrank + 1.0)
-
- allocate(dummy_i(NSPEC_CRUST_MANTLE),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating dummy_i')
-
- ! determines neighbor rank for shared faces
- call get_MPI_interfaces(myrank,NGLOB_CRUST_MANTLE,NSPEC_CRUST_MANTLE, &
- test_flag,my_neighbours,nibool_neighbours,ibool_neighbours, &
- num_interfaces_crust_mantle,max_nibool_interfaces_cm, &
- max_nibool,MAX_NEIGHBOURS, &
- ibool,is_on_a_slice_edge, &
- IREGION_CRUST_MANTLE,.false.,dummy_i,INCLUDE_CENTRAL_CUBE, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle,NPROCTOT)
-
- deallocate(test_flag)
- deallocate(dummy_i)
-
- ! stores MPI interfaces informations
- allocate(my_neighbours_crust_mantle(num_interfaces_crust_mantle), &
- nibool_interfaces_crust_mantle(num_interfaces_crust_mantle), &
- stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating array my_neighbours_crust_mantle etc.')
- my_neighbours_crust_mantle = -1
- nibool_interfaces_crust_mantle = 0
-
- ! copies interfaces arrays
- if( num_interfaces_crust_mantle > 0 ) then
- allocate(ibool_interfaces_crust_mantle(max_nibool_interfaces_cm,num_interfaces_crust_mantle), &
- stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating array ibool_interfaces_crust_mantle')
- ibool_interfaces_crust_mantle = 0
-
- ! ranks of neighbour processes
- my_neighbours_crust_mantle(:) = my_neighbours(1:num_interfaces_crust_mantle)
- ! number of global ibool entries on each interface
- nibool_interfaces_crust_mantle(:) = nibool_neighbours(1:num_interfaces_crust_mantle)
- ! global iglob point ids on each interface
- ibool_interfaces_crust_mantle(:,:) = ibool_neighbours(1:max_nibool_interfaces_cm,1:num_interfaces_crust_mantle)
- else
- ! dummy allocation (fortran90 should allow allocate statement with zero array size)
- max_nibool_interfaces_cm = 0
- allocate(ibool_interfaces_crust_mantle(0,0),stat=ier)
- endif
-
- ! debug: outputs MPI interface
- if( DEBUG ) then
- do i=1,num_interfaces_crust_mantle
- write(filename,'(a,i6.6,a,i2.2)') trim(OUTPUT_FILES)//'/MPI_points_crust_mantle_proc',myrank, &
- '_',my_neighbours_crust_mantle(i)
- call write_VTK_data_points(NGLOB_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- ibool_interfaces_crust_mantle(1:nibool_interfaces_crust_mantle(i),i), &
- nibool_interfaces_crust_mantle(i),filename)
- enddo
- call sync_all()
- endif
-
- ! checks addressing
- call test_MPI_neighbours(IREGION_CRUST_MANTLE, &
- num_interfaces_crust_mantle,max_nibool_interfaces_cm, &
- my_neighbours_crust_mantle,nibool_interfaces_crust_mantle, &
- ibool_interfaces_crust_mantle)
-
- ! checks with assembly of test fields
- call test_MPI_cm()
-
- end subroutine setup_MPI_interfaces_cm
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine setup_MPI_interfaces_oc(MAX_NEIGHBOURS,my_neighbours,nibool_neighbours, &
- max_nibool,ibool_neighbours)
-
- use meshfem3D_par,only: &
- myrank,iproc_xi,iproc_eta,ichunk,addressing,INCLUDE_CENTRAL_CUBE, &
- NPROC_XI,NPROC_ETA,NPROCTOT, &
- NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NCHUNKS, &
- OUTPUT_FILES
-
- use meshfem3D_par,only: ibool,is_on_a_slice_edge
-
- use create_MPI_interfaces_par
- use MPI_outer_core_par
- implicit none
-
- integer :: MAX_NEIGHBOURS,max_nibool
- integer, dimension(MAX_NEIGHBOURS) :: my_neighbours,nibool_neighbours
- integer, dimension(max_nibool,MAX_NEIGHBOURS) :: ibool_neighbours
-
- ! local parameters
- ! temporary buffers for send and receive between faces of the slices and the chunks
- real(kind=CUSTOM_REAL), dimension(npoin2D_max_all_CM_IC) :: &
- buffer_send_faces_scalar,buffer_received_faces_scalar
- real(kind=CUSTOM_REAL),dimension(:),allocatable :: test_flag
- integer,dimension(:),allocatable :: dummy_i
- integer :: i,ier
- ! debug file output
- character(len=150) :: filename
- logical,parameter :: DEBUG = .false.
-
- ! sets up MPI interfaces
- ! outer core region
- if( myrank == 0 ) write(IMAIN,*) 'outer core mpi:'
-
- allocate(test_flag(NGLOB_OUTER_CORE), &
- stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating test_flag outer core')
-
- ! sets flag to rank id (+1 to avoid problems with zero rank)
- test_flag(:) = myrank + 1.0
-
- ! assembles values
- call assemble_MPI_scalar_block(myrank,test_flag, &
- NGLOB_OUTER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_faces_outer_core,npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iboolfaces_outer_core,iboolcorner_outer_core, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces_scalar,buffer_received_faces_scalar,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_XY,NCHUNKS)
-
-
- ! removes own myrank id (+1)
- test_flag(:) = test_flag(:) - ( myrank + 1.0)
-
- allocate(dummy_i(NSPEC_OUTER_CORE),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating dummy_i')
-
- ! determines neighbor rank for shared faces
- call get_MPI_interfaces(myrank,NGLOB_OUTER_CORE,NSPEC_OUTER_CORE, &
- test_flag,my_neighbours,nibool_neighbours,ibool_neighbours, &
- num_interfaces_outer_core,max_nibool_interfaces_oc, &
- max_nibool,MAX_NEIGHBOURS, &
- ibool,is_on_a_slice_edge, &
- IREGION_OUTER_CORE,.false.,dummy_i,INCLUDE_CENTRAL_CUBE, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core,NPROCTOT)
-
- deallocate(test_flag)
- deallocate(dummy_i)
-
- ! stores MPI interfaces informations
- allocate(my_neighbours_outer_core(num_interfaces_outer_core), &
- nibool_interfaces_outer_core(num_interfaces_outer_core), &
- stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating array my_neighbours_outer_core etc.')
- my_neighbours_outer_core = -1
- nibool_interfaces_outer_core = 0
-
- ! copies interfaces arrays
- if( num_interfaces_outer_core > 0 ) then
- allocate(ibool_interfaces_outer_core(max_nibool_interfaces_oc,num_interfaces_outer_core), &
- stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating array ibool_interfaces_outer_core')
- ibool_interfaces_outer_core = 0
-
- ! ranks of neighbour processes
- my_neighbours_outer_core(:) = my_neighbours(1:num_interfaces_outer_core)
- ! number of global ibool entries on each interface
- nibool_interfaces_outer_core(:) = nibool_neighbours(1:num_interfaces_outer_core)
- ! global iglob point ids on each interface
- ibool_interfaces_outer_core(:,:) = ibool_neighbours(1:max_nibool_interfaces_oc,1:num_interfaces_outer_core)
- else
- ! dummy allocation (fortran90 should allow allocate statement with zero array size)
- max_nibool_interfaces_oc = 0
- allocate(ibool_interfaces_outer_core(0,0),stat=ier)
- endif
-
- ! debug: outputs MPI interface
- if( DEBUG ) then
- do i=1,num_interfaces_outer_core
- write(filename,'(a,i6.6,a,i2.2)') trim(OUTPUT_FILES)//'/MPI_points_outer_core_proc',myrank, &
- '_',my_neighbours_outer_core(i)
- call write_VTK_data_points(NGLOB_OUTER_CORE, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- ibool_interfaces_outer_core(1:nibool_interfaces_outer_core(i),i), &
- nibool_interfaces_outer_core(i),filename)
- enddo
- call sync_all()
- endif
-
- ! checks addressing
- call test_MPI_neighbours(IREGION_OUTER_CORE, &
- num_interfaces_outer_core,max_nibool_interfaces_oc, &
- my_neighbours_outer_core,nibool_interfaces_outer_core, &
- ibool_interfaces_outer_core)
-
- ! checks with assembly of test fields
- call test_MPI_oc()
-
- end subroutine setup_MPI_interfaces_oc
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine setup_MPI_interfaces_ic(MAX_NEIGHBOURS,my_neighbours,nibool_neighbours, &
- max_nibool,ibool_neighbours)
-
- use meshfem3D_par,only: &
- myrank,iproc_xi,iproc_eta,ichunk,addressing,INCLUDE_CENTRAL_CUBE, &
- NPROC_XI,NPROC_ETA,NPROCTOT, &
- NGLOB1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NCHUNKS, &
- OUTPUT_FILES,IFLAG_IN_FICTITIOUS_CUBE,NGLLX,NGLLY,NGLLZ,NSPEC2D_BOTTOM
-
- use meshfem3D_par,only: ibool,idoubling,is_on_a_slice_edge
-
- use create_MPI_interfaces_par
- use MPI_inner_core_par
-
- implicit none
-
- integer :: MAX_NEIGHBOURS,max_nibool
- integer, dimension(MAX_NEIGHBOURS) :: my_neighbours,nibool_neighbours
- integer, dimension(max_nibool,MAX_NEIGHBOURS) :: ibool_neighbours
-
- ! local parameters
- ! temporary buffers for send and receive between faces of the slices and the chunks
- real(kind=CUSTOM_REAL), dimension(npoin2D_max_all_CM_IC) :: &
- buffer_send_faces_scalar,buffer_received_faces_scalar
- real(kind=CUSTOM_REAL),dimension(:),allocatable :: test_flag
- integer :: i,j,k,ispec,iglob,ier
- integer :: ndim_assemble
- ! debug file output
- character(len=150) :: filename
- logical,parameter :: DEBUG = .false.
-
- ! sets up MPI interfaces
- ! inner core
- if( myrank == 0 ) write(IMAIN,*) 'inner core mpi:'
-
- allocate(test_flag(NGLOB_INNER_CORE), &
- stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating test_flag inner core')
-
- ! sets flag to rank id (+1 to avoid problems with zero rank)
- test_flag(:) = 0.0
- do ispec=1,NSPEC_INNER_CORE
- ! suppress fictitious elements in central cube
- if(idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
- ! sets flags
- do k = 1,NGLLZ
- do j = 1,NGLLY
- do i = 1,NGLLX
- iglob = ibool(i,j,k,ispec)
- test_flag(iglob) = myrank + 1.0
- enddo
- enddo
- enddo
- enddo
-
- ! assembles values
- call assemble_MPI_scalar_block(myrank,test_flag, &
- NGLOB_INNER_CORE, &
- iproc_xi,iproc_eta,ichunk,addressing, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_faces_inner_core,npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iboolfaces_inner_core,iboolcorner_inner_core, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- buffer_send_faces_scalar,buffer_received_faces_scalar,npoin2D_max_all_CM_IC, &
- buffer_send_chunkcorn_scalar,buffer_recv_chunkcorn_scalar, &
- NUMMSGS_FACES,NUM_MSG_TYPES,NCORNERSCHUNKS, &
- NPROC_XI,NPROC_ETA,NGLOB1D_RADIAL(IREGION_INNER_CORE), &
- NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE),NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE), &
- NGLOB2DMAX_XY,NCHUNKS)
-
- ! debug: idoubling inner core
- if( DEBUG ) then
- write(filename,'(a,i6.6)') trim(OUTPUT_FILES)//'/MPI_idoubling_inner_core_proc',myrank
- call write_VTK_data_elem_i(NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- ibool, &
- idoubling,filename)
- call sync_all()
- endif
-
- ! including central cube
- if(INCLUDE_CENTRAL_CUBE) then
- ! user output
- if( myrank == 0 ) write(IMAIN,*) 'inner core with central cube mpi:'
-
- ! test_flag is a scalar, not a vector
- ndim_assemble = 1
-
- ! use central cube buffers to assemble the inner core mass matrix with the central cube
- call assemble_MPI_central_cube_block(ichunk,nb_msgs_theor_in_cube, sender_from_slices_to_cube, &
- npoin2D_cube_from_slices, buffer_all_cube_from_slices, &
- buffer_slices, buffer_slices2, ibool_central_cube, &
- receiver_cube_from_slices, ibool, &
- idoubling, NSPEC_INNER_CORE, &
- ibelm_bottom_inner_core, NSPEC2D_BOTTOM(IREGION_INNER_CORE), &
- NGLOB_INNER_CORE, &
- test_flag,ndim_assemble, &
- iproc_eta,addressing,NCHUNKS,NPROC_XI,NPROC_ETA)
-
- ! frees array not needed anymore
- deallocate(ibelm_bottom_inner_core)
-
- endif
-
- ! removes own myrank id (+1)
- test_flag = test_flag - ( myrank + 1.0)
- where( test_flag < 0.0 ) test_flag = 0.0
-
- ! debug: in sequential order, for testing purpose
- !do i=0,NPROCTOT - 1
- ! if( myrank == i ) then
- ! ! gets new interfaces for inner_core without central cube yet
- ! ! determines neighbor rank for shared faces
- ! call get_MPI_interfaces(myrank,NGLOB_INNER_CORE,NSPEC_INNER_CORE, &
- ! test_flag,my_neighbours,nibool_neighbours,ibool_neighbours, &
- ! num_interfaces_inner_core,max_nibool_interfaces_ic, &
- ! max_nibool,MAX_NEIGHBOURS, &
- ! ibool,is_on_a_slice_edge, &
- ! IREGION_INNER_CORE,.false.,idoubling,INCLUDE_CENTRAL_CUBE, &
- ! xstore_inner_core,ystore_inner_core,zstore_inner_core,NPROCTOT)
- ! endif
- ! call sync_all()
- !enddo
-
- ! gets new interfaces for inner_core without central cube yet
- ! determines neighbor rank for shared faces
- call get_MPI_interfaces(myrank,NGLOB_INNER_CORE,NSPEC_INNER_CORE, &
- test_flag,my_neighbours,nibool_neighbours,ibool_neighbours, &
- num_interfaces_inner_core,max_nibool_interfaces_ic, &
- max_nibool,MAX_NEIGHBOURS, &
- ibool,is_on_a_slice_edge, &
- IREGION_INNER_CORE,.false.,idoubling,INCLUDE_CENTRAL_CUBE, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core,NPROCTOT)
-
- deallocate(test_flag)
-
- ! stores MPI interfaces informations
- allocate(my_neighbours_inner_core(num_interfaces_inner_core), &
- nibool_interfaces_inner_core(num_interfaces_inner_core), &
- stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating array my_neighbours_inner_core etc.')
- my_neighbours_inner_core = -1
- nibool_interfaces_inner_core = 0
-
- ! copies interfaces arrays
- if( num_interfaces_inner_core > 0 ) then
- allocate(ibool_interfaces_inner_core(max_nibool_interfaces_ic,num_interfaces_inner_core), &
- stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating array ibool_interfaces_inner_core')
- ibool_interfaces_inner_core = 0
-
- ! ranks of neighbour processes
- my_neighbours_inner_core(:) = my_neighbours(1:num_interfaces_inner_core)
- ! number of global ibool entries on each interface
- nibool_interfaces_inner_core(:) = nibool_neighbours(1:num_interfaces_inner_core)
- ! global iglob point ids on each interface
- ibool_interfaces_inner_core(:,:) = ibool_neighbours(1:max_nibool_interfaces_ic,1:num_interfaces_inner_core)
- else
- ! dummy allocation (fortran90 should allow allocate statement with zero array size)
- max_nibool_interfaces_ic = 0
- allocate(ibool_interfaces_inner_core(0,0),stat=ier)
- endif
-
- ! debug: saves MPI interfaces
- if( DEBUG ) then
- do i=1,num_interfaces_inner_core
- write(filename,'(a,i6.6,a,i2.2)') trim(OUTPUT_FILES)//'/MPI_points_inner_core_proc',myrank, &
- '_',my_neighbours_inner_core(i)
- call write_VTK_data_points(NGLOB_INNER_CORE, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- ibool_interfaces_inner_core(1:nibool_interfaces_inner_core(i),i), &
- nibool_interfaces_inner_core(i),filename)
- enddo
- call sync_all()
- endif
-
- ! checks addressing
- call test_MPI_neighbours(IREGION_INNER_CORE, &
- num_interfaces_inner_core,max_nibool_interfaces_ic, &
- my_neighbours_inner_core,nibool_interfaces_inner_core, &
- ibool_interfaces_inner_core)
-
- ! checks with assembly of test fields
- call test_MPI_ic()
-
- end subroutine setup_MPI_interfaces_ic
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_color_perm.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_color_perm.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_color_perm.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,1234 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 setup_color_perm(iregion_code)
-
- use meshfem3D_par,only: &
- myrank,IMAIN,USE_MESH_COLORING_GPU,SAVE_MESH_FILES, &
- IREGION_CRUST_MANTLE,IREGION_OUTER_CORE,IREGION_INNER_CORE
-
- use meshfem3D_par,only: ibool,is_on_a_slice_edge
-
- use MPI_crust_mantle_par
- use MPI_outer_core_par
- use MPI_inner_core_par
-
- implicit none
-
- integer,intent(in) :: iregion_code
-
- ! local parameters
- integer, dimension(:), allocatable :: perm
- integer :: ier
- integer :: nspec,nglob
- integer :: idomain
-
- ! user output
- if(myrank == 0) then
- write(IMAIN,*) ' mesh coloring: ',USE_MESH_COLORING_GPU
- endif
-
- select case( iregion_code )
- case( IREGION_CRUST_MANTLE )
- ! crust mantle
- ! initializes
- num_colors_outer_crust_mantle = 0
- num_colors_inner_crust_mantle = 0
-
- ! mesh coloring
- if( USE_MESH_COLORING_GPU ) then
-
- ! user output
- if(myrank == 0) write(IMAIN,*) ' coloring crust mantle... '
-
- ! crust/mantle region
- nspec = NSPEC_CRUST_MANTLE
- nglob = NGLOB_CRUST_MANTLE
- idomain = IREGION_CRUST_MANTLE
-
- ! creates coloring of elements
- allocate(perm(nspec),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating temporary perm crust mantle array')
- perm(:) = 0
-
- call setup_color(myrank,nspec,nglob,ibool,perm, &
- idomain,is_on_a_slice_edge, &
- num_phase_ispec_crust_mantle,phase_ispec_inner_crust_mantle, &
- SAVE_MESH_FILES)
-
- ! checks
- if(minval(perm) /= 1) &
- call exit_MPI(myrank, 'minval(perm) should be 1')
- if(maxval(perm) /= num_phase_ispec_crust_mantle) &
- call exit_MPI(myrank, 'maxval(perm) should be num_phase_ispec_crust_mantle')
-
- ! sorts array according to permutation
- call sync_all()
- if(myrank == 0) then
- write(IMAIN,*) ' mesh permutation:'
- endif
- call setup_permutation(myrank,nspec,nglob,ibool, &
- idomain,perm, &
- num_colors_outer_crust_mantle,num_colors_inner_crust_mantle, &
- num_elem_colors_crust_mantle, &
- num_phase_ispec_crust_mantle,phase_ispec_inner_crust_mantle, &
- SAVE_MESH_FILES)
-
- deallocate(perm)
- else
- ! dummy array
- allocate(num_elem_colors_crust_mantle(num_colors_outer_crust_mantle+num_colors_inner_crust_mantle),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating num_elem_colors_crust_mantle array')
- endif
-
- case( IREGION_OUTER_CORE )
- ! outer core
- ! initializes
- num_colors_outer_outer_core = 0
- num_colors_inner_outer_core = 0
-
- ! mesh coloring
- if( USE_MESH_COLORING_GPU ) then
-
- ! user output
- if(myrank == 0) write(IMAIN,*) ' coloring outer core... '
-
- ! outer core region
- nspec = NSPEC_OUTER_CORE
- nglob = NGLOB_OUTER_CORE
- idomain = IREGION_OUTER_CORE
-
- ! creates coloring of elements
- allocate(perm(nspec),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating temporary perm outer_core array')
- perm(:) = 0
-
- call setup_color(myrank,nspec,nglob,ibool,perm, &
- idomain,is_on_a_slice_edge, &
- num_phase_ispec_outer_core,phase_ispec_inner_outer_core, &
- SAVE_MESH_FILES)
-
- ! checks
- if(minval(perm) /= 1) &
- call exit_MPI(myrank, 'minval(perm) should be 1')
- if(maxval(perm) /= num_phase_ispec_outer_core) &
- call exit_MPI(myrank, 'maxval(perm) should be num_phase_ispec_outer_core')
-
- ! sorts array according to permutation
- call sync_all()
- if(myrank == 0) then
- write(IMAIN,*) ' mesh permutation:'
- endif
- call setup_permutation(myrank,nspec,nglob,ibool, &
- idomain,perm, &
- num_colors_outer_outer_core,num_colors_inner_outer_core, &
- num_elem_colors_outer_core, &
- num_phase_ispec_outer_core,phase_ispec_inner_outer_core, &
- SAVE_MESH_FILES)
-
- deallocate(perm)
- else
- ! dummy array
- allocate(num_elem_colors_outer_core(num_colors_outer_outer_core+num_colors_inner_outer_core),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating num_elem_colors_outer_core array')
- endif
-
- case( IREGION_INNER_CORE )
- ! inner core
- ! initializes
- num_colors_outer_inner_core = 0
- num_colors_inner_inner_core = 0
-
- ! mesh coloring
- if( USE_MESH_COLORING_GPU ) then
-
- ! user output
- if(myrank == 0) write(IMAIN,*) ' coloring inner core... '
-
- ! inner core region
- nspec = NSPEC_INNER_CORE
- nglob = NGLOB_INNER_CORE
- idomain = IREGION_INNER_CORE
-
- ! creates coloring of elements
- allocate(perm(nspec),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating temporary perm inner_core array')
- perm(:) = 0
-
- call setup_color(myrank,nspec,nglob,ibool,perm, &
- idomain,is_on_a_slice_edge, &
- num_phase_ispec_inner_core,phase_ispec_inner_inner_core, &
- SAVE_MESH_FILES)
-
- ! checks
- ! inner core contains ficticious elements not counted for
- if(minval(perm) < 0) &
- call exit_MPI(myrank, 'minval(perm) should be at least 0')
- if(maxval(perm) > num_phase_ispec_inner_core) then
- print*,'error perm inner core:',minval(perm),maxval(perm),num_phase_ispec_inner_core
- call exit_MPI(myrank, 'maxval(perm) should be num_phase_ispec_inner_core')
- endif
-
- ! sorts array according to permutation
- call sync_all()
- if(myrank == 0) then
- write(IMAIN,*) ' mesh permutation:'
- endif
- call setup_permutation(myrank,nspec,nglob,ibool, &
- idomain,perm, &
- num_colors_outer_inner_core,num_colors_inner_inner_core, &
- num_elem_colors_inner_core, &
- num_phase_ispec_inner_core,phase_ispec_inner_inner_core, &
- SAVE_MESH_FILES)
-
- deallocate(perm)
- else
- ! dummy array
- allocate(num_elem_colors_inner_core(num_colors_outer_inner_core+num_colors_inner_inner_core),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating num_elem_colors_inner_core array')
- endif
-
- end select
-
- end subroutine setup_color_perm
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine setup_color(myrank,nspec,nglob,ibool,perm, &
- idomain,is_on_a_slice_edge, &
- num_phase_ispec_d,phase_ispec_inner_d, &
- SAVE_MESH_FILES)
-
-! sets up mesh coloring
-
- use meshfem3D_par,only: &
- LOCAL_PATH,MAX_NUMBER_OF_COLORS,IMAIN,NGLLX,NGLLY,NGLLZ,IFLAG_IN_FICTITIOUS_CUBE, &
- IREGION_CRUST_MANTLE,IREGION_OUTER_CORE,IREGION_INNER_CORE
-
- use meshfem3D_par,only: &
- idoubling
-
- use MPI_crust_mantle_par,only: &
- num_colors_outer_crust_mantle,num_colors_inner_crust_mantle,num_elem_colors_crust_mantle, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
-
- use MPI_outer_core_par,only: &
- num_colors_outer_outer_core,num_colors_inner_outer_core,num_elem_colors_outer_core
-
- use MPI_inner_core_par,only: &
- num_colors_outer_inner_core,num_colors_inner_inner_core,num_elem_colors_inner_core
-
- implicit none
-
- integer :: myrank,nspec,nglob
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
-
- integer, dimension(nspec) :: perm
-
- ! wrapper array for ispec is in domain:
- ! idomain: 1 == crust/mantle, 2 == outer core, 3 == inner core
- integer :: idomain
- logical, dimension(nspec) :: is_on_a_slice_edge
- integer :: num_phase_ispec_d
- integer, dimension(num_phase_ispec_d,2) :: phase_ispec_inner_d
-
- logical :: SAVE_MESH_FILES
-
- ! local parameters
- ! added for color permutation
- integer :: nb_colors_outer_elements,nb_colors_inner_elements
- integer, dimension(:), allocatable :: num_of_elems_in_this_color
- integer, dimension(:), allocatable :: color
- integer, dimension(:), allocatable :: first_elem_number_in_this_color
- logical, dimension(:), allocatable :: ispec_is_d
-
- integer :: nspec_outer,nspec_inner,nspec_domain
- integer :: nspec_outer_min_global,nspec_outer_max_global
- integer :: nspec_inner_min_global,nspec_inner_max_global
- integer :: min_elem_global,max_elem_global
-
- integer :: nb_colors
- integer :: nb_colors_min,nb_colors_max
-
- integer :: icolor,ispec,ispec_counter
- integer :: ispec_inner,ispec_outer
- integer :: ier
-
- character(len=2),dimension(3) :: str_domain = (/ "cm", "oc", "ic" /)
- character(len=256) :: filename
- character(len=150) :: prname
-
- ! debug file output
- logical, parameter :: DEBUG = .false.
- ! debug coloring : creates dummy mesh coloring, separating only inner/outer elements into colors
- logical, parameter :: DEBUG_COLOR = .false.
-
- !!!! David Michea: detection of the edges, coloring and permutation separately
-
- ! 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
-
- ! allocates temporary array with colors
- allocate(color(nspec),stat=ier)
- if( ier /= 0 ) stop 'error allocating temporary color array'
- allocate(first_elem_number_in_this_color(MAX_NUMBER_OF_COLORS + 1),stat=ier)
- if( ier /= 0 ) stop 'error allocating first_elem_number_in_this_color array'
-
- ! flags for elements in this domain
- ! for compatiblity with SPECFEM3D mesh coloring routine
- allocate(ispec_is_d(nspec),stat=ier)
- if( ier /= 0 ) stop 'error allocating ispec_is_d array'
-
- ! sets up domain coloring arrays
- select case(idomain)
- case( IREGION_CRUST_MANTLE,IREGION_OUTER_CORE )
- ! crust/mantle and outer core region meshes use all elements
- ispec_is_d(:) = .true.
- case( IREGION_INNER_CORE )
- ! initializes
- ispec_is_d(:) = .true.
- ! excludes ficticious elements from coloring
- where(idoubling == IFLAG_IN_FICTITIOUS_CUBE) ispec_is_d = .false.
- ! checks
- if( count(ispec_is_d) == 0 ) then
- stop 'error no inner core elements'
- endif
- case default
- stop 'error idomain in setup_color'
- end select
-
- ! fast element coloring scheme
- call get_perm_color_faster(is_on_a_slice_edge,ispec_is_d, &
- ibool,perm,color, &
- nspec,nglob, &
- nb_colors_outer_elements,nb_colors_inner_elements, &
- nspec_outer,nspec_inner,nspec_domain, &
- first_elem_number_in_this_color, &
- myrank)
-
- ! debug: file output
- if( SAVE_MESH_FILES .and. DEBUG .and. idomain == IREGION_CRUST_MANTLE ) then
- call create_name_database(prname,myrank,idomain,LOCAL_PATH)
- filename = prname(1:len_trim(prname))//'color_'//str_domain(idomain)
- call write_VTK_data_elem_i(nspec,nglob, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle,ibool, &
- color,filename)
- endif
- deallocate(color)
-
- ! 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_domain + 1
-
- allocate(num_of_elems_in_this_color(nb_colors_outer_elements + nb_colors_inner_elements),stat=ier)
- if( ier /= 0 ) then
- print*,'error',myrank,' allocating num_of_elems_in_this_color:',nb_colors_outer_elements,nb_colors_inner_elements, &
- nb_colors_outer_elements + nb_colors_inner_elements
- call exit_MPI(myrank,'error allocating num_of_elems_in_this_color array')
- endif
-
- num_of_elems_in_this_color(:) = 0
- 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)
- enddo
- deallocate(first_elem_number_in_this_color)
-
- ! 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_domain) then
- print *,'error number of elements in this color:',idomain
- print *,'rank: ',myrank,' nspec = ',nspec_domain
- print *,' total number of elements in all the colors of the mesh = ', &
- sum(num_of_elems_in_this_color)
- call exit_MPI(myrank, '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 *,'error number of outer elements in this color:',idomain
- print *,'rank: ',myrank,' nspec_outer = ',nspec_outer
- print*,'nb_colors_outer_elements = ',nb_colors_outer_elements
- print *,'total number of elements in all the colors of the mesh for outer elements = ', &
- sum(num_of_elems_in_this_color(1:nb_colors_outer_elements))
- call exit_MPI(myrank, 'incorrect total number of elements in all the colors of the mesh for outer elements')
- endif
-
- ! debug: no mesh coloring, only creates dummy coloring arrays
- if( DEBUG_COLOR ) then
- nb_colors_outer_elements = 0
- nb_colors_inner_elements = 0
- ispec_counter = 0
-
- ! first generate all the outer elements
- do ispec = 1,nspec
- if( ispec_is_d(ispec) ) then
- if( is_on_a_slice_edge(ispec) .eqv. .true. ) then
- ispec_counter = ispec_counter + 1
- perm(ispec) = ispec_counter
- endif
- endif
- enddo
-
- ! store total number of outer elements
- nspec_outer = ispec_counter
-
- ! only single color
- if(nspec_outer > 0 ) nb_colors_outer_elements = 1
-
- ! then generate all the inner elements
- do ispec = 1,nspec
- if( ispec_is_d(ispec) ) then
- if( is_on_a_slice_edge(ispec) .eqv. .false. ) then
- ispec_counter = ispec_counter + 1
- perm(ispec) = ispec_counter - nspec_outer ! starts again at 1
- endif
- endif
- enddo
- nspec_inner = ispec_counter - nspec_outer
-
- ! only single color
- if(nspec_inner > 0 ) nb_colors_inner_elements = 1
-
- ! user output
- if(myrank == 0 ) then
- write(IMAIN,*) 'debugging mesh coloring:'
- write(IMAIN,*) 'nb_colors inner / outer: ',nb_colors_inner_elements,nb_colors_outer_elements
- endif
-
- ! re-allocate
- if(allocated(num_of_elems_in_this_color) ) deallocate(num_of_elems_in_this_color)
- allocate(num_of_elems_in_this_color(nb_colors_outer_elements + nb_colors_inner_elements),stat=ier)
- if( ier /= 0 ) then
- print*,'error',myrank,' allocating num_of_elems_in_this_color:',nb_colors_outer_elements,nb_colors_inner_elements, &
- nb_colors_outer_elements + nb_colors_inner_elements
- call exit_MPI(myrank,'error allocating num_of_elems_in_this_color array')
- endif
-
- if( nspec_outer > 0 ) num_of_elems_in_this_color(1) = nspec_outer
- if( nspec_inner > 0 ) num_of_elems_in_this_color(2) = nspec_inner
- endif ! debug_color
-
- ! debug: saves mesh coloring numbers into files
- if( DEBUG ) then
- ! debug file output
- call create_name_database(prname,myrank,idomain,LOCAL_PATH)
- filename = prname(1:len_trim(prname))//'num_of_elems_in_this_color_'//str_domain(idomain)//'.dat'
- open(unit=99,file=trim(filename),status='unknown',iostat=ier)
- if( ier /= 0 ) stop 'error opening num_of_elems_in_this_color file'
- ! 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
- ! outer elements
- do icolor = 1, nb_colors_outer_elements + nb_colors_inner_elements
- write(99,*) num_of_elems_in_this_color(icolor)
- enddo
- close(99)
- endif
-
- ! checks non-zero elements in colors
- do icolor = 1,nb_colors_outer_elements + nb_colors_inner_elements
- ! checks
- if( num_of_elems_in_this_color(icolor) == 0 ) then
- print *,'rank: ',myrank,'domain:',idomain,' nspec = ',nspec_domain
- print *,'error zero elements in this color:',icolor
- print *,'total number of elements in all the colors of the mesh = ', &
- sum(num_of_elems_in_this_color)
- call exit_MPI(myrank, 'zero elements in a color of the mesh')
- endif
- enddo
-
-
-
- ! sets up domain coloring arrays
- select case(idomain)
- case( IREGION_CRUST_MANTLE )
- ! crust/mantle domains
- num_colors_outer_crust_mantle = nb_colors_outer_elements
- num_colors_inner_crust_mantle = nb_colors_inner_elements
-
- allocate(num_elem_colors_crust_mantle(num_colors_outer_crust_mantle + num_colors_inner_crust_mantle),stat=ier)
- if( ier /= 0 ) stop 'error allocating num_elem_colors_crust_mantle array'
-
- num_elem_colors_crust_mantle(:) = num_of_elems_in_this_color(:)
-
- case( IREGION_OUTER_CORE )
- ! outer core domains
- num_colors_outer_outer_core = nb_colors_outer_elements
- num_colors_inner_outer_core = nb_colors_inner_elements
-
- allocate(num_elem_colors_outer_core(num_colors_outer_outer_core + num_colors_inner_outer_core),stat=ier)
- if( ier /= 0 ) stop 'error allocating num_elem_colors_outer_core array'
-
- num_elem_colors_outer_core(:) = num_of_elems_in_this_color(:)
-
- case( IREGION_INNER_CORE )
- ! inner core domains
- num_colors_outer_inner_core = nb_colors_outer_elements
- num_colors_inner_inner_core = nb_colors_inner_elements
-
- allocate(num_elem_colors_inner_core(num_colors_outer_inner_core + num_colors_inner_inner_core),stat=ier)
- if( ier /= 0 ) stop 'error allocating num_elem_colors_inner_core array'
-
- num_elem_colors_inner_core(:) = num_of_elems_in_this_color(:)
-
- case default
- stop 'error idomain not recognized'
- end select
-
- ! sets up elements for loops in simulations
- ispec_inner = 0
- ispec_outer = 0
- do ispec = 1, nspec
- ! only elements in this domain
- if( ispec_is_d(ispec) ) then
-
- ! sets phase_ispec arrays with ordering of elements
- if( is_on_a_slice_edge(ispec) .eqv. .true. ) then
- ! outer elements
- ispec_outer = perm(ispec)
-
- ! checks
- if( ispec_outer < 1 .or. ispec_outer > num_phase_ispec_d ) then
- print*,'error outer permutation:',idomain
- print*,'rank:',myrank,' ispec_inner = ',ispec_outer
- print*,'num_phase_ispec_d = ',num_phase_ispec_d
- call exit_MPI(myrank,'error outer permutation')
- endif
-
- phase_ispec_inner_d(ispec_outer,1) = ispec
-
- else
- ! inner elements
- ispec_inner = perm(ispec)
-
- ! checks
- if( ispec_inner < 1 .or. ispec_inner > num_phase_ispec_d ) then
- print*,'error inner permutation:',idomain
- print*,'rank:',myrank,' ispec_inner = ',ispec_inner
- print*,'num_phase_ispec_d = ',num_phase_ispec_d
- call exit_MPI(myrank,'error inner permutation')
- endif
-
- phase_ispec_inner_d(ispec_inner,2) = ispec
-
- endif
- endif
- enddo
-
- ! total number of colors
- nb_colors = nb_colors_inner_elements + nb_colors_outer_elements
- call min_all_i(nb_colors,nb_colors_min)
- call max_all_i(nb_colors,nb_colors_max)
-
- ! min/max of elements per color
- call min_all_i(minval(num_of_elems_in_this_color(:)),min_elem_global)
- call max_all_i(maxval(num_of_elems_in_this_color(:)),max_elem_global)
-
- ! min/max of inner/outer elements
- call min_all_i(nspec_inner,nspec_inner_min_global)
- call max_all_i(nspec_inner,nspec_inner_max_global)
- call min_all_i(nspec_outer,nspec_outer_min_global)
- call max_all_i(nspec_outer,nspec_outer_max_global)
-
- ! user output
- if(myrank == 0) then
- write(IMAIN,*) ' total colors:'
- write(IMAIN,*) ' total colors min/max = ',nb_colors_min,nb_colors_max
- write(IMAIN,*) ' elements per color min/max = ',min_elem_global,max_elem_global
- write(IMAIN,*) ' inner elements min/max = ',nspec_inner_min_global,nspec_inner_max_global
- write(IMAIN,*) ' outer elements min/max = ',nspec_outer_min_global,nspec_outer_max_global
- endif
-
- ! debug: outputs permutation array as vtk file
- if( DEBUG .and. idomain == IREGION_CRUST_MANTLE ) then
- call create_name_database(prname,myrank,idomain,LOCAL_PATH)
- filename = prname(1:len_trim(prname))//'perm_'//str_domain(idomain)
- call write_VTK_data_elem_i(nspec,nglob, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle,ibool, &
- perm,filename)
- endif
-
- deallocate(ispec_is_d)
- deallocate(num_of_elems_in_this_color)
-
- end subroutine setup_color
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine setup_permutation(myrank,nspec,nglob,ibool, &
- idomain,perm, &
- num_colors_outer,num_colors_inner, &
- num_elem_colors, &
- num_phase_ispec_d,phase_ispec_inner_d, &
- SAVE_MESH_FILES)
-
- use constants
-
- use meshfem3D_models_par,only: &
- TRANSVERSE_ISOTROPY,HETEROGEN_3D_MANTLE,ANISOTROPIC_3D_MANTLE, &
- ANISOTROPIC_INNER_CORE,ATTENUATION,SAVE_BOUNDARY_MESH
-
- use meshfem3D_par,only: &
- ABSORBING_CONDITIONS, &
- LOCAL_PATH, &
- NCHUNKS,NSPEC2D_TOP,NSPEC2D_BOTTOM, &
- xstore,ystore,zstore,idoubling
-
- use create_regions_mesh_par2,only: &
- xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
- gammaxstore,gammaystore,gammazstore, &
- rhostore,dvpstore,kappavstore,kappahstore,muvstore,muhstore,eta_anisostore, &
- c11store,c12store,c13store,c14store,c15store,c16store,c22store, &
- c23store,c24store,c25store,c26store,c33store,c34store,c35store, &
- c36store,c44store,c45store,c46store,c55store,c56store,c66store, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
- rho_vp,rho_vs, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
- ispec_is_tiso,tau_e_store,Qmu_store, &
- NSPEC2D_MOHO, NSPEC2D_400, NSPEC2D_670, &
- ibelm_moho_top,ibelm_moho_bot,ibelm_400_top,ibelm_400_bot, &
- ibelm_670_top,ibelm_670_bot
-
- use MPI_crust_mantle_par,only: NSPEC_CRUST_MANTLE, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle
-
- use MPI_outer_core_par,only: NSPEC_OUTER_CORE
- use MPI_inner_core_par,only: NSPEC_INNER_CORE
-
- implicit none
-
- integer,intent(in) :: myrank,nspec,nglob
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
-
- integer,intent(in) :: idomain
- integer, dimension(nspec),intent(inout) :: perm
-
- integer :: num_colors_outer,num_colors_inner
- integer, dimension(num_colors_outer + num_colors_inner) :: num_elem_colors
- integer :: num_phase_ispec_d
- integer, dimension(num_phase_ispec_d,2) :: phase_ispec_inner_d
-
- logical :: SAVE_MESH_FILES
-
- ! local parameters
- ! added for sorting
- double precision, dimension(:,:,:,:), allocatable :: temp_array_dble,temp_array_dble1
- double precision, dimension(:,:,:,:,:), allocatable :: temp_array_dble_sls,temp_array_dble_sls1
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: temp_array_real
- integer, dimension(:,:,:,:), allocatable :: temp_array_int
- integer, dimension(:), allocatable :: temp_array_int_1D
- integer, dimension(:), allocatable :: temp_perm_global
- logical, dimension(:), allocatable :: temp_array_logical_1D
- logical, dimension(:), allocatable :: mask_global
-
- integer :: icolor,icounter,ispec,ielem,ier,i
- integer :: iface,old_ispec,new_ispec
-
- character(len=256) :: filename
- character(len=150) :: prname
-
- ! debug file output
- logical,parameter :: DEBUG = .false.
-
- ! sorts array according to permutation
- allocate(temp_perm_global(nspec),stat=ier)
- if( ier /= 0 ) stop 'error temp_perm_global array'
-
- ! global ordering
- temp_perm_global(:) = 0
- icounter = 0
-
- ! fills global permutation array
-
- ! first outer elements coloring
- ! phase element counter
- ielem = 0
- do icolor = 1,num_colors_outer
- ! loops through elements
- do i = 1,num_elem_colors(icolor)
- ielem = ielem + 1
- ispec = phase_ispec_inner_d(ielem,1) ! 1 <-- first phase, outer elements
- ! reorders elements
- icounter = icounter + 1
- temp_perm_global(ispec) = icounter
- ! resets to new order
- phase_ispec_inner_d(ielem,1) = icounter
- enddo
- enddo
- ! inner elements coloring
- ielem = 0
- do icolor = num_colors_outer+1,num_colors_outer+num_colors_inner
- ! loops through elements
- do i = 1,num_elem_colors(icolor)
- ielem = ielem + 1
- ispec = phase_ispec_inner_d(ielem,2) ! 2 <-- second phase, inner elements
- ! reorders elements
- icounter = icounter + 1
- temp_perm_global(ispec) = icounter
- ! resets to new order
- phase_ispec_inner_d(ielem,2) = icounter
- enddo
- enddo
-
- ! handles fictitious cube elements for inner core
- ! which contains ficticious elements not counted for
- if( idomain == IREGION_INNER_CORE ) then
- ! fills up permutation with ficticious numbering
- do ispec = 1,nspec
- if( temp_perm_global(ispec) == 0 ) then
- icounter = icounter + 1
- temp_perm_global(ispec) = icounter
- endif
- enddo
- endif
-
- ! checks counter
- if( icounter /= nspec ) then
- print*,'error temp perm: ',icounter,nspec
- stop 'error temporary global permutation incomplete'
- endif
- ! checks values
- if(minval(temp_perm_global) /= 1) call exit_MPI(myrank, 'minval(temp_perm_global) should be 1')
- if(maxval(temp_perm_global) /= nspec) call exit_MPI(myrank, 'maxval(temp_perm_global) should be nspec')
-
- ! checks if every element was uniquely set
- allocate(mask_global(nspec),stat=ier)
- if( ier /= 0 ) stop 'error allocating temporary mask_global'
- mask_global(:) = .false.
-
- icounter = 0 ! counts permutations
- do ispec = 1, nspec
- new_ispec = temp_perm_global(ispec)
- ! checks bounds
- if( new_ispec < 1 .or. new_ispec > nspec ) call exit_MPI(myrank,'error temp_perm_global ispec bounds')
- ! checks if already set
- if( mask_global(new_ispec) ) then
- print*,'error temp_perm_global:',ispec,new_ispec,'element already set'
- call exit_MPI(myrank,'error global permutation')
- else
- mask_global(new_ispec) = .true.
- endif
- ! counts permutations
- if( new_ispec /= ispec ) icounter = icounter + 1
- enddo
-
- ! checks number of set elements
- if( count(mask_global(:)) /= nspec ) then
- print*,'error temp_perm_global:',count(mask_global(:)),nspec,'permutation incomplete'
- call exit_MPI(myrank,'error global permutation incomplete')
- endif
- deallocate(mask_global)
-
- ! user output
- if(myrank == 0) then
- write(IMAIN,*) ' number of permutations = ',icounter
- endif
-
- ! outputs permutation array as vtk file
- if( SAVE_MESH_FILES .and. DEBUG .and. idomain == IREGION_CRUST_MANTLE ) then
- call create_name_database(prname,myrank,idomain,LOCAL_PATH)
- filename = prname(1:len_trim(prname))//'perm_global'
- call write_VTK_data_elem_i(nspec,nglob, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle,ibool, &
- temp_perm_global,filename)
- endif
-
- ! store as new permutation
- perm(:) = temp_perm_global(:)
- deallocate(temp_perm_global)
-
- ! permutes all required mesh arrays according to new ordering
-
- ! permutation of ibool
- allocate(temp_array_int(NGLLX,NGLLY,NGLLZ,nspec))
- call permute_elements_integer(ibool,temp_array_int,perm,nspec)
- deallocate(temp_array_int)
-
- ! element idoubling flags
- allocate(temp_array_int_1D(nspec))
- call permute_elements_integer1D(idoubling,temp_array_int_1D,perm,nspec)
- deallocate(temp_array_int_1D)
-
- ! element domain flags
- allocate(temp_array_logical_1D(nspec))
- call permute_elements_logical1D(ispec_is_tiso,temp_array_logical_1D,perm,nspec)
- deallocate(temp_array_logical_1D)
-
- ! mesh arrays
- ! double precision
- allocate(temp_array_dble(NGLLX,NGLLY,NGLLZ,nspec))
- call permute_elements_dble(xstore,temp_array_dble,perm,nspec)
- call permute_elements_dble(ystore,temp_array_dble,perm,nspec)
- call permute_elements_dble(zstore,temp_array_dble,perm,nspec)
- deallocate(temp_array_dble)
- ! custom precision
- allocate(temp_array_real(NGLLX,NGLLY,NGLLZ,nspec))
- call permute_elements_real(xixstore,temp_array_real,perm,nspec)
- call permute_elements_real(xiystore,temp_array_real,perm,nspec)
- call permute_elements_real(xizstore,temp_array_real,perm,nspec)
- call permute_elements_real(etaxstore,temp_array_real,perm,nspec)
- call permute_elements_real(etaystore,temp_array_real,perm,nspec)
- call permute_elements_real(etazstore,temp_array_real,perm,nspec)
- call permute_elements_real(gammaxstore,temp_array_real,perm,nspec)
- call permute_elements_real(gammaystore,temp_array_real,perm,nspec)
- call permute_elements_real(gammazstore,temp_array_real,perm,nspec)
-
- ! material parameters
- call permute_elements_real(rhostore,temp_array_real,perm,nspec)
- call permute_elements_real(kappavstore,temp_array_real,perm,nspec)
- deallocate(temp_array_real)
-
- ! boundary surfaces
- ! note: only arrays pointing to ispec will have to be permutated since value of ispec will be different
- !
- ! xmin
- do iface = 1,nspec2D_xmin
- old_ispec = ibelm_xmin(iface)
- new_ispec = perm(old_ispec)
- ibelm_xmin(iface) = new_ispec
- enddo
- ! xmax
- do iface = 1,nspec2D_xmax
- old_ispec = ibelm_xmax(iface)
- new_ispec = perm(old_ispec)
- ibelm_xmax(iface) = new_ispec
- enddo
- ! ymin
- do iface = 1,nspec2D_ymin
- old_ispec = ibelm_ymin(iface)
- new_ispec = perm(old_ispec)
- ibelm_ymin(iface) = new_ispec
- enddo
- ! ymax
- do iface = 1,nspec2D_ymax
- old_ispec = ibelm_ymax(iface)
- new_ispec = perm(old_ispec)
- ibelm_ymax(iface) = new_ispec
- enddo
- ! bottom
- do iface = 1,NSPEC2D_BOTTOM(idomain)
- old_ispec = ibelm_bottom(iface)
- new_ispec = perm(old_ispec)
- ibelm_bottom(iface) = new_ispec
- enddo
- ! top
- do iface = 1,NSPEC2D_TOP(idomain)
- old_ispec = ibelm_top(iface)
- new_ispec = perm(old_ispec)
- ibelm_top(iface) = new_ispec
- enddo
-
- ! attenuation arrays
- if (ATTENUATION) then
- if (USE_3D_ATTENUATION_ARRAYS) then
- allocate(temp_array_dble(NGLLX,NGLLY,NGLLZ,nspec))
- allocate(temp_array_dble_sls(N_SLS,NGLLX,NGLLY,NGLLZ,nspec))
- call permute_elements_dble(Qmu_store,temp_array_dble,perm,nspec)
- call permute_elements_dble_sls(tau_e_store,temp_array_dble_sls,perm,nspec)
- deallocate(temp_array_dble,temp_array_dble_sls)
- else
- allocate(temp_array_dble1(1,1,1,nspec))
- allocate(temp_array_dble_sls1(N_SLS,1,1,1,nspec))
- call permute_elements_dble1(Qmu_store,temp_array_dble1,perm,nspec)
- call permute_elements_dble_sls1(tau_e_store,temp_array_dble_sls1,perm,nspec)
- deallocate(temp_array_dble1,temp_array_dble_sls1)
- endif
- endif
-
- select case( idomain )
- case( IREGION_CRUST_MANTLE )
- ! checks number of elements
- if( nspec /= NSPEC_CRUST_MANTLE ) &
- call exit_MPI(myrank,'error in permutation nspec should be NSPEC_CRUST_MANTLE')
-
- allocate(temp_array_real(NGLLX,NGLLY,NGLLZ,nspec))
-
- if(ANISOTROPIC_3D_MANTLE) then
- call permute_elements_real(c11store,temp_array_real,perm,nspec)
- call permute_elements_real(c11store,temp_array_real,perm,nspec)
- call permute_elements_real(c12store,temp_array_real,perm,nspec)
- call permute_elements_real(c13store,temp_array_real,perm,nspec)
- call permute_elements_real(c14store,temp_array_real,perm,nspec)
- call permute_elements_real(c15store,temp_array_real,perm,nspec)
- call permute_elements_real(c16store,temp_array_real,perm,nspec)
- call permute_elements_real(c22store,temp_array_real,perm,nspec)
- call permute_elements_real(c23store,temp_array_real,perm,nspec)
- call permute_elements_real(c24store,temp_array_real,perm,nspec)
- call permute_elements_real(c25store,temp_array_real,perm,nspec)
- call permute_elements_real(c26store,temp_array_real,perm,nspec)
- call permute_elements_real(c33store,temp_array_real,perm,nspec)
- call permute_elements_real(c34store,temp_array_real,perm,nspec)
- call permute_elements_real(c35store,temp_array_real,perm,nspec)
- call permute_elements_real(c36store,temp_array_real,perm,nspec)
- call permute_elements_real(c44store,temp_array_real,perm,nspec)
- call permute_elements_real(c45store,temp_array_real,perm,nspec)
- call permute_elements_real(c46store,temp_array_real,perm,nspec)
- call permute_elements_real(c55store,temp_array_real,perm,nspec)
- call permute_elements_real(c56store,temp_array_real,perm,nspec)
- call permute_elements_real(c66store,temp_array_real,perm,nspec)
- else
- call permute_elements_real(muvstore,temp_array_real,perm,nspec)
-
- if(TRANSVERSE_ISOTROPY) then
- call permute_elements_real(kappahstore,temp_array_real,perm,nspec)
- call permute_elements_real(muhstore,temp_array_real,perm,nspec)
- call permute_elements_real(eta_anisostore,temp_array_real,perm,nspec)
- endif
- endif
-
- if(HETEROGEN_3D_MANTLE) then
- call permute_elements_real(dvpstore,temp_array_real,perm,nspec)
- endif
-
- if(ABSORBING_CONDITIONS .and. NCHUNKS /= 6 ) then
- call permute_elements_real(rho_vp,temp_array_real,perm,nspec)
- call permute_elements_real(rho_vs,temp_array_real,perm,nspec)
- endif
-
- deallocate(temp_array_real)
-
- ! discontinuities boundary surface
- if( SAVE_BOUNDARY_MESH ) then
- ! moho
- do iface = 1,nspec2D_MOHO
- ! top
- old_ispec = ibelm_moho_top(iface)
- new_ispec = perm(old_ispec)
- ibelm_moho_top(iface) = new_ispec
- ! bottom
- old_ispec = ibelm_moho_bot(iface)
- new_ispec = perm(old_ispec)
- ibelm_moho_bot(iface) = new_ispec
- enddo
- ! 400
- do iface = 1,nspec2D_400
- ! top
- old_ispec = ibelm_400_top(iface)
- new_ispec = perm(old_ispec)
- ibelm_400_top(iface) = new_ispec
- ! bottom
- old_ispec = ibelm_400_bot(iface)
- new_ispec = perm(old_ispec)
- ibelm_400_bot(iface) = new_ispec
- enddo
- ! 670
- do iface = 1,nspec2D_670
- ! top
- old_ispec = ibelm_670_top(iface)
- new_ispec = perm(old_ispec)
- ibelm_670_top(iface) = new_ispec
- ! bottom
- old_ispec = ibelm_670_bot(iface)
- new_ispec = perm(old_ispec)
- ibelm_670_bot(iface) = new_ispec
- enddo
- endif
-
- case( IREGION_OUTER_CORE )
- ! checks number of elements
- if( nspec /= NSPEC_OUTER_CORE ) &
- call exit_MPI(myrank,'error in permutation nspec should be NSPEC_OUTER_CORE')
-
- if(ABSORBING_CONDITIONS .and. NCHUNKS /= 6 ) then
- allocate(temp_array_real(NGLLX,NGLLY,NGLLZ,nspec))
-
- call permute_elements_real(rho_vp,temp_array_real,perm,nspec)
-
- deallocate(temp_array_real)
- endif
-
- case( IREGION_INNER_CORE )
- ! checks number of elements
- if( nspec /= NSPEC_INNER_CORE ) &
- call exit_MPI(myrank,'error in permutation nspec should be NSPEC_INNER_CORE')
-
- allocate(temp_array_real(NGLLX,NGLLY,NGLLZ,nspec))
-
- ! note: muvstore needed for attenuation also for anisotropic inner core
- call permute_elements_real(muvstore,temp_array_real,perm,nspec)
-
- ! anisotropy in the inner core only
- if(ANISOTROPIC_INNER_CORE) then
- call permute_elements_real(c11store,temp_array_real,perm,nspec)
- call permute_elements_real(c33store,temp_array_real,perm,nspec)
- call permute_elements_real(c12store,temp_array_real,perm,nspec)
- call permute_elements_real(c13store,temp_array_real,perm,nspec)
- call permute_elements_real(c44store,temp_array_real,perm,nspec)
- endif
-
- deallocate(temp_array_real)
-
- case default
- stop 'error idomain in setup_permutation'
- end select
-
- end subroutine setup_permutation
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-! deprecated ...
-!
-! subroutine setup_color_perm(myrank,iregion_code,nspec,nglob, &
-! ibool,is_on_a_slice_edge,prname, &
-! npoin2D_xi,npoin2D_eta)
-!
-! use constants
-! use meshfem3D_par,only: NSTEP,DT,NPROC_XI,NPROC_ETA
-! implicit none
-!
-! ! standard include of the MPI library
-! include 'mpif.h'
-!
-! integer :: myrank
-! integer :: iregion_code
-!
-! integer :: nspec,nglob
-! integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
-!
-! ! this for non blocking MPI
-! logical, dimension(nspec) :: is_on_a_slice_edge
-!
-! ! name of the database file
-! character(len=150) :: prname
-!
-! integer :: npoin2D_xi,npoin2D_eta
-!
-! ! local parameters
-! 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
-! integer :: ispec,ier
-!
-! !!!! 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
-!
-! ! user output
-! if(myrank == 0 ) write(IMAIN,*) ' creating mesh coloring'
-!
-! 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',iostat=ier)
-! if( ier /= 0 ) call exit_mpi(myrank,'error opening num_of_elems_in_this_color file')
-!
-! ! 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)
-! call exit_mpi(myrank,'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)
-! call exit_mpi(myrank,'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 ! USE_MESH_COLORING_GPU
-!
-! !! 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',iostat=ier)
-! if( ier /= 0 ) call exit_mpi(myrank,'error opening file values_from_mesher_f90.h')
-!
-! 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',iostat=ier)
-! if( ier /= 0 ) call exit_mpi(myrank,'error opening file values_from_mesher_C.h')
-!
-! 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',iostat=ier)
-! if( ier /= 0 ) call exit_mpi(myrank,'error opening values_from_mesher_nspec_outer.h file')
-!
-! 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)
-!
-!
-! end subroutine setup_color_perm
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_counters.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_counters.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_counters.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,145 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 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 setup_counters
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_inner_outer.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_inner_outer.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_inner_outer.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,188 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 setup_inner_outer(iregion_code)
-
- use meshfem3D_par,only: &
- myrank,OUTPUT_FILES,IMAIN, &
- IREGION_CRUST_MANTLE,IREGION_OUTER_CORE,IREGION_INNER_CORE
-
- use meshfem3D_par,only: ibool,is_on_a_slice_edge
-
- use MPI_crust_mantle_par
- use MPI_outer_core_par
- use MPI_inner_core_par
-
- implicit none
-
- integer,intent(in) :: iregion_code
-
- ! local parameters
- real :: percentage_edge
- integer :: ier,ispec,iinner,iouter
- ! debug file output
- character(len=150) :: filename
- logical,parameter :: DEBUG = .false.
-
- ! stores inner / outer elements
- !
- ! note: arrays is_on_a_slice_edge_.. have flags set for elements which need to
- ! communicate with other MPI processes
- select case( iregion_code )
- case( IREGION_CRUST_MANTLE )
- ! crust_mantle
- nspec_outer_crust_mantle = count( is_on_a_slice_edge )
- nspec_inner_crust_mantle = NSPEC_CRUST_MANTLE - nspec_outer_crust_mantle
-
- num_phase_ispec_crust_mantle = max(nspec_inner_crust_mantle,nspec_outer_crust_mantle)
-
- allocate(phase_ispec_inner_crust_mantle(num_phase_ispec_crust_mantle,2),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating array phase_ispec_inner_crust_mantle')
-
- phase_ispec_inner_crust_mantle(:,:) = 0
- iinner = 0
- iouter = 0
- do ispec=1,NSPEC_CRUST_MANTLE
- if( is_on_a_slice_edge(ispec) ) then
- ! outer element
- iouter = iouter + 1
- phase_ispec_inner_crust_mantle(iouter,1) = ispec
- else
- ! inner element
- iinner = iinner + 1
- phase_ispec_inner_crust_mantle(iinner,2) = ispec
- endif
- enddo
-
- ! user output
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'for overlapping of communications with calculations:'
- write(IMAIN,*)
- percentage_edge = 100. * nspec_outer_crust_mantle / real(NSPEC_CRUST_MANTLE)
- write(IMAIN,*) 'percentage of edge elements in crust/mantle ',percentage_edge,'%'
- write(IMAIN,*) 'percentage of volume elements in crust/mantle ',100. - percentage_edge,'%'
- write(IMAIN,*)
- endif
-
- ! debug: saves element flags
- if( DEBUG ) then
- write(filename,'(a,i6.6)') trim(OUTPUT_FILES)//'/MPI_innerouter_crust_mantle_proc',myrank
- call write_VTK_data_elem_l(NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle, &
- ibool, &
- is_on_a_slice_edge,filename)
- endif
-
- case( IREGION_OUTER_CORE )
- ! outer_core
- nspec_outer_outer_core = count( is_on_a_slice_edge )
- nspec_inner_outer_core = NSPEC_OUTER_CORE - nspec_outer_outer_core
-
- num_phase_ispec_outer_core = max(nspec_inner_outer_core,nspec_outer_outer_core)
-
- allocate(phase_ispec_inner_outer_core(num_phase_ispec_outer_core,2),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating array phase_ispec_inner_outer_core')
-
- phase_ispec_inner_outer_core(:,:) = 0
- iinner = 0
- iouter = 0
- do ispec=1,NSPEC_OUTER_CORE
- if( is_on_a_slice_edge(ispec) ) then
- ! outer element
- iouter = iouter + 1
- phase_ispec_inner_outer_core(iouter,1) = ispec
- else
- ! inner element
- iinner = iinner + 1
- phase_ispec_inner_outer_core(iinner,2) = ispec
- endif
- enddo
-
- ! user output
- if(myrank == 0) then
- percentage_edge = 100.* nspec_outer_outer_core / real(NSPEC_OUTER_CORE)
- write(IMAIN,*) 'percentage of edge elements in outer core ',percentage_edge,'%'
- write(IMAIN,*) 'percentage of volume elements in outer core ',100. - percentage_edge,'%'
- write(IMAIN,*)
- endif
-
- ! debug: saves element flags
- if( DEBUG ) then
- write(filename,'(a,i6.6)') trim(OUTPUT_FILES)//'/MPI_innerouter_outer_core_proc',myrank
- call write_VTK_data_elem_l(NSPEC_OUTER_CORE,NGLOB_OUTER_CORE, &
- xstore_outer_core,ystore_outer_core,zstore_outer_core, &
- ibool, &
- is_on_a_slice_edge,filename)
- endif
-
- case( IREGION_INNER_CORE )
- ! inner_core
- nspec_outer_inner_core = count( is_on_a_slice_edge )
- nspec_inner_inner_core = NSPEC_INNER_CORE - nspec_outer_inner_core
-
- num_phase_ispec_inner_core = max(nspec_inner_inner_core,nspec_outer_inner_core)
-
- allocate(phase_ispec_inner_inner_core(num_phase_ispec_inner_core,2),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating array phase_ispec_inner_inner_core')
-
- phase_ispec_inner_inner_core(:,:) = 0
- iinner = 0
- iouter = 0
- do ispec=1,NSPEC_INNER_CORE
- if( is_on_a_slice_edge(ispec) ) then
- ! outer element
- iouter = iouter + 1
- phase_ispec_inner_inner_core(iouter,1) = ispec
- else
- ! inner element
- iinner = iinner + 1
- phase_ispec_inner_inner_core(iinner,2) = ispec
- endif
- enddo
-
- ! user output
- if(myrank == 0) then
- percentage_edge = 100. * nspec_outer_inner_core / real(NSPEC_INNER_CORE)
- write(IMAIN,*) 'percentage of edge elements in inner core ',percentage_edge,'%'
- write(IMAIN,*) 'percentage of volume elements in inner core ',100. - percentage_edge,'%'
- write(IMAIN,*)
- endif
-
- ! debug: saves element flags
- if( DEBUG ) then
- write(filename,'(a,i6.6)') trim(OUTPUT_FILES)//'/MPI_innerouter_inner_core_proc',myrank
- call write_VTK_data_elem_l(NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
- xstore_inner_core,ystore_inner_core,zstore_inner_core, &
- ibool, &
- is_on_a_slice_edge,filename)
- endif
-
- end select
-
- end subroutine setup_Inner_Outer
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_model.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_model.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/setup_model.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,189 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 setup_model()
-
- use meshfem3D_par
- implicit none
-
- ! user output
- if(myrank == 0) call sm_output_info()
-
- ! 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 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 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)
-
-
- ! distributes 3D models
- call meshfem3D_models_broadcast(myrank,NSPEC, &
- MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD,&
- R80,R220,R670,RCMB,RICB, &
- LOCAL_PATH)
-
-
- ! user output
- if(myrank == 0 ) then
- write(IMAIN,*)
- write(IMAIN,*)
- endif
- call sync_all()
-
- end subroutine setup_model
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine sm_output_info()
-
- use meshfem3D_models_par
- use meshfem3D_par,only: &
- MODEL,sizeprocs,NEX_XI,NEX_ETA, &
- NPROC_XI,NPROC_ETA,NPROC,NCHUNKS,NPROCTOT, &
- R_CENTRAL_CUBE
-
- implicit none
-
- ! user output
- write(IMAIN,*)
- write(IMAIN,*) 'There are ',sizeprocs,' MPI processes'
- write(IMAIN,*) 'Processes are numbered from 0 to ',sizeprocs-1
- write(IMAIN,*)
- write(IMAIN,*) 'There are ',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,*)
-
- ! model user parameters
- write(IMAIN,*) 'model: ',trim(MODEL)
- if(OCEANS) then
- write(IMAIN,*) ' incorporating the oceans using equivalent load'
- else
- write(IMAIN,*) ' no oceans'
- endif
- if(ELLIPTICITY) then
- write(IMAIN,*) ' incorporating ellipticity'
- else
- write(IMAIN,*) ' no ellipticity'
- endif
- if(TOPOGRAPHY) then
- write(IMAIN,*) ' incorporating surface topography'
- else
- write(IMAIN,*) ' no surface topography'
- endif
- if(GRAVITY) then
- write(IMAIN,*) ' incorporating self-gravitation (Cowling approximation)'
- else
- write(IMAIN,*) ' no self-gravitation'
- endif
- if(ROTATION) then
- write(IMAIN,*) ' incorporating rotation'
- else
- write(IMAIN,*) ' no rotation'
- endif
- if(ATTENUATION) then
- write(IMAIN,*) ' incorporating attenuation using ',N_SLS,' standard linear solids'
- if(ATTENUATION_3D) write(IMAIN,*)' using 3D attenuation model'
- else
- write(IMAIN,*) ' no attenuation'
- endif
- write(IMAIN,*)
-
- ! model mesh parameters
- if(ISOTROPIC_3D_MANTLE) then
- write(IMAIN,*) ' incorporating 3-D lateral variations'
- else
- write(IMAIN,*) ' no 3-D lateral variations'
- endif
- if(HETEROGEN_3D_MANTLE) then
- write(IMAIN,*) ' incorporating heterogeneities in the mantle'
- else
- write(IMAIN,*) ' no heterogeneities in the mantle'
- endif
- if(CRUSTAL) then
- write(IMAIN,*) ' incorporating crustal variations'
- else
- write(IMAIN,*) ' no crustal variations'
- endif
- 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
- if(TRANSVERSE_ISOTROPY) then
- write(IMAIN,*) ' incorporating anisotropy'
- else
- write(IMAIN,*) ' no anisotropy'
- endif
- if(ANISOTROPIC_INNER_CORE) then
- write(IMAIN,*) ' incorporating anisotropic inner core'
- else
- write(IMAIN,*) ' no inner-core anisotropy'
- endif
- 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'
-
- ! flushes I/O buffer
- call flush_IMAIN()
-
- end subroutine sm_output_info
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/test_MPI_interfaces.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/test_MPI_interfaces.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/meshfem3D/test_MPI_interfaces.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,575 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 test_MPI_neighbours(iregion_code, &
- num_interfaces,max_nibool_interfaces, &
- my_neighbours,nibool_interfaces, &
- ibool_interfaces)
-
- use constants
- use meshfem3D_par,only: NPROCTOT,myrank
- use MPI_crust_mantle_par,only: NGLOB_CRUST_MANTLE
- use MPI_outer_core_par,only: NGLOB_OUTER_CORE
- use MPI_inner_core_par,only: NGLOB_INNER_CORE
-
- implicit none
-
- integer,intent(in) :: iregion_code
- integer,intent(in) :: num_interfaces,max_nibool_interfaces
- integer,dimension(num_interfaces),intent(in) :: my_neighbours,nibool_interfaces
- integer,dimension(max_nibool_interfaces,num_interfaces),intent(in):: ibool_interfaces
-
- ! local parameters
- integer,dimension(:),allocatable :: dummy_i
- integer,dimension(:,:),allocatable :: test_interfaces
- integer,dimension(:,:),allocatable :: test_interfaces_nibool
- integer :: ineighbour,iproc,inum,i,j,ier,ipoints,max_num,iglob
- logical :: is_okay
- logical,dimension(:),allocatable :: mask
-
- ! debug output
- !do iproc=0,NPROCTOT-1
- ! if( myrank == iproc ) then
- ! print*, 'mpi rank',myrank,'interfaces : ',num_interfaces,'region',iregion_code
- ! do j=1,num_interfaces
- ! print*, ' my_neighbours: ',my_neighbours(j),nibool_interfaces(j)
- ! enddo
- ! print*
- ! endif
- ! call sync_all()
- !enddo
-
- ! checks maximum number of interface points
- if( max_nibool_interfaces == 0 .and. NPROCTOT > 1 ) then
- print*,'test MPI: rank ',myrank,'max_nibool_interfaces is zero'
- call exit_mpi(myrank,'error test max_nibool_interfaces zero')
- endif
-
- ! allocates global mask
- select case(iregion_code)
- case( IREGION_CRUST_MANTLE )
- allocate(mask(NGLOB_CRUST_MANTLE))
- case( IREGION_OUTER_CORE )
- allocate(mask(NGLOB_OUTER_CORE))
- case( IREGION_INNER_CORE )
- allocate(mask(NGLOB_INNER_CORE))
- case default
- call exit_mpi(myrank,'error test MPI: iregion_code not recognized')
- end select
-
- ! test ibool entries
- ! (must be non-zero and unique)
- do i = 1,num_interfaces
- ! number of interface points
- if( nibool_interfaces(i) > max_nibool_interfaces ) then
- print*,'error test MPI: rank',myrank,'nibool values:',nibool_interfaces(i),max_nibool_interfaces
- call exit_mpi(myrank,'error test MPI: nibool exceeds max_nibool_interfaces')
- endif
-
- mask(:) = .false.
-
- ! ibool entries
- do j = 1,nibool_interfaces(i)
- iglob = ibool_interfaces(j,i)
-
- ! checks zero entry
- if( iglob <= 0 ) then
- print*,'error test MPI: rank ',myrank,'ibool value:',iglob,'interface:',i,'point:',j
- call exit_mpi(myrank,'error test MPI: ibool values invalid')
- endif
-
- ! checks duplicate
- if( j < nibool_interfaces(i) ) then
- if( iglob == ibool_interfaces(j+1,i) ) then
- print*,'error test MPI: rank',myrank,'ibool duplicate:',iglob,'interface:',i,'point:',j
- call exit_mpi(myrank,'error test MPI: ibool duplicates')
- endif
- endif
-
- ! checks if unique global value
- if( .not. mask(iglob) ) then
- mask(iglob) = .true.
- else
- print*,'error test MPI: rank',myrank,'ibool masked:',iglob,'interface:',i,'point:',j
- call exit_mpi(myrank,'error test MPI: ibool masked already')
- endif
- enddo
- enddo
- deallocate(mask)
-
- ! checks neighbors
- ! gets maximum interfaces from all processes
- call max_all_i(num_interfaces,max_num)
-
- ! master gathers infos
- if( myrank == 0 ) then
- ! array for gathering infos
- allocate(test_interfaces(max_num,0:NPROCTOT),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating test_interfaces')
- test_interfaces = -1
-
- allocate(test_interfaces_nibool(max_num,0:NPROCTOT),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating test_interfaces_nibool')
- test_interfaces_nibool = 0
-
- ! used to store number of interfaces per proc
- allocate(dummy_i(0:NPROCTOT),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating dummy_i for test interfaces')
- dummy_i = 0
-
- ! sets infos for master process
- test_interfaces(1:num_interfaces,0) = my_neighbours(1:num_interfaces)
- test_interfaces_nibool(1:num_interfaces,0) = nibool_interfaces(1:num_interfaces)
- dummy_i(0) = num_interfaces
-
- ! collects from other processes
- do iproc=1,NPROCTOT-1
- ! gets number of interfaces
- !call MPI_RECV(inum,1,MPI_INTEGER,iproc,itag,MPI_COMM_WORLD,msg_status,ier)
- call recv_singlei(inum,iproc,itag)
- dummy_i(iproc) = inum
- if( inum > 0 ) then
- !call MPI_RECV(test_interfaces(1:inum,iproc),inum, &
- ! MPI_INTEGER,iproc,itag,MPI_COMM_WORLD,msg_status,ier)
- call recv_i(test_interfaces(1:inum,iproc),inum,iproc,itag)
-
- !call MPI_RECV(test_interfaces_nibool(1:inum,iproc),inum, &
- ! MPI_INTEGER,iproc,itag,MPI_COMM_WORLD,msg_status,ier)
- call recv_i(test_interfaces_nibool(1:inum,iproc),inum,iproc,itag)
- endif
- enddo
- else
- ! sends infos to master process
- !call MPI_SEND(num_interfaces,1,MPI_INTEGER,0,itag,MPI_COMM_WORLD,ier)
- call send_singlei(num_interfaces,0,itag)
- if( num_interfaces > 0 ) then
- !call MPI_SEND(my_neighbours(1:num_interfaces),num_interfaces, &
- ! MPI_INTEGER,0,itag,MPI_COMM_WORLD,ier)
- call send_i(my_neighbours(1:num_interfaces),num_interfaces,0,itag)
-
- !call MPI_SEND(nibool_interfaces(1:num_interfaces),num_interfaces, &
- ! MPI_INTEGER,0,itag,MPI_COMM_WORLD,ier)
- call send_i(nibool_interfaces(1:num_interfaces),num_interfaces,0,itag)
-
- endif
- endif
- call sync_all()
-
- ! checks if addressing is okay
- if( myrank == 0 ) then
- ! for each process
- do iproc=0,NPROCTOT-1
- ! loops over all neighbors
- do i=1,dummy_i(iproc)
- ! gets neighbour rank and number of points on interface with it
- ineighbour = test_interfaces(i,iproc)
- ipoints = test_interfaces_nibool(i,iproc)
-
- ! checks values
- if( ineighbour < 0 .or. ineighbour > NPROCTOT-1 ) then
- print*,'error neighbour:',iproc,ineighbour
- call exit_mpi(myrank,'error ineighbour')
- endif
- if( ipoints <= 0 ) then
- print*,'error neighbour points:',iproc,ipoints
- call exit_mpi(myrank,'error ineighbour points')
- endif
-
- ! looks up corresponding entry in neighbour array
- is_okay = .false.
- do j=1,dummy_i(ineighbour)
- if( test_interfaces(j,ineighbour) == iproc ) then
- ! checks if same number of interface points with this neighbour
- if( test_interfaces_nibool(j,ineighbour) == ipoints ) then
- is_okay = .true.
- else
- print*,'error ',iproc,'neighbour ',ineighbour,' points =',ipoints
- print*,' ineighbour has points = ',test_interfaces_nibool(j,ineighbour)
- print*
- call exit_mpi(myrank,'error ineighbour points differ')
- endif
- exit
- endif
- enddo
- if( .not. is_okay ) then
- print*,'error ',iproc,' neighbour not found: ',ineighbour
- print*,'iproc ',iproc,' interfaces:'
- print*,test_interfaces(1:dummy_i(iproc),iproc)
- print*,'ineighbour ',ineighbour,' interfaces:'
- print*,test_interfaces(1:dummy_i(ineighbour),ineighbour)
- print*
- call exit_mpi(myrank,'error ineighbour not found')
- endif
- enddo
- enddo
-
- ! user output
- write(IMAIN,*) ' mpi addressing maximum interfaces:',maxval(dummy_i)
- write(IMAIN,*) ' mpi addressing : all interfaces okay'
- write(IMAIN,*)
-
- deallocate(dummy_i)
- deallocate(test_interfaces)
- endif
- call sync_all()
-
- end subroutine test_MPI_neighbours
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine test_MPI_cm()
-
- use meshfem3D_par,only: NPROCTOT,myrank
- use create_MPI_interfaces_par
- use MPI_crust_mantle_par
-
- implicit none
-
- ! local parameters
- real(kind=CUSTOM_REAL),dimension(:,:),allocatable :: test_flag_vector
- integer :: i,j,iglob,ier
- integer :: inum,icount,ival
- integer :: num_unique,num_max_valence
- integer,dimension(:),allocatable :: valence
-
- ! crust mantle
- allocate(test_flag_vector(NDIM,NGLOB_CRUST_MANTLE),stat=ier)
- if( ier /= 0 ) stop 'error allocating array test_flag etc.'
- allocate(valence(NGLOB_CRUST_MANTLE),stat=ier)
- if( ier /= 0 ) stop 'error allocating array valence'
-
- ! points defined by interfaces
- valence(:) = 0
- test_flag_vector(:,:) = 0.0
- do i=1,num_interfaces_crust_mantle
- do j=1,nibool_interfaces_crust_mantle(i)
- iglob = ibool_interfaces_crust_mantle(j,i)
- ! sets flag on
- test_flag_vector(1,iglob) = 1.0_CUSTOM_REAL
- ! counts valence (occurrences)
- valence(iglob) = valence(iglob) + 1
- enddo
- enddo
- ! total number of interface points
- i = sum(nibool_interfaces_crust_mantle)
- call sum_all_i(i,inum)
-
- ! total number of unique points (some could be shared between different processes)
- i = nint( sum(test_flag_vector) )
- num_unique= i
- call sum_all_i(i,icount)
-
- ! maximum valence
- i = maxval( valence(:) )
- num_max_valence = i
- call max_all_i(i,ival)
-
- ! user output
- if( myrank == 0 ) then
- write(IMAIN,*) ' total MPI interface points : ',inum
- write(IMAIN,*) ' unique MPI interface points: ',icount
- write(IMAIN,*) ' maximum valence : ',ival
- endif
-
- ! initializes for assembly
- test_flag_vector(:,:) = 1.0_CUSTOM_REAL
-
- ! adds contributions from different partitions to flag arrays
- call assemble_MPI_vector(NPROCTOT,NGLOB_CRUST_MANTLE, &
- test_flag_vector, &
- num_interfaces_crust_mantle,max_nibool_interfaces_cm, &
- nibool_interfaces_crust_mantle,ibool_interfaces_crust_mantle,&
- my_neighbours_crust_mantle)
-
- ! removes initial flag
- test_flag_vector(:,:) = test_flag_vector(:,:) - 1.0_CUSTOM_REAL
-
- ! checks number of interface points
- i = 0
- do iglob=1,NGLOB_CRUST_MANTLE
- ! only counts flags with MPI contributions
- if( test_flag_vector(1,iglob) > 0.0 ) i = i + 1
-
- ! checks valence
- if( valence(iglob) /= nint(test_flag_vector(1,iglob)) .or. &
- valence(iglob) /= nint(test_flag_vector(2,iglob)) .or. &
- valence(iglob) /= nint(test_flag_vector(3,iglob)) ) then
- print*,'error test MPI: rank',myrank,'valence:',valence(iglob),'flag:',test_flag_vector(:,:)
- call exit_mpi(myrank,'error test MPI crust mantle valence')
- endif
- enddo
-
- ! checks within slice
- if( i /= num_unique ) then
- print*,'error test crust mantle : rank',myrank,'unique mpi points:',i,num_unique
- call exit_mpi(myrank,'error MPI assembly crust mantle')
- endif
-
- ! total number of assembly points
- call sum_all_i(i,inum)
-
- ! points defined by interfaces
- if( myrank == 0 ) then
- ! checks
- if( inum /= icount ) then
- print*,'error crust mantle : total mpi points:',myrank,'total: ',inum,icount
- call exit_mpi(myrank,'error MPI assembly crust mantle')
- endif
-
- ! user output
- write(IMAIN,*) ' total unique MPI interface points:',inum
- write(IMAIN,*)
- endif
-
- deallocate(test_flag_vector)
- deallocate(valence)
-
- call sync_all()
-
- end subroutine test_MPI_cm
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine test_MPI_oc()
-
- use meshfem3D_par,only: NPROCTOT,myrank
- use create_MPI_interfaces_par
- use MPI_outer_core_par
-
- implicit none
-
- ! local parameters
- real(kind=CUSTOM_REAL),dimension(:),allocatable :: test_flag
- integer :: i,j,iglob,ier
- integer :: inum,icount,ival
- integer :: num_max_valence,num_unique
- integer,dimension(:),allocatable :: valence
-
- ! outer core
- allocate(test_flag(NGLOB_OUTER_CORE),stat=ier)
- if( ier /= 0 ) stop 'error allocating array test_flag etc.'
- allocate(valence(NGLOB_OUTER_CORE),stat=ier)
- if( ier /= 0 ) stop 'error allocating array valence'
-
- ! points defined by interfaces
- valence(:) = 0
- test_flag = 0.0
- do i=1,num_interfaces_outer_core
- do j=1,nibool_interfaces_outer_core(i)
- iglob = ibool_interfaces_outer_core(j,i)
- test_flag(iglob) = 1.0_CUSTOM_REAL
- ! counts valence (occurrences)
- valence(iglob) = valence(iglob) + 1
- enddo
- enddo
- i = sum(nibool_interfaces_outer_core)
- call sum_all_i(i,inum)
-
- i = nint( sum(test_flag) )
- num_unique = i
- call sum_all_i(i,icount)
-
- ! maximum valence
- i = maxval( valence(:) )
- num_max_valence = i
- call max_all_i(i,ival)
-
- if( myrank == 0 ) then
- write(IMAIN,*) ' total MPI interface points : ',inum
- write(IMAIN,*) ' unique MPI interface points: ',icount
- write(IMAIN,*) ' maximum valence : ',ival
- endif
-
- ! initialized for assembly
- test_flag(:) = 1.0_CUSTOM_REAL
-
- ! adds contributions from different partitions to flag arrays
- call assemble_MPI_scalar(NPROCTOT,NGLOB_OUTER_CORE, &
- test_flag, &
- num_interfaces_outer_core,max_nibool_interfaces_oc, &
- nibool_interfaces_outer_core,ibool_interfaces_outer_core,&
- my_neighbours_outer_core)
-
-
- ! removes initial flag
- test_flag(:) = test_flag(:) - 1.0_CUSTOM_REAL
-
- ! checks number of interface points
- i = 0
- do iglob=1,NGLOB_OUTER_CORE
- ! only counts flags with MPI contributions
- if( test_flag(iglob) > 0.0 ) i = i + 1
-
- ! checks valence
- if( valence(iglob) /= nint(test_flag(iglob)) ) then
- print*,'error test MPI: rank',myrank,'valence:',valence(iglob),'flag:',test_flag(iglob)
- call exit_mpi(myrank,'error test outer core valence')
- endif
- enddo
-
- ! checks within slice
- if( i /= num_unique ) then
- print*,'error test outer core : rank',myrank,'unique mpi points:',i,num_unique
- call exit_mpi(myrank,'error MPI assembly outer core')
- endif
- call sum_all_i(i,inum)
-
- ! output
- if( myrank == 0 ) then
- ! checks
- if( inum /= icount ) then
- print*,'error outer core : total mpi points:',myrank,'total: ',inum,icount
- call exit_mpi(myrank,'error MPI assembly outer_core')
- endif
-
- ! user output
- write(IMAIN,*) ' total assembled MPI interface points:',inum
- write(IMAIN,*)
- endif
-
- deallocate(test_flag)
- deallocate(valence)
-
- call sync_all()
-
- end subroutine test_MPI_oc
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine test_MPI_ic()
-
- use meshfem3D_par,only: NPROCTOT,myrank
- use create_MPI_interfaces_par
- use MPI_inner_core_par
-
- implicit none
-
- ! local parameters
- real(kind=CUSTOM_REAL),dimension(:,:),allocatable :: test_flag_vector
- integer :: i,j,iglob,ier
- integer :: inum,icount,ival
- integer :: num_unique,num_max_valence
- integer,dimension(:),allocatable :: valence
-
- ! inner core
- allocate(test_flag_vector(NDIM,NGLOB_INNER_CORE),stat=ier)
- if( ier /= 0 ) stop 'error allocating array test_flag etc.'
- allocate(valence(NGLOB_INNER_CORE),stat=ier)
- if( ier /= 0 ) stop 'error allocating array valence'
-
- ! points defined by interfaces
- valence(:) = 0
- test_flag_vector(:,:) = 0.0
- do i=1,num_interfaces_inner_core
- do j=1,nibool_interfaces_inner_core(i)
- iglob = ibool_interfaces_inner_core(j,i)
- ! sets flag on
- test_flag_vector(1,iglob) = 1.0_CUSTOM_REAL
- ! counts valence (occurrences)
- valence(iglob) = valence(iglob) + 1
- enddo
- enddo
- i = sum(nibool_interfaces_inner_core)
- call sum_all_i(i,inum)
-
- i = nint( sum(test_flag_vector) )
- num_unique= i
- call sum_all_i(i,icount)
-
- ! maximum valence
- i = maxval( valence(:) )
- num_max_valence = i
- call max_all_i(i,ival)
-
- if( myrank == 0 ) then
- write(IMAIN,*) ' total MPI interface points : ',inum
- write(IMAIN,*) ' unique MPI interface points: ',icount
- write(IMAIN,*) ' maximum valence : ',ival
- endif
-
- ! initializes for assembly
- test_flag_vector = 1.0_CUSTOM_REAL
-
- ! adds contributions from different partitions to flag arrays
- call assemble_MPI_vector(NPROCTOT,NGLOB_INNER_CORE, &
- test_flag_vector, &
- num_interfaces_inner_core,max_nibool_interfaces_ic, &
- nibool_interfaces_inner_core,ibool_interfaces_inner_core,&
- my_neighbours_inner_core)
-
- ! removes initial flag
- test_flag_vector(:,:) = test_flag_vector(:,:) - 1.0_CUSTOM_REAL
-
- ! checks number of interface points
- i = 0
- do iglob=1,NGLOB_INNER_CORE
- ! only counts flags with MPI contributions
- if( test_flag_vector(1,iglob) > 0.0 ) i = i + 1
-
- ! checks valence
- if( valence(iglob) /= nint(test_flag_vector(1,iglob)) .or. &
- valence(iglob) /= nint(test_flag_vector(2,iglob)) .or. &
- valence(iglob) /= nint(test_flag_vector(3,iglob)) ) then
- print*,'error test MPI: rank',myrank,'valence:',valence(iglob),'flag:',test_flag_vector(:,:)
- call exit_mpi(myrank,'error test MPI inner core valence')
- endif
-
- enddo
-
- ! checks within slice
- if( i /= num_unique ) then
- print*,'error test inner core : rank',myrank,'unique mpi points:',i,num_unique
- call exit_mpi(myrank,'error MPI assembly inner core')
- endif
- call sum_all_i(i,inum)
-
- if( myrank == 0 ) then
- ! checks
- if( inum /= icount ) then
- print*,'error inner core : total mpi points:',myrank,'total: ',inum,icount
- call exit_mpi(myrank,'error MPI assembly inner core')
- endif
-
- ! user output
- write(IMAIN,*) ' total assembled MPI interface points:',inum
- write(IMAIN,*)
- endif
-
- deallocate(test_flag_vector)
- deallocate(valence)
-
- call sync_all()
-
- end subroutine test_MPI_ic
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/count_elements.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/count_elements.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/count_elements.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,375 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 count_elements(NEX_XI,NEX_ETA,NEX_PER_PROC_XI,NPROC,&
- NEX_PER_PROC_ETA,ratio_divide_central_cube,&
- NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- ner,ratio_sampling_array,this_region_has_a_doubling, &
- ifirst_region,ilast_region,iter_region,iter_layer, &
- doubling,tmp_sum,tmp_sum_xi,tmp_sum_eta, &
- NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
- nb_lay_sb, nspec_sb, nglob_surf, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, INCLUDE_CENTRAL_CUBE, &
- last_doubling_layer, &
- DIFF_NSPEC1D_RADIAL,DIFF_NSPEC2D_XI,DIFF_NSPEC2D_ETA,&
- tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,&
- nglob_edge_v,to_remove)
-
-
- implicit none
-
- include "constants.h"
-
-
- ! parameters to be computed based upon parameters above read from file
- integer NPROC,NEX_XI,NEX_ETA,NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
-
- integer, dimension(MAX_NUM_REGIONS) :: NSPEC,NSPEC2D_XI,NSPEC2D_ETA, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- NSPEC1D_RADIAL,NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
-
-
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
-
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
-
-
- integer :: ifirst_region, ilast_region, iter_region, iter_layer, doubling, tmp_sum, tmp_sum_xi, tmp_sum_eta
- integer :: NUMBER_OF_MESH_LAYERS,layer_offset,nspec2D_xi_sb,nspec2D_eta_sb, &
- nb_lay_sb, nspec_sb, nglob_surf
-
-
- ! for the cut doublingbrick improvement
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA
- logical :: INCLUDE_CENTRAL_CUBE
- integer :: last_doubling_layer
- 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
-
- integer :: tmp_sum_nglob2D_xi, tmp_sum_nglob2D_eta,divider,nglob_edges_h,nglob_edge_v,to_remove
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! calculation of number of elements (NSPEC) below
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- ratio_divide_central_cube = maxval(ratio_sampling_array(1:NUMBER_OF_MESH_LAYERS))
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 1D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
- ! theoretical number of spectral elements in radial direction
- do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
- if(iter_region == IREGION_CRUST_MANTLE) then
- ifirst_region = 1
- ilast_region = 10 + layer_offset
- else if(iter_region == IREGION_OUTER_CORE) then
- ifirst_region = 11 + layer_offset
- ilast_region = NUMBER_OF_MESH_LAYERS - 1
- else if(iter_region == IREGION_INNER_CORE) then
- ifirst_region = NUMBER_OF_MESH_LAYERS
- ilast_region = NUMBER_OF_MESH_LAYERS
- else
- stop 'incorrect region code detected'
- endif
- NSPEC1D_RADIAL(iter_region) = sum(ner(ifirst_region:ilast_region))
- enddo
-
- ! difference of radial number of element for outer core if the superbrick is cut
- DIFF_NSPEC1D_RADIAL(:,:) = 0
- if (CUT_SUPERBRICK_XI) then
- if (CUT_SUPERBRICK_ETA) then
- DIFF_NSPEC1D_RADIAL(2,1) = 1
- DIFF_NSPEC1D_RADIAL(3,1) = 2
- DIFF_NSPEC1D_RADIAL(4,1) = 1
-
- DIFF_NSPEC1D_RADIAL(1,2) = 1
- DIFF_NSPEC1D_RADIAL(2,2) = 2
- DIFF_NSPEC1D_RADIAL(3,2) = 1
-
- DIFF_NSPEC1D_RADIAL(1,3) = 1
- DIFF_NSPEC1D_RADIAL(3,3) = 1
- DIFF_NSPEC1D_RADIAL(4,3) = 2
-
- DIFF_NSPEC1D_RADIAL(1,4) = 2
- DIFF_NSPEC1D_RADIAL(2,4) = 1
- DIFF_NSPEC1D_RADIAL(4,4) = 1
- else
- DIFF_NSPEC1D_RADIAL(2,1) = 1
- DIFF_NSPEC1D_RADIAL(3,1) = 1
-
- DIFF_NSPEC1D_RADIAL(1,2) = 1
- DIFF_NSPEC1D_RADIAL(4,2) = 1
- endif
- else
- if (CUT_SUPERBRICK_ETA) then
- DIFF_NSPEC1D_RADIAL(3,1) = 1
- DIFF_NSPEC1D_RADIAL(4,1) = 1
-
- DIFF_NSPEC1D_RADIAL(1,2) = 1
- DIFF_NSPEC1D_RADIAL(2,2) = 1
- endif
- endif
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 2D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- ! exact number of surface elements for faces along XI and ETA
-
- do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
- if(iter_region == IREGION_CRUST_MANTLE) then
- ifirst_region = 1
- ilast_region = 10 + layer_offset
- else if(iter_region == IREGION_OUTER_CORE) then
- ifirst_region = 11 + layer_offset
- ilast_region = NUMBER_OF_MESH_LAYERS - 1
- else if(iter_region == IREGION_INNER_CORE) then
- ifirst_region = NUMBER_OF_MESH_LAYERS
- ilast_region = NUMBER_OF_MESH_LAYERS
- else
- stop 'incorrect region code detected'
- endif
- tmp_sum_xi = 0
- tmp_sum_eta = 0
- tmp_sum_nglob2D_xi = 0
- tmp_sum_nglob2D_eta = 0
- do iter_layer = ifirst_region, ilast_region
- if (this_region_has_a_doubling(iter_layer)) then
- if (iter_region == IREGION_OUTER_CORE .and. iter_layer == last_doubling_layer) then
- ! simple brick
- divider = 1
- nglob_surf = 6*NGLLX**2 - 7*NGLLX + 2
- nglob_edges_h = 2*(NGLLX-1)+1 + NGLLX
- ! minimum value to be safe
- nglob_edge_v = NGLLX-2
- nb_lay_sb = 2
- nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK
- nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK
- else
- ! double brick
- divider = 2
- if (ner(iter_layer) == 1) then
- nglob_surf = 6*NGLLX**2 - 8*NGLLX + 3
- nglob_edges_h = 4*(NGLLX-1)+1 + 2*(NGLLX-1)+1
- nglob_edge_v = NGLLX-2
- nb_lay_sb = 1
- nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK_1L
- nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK_1L
- else
- nglob_surf = 8*NGLLX**2 - 11*NGLLX + 4
- nglob_edges_h = 4*(NGLLX-1)+1 + 2*(NGLLX-1)+1
- nglob_edge_v = 2*(NGLLX-1)+1 -2
- nb_lay_sb = 2
- nspec2D_xi_sb = NSPEC2D_XI_SUPERBRICK
- nspec2D_eta_sb = NSPEC2D_ETA_SUPERBRICK
- divider = 2
- endif
- endif
- doubling = 1
- to_remove = 1
- else
- if (iter_layer /= ifirst_region) then
- to_remove = 0
- else
- to_remove = 1
- endif
- ! dummy values to avoid a warning
- nglob_surf = 0
- nglob_edges_h = 0
- nglob_edge_v = 0
- divider = 1
- doubling = 0
- nb_lay_sb = 0
- nspec2D_xi_sb = 0
- nspec2D_eta_sb = 0
- endif
-
- tmp_sum_xi = tmp_sum_xi + ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)) * &
- (ner(iter_layer) - doubling*nb_lay_sb)) + &
- doubling * ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)) * (nspec2D_xi_sb/2))
-
- tmp_sum_eta = tmp_sum_eta + ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)) * &
- (ner(iter_layer) - doubling*nb_lay_sb)) + &
- doubling * ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)) * (nspec2D_eta_sb/2))
-
- tmp_sum_nglob2D_xi = tmp_sum_nglob2D_xi + (((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)) * &
- (ner(iter_layer) - doubling*nb_lay_sb))*NGLLX*NGLLX) - &
- ((((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - doubling*nb_lay_sb)) + &
- ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))*(ner(iter_layer) - to_remove - doubling*nb_lay_sb))*NGLLX) + &
- (((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - to_remove - doubling*nb_lay_sb)) + &
- doubling * (((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))/divider) * (nglob_surf-nglob_edges_h) - &
- ((NEX_PER_PROC_XI / ratio_sampling_array(iter_layer))/divider -1) * nglob_edge_v)
-
- tmp_sum_nglob2D_eta = tmp_sum_nglob2D_eta + (((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)) * &
- (ner(iter_layer) - doubling*nb_lay_sb))*NGLLX*NGLLX) - &
- ((((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - doubling*nb_lay_sb)) + &
- ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))* &
- (ner(iter_layer) - to_remove - doubling*nb_lay_sb))*NGLLX) + &
- (((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))-1)*(ner(iter_layer) - to_remove - doubling*nb_lay_sb)) + &
- doubling * (((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))/divider) * (nglob_surf-nglob_edges_h) - &
- ((NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer))/divider -1) * nglob_edge_v)
-
- enddo ! iter_layer
-
- NSPEC2D_XI(iter_region) = tmp_sum_xi
- NSPEC2D_ETA(iter_region) = tmp_sum_eta
-
- NGLOB2DMAX_YMIN_YMAX(iter_region) = tmp_sum_nglob2D_xi
- NGLOB2DMAX_XMIN_XMAX(iter_region) = tmp_sum_nglob2D_eta
-
- if (iter_region == IREGION_INNER_CORE .and. INCLUDE_CENTRAL_CUBE) then
- NSPEC2D_XI(iter_region) = NSPEC2D_XI(iter_region) + &
- ((NEX_PER_PROC_XI / ratio_divide_central_cube)*(NEX_XI / ratio_divide_central_cube))
- NSPEC2D_ETA(iter_region) = NSPEC2D_ETA(iter_region) + &
- ((NEX_PER_PROC_ETA / ratio_divide_central_cube)*(NEX_XI / ratio_divide_central_cube))
-
- NGLOB2DMAX_YMIN_YMAX(iter_region) = NGLOB2DMAX_YMIN_YMAX(iter_region) + &
- (((NEX_PER_PROC_XI / ratio_divide_central_cube)*(NGLLX-1)+1)*((NEX_XI / ratio_divide_central_cube)*(NGLLX-1)+1))
-
- NGLOB2DMAX_XMIN_XMAX(iter_region) = NGLOB2DMAX_XMIN_XMAX(iter_region) + &
- (((NEX_PER_PROC_ETA / ratio_divide_central_cube)*(NGLLX-1)+1)*((NEX_XI / ratio_divide_central_cube)*(NGLLX-1)+1))
- endif
- enddo ! iter_region
-
- ! difference of number of surface elements along xi or eta for outer core if the superbrick is cut
- DIFF_NSPEC2D_XI(:,:) = 0
- DIFF_NSPEC2D_ETA(:,:) = 0
- if (CUT_SUPERBRICK_XI) then
- if (CUT_SUPERBRICK_ETA) then
- DIFF_NSPEC2D_XI(2,1) = 2
- DIFF_NSPEC2D_XI(1,2) = 2
- DIFF_NSPEC2D_XI(2,3) = 2
- DIFF_NSPEC2D_XI(1,4) = 2
-
- DIFF_NSPEC2D_ETA(2,1) = 1
- DIFF_NSPEC2D_ETA(2,2) = 1
- DIFF_NSPEC2D_ETA(1,3) = 1
- DIFF_NSPEC2D_ETA(1,4) = 1
- else
- DIFF_NSPEC2D_ETA(2,1) = 1
- DIFF_NSPEC2D_ETA(1,2) = 1
- endif
- else
- if (CUT_SUPERBRICK_ETA) then
- DIFF_NSPEC2D_XI(2,1) = 2
- DIFF_NSPEC2D_XI(1,2) = 2
- endif
- endif
- DIFF_NSPEC2D_XI(:,:) = DIFF_NSPEC2D_XI(:,:) * (NEX_PER_PROC_XI / ratio_divide_central_cube)
- DIFF_NSPEC2D_ETA(:,:) = DIFF_NSPEC2D_ETA(:,:) * (NEX_PER_PROC_ETA / ratio_divide_central_cube)
-
-! exact number of surface elements on the bottom and top boundaries
-
- ! in the crust and mantle
- NSPEC2D_TOP(IREGION_CRUST_MANTLE) = (NEX_XI/ratio_sampling_array(1))*(NEX_ETA/ratio_sampling_array(1))/NPROC
- NSPEC2D_BOTTOM(IREGION_CRUST_MANTLE) = (NEX_XI/ratio_sampling_array(10+layer_offset))*&
- (NEX_ETA/ratio_sampling_array(10+layer_offset))/NPROC
-
- ! in the outer core with mesh doubling
- if (ADD_4TH_DOUBLING) then
- NSPEC2D_TOP(IREGION_OUTER_CORE) = (NEX_XI/(ratio_divide_central_cube/4))*(NEX_ETA/(ratio_divide_central_cube/4))/NPROC
- NSPEC2D_BOTTOM(IREGION_OUTER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
- else
- NSPEC2D_TOP(IREGION_OUTER_CORE) = (NEX_XI/(ratio_divide_central_cube/2))*(NEX_ETA/(ratio_divide_central_cube/2))/NPROC
- NSPEC2D_BOTTOM(IREGION_OUTER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
- endif
-
- ! in the top of the inner core
- NSPEC2D_TOP(IREGION_INNER_CORE) = (NEX_XI/ratio_divide_central_cube)*(NEX_ETA/ratio_divide_central_cube)/NPROC
- NSPEC2D_BOTTOM(IREGION_INNER_CORE) = NSPEC2D_TOP(IREGION_INNER_CORE)
-
- ! maximum number of surface elements on vertical boundaries of the slices
- NSPEC2DMAX_XMIN_XMAX(:) = NSPEC2D_ETA(:)
- NSPEC2DMAX_XMIN_XMAX(IREGION_OUTER_CORE) = NSPEC2DMAX_XMIN_XMAX(IREGION_OUTER_CORE) + maxval(DIFF_NSPEC2D_ETA(:,:))
- NSPEC2DMAX_YMIN_YMAX(:) = NSPEC2D_XI(:)
- NSPEC2DMAX_YMIN_YMAX(IREGION_OUTER_CORE) = NSPEC2DMAX_YMIN_YMAX(IREGION_OUTER_CORE) + maxval(DIFF_NSPEC2D_XI(:,:))
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 3D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- ! exact number of spectral elements in each region
-
- do iter_region = IREGION_CRUST_MANTLE,IREGION_INNER_CORE
- if(iter_region == IREGION_CRUST_MANTLE) then
- ifirst_region = 1
- ilast_region = 10 + layer_offset
- else if(iter_region == IREGION_OUTER_CORE) then
- ifirst_region = 11 + layer_offset
- ilast_region = NUMBER_OF_MESH_LAYERS - 1
- else if(iter_region == IREGION_INNER_CORE) then
- ifirst_region = NUMBER_OF_MESH_LAYERS
- ilast_region = NUMBER_OF_MESH_LAYERS
- else
- stop 'incorrect region code detected'
- endif
- tmp_sum = 0;
- do iter_layer = ifirst_region, ilast_region
- if (this_region_has_a_doubling(iter_layer)) then
- if (ner(iter_layer) == 1) then
- nb_lay_sb = 1
- nspec_sb = NSPEC_SUPERBRICK_1L
- else
- nb_lay_sb = 2
- nspec_sb = NSPEC_DOUBLING_SUPERBRICK
- endif
- doubling = 1
- else
- doubling = 0
- nb_lay_sb = 0
- nspec_sb = 0
- endif
- tmp_sum = tmp_sum + (((NEX_XI / ratio_sampling_array(iter_layer)) * (NEX_ETA / ratio_sampling_array(iter_layer)) * &
- (ner(iter_layer) - doubling*nb_lay_sb)) + &
- doubling * ((NEX_XI / ratio_sampling_array(iter_layer)) * (NEX_ETA / ratio_sampling_array(iter_layer)) * &
- (nspec_sb/4))) / NPROC
- enddo
- NSPEC(iter_region) = tmp_sum
- enddo
-
- if(INCLUDE_CENTRAL_CUBE) NSPEC(IREGION_INNER_CORE) = NSPEC(IREGION_INNER_CORE) + &
- (NEX_PER_PROC_XI / ratio_divide_central_cube) * &
- (NEX_PER_PROC_ETA / ratio_divide_central_cube) * &
- (NEX_XI / ratio_divide_central_cube)
-
- if(minval(NSPEC) <= 0) stop 'negative NSPEC, there is a problem somewhere, try to recompile :) '
-
- end subroutine count_elements
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/count_points.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/count_points.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/count_points.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,242 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 count_points(NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube,&
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB,&
- nblocks_xi,nblocks_eta,ner,ratio_sampling_array,&
- this_region_has_a_doubling,&
- ifirst_region, ilast_region, iter_region, iter_layer, &
- doubling, padding, tmp_sum, &
- INCLUDE_CENTRAL_CUBE,NER_TOP_CENTRAL_CUBE_ICB,NEX_XI, &
- NUMBER_OF_MESH_LAYERS,layer_offset, &
- nb_lay_sb, nglob_vol, nglob_surf, nglob_edge, &
- CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA, &
- last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
- normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge)
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! calculation of number of points (NGLOB) below
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
- implicit none
-
- include "constants.h"
-
-! parameters read from parameter file
-
-! parameters to be computed based upon parameters above read from file
- integer NEX_PER_PROC_XI,NEX_PER_PROC_ETA,ratio_divide_central_cube
-
- integer, dimension(MAX_NUM_REGIONS) :: &
- NSPEC1D_RADIAL,NGLOB1D_RADIAL, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- NGLOB
-
- integer NER_TOP_CENTRAL_CUBE_ICB,NEX_XI
- integer nblocks_xi,nblocks_eta
-
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: ner,ratio_sampling_array
- logical, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: this_region_has_a_doubling
-
- integer :: ifirst_region, ilast_region, iter_region, iter_layer, doubling, padding, tmp_sum
- integer :: NUMBER_OF_MESH_LAYERS,layer_offset, &
- nb_lay_sb, nglob_vol, nglob_surf, nglob_edge
-
-! for the cut doublingbrick improvement
- logical :: CUT_SUPERBRICK_XI,CUT_SUPERBRICK_ETA,INCLUDE_CENTRAL_CUBE
- integer :: last_doubling_layer, cut_doubling, nglob_int_surf_xi, nglob_int_surf_eta,nglob_ext_surf,&
- normal_doubling, nglob_center_edge, nglob_corner_edge, nglob_border_edge
-
-
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 1D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! theoretical number of Gauss-Lobatto points in radial direction
- NGLOB1D_RADIAL(:) = NSPEC1D_RADIAL(:)*(NGLLZ-1)+1
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 2D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! 2-D addressing and buffers for summation between slices
-! we add one to number of points because of the flag after the last point
- NGLOB2DMAX_XMIN_XMAX(:) = NGLOB2DMAX_XMIN_XMAX(:) + 1
- NGLOB2DMAX_YMIN_YMAX(:) = NGLOB2DMAX_YMIN_YMAX(:) + 1
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! 3D case
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! exact number of global points in each region
-
-! initialize array
- NGLOB(:) = 0
-
-! in the inner core (no doubling region + eventually central cube)
- if(INCLUDE_CENTRAL_CUBE) then
- NGLOB(IREGION_INNER_CORE) = ((NEX_PER_PROC_XI/ratio_divide_central_cube) &
- *(NGLLX-1)+1)*((NEX_PER_PROC_ETA/ratio_divide_central_cube) &
- *(NGLLY-1)+1)*((NER_TOP_CENTRAL_CUBE_ICB + NEX_XI / ratio_divide_central_cube)*(NGLLZ-1)+1)
- else
- NGLOB(IREGION_INNER_CORE) = ((NEX_PER_PROC_XI/ratio_divide_central_cube) &
- *(NGLLX-1)+1)*((NEX_PER_PROC_ETA/ratio_divide_central_cube) &
- *(NGLLY-1)+1)*((NER_TOP_CENTRAL_CUBE_ICB)*(NGLLZ-1)+1)
- endif
-
-! in the crust-mantle and outercore
- do iter_region = IREGION_CRUST_MANTLE,IREGION_OUTER_CORE
- if(iter_region == IREGION_CRUST_MANTLE) then
- ifirst_region = 1
- ilast_region = 10 + layer_offset
- else if(iter_region == IREGION_OUTER_CORE) then
- ifirst_region = 11 + layer_offset
- ilast_region = NUMBER_OF_MESH_LAYERS - 1
- else
- stop 'incorrect region code detected'
- endif
- tmp_sum = 0;
- do iter_layer = ifirst_region, ilast_region
- nglob_int_surf_eta=0
- nglob_int_surf_xi=0
- nglob_ext_surf = 0
- nglob_center_edge = 0
- nglob_corner_edge = 0
- nglob_border_edge = 0
- if (this_region_has_a_doubling(iter_layer)) then
- if (iter_region == IREGION_OUTER_CORE .and. iter_layer == last_doubling_layer .and. &
- (CUT_SUPERBRICK_XI .or. CUT_SUPERBRICK_ETA)) then
- doubling = 1
- normal_doubling = 0
- cut_doubling = 1
- nb_lay_sb = 2
- nglob_edge = 0
- nglob_surf = 0
- nglob_vol = 8*NGLLX**3 - 12*NGLLX**2 + 6*NGLLX - 1
- nglob_int_surf_eta = 6*NGLLX**2 - 7*NGLLX + 2
- nglob_int_surf_xi = 5*NGLLX**2 - 5*NGLLX + 1
- nglob_ext_surf = 4*NGLLX**2-4*NGLLX+1
- nglob_center_edge = 4*(NGLLX-1)+1
- nglob_corner_edge = 2*(NGLLX-1)+1
- nglob_border_edge = 3*(NGLLX-1)+1
- else
- if (ner(iter_layer) == 1) then
- nb_lay_sb = 1
- nglob_vol = 28*NGLLX**3 - 62*NGLLX**2 + 47*NGLLX - 12
- nglob_surf = 6*NGLLX**2-8*NGLLX+3
- nglob_edge = NGLLX
- else
- nb_lay_sb = 2
- nglob_vol = 32*NGLLX**3 - 70*NGLLX**2 + 52*NGLLX - 13
- nglob_surf = 8*NGLLX**2-11*NGLLX+4
- nglob_edge = 2*NGLLX-1
- endif
- doubling = 1
- normal_doubling = 1
- cut_doubling = 0
- endif
- padding = -1
- else
- doubling = 0
- normal_doubling = 0
- cut_doubling = 0
- padding = 0
- nb_lay_sb = 0
- nglob_vol = 0
- nglob_surf = 0
- nglob_edge = 0
- endif
- if (iter_layer == ilast_region) padding = padding +1
- nblocks_xi = NEX_PER_PROC_XI / ratio_sampling_array(iter_layer)
- nblocks_eta = NEX_PER_PROC_ETA / ratio_sampling_array(iter_layer)
-
- tmp_sum = tmp_sum + &
- ((nblocks_xi)*(NGLLX-1)+1) * ((nblocks_eta)*(NGLLX-1)+1) * ((ner(iter_layer) - doubling*nb_lay_sb)*(NGLLX-1)+padding)+&
- normal_doubling * ((((nblocks_xi*nblocks_eta)/4)*nglob_vol) - &
- (((nblocks_eta/2-1)*nblocks_xi/2+(nblocks_xi/2-1)*nblocks_eta/2)*nglob_surf) + &
- ((nblocks_eta/2-1)*(nblocks_xi/2-1)*nglob_edge)) + &
- cut_doubling*(nglob_vol*(nblocks_xi*nblocks_eta) - &
- ( nblocks_eta*(int(nblocks_xi/2)*nglob_int_surf_xi + int((nblocks_xi-1)/2)*nglob_ext_surf) + &
- nblocks_xi*(int(nblocks_eta/2)*nglob_int_surf_eta + int((nblocks_eta-1)/2)*nglob_ext_surf)&
- ) + &
- ( int(nblocks_xi/2)*int(nblocks_eta/2)*nglob_center_edge + &
- int((nblocks_xi-1)/2)*int((nblocks_eta-1)/2)*nglob_corner_edge + &
- ((int(nblocks_eta/2)*int((nblocks_xi-1)/2))+(int((nblocks_eta-1)/2)*int(nblocks_xi/2)))*nglob_border_edge&
- ))
- enddo
- NGLOB(iter_region) = tmp_sum
- enddo
-
-!!! example :
-!!! nblocks_xi/2=5
-!!! ____________________________________
-!!! I I I I I I
-!!! I I I I I I
-!!! I I I I I I
-!!! nblocks_eta/2=3 I______+______+______+______+______I
-!!! I I I I I I
-!!! I I I I I I
-!!! I I I I I I
-!!! I______+______+______+______+______I
-!!! I I I I I I
-!!! I I I I I I
-!!! I I I I I I
-!!! I______I______I______I______I______I
-!!!
-!!! NGLOB for this doubling layer = 3*5*Volume - ((3-1)*5+(5-1)*3)*Surface + (3-1)*(5-1)*Edge
-!!!
-!!! 32*NGLLX**3 - 70*NGLLX**2 + 52*NGLLX - 13 -> nb GLL points in a superbrick (Volume)
-!!! 8*NGLLX**2-11*NGLLX+4 -> nb GLL points on a superbrick side (Surface)
-!!! 2*NGLLX-1 -> nb GLL points on a corner edge of a superbrick (Edge)
-
-!!! for the one layer superbrick :
-!!! NGLOB = 28.NGLL^3 - 62.NGLL^2 + 47.NGLL - 12 (Volume)
-!!! NGLOB = 6.NGLL^2 - 8.NGLL + 3 (Surface)
-!!! NGLOB = NGLL (Edge)
-!!!
-!!! those results were obtained by using the script UTILS/doubling_brick/count_nglob_analytical.pl
-!!! with an opendx file of the superbrick's geometry
-
-!!! for the basic doubling bricks (two layers)
-!!! NGLOB = 8.NGLL^3 - 12.NGLL^2 + 6.NGLL - 1 (VOLUME)
-!!! NGLOB = 5.NGLL^2 - 5.NGLL + 1 (SURFACE 1)
-!!! NGLOB = 6.NGLL^2 - 7.NGLL + 2 (SURFACE 2)
-
- end subroutine count_points
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/define_all_layers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/define_all_layers.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/define_all_layers.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,949 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 define_all_layers(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,&
- RMIDDLE_CRUST,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER,&
- ONE_CRUST, &
- ner,ratio_sampling_array,&
- NUMBER_OF_MESH_LAYERS,layer_offset,last_doubling_layer, &
- r_bottom,r_top,this_region_has_a_doubling,&
- ielem,elem_doubling_mantle,elem_doubling_middle_outer_core,&
- elem_doubling_bottom_outer_core,&
- DEPTH_SECOND_DOUBLING_REAL,DEPTH_THIRD_DOUBLING_REAL, &
- DEPTH_FOURTH_DOUBLING_REAL,distance,distance_min,zval,&
- doubling_index,rmins,rmaxs)
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!
-!!!!!! definition of general mesh parameters below
-!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- implicit none
-
- include "constants.h"
-
- ! parameters read from parameter file
- integer 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
-
- ! radii
- double precision RMIDDLE_CRUST,R220,R400,R600,R670,R771,RTOPDDOUBLEPRIME,RCMB,RICB, &
- R_CENTRAL_CUBE,RMOHO_FICTITIOUS_IN_MESHER,R80_FICTITIOUS_IN_MESHER
-
- logical ONE_CRUST
-
- ! layers
- integer :: NUMBER_OF_MESH_LAYERS,layer_offset,last_doubling_layer
- 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
-
- ! doubling elements
- integer :: ielem,elem_doubling_mantle,elem_doubling_middle_outer_core,elem_doubling_bottom_outer_core
- double precision :: DEPTH_SECOND_DOUBLING_REAL,DEPTH_THIRD_DOUBLING_REAL, &
- DEPTH_FOURTH_DOUBLING_REAL,distance,distance_min,zval
-
- integer, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: doubling_index
- double precision, dimension(MAX_NUMBER_OF_MESH_LAYERS) :: rmins,rmaxs
-
-
-! find element below top of which we should implement the second doubling in the mantle
-! locate element closest to optimal value
- distance_min = HUGEVAL
- do ielem = 2,NER_TOPDDOUBLEPRIME_771
- zval = RTOPDDOUBLEPRIME + ielem * (R771 - RTOPDDOUBLEPRIME) / dble(NER_TOPDDOUBLEPRIME_771)
- distance = abs(zval - (R_EARTH - DEPTH_SECOND_DOUBLING_OPTIMAL))
- if(distance < distance_min) then
- elem_doubling_mantle = ielem
- distance_min = distance
- DEPTH_SECOND_DOUBLING_REAL = R_EARTH - zval
- endif
- enddo
-
-! find element below top of which we should implement the third doubling in the middle of the outer core
-! locate element closest to optimal value
- distance_min = HUGEVAL
-! start at element number 4 because we need at least two elements below for the fourth doubling
-! implemented at the bottom of the outer core
- do ielem = 4,NER_OUTER_CORE
- zval = RICB + ielem * (RCMB - RICB) / dble(NER_OUTER_CORE)
- distance = abs(zval - (R_EARTH - DEPTH_THIRD_DOUBLING_OPTIMAL))
- if(distance < distance_min) then
- elem_doubling_middle_outer_core = ielem
- distance_min = distance
- DEPTH_THIRD_DOUBLING_REAL = R_EARTH - zval
- endif
- enddo
-
- if (ADD_4TH_DOUBLING) then
-! find element below top of which we should implement the fourth doubling in the middle of the outer core
-! locate element closest to optimal value
- distance_min = HUGEVAL
-! end two elements before the top because we need at least two elements above for the third doubling
-! implemented in the middle of the outer core
- do ielem = 2,NER_OUTER_CORE-2
- zval = RICB + ielem * (RCMB - RICB) / dble(NER_OUTER_CORE)
- distance = abs(zval - (R_EARTH - DEPTH_FOURTH_DOUBLING_OPTIMAL))
- if(distance < distance_min) then
- elem_doubling_bottom_outer_core = ielem
- distance_min = distance
- DEPTH_FOURTH_DOUBLING_REAL = R_EARTH - zval
- endif
- enddo
-! make sure that the two doublings in the outer core are found in the right order
- if(elem_doubling_bottom_outer_core >= elem_doubling_middle_outer_core) &
- stop 'error in location of the two doublings in the outer core'
- endif
-
- ratio_sampling_array(15) = 0
-
-! define all the layers of the mesh
- if (.not. ADD_4TH_DOUBLING) then
-
- ! default case:
- ! no fourth doubling at the bottom of the outer core
-
- if (SUPPRESS_CRUSTAL_MESH) then
-
- ! suppress the crustal layers
- ! will be replaced by an extension of the mantle: R_EARTH is not modified,
- ! but no more crustal doubling
-
- NUMBER_OF_MESH_LAYERS = 14
- layer_offset = 1
-
- ! now only one region
- ner( 1) = NER_CRUST + NER_80_MOHO
- ner( 2) = 0
- ner( 3) = 0
-
- ner( 4) = NER_220_80
- ner( 5) = NER_400_220
- ner( 6) = NER_600_400
- ner( 7) = NER_670_600
- ner( 8) = NER_771_670
- ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner(10) = elem_doubling_mantle
- ner(11) = NER_CMB_TOPDDOUBLEPRIME
- ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(13) = elem_doubling_middle_outer_core
- ner(14) = NER_TOP_CENTRAL_CUBE_ICB
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1:9) = 1
- ratio_sampling_array(10:12) = 2
- ratio_sampling_array(13:14) = 4
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1:3) = IFLAG_CRUST !!!!! IFLAG_80_MOHO
- doubling_index(4) = IFLAG_220_80
- doubling_index(5:7) = IFLAG_670_220
- doubling_index(8:11) = IFLAG_MANTLE_NORMAL
- doubling_index(12:13) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(14) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(10) = .true.
- this_region_has_a_doubling(13) = .true.
- last_doubling_layer = 13
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- r_top(1) = R_EARTH
- r_bottom(1) = R80_FICTITIOUS_IN_MESHER
-
- r_top(2) = RMIDDLE_CRUST !!!! now fictitious
- r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
-
- r_top(3) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
- r_bottom(3) = R80_FICTITIOUS_IN_MESHER !!!! now fictitious
-
- r_top(4) = R80_FICTITIOUS_IN_MESHER
- r_bottom(4) = R220
-
- r_top(5) = R220
- r_bottom(5) = R400
-
- r_top(6) = R400
- r_bottom(6) = R600
-
- r_top(7) = R600
- r_bottom(7) = R670
-
- r_top(8) = R670
- r_bottom(8) = R771
-
- r_top(9) = R771
- r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(10) = RTOPDDOUBLEPRIME
-
- r_top(11) = RTOPDDOUBLEPRIME
- r_bottom(11) = RCMB
-
- r_top(12) = RCMB
- r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(13) = RICB
-
- r_top(14) = RICB
- r_bottom(14) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = R80_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(2) = RMIDDLE_CRUST / R_EARTH !!!! now fictitious
- rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
-
- rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
- rmins(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
-
- rmaxs(4) = R80_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(4) = R220 / R_EARTH
-
- rmaxs(5) = R220 / R_EARTH
- rmins(5) = R400 / R_EARTH
-
- rmaxs(6) = R400 / R_EARTH
- rmins(6) = R600 / R_EARTH
-
- rmaxs(7) = R600 / R_EARTH
- rmins(7) = R670 / R_EARTH
-
- rmaxs(8) = R670 / R_EARTH
- rmins(8) = R771 / R_EARTH
-
- rmaxs(9:10) = R771 / R_EARTH
- rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(11) = RCMB / R_EARTH
-
- rmaxs(12:13) = RCMB / R_EARTH
- rmins(12:13) = RICB / R_EARTH
-
- rmaxs(14) = RICB / R_EARTH
- rmins(14) = R_CENTRAL_CUBE / R_EARTH
-
- else if (ONE_CRUST) then
-
- ! 1D models:
- ! in order to increase stability and therefore to allow cheaper
- ! simulations (larger time step), 1D models can be run with just one average crustal
- ! layer instead of two.
-
- NUMBER_OF_MESH_LAYERS = 13
- layer_offset = 0
-
- ner( 1) = NER_CRUST
- ner( 2) = NER_80_MOHO
- ner( 3) = NER_220_80
- ner( 4) = NER_400_220
- ner( 5) = NER_600_400
- ner( 6) = NER_670_600
- ner( 7) = NER_771_670
- ner( 8) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner( 9) = elem_doubling_mantle
- ner(10) = NER_CMB_TOPDDOUBLEPRIME
- ner(11) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(12) = elem_doubling_middle_outer_core
- ner(13) = NER_TOP_CENTRAL_CUBE_ICB
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1) = 1
- ratio_sampling_array(2:8) = 2
- ratio_sampling_array(9:11) = 4
- ratio_sampling_array(12:13) = 8
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1) = IFLAG_CRUST
- doubling_index(2) = IFLAG_80_MOHO
- doubling_index(3) = IFLAG_220_80
- doubling_index(4:6) = IFLAG_670_220
- doubling_index(7:10) = IFLAG_MANTLE_NORMAL
- doubling_index(11:12) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(13) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(2) = .true.
- this_region_has_a_doubling(9) = .true.
- this_region_has_a_doubling(12) = .true.
- last_doubling_layer = 12
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- !!!!!!!!!!! DK DK UGLY: beware, is there a bug when 3D crust crosses anisotropy in the mantle?
- !!!!!!!!!!! DK DK UGLY: i.e. if there is no thick crust there, some elements above the Moho
- !!!!!!!!!!! DK DK UGLY: should be anisotropic but anisotropy is currently only
- !!!!!!!!!!! DK DK UGLY: stored between d220 and MOHO to save memory? Clarify this one day.
- !!!!!!!!!!! DK DK UGLY: The Moho stretching and squishing that Jeroen added to V4.0
- !!!!!!!!!!! DK DK UGLY: should partly deal with this problem.
-
- r_top(1) = R_EARTH
- r_bottom(1) = RMOHO_FICTITIOUS_IN_MESHER
-
- r_top(2) = RMOHO_FICTITIOUS_IN_MESHER
- r_bottom(2) = R80_FICTITIOUS_IN_MESHER
-
- r_top(3) = R80_FICTITIOUS_IN_MESHER
- r_bottom(3) = R220
-
- r_top(4) = R220
- r_bottom(4) = R400
-
- r_top(5) = R400
- r_bottom(5) = R600
-
- r_top(6) = R600
- r_bottom(6) = R670
-
- r_top(7) = R670
- r_bottom(7) = R771
-
- r_top(8) = R771
- r_bottom(8) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(9) = RTOPDDOUBLEPRIME
-
- r_top(10) = RTOPDDOUBLEPRIME
- r_bottom(10) = RCMB
-
- r_top(11) = RCMB
- r_bottom(11) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(12) = RICB
-
- r_top(13) = RICB
- r_bottom(13) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(2) = R80_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(3) = R220 / R_EARTH
-
- rmaxs(4) = R220 / R_EARTH
- rmins(4) = R400 / R_EARTH
-
- rmaxs(5) = R400 / R_EARTH
- rmins(5) = R600 / R_EARTH
-
- rmaxs(6) = R600 / R_EARTH
- rmins(6) = R670 / R_EARTH
-
- rmaxs(7) = R670 / R_EARTH
- rmins(7) = R771 / R_EARTH
-
- rmaxs(8:9) = R771 / R_EARTH
- rmins(8:9) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(10) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(10) = RCMB / R_EARTH
-
- rmaxs(11:12) = RCMB / R_EARTH
- rmins(11:12) = RICB / R_EARTH
-
- rmaxs(13) = RICB / R_EARTH
- rmins(13) = R_CENTRAL_CUBE / R_EARTH
-
- else
-
- ! default case for 3D models:
- ! contains the crustal layers
- ! doubling at the base of the crust
-
- NUMBER_OF_MESH_LAYERS = 14
- layer_offset = 1
- if ((RMIDDLE_CRUST-RMOHO_FICTITIOUS_IN_MESHER)<(R_EARTH-RMIDDLE_CRUST)) then
- ner( 1) = ceiling (NER_CRUST / 2.d0)
- ner( 2) = floor (NER_CRUST / 2.d0)
- else
- ner( 1) = floor (NER_CRUST / 2.d0) ! regional mesh: ner(1) = 1 since NER_CRUST=3
- ner( 2) = ceiling (NER_CRUST / 2.d0) ! ner(2) = 2
- endif
- ner( 3) = NER_80_MOHO
- ner( 4) = NER_220_80
- ner( 5) = NER_400_220
- ner( 6) = NER_600_400
- ner( 7) = NER_670_600
- ner( 8) = NER_771_670
- ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner(10) = elem_doubling_mantle
- ner(11) = NER_CMB_TOPDDOUBLEPRIME
- ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(13) = elem_doubling_middle_outer_core
- ner(14) = NER_TOP_CENTRAL_CUBE_ICB
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1:2) = 1
- ratio_sampling_array(3:9) = 2
- ratio_sampling_array(10:12) = 4
- ratio_sampling_array(13:14) = 8
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1:2) = IFLAG_CRUST
- doubling_index(3) = IFLAG_80_MOHO
- doubling_index(4) = IFLAG_220_80
- doubling_index(5:7) = IFLAG_670_220
- doubling_index(8:11) = IFLAG_MANTLE_NORMAL
- doubling_index(12:13) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(14) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(3) = .true.
- this_region_has_a_doubling(10) = .true.
- this_region_has_a_doubling(13) = .true.
- this_region_has_a_doubling(14) = .false.
- last_doubling_layer = 13
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- r_top(1) = R_EARTH
- r_bottom(1) = RMIDDLE_CRUST
-
- r_top(2) = RMIDDLE_CRUST
- r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER
-
- r_top(3) = RMOHO_FICTITIOUS_IN_MESHER
- r_bottom(3) = R80_FICTITIOUS_IN_MESHER
-
- r_top(4) = R80_FICTITIOUS_IN_MESHER
- r_bottom(4) = R220
-
- r_top(5) = R220
- r_bottom(5) = R400
-
- r_top(6) = R400
- r_bottom(6) = R600
-
- r_top(7) = R600
- r_bottom(7) = R670
-
- r_top(8) = R670
- r_bottom(8) = R771
-
- r_top(9) = R771
- r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(10) = RTOPDDOUBLEPRIME
-
- r_top(11) = RTOPDDOUBLEPRIME
- r_bottom(11) = RCMB
-
- r_top(12) = RCMB
- r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(13) = RICB
-
- r_top(14) = RICB
- r_bottom(14) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = RMIDDLE_CRUST / R_EARTH
-
- rmaxs(2) = RMIDDLE_CRUST / R_EARTH
- rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(4) = R80_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(4) = R220 / R_EARTH
-
- rmaxs(5) = R220 / R_EARTH
- rmins(5) = R400 / R_EARTH
-
- rmaxs(6) = R400 / R_EARTH
- rmins(6) = R600 / R_EARTH
-
- rmaxs(7) = R600 / R_EARTH
- rmins(7) = R670 / R_EARTH
-
- rmaxs(8) = R670 / R_EARTH
- rmins(8) = R771 / R_EARTH
-
- rmaxs(9:10) = R771 / R_EARTH
- rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(11) = RCMB / R_EARTH
-
- rmaxs(12:13) = RCMB / R_EARTH
- rmins(12:13) = RICB / R_EARTH
-
- rmaxs(14) = RICB / R_EARTH
- rmins(14) = R_CENTRAL_CUBE / R_EARTH
-
- endif
- else
-
- ! 4th doubling case:
- ! includes fourth doubling at the bottom of the outer core
-
- if (SUPPRESS_CRUSTAL_MESH) then
-
- ! suppress the crustal layers
- ! will be replaced by an extension of the mantle: R_EARTH is not modified,
- ! but no more crustal doubling
-
- NUMBER_OF_MESH_LAYERS = 15
- layer_offset = 1
-
- ! now only one region
- ner( 1) = NER_CRUST + NER_80_MOHO
- ner( 2) = 0
- ner( 3) = 0
-
- ner( 4) = NER_220_80
- ner( 5) = NER_400_220
- ner( 6) = NER_600_400
- ner( 7) = NER_670_600
- ner( 8) = NER_771_670
- ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner(10) = elem_doubling_mantle
- ner(11) = NER_CMB_TOPDDOUBLEPRIME
- ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(13) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
- ner(14) = elem_doubling_bottom_outer_core
- ner(15) = NER_TOP_CENTRAL_CUBE_ICB
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1:9) = 1
- ratio_sampling_array(10:12) = 2
- ratio_sampling_array(13) = 4
- ratio_sampling_array(14:15) = 8
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1:3) = IFLAG_CRUST !!!!! IFLAG_80_MOHO
- doubling_index(4) = IFLAG_220_80
- doubling_index(5:7) = IFLAG_670_220
- doubling_index(8:11) = IFLAG_MANTLE_NORMAL
- doubling_index(12:14) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(15) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(10) = .true.
- this_region_has_a_doubling(13) = .true.
- this_region_has_a_doubling(14) = .true.
- last_doubling_layer = 14
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- r_top(1) = R_EARTH
- r_bottom(1) = R80_FICTITIOUS_IN_MESHER
-
- r_top(2) = RMIDDLE_CRUST !!!! now fictitious
- r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
-
- r_top(3) = RMOHO_FICTITIOUS_IN_MESHER !!!! now fictitious
- r_bottom(3) = R80_FICTITIOUS_IN_MESHER !!!! now fictitious
-
- r_top(4) = R80_FICTITIOUS_IN_MESHER
- r_bottom(4) = R220
-
- r_top(5) = R220
- r_bottom(5) = R400
-
- r_top(6) = R400
- r_bottom(6) = R600
-
- r_top(7) = R600
- r_bottom(7) = R670
-
- r_top(8) = R670
- r_bottom(8) = R771
-
- r_top(9) = R771
- r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(10) = RTOPDDOUBLEPRIME
-
- r_top(11) = RTOPDDOUBLEPRIME
- r_bottom(11) = RCMB
-
- r_top(12) = RCMB
- r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
-
- r_top(14) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
- r_bottom(14) = RICB
-
- r_top(15) = RICB
- r_bottom(15) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = R80_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(2) = RMIDDLE_CRUST / R_EARTH !!!! now fictitious
- rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
-
- rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
- rmins(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH !!!! now fictitious
-
- rmaxs(4) = R80_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(4) = R220 / R_EARTH
-
- rmaxs(5) = R220 / R_EARTH
- rmins(5) = R400 / R_EARTH
-
- rmaxs(6) = R400 / R_EARTH
- rmins(6) = R600 / R_EARTH
-
- rmaxs(7) = R600 / R_EARTH
- rmins(7) = R670 / R_EARTH
-
- rmaxs(8) = R670 / R_EARTH
- rmins(8) = R771 / R_EARTH
-
- rmaxs(9:10) = R771 / R_EARTH
- rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(11) = RCMB / R_EARTH
-
- rmaxs(12:14) = RCMB / R_EARTH
- rmins(12:14) = RICB / R_EARTH
-
- rmaxs(15) = RICB / R_EARTH
- rmins(15) = R_CENTRAL_CUBE / R_EARTH
-
- else if (ONE_CRUST) then
-
- ! 1D models:
- ! in order to increase stability and therefore to allow cheaper
- ! simulations (larger time step), 1D models can be run with just one average crustal
- ! layer instead of two.
-
- NUMBER_OF_MESH_LAYERS = 14
- layer_offset = 0
-
- ner( 1) = NER_CRUST
- ner( 2) = NER_80_MOHO
- ner( 3) = NER_220_80
- ner( 4) = NER_400_220
- ner( 5) = NER_600_400
- ner( 6) = NER_670_600
- ner( 7) = NER_771_670
- ner( 8) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner( 9) = elem_doubling_mantle
- ner(10) = NER_CMB_TOPDDOUBLEPRIME
- ner(11) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(12) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
- ner(13) = elem_doubling_bottom_outer_core
- ner(14) = NER_TOP_CENTRAL_CUBE_ICB
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1) = 1
- ratio_sampling_array(2:8) = 2
- ratio_sampling_array(9:11) = 4
- ratio_sampling_array(12) = 8
- ratio_sampling_array(13:14) = 16
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1) = IFLAG_CRUST
- doubling_index(2) = IFLAG_80_MOHO
- doubling_index(3) = IFLAG_220_80
- doubling_index(4:6) = IFLAG_670_220
- doubling_index(7:10) = IFLAG_MANTLE_NORMAL
- doubling_index(11:13) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(14) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(2) = .true.
- this_region_has_a_doubling(9) = .true.
- this_region_has_a_doubling(12) = .true.
- this_region_has_a_doubling(13) = .true.
- last_doubling_layer = 13
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- !!!!!!!!!!! DK DK UGLY: beware, is there a bug when 3D crust crosses anisotropy in the mantle?
- !!!!!!!!!!! DK DK UGLY: i.e. if there is no thick crust there, some elements above the Moho
- !!!!!!!!!!! DK DK UGLY: should be anisotropic but anisotropy is currently only
- !!!!!!!!!!! DK DK UGLY: stored between d220 and MOHO to save memory? Clarify this one day.
- !!!!!!!!!!! DK DK UGLY: The Moho stretching and squishing that Jeroen added to V4.0
- !!!!!!!!!!! DK DK UGLY: should partly deal with this problem.
-
- r_top(1) = R_EARTH
- r_bottom(1) = RMOHO_FICTITIOUS_IN_MESHER
-
- r_top(2) = RMOHO_FICTITIOUS_IN_MESHER
- r_bottom(2) = R80_FICTITIOUS_IN_MESHER
-
- r_top(3) = R80_FICTITIOUS_IN_MESHER
- r_bottom(3) = R220
-
- r_top(4) = R220
- r_bottom(4) = R400
-
- r_top(5) = R400
- r_bottom(5) = R600
-
- r_top(6) = R600
- r_bottom(6) = R670
-
- r_top(7) = R670
- r_bottom(7) = R771
-
- r_top(8) = R771
- r_bottom(8) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(9) = RTOPDDOUBLEPRIME
-
- r_top(10) = RTOPDDOUBLEPRIME
- r_bottom(10) = RCMB
-
- r_top(11) = RCMB
- r_bottom(11) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(12) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
-
- r_top(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
- r_bottom(13) = RICB
-
- r_top(14) = RICB
- r_bottom(14) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(2) = R80_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(3) = R220 / R_EARTH
-
- rmaxs(4) = R220 / R_EARTH
- rmins(4) = R400 / R_EARTH
-
- rmaxs(5) = R400 / R_EARTH
- rmins(5) = R600 / R_EARTH
-
- rmaxs(6) = R600 / R_EARTH
- rmins(6) = R670 / R_EARTH
-
- rmaxs(7) = R670 / R_EARTH
- rmins(7) = R771 / R_EARTH
-
- rmaxs(8:9) = R771 / R_EARTH
- rmins(8:9) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(10) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(10) = RCMB / R_EARTH
-
- rmaxs(11:13) = RCMB / R_EARTH
- rmins(11:13) = RICB / R_EARTH
-
- rmaxs(14) = RICB / R_EARTH
- rmins(14) = R_CENTRAL_CUBE / R_EARTH
-
- else
-
- ! for 3D models:
- ! contains the crustal layers
- ! doubling at the base of the crust
-
- NUMBER_OF_MESH_LAYERS = 15
- layer_offset = 1
- if ((RMIDDLE_CRUST-RMOHO_FICTITIOUS_IN_MESHER)<(R_EARTH-RMIDDLE_CRUST)) then
- ner( 1) = ceiling (NER_CRUST / 2.d0)
- ner( 2) = floor (NER_CRUST / 2.d0)
- else
- ner( 1) = floor (NER_CRUST / 2.d0)
- ner( 2) = ceiling (NER_CRUST / 2.d0)
- endif
- ner( 3) = NER_80_MOHO
- ner( 4) = NER_220_80
- ner( 5) = NER_400_220
- ner( 6) = NER_600_400
- ner( 7) = NER_670_600
- ner( 8) = NER_771_670
- ner( 9) = NER_TOPDDOUBLEPRIME_771 - elem_doubling_mantle
- ner(10) = elem_doubling_mantle
- ner(11) = NER_CMB_TOPDDOUBLEPRIME
- ner(12) = NER_OUTER_CORE - elem_doubling_middle_outer_core
- ner(13) = elem_doubling_middle_outer_core - elem_doubling_bottom_outer_core
- ner(14) = elem_doubling_bottom_outer_core
- ner(15) = NER_TOP_CENTRAL_CUBE_ICB
-
- ! value of the doubling ratio in each radial region of the mesh
- ratio_sampling_array(1:2) = 1
- ratio_sampling_array(3:9) = 2
- ratio_sampling_array(10:12) = 4
- ratio_sampling_array(13) = 8
- ratio_sampling_array(14:15) = 16
-
- ! value of the doubling index flag in each radial region of the mesh
- doubling_index(1:2) = IFLAG_CRUST
- doubling_index(3) = IFLAG_80_MOHO
- doubling_index(4) = IFLAG_220_80
- doubling_index(5:7) = IFLAG_670_220
- doubling_index(8:11) = IFLAG_MANTLE_NORMAL
- doubling_index(12:14) = IFLAG_OUTER_CORE_NORMAL
- doubling_index(15) = IFLAG_INNER_CORE_NORMAL
-
- ! define the three regions in which we implement a mesh doubling at the top of that region
- this_region_has_a_doubling(:) = .false.
- this_region_has_a_doubling(3) = .true.
- this_region_has_a_doubling(10) = .true.
- this_region_has_a_doubling(13) = .true.
- this_region_has_a_doubling(14) = .true.
- last_doubling_layer = 14
-
- ! define the top and bottom radii of all the regions of the mesh in the radial direction
- ! the first region is the crust at the surface of the Earth
- ! the last region is in the inner core near the center of the Earth
-
- r_top(1) = R_EARTH
- r_bottom(1) = RMIDDLE_CRUST
-
- r_top(2) = RMIDDLE_CRUST
- r_bottom(2) = RMOHO_FICTITIOUS_IN_MESHER
-
- r_top(3) = RMOHO_FICTITIOUS_IN_MESHER
- r_bottom(3) = R80_FICTITIOUS_IN_MESHER
-
- r_top(4) = R80_FICTITIOUS_IN_MESHER
- r_bottom(4) = R220
-
- r_top(5) = R220
- r_bottom(5) = R400
-
- r_top(6) = R400
- r_bottom(6) = R600
-
- r_top(7) = R600
- r_bottom(7) = R670
-
- r_top(8) = R670
- r_bottom(8) = R771
-
- r_top(9) = R771
- r_bottom(9) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
-
- r_top(10) = R_EARTH - DEPTH_SECOND_DOUBLING_REAL
- r_bottom(10) = RTOPDDOUBLEPRIME
-
- r_top(11) = RTOPDDOUBLEPRIME
- r_bottom(11) = RCMB
-
- r_top(12) = RCMB
- r_bottom(12) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
-
- r_top(13) = R_EARTH - DEPTH_THIRD_DOUBLING_REAL
- r_bottom(13) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
-
- r_top(14) = R_EARTH - DEPTH_FOURTH_DOUBLING_REAL
- r_bottom(14) = RICB
-
- r_top(15) = RICB
- r_bottom(15) = R_CENTRAL_CUBE
-
- ! new definition of rmins & rmaxs
- rmaxs(1) = ONE
- rmins(1) = RMIDDLE_CRUST / R_EARTH
-
- rmaxs(2) = RMIDDLE_CRUST / R_EARTH
- rmins(2) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(3) = RMOHO_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(3) = R80_FICTITIOUS_IN_MESHER / R_EARTH
-
- rmaxs(4) = R80_FICTITIOUS_IN_MESHER / R_EARTH
- rmins(4) = R220 / R_EARTH
-
- rmaxs(5) = R220 / R_EARTH
- rmins(5) = R400 / R_EARTH
-
- rmaxs(6) = R400 / R_EARTH
- rmins(6) = R600 / R_EARTH
-
- rmaxs(7) = R600 / R_EARTH
- rmins(7) = R670 / R_EARTH
-
- rmaxs(8) = R670 / R_EARTH
- rmins(8) = R771 / R_EARTH
-
- rmaxs(9:10) = R771 / R_EARTH
- rmins(9:10) = RTOPDDOUBLEPRIME / R_EARTH
-
- rmaxs(11) = RTOPDDOUBLEPRIME / R_EARTH
- rmins(11) = RCMB / R_EARTH
-
- rmaxs(12:14) = RCMB / R_EARTH
- rmins(12:14) = RICB / R_EARTH
-
- rmaxs(15) = RICB / R_EARTH
- rmins(15) = R_CENTRAL_CUBE / R_EARTH
- endif
- endif
-
-
- end subroutine define_all_layers
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/get_timestep_and_layers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/get_timestep_and_layers.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/get_timestep_and_layers.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,448 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 get_timestep_and_layers(DT,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,R_CENTRAL_CUBE, &
- NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL,THREE_D_MODEL, &
- ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES,&
- ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL, &
- ANISOTROPIC_INNER_CORE)
-
-
- implicit none
-
- include "constants.h"
-
- ! parameters read from parameter file
- integer MIN_ATTENUATION_PERIOD,MAX_ATTENUATION_PERIOD
-
- integer 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
-
- integer NEX_MAX,NCHUNKS,REFERENCE_1D_MODEL,THREE_D_MODEL
-
- double precision DT
- double precision R_CENTRAL_CUBE
- double precision ANGULAR_WIDTH_XI_IN_DEGREES,ANGULAR_WIDTH_ETA_IN_DEGREES
-
- logical ONE_CRUST,HONOR_1D_SPHERICAL_MOHO,CASE_3D,CRUSTAL,ANISOTROPIC_INNER_CORE
-
- ! local variables
- integer multiplication_factor
-
- !----
- !---- case prem_onecrust by default
- !----
- if (SUPPRESS_CRUSTAL_MESH) then
- multiplication_factor=2
- else
- multiplication_factor=1
- endif
-
- ! element width = 0.5625000 degrees = 62.54715 km
- if(NEX_MAX*multiplication_factor <= 160) then
- ! time step
- DT = 0.252d0
-
- ! attenuation period range
- MIN_ATTENUATION_PERIOD = 30
- MAX_ATTENUATION_PERIOD = 1500
-
- ! number of element layers in each mesh region
- NER_CRUST = 1
- NER_80_MOHO = 1
- NER_220_80 = 2
- NER_400_220 = 2
- NER_600_400 = 2
- NER_670_600 = 1
- NER_771_670 = 1
- NER_TOPDDOUBLEPRIME_771 = 15
- NER_CMB_TOPDDOUBLEPRIME = 1
- NER_OUTER_CORE = 16
- NER_TOP_CENTRAL_CUBE_ICB = 2
-
- ! radius of central cube
- R_CENTRAL_CUBE = 950000.d0
-
- ! element width = 0.3515625 degrees = 39.09196 km
- else if(NEX_MAX*multiplication_factor <= 256) then
- DT = 0.225d0
-
- MIN_ATTENUATION_PERIOD = 20
- MAX_ATTENUATION_PERIOD = 1000
-
- NER_CRUST = 1
- NER_80_MOHO = 1
- NER_220_80 = 2
- NER_400_220 = 3
- NER_600_400 = 3
- NER_670_600 = 1
- NER_771_670 = 1
- NER_TOPDDOUBLEPRIME_771 = 22
- NER_CMB_TOPDDOUBLEPRIME = 2
- NER_OUTER_CORE = 24
- NER_TOP_CENTRAL_CUBE_ICB = 3
- R_CENTRAL_CUBE = 965000.d0
-
- ! element width = 0.2812500 degrees = 31.27357 km
- else if(NEX_MAX*multiplication_factor <= 320) then
- DT = 0.16d0
-
- MIN_ATTENUATION_PERIOD = 15
- MAX_ATTENUATION_PERIOD = 750
-
- NER_CRUST = 1
- NER_80_MOHO = 1
- NER_220_80 = 3
- NER_400_220 = 4
- NER_600_400 = 4
- NER_670_600 = 1
- NER_771_670 = 2
- NER_TOPDDOUBLEPRIME_771 = 29
- NER_CMB_TOPDDOUBLEPRIME = 2
- NER_OUTER_CORE = 32
- NER_TOP_CENTRAL_CUBE_ICB = 4
- R_CENTRAL_CUBE = 940000.d0
-
- ! element width = 0.1875000 degrees = 20.84905 km
- else if(NEX_MAX*multiplication_factor <= 480) then
- DT = 0.11d0
-
- MIN_ATTENUATION_PERIOD = 10
- MAX_ATTENUATION_PERIOD = 500
-
- NER_CRUST = 1
- NER_80_MOHO = 2
- NER_220_80 = 4
- NER_400_220 = 5
- NER_600_400 = 6
- NER_670_600 = 2
- NER_771_670 = 2
- NER_TOPDDOUBLEPRIME_771 = 44
- NER_CMB_TOPDDOUBLEPRIME = 3
- NER_OUTER_CORE = 48
- NER_TOP_CENTRAL_CUBE_ICB = 5
- R_CENTRAL_CUBE = 988000.d0
-
- ! element width = 0.1757812 degrees = 19.54598 km
- else if(NEX_MAX*multiplication_factor <= 512) then
- DT = 0.1125d0
-
- MIN_ATTENUATION_PERIOD = 9
- MAX_ATTENUATION_PERIOD = 500
-
- NER_CRUST = 1
- NER_80_MOHO = 2
- NER_220_80 = 4
- NER_400_220 = 6
- NER_600_400 = 6
- NER_670_600 = 2
- NER_771_670 = 3
- NER_TOPDDOUBLEPRIME_771 = 47
- NER_CMB_TOPDDOUBLEPRIME = 3
- NER_OUTER_CORE = 51
- NER_TOP_CENTRAL_CUBE_ICB = 5
- R_CENTRAL_CUBE = 1010000.d0
-
- ! element width = 0.1406250 degrees = 15.63679 km
- else if(NEX_MAX*multiplication_factor <= 640) then
- DT = 0.09d0
-
- MIN_ATTENUATION_PERIOD = 8
- MAX_ATTENUATION_PERIOD = 400
-
- NER_CRUST = 2
- NER_80_MOHO = 3
- NER_220_80 = 5
- NER_400_220 = 7
- NER_600_400 = 8
- NER_670_600 = 3
- NER_771_670 = 3
- NER_TOPDDOUBLEPRIME_771 = 59
- NER_CMB_TOPDDOUBLEPRIME = 4
- NER_OUTER_CORE = 64
- NER_TOP_CENTRAL_CUBE_ICB = 6
- R_CENTRAL_CUBE = 1020000.d0
-
- ! element width = 0.1041667 degrees = 11.58280 km
- else if(NEX_MAX*multiplication_factor <= 864) then
- DT = 0.0667d0
-
- MIN_ATTENUATION_PERIOD = 6
- MAX_ATTENUATION_PERIOD = 300
-
- NER_CRUST = 2
- NER_80_MOHO = 4
- NER_220_80 = 6
- NER_400_220 = 10
- NER_600_400 = 10
- NER_670_600 = 3
- NER_771_670 = 4
- NER_TOPDDOUBLEPRIME_771 = 79
- NER_CMB_TOPDDOUBLEPRIME = 5
- NER_OUTER_CORE = 86
- NER_TOP_CENTRAL_CUBE_ICB = 9
- R_CENTRAL_CUBE = 990000.d0
-
- ! element width = 7.8125000E-02 degrees = 8.687103 km
- else if(NEX_MAX*multiplication_factor <= 1152) then
- DT = 0.05d0
-
- MIN_ATTENUATION_PERIOD = 4
- MAX_ATTENUATION_PERIOD = 200
-
- NER_CRUST = 3
- NER_80_MOHO = 6
- NER_220_80 = 8
- NER_400_220 = 13
- NER_600_400 = 13
- NER_670_600 = 4
- NER_771_670 = 6
- NER_TOPDDOUBLEPRIME_771 = 106
- NER_CMB_TOPDDOUBLEPRIME = 7
- NER_OUTER_CORE = 116
- NER_TOP_CENTRAL_CUBE_ICB = 12
- R_CENTRAL_CUBE = 985000.d0
-
- ! element width = 7.2115384E-02 degrees = 8.018865 km
- else if(NEX_MAX*multiplication_factor <= 1248) then
- DT = 0.0462d0
-
- MIN_ATTENUATION_PERIOD = 4
- MAX_ATTENUATION_PERIOD = 200
-
- NER_CRUST = 3
- NER_80_MOHO = 6
- NER_220_80 = 9
- NER_400_220 = 14
- NER_600_400 = 14
- NER_670_600 = 5
- NER_771_670 = 6
- NER_TOPDDOUBLEPRIME_771 = 114
- NER_CMB_TOPDDOUBLEPRIME = 8
- NER_OUTER_CORE = 124
- NER_TOP_CENTRAL_CUBE_ICB = 13
- R_CENTRAL_CUBE = 985000.d0
-
- else
-
- ! scale with respect to 1248 if above that limit
- DT = 0.0462d0 * 1248.d0 / (2.d0*NEX_MAX)
-
- MIN_ATTENUATION_PERIOD = 4
- MAX_ATTENUATION_PERIOD = 200
-
- NER_CRUST = nint(3 * 2.d0*NEX_MAX / 1248.d0)
- NER_80_MOHO = nint(6 * 2.d0*NEX_MAX / 1248.d0)
- NER_220_80 = nint(9 * 2.d0*NEX_MAX / 1248.d0)
- NER_400_220 = nint(14 * 2.d0*NEX_MAX / 1248.d0)
- NER_600_400 = nint(14 * 2.d0*NEX_MAX / 1248.d0)
- NER_670_600 = nint(5 * 2.d0*NEX_MAX / 1248.d0)
- NER_771_670 = nint(6 * 2.d0*NEX_MAX / 1248.d0)
- NER_TOPDDOUBLEPRIME_771 = nint(114 * 2.d0*NEX_MAX / 1248.d0)
- NER_CMB_TOPDDOUBLEPRIME = nint(8 * 2.d0*NEX_MAX / 1248.d0)
- NER_OUTER_CORE = nint(124 * 2.d0*NEX_MAX / 1248.d0)
- NER_TOP_CENTRAL_CUBE_ICB = nint(13 * 2.d0*NEX_MAX / 1248.d0)
- R_CENTRAL_CUBE = 985000.d0
-
- !! removed this limit else
- !! removed this limit stop 'problem with this value of NEX_MAX'
- endif
-
- !> Hejun
- ! avoids elongated elements below the 670-discontinuity,
- ! since for model REFERENCE_MODEL_1DREF,
- ! the 670-discontinuity is moved up to 650 km depth.
- if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1DREF) then
- NER_771_670 = NER_771_670 + 1
- endif
-
- !----
- !---- change some values in the case of regular PREM with two crustal layers or of 3D models
- !----
-
- ! case of regular PREM with two crustal layers: change the time step for small meshes
- ! because of a different size of elements in the radial direction in the crust
- if (HONOR_1D_SPHERICAL_MOHO) then
- ! 1D models honor 1D spherical moho
- if (.not. ONE_CRUST) then
- ! case 1D + two crustal layers
- if (NER_CRUST < 2 ) NER_CRUST = 2
- ! makes time step smaller
- if(NEX_MAX*multiplication_factor <= 160) then
- DT = 0.20d0
- else if(NEX_MAX*multiplication_factor <= 256) then
- DT = 0.20d0
- endif
- endif
- else
- ! 3D models: must have two element layers for crust
- if (NER_CRUST < 2 ) NER_CRUST = 2
- ! makes time step smaller
- if(NEX_MAX*multiplication_factor <= 80) then
- DT = 0.125d0
- else if(NEX_MAX*multiplication_factor <= 160) then
- DT = 0.15d0
- else if(NEX_MAX*multiplication_factor <= 256) then
- DT = 0.17d0
- else if(NEX_MAX*multiplication_factor <= 320) then
- DT = 0.155d0
- endif
- endif
-
- if( .not. ATTENUATION_RANGE_PREDEFINED ) then
- call auto_attenuation_periods(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
- MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD)
- endif
-
- if(ANGULAR_WIDTH_XI_IN_DEGREES < 90.0d0 .or. &
- ANGULAR_WIDTH_ETA_IN_DEGREES < 90.0d0 .or. &
- NEX_MAX > 1248) then
-
- call auto_ner(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
- 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, &
- R_CENTRAL_CUBE, CASE_3D, CRUSTAL, &
- HONOR_1D_SPHERICAL_MOHO, REFERENCE_1D_MODEL)
-
- call auto_attenuation_periods(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, &
- MIN_ATTENUATION_PERIOD, MAX_ATTENUATION_PERIOD)
-
- call auto_time_stepping(ANGULAR_WIDTH_XI_IN_DEGREES, NEX_MAX, DT)
-
- !! DK DK suppressed because this routine should not write anything to the screen
- ! write(*,*)'##############################################################'
- ! write(*,*)
- ! write(*,*)' Auto Radial Meshing Code '
- ! write(*,*)' Consult read_compute_parameters.f90 and auto_ner.f90 '
- ! write(*,*)' This should only be invoked for chunks less than 90 degrees'
- ! write(*,*)' and for chunks greater than 1248 elements wide'
- ! write(*,*)
- ! write(*,*)'CHUNK WIDTH: ', ANGULAR_WIDTH_XI_IN_DEGREES
- ! write(*,*)'NEX: ', NEX_MAX
- ! write(*,*)'NER_CRUST: ', NER_CRUST
- ! write(*,*)'NER_80_MOHO: ', NER_80_MOHO
- ! write(*,*)'NER_220_80: ', NER_220_80
- ! write(*,*)'NER_400_220: ', NER_400_220
- ! write(*,*)'NER_600_400: ', NER_600_400
- ! write(*,*)'NER_670_600: ', NER_670_600
- ! write(*,*)'NER_771_670: ', NER_771_670
- ! write(*,*)'NER_TOPDDOUBLEPRIME_771: ', NER_TOPDDOUBLEPRIME_771
- ! write(*,*)'NER_CMB_TOPDDOUBLEPRIME: ', NER_CMB_TOPDDOUBLEPRIME
- ! write(*,*)'NER_OUTER_CORE: ', NER_OUTER_CORE
- ! write(*,*)'NER_TOP_CENTRAL_CUBE_ICB: ', NER_TOP_CENTRAL_CUBE_ICB
- ! write(*,*)'R_CENTRAL_CUBE: ', R_CENTRAL_CUBE
- ! write(*,*)'multiplication factor: ', multiplication_factor
- ! write(*,*)
- ! write(*,*)'DT: ',DT
- ! write(*,*)'MIN_ATTENUATION_PERIOD ',MIN_ATTENUATION_PERIOD
- ! write(*,*)'MAX_ATTENUATION_PERIOD ',MAX_ATTENUATION_PERIOD
- ! write(*,*)
- ! write(*,*)'##############################################################'
-
- if (HONOR_1D_SPHERICAL_MOHO) then
- if (.not. ONE_CRUST) then
- ! case 1D + two crustal layers
- if (NER_CRUST < 2 ) NER_CRUST = 2
- endif
- else
- ! case 3D
- if (NER_CRUST < 2 ) NER_CRUST = 2
- endif
-
- endif
-
-!---
-!
-! ADD YOUR MODEL HERE
-!
-!---
-
-
- ! time step reductions are based on empirical values (..somehow)
-
- ! following models need special attention, at least for global simulations:
- if( NCHUNKS == 6 ) then
- ! makes time step smaller for this ref model, otherwise becomes unstable in fluid
- if (REFERENCE_1D_MODEL == REFERENCE_MODEL_IASP91) &
- DT = DT*(1.d0 - 0.3d0)
-
- ! using inner core anisotropy, simulations might become unstable in solid
- if( ANISOTROPIC_INNER_CORE ) then
- ! DT = DT*(1.d0 - 0.1d0) not working yet...
- stop 'anisotropic inner core - unstable feature, uncomment this line in get_timestep_and_layers.f90'
- endif
- endif
-
- ! following models need special attention, regardless of number of chunks:
- ! it makes the time step smaller for this ref model, otherwise becomes unstable in fluid
- if (REFERENCE_1D_MODEL == REFERENCE_MODEL_1066A) &
- DT = DT*(1.d0 - 0.8d0) ! *0.20d0
-
-
- if( ITYPE_CRUSTAL_MODEL == ICRUST_CRUSTMAPS ) &
- DT = DT*(1.d0 - 0.3d0)
-
- ! decreases time step as otherwise the solution might become unstable for rougher/unsmoothed models
- if( .false. ) then
- if( THREE_D_MODEL == THREE_D_MODEL_PPM ) DT = DT * (1.d0 - 0.2d0)
- endif
-
- ! takes a 5% safety margin on the maximum stable time step
- ! which was obtained by trial and error
- DT = DT * (1.d0 - 0.05d0)
-
- ! adapts number of element layers in crust and time step for regional simulations
- if( REGIONAL_MOHO_MESH ) then
- ! hard coded number of crustal element layers and time step
-
- ! checks
- if( NCHUNKS > 1 ) stop 'regional moho mesh: NCHUNKS error in rcp_set_timestep_and_layers'
- if( HONOR_1D_SPHERICAL_MOHO ) return
-
- ! original values
- !print*,'NER:',NER_CRUST
- !print*,'DT:',DT
-
- ! enforce 3 element layers
- NER_CRUST = 3
-
- ! increased stability, empirical
- DT = DT*(1.d0 + 0.5d0)
-
- if( REGIONAL_MOHO_MESH_EUROPE ) DT = 0.17 ! europe
- if( REGIONAL_MOHO_MESH_ASIA ) DT = 0.15 ! asia & middle east
-
- endif
-
- end subroutine get_timestep_and_layers
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/write_VTK_file.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/write_VTK_file.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/shared/write_VTK_file.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,608 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 write_VTK_data_points(nglob, &
- xstore_dummy,ystore_dummy,zstore_dummy, &
- points_globalindices,num_points_globalindices, &
- prname_file)
-
-! external mesh routine for saving vtk files for points locations
-
- implicit none
-
- include "constants.h"
-
- integer :: nglob
-
- ! global coordinates
- real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
-
- ! gll data values array
- integer :: num_points_globalindices
- integer, dimension(num_points_globalindices) :: points_globalindices
-
- ! file name
- character(len=150) prname_file
-
- integer :: i,iglob
-
- ! write source and receiver VTK files for Paraview
- !debug
- !write(IMAIN,*) ' vtk file: '
- !write(IMAIN,*) ' ',prname_file(1:len_trim(prname_file))//'.vtk'
-
- open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
- write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
- write(IOVTK,'(a)') 'material model VTK file'
- write(IOVTK,'(a)') 'ASCII'
- write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
- write(IOVTK, '(a,i12,a)') 'POINTS ', num_points_globalindices, ' float'
- do i=1,num_points_globalindices
- iglob = points_globalindices(i)
- if( iglob <= 0 .or. iglob > nglob ) then
- print*,'error: '//prname_file(1:len_trim(prname_file))//'.vtk'
- print*,'error global index: ',iglob,i
- close(IOVTK)
- stop 'error vtk points file'
- endif
-
- write(IOVTK,'(3e18.6)') xstore_dummy(iglob),ystore_dummy(iglob),zstore_dummy(iglob)
- enddo
- write(IOVTK,*) ""
-
- close(IOVTK)
-
- end subroutine write_VTK_data_points
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine write_VTK_glob_points(nglob, &
- xstore_dummy,ystore_dummy,zstore_dummy, &
- glob_values, &
- prname_file)
-
-! external mesh routine for saving vtk files for points locations
-
- implicit none
-
- include "constants.h"
-
- integer :: nglob
-
- ! global coordinates
- real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
-
- ! gll data values array
- real(kind=CUSTOM_REAL), dimension(nglob) :: glob_values
-
- ! file name
- character(len=150) prname_file
-
- integer :: iglob
-
- ! write source and receiver VTK files for Paraview
- !debug
- !write(IMAIN,*) ' vtk file: '
- !write(IMAIN,*) ' ',prname_file(1:len_trim(prname_file))//'.vtk'
-
- open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
- write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
- write(IOVTK,'(a)') 'material model VTK file'
- write(IOVTK,'(a)') 'ASCII'
- write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
- write(IOVTK, '(a,i12,a)') 'POINTS ', nglob, ' float'
- do iglob=1,nglob
- write(IOVTK,*) xstore_dummy(iglob),ystore_dummy(iglob),zstore_dummy(iglob)
- enddo
- write(IOVTK,*) ""
-
- ! writes out gll-data (velocity) for each element point
- write(IOVTK,'(a,i12)') "POINT_DATA ",nglob
- write(IOVTK,'(a)') "SCALARS glob_data float"
- write(IOVTK,'(a)') "LOOKUP_TABLE default"
- do iglob=1,nglob
- write(IOVTK,*) glob_values(iglob)
- enddo
- write(IOVTK,*) ""
-
- close(IOVTK)
-
- end subroutine write_VTK_glob_points
-
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine write_VTK_data_elem_l(nspec,nglob, &
- xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
- elem_flag,prname_file)
-
-! routine for saving vtk file holding logical flag on each spectral element
-
- implicit none
-
- include "constants.h"
-
- integer :: nspec,nglob
-
- ! global coordinates
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
-
- ! element flag array
- logical, dimension(nspec) :: elem_flag
- integer :: ispec,i
-
- ! file name
- character(len=150) prname_file
-
- ! write source and receiver VTK files for Paraview
- !debug
- !write(IMAIN,*) ' vtk file: '
- !write(IMAIN,*) ' ',prname_file(1:len_trim(prname_file))//'.vtk'
-
- open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
- write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
- write(IOVTK,'(a)') 'material model VTK file'
- write(IOVTK,'(a)') 'ASCII'
- write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
- write(IOVTK, '(a,i12,a)') 'POINTS ', nglob, ' float'
- do i=1,nglob
- write(IOVTK,'(3e18.6)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
- enddo
- write(IOVTK,*) ""
-
- ! note: indices for vtk start at 0
- write(IOVTK,'(a,i12,i12)') "CELLS ",nspec,nspec*9
- do ispec=1,nspec
- write(IOVTK,'(9i12)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
- ibool(1,1,NGLLZ,ispec)-1,ibool(NGLLX,1,NGLLZ,ispec)-1,ibool(NGLLX,NGLLY,NGLLZ,ispec)-1,ibool(1,NGLLY,NGLLZ,ispec)-1
- enddo
- write(IOVTK,*) ""
-
- ! type: hexahedrons
- write(IOVTK,'(a,i12)') "CELL_TYPES ",nspec
- write(IOVTK,*) (12,ispec=1,nspec)
- write(IOVTK,*) ""
-
- write(IOVTK,'(a,i12)') "CELL_DATA ",nspec
- write(IOVTK,'(a)') "SCALARS elem_flag integer"
- write(IOVTK,'(a)') "LOOKUP_TABLE default"
- do ispec = 1,nspec
- if( elem_flag(ispec) .eqv. .true. ) then
- write(IOVTK,*) 1
- else
- write(IOVTK,*) 0
- endif
- enddo
- write(IOVTK,*) ""
- close(IOVTK)
-
-
- end subroutine write_VTK_data_elem_l
-
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-
- subroutine write_VTK_data_elem_i(nspec,nglob, &
- xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
- elem_flag,prname_file)
-
-
-! routine for saving vtk file holding integer value on each spectral element
-
- implicit none
-
- include "constants.h"
-
- integer :: nspec,nglob
-
- ! global coordinates
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
-
- ! element flag array
- integer, dimension(nspec) :: elem_flag
- integer :: ispec,i
-
- ! file name
- character(len=150) prname_file
-
- ! write source and receiver VTK files for Paraview
- !debug
- !write(IMAIN,*) ' vtk file: '
- !write(IMAIN,*) ' ',prname_file(1:len_trim(prname_file))//'.vtk'
-
- open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
- write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
- write(IOVTK,'(a)') 'material model VTK file'
- write(IOVTK,'(a)') 'ASCII'
- write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
- write(IOVTK, '(a,i12,a)') 'POINTS ', nglob, ' float'
- do i=1,nglob
- write(IOVTK,'(3e18.6)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
- enddo
- write(IOVTK,*) ""
-
- ! note: indices for vtk start at 0
- write(IOVTK,'(a,i12,i12)') "CELLS ",nspec,nspec*9
- do ispec=1,nspec
- write(IOVTK,'(9i12)') 8,ibool(1,1,1,ispec)-1,ibool(NGLLX,1,1,ispec)-1,ibool(NGLLX,NGLLY,1,ispec)-1,ibool(1,NGLLY,1,ispec)-1,&
- ibool(1,1,NGLLZ,ispec)-1,ibool(NGLLX,1,NGLLZ,ispec)-1,ibool(NGLLX,NGLLY,NGLLZ,ispec)-1,ibool(1,NGLLY,NGLLZ,ispec)-1
- enddo
- write(IOVTK,*) ""
-
- ! type: hexahedrons
- write(IOVTK,'(a,i12)') "CELL_TYPES ",nspec
- write(IOVTK,*) (12,ispec=1,nspec)
- write(IOVTK,*) ""
-
- write(IOVTK,'(a,i12)') "CELL_DATA ",nspec
- write(IOVTK,'(a)') "SCALARS elem_val integer"
- write(IOVTK,'(a)') "LOOKUP_TABLE default"
- do ispec = 1,nspec
- write(IOVTK,*) elem_flag(ispec)
- enddo
- write(IOVTK,*) ""
- close(IOVTK)
-
- end subroutine write_VTK_data_elem_i
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-! external mesh routine for saving vtk files for custom_real values on global points
-
- subroutine write_VTK_data_cr(idoubling,nspec,nglob, &
- xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
- glob_data,prname_file)
-
-! outputs single file for each process
-
- implicit none
-
- include "constants.h"
-
- integer :: nspec,nglob
-
- integer, dimension(nspec):: idoubling
-
- ! global coordinates
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
-
- ! global data values array
- real(kind=CUSTOM_REAL), dimension(NDIM,nglob) :: glob_data
-
- ! file name
- character(len=256) prname_file
-
- ! local parameters
- integer :: ispec,i
- real(kind=CUSTOM_REAL) :: rval,thetaval,phival,xval,yval,zval
-
- ! write source and receiver VTK files for Paraview
- open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
- write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
- write(IOVTK,'(a)') 'material model VTK file'
- write(IOVTK,'(a)') 'ASCII'
- write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
- write(IOVTK, '(a,i12,a)') 'POINTS ', nglob, ' float'
- do i=1,nglob
-
- !x,y,z store have been converted to r theta phi already, need to revert back for xyz output
- rval = xstore_dummy(i)
- thetaval = ystore_dummy(i)
- phival = zstore_dummy(i)
- call rthetaphi_2_xyz(xval,yval,zval,rval,thetaval,phival)
-
- !write(IOVTK,'(3e18.6)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
- write(IOVTK,'(3e18.6)') xval,yval,zval
- enddo
- write(IOVTK,*) ""
-
- ! defines cell on coarse corner points
- ! note: indices for vtk start at 0
- write(IOVTK,'(a,i12,i12)') "CELLS ",nspec,nspec*9
- do ispec=1,nspec
-
- ! specific to inner core elements
- ! exclude fictitious elements in central cube
- if(idoubling(ispec) /= IFLAG_IN_FICTITIOUS_CUBE) then
- ! valid cell
- write(IOVTK,'(9i12)') 8,ibool(1,1,1,ispec)-1, &
- ibool(NGLLX,1,1,ispec)-1, &
- ibool(NGLLX,NGLLY,1,ispec)-1, &
- ibool(1,NGLLY,1,ispec)-1, &
- ibool(1,1,NGLLZ,ispec)-1, &
- ibool(NGLLX,1,NGLLZ,ispec)-1, &
- ibool(NGLLX,NGLLY,NGLLZ,ispec)-1, &
- ibool(1,NGLLY,NGLLZ,ispec)-1
- else
- ! fictitious elements in central cube
- ! maps cell onto a randomly chosen point
- write(IOVTK,'(9i12)') 8,ibool(1,1,1,1)-1, &
- ibool(1,1,1,1)-1, &
- ibool(1,1,1,1)-1, &
- ibool(1,1,1,1)-1, &
- ibool(1,1,1,1)-1, &
- ibool(1,1,1,1)-1, &
- ibool(1,1,1,1)-1, &
- ibool(1,1,1,1)-1
- endif
-
- enddo
- write(IOVTK,*) ""
-
- ! type: hexahedrons
- write(IOVTK,'(a,i12)') "CELL_TYPES ",nspec
- write(IOVTK,*) (12,ispec=1,nspec)
- write(IOVTK,*) ""
-
- ! x components
- write(IOVTK,'(a,i12)') "POINT_DATA ",nglob
- write(IOVTK,'(a)') "SCALARS x_comp float"
- write(IOVTK,'(a)') "LOOKUP_TABLE default"
- do i = 1,nglob
- write(IOVTK,*) glob_data(1,i)
- enddo
- ! y components
- write(IOVTK,'(a)') "SCALARS y_comp float"
- write(IOVTK,'(a)') "LOOKUP_TABLE default"
- do i = 1,nglob
- write(IOVTK,*) glob_data(2,i)
- enddo
- ! z components
- write(IOVTK,'(a)') "SCALARS z_comp float"
- write(IOVTK,'(a)') "LOOKUP_TABLE default"
- do i = 1,nglob
- write(IOVTK,*) glob_data(3,i)
- enddo
- ! norm
- write(IOVTK,'(a)') "SCALARS norm float"
- write(IOVTK,'(a)') "LOOKUP_TABLE default"
- do i = 1,nglob
- write(IOVTK,*) sqrt( glob_data(1,i)*glob_data(1,i) &
- + glob_data(2,i)*glob_data(2,i) &
- + glob_data(3,i)*glob_data(3,i))
- enddo
- write(IOVTK,*) ""
-
- close(IOVTK)
-
-
- end subroutine write_VTK_data_cr
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
-! external mesh routine for saving vtk files for custom_real values on global points
-
- subroutine write_VTK_data_cr_all(myrank,NPROCTOT,idoubling, &
- nspec,nglob, &
- xstore_dummy,ystore_dummy,zstore_dummy,ibool, &
- glob_data,prname_file)
-
-! outputs single file for all processes
-
- implicit none
-
- include "constants.h"
-
- include 'mpif.h'
- include "precision.h"
-
- integer :: myrank,NPROCTOT
-
- integer ::nspec,nglob
-
- integer, dimension(nspec):: idoubling
-
- ! global coordinates
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_dummy,ystore_dummy,zstore_dummy
-
- ! global data values array
- real(kind=CUSTOM_REAL), dimension(NDIM,nglob) :: glob_data
-
- ! file name
- character(len=256) prname_file
-
- ! local parameters
- integer :: ispec,i,iproc,ier
- real(kind=CUSTOM_REAL) :: rval,thetaval,phival,xval,yval,zval
-
- real(kind=CUSTOM_REAL), dimension(:,:),allocatable :: &
- store_val_x_all,store_val_y_all,store_val_z_all, &
- store_val_ux_all,store_val_uy_all,store_val_uz_all
- integer, dimension(:,:,:,:,:),allocatable :: ibool_all
- integer, dimension(:,:),allocatable :: idoubling_all
-
- ! master collect arrays
- if( myrank == 0 ) then
- allocate(store_val_x_all(nglob,0:NPROCTOT-1), &
- store_val_y_all(nglob,0:NPROCTOT-1), &
- store_val_z_all(nglob,0:NPROCTOT-1), &
- store_val_ux_all(nglob,0:NPROCTOT-1), &
- store_val_uy_all(nglob,0:NPROCTOT-1), &
- store_val_uz_all(nglob,0:NPROCTOT-1), &
- idoubling_all(nspec,0:NPROCTOT-1), &
- ibool_all(NGLLX,NGLLY,NGLLZ,nspec,0:NPROCTOT-1),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating stores')
- else
- ! dummy arrays
- allocate(store_val_x_all(1,1), &
- store_val_y_all(1,1), &
- store_val_z_all(1,1), &
- store_val_ux_all(1,1), &
- store_val_uy_all(1,1), &
- store_val_uz_all(1,1), &
- idoubling_all(1,1), &
- ibool_all(1,1,1,1,1),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating dummy stores')
- endif
-
- ! gather info on master proc
- call MPI_GATHER(xstore_dummy,nglob,CUSTOM_MPI_TYPE,store_val_x_all,nglob,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(ystore_dummy,nglob,CUSTOM_MPI_TYPE,store_val_y_all,nglob,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(zstore_dummy,nglob,CUSTOM_MPI_TYPE,store_val_z_all,nglob,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
-
- call MPI_GATHER(glob_data(1,:),nglob,CUSTOM_MPI_TYPE,store_val_ux_all,nglob,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(glob_data(2,:),nglob,CUSTOM_MPI_TYPE,store_val_uy_all,nglob,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(glob_data(3,:),nglob,CUSTOM_MPI_TYPE,store_val_uz_all,nglob,CUSTOM_MPI_TYPE,0,MPI_COMM_WORLD,ier)
-
- call MPI_GATHER(ibool,NGLLX*NGLLY*NGLLZ*nspec,MPI_INTEGER,ibool_all, &
- NGLLX*NGLLY*NGLLZ*nspec,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_GATHER(idoubling,nspec,MPI_INTEGER,idoubling_all,nspec,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
-
- if( myrank == 0 ) then
-
- ! write source and receiver VTK files for Paraview
- open(IOVTK,file=prname_file(1:len_trim(prname_file))//'.vtk',status='unknown')
- write(IOVTK,'(a)') '# vtk DataFile Version 3.1'
- write(IOVTK,'(a)') 'material model VTK file'
- write(IOVTK,'(a)') 'ASCII'
- write(IOVTK,'(a)') 'DATASET UNSTRUCTURED_GRID'
- write(IOVTK, '(a,i12,a)') 'POINTS ', nglob*NPROCTOT, ' float'
- do iproc=0, NPROCTOT-1
- do i=1,nglob
-
- !x,y,z store have been converted to r theta phi already, need to revert back for xyz output
- rval = store_val_x_all(i,iproc)
- thetaval = store_val_y_all(i,iproc)
- phival = store_val_z_all(i,iproc)
- call rthetaphi_2_xyz(xval,yval,zval,rval,thetaval,phival)
-
- !write(IOVTK,'(3e18.6)') xstore_dummy(i),ystore_dummy(i),zstore_dummy(i)
- write(IOVTK,'(3e18.6)') xval,yval,zval
- enddo
- enddo
- write(IOVTK,*) ""
-
- ! defines cell on coarse corner points
- ! note: indices for vtk start at 0
- write(IOVTK,'(a,i12,i12)') "CELLS ",nspec*NPROCTOT,nspec*NPROCTOT*9
- do iproc=0, NPROCTOT-1
- do ispec=1,nspec
-
- ! note: central cube elements are only shared and used in CHUNK_AB and CHUNK_AB_ANTIPODE
- ! all other chunks ignore those elements
-
- ! specific to inner core elements
- ! exclude fictitious elements in central cube
- if(idoubling_all(ispec,iproc) /= IFLAG_IN_FICTITIOUS_CUBE) then
- ! valid cell
- ! cell corner ids
- write(IOVTK,'(9i12)') 8,ibool_all(1,1,1,ispec,iproc)-1+iproc*nglob, &
- ibool_all(NGLLX,1,1,ispec,iproc)-1+iproc*nglob, &
- ibool_all(NGLLX,NGLLY,1,ispec,iproc)-1+iproc*nglob, &
- ibool_all(1,NGLLY,1,ispec,iproc)-1+iproc*nglob, &
- ibool_all(1,1,NGLLZ,ispec,iproc)-1+iproc*nglob, &
- ibool_all(NGLLX,1,NGLLZ,ispec,iproc)-1+iproc*nglob, &
- ibool_all(NGLLX,NGLLY,NGLLZ,ispec,iproc)-1+iproc*nglob, &
- ibool_all(1,NGLLY,NGLLZ,ispec,iproc)-1+iproc*nglob
- else
- ! fictitious elements in central cube
- ! maps cell onto a randomly chosen point
- write(IOVTK,'(9i12)') 8,ibool_all(1,1,1,1,iproc)-1, &
- ibool_all(1,1,1,1,iproc)-1, &
- ibool_all(1,1,1,1,iproc)-1, &
- ibool_all(1,1,1,1,iproc)-1, &
- ibool_all(1,1,1,1,iproc)-1, &
- ibool_all(1,1,1,1,iproc)-1, &
- ibool_all(1,1,1,1,iproc)-1, &
- ibool_all(1,1,1,1,iproc)-1
- endif
-
- enddo
- enddo
- write(IOVTK,*) ""
-
- ! type: hexahedrons
- write(IOVTK,'(a,i12)') "CELL_TYPES ",nspec*NPROCTOT
- write(IOVTK,*) (12,ispec=1,nspec*NPROCTOT)
- write(IOVTK,*) ""
-
- ! x components
- write(IOVTK,'(a,i12)') "POINT_DATA ",nglob*NPROCTOT
- write(IOVTK,'(a)') "SCALARS x_comp float"
- write(IOVTK,'(a)') "LOOKUP_TABLE default"
- do iproc=0, NPROCTOT-1
- do i = 1,nglob
- write(IOVTK,*) store_val_ux_all(i,iproc)
- enddo
- enddo
- ! y components
- write(IOVTK,'(a)') "SCALARS y_comp float"
- write(IOVTK,'(a)') "LOOKUP_TABLE default"
- do iproc=0, NPROCTOT-1
- do i = 1,nglob
- write(IOVTK,*) store_val_uy_all(i,iproc)
- enddo
- enddo
- ! z components
- write(IOVTK,'(a)') "SCALARS z_comp float"
- write(IOVTK,'(a)') "LOOKUP_TABLE default"
- do iproc=0, NPROCTOT-1
- do i = 1,nglob
- write(IOVTK,*) store_val_uz_all(i,iproc)
- enddo
- enddo
- ! norm
- write(IOVTK,'(a)') "SCALARS norm float"
- write(IOVTK,'(a)') "LOOKUP_TABLE default"
- do iproc=0, NPROCTOT-1
- do i = 1,nglob
- write(IOVTK,*) sqrt( store_val_ux_all(i,iproc)**2 &
- + store_val_uy_all(i,iproc)**2 &
- + store_val_uz_all(i,iproc)**2 )
- enddo
- enddo
- write(IOVTK,*) ""
-
- close(IOVTK)
-
- endif
-
- deallocate(store_val_x_all,store_val_y_all,store_val_z_all, &
- store_val_ux_all,store_val_uy_all,store_val_uz_all, &
- ibool_all)
-
- end subroutine write_VTK_data_cr_all
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_crust_mantle.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,959 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 compute_forces_crust_mantle(NSPEC,NGLOB,NSPEC_ATT, &
- deltat, &
- displ_crust_mantle, &
- veloc_crust_mantle, &
- accel_crust_mantle, &
- phase_is_inner, &
- R_xx,R_yy,R_xy,R_xz,R_yz, &
- epsilondev_xx,epsilondev_yy,epsilondev_xy, &
- epsilondev_xz,epsilondev_yz, &
- epsilon_trace_over_3, &
- alphaval,betaval,gammaval, &
- factor_common,vx,vy,vz,vnspec)
-
- use constants_solver
-
- use specfem_par,only: &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- minus_gravity_table,density_table,minus_deriv_gravity_table
-
- use specfem_par_crustmantle,only: &
- xstore => xstore_crust_mantle,ystore => ystore_crust_mantle,zstore => zstore_crust_mantle, &
- xix => xix_crust_mantle,xiy => xiy_crust_mantle,xiz => xiz_crust_mantle, &
- etax => etax_crust_mantle,etay => etay_crust_mantle,etaz => etaz_crust_mantle, &
- gammax => gammax_crust_mantle,gammay => gammay_crust_mantle,gammaz => gammaz_crust_mantle, &
- kappavstore => kappavstore_crust_mantle,kappahstore => kappahstore_crust_mantle, &
- muvstore => muvstore_crust_mantle,muhstore => muhstore_crust_mantle, &
- eta_anisostore => eta_anisostore_crust_mantle, &
- c11store => c11store_crust_mantle,c12store => c12store_crust_mantle,c13store => c13store_crust_mantle, &
- c14store => c14store_crust_mantle,c15store => c15store_crust_mantle,c16store => c16store_crust_mantle, &
- c22store => c22store_crust_mantle,c23store => c23store_crust_mantle,c24store => c24store_crust_mantle, &
- c25store => c25store_crust_mantle,c26store => c26store_crust_mantle,c33store => c33store_crust_mantle, &
- c34store => c34store_crust_mantle,c35store => c35store_crust_mantle,c36store => c36store_crust_mantle, &
- c44store => c44store_crust_mantle,c45store => c45store_crust_mantle,c46store => c46store_crust_mantle, &
- c55store => c55store_crust_mantle,c56store => c56store_crust_mantle,c66store => c66store_crust_mantle, &
- ibool => ibool_crust_mantle, &
- ispec_is_tiso => ispec_is_tiso_crust_mantle, &
- one_minus_sum_beta => one_minus_sum_beta_crust_mantle, &
- phase_ispec_inner => phase_ispec_inner_crust_mantle, &
- nspec_outer => nspec_outer_crust_mantle, &
- nspec_inner => nspec_inner_crust_mantle
-
- implicit none
-
- integer :: NSPEC,NGLOB,NSPEC_ATT
-
- ! time step
- real(kind=CUSTOM_REAL) :: deltat
-
- ! displacement, velocity and acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB) :: displ_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB) :: veloc_crust_mantle
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB) :: accel_crust_mantle
-
- ! variable sized array variables
- integer :: vx,vy,vz,vnspec
-
- ! memory variables for attenuation
- ! memory variables R_ij are stored at the local rather than global level
- ! to allow for optimization of cache access by compiler
- real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATT) :: R_xx,R_yy,R_xy,R_xz,R_yz
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
- epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
- real(kind=CUSTOM_REAL),dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: epsilon_trace_over_3
-
- ! [alpha,beta,gamma]val reduced to N_SLS and factor_common to N_SLS*NUM_NODES
- real(kind=CUSTOM_REAL), dimension(N_SLS,vx,vy,vz,vnspec) :: factor_common
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
-
- ! inner/outer element run flag
- logical :: phase_is_inner
-
- ! local parameters
-
- ! for attenuation
- real(kind=CUSTOM_REAL) one_minus_sum_beta_use,minus_sum_beta
- real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: factor_common_c44_muv
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
- tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
-
- integer ispec,iglob,ispec_strain
- integer i,j,k,l
- integer i_SLS
-
- ! the 21 coefficients for an anisotropic medium in reduced notation
- real(kind=CUSTOM_REAL) c11,c22,c33,c44,c55,c66,c12,c13,c23,c14,c24,c34,c15,c25,c35,c45,c16,c26,c36,c46,c56
-
- real(kind=CUSTOM_REAL) rhovphsq,sinphifour,cosphisq,sinphisq,costhetasq,rhovsvsq,sinthetasq, &
- cosphifour,costhetafour,rhovpvsq,sinthetafour,rhovshsq,cosfourphi, &
- costwotheta,cosfourtheta,sintwophisq,costheta,sinphi,sintheta,cosphi, &
- sintwotheta,costwophi,sintwophi,costwothetasq,costwophisq,phi,theta
-
- real(kind=CUSTOM_REAL) two_rhovsvsq,two_rhovshsq ! two_rhovpvsq,two_rhovphsq
- real(kind=CUSTOM_REAL) four_rhovsvsq,four_rhovshsq ! four_rhovpvsq,four_rhovphsq,
-
- real(kind=CUSTOM_REAL) twoetaminone,etaminone,eta_aniso
- real(kind=CUSTOM_REAL) two_eta_aniso,four_eta_aniso,six_eta_aniso
-
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
-
- real(kind=CUSTOM_REAL) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
- real(kind=CUSTOM_REAL) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
-
- real(kind=CUSTOM_REAL) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
-
- real(kind=CUSTOM_REAL) hp1,hp2,hp3
- real(kind=CUSTOM_REAL) fac1,fac2,fac3
- real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
- real(kind=CUSTOM_REAL) kappal,kappavl,kappahl,muvl,muhl
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sum_terms
-
- real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
- real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
- real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
-
- real(kind=CUSTOM_REAL) tempx1l_att,tempx2l_att,tempx3l_att
- real(kind=CUSTOM_REAL) tempy1l_att,tempy2l_att,tempy3l_att
- real(kind=CUSTOM_REAL) tempz1l_att,tempz2l_att,tempz3l_att
-
- real(kind=CUSTOM_REAL) duxdxl_att,duxdyl_att,duxdzl_att,duydxl_att
- real(kind=CUSTOM_REAL) duydyl_att,duydzl_att,duzdxl_att,duzdyl_att,duzdzl_att;
- real(kind=CUSTOM_REAL) duxdyl_plus_duydxl_att,duzdxl_plus_duxdzl_att,duzdyl_plus_duydzl_att;
-
- ! for gravity
- integer int_radius
- real(kind=CUSTOM_REAL) sigma_yx,sigma_zx,sigma_zy
- double precision radius,rho,minus_g,minus_dg
- double precision minus_g_over_radius,minus_dg_plus_g_over_radius
- double precision cos_theta,sin_theta,cos_phi,sin_phi
- double precision cos_theta_sq,sin_theta_sq,cos_phi_sq,sin_phi_sq
- double precision factor,sx_l,sy_l,sz_l,gxl,gyl,gzl
- double precision Hxxl,Hyyl,Hzzl,Hxyl,Hxzl,Hyzl
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: rho_s_H
-
-! integer :: computed_elements
- integer :: num_elements,ispec_p
- integer :: iphase
-
-! ****************************************************
-! big loop over all spectral elements in the solid
-! ****************************************************
-
-! computed_elements = 0
- if( .not. phase_is_inner ) then
- iphase = 1
- num_elements = nspec_outer
- else
- iphase = 2
- num_elements = nspec_inner
- endif
-
- do ispec_p = 1,num_elements
-
- ispec = phase_ispec_inner(ispec_p,iphase)
-
- ! only compute element which belong to current phase (inner or outer elements)
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- tempx1l = 0._CUSTOM_REAL
- tempx2l = 0._CUSTOM_REAL
- tempx3l = 0._CUSTOM_REAL
-
- tempy1l = 0._CUSTOM_REAL
- tempy2l = 0._CUSTOM_REAL
- tempy3l = 0._CUSTOM_REAL
-
- tempz1l = 0._CUSTOM_REAL
- tempz2l = 0._CUSTOM_REAL
- tempz3l = 0._CUSTOM_REAL
-
- do l=1,NGLLX
- hp1 = hprime_xx(i,l)
- iglob = ibool(l,j,k,ispec)
- tempx1l = tempx1l + displ_crust_mantle(1,iglob)*hp1
- tempy1l = tempy1l + displ_crust_mantle(2,iglob)*hp1
- tempz1l = tempz1l + displ_crust_mantle(3,iglob)*hp1
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- hp2 = hprime_yy(j,l)
- iglob = ibool(i,l,k,ispec)
- tempx2l = tempx2l + displ_crust_mantle(1,iglob)*hp2
- tempy2l = tempy2l + displ_crust_mantle(2,iglob)*hp2
- tempz2l = tempz2l + displ_crust_mantle(3,iglob)*hp2
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- hp3 = hprime_zz(k,l)
- iglob = ibool(i,j,l,ispec)
- tempx3l = tempx3l + displ_crust_mantle(1,iglob)*hp3
- tempy3l = tempy3l + displ_crust_mantle(2,iglob)*hp3
- tempz3l = tempz3l + displ_crust_mantle(3,iglob)*hp3
- enddo
-
- if( ATTENUATION_VAL .and. COMPUTE_AND_STORE_STRAIN ) then
- ! temporary variables used for fixing attenuation in a consistent way
-
- tempx1l_att = tempx1l
- tempx2l_att = tempx2l
- tempx3l_att = tempx3l
-
- tempy1l_att = tempy1l
- tempy2l_att = tempy2l
- tempy3l_att = tempy3l
-
- tempz1l_att = tempz1l
- tempz2l_att = tempz2l
- tempz3l_att = tempz3l
-
- if(ATTENUATION_NEW_VAL) then
- ! takes new routines
- ! use first order Taylor expansion of displacement for local storage of stresses
- ! at this current time step, to fix attenuation in a consistent way
- do l=1,NGLLX
- hp1 = hprime_xx(i,l)
- iglob = ibool(l,j,k,ispec)
- tempx1l_att = tempx1l_att + deltat*veloc_crust_mantle(1,iglob)*hp1
- tempy1l_att = tempy1l_att + deltat*veloc_crust_mantle(2,iglob)*hp1
- tempz1l_att = tempz1l_att + deltat*veloc_crust_mantle(3,iglob)*hp1
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- hp2 = hprime_yy(j,l)
- iglob = ibool(i,l,k,ispec)
- tempx2l_att = tempx2l_att + deltat*veloc_crust_mantle(1,iglob)*hp2
- tempy2l_att = tempy2l_att + deltat*veloc_crust_mantle(2,iglob)*hp2
- tempz2l_att = tempz2l_att + deltat*veloc_crust_mantle(3,iglob)*hp2
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- hp3 = hprime_zz(k,l)
- iglob = ibool(i,j,l,ispec)
- tempx3l_att = tempx3l_att + deltat*veloc_crust_mantle(1,iglob)*hp3
- tempy3l_att = tempy3l_att + deltat*veloc_crust_mantle(2,iglob)*hp3
- tempz3l_att = tempz3l_att + deltat*veloc_crust_mantle(3,iglob)*hp3
- enddo
- endif
- endif
-
-! get derivatives of ux, uy and uz with respect to x, y and z
-
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
-
-! compute the jacobian
- jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
- - xiyl*(etaxl*gammazl-etazl*gammaxl) &
- + xizl*(etaxl*gammayl-etayl*gammaxl))
-
- duxdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
- duxdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
- duxdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
-
- duydxl = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
- duydyl = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
- duydzl = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
-
- duzdxl = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
- duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
- duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
-
-! precompute some sums to save CPU time
- duxdxl_plus_duydyl = duxdxl + duydyl
- duxdxl_plus_duzdzl = duxdxl + duzdzl
- duydyl_plus_duzdzl = duydyl + duzdzl
- duxdyl_plus_duydxl = duxdyl + duydxl
- duzdxl_plus_duxdzl = duzdxl + duxdzl
- duzdyl_plus_duydzl = duzdyl + duydzl
-
- if( ATTENUATION_VAL .and. COMPUTE_AND_STORE_STRAIN ) then
- ! temporary variables used for fixing attenuation in a consistent way
- duxdxl_att = xixl*tempx1l_att + etaxl*tempx2l_att + gammaxl*tempx3l_att
- duxdyl_att = xiyl*tempx1l_att + etayl*tempx2l_att + gammayl*tempx3l_att
- duxdzl_att = xizl*tempx1l_att + etazl*tempx2l_att + gammazl*tempx3l_att
-
- duydxl_att = xixl*tempy1l_att + etaxl*tempy2l_att + gammaxl*tempy3l_att
- duydyl_att = xiyl*tempy1l_att + etayl*tempy2l_att + gammayl*tempy3l_att
- duydzl_att = xizl*tempy1l_att + etazl*tempy2l_att + gammazl*tempy3l_att
-
- duzdxl_att = xixl*tempz1l_att + etaxl*tempz2l_att + gammaxl*tempz3l_att
- duzdyl_att = xiyl*tempz1l_att + etayl*tempz2l_att + gammayl*tempz3l_att
- duzdzl_att = xizl*tempz1l_att + etazl*tempz2l_att + gammazl*tempz3l_att
-
- ! precompute some sums to save CPU time
- duxdyl_plus_duydxl_att = duxdyl_att + duydxl_att
- duzdxl_plus_duxdzl_att = duzdxl_att + duxdzl_att
- duzdyl_plus_duydzl_att = duzdyl_att + duydzl_att
-
- ! compute deviatoric strain
- if(NSPEC_CRUST_MANTLE_STRAIN_ONLY == 1) then
- ispec_strain = 1
- else
- ispec_strain = ispec
- endif
- epsilon_trace_over_3(i,j,k,ispec_strain) = ONE_THIRD * (duxdxl_att + duydyl_att + duzdzl_att)
- epsilondev_loc(1,i,j,k) = duxdxl_att - epsilon_trace_over_3(i,j,k,ispec_strain)
- epsilondev_loc(2,i,j,k) = duydyl_att - epsilon_trace_over_3(i,j,k,ispec_strain)
- epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl_att
- epsilondev_loc(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl_att
- epsilondev_loc(5,i,j,k) = 0.5 * duzdyl_plus_duydzl_att
- else
- ! compute deviatoric strain
- if (COMPUTE_AND_STORE_STRAIN) then
- if(NSPEC_CRUST_MANTLE_STRAIN_ONLY == 1) then
- ispec_strain = 1
- else
- ispec_strain = ispec
- endif
- epsilon_trace_over_3(i,j,k,ispec_strain) = ONE_THIRD * (duxdxl + duydyl + duzdzl)
- epsilondev_loc(1,i,j,k) = duxdxl - epsilon_trace_over_3(i,j,k,ispec_strain)
- epsilondev_loc(2,i,j,k) = duydyl - epsilon_trace_over_3(i,j,k,ispec_strain)
- epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
- epsilondev_loc(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl
- epsilondev_loc(5,i,j,k) = 0.5 * duzdyl_plus_duydzl
- endif
- endif
-
- ! precompute terms for attenuation if needed
- if( ATTENUATION_VAL ) then
- if( USE_3D_ATTENUATION_ARRAYS ) then
- one_minus_sum_beta_use = one_minus_sum_beta(i,j,k,ispec)
- else
- one_minus_sum_beta_use = one_minus_sum_beta(1,1,1,ispec)
- endif
- minus_sum_beta = one_minus_sum_beta_use - 1.0_CUSTOM_REAL
- endif
-
- !
- ! compute either isotropic or anisotropic elements
- !
-
- if(ANISOTROPIC_3D_MANTLE_VAL) then
-
- c11 = c11store(i,j,k,ispec)
- c12 = c12store(i,j,k,ispec)
- c13 = c13store(i,j,k,ispec)
- c14 = c14store(i,j,k,ispec)
- c15 = c15store(i,j,k,ispec)
- c16 = c16store(i,j,k,ispec)
- c22 = c22store(i,j,k,ispec)
- c23 = c23store(i,j,k,ispec)
- c24 = c24store(i,j,k,ispec)
- c25 = c25store(i,j,k,ispec)
- c26 = c26store(i,j,k,ispec)
- c33 = c33store(i,j,k,ispec)
- c34 = c34store(i,j,k,ispec)
- c35 = c35store(i,j,k,ispec)
- c36 = c36store(i,j,k,ispec)
- c44 = c44store(i,j,k,ispec)
- c45 = c45store(i,j,k,ispec)
- c46 = c46store(i,j,k,ispec)
- c55 = c55store(i,j,k,ispec)
- c56 = c56store(i,j,k,ispec)
- c66 = c66store(i,j,k,ispec)
-
- if(ATTENUATION_VAL) then
- mul = c44
- c11 = c11 + FOUR_THIRDS * minus_sum_beta * mul
- c12 = c12 - TWO_THIRDS * minus_sum_beta * mul
- c13 = c13 - TWO_THIRDS * minus_sum_beta * mul
- c22 = c22 + FOUR_THIRDS * minus_sum_beta * mul
- c23 = c23 - TWO_THIRDS * minus_sum_beta * mul
- c33 = c33 + FOUR_THIRDS * minus_sum_beta * mul
- c44 = c44 + minus_sum_beta * mul
- c55 = c55 + minus_sum_beta * mul
- c66 = c66 + minus_sum_beta * mul
- endif
-
- sigma_xx = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
- c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
-
- sigma_yy = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
- c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
-
- sigma_zz = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
- c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
-
- sigma_xy = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
- c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
-
- sigma_xz = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
- c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
-
- sigma_yz = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
- c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
-
- else
-
- ! do not use transverse isotropy except if element is between d220 and Moho
-! if(.not. (TRANSVERSE_ISOTROPY_VAL .and. (idoubling(ispec)==IFLAG_220_80 .or. idoubling(ispec)==IFLAG_80_MOHO))) then
-
- if( .not. ispec_is_tiso(ispec) ) then
-
- ! isotropic element
-
- ! layer with no transverse isotropy, use kappav and muv
- kappal = kappavstore(i,j,k,ispec)
- mul = muvstore(i,j,k,ispec)
-
- ! use unrelaxed parameters if attenuation
- if(ATTENUATION_VAL) mul = mul * one_minus_sum_beta_use
-
- lambdalplus2mul = kappal + FOUR_THIRDS * mul
- lambdal = lambdalplus2mul - 2.*mul
-
- ! compute stress sigma
-
- sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
- sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
- sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
-
- sigma_xy = mul*duxdyl_plus_duydxl
- sigma_xz = mul*duzdxl_plus_duxdzl
- sigma_yz = mul*duzdyl_plus_duydzl
-
- else
-
- ! transverse isotropic element
-
- ! use Kappa and mu from transversely isotropic model
- kappavl = kappavstore(i,j,k,ispec)
- muvl = muvstore(i,j,k,ispec)
-
- kappahl = kappahstore(i,j,k,ispec)
- muhl = muhstore(i,j,k,ispec)
-
- ! use unrelaxed parameters if attenuation
- ! eta does not need to be shifted since it is a ratio
- if(ATTENUATION_VAL) then
- muvl = muvl * one_minus_sum_beta_use
- muhl = muhl * one_minus_sum_beta_use
- endif
-
- rhovpvsq = kappavl + FOUR_THIRDS * muvl !!! that is C
- rhovphsq = kappahl + FOUR_THIRDS * muhl !!! that is A
-
- rhovsvsq = muvl !!! that is L
- rhovshsq = muhl !!! that is N
-
- eta_aniso = eta_anisostore(i,j,k,ispec) !!! that is F / (A - 2 L)
-
- ! use mesh coordinates to get theta and phi
- ! ystore and zstore contain theta and phi
-
- iglob = ibool(i,j,k,ispec)
- theta = ystore(iglob)
- phi = zstore(iglob)
-
- costheta = cos(theta)
- sintheta = sin(theta)
- cosphi = cos(phi)
- sinphi = sin(phi)
-
- costhetasq = costheta * costheta
- sinthetasq = sintheta * sintheta
- cosphisq = cosphi * cosphi
- sinphisq = sinphi * sinphi
-
- costhetafour = costhetasq * costhetasq
- sinthetafour = sinthetasq * sinthetasq
- cosphifour = cosphisq * cosphisq
- sinphifour = sinphisq * sinphisq
-
- costwotheta = cos(2.*theta)
- sintwotheta = sin(2.*theta)
- costwophi = cos(2.*phi)
- sintwophi = sin(2.*phi)
-
- cosfourtheta = cos(4.*theta)
- cosfourphi = cos(4.*phi)
-
- costwothetasq = costwotheta * costwotheta
-
- costwophisq = costwophi * costwophi
- sintwophisq = sintwophi * sintwophi
-
- etaminone = eta_aniso - 1.
- twoetaminone = 2. * eta_aniso - 1.
-
- ! precompute some products to reduce the CPU time
-
- two_eta_aniso = 2.*eta_aniso
- four_eta_aniso = 4.*eta_aniso
- six_eta_aniso = 6.*eta_aniso
-
- !two_rhovpvsq = 2.*rhovpvsq
- !two_rhovphsq = 2.*rhovphsq
- two_rhovsvsq = 2.*rhovsvsq
- two_rhovshsq = 2.*rhovshsq
-
- !four_rhovpvsq = 4.*rhovpvsq
- !four_rhovphsq = 4.*rhovphsq
- four_rhovsvsq = 4.*rhovsvsq
- four_rhovshsq = 4.*rhovshsq
-
- ! the 21 anisotropic coefficients computed using Mathematica
-
- c11 = rhovphsq*sinphifour + 2.*cosphisq*sinphisq* &
- (rhovphsq*costhetasq + (eta_aniso*rhovphsq + two_rhovsvsq - two_eta_aniso*rhovsvsq)* &
- sinthetasq) + cosphifour* &
- (rhovphsq*costhetafour + 2.*(eta_aniso*rhovphsq + two_rhovsvsq - two_eta_aniso*rhovsvsq)* &
- costhetasq*sinthetasq + rhovpvsq*sinthetafour)
-
- c12 = ((rhovphsq - two_rhovshsq)*(3. + cosfourphi)*costhetasq)/4. - &
- four_rhovshsq*cosphisq*costhetasq*sinphisq + &
- (rhovphsq*(11. + 4.*costwotheta + cosfourtheta)*sintwophisq)/32. + &
- eta_aniso*(rhovphsq - two_rhovsvsq)*(cosphifour + &
- 2.*cosphisq*costhetasq*sinphisq + sinphifour)*sinthetasq + &
- rhovpvsq*cosphisq*sinphisq*sinthetafour - &
- rhovsvsq*sintwophisq*sinthetafour
-
- c13 = (cosphisq*(rhovphsq + six_eta_aniso*rhovphsq + rhovpvsq - four_rhovsvsq - &
- 12.*eta_aniso*rhovsvsq + (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - &
- four_eta_aniso*rhovsvsq)*cosfourtheta))/8. + &
- sinphisq*(eta_aniso*(rhovphsq - two_rhovsvsq)*costhetasq + &
- (rhovphsq - two_rhovshsq)*sinthetasq)
-
- c14 = costheta*sinphi*((cosphisq* &
- (-rhovphsq + rhovpvsq + four_rhovshsq - four_rhovsvsq + &
- (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + four_rhovsvsq - &
- four_eta_aniso*rhovsvsq)*costwotheta))/2. + &
- (etaminone*rhovphsq + 2.*(rhovshsq - eta_aniso*rhovsvsq))*sinphisq)* sintheta
-
- c15 = cosphi*costheta*((cosphisq* (-rhovphsq + rhovpvsq + &
- (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - four_eta_aniso*rhovsvsq)* &
- costwotheta))/2. + etaminone*(rhovphsq - two_rhovsvsq)*sinphisq)*sintheta
-
- c16 = (cosphi*sinphi*(cosphisq* (-rhovphsq + rhovpvsq + &
- (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + four_rhovsvsq - &
- four_eta_aniso*rhovsvsq)*costwotheta) + &
- 2.*etaminone*(rhovphsq - two_rhovsvsq)*sinphisq)*sinthetasq)/2.
-
- c22 = rhovphsq*cosphifour + 2.*cosphisq*sinphisq* &
- (rhovphsq*costhetasq + (eta_aniso*rhovphsq + two_rhovsvsq - two_eta_aniso*rhovsvsq)* &
- sinthetasq) + sinphifour* &
- (rhovphsq*costhetafour + 2.*(eta_aniso*rhovphsq + two_rhovsvsq - two_eta_aniso*rhovsvsq)* &
- costhetasq*sinthetasq + rhovpvsq*sinthetafour)
-
- c23 = ((rhovphsq + six_eta_aniso*rhovphsq + rhovpvsq - four_rhovsvsq - 12.*eta_aniso*rhovsvsq + &
- (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - four_eta_aniso*rhovsvsq)* &
- cosfourtheta)*sinphisq)/8. + &
- cosphisq*(eta_aniso*(rhovphsq - two_rhovsvsq)*costhetasq + &
- (rhovphsq - two_rhovshsq)*sinthetasq)
-
- c24 = costheta*sinphi*(etaminone*(rhovphsq - two_rhovsvsq)*cosphisq + &
- ((-rhovphsq + rhovpvsq + (twoetaminone*rhovphsq - rhovpvsq + &
- four_rhovsvsq - four_eta_aniso*rhovsvsq)*costwotheta)*sinphisq)/2.)*sintheta
-
- c25 = cosphi*costheta*((etaminone*rhovphsq + 2.*(rhovshsq - eta_aniso*rhovsvsq))* &
- cosphisq + ((-rhovphsq + rhovpvsq + four_rhovshsq - four_rhovsvsq + &
- (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + four_rhovsvsq - &
- four_eta_aniso*rhovsvsq)*costwotheta)*sinphisq)/2.)*sintheta
-
- c26 = (cosphi*sinphi*(2.*etaminone*(rhovphsq - two_rhovsvsq)*cosphisq + &
- (-rhovphsq + rhovpvsq + (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + four_rhovsvsq - &
- four_eta_aniso*rhovsvsq)*costwotheta)*sinphisq)*sinthetasq)/2.
-
- c33 = rhovpvsq*costhetafour + 2.*(eta_aniso*(rhovphsq - two_rhovsvsq) + two_rhovsvsq)* &
- costhetasq*sinthetasq + rhovphsq*sinthetafour
-
- c34 = -((rhovphsq - rhovpvsq + (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq &
- - four_eta_aniso*rhovsvsq)*costwotheta)*sinphi*sintwotheta)/4.
-
- c35 = -(cosphi*(rhovphsq - rhovpvsq + &
- (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - four_eta_aniso*rhovsvsq)* &
- costwotheta)*sintwotheta)/4.
-
- c36 = -((rhovphsq - rhovpvsq - four_rhovshsq + four_rhovsvsq + &
- (twoetaminone*rhovphsq - rhovpvsq + four_rhovsvsq - four_eta_aniso*rhovsvsq)* &
- costwotheta)*sintwophi*sinthetasq)/4.
-
- c44 = cosphisq*(rhovsvsq*costhetasq + rhovshsq*sinthetasq) + &
- sinphisq*(rhovsvsq*costwothetasq + &
- (rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq + four_eta_aniso*rhovsvsq)*costhetasq* sinthetasq)
-
- c45 = ((rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq - two_rhovshsq - two_rhovsvsq + &
- four_eta_aniso*rhovsvsq + (rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq + &
- 4.*etaminone*rhovsvsq)*costwotheta)*sintwophi*sinthetasq)/4.
-
- c46 = -(cosphi*costheta*((rhovshsq - rhovsvsq)*cosphisq - &
- ((rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq - two_rhovshsq - two_rhovsvsq + &
- four_eta_aniso*rhovsvsq + (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + &
- four_rhovsvsq - four_eta_aniso*rhovsvsq)*costwotheta)*sinphisq)/2.)* sintheta)
-
- c55 = sinphisq*(rhovsvsq*costhetasq + rhovshsq*sinthetasq) + &
- cosphisq*(rhovsvsq*costwothetasq + &
- (rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq + four_eta_aniso*rhovsvsq)*costhetasq* sinthetasq)
-
- c56 = costheta*sinphi*((cosphisq* &
- (rhovphsq - two_eta_aniso*rhovphsq + rhovpvsq - two_rhovshsq - two_rhovsvsq + &
- four_eta_aniso*rhovsvsq + (-rhovphsq + two_eta_aniso*rhovphsq - rhovpvsq + &
- four_rhovsvsq - four_eta_aniso*rhovsvsq)*costwotheta))/2. + &
- (-rhovshsq + rhovsvsq)*sinphisq)*sintheta
-
- c66 = rhovshsq*costwophisq*costhetasq - &
- 2.*(rhovphsq - two_rhovshsq)*cosphisq*costhetasq*sinphisq + &
- (rhovphsq*(11. + 4.*costwotheta + cosfourtheta)*sintwophisq)/32. - &
- (rhovsvsq*(-6. - 2.*cosfourphi + cos(4.*phi - 2.*theta) - 2.*costwotheta + &
- cos(2.*(2.*phi + theta)))*sinthetasq)/8. + &
- rhovpvsq*cosphisq*sinphisq*sinthetafour - &
- (eta_aniso*(rhovphsq - two_rhovsvsq)*sintwophisq*sinthetafour)/2.
-
- ! general expression of stress tensor for full Cijkl with 21 coefficients
-
- sigma_xx = c11*duxdxl + c16*duxdyl_plus_duydxl + c12*duydyl + &
- c15*duzdxl_plus_duxdzl + c14*duzdyl_plus_duydzl + c13*duzdzl
-
- sigma_yy = c12*duxdxl + c26*duxdyl_plus_duydxl + c22*duydyl + &
- c25*duzdxl_plus_duxdzl + c24*duzdyl_plus_duydzl + c23*duzdzl
-
- sigma_zz = c13*duxdxl + c36*duxdyl_plus_duydxl + c23*duydyl + &
- c35*duzdxl_plus_duxdzl + c34*duzdyl_plus_duydzl + c33*duzdzl
-
- sigma_xy = c16*duxdxl + c66*duxdyl_plus_duydxl + c26*duydyl + &
- c56*duzdxl_plus_duxdzl + c46*duzdyl_plus_duydzl + c36*duzdzl
-
- sigma_xz = c15*duxdxl + c56*duxdyl_plus_duydxl + c25*duydyl + &
- c55*duzdxl_plus_duxdzl + c45*duzdyl_plus_duydzl + c35*duzdzl
-
- sigma_yz = c14*duxdxl + c46*duxdyl_plus_duydxl + c24*duydyl + &
- c45*duzdxl_plus_duxdzl + c44*duzdyl_plus_duydzl + c34*duzdzl
-
- endif
-
- endif ! end of test whether isotropic or anisotropic element
-
- ! subtract memory variables if attenuation
- if(ATTENUATION_VAL .and. ( USE_ATTENUATION_MIMIC .eqv. .false. ) ) then
- do i_SLS = 1,N_SLS
- R_xx_val = R_xx(i_SLS,i,j,k,ispec)
- R_yy_val = R_yy(i_SLS,i,j,k,ispec)
- sigma_xx = sigma_xx - R_xx_val
- sigma_yy = sigma_yy - R_yy_val
- sigma_zz = sigma_zz + R_xx_val + R_yy_val
- sigma_xy = sigma_xy - R_xy(i_SLS,i,j,k,ispec)
- sigma_xz = sigma_xz - R_xz(i_SLS,i,j,k,ispec)
- sigma_yz = sigma_yz - R_yz(i_SLS,i,j,k,ispec)
- enddo
- endif
-
- ! define symmetric components of sigma for gravity
- sigma_yx = sigma_xy
- sigma_zx = sigma_xz
- sigma_zy = sigma_yz
-
- ! compute non-symmetric terms for gravity
- if(GRAVITY_VAL) then
-
- ! use mesh coordinates to get theta and phi
- ! x y and z contain r theta and phi
-
- iglob = ibool(i,j,k,ispec)
- radius = dble(xstore(iglob))
- theta = ystore(iglob)
- phi = zstore(iglob)
-
- cos_theta = dcos(dble(theta))
- sin_theta = dsin(dble(theta))
- cos_phi = dcos(dble(phi))
- sin_phi = dsin(dble(phi))
-
- ! get g, rho and dg/dr=dg
- ! spherical components of the gravitational acceleration
- ! for efficiency replace with lookup table every 100 m in radial direction
- int_radius = nint(radius * R_EARTH_KM * 10.d0)
- minus_g = minus_gravity_table(int_radius)
- minus_dg = minus_deriv_gravity_table(int_radius)
- rho = density_table(int_radius)
-
- ! Cartesian components of the gravitational acceleration
- gxl = minus_g*sin_theta*cos_phi
- gyl = minus_g*sin_theta*sin_phi
- gzl = minus_g*cos_theta
-
- ! Cartesian components of gradient of gravitational acceleration
- ! obtained from spherical components
-
- minus_g_over_radius = minus_g / radius
- minus_dg_plus_g_over_radius = minus_dg - minus_g_over_radius
-
- cos_theta_sq = cos_theta**2
- sin_theta_sq = sin_theta**2
- cos_phi_sq = cos_phi**2
- sin_phi_sq = sin_phi**2
-
- Hxxl = minus_g_over_radius*(cos_phi_sq*cos_theta_sq + sin_phi_sq) + cos_phi_sq*minus_dg*sin_theta_sq
- Hyyl = minus_g_over_radius*(cos_phi_sq + cos_theta_sq*sin_phi_sq) + minus_dg*sin_phi_sq*sin_theta_sq
- Hzzl = cos_theta_sq*minus_dg + minus_g_over_radius*sin_theta_sq
- Hxyl = cos_phi*minus_dg_plus_g_over_radius*sin_phi*sin_theta_sq
- Hxzl = cos_phi*cos_theta*minus_dg_plus_g_over_radius*sin_theta
- Hyzl = cos_theta*minus_dg_plus_g_over_radius*sin_phi*sin_theta
-
- iglob = ibool(i,j,k,ispec)
-
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
-
- ! get displacement and multiply by density to compute G tensor
- sx_l = rho * dble(displ_crust_mantle(1,iglob))
- sy_l = rho * dble(displ_crust_mantle(2,iglob))
- sz_l = rho * dble(displ_crust_mantle(3,iglob))
-
- ! compute G tensor from s . g and add to sigma (not symmetric)
- sigma_xx = sigma_xx + sngl(sy_l*gyl + sz_l*gzl)
- sigma_yy = sigma_yy + sngl(sx_l*gxl + sz_l*gzl)
- sigma_zz = sigma_zz + sngl(sx_l*gxl + sy_l*gyl)
-
- sigma_xy = sigma_xy - sngl(sx_l * gyl)
- sigma_yx = sigma_yx - sngl(sy_l * gxl)
-
- sigma_xz = sigma_xz - sngl(sx_l * gzl)
- sigma_zx = sigma_zx - sngl(sz_l * gxl)
-
- sigma_yz = sigma_yz - sngl(sy_l * gzl)
- sigma_zy = sigma_zy - sngl(sz_l * gyl)
-
- ! precompute vector
- factor = dble(jacobianl) * wgll_cube(i,j,k)
- rho_s_H(1,i,j,k) = sngl(factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl))
- rho_s_H(2,i,j,k) = sngl(factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl))
- rho_s_H(3,i,j,k) = sngl(factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl))
-
- else
-
- ! get displacement and multiply by density to compute G tensor
- sx_l = rho * displ_crust_mantle(1,iglob)
- sy_l = rho * displ_crust_mantle(2,iglob)
- sz_l = rho * displ_crust_mantle(3,iglob)
-
- ! compute G tensor from s . g and add to sigma (not symmetric)
- sigma_xx = sigma_xx + sy_l*gyl + sz_l*gzl
- sigma_yy = sigma_yy + sx_l*gxl + sz_l*gzl
- sigma_zz = sigma_zz + sx_l*gxl + sy_l*gyl
-
- sigma_xy = sigma_xy - sx_l * gyl
- sigma_yx = sigma_yx - sy_l * gxl
-
- sigma_xz = sigma_xz - sx_l * gzl
- sigma_zx = sigma_zx - sz_l * gxl
-
- sigma_yz = sigma_yz - sy_l * gzl
- sigma_zy = sigma_zy - sz_l * gyl
-
- ! precompute vector
- factor = jacobianl * wgll_cube(i,j,k)
- rho_s_H(1,i,j,k) = factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl)
- rho_s_H(2,i,j,k) = factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl)
- rho_s_H(3,i,j,k) = factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl)
-
- endif
-
- endif ! end of section with gravity terms
-
- ! form dot product with test vector, non-symmetric form
- tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl)
- tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl)
- tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
-
- tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl)
- tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl)
- tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
-
- tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl)
- tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl)
- tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
-
- enddo ! NGLLX
- enddo ! NGLLY
- enddo ! NGLLZ
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- tempx1l = 0._CUSTOM_REAL
- tempy1l = 0._CUSTOM_REAL
- tempz1l = 0._CUSTOM_REAL
-
- tempx2l = 0._CUSTOM_REAL
- tempy2l = 0._CUSTOM_REAL
- tempz2l = 0._CUSTOM_REAL
-
- tempx3l = 0._CUSTOM_REAL
- tempy3l = 0._CUSTOM_REAL
- tempz3l = 0._CUSTOM_REAL
-
- do l=1,NGLLX
- fac1 = hprimewgll_xx(l,i)
- tempx1l = tempx1l + tempx1(l,j,k)*fac1
- tempy1l = tempy1l + tempy1(l,j,k)*fac1
- tempz1l = tempz1l + tempz1(l,j,k)*fac1
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- fac2 = hprimewgll_yy(l,j)
- tempx2l = tempx2l + tempx2(i,l,k)*fac2
- tempy2l = tempy2l + tempy2(i,l,k)*fac2
- tempz2l = tempz2l + tempz2(i,l,k)*fac2
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- fac3 = hprimewgll_zz(l,k)
- tempx3l = tempx3l + tempx3(i,j,l)*fac3
- tempy3l = tempy3l + tempy3(i,j,l)*fac3
- tempz3l = tempz3l + tempz3(i,j,l)*fac3
- enddo
-
- fac1 = wgllwgll_yz(j,k)
- fac2 = wgllwgll_xz(i,k)
- fac3 = wgllwgll_xy(i,j)
-
- sum_terms(1,i,j,k) = - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
- sum_terms(2,i,j,k) = - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
- sum_terms(3,i,j,k) = - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
-
- if(GRAVITY_VAL) sum_terms(:,i,j,k) = sum_terms(:,i,j,k) + rho_s_H(:,i,j,k)
-
- enddo ! NGLLX
- enddo ! NGLLY
- enddo ! NGLLZ
-
- ! sum contributions from each element to the global mesh and add gravity terms
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
- accel_crust_mantle(:,iglob) = accel_crust_mantle(:,iglob) + sum_terms(:,i,j,k)
- enddo
- enddo
- enddo
-
-! update memory variables based upon the Runge-Kutta scheme
-! convention for attenuation
-! term in xx = 1
-! term in yy = 2
-! term in xy = 3
-! term in xz = 4
-! term in yz = 5
-! term in zz not computed since zero trace
-! This is because we only implement Q_\mu attenuation and not Q_\kappa.
-! Note that this does *NOT* imply that there is no attenuation for P waves
-! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
-! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
-! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
-! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
-
- if(ATTENUATION_VAL .and. ( USE_ATTENUATION_MIMIC .eqv. .false. )) then
-
-! use Runge-Kutta scheme to march in time
- do i_SLS = 1,N_SLS
-
-! get coefficients for that standard linear solid
-! IMPROVE we use mu_v here even if there is some anisotropy
-! IMPROVE we should probably use an average value instead
-
- ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
- if(USE_3D_ATTENUATION_ARRAYS) then
- if(ANISOTROPIC_3D_MANTLE_VAL) then
- factor_common_c44_muv(:,:,:) = factor_common(i_SLS,:,:,:,ispec) * c44store(:,:,:,ispec)
- else
- factor_common_c44_muv(:,:,:) = factor_common(i_SLS,:,:,:,ispec) * muvstore(:,:,:,ispec)
- endif
- else
- if(ANISOTROPIC_3D_MANTLE_VAL) then
- factor_common_c44_muv(:,:,:) = factor_common(i_SLS,1,1,1,ispec) * c44store(:,:,:,ispec)
- else
- factor_common_c44_muv(:,:,:) = factor_common(i_SLS,1,1,1,ispec) * muvstore(:,:,:,ispec)
- endif
- endif
-
-! do i_memory = 1,5
-! R_memory(i_memory,i_SLS,:,:,:,ispec) = alphaval(i_SLS) * &
-! R_memory(i_memory,i_SLS,:,:,:,ispec) + &
-! factor_common_c44_muv * &
-! (betaval(i_SLS) * epsilondev(i_memory,:,:,:,ispec) + &
-! gammaval(i_SLS) * epsilondev_loc(i_memory,:,:,:))
-! enddo
-
- R_xx(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xx(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xx(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(1,:,:,:))
-
- R_yy(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_yy(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
- (betaval(i_SLS) * epsilondev_yy(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(2,:,:,:))
-
- R_xy(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xy(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xy(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(3,:,:,:))
-
- R_xz(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xz(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xz(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(4,:,:,:))
-
- R_yz(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_yz(i_SLS,:,:,:,ispec) + factor_common_c44_muv(:,:,:) * &
- (betaval(i_SLS) * epsilondev_yz(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(5,:,:,:))
-
- enddo
- endif
-
- ! save deviatoric strain for Runge-Kutta scheme
- if(COMPUTE_AND_STORE_STRAIN) then
- !epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- epsilondev_xx(i,j,k,ispec) = epsilondev_loc(1,i,j,k)
- epsilondev_yy(i,j,k,ispec) = epsilondev_loc(2,i,j,k)
- epsilondev_xy(i,j,k,ispec) = epsilondev_loc(3,i,j,k)
- epsilondev_xz(i,j,k,ispec) = epsilondev_loc(4,i,j,k)
- epsilondev_yz(i,j,k,ispec) = epsilondev_loc(5,i,j,k)
- enddo
- enddo
- enddo
- endif
-
- enddo ! spectral element loop NSPEC_CRUST_MANTLE
-
- end subroutine compute_forces_crust_mantle
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_inner_core.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,713 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 compute_forces_inner_core( NSPEC,NGLOB,NSPEC_ATT, &
- deltat, &
- displ_inner_core, &
- veloc_inner_core, &
- accel_inner_core, &
- phase_is_inner, &
- R_xx,R_yy,R_xy,R_xz,R_yz, &
- epsilondev_xx,epsilondev_yy,epsilondev_xy, &
- epsilondev_xz,epsilondev_yz, &
- epsilon_trace_over_3,&
- alphaval,betaval,gammaval,factor_common, &
- vx,vy,vz,vnspec)
-
- use constants_solver
-
- use specfem_par,only: &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- minus_gravity_table,density_table,minus_deriv_gravity_table
-
- use specfem_par_innercore,only: &
- xstore => xstore_inner_core,ystore => ystore_inner_core,zstore => zstore_inner_core, &
- xix => xix_inner_core,xiy => xiy_inner_core,xiz => xiz_inner_core, &
- etax => etax_inner_core,etay => etay_inner_core,etaz => etaz_inner_core, &
- gammax => gammax_inner_core,gammay => gammay_inner_core,gammaz => gammaz_inner_core, &
- kappavstore => kappavstore_inner_core, &
- muvstore => muvstore_inner_core, &
- c11store => c11store_inner_core,c12store => c12store_inner_core,c13store => c13store_inner_core, &
- c33store => c33store_inner_core,c44store => c44store_inner_core, &
- ibool => ibool_inner_core,idoubling => idoubling_inner_core, &
- one_minus_sum_beta => one_minus_sum_beta_inner_core, &
- phase_ispec_inner => phase_ispec_inner_inner_core, &
- nspec_outer => nspec_outer_inner_core, &
- nspec_inner => nspec_inner_inner_core
-
- implicit none
-
- integer :: NSPEC,NGLOB,NSPEC_ATT
-
- ! time step
- real(kind=CUSTOM_REAL) deltat
-
- ! displacement, velocity and acceleration
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB) :: displ_inner_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB) :: veloc_inner_core
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLOB) :: accel_inner_core
-
- ! for attenuation
- ! memory variables R_ij are stored at the local rather than global level
- ! to allow for optimization of cache access by compiler
- ! variable lengths for factor_common and one_minus_sum_beta
-
- ! variable sized array variables
- integer vx, vy, vz, vnspec
-
- real(kind=CUSTOM_REAL), dimension(N_SLS,vx,vy,vz,vnspec) :: factor_common
- real(kind=CUSTOM_REAL), dimension(N_SLS) :: alphaval,betaval,gammaval
-
- real(kind=CUSTOM_REAL), dimension(N_SLS,NGLLX,NGLLY,NGLLZ,NSPEC_ATT) :: R_xx,R_yy,R_xy,R_xz,R_yz
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
- epsilondev_xx,epsilondev_yy,epsilondev_xy,epsilondev_xz,epsilondev_yz
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: epsilon_trace_over_3
-
- ! inner/outer element run flag
- logical :: phase_is_inner
-
- ! local parameters
-
- real(kind=CUSTOM_REAL), dimension(5,NGLLX,NGLLY,NGLLZ) :: epsilondev_loc
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: factor_common_use
- real(kind=CUSTOM_REAL) R_xx_val,R_yy_val
- integer i_SLS
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: &
- tempx1,tempx2,tempx3,tempy1,tempy2,tempy3,tempz1,tempz2,tempz3
-
- integer ispec,iglob,ispec_strain
- integer i,j,k,l
-
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- real(kind=CUSTOM_REAL) duxdxl,duxdyl,duxdzl,duydxl,duydyl,duydzl,duzdxl,duzdyl,duzdzl
-
- real(kind=CUSTOM_REAL) duxdxl_plus_duydyl,duxdxl_plus_duzdzl,duydyl_plus_duzdzl
- real(kind=CUSTOM_REAL) duxdyl_plus_duydxl,duzdxl_plus_duxdzl,duzdyl_plus_duydzl
-
- real(kind=CUSTOM_REAL) sigma_xx,sigma_yy,sigma_zz,sigma_xy,sigma_xz,sigma_yz
-
- real(kind=CUSTOM_REAL) hp1,hp2,hp3
- real(kind=CUSTOM_REAL) fac1,fac2,fac3
- real(kind=CUSTOM_REAL) lambdal,mul,lambdalplus2mul
- real(kind=CUSTOM_REAL) kappal
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: sum_terms
-
- real(kind=CUSTOM_REAL) minus_sum_beta
- real(kind=CUSTOM_REAL) c11l,c33l,c12l,c13l,c44l
-
- real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l
- real(kind=CUSTOM_REAL) tempy1l,tempy2l,tempy3l
- real(kind=CUSTOM_REAL) tempz1l,tempz2l,tempz3l
-
- real(kind=CUSTOM_REAL) tempx1l_att,tempx2l_att,tempx3l_att
- real(kind=CUSTOM_REAL) tempy1l_att,tempy2l_att,tempy3l_att
- real(kind=CUSTOM_REAL) tempz1l_att,tempz2l_att,tempz3l_att
-
- real(kind=CUSTOM_REAL) duxdxl_att,duxdyl_att,duxdzl_att,duydxl_att
- real(kind=CUSTOM_REAL) duydyl_att,duydzl_att,duzdxl_att,duzdyl_att,duzdzl_att;
- real(kind=CUSTOM_REAL) duxdyl_plus_duydxl_att,duzdxl_plus_duxdzl_att,duzdyl_plus_duydzl_att;
-
- ! for gravity
- double precision radius,rho,minus_g,minus_dg
- double precision minus_g_over_radius,minus_dg_plus_g_over_radius
- double precision cos_theta,sin_theta,cos_phi,sin_phi
- double precision cos_theta_sq,sin_theta_sq,cos_phi_sq,sin_phi_sq
- double precision theta,phi,factor,gxl,gyl,gzl,sx_l,sy_l,sz_l
- double precision Hxxl,Hyyl,Hzzl,Hxyl,Hxzl,Hyzl
- real(kind=CUSTOM_REAL), dimension(NDIM,NGLLX,NGLLY,NGLLZ) :: rho_s_H
- real(kind=CUSTOM_REAL) sigma_yx,sigma_zx,sigma_zy
- integer :: int_radius
-
-! integer :: computed_elements
- integer :: num_elements,ispec_p
- integer :: iphase
-
-! ****************************************************
-! big loop over all spectral elements in the solid
-! ****************************************************
-
-! computed_elements = 0
- if( .not. phase_is_inner ) then
- iphase = 1
- num_elements = nspec_outer
- else
- iphase = 2
- num_elements = nspec_inner
- endif
-
- do ispec_p = 1,num_elements
-
- ispec = phase_ispec_inner(ispec_p,iphase)
-
- ! only compute element which belong to current phase (inner or outer elements)
-
- ! exclude fictitious elements in central cube
- if(idoubling(ispec) /= IFLAG_IN_FICTITIOUS_CUBE) then
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- tempx1l = 0._CUSTOM_REAL
- tempx2l = 0._CUSTOM_REAL
- tempx3l = 0._CUSTOM_REAL
-
- tempy1l = 0._CUSTOM_REAL
- tempy2l = 0._CUSTOM_REAL
- tempy3l = 0._CUSTOM_REAL
-
- tempz1l = 0._CUSTOM_REAL
- tempz2l = 0._CUSTOM_REAL
- tempz3l = 0._CUSTOM_REAL
-
- do l=1,NGLLX
- hp1 = hprime_xx(i,l)
- iglob = ibool(l,j,k,ispec)
- tempx1l = tempx1l + displ_inner_core(1,iglob)*hp1
- tempy1l = tempy1l + displ_inner_core(2,iglob)*hp1
- tempz1l = tempz1l + displ_inner_core(3,iglob)*hp1
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- hp2 = hprime_yy(j,l)
- iglob = ibool(i,l,k,ispec)
- tempx2l = tempx2l + displ_inner_core(1,iglob)*hp2
- tempy2l = tempy2l + displ_inner_core(2,iglob)*hp2
- tempz2l = tempz2l + displ_inner_core(3,iglob)*hp2
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- hp3 = hprime_zz(k,l)
- iglob = ibool(i,j,l,ispec)
- tempx3l = tempx3l + displ_inner_core(1,iglob)*hp3
- tempy3l = tempy3l + displ_inner_core(2,iglob)*hp3
- tempz3l = tempz3l + displ_inner_core(3,iglob)*hp3
- enddo
-
- if( ATTENUATION_VAL .and. COMPUTE_AND_STORE_STRAIN ) then
- ! temporary variables used for fixing attenuation in a consistent way
-
- tempx1l_att = tempx1l
- tempx2l_att = tempx2l
- tempx3l_att = tempx3l
-
- tempy1l_att = tempy1l
- tempy2l_att = tempy2l
- tempy3l_att = tempy3l
-
- tempz1l_att = tempz1l
- tempz2l_att = tempz2l
- tempz3l_att = tempz3l
-
- if(ATTENUATION_NEW_VAL) then
- ! takes new routines
- ! use first order Taylor expansion of displacement for local storage of stresses
- ! at this current time step, to fix attenuation in a consistent way
- do l=1,NGLLX
- hp1 = hprime_xx(i,l)
- iglob = ibool(l,j,k,ispec)
- tempx1l_att = tempx1l_att + deltat*veloc_inner_core(1,iglob)*hp1
- tempy1l_att = tempy1l_att + deltat*veloc_inner_core(2,iglob)*hp1
- tempz1l_att = tempz1l_att + deltat*veloc_inner_core(3,iglob)*hp1
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- hp2 = hprime_yy(j,l)
- iglob = ibool(i,l,k,ispec)
- tempx2l_att = tempx2l_att + deltat*veloc_inner_core(1,iglob)*hp2
- tempy2l_att = tempy2l_att + deltat*veloc_inner_core(2,iglob)*hp2
- tempz2l_att = tempz2l_att + deltat*veloc_inner_core(3,iglob)*hp2
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- hp3 = hprime_zz(k,l)
- iglob = ibool(i,j,l,ispec)
- tempx3l_att = tempx3l_att + deltat*veloc_inner_core(1,iglob)*hp3
- tempy3l_att = tempy3l_att + deltat*veloc_inner_core(2,iglob)*hp3
- tempz3l_att = tempz3l_att + deltat*veloc_inner_core(3,iglob)*hp3
- enddo
- endif
- endif
-
-! get derivatives of ux, uy and uz with respect to x, y and z
-
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
-
-! compute the jacobian
- jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
- - xiyl*(etaxl*gammazl-etazl*gammaxl) &
- + xizl*(etaxl*gammayl-etayl*gammaxl))
-
- duxdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
- duxdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
- duxdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
-
- duydxl = xixl*tempy1l + etaxl*tempy2l + gammaxl*tempy3l
- duydyl = xiyl*tempy1l + etayl*tempy2l + gammayl*tempy3l
- duydzl = xizl*tempy1l + etazl*tempy2l + gammazl*tempy3l
-
- duzdxl = xixl*tempz1l + etaxl*tempz2l + gammaxl*tempz3l
- duzdyl = xiyl*tempz1l + etayl*tempz2l + gammayl*tempz3l
- duzdzl = xizl*tempz1l + etazl*tempz2l + gammazl*tempz3l
-
-! precompute some sums to save CPU time
- duxdxl_plus_duydyl = duxdxl + duydyl
- duxdxl_plus_duzdzl = duxdxl + duzdzl
- duydyl_plus_duzdzl = duydyl + duzdzl
- duxdyl_plus_duydxl = duxdyl + duydxl
- duzdxl_plus_duxdzl = duzdxl + duxdzl
- duzdyl_plus_duydzl = duzdyl + duydzl
-
- if( ATTENUATION_VAL .and. COMPUTE_AND_STORE_STRAIN ) then
- ! temporary variables used for fixing attenuation in a consistent way
- duxdxl_att = xixl*tempx1l_att + etaxl*tempx2l_att + gammaxl*tempx3l_att
- duxdyl_att = xiyl*tempx1l_att + etayl*tempx2l_att + gammayl*tempx3l_att
- duxdzl_att = xizl*tempx1l_att + etazl*tempx2l_att + gammazl*tempx3l_att
-
- duydxl_att = xixl*tempy1l_att + etaxl*tempy2l_att + gammaxl*tempy3l_att
- duydyl_att = xiyl*tempy1l_att + etayl*tempy2l_att + gammayl*tempy3l_att
- duydzl_att = xizl*tempy1l_att + etazl*tempy2l_att + gammazl*tempy3l_att
-
- duzdxl_att = xixl*tempz1l_att + etaxl*tempz2l_att + gammaxl*tempz3l_att
- duzdyl_att = xiyl*tempz1l_att + etayl*tempz2l_att + gammayl*tempz3l_att
- duzdzl_att = xizl*tempz1l_att + etazl*tempz2l_att + gammazl*tempz3l_att
-
- ! precompute some sums to save CPU time
- duxdyl_plus_duydxl_att = duxdyl_att + duydxl_att
- duzdxl_plus_duxdzl_att = duzdxl_att + duxdzl_att
- duzdyl_plus_duydzl_att = duzdyl_att + duydzl_att
-
- ! compute deviatoric strain
- if(NSPEC_INNER_CORE_STRAIN_ONLY == 1) then
- ispec_strain = 1
- else
- ispec_strain = ispec
- endif
- epsilon_trace_over_3(i,j,k,ispec_strain) = ONE_THIRD * (duxdxl_att + duydyl_att + duzdzl_att)
- epsilondev_loc(1,i,j,k) = duxdxl_att - epsilon_trace_over_3(i,j,k,ispec_strain)
- epsilondev_loc(2,i,j,k) = duydyl_att - epsilon_trace_over_3(i,j,k,ispec_strain)
- epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl_att
- epsilondev_loc(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl_att
- epsilondev_loc(5,i,j,k) = 0.5 * duzdyl_plus_duydzl_att
- else
- ! compute deviatoric strain
- if (COMPUTE_AND_STORE_STRAIN) then
- if(NSPEC_INNER_CORE_STRAIN_ONLY == 1) then
- ispec_strain = 1
- else
- ispec_strain = ispec
- endif
- epsilon_trace_over_3(i,j,k,ispec_strain) = ONE_THIRD * (duxdxl + duydyl + duzdzl)
- epsilondev_loc(1,i,j,k) = duxdxl - epsilon_trace_over_3(i,j,k,ispec_strain)
- epsilondev_loc(2,i,j,k) = duydyl - epsilon_trace_over_3(i,j,k,ispec_strain)
- epsilondev_loc(3,i,j,k) = 0.5 * duxdyl_plus_duydxl
- epsilondev_loc(4,i,j,k) = 0.5 * duzdxl_plus_duxdzl
- epsilondev_loc(5,i,j,k) = 0.5 * duzdyl_plus_duydzl
- endif
- endif
-
- ! precompute terms for attenuation if needed
- if( ATTENUATION_VAL ) then
- if( USE_3D_ATTENUATION_ARRAYS ) then
- minus_sum_beta = one_minus_sum_beta(i,j,k,ispec) - 1.0_CUSTOM_REAL
- else
- minus_sum_beta = one_minus_sum_beta(1,1,1,ispec) - 1.0_CUSTOM_REAL
- endif
- endif
-
- if(ANISOTROPIC_INNER_CORE_VAL) then
-
-! elastic tensor for hexagonal symmetry in reduced notation:
-!
-! c11 c12 c13 0 0 0
-! c12 c11 c13 0 0 0
-! c13 c13 c33 0 0 0
-! 0 0 0 c44 0 0
-! 0 0 0 0 c44 0
-! 0 0 0 0 0 (c11-c12)/2
-!
-! in terms of the A, C, L, N and F of Love (1927):
-!
-! c11 = A
-! c12 = A-2N
-! c13 = F
-! c33 = C
-! c44 = L
-
- c11l = c11store(i,j,k,ispec)
- c12l = c12store(i,j,k,ispec)
- c13l = c13store(i,j,k,ispec)
- c33l = c33store(i,j,k,ispec)
- c44l = c44store(i,j,k,ispec)
-
-! use unrelaxed parameters if attenuation
- if(ATTENUATION_VAL) then
- mul = muvstore(i,j,k,ispec)
- c11l = c11l + FOUR_THIRDS * minus_sum_beta * mul
- c12l = c12l - TWO_THIRDS * minus_sum_beta * mul
- c13l = c13l - TWO_THIRDS * minus_sum_beta * mul
- c33l = c33l + FOUR_THIRDS * minus_sum_beta * mul
- c44l = c44l + minus_sum_beta * mul
- endif
-
- sigma_xx = c11l*duxdxl + c12l*duydyl + c13l*duzdzl
- sigma_yy = c12l*duxdxl + c11l*duydyl + c13l*duzdzl
- sigma_zz = c13l*duxdxl + c13l*duydyl + c33l*duzdzl
- sigma_xy = 0.5*(c11l-c12l)*duxdyl_plus_duydxl
- sigma_xz = c44l*duzdxl_plus_duxdzl
- sigma_yz = c44l*duzdyl_plus_duydzl
- else
-
-! inner core with no anisotropy, use kappav and muv for instance
-! layer with no anisotropy, use kappav and muv for instance
- kappal = kappavstore(i,j,k,ispec)
- mul = muvstore(i,j,k,ispec)
-
- ! use unrelaxed parameters if attenuation
- if( ATTENUATION_VAL ) then
- if( USE_3D_ATTENUATION_ARRAYS ) then
- mul = mul * one_minus_sum_beta(i,j,k,ispec)
- else
- mul = mul * one_minus_sum_beta(1,1,1,ispec)
- endif
- endif
-
- lambdalplus2mul = kappal + FOUR_THIRDS * mul
- lambdal = lambdalplus2mul - 2.*mul
-
-! compute stress sigma
-
- sigma_xx = lambdalplus2mul*duxdxl + lambdal*duydyl_plus_duzdzl
- sigma_yy = lambdalplus2mul*duydyl + lambdal*duxdxl_plus_duzdzl
- sigma_zz = lambdalplus2mul*duzdzl + lambdal*duxdxl_plus_duydyl
-
- sigma_xy = mul*duxdyl_plus_duydxl
- sigma_xz = mul*duzdxl_plus_duxdzl
- sigma_yz = mul*duzdyl_plus_duydzl
-
- endif
-
-! subtract memory variables if attenuation
- if(ATTENUATION_VAL .and. ( USE_ATTENUATION_MIMIC .eqv. .false. ) ) then
- do i_SLS = 1,N_SLS
- R_xx_val = R_xx(i_SLS,i,j,k,ispec)
- R_yy_val = R_yy(i_SLS,i,j,k,ispec)
- sigma_xx = sigma_xx - R_xx_val
- sigma_yy = sigma_yy - R_yy_val
- sigma_zz = sigma_zz + R_xx_val + R_yy_val
- sigma_xy = sigma_xy - R_xy(i_SLS,i,j,k,ispec)
- sigma_xz = sigma_xz - R_xz(i_SLS,i,j,k,ispec)
- sigma_yz = sigma_yz - R_yz(i_SLS,i,j,k,ispec)
- enddo
- endif
-
-! define symmetric components of sigma for gravity
- sigma_yx = sigma_xy
- sigma_zx = sigma_xz
- sigma_zy = sigma_yz
-
-! compute non-symmetric terms for gravity
- if(GRAVITY_VAL) then
-
-! use mesh coordinates to get theta and phi
-! x y and z contain r theta and phi
-
- iglob = ibool(i,j,k,ispec)
- radius = dble(xstore(iglob))
- theta = dble(ystore(iglob))
- phi = dble(zstore(iglob))
-
-! make sure radius is never zero even for points at center of cube
-! because we later divide by radius
- if(radius < 100.d0 / R_EARTH) radius = 100.d0 / R_EARTH
-
- cos_theta = dcos(theta)
- sin_theta = dsin(theta)
- cos_phi = dcos(phi)
- sin_phi = dsin(phi)
-
-! get g, rho and dg/dr=dg
-! spherical components of the gravitational acceleration
-! for efficiency replace with lookup table every 100 m in radial direction
-! make sure we never use zero for point exactly at the center of the Earth
- int_radius = max(1,nint(radius * R_EARTH_KM * 10.d0))
- minus_g = minus_gravity_table(int_radius)
- minus_dg = minus_deriv_gravity_table(int_radius)
- rho = density_table(int_radius)
-
-! Cartesian components of the gravitational acceleration
- gxl = minus_g*sin_theta*cos_phi
- gyl = minus_g*sin_theta*sin_phi
- gzl = minus_g*cos_theta
-
-! Cartesian components of gradient of gravitational acceleration
-! obtained from spherical components
-
- minus_g_over_radius = minus_g / radius
- minus_dg_plus_g_over_radius = minus_dg - minus_g_over_radius
-
- cos_theta_sq = cos_theta**2
- sin_theta_sq = sin_theta**2
- cos_phi_sq = cos_phi**2
- sin_phi_sq = sin_phi**2
-
- Hxxl = minus_g_over_radius*(cos_phi_sq*cos_theta_sq + sin_phi_sq) + cos_phi_sq*minus_dg*sin_theta_sq
- Hyyl = minus_g_over_radius*(cos_phi_sq + cos_theta_sq*sin_phi_sq) + minus_dg*sin_phi_sq*sin_theta_sq
- Hzzl = cos_theta_sq*minus_dg + minus_g_over_radius*sin_theta_sq
- Hxyl = cos_phi*minus_dg_plus_g_over_radius*sin_phi*sin_theta_sq
- Hxzl = cos_phi*cos_theta*minus_dg_plus_g_over_radius*sin_theta
- Hyzl = cos_theta*minus_dg_plus_g_over_radius*sin_phi*sin_theta
-
- iglob = ibool(i,j,k,ispec)
-
-! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
-
-! get displacement and multiply by density to compute G tensor
- sx_l = rho * dble(displ_inner_core(1,iglob))
- sy_l = rho * dble(displ_inner_core(2,iglob))
- sz_l = rho * dble(displ_inner_core(3,iglob))
-
-! compute G tensor from s . g and add to sigma (not symmetric)
- sigma_xx = sigma_xx + sngl(sy_l*gyl + sz_l*gzl)
- sigma_yy = sigma_yy + sngl(sx_l*gxl + sz_l*gzl)
- sigma_zz = sigma_zz + sngl(sx_l*gxl + sy_l*gyl)
-
- sigma_xy = sigma_xy - sngl(sx_l * gyl)
- sigma_yx = sigma_yx - sngl(sy_l * gxl)
-
- sigma_xz = sigma_xz - sngl(sx_l * gzl)
- sigma_zx = sigma_zx - sngl(sz_l * gxl)
-
- sigma_yz = sigma_yz - sngl(sy_l * gzl)
- sigma_zy = sigma_zy - sngl(sz_l * gyl)
-
-! precompute vector
- factor = dble(jacobianl) * wgll_cube(i,j,k)
- rho_s_H(1,i,j,k) = sngl(factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl))
- rho_s_H(2,i,j,k) = sngl(factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl))
- rho_s_H(3,i,j,k) = sngl(factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl))
-
- else
-
-! get displacement and multiply by density to compute G tensor
- sx_l = rho * displ_inner_core(1,iglob)
- sy_l = rho * displ_inner_core(2,iglob)
- sz_l = rho * displ_inner_core(3,iglob)
-
-! compute G tensor from s . g and add to sigma (not symmetric)
- sigma_xx = sigma_xx + sy_l*gyl + sz_l*gzl
- sigma_yy = sigma_yy + sx_l*gxl + sz_l*gzl
- sigma_zz = sigma_zz + sx_l*gxl + sy_l*gyl
-
- sigma_xy = sigma_xy - sx_l * gyl
- sigma_yx = sigma_yx - sy_l * gxl
-
- sigma_xz = sigma_xz - sx_l * gzl
- sigma_zx = sigma_zx - sz_l * gxl
-
- sigma_yz = sigma_yz - sy_l * gzl
- sigma_zy = sigma_zy - sz_l * gyl
-
-! precompute vector
- factor = jacobianl * wgll_cube(i,j,k)
- rho_s_H(1,i,j,k) = factor * (sx_l * Hxxl + sy_l * Hxyl + sz_l * Hxzl)
- rho_s_H(2,i,j,k) = factor * (sx_l * Hxyl + sy_l * Hyyl + sz_l * Hyzl)
- rho_s_H(3,i,j,k) = factor * (sx_l * Hxzl + sy_l * Hyzl + sz_l * Hzzl)
-
- endif
-
- endif ! end of section with gravity terms
-
-! form dot product with test vector, non-symmetric form
-
- tempx1(i,j,k) = jacobianl * (sigma_xx*xixl + sigma_yx*xiyl + sigma_zx*xizl)
- tempy1(i,j,k) = jacobianl * (sigma_xy*xixl + sigma_yy*xiyl + sigma_zy*xizl)
- tempz1(i,j,k) = jacobianl * (sigma_xz*xixl + sigma_yz*xiyl + sigma_zz*xizl)
-
- tempx2(i,j,k) = jacobianl * (sigma_xx*etaxl + sigma_yx*etayl + sigma_zx*etazl)
- tempy2(i,j,k) = jacobianl * (sigma_xy*etaxl + sigma_yy*etayl + sigma_zy*etazl)
- tempz2(i,j,k) = jacobianl * (sigma_xz*etaxl + sigma_yz*etayl + sigma_zz*etazl)
-
- tempx3(i,j,k) = jacobianl * (sigma_xx*gammaxl + sigma_yx*gammayl + sigma_zx*gammazl)
- tempy3(i,j,k) = jacobianl * (sigma_xy*gammaxl + sigma_yy*gammayl + sigma_zy*gammazl)
- tempz3(i,j,k) = jacobianl * (sigma_xz*gammaxl + sigma_yz*gammayl + sigma_zz*gammazl)
-
- enddo
- enddo
- enddo
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- tempx1l = 0._CUSTOM_REAL
- tempy1l = 0._CUSTOM_REAL
- tempz1l = 0._CUSTOM_REAL
-
- tempx2l = 0._CUSTOM_REAL
- tempy2l = 0._CUSTOM_REAL
- tempz2l = 0._CUSTOM_REAL
-
- tempx3l = 0._CUSTOM_REAL
- tempy3l = 0._CUSTOM_REAL
- tempz3l = 0._CUSTOM_REAL
-
- do l=1,NGLLX
- fac1 = hprimewgll_xx(l,i)
- tempx1l = tempx1l + tempx1(l,j,k)*fac1
- tempy1l = tempy1l + tempy1(l,j,k)*fac1
- tempz1l = tempz1l + tempz1(l,j,k)*fac1
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLY
- fac2 = hprimewgll_yy(l,j)
- tempx2l = tempx2l + tempx2(i,l,k)*fac2
- tempy2l = tempy2l + tempy2(i,l,k)*fac2
- tempz2l = tempz2l + tempz2(i,l,k)*fac2
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
-
-!!! can merge these loops because NGLLX = NGLLY = NGLLZ do l=1,NGLLZ
- fac3 = hprimewgll_zz(l,k)
- tempx3l = tempx3l + tempx3(i,j,l)*fac3
- tempy3l = tempy3l + tempy3(i,j,l)*fac3
- tempz3l = tempz3l + tempz3(i,j,l)*fac3
- enddo
-
- fac1 = wgllwgll_yz(j,k)
- fac2 = wgllwgll_xz(i,k)
- fac3 = wgllwgll_xy(i,j)
-
- sum_terms(1,i,j,k) = - (fac1*tempx1l + fac2*tempx2l + fac3*tempx3l)
- sum_terms(2,i,j,k) = - (fac1*tempy1l + fac2*tempy2l + fac3*tempy3l)
- sum_terms(3,i,j,k) = - (fac1*tempz1l + fac2*tempz2l + fac3*tempz3l)
-
- if(GRAVITY_VAL) sum_terms(:,i,j,k) = sum_terms(:,i,j,k) + rho_s_H(:,i,j,k)
-
- enddo
- enddo
- enddo
-
-! sum contributions from each element to the global mesh and add gravity terms
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- iglob = ibool(i,j,k,ispec)
- accel_inner_core(:,iglob) = accel_inner_core(:,iglob) + sum_terms(:,i,j,k)
- enddo
- enddo
- enddo
-
-! use Runge-Kutta scheme to march memory variables in time
-! convention for attenuation
-! term in xx = 1
-! term in yy = 2
-! term in xy = 3
-! term in xz = 4
-! term in yz = 5
-! term in zz not computed since zero trace
-! This is because we only implement Q_\mu attenuation and not Q_\kappa.
-! Note that this does *NOT* imply that there is no attenuation for P waves
-! because for Q_\kappa = infinity one gets (see for instance Dahlen and Tromp (1998)
-! equation (9.59) page 350): Q_\alpha = Q_\mu * 3 * (V_p/V_s)^2 / 4
-! therefore Q_\alpha is not zero; for instance for V_p / V_s = sqrt(3)
-! we get Q_\alpha = (9 / 4) * Q_\mu = 2.25 * Q_\mu
-
- if(ATTENUATION_VAL .and. ( USE_ATTENUATION_MIMIC .eqv. .false. )) then
-
- do i_SLS = 1,N_SLS
-
- ! reformatted R_memory to handle large factor_common and reduced [alpha,beta,gamma]val
- if (USE_3D_ATTENUATION_ARRAYS) then
- factor_common_use(:,:,:) = factor_common(i_SLS,:,:,:,ispec) * muvstore(:,:,:,ispec)
- else
- factor_common_use(:,:,:) = factor_common(i_SLS,1,1,1,ispec) * muvstore(:,:,:,ispec)
- endif
-
-! do i_memory = 1,5
-! R_memory(i_memory,i_SLS,:,:,:,ispec) = &
-! alphaval(i_SLS) * &
-! R_memory(i_memory,i_SLS,:,:,:,ispec) + muvstore(:,:,:,ispec) * &
-! factor_common_use * &
-! (betaval(i_SLS) * &
-! epsilondev(i_memory,:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(i_memory,:,:,:))
-! enddo
-
- R_xx(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xx(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xx(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(1,:,:,:))
-
- R_yy(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_yy(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
- (betaval(i_SLS) * epsilondev_yy(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(2,:,:,:))
-
- R_xy(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xy(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xy(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(3,:,:,:))
-
- R_xz(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_xz(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
- (betaval(i_SLS) * epsilondev_xz(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(4,:,:,:))
-
- R_yz(i_SLS,:,:,:,ispec) = alphaval(i_SLS) * R_yz(i_SLS,:,:,:,ispec) + factor_common_use(:,:,:) * &
- (betaval(i_SLS) * epsilondev_yz(:,:,:,ispec) + gammaval(i_SLS) * epsilondev_loc(5,:,:,:))
-
- enddo
-
- endif
-
- if (COMPUTE_AND_STORE_STRAIN) then
-! save deviatoric strain for Runge-Kutta scheme
- !epsilondev(:,:,:,:,ispec) = epsilondev_loc(:,:,:,:)
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
- epsilondev_xx(i,j,k,ispec) = epsilondev_loc(1,i,j,k)
- epsilondev_yy(i,j,k,ispec) = epsilondev_loc(2,i,j,k)
- epsilondev_xy(i,j,k,ispec) = epsilondev_loc(3,i,j,k)
- epsilondev_xz(i,j,k,ispec) = epsilondev_loc(4,i,j,k)
- epsilondev_yz(i,j,k,ispec) = epsilondev_loc(5,i,j,k)
- enddo
- enddo
- enddo
-
- endif
-
- endif ! end test to exclude fictitious elements in central cube
-
- enddo ! spectral element loop
-
- end subroutine compute_forces_inner_core
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_outer_core.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_outer_core.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/compute_forces_outer_core.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,339 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 compute_forces_outer_core(time,deltat,two_omega_earth, &
- NSPEC,NGLOB, &
- A_array_rotation,B_array_rotation, &
- displfluid,accelfluid, &
- div_displfluid,phase_is_inner)
-
- use constants_solver
-
- use specfem_par,only: &
- hprime_xx,hprime_yy,hprime_zz,hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube, &
- minus_rho_g_over_kappa_fluid,d_ln_density_dr_table, &
- MOVIE_VOLUME
-
- use specfem_par_outercore,only: &
- xstore => xstore_outer_core,ystore => ystore_outer_core,zstore => zstore_outer_core, &
- xix => xix_outer_core,xiy => xiy_outer_core,xiz => xiz_outer_core, &
- etax => etax_outer_core,etay => etay_outer_core,etaz => etaz_outer_core, &
- gammax => gammax_outer_core,gammay => gammay_outer_core,gammaz => gammaz_outer_core, &
- ibool => ibool_outer_core, &
- phase_ispec_inner => phase_ispec_inner_outer_core, &
- nspec_outer => nspec_outer_outer_core, &
- nspec_inner => nspec_inner_outer_core
-
- implicit none
-
- integer :: NSPEC,NGLOB
-
- ! for the Euler scheme for rotation
- real(kind=CUSTOM_REAL) time,deltat,two_omega_earth
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC) :: &
- A_array_rotation,B_array_rotation
-
- ! displacement and acceleration
- real(kind=CUSTOM_REAL), dimension(NGLOB) :: displfluid,accelfluid
-
- ! divergence of displacement
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ,NSPEC_OUTER_CORE_ADJOINT) :: div_displfluid
-
- ! inner/outer element run flag
- logical :: phase_is_inner
-
- ! local parameters
-
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: tempx1,tempx2,tempx3
- ! for gravity
- integer int_radius
- double precision radius,theta,phi,gxl,gyl,gzl
- double precision cos_theta,sin_theta,cos_phi,sin_phi
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: gravity_term
- ! for the Euler scheme for rotation
- real(kind=CUSTOM_REAL) two_omega_deltat,cos_two_omega_t,sin_two_omega_t,A_rotation,B_rotation, &
- ux_rotation,uy_rotation,dpotentialdx_with_rot,dpotentialdy_with_rot
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY,NGLLZ) :: source_euler_A,source_euler_B
-
- integer ispec,iglob
- integer i,j,k,l
-
- real(kind=CUSTOM_REAL) xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- real(kind=CUSTOM_REAL) dpotentialdxl,dpotentialdyl,dpotentialdzl
- real(kind=CUSTOM_REAL) tempx1l,tempx2l,tempx3l,sum_terms
-
- double precision grad_x_ln_rho,grad_y_ln_rho,grad_z_ln_rho
-
-! integer :: computed_elements
- integer :: num_elements,ispec_p
- integer :: iphase
-
-! ****************************************************
-! big loop over all spectral elements in the fluid
-! ****************************************************
-
- if (NSPEC_OUTER_CORE_ADJOINT /= 1 .and. ( .not. phase_is_inner )) div_displfluid(:,:,:,:) = 0._CUSTOM_REAL
-
-! computed_elements = 0
- if( .not. phase_is_inner ) then
- iphase = 1
- num_elements = nspec_outer
- else
- iphase = 2
- num_elements = nspec_inner
- endif
-
- do ispec_p = 1,num_elements
-
- ispec = phase_ispec_inner(ispec_p,iphase)
-
- ! only compute element which belong to current phase (inner or outer elements)
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- tempx1l = 0._CUSTOM_REAL
- tempx2l = 0._CUSTOM_REAL
- tempx3l = 0._CUSTOM_REAL
-
- do l=1,NGLLX
- !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
- tempx1l = tempx1l + displfluid(ibool(l,j,k,ispec)) * hprime_xx(i,l)
- tempx2l = tempx2l + displfluid(ibool(i,l,k,ispec)) * hprime_yy(j,l)
- tempx3l = tempx3l + displfluid(ibool(i,j,l,ispec)) * hprime_zz(k,l)
- enddo
-
- ! get derivatives of velocity potential with respect to x, y and z
- xixl = xix(i,j,k,ispec)
- xiyl = xiy(i,j,k,ispec)
- xizl = xiz(i,j,k,ispec)
- etaxl = etax(i,j,k,ispec)
- etayl = etay(i,j,k,ispec)
- etazl = etaz(i,j,k,ispec)
- gammaxl = gammax(i,j,k,ispec)
- gammayl = gammay(i,j,k,ispec)
- gammazl = gammaz(i,j,k,ispec)
-
- ! compute the jacobian
- jacobianl = 1._CUSTOM_REAL / (xixl*(etayl*gammazl-etazl*gammayl) &
- - xiyl*(etaxl*gammazl-etazl*gammaxl) &
- + xizl*(etaxl*gammayl-etayl*gammaxl))
-
- dpotentialdxl = xixl*tempx1l + etaxl*tempx2l + gammaxl*tempx3l
- dpotentialdyl = xiyl*tempx1l + etayl*tempx2l + gammayl*tempx3l
- dpotentialdzl = xizl*tempx1l + etazl*tempx2l + gammazl*tempx3l
-
- ! compute contribution of rotation and add to gradient of potential
- ! this term has no Z component
- if(ROTATION_VAL) then
-
- ! store the source for the Euler scheme for A_rotation and B_rotation
- two_omega_deltat = deltat * two_omega_earth
-
- cos_two_omega_t = cos(two_omega_earth*time)
- sin_two_omega_t = sin(two_omega_earth*time)
-
- ! time step deltat of Euler scheme is included in the source
- source_euler_A(i,j,k) = two_omega_deltat &
- * (cos_two_omega_t * dpotentialdyl + sin_two_omega_t * dpotentialdxl)
- source_euler_B(i,j,k) = two_omega_deltat &
- * (sin_two_omega_t * dpotentialdyl - cos_two_omega_t * dpotentialdxl)
-
- A_rotation = A_array_rotation(i,j,k,ispec)
- B_rotation = B_array_rotation(i,j,k,ispec)
-
- ux_rotation = A_rotation*cos_two_omega_t + B_rotation*sin_two_omega_t
- uy_rotation = - A_rotation*sin_two_omega_t + B_rotation*cos_two_omega_t
-
- dpotentialdx_with_rot = dpotentialdxl + ux_rotation
- dpotentialdy_with_rot = dpotentialdyl + uy_rotation
-
- else
-
- dpotentialdx_with_rot = dpotentialdxl
- dpotentialdy_with_rot = dpotentialdyl
-
- endif ! end of section with rotation
-
- ! add (chi/rho)grad(rho) term in no gravity case
- if(.not. GRAVITY_VAL) then
- ! With regards to the non-gravitating case: we cannot set N^2 = 0 *and* let g = 0.
- ! We can *either* assume N^2 = 0 but keep gravity g, *or* we can assume that gravity
- ! is negligible to begin with, as in our GJI 2002a, in which case N does not arise.
- ! We get:
- !
- ! \ddot\chi = \rho^{-1}\kappa\bdel\cdot(\bdel\chi+\chi\bdel\ln\rho)
- !
- ! Then the displacement is
- !
- ! \bu = \bdel\chi+\chi\bdel\ln\rho = \rho^{-1}\bdel(\rho\chi)
- !
- ! and the pressure is
- !
- ! p = -\rho\ddot{\chi}
- !
- ! Thus in our 2002b GJI paper eqn (21) is wrong, and equation (41)
- ! in our AGU monograph is incorrect; these equations should be replaced by
- !
- ! \ddot\chi = \rho^{-1}\kappa\bdel\cdot(\bdel\chi+\chi\bdel\ln\rho)
- !
- ! Note that the fluid potential we use in GJI 2002a differs from the one used here:
- !
- ! \chi_GJI2002a = \rho\partial\t\chi
- !
- ! such that
- !
- ! \bv = \partial_t\bu=\rho^{-1}\bdel\chi_GJI2002a (GJI 2002a eqn 20)
- !
- ! p = - \partial_t\chi_GJI2002a (GJI 2002a eqn 19)
-
- ! use mesh coordinates to get theta and phi
- ! x y z contain r theta phi
- iglob = ibool(i,j,k,ispec)
-
- radius = dble(xstore(iglob))
- theta = dble(ystore(iglob))
- phi = dble(zstore(iglob))
-
- cos_theta = dcos(theta)
- sin_theta = dsin(theta)
- cos_phi = dcos(phi)
- sin_phi = dsin(phi)
-
- int_radius = nint(radius * R_EARTH_KM * 10.d0)
-
- ! grad(rho)/rho in Cartesian components
- grad_x_ln_rho = sin_theta * cos_phi * d_ln_density_dr_table(int_radius)
- grad_y_ln_rho = sin_theta * sin_phi * d_ln_density_dr_table(int_radius)
- grad_z_ln_rho = cos_theta * d_ln_density_dr_table(int_radius)
-
- ! adding (chi/rho)grad(rho)
- dpotentialdx_with_rot = dpotentialdx_with_rot + displfluid(iglob) * grad_x_ln_rho
- dpotentialdy_with_rot = dpotentialdy_with_rot + displfluid(iglob) * grad_y_ln_rho
- dpotentialdzl = dpotentialdzl + displfluid(iglob) * grad_z_ln_rho
-
-
- else ! if gravity is turned on
-
- ! compute divergence of displacment
- ! precompute and store gravity term
-
- ! use mesh coordinates to get theta and phi
- ! x y z contain r theta phi
- iglob = ibool(i,j,k,ispec)
-
- radius = dble(xstore(iglob))
- theta = dble(ystore(iglob))
- phi = dble(zstore(iglob))
-
- cos_theta = dcos(theta)
- sin_theta = dsin(theta)
- cos_phi = dcos(phi)
- sin_phi = dsin(phi)
-
- ! get g, rho and dg/dr=dg
- ! spherical components of the gravitational acceleration
- ! for efficiency replace with lookup table every 100 m in radial direction
- int_radius = nint(radius * R_EARTH_KM * 10.d0)
-
- ! Cartesian components of the gravitational acceleration
- ! integrate and multiply by rho / Kappa
- gxl = sin_theta*cos_phi
- gyl = sin_theta*sin_phi
- gzl = cos_theta
-
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- gravity_term(i,j,k) = &
- sngl(minus_rho_g_over_kappa_fluid(int_radius) * &
- dble(jacobianl) * wgll_cube(i,j,k) * &
- (dble(dpotentialdx_with_rot) * gxl + &
- dble(dpotentialdy_with_rot) * gyl + dble(dpotentialdzl) * gzl))
- else
- gravity_term(i,j,k) = minus_rho_g_over_kappa_fluid(int_radius) * &
- jacobianl * wgll_cube(i,j,k) * (dpotentialdx_with_rot * gxl + &
- dpotentialdy_with_rot * gyl + dpotentialdzl * gzl)
- endif
-
- ! divergence of displacement field with gravity on
- ! note: these calculations are only considered for SIMULATION_TYPE == 1 .and. SAVE_FORWARD
- ! and one has set MOVIE_VOLUME_TYPE == 4 when MOVIE_VOLUME is .true.;
- ! in case of SIMULATION_TYPE == 3, it gets overwritten by compute_kernels_outer_core()
- if (NSPEC_OUTER_CORE_ADJOINT /= 1 .and. MOVIE_VOLUME ) then
- div_displfluid(i,j,k,ispec) = &
- minus_rho_g_over_kappa_fluid(int_radius) * (dpotentialdx_with_rot * gxl + &
- dpotentialdy_with_rot * gyl + dpotentialdzl * gzl)
- endif
-
- endif
-
- tempx1(i,j,k) = jacobianl*(xixl*dpotentialdx_with_rot + xiyl*dpotentialdy_with_rot + xizl*dpotentialdzl)
- tempx2(i,j,k) = jacobianl*(etaxl*dpotentialdx_with_rot + etayl*dpotentialdy_with_rot + etazl*dpotentialdzl)
- tempx3(i,j,k) = jacobianl*(gammaxl*dpotentialdx_with_rot + gammayl*dpotentialdy_with_rot + gammazl*dpotentialdzl)
-
- enddo
- enddo
- enddo
-
- do k=1,NGLLZ
- do j=1,NGLLY
- do i=1,NGLLX
-
- tempx1l = 0._CUSTOM_REAL
- tempx2l = 0._CUSTOM_REAL
- tempx3l = 0._CUSTOM_REAL
-
- do l=1,NGLLX
- !!! can merge these loops because NGLLX = NGLLY = NGLLZ enddo
- tempx1l = tempx1l + tempx1(l,j,k) * hprimewgll_xx(l,i)
- tempx2l = tempx2l + tempx2(i,l,k) * hprimewgll_yy(l,j)
- tempx3l = tempx3l + tempx3(i,j,l) * hprimewgll_zz(l,k)
- enddo
-
- ! sum contributions from each element to the global mesh and add gravity term
- sum_terms = - (wgllwgll_yz(j,k)*tempx1l + wgllwgll_xz(i,k)*tempx2l + wgllwgll_xy(i,j)*tempx3l)
- if(GRAVITY_VAL) sum_terms = sum_terms + gravity_term(i,j,k)
-
- accelfluid(ibool(i,j,k,ispec)) = accelfluid(ibool(i,j,k,ispec)) + sum_terms
-
- enddo
- enddo
- enddo
-
- ! update rotation term with Euler scheme
- if(ROTATION_VAL) then
- ! use the source saved above
- A_array_rotation(:,:,:,ispec) = A_array_rotation(:,:,:,ispec) + source_euler_A(:,:,:)
- B_array_rotation(:,:,:,ispec) = B_array_rotation(:,:,:,ispec) + source_euler_B(:,:,:)
- endif
-
- enddo ! spectral element loop
-
- end subroutine compute_forces_outer_core
-
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/finalize_simulation.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/finalize_simulation.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/finalize_simulation.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,274 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 finalize_simulation()
-
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
- use specfem_par_movie
- implicit none
-
- ! synchronize all processes, waits until all processes have written their seismograms
- call sync_all()
-
- ! closes Stacey absorbing boundary snapshots
- if( ABSORBING_CONDITIONS ) then
- ! crust mantle
- if (nspec2D_xmin_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(0)
- endif
-
- if (nspec2D_xmax_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(1)
- endif
-
- if (nspec2D_ymin_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(2)
- endif
-
- if (nspec2D_ymax_crust_mantle > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(3)
- endif
-
- ! outer core
- if (nspec2D_xmin_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(4)
- endif
-
- if (nspec2D_xmax_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(5)
- endif
-
- if (nspec2D_ymin_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(6)
- endif
-
- if (nspec2D_ymax_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(7)
- endif
-
- if (nspec2D_zmin_outer_core > 0 .and. (SIMULATION_TYPE == 3 &
- .or. (SIMULATION_TYPE == 1 .and. SAVE_FORWARD))) then
- call close_file_abs(8)
- endif
-
- ! frees memory
- deallocate(absorb_xmin_crust_mantle, &
- absorb_xmax_crust_mantle, &
- absorb_ymin_crust_mantle, &
- absorb_ymax_crust_mantle, &
- absorb_xmin_outer_core, &
- absorb_xmax_outer_core, &
- absorb_ymin_outer_core, &
- absorb_ymax_outer_core, &
- absorb_zmin_outer_core)
- endif
-
- ! save/read the surface movie using the same c routine as we do for absorbing boundaries (file ID is 9)
- if (NOISE_TOMOGRAPHY/=0) then
- call close_file_abs(9)
- endif
-
- ! save files to local disk or tape system if restart file
- call save_forward_arrays()
-
- ! dump kernel arrays
- if (SIMULATION_TYPE == 3) then
- ! crust mantle
- call save_kernels_crust_mantle()
-
- ! noise strength kernel
- if (NOISE_TOMOGRAPHY == 3) then
- call save_kernels_strength_noise()
- endif
-
- ! outer core
- call save_kernels_outer_core()
-
- ! inner core
- call save_kernels_inner_core()
-
- ! boundary kernel
- if (SAVE_BOUNDARY_MESH) then
- call save_kernels_boundary_kl()
- endif
-
- ! approximate hessian
- if( APPROXIMATE_HESS_KL ) then
- call save_kernels_hessian()
- endif
- endif
-
- ! save source derivatives for adjoint simulations
- if (SIMULATION_TYPE == 2 .and. nrec_local > 0) then
- call save_kernels_source_derivatives()
- endif
-
- ! frees dynamically allocated memory
-
- ! mass matrices
- deallocate(rmassx_crust_mantle)
- deallocate(rmassy_crust_mantle)
- deallocate(rmassz_crust_mantle)
-
- deallocate(rmass_outer_core)
- deallocate(rmass_inner_core)
-
-
- ! mpi buffers
- deallocate(buffer_send_vector_crust_mantle,buffer_recv_vector_crust_mantle, &
- request_send_vector_cm,request_recv_vector_cm)
- deallocate(buffer_send_scalar_outer_core,buffer_recv_scalar_outer_core, &
- request_send_scalar_oc,request_recv_scalar_oc)
- deallocate(buffer_send_vector_inner_core,buffer_recv_vector_inner_core, &
- request_send_vector_ic,request_recv_vector_ic)
-
- if( SIMULATION_TYPE == 3 ) then
- deallocate(b_buffer_send_vector_cm,b_buffer_recv_vector_cm, &
- b_request_send_vector_cm,b_request_recv_vector_cm)
- deallocate(b_buffer_send_scalar_outer_core,b_buffer_recv_scalar_outer_core, &
- b_request_send_scalar_oc,b_request_recv_scalar_oc)
- deallocate(b_buffer_send_vector_inner_core,b_buffer_recv_vector_inner_core, &
- b_request_send_vector_ic,b_request_recv_vector_ic)
- endif
-
- deallocate(my_neighbours_crust_mantle,nibool_interfaces_crust_mantle)
- deallocate(ibool_interfaces_crust_mantle)
- deallocate(my_neighbours_outer_core,nibool_interfaces_outer_core)
- deallocate(ibool_interfaces_outer_core)
- deallocate(my_neighbours_inner_core,nibool_interfaces_inner_core)
- deallocate(ibool_interfaces_inner_core)
-
- ! inner/outer elements
- deallocate(phase_ispec_inner_crust_mantle)
- deallocate(phase_ispec_inner_outer_core)
- deallocate(phase_ispec_inner_inner_core)
-
- ! coloring
- deallocate(num_elem_colors_crust_mantle)
- deallocate(num_elem_colors_outer_core)
- deallocate(num_elem_colors_inner_core)
-
- ! sources
- deallocate(islice_selected_source, &
- ispec_selected_source, &
- Mxx,Myy,Mzz,Mxy,Mxz,Myz)
- deallocate(xi_source,eta_source,gamma_source)
- deallocate(tshift_cmt,hdur,hdur_gaussian)
- deallocate(nu_source)
-
- if (SIMULATION_TYPE == 1 .or. SIMULATION_TYPE == 3) deallocate(sourcearrays)
- if (SIMULATION_TYPE == 2 .or. SIMULATION_TYPE == 3) then
- deallocate(iadj_vec)
- if(nadj_rec_local > 0) then
- deallocate(adj_sourcearrays)
- deallocate(iadjsrc,iadjsrc_len)
- endif
- endif
-
- ! receivers
- deallocate(islice_selected_rec,ispec_selected_rec, &
- xi_receiver,eta_receiver,gamma_receiver)
- deallocate(station_name,network_name, &
- stlat,stlon,stele,stbur)
- deallocate(nu,number_receiver_global)
-
- if( nrec_local > 0 ) then
- deallocate(hxir_store, &
- hetar_store, &
- hgammar_store)
- if( SIMULATION_TYPE == 2 ) then
- deallocate(moment_der,stshift_der)
- endif
- endif
- deallocate(seismograms)
-
- if (SIMULATION_TYPE == 3) then
- if( APPROXIMATE_HESS_KL ) then
- deallocate(hess_kl_crust_mantle)
- endif
- deallocate(beta_kl_outer_core)
- endif
-
- ! movies
- if(MOVIE_SURFACE .or. NOISE_TOMOGRAPHY /= 0 ) then
- deallocate(store_val_x,store_val_y,store_val_z, &
- store_val_ux,store_val_uy,store_val_uz)
- if (MOVIE_SURFACE) then
- deallocate(store_val_x_all,store_val_y_all,store_val_z_all, &
- store_val_ux_all,store_val_uy_all,store_val_uz_all)
- endif
- endif
- if(MOVIE_VOLUME) then
- deallocate(nu_3dmovie)
- endif
-
- ! noise simulations
- if ( NOISE_TOMOGRAPHY /= 0 ) then
- deallocate(noise_sourcearray, &
- normal_x_noise,normal_y_noise,normal_z_noise, &
- mask_noise,noise_surface_movie)
- endif
-
- ! vtk visualization
- if( VTK_MODE ) then
- ! closes/cleans up vtk window
- if(myrank == 0 ) call finish_vtkwindow()
-
- ! frees memory
- deallocate(vtkdata,vtkmask)
- if( NPROCTOT_VAL > 1 ) then
- deallocate(vtkdata_points_all,vtkdata_offset_all)
- if( myrank == 0 ) deallocate(vtkdata_all)
- endif
- endif
-
- ! close the main output file
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'End of the simulation'
- write(IMAIN,*)
- close(IMAIN)
- endif
-
- ! synchronize all the processes to make sure everybody has finished
- call sync_all()
-
- if (ADIOS_ENABLED) then
- call adios_cleanup()
- endif
- end subroutine finalize_simulation
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_topography_bathymetry.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_topography_bathymetry.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/read_topography_bathymetry.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,85 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 read_topography_bathymetry()
-
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
- implicit none
-
- include 'mpif.h'
-
- ! local parameters
- integer :: ier
- ! timing
- double precision, external :: wtime
-
- ! get MPI starting time
- time_start = wtime()
-
- ! make ellipticity
- if( ELLIPTICITY_VAL ) then
- ! splines used for locating exact source/receivers positions
- ! in locate_sources() and locate_receivers() routines
- call make_ellipticity(nspl,rspl,espl,espl2,ONE_CRUST)
- endif
-
- ! read topography and bathymetry file
- if( TOPOGRAPHY ) then
- ! allocates topography array
- allocate(ibathy_topo(NX_BATHY,NY_BATHY),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating ibathy_topo array')
-
- ! initializes
- ibathy_topo(:,:) = 0
-
- ! master reads file
- if(myrank == 0 ) then
- ! user output
- write(IMAIN,*) 'topography:'
-
- ! reads topo file
- call read_topo_bathy_database(ibathy_topo,LOCAL_PATH)
- endif
-
- ! broadcast the information read on the master to the nodes
- call MPI_BCAST(ibathy_topo,NX_BATHY*NY_BATHY,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- endif
-
- ! user output
- call sync_all()
- if( myrank == 0 .and. (TOPOGRAPHY .or. OCEANS_VAL .or. ELLIPTICITY_VAL)) then
- ! elapsed time since beginning of mesh generation
- tCPU = wtime() - time_start
- write(IMAIN,*)
- write(IMAIN,*) 'Elapsed time for reading topo/bathy in seconds = ',sngl(tCPU)
- write(IMAIN,*)
- endif
-
- end subroutine read_topography_bathymetry
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/setup_GLL_points.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/setup_GLL_points.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/setup_GLL_points.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,57 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 setup_GLL_points()
-
- use specfem_par
- implicit none
-
- ! local parameters
- integer :: i,j
-
- ! set up GLL points, weights and derivation matrices
- call define_derivation_matrices(xigll,yigll,zigll,wxgll,wygll,wzgll, &
- hprime_xx,hprime_yy,hprime_zz, &
- hprimewgll_xx,hprimewgll_yy,hprimewgll_zz, &
- wgllwgll_xy,wgllwgll_xz,wgllwgll_yz,wgll_cube)
-
- if( USE_DEVILLE_PRODUCTS_VAL ) then
-
- ! check that optimized routines from Deville et al. (2002) can be used
- if(NGLLX /= 5 .or. NGLLY /= 5 .or. NGLLZ /= 5) &
- stop 'Deville et al. (2002) routines can only be used if NGLLX = NGLLY = NGLLZ = 5'
-
- ! define transpose of derivation matrix
- do j = 1,NGLLY
- do i = 1,NGLLX
- hprime_xxT(j,i) = hprime_xx(i,j)
- hprimewgll_xxT(j,i) = hprimewgll_xx(i,j)
- enddo
- enddo
- endif
-
- end subroutine setup_GLL_points
Deleted: seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_movie_output.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_movie_output.f90 2013-07-02 15:37:49 UTC (rev 22486)
+++ seismo/3D/SPECFEM3D_GLOBE/trunk/src/specfem3D/write_movie_output.f90 2013-07-02 15:58:12 UTC (rev 22487)
@@ -1,292 +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 CNRS / INRIA / University of Pau, France
-! (c) Princeton University and CNRS / INRIA / University of Pau
-! 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 write_movie_output()
-
- use specfem_par
- use specfem_par_crustmantle
- use specfem_par_innercore
- use specfem_par_outercore
- use specfem_par_movie
- implicit none
-
- ! local parameters
- ! debugging
- character(len=256) :: filename
- integer,dimension(:),allocatable :: dummy_i
-
- logical, parameter :: DEBUG_SNAPSHOT = .false.
-
- logical, parameter :: RUN_EXTERNAL_SCRIPT = .true.
- character(len=256) :: script_name = "tar_databases_file.sh"
- character(len=256) :: system_command
-
- ! save movie on surface
- if( MOVIE_SURFACE ) then
- if( mod(it,NTSTEP_BETWEEN_FRAMES) == 0) then
-
- ! gets resulting array values onto CPU
- if( GPU_MODE ) then
- ! transfers whole fields
- call transfer_displ_cm_from_device(NDIM*NGLOB_CRUST_MANTLE,displ_crust_mantle,Mesh_pointer)
- call transfer_veloc_cm_from_device(NDIM*NGLOB_CRUST_MANTLE,veloc_crust_mantle,Mesh_pointer)
- endif
-
- ! save velocity here to avoid static offset on displacement for movies
- call write_movie_surface()
-
- endif
- endif
-
-
- ! save movie in full 3D mesh
- if(MOVIE_VOLUME ) then
-
- ! updates integral of strain for adjoint movie volume
- if( MOVIE_VOLUME_TYPE == 2 .or. MOVIE_VOLUME_TYPE == 3 ) then
- ! transfers strain arrays onto CPU
- if( GPU_MODE ) then
- call transfer_strain_cm_from_device(Mesh_pointer,eps_trace_over_3_crust_mantle, &
- epsilondev_xx_crust_mantle,epsilondev_yy_crust_mantle, &
- epsilondev_xy_crust_mantle,epsilondev_xz_crust_mantle, &
- epsilondev_yz_crust_mantle)
- endif
-
- ! integrates strain
- call movie_volume_integrate_strain(deltat,size(Ieps_trace_over_3_crust_mantle,4), &
- eps_trace_over_3_crust_mantle, &
- epsilondev_xx_crust_mantle,epsilondev_yy_crust_mantle, &
- epsilondev_xy_crust_mantle,epsilondev_xz_crust_mantle, &
- epsilondev_yz_crust_mantle, &
- Ieps_trace_over_3_crust_mantle, &
- Iepsilondev_xx_crust_mantle,Iepsilondev_yy_crust_mantle, &
- Iepsilondev_xy_crust_mantle,Iepsilondev_xz_crust_mantle, &
- Iepsilondev_yz_crust_mantle)
- endif
-
- ! file output
- if( mod(it-MOVIE_START,NTSTEP_BETWEEN_FRAMES) == 0 &
- .and. it >= MOVIE_START .and. it <= MOVIE_STOP) then
-
- select case( MOVIE_VOLUME_TYPE )
- case( 1 )
- ! output strains
-
- ! gets resulting array values onto CPU
- if( GPU_MODE ) then
- call transfer_strain_cm_from_device(Mesh_pointer, &
- eps_trace_over_3_crust_mantle, &
- epsilondev_xx_crust_mantle,epsilondev_yy_crust_mantle, &
- epsilondev_xy_crust_mantle,epsilondev_xz_crust_mantle, &
- epsilondev_yz_crust_mantle)
- endif
-
- call write_movie_volume_strains(myrank,npoints_3dmovie, &
- LOCAL_TMP_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
- it,eps_trace_over_3_crust_mantle, &
- epsilondev_xx_crust_mantle,epsilondev_yy_crust_mantle,epsilondev_xy_crust_mantle, &
- epsilondev_xz_crust_mantle,epsilondev_yz_crust_mantle, &
- muvstore_crust_mantle_3dmovie, &
- mask_3dmovie,nu_3dmovie)
-
- case( 2, 3 )
- ! output the Time Integral of Strain, or \mu*TIS
- call write_movie_volume_strains(myrank,npoints_3dmovie, &
- LOCAL_TMP_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE, &
- it,Ieps_trace_over_3_crust_mantle, &
- Iepsilondev_xx_crust_mantle,Iepsilondev_yy_crust_mantle,Iepsilondev_xy_crust_mantle, &
- Iepsilondev_xz_crust_mantle,Iepsilondev_yz_crust_mantle, &
- muvstore_crust_mantle_3dmovie, &
- mask_3dmovie,nu_3dmovie)
-
- case( 4 )
- ! output divergence and curl in whole volume
-
- ! gets resulting array values onto CPU
- if( GPU_MODE ) then
- ! strains
- call transfer_strain_cm_from_device(Mesh_pointer, &
- eps_trace_over_3_crust_mantle, &
- epsilondev_xx_crust_mantle,epsilondev_yy_crust_mantle, &
- epsilondev_xy_crust_mantle,epsilondev_xz_crust_mantle, &
- epsilondev_yz_crust_mantle)
- call transfer_strain_ic_from_device(Mesh_pointer, &
- eps_trace_over_3_inner_core, &
- epsilondev_xx_inner_core,epsilondev_yy_inner_core, &
- epsilondev_xy_inner_core,epsilondev_xz_inner_core, &
- epsilondev_yz_inner_core)
- ! wavefields
- call transfer_fields_oc_from_device(NGLOB_OUTER_CORE, &
- displ_outer_core,veloc_outer_core,accel_outer_core,Mesh_pointer)
- endif
-
- call write_movie_volume_divcurl(myrank,it,eps_trace_over_3_crust_mantle,&
- div_displ_outer_core, &
- accel_outer_core,kappavstore_outer_core,rhostore_outer_core,ibool_outer_core, &
- eps_trace_over_3_inner_core, &
- epsilondev_xx_crust_mantle,epsilondev_yy_crust_mantle,epsilondev_xy_crust_mantle, &
- epsilondev_xz_crust_mantle,epsilondev_yz_crust_mantle, &
- epsilondev_xx_inner_core,epsilondev_yy_inner_core,epsilondev_xy_inner_core, &
- epsilondev_xz_inner_core,epsilondev_yz_inner_core, &
- LOCAL_TMP_PATH)
-
- case( 5 )
- !output displacement
- if( GPU_MODE ) then
- call transfer_displ_cm_from_device(NDIM*NGLOB_CRUST_MANTLE,displ_crust_mantle,Mesh_pointer)
- endif
-
- scalingval = scale_displ
- call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
- LOCAL_TMP_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE,ibool_crust_mantle, &
- displ_crust_mantle, &
- scalingval,mask_3dmovie,nu_3dmovie)
-
- case( 6 )
- !output velocity
- if( GPU_MODE ) then
- call transfer_veloc_cm_from_device(NDIM*NGLOB_CRUST_MANTLE,veloc_crust_mantle,Mesh_pointer)
- endif
-
- scalingval = scale_veloc
- call write_movie_volume_vector(myrank,it,npoints_3dmovie, &
- LOCAL_TMP_PATH,MOVIE_VOLUME_TYPE,MOVIE_COARSE,ibool_crust_mantle, &
- veloc_crust_mantle, &
- scalingval,mask_3dmovie,nu_3dmovie)
-
- case( 7 )
- ! output norm of displacement
-
- ! gets resulting array values onto CPU
- if( GPU_MODE ) then
- ! displacement wavefields
- call transfer_displ_cm_from_device(NDIM*NGLOB_CRUST_MANTLE,displ_crust_mantle,Mesh_pointer)
- call transfer_displ_ic_from_device(NDIM*NGLOB_INNER_CORE,displ_inner_core,Mesh_pointer)
- call transfer_displ_oc_from_device(NGLOB_OUTER_CORE,displ_outer_core,Mesh_pointer)
- endif
-
- call write_movie_volume_displnorm(myrank,it,LOCAL_TMP_PATH, &
- displ_crust_mantle,displ_inner_core,displ_outer_core, &
- ibool_crust_mantle,ibool_inner_core,ibool_outer_core)
-
- case( 8 )
- ! output norm of velocity
-
- ! gets resulting array values onto CPU
- if( GPU_MODE ) then
- ! velocity wavefields
- call transfer_veloc_cm_from_device(NDIM*NGLOB_CRUST_MANTLE,veloc_crust_mantle,Mesh_pointer)
- call transfer_veloc_ic_from_device(NDIM*NGLOB_INNER_CORE,veloc_inner_core,Mesh_pointer)
- call transfer_veloc_oc_from_device(NGLOB_OUTER_CORE,veloc_outer_core,Mesh_pointer)
- endif
-
- call write_movie_volume_velnorm(myrank,it,LOCAL_TMP_PATH, &
- veloc_crust_mantle,veloc_inner_core,veloc_outer_core, &
- ibool_crust_mantle,ibool_inner_core,ibool_outer_core)
-
- case( 9 )
- ! output norm of acceleration
-
- ! gets resulting array values onto CPU
- if( GPU_MODE ) then
- ! acceleration wavefields
- call transfer_accel_cm_from_device(NDIM*NGLOB_CRUST_MANTLE,accel_crust_mantle,Mesh_pointer)
- call transfer_accel_ic_from_device(NDIM*NGLOB_INNER_CORE,accel_inner_core,Mesh_pointer)
- call transfer_accel_oc_from_device(NGLOB_OUTER_CORE,accel_outer_core,Mesh_pointer)
- endif
-
- call write_movie_volume_accelnorm(myrank,it,LOCAL_TMP_PATH, &
- accel_crust_mantle,accel_inner_core,accel_outer_core, &
- ibool_crust_mantle,ibool_inner_core,ibool_outer_core)
-
- case default
- call exit_MPI(myrank, 'MOVIE_VOLUME_TYPE has to be in range from 1 to 9')
-
- end select ! MOVIE_VOLUME_TYPE
-
- ! executes an external script on the node
- if( RUN_EXTERNAL_SCRIPT ) then
- call sync_all()
- if( myrank == 0 ) then
- write(system_command,"('./',a,1x,i6.6,' >& out.',i6.6,'.log &')") trim(script_name),it,it
- !print*,trim(system_command)
- call system(system_command)
- endif
- endif
- endif
- endif ! MOVIE_VOLUME
-
- ! debugging
- if( DEBUG_SNAPSHOT ) then
- if( mod(it-MOVIE_START,NTSTEP_BETWEEN_FRAMES) == 0 &
- .and. it >= MOVIE_START .and. it <= MOVIE_STOP) then
-
- !output displacement
- if( GPU_MODE ) then
- call transfer_displ_cm_from_device(NDIM*NGLOB_CRUST_MANTLE,displ_crust_mantle,Mesh_pointer)
- call transfer_displ_ic_from_device(NDIM*NGLOB_INNER_CORE,displ_inner_core,Mesh_pointer)
- endif
-
- ! VTK file output
- ! displacement values
-
- ! crust mantle
- allocate(dummy_i(NSPEC_CRUST_MANTLE))
- dummy_i(:) = IFLAG_CRUST
- ! one file per process
- write(prname,'(a,i6.6,a)') 'OUTPUT_FILES/snapshot_proc',myrank,'_'
- write(filename,'(a,a,i6.6)') prname(1:len_trim(prname)),'reg_1_displ_',it
- call write_VTK_data_cr(dummy_i,NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE, &
- xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle, &
- displ_crust_mantle,filename)
- ! single file for all
- !write(prname,'(a)') 'OUTPUT_FILES/snapshot_all_'
- !write(filename,'(a,a,i6.6)') prname(1:len_trim(prname)),'reg_1_displ_',it
- !call write_VTK_data_cr_all(myrank,NPROCTOT_VAL,dummy_i, &
- ! NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE, &
- ! xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle,ibool_crust_mantle, &
- ! displ_crust_mantle,filename)
- deallocate(dummy_i)
-
- ! inner core
- ! one file per process
- !write(prname,'(a,i6.6,a)') trim(LOCAL_TMP_PATH)//'/'//'proc',myrank,'_'
- !write(filename,'(a,a,i6.6)') prname(1:len_trim(prname)),'reg_3_displ_',it
- !call write_VTK_data_cr(idoubling_inner_core,NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
- ! xstore_inner_core,ystore_inner_core,zstore_inner_core,ibool_inner_core, &
- ! displ_inner_core,filename)
- ! single file for all
- !write(prname,'(a)') 'OUTPUT_FILES/snapshot_all_'
- !write(filename,'(a,a,i6.6)') prname(1:len_trim(prname)),'reg_3_displ_',it
- !call write_VTK_data_cr_all(myrank,NPROCTOT_VAL,idoubling_inner_core, &
- ! NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
- ! xstore_inner_core,ystore_inner_core,zstore_inner_core,ibool_inner_core, &
- ! displ_inner_core,filename)
- endif
- endif
-
- end subroutine write_movie_output
More information about the CIG-COMMITS
mailing list