[cig-commits] r20565 - in seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER: EXAMPLES/global_s362ani_small/DATA EXAMPLES/regional_Greece_small/DATA UTILS/oldstuff/older_versions src/cuda src/meshfem3D src/specfem3D
danielpeter at geodynamics.org
danielpeter at geodynamics.org
Fri Aug 10 19:22:08 PDT 2012
Author: danielpeter
Date: 2012-08-10 19:22:07 -0700 (Fri, 10 Aug 2012)
New Revision: 20565
Added:
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/UTILS/oldstuff/older_versions/read_arrays_buffers_mesher.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/UTILS/oldstuff/older_versions/read_arrays_buffers_solver.f90
Removed:
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/read_arrays_buffers_mesher.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_arrays_buffers_solver.f90
Modified:
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/EXAMPLES/global_s362ani_small/DATA/Par_file
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/EXAMPLES/regional_Greece_small/DATA/Par_file
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/specfem3D_gpu_cuda_method_stubs.c
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/Makefile.in
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_MPI_interfaces.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_chunk_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_mass_matrices.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_meshes.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regions_mesh.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_1D_buffers.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_cutplanes_eta.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_cutplanes_xi.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_absorb.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/meshfem3D_par.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/moho_stretching.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver.f90
seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/setup_color_perm.f90
Log:
changes meshing order to setup mesh coloring; uses internal arrays for mpi buffers to avoid additional mesh file outputs
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/EXAMPLES/global_s362ani_small/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/EXAMPLES/global_s362ani_small/DATA/Par_file 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/EXAMPLES/global_s362ani_small/DATA/Par_file 2012-08-11 02:22:07 UTC (rev 20565)
@@ -32,7 +32,7 @@
# fully 3D models:
# transversely_isotropic_prem_plus_3D_crust_2.0, 3D_anisotropic, 3D_attenuation,
# s20rts, s362ani, s362iso, s362wmani, s362ani_prem, s29ea
-MODEL = s362ani
+MODEL = 1D_transversely_isotropic_prem
# parameters describing the Earth model
OCEANS = .false.
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/EXAMPLES/regional_Greece_small/DATA/Par_file
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/EXAMPLES/regional_Greece_small/DATA/Par_file 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/EXAMPLES/regional_Greece_small/DATA/Par_file 2012-08-11 02:22:07 UTC (rev 20565)
@@ -8,16 +8,16 @@
NCHUNKS = 1
# angular width of the first chunk (not used if full sphere with six chunks)
-ANGULAR_WIDTH_XI_IN_DEGREES = 20.d0 # angular size of a chunk
-ANGULAR_WIDTH_ETA_IN_DEGREES = 20.d0
+ANGULAR_WIDTH_XI_IN_DEGREES = 90.d0 # angular size of a chunk
+ANGULAR_WIDTH_ETA_IN_DEGREES = 90.d0
CENTER_LATITUDE_IN_DEGREES = 40.d0
CENTER_LONGITUDE_IN_DEGREES = 25.d0
GAMMA_ROTATION_AZIMUTH = 0.d0
# number of elements at the surface along the two sides of the first chunk
# (must be multiple of 16 and 8 * multiple of NPROC below)
-NEX_XI = 64
-NEX_ETA = 64
+NEX_XI = 48
+NEX_ETA = 48
# number of MPI processors along the two sides of the first chunk
NPROC_XI = 2
@@ -36,11 +36,11 @@
MODEL = s362ani
# parameters describing the Earth model
-OCEANS = .false.
-ELLIPTICITY = .false.
-TOPOGRAPHY = .false.
-GRAVITY = .false.
-ROTATION = .false.
+OCEANS = .true.
+ELLIPTICITY = .true.
+TOPOGRAPHY = .true.
+GRAVITY = .true.
+ROTATION = .true.
ATTENUATION = .true.
ATTENUATION_NEW = .false.
@@ -48,7 +48,7 @@
ABSORBING_CONDITIONS = .false.
# record length in minutes
-RECORD_LENGTH_IN_MINUTES = 2.5d0
+RECORD_LENGTH_IN_MINUTES = 30.0d0
# save AVS or OpenDX movies
MOVIE_SURFACE = .false.
Copied: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/UTILS/oldstuff/older_versions/read_arrays_buffers_mesher.f90 (from rev 20564, seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/read_arrays_buffers_mesher.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/UTILS/oldstuff/older_versions/read_arrays_buffers_mesher.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/UTILS/oldstuff/older_versions/read_arrays_buffers_mesher.f90 2012-08-11 02:22:07 UTC (rev 20565)
@@ -0,0 +1,341 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! April 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+ subroutine read_arrays_buffers_mesher(iregion_code,myrank, &
+ iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta, &
+ npoin2D_xi,npoin2D_eta, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ iboolfaces,npoin2D_faces,iboolcorner, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NGLOB1D_RADIAL, &
+ NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT,NPROC_XI,NPROC_ETA,LOCAL_PATH,NCHUNKS)
+
+ implicit none
+
+! standard include of the MPI library
+ include 'mpif.h'
+
+ include "constants.h"
+
+ integer iregion_code,myrank,NCHUNKS,ier
+
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi,npoin2D_eta
+ integer :: NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NGLOB1D_RADIAL
+ integer :: NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT,NPROC_XI,NPROC_ETA
+
+ integer :: npoin2D_faces(NUMFACES_SHARED)
+
+ character(len=150) :: LOCAL_PATH
+
+ integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces
+ integer, dimension(NGLOB1D_RADIAL,NUMCORNERS_SHARED) :: iboolcorner
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
+
+ integer, dimension(NUMMSGS_FACES) :: iprocfrom_faces,iprocto_faces,imsg_type
+
+! allocate array for messages for corners
+ integer, dimension(NCORNERSCHUNKS) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
+
+ integer :: npoin2D_xi_mesher,npoin2D_eta_mesher
+ integer :: npoin1D_corner
+
+ integer :: imsg,icount_faces,icount_corners
+ integer :: ipoin1D,ipoin2D
+
+ double precision :: xdummy,ydummy,zdummy
+
+! processor identification
+ character(len=150) :: OUTPUT_FILES,prname,filename
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+
+! create the name for the database of the current slide and region
+ call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
+
+! read 2-D addressing for summation between slices along xi with MPI
+
+! read iboolleft_xi of this slice
+ open(unit=IIN,file=prname(1:len_trim(prname))//'iboolleft_xi.txt', &
+ status='old',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error opening iboolleft_xi file')
+
+ npoin2D_xi(1) = 1
+ 350 continue
+ read(IIN,*) iboolleft_xi(npoin2D_xi(1)),xdummy,ydummy,zdummy
+ if(iboolleft_xi(npoin2D_xi(1)) > 0) then
+ npoin2D_xi(1) = npoin2D_xi(1) + 1
+ goto 350
+ endif
+! subtract the line that contains the flag after the last point
+ npoin2D_xi(1) = npoin2D_xi(1) - 1
+! read nb of points given by the mesher
+ read(IIN,*) npoin2D_xi_mesher
+ if(npoin2D_xi(1) > NGLOB2DMAX_XMIN_XMAX .or. npoin2D_xi(1) /= npoin2D_xi_mesher) &
+ call exit_MPI(myrank,'incorrect iboolleft_xi read')
+ close(IIN)
+
+! read iboolright_xi of this slice
+ open(unit=IIN,file=prname(1:len_trim(prname))//'iboolright_xi.txt', &
+ status='old',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error opening iboolright_xi file')
+
+ npoin2D_xi(2) = 1
+ 360 continue
+ read(IIN,*) iboolright_xi(npoin2D_xi(2)),xdummy,ydummy,zdummy
+ if(iboolright_xi(npoin2D_xi(2)) > 0) then
+ npoin2D_xi(2) = npoin2D_xi(2) + 1
+ goto 360
+ endif
+! subtract the line that contains the flag after the last point
+ npoin2D_xi(2) = npoin2D_xi(2) - 1
+! read nb of points given by the mesher
+ read(IIN,*) npoin2D_xi_mesher
+ if(npoin2D_xi(2) > NGLOB2DMAX_XMIN_XMAX .or. npoin2D_xi(2) /= npoin2D_xi_mesher) &
+ call exit_MPI(myrank,'incorrect iboolright_xi read')
+ close(IIN)
+
+ if(myrank == 0) then
+ write(IMAIN,*) ' #max of points in MPI buffers along xi npoin2D_xi = ', &
+ maxval(npoin2D_xi(:))
+ write(IMAIN,*) ' #max of array elements transferred npoin2D_xi*NDIM = ', &
+ maxval(npoin2D_xi(:))*NDIM
+ write(IMAIN,*)
+ endif
+
+! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! read 2-D addressing for summation between slices along eta with MPI
+
+! read iboolleft_eta of this slice
+ open(unit=IIN,file=prname(1:len_trim(prname))//'iboolleft_eta.txt', &
+ status='old',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error opening iboolleft_eta file')
+
+ npoin2D_eta(1) = 1
+ 370 continue
+ read(IIN,*) iboolleft_eta(npoin2D_eta(1)),xdummy,ydummy,zdummy
+ if(iboolleft_eta(npoin2D_eta(1)) > 0) then
+ npoin2D_eta(1) = npoin2D_eta(1) + 1
+ goto 370
+ endif
+! subtract the line that contains the flag after the last point
+ npoin2D_eta(1) = npoin2D_eta(1) - 1
+! read nb of points given by the mesher
+ read(IIN,*) npoin2D_eta_mesher
+ if(npoin2D_eta(1) > NGLOB2DMAX_YMIN_YMAX .or. npoin2D_eta(1) /= npoin2D_eta_mesher) &
+ call exit_MPI(myrank,'incorrect iboolleft_eta read')
+ close(IIN)
+
+! read iboolright_eta of this slice
+ open(unit=IIN,file=prname(1:len_trim(prname))//'iboolright_eta.txt', &
+ status='old',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error opening iboolright_eta file')
+
+ npoin2D_eta(2) = 1
+ 380 continue
+ read(IIN,*) iboolright_eta(npoin2D_eta(2)),xdummy,ydummy,zdummy
+ if(iboolright_eta(npoin2D_eta(2)) > 0) then
+ npoin2D_eta(2) = npoin2D_eta(2) + 1
+ goto 380
+ endif
+! subtract the line that contains the flag after the last point
+ npoin2D_eta(2) = npoin2D_eta(2) - 1
+! read nb of points given by the mesher
+ read(IIN,*) npoin2D_eta_mesher
+ if(npoin2D_eta(2) > NGLOB2DMAX_YMIN_YMAX .or. npoin2D_eta(2) /= npoin2D_eta_mesher) &
+ call exit_MPI(myrank,'incorrect iboolright_eta read')
+ close(IIN)
+
+ if(myrank == 0) then
+ write(IMAIN,*) ' #max of points in MPI buffers along eta npoin2D_eta = ', &
+ maxval(npoin2D_eta(:))
+ write(IMAIN,*) ' #max of array elements transferred npoin2D_eta*NDIM = ', &
+ maxval(npoin2D_eta(:))*NDIM
+ write(IMAIN,*)
+ endif
+
+
+!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+
+! read chunk messages only if more than one chunk
+ if(NCHUNKS > 1) then
+
+! read messages to assemble between chunks with MPI
+
+ if(myrank == 0) then
+
+ ! file with the list of processors for each message for faces
+ open(unit=IIN,file=trim(OUTPUT_FILES)//'/list_messages_faces.txt', &
+ status='old',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error opening list_messages_faces file')
+
+ do imsg = 1,NUMMSGS_FACES
+ read(IIN,*) imsg_type(imsg),iprocfrom_faces(imsg),iprocto_faces(imsg)
+
+ ! checks array values bounds
+ if (iprocfrom_faces(imsg) < 0 &
+ .or. iprocto_faces(imsg) < 0 &
+ .or. iprocfrom_faces(imsg) > NPROCTOT-1 &
+ .or. iprocto_faces(imsg) > NPROCTOT-1) &
+ call exit_MPI(myrank,'incorrect chunk faces numbering')
+ ! checks types
+ if (imsg_type(imsg) < 1 .or. imsg_type(imsg) > 3) &
+ call exit_MPI(myrank,'incorrect message type labeling')
+
+ enddo
+ close(IIN)
+
+ ! file with the list of processors for each message for corners
+ open(unit=IIN,file=trim(OUTPUT_FILES)//'/list_messages_corners.txt', &
+ status='old',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error opening list_messages_corners file')
+
+ do imsg = 1,NCORNERSCHUNKS
+ read(IIN,*) iproc_master_corners(imsg),iproc_worker1_corners(imsg), &
+ iproc_worker2_corners(imsg)
+ if (iproc_master_corners(imsg) < 0 &
+ .or. iproc_worker1_corners(imsg) < 0 &
+ .or. iproc_worker2_corners(imsg) < 0 &
+ .or. iproc_master_corners(imsg) > NPROCTOT-1 &
+ .or. iproc_worker1_corners(imsg) > NPROCTOT-1 &
+ .or. iproc_worker2_corners(imsg) > NPROCTOT-1) &
+ call exit_MPI(myrank,'incorrect chunk corner numbering')
+ enddo
+ close(IIN)
+
+ endif
+
+! broadcast the information read on the master to the nodes
+ call MPI_BCAST(imsg_type,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iprocfrom_faces,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iprocto_faces,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+
+ call MPI_BCAST(iproc_master_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iproc_worker1_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ call MPI_BCAST(iproc_worker2_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error mpi broadcast')
+
+
+!---- read 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
+
+ ! read file with 2D buffer for faces
+ if(myrank == iprocfrom_faces(imsg)) then
+ write(filename,"('buffer_faces_chunks_sender_msg',i6.6,'.txt')") imsg
+ else if(myrank == iprocto_faces(imsg)) then
+ write(filename,"('buffer_faces_chunks_receiver_msg',i6.6,'.txt')") imsg
+ endif
+
+ open(unit=IIN,file=prname(1:len_trim(prname))//filename,status='old',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error opening buffer_faces file')
+
+ read(IIN,*) npoin2D_faces(icount_faces)
+ if(npoin2D_faces(icount_faces) > NGLOB2DMAX_XY) then
+ print*,'error ',myrank,' npoin2D_faces: ',npoin2D_faces(icount_faces),icount_faces
+ print*,'iregion_code:',iregion_code
+ call exit_MPI(myrank,'incorrect nb of points in face buffer')
+ endif
+
+ do ipoin2D = 1,npoin2D_faces(icount_faces)
+ read(IIN,*) iboolfaces(ipoin2D,icount_faces),xdummy,ydummy,zdummy
+ enddo
+ close(IIN)
+
+ endif
+ enddo
+
+
+!---- read indirect addressing for each message for corners of the chunks
+!---- a given slice can belong to at most one corner
+ icount_corners = 0
+ do imsg = 1,NCORNERSCHUNKS
+ ! if only two chunks then there is no second worker
+ if(myrank == iproc_master_corners(imsg) .or. &
+ myrank == iproc_worker1_corners(imsg) .or. &
+ (NCHUNKS /= 2 .and. myrank == iproc_worker2_corners(imsg))) then
+
+ icount_corners = icount_corners + 1
+ if(icount_corners>1 .and. (NPROC_XI > 1 .or. NPROC_ETA > 1)) then
+ print*,'error ',myrank,'icount_corners:',icount_corners
+ print*,'iregion_code:',iregion_code
+ call exit_MPI(myrank,'more than one corner for this slice')
+ endif
+ if(icount_corners>4) call exit_MPI(myrank,'more than four corners for this slice')
+
+ ! read file with 1D buffer for corner
+ if(myrank == iproc_master_corners(imsg)) then
+ write(filename,"('buffer_corners_chunks_master_msg',i6.6,'.txt')") imsg
+ else if(myrank == iproc_worker1_corners(imsg)) then
+ write(filename,"('buffer_corners_chunks_worker1_msg',i6.6,'.txt')") imsg
+ else if( NCHUNKS /= 2 .and. myrank == iproc_worker2_corners(imsg)) then
+ write(filename,"('buffer_corners_chunks_worker2_msg',i6.6,'.txt')") imsg
+ endif
+
+ ! matching codes
+ open(unit=IIN,file=prname(1:len_trim(prname))//filename, &
+ status='old',action='read',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error opening buffer_corners_chunks file')
+
+ read(IIN,*) npoin1D_corner
+ if(npoin1D_corner /= NGLOB1D_RADIAL) then
+ print*,'error ',myrank,' npoin1D_corner: ',npoin1D_corner,'NGLOB1D_RADIAL:',NGLOB1D_RADIAL
+ print*,'iregion_code:',iregion_code
+ call exit_MPI(myrank,'incorrect nb of points in corner buffer')
+ endif
+ do ipoin1D = 1,npoin1D_corner
+ read(IIN,*) iboolcorner(ipoin1D,icount_corners),xdummy,ydummy,zdummy
+ enddo
+ close(IIN)
+
+ endif
+
+
+ enddo
+
+ endif
+
+ end subroutine read_arrays_buffers_mesher
+
Copied: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/UTILS/oldstuff/older_versions/read_arrays_buffers_solver.f90 (from rev 20554, seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_arrays_buffers_solver.f90)
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/UTILS/oldstuff/older_versions/read_arrays_buffers_solver.f90 (rev 0)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/UTILS/oldstuff/older_versions/read_arrays_buffers_solver.f90 2012-08-11 02:22:07 UTC (rev 20565)
@@ -0,0 +1,339 @@
+!=====================================================================
+!
+! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
+! --------------------------------------------------
+!
+! Main authors: Dimitri Komatitsch and Jeroen Tromp
+! Princeton University, USA
+! and University of Pau / CNRS / INRIA, France
+! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
+! April 2011
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 2 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License along
+! with this program; if not, write to the Free Software Foundation, Inc.,
+! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+!
+!=====================================================================
+
+! obsolete...
+!
+! subroutine read_arrays_buffers_solver(iregion_code,myrank, &
+! iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta, &
+! npoin2D_xi,npoin2D_eta, &
+! iprocfrom_faces,iprocto_faces,imsg_type, &
+! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+! iboolfaces,npoin2D_faces,iboolcorner, &
+! NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NGLOB1D_RADIAL, &
+! NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT,NPROC_XI,NPROC_ETA,LOCAL_PATH,NCHUNKS)
+!
+! implicit none
+!
+!! standard include of the MPI library
+! include 'mpif.h'
+!
+! include "constants.h"
+!
+! integer iregion_code,myrank,NCHUNKS,ier
+!
+! integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi,npoin2D_eta
+! integer NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NGLOB1D_RADIAL
+! integer NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT,NPROC_XI,NPROC_ETA
+!
+! integer npoin2D_faces(NUMFACES_SHARED)
+!
+! character(len=150) LOCAL_PATH
+!
+! integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces
+! integer, dimension(NGLOB1D_RADIAL,NUMCORNERS_SHARED) :: iboolcorner
+! integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
+! integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
+!
+! integer, dimension(NUMMSGS_FACES) :: iprocfrom_faces,iprocto_faces,imsg_type
+!
+!! allocate array for messages for corners
+! integer, dimension(NCORNERSCHUNKS) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
+!
+! integer npoin2D_xi_mesher,npoin2D_eta_mesher
+! integer npoin1D_corner
+!
+! integer imsg,icount_faces,icount_corners
+! integer ipoin1D,ipoin2D
+!
+! double precision xdummy,ydummy,zdummy
+!
+!! processor identification
+! character(len=150) OUTPUT_FILES,prname,filename
+!
+!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+!
+!! get the base pathname for output files
+! call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+!
+!! create the name for the database of the current slide and region
+! call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
+!
+!! read 2-D addressing for summation between slices along xi with MPI
+!
+!! read iboolleft_xi of this slice
+! open(unit=IIN,file=prname(1:len_trim(prname))//'iboolleft_xi.txt', &
+! status='old',action='read',iostat=ier)
+! if( ier /= 0 ) call exit_MPI(myrank,'error opening iboolleft_xi file')
+!
+! npoin2D_xi(1) = 1
+! 350 continue
+! read(IIN,*) iboolleft_xi(npoin2D_xi(1)),xdummy,ydummy,zdummy
+! if(iboolleft_xi(npoin2D_xi(1)) > 0) then
+! npoin2D_xi(1) = npoin2D_xi(1) + 1
+! goto 350
+! endif
+!! subtract the line that contains the flag after the last point
+! npoin2D_xi(1) = npoin2D_xi(1) - 1
+!! read nb of points given by the mesher
+! read(IIN,*) npoin2D_xi_mesher
+! if(npoin2D_xi(1) > NGLOB2DMAX_XMIN_XMAX .or. npoin2D_xi(1) /= npoin2D_xi_mesher) &
+! call exit_MPI(myrank,'incorrect iboolleft_xi read')
+! close(IIN)
+!
+!! read iboolright_xi of this slice
+! open(unit=IIN,file=prname(1:len_trim(prname))//'iboolright_xi.txt', &
+! status='old',action='read',iostat=ier)
+! if( ier /= 0 ) call exit_MPI(myrank,'error opening iboolright_xi file')
+!
+! npoin2D_xi(2) = 1
+! 360 continue
+! read(IIN,*) iboolright_xi(npoin2D_xi(2)),xdummy,ydummy,zdummy
+! if(iboolright_xi(npoin2D_xi(2)) > 0) then
+! npoin2D_xi(2) = npoin2D_xi(2) + 1
+! goto 360
+! endif
+!! subtract the line that contains the flag after the last point
+! npoin2D_xi(2) = npoin2D_xi(2) - 1
+!! read nb of points given by the mesher
+! read(IIN,*) npoin2D_xi_mesher
+! if(npoin2D_xi(2) > NGLOB2DMAX_XMIN_XMAX .or. npoin2D_xi(2) /= npoin2D_xi_mesher) &
+! call exit_MPI(myrank,'incorrect iboolright_xi read')
+! close(IIN)
+!
+! if(myrank == 0) then
+! write(IMAIN,*) ' #max of points in MPI buffers along xi npoin2D_xi = ', &
+! maxval(npoin2D_xi(:))
+! write(IMAIN,*) ' #max of array elements transferred npoin2D_xi*NDIM = ', &
+! maxval(npoin2D_xi(:))*NDIM
+! write(IMAIN,*)
+! endif
+!
+!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+!
+!! read 2-D addressing for summation between slices along eta with MPI
+!
+!! read iboolleft_eta of this slice
+! open(unit=IIN,file=prname(1:len_trim(prname))//'iboolleft_eta.txt', &
+! status='old',action='read',iostat=ier)
+! if( ier /= 0 ) call exit_MPI(myrank,'error opening iboolleft_eta file')
+!
+! npoin2D_eta(1) = 1
+! 370 continue
+! read(IIN,*) iboolleft_eta(npoin2D_eta(1)),xdummy,ydummy,zdummy
+! if(iboolleft_eta(npoin2D_eta(1)) > 0) then
+! npoin2D_eta(1) = npoin2D_eta(1) + 1
+! goto 370
+! endif
+!! subtract the line that contains the flag after the last point
+! npoin2D_eta(1) = npoin2D_eta(1) - 1
+!! read nb of points given by the mesher
+! read(IIN,*) npoin2D_eta_mesher
+! if(npoin2D_eta(1) > NGLOB2DMAX_YMIN_YMAX .or. npoin2D_eta(1) /= npoin2D_eta_mesher) &
+! call exit_MPI(myrank,'incorrect iboolleft_eta read')
+! close(IIN)
+!
+!! read iboolright_eta of this slice
+! open(unit=IIN,file=prname(1:len_trim(prname))//'iboolright_eta.txt', &
+! status='old',action='read',iostat=ier)
+! if( ier /= 0 ) call exit_MPI(myrank,'error opening iboolright_eta file')
+!
+! npoin2D_eta(2) = 1
+! 380 continue
+! read(IIN,*) iboolright_eta(npoin2D_eta(2)),xdummy,ydummy,zdummy
+! if(iboolright_eta(npoin2D_eta(2)) > 0) then
+! npoin2D_eta(2) = npoin2D_eta(2) + 1
+! goto 380
+! endif
+!! subtract the line that contains the flag after the last point
+! npoin2D_eta(2) = npoin2D_eta(2) - 1
+!! read nb of points given by the mesher
+! read(IIN,*) npoin2D_eta_mesher
+! if(npoin2D_eta(2) > NGLOB2DMAX_YMIN_YMAX .or. npoin2D_eta(2) /= npoin2D_eta_mesher) &
+! call exit_MPI(myrank,'incorrect iboolright_eta read')
+! close(IIN)
+!
+! if(myrank == 0) then
+! write(IMAIN,*) ' #max of points in MPI buffers along eta npoin2D_eta = ', &
+! maxval(npoin2D_eta(:))
+! write(IMAIN,*) ' #max of array elements transferred npoin2D_eta*NDIM = ', &
+! maxval(npoin2D_eta(:))*NDIM
+! write(IMAIN,*)
+! endif
+!
+!
+!!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
+!
+!! read chunk messages only if more than one chunk
+! if(NCHUNKS /= 1) then
+!
+!! read messages to assemble between chunks with MPI
+!
+! if(myrank == 0) then
+!
+! ! file with the list of processors for each message for faces
+! open(unit=IIN,file=trim(OUTPUT_FILES)//'/list_messages_faces.txt', &
+! status='old',action='read',iostat=ier)
+! if( ier /= 0 ) call exit_MPI(myrank,'error opening list_messages_faces file')
+!
+! do imsg = 1,NUMMSGS_FACES
+! read(IIN,*) imsg_type(imsg),iprocfrom_faces(imsg),iprocto_faces(imsg)
+! if (iprocfrom_faces(imsg) < 0 &
+! .or. iprocto_faces(imsg) < 0 &
+! .or. iprocfrom_faces(imsg) > NPROCTOT-1 &
+! .or. iprocto_faces(imsg) > NPROCTOT-1) &
+! call exit_MPI(myrank,'incorrect chunk faces numbering')
+! if (imsg_type(imsg) < 1 .or. imsg_type(imsg) > 3) &
+! call exit_MPI(myrank,'incorrect message type labeling')
+! enddo
+! close(IIN)
+!
+! ! file with the list of processors for each message for corners
+! open(unit=IIN,file=trim(OUTPUT_FILES)//'/list_messages_corners.txt', &
+! status='old',action='read',iostat=ier)
+! if( ier /= 0 ) call exit_MPI(myrank,'error opening list_messages_corners file')
+!
+! do imsg = 1,NCORNERSCHUNKS
+! read(IIN,*) iproc_master_corners(imsg),iproc_worker1_corners(imsg), &
+! iproc_worker2_corners(imsg)
+! if (iproc_master_corners(imsg) < 0 &
+! .or. iproc_worker1_corners(imsg) < 0 &
+! .or. iproc_worker2_corners(imsg) < 0 &
+! .or. iproc_master_corners(imsg) > NPROCTOT-1 &
+! .or. iproc_worker1_corners(imsg) > NPROCTOT-1 &
+! .or. iproc_worker2_corners(imsg) > NPROCTOT-1) &
+! call exit_MPI(myrank,'incorrect chunk corner numbering')
+! enddo
+! close(IIN)
+!
+! endif
+!
+!! broadcast the information read on the master to the nodes
+! call MPI_BCAST(imsg_type,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+! call MPI_BCAST(iprocfrom_faces,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+! call MPI_BCAST(iprocto_faces,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+!
+! call MPI_BCAST(iproc_master_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+! call MPI_BCAST(iproc_worker1_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+! call MPI_BCAST(iproc_worker2_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
+! if( ier /= 0 ) call exit_MPI(myrank,'error mpi broadcast')
+!
+!
+!!---- read 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
+!
+! ! read file with 2D buffer for faces
+! if(myrank == iprocfrom_faces(imsg)) then
+! write(filename,"('buffer_faces_chunks_sender_msg',i6.6,'.txt')") imsg
+! else if(myrank == iprocto_faces(imsg)) then
+! write(filename,"('buffer_faces_chunks_receiver_msg',i6.6,'.txt')") imsg
+! endif
+!
+! open(unit=IIN,file=prname(1:len_trim(prname))//filename,status='old',action='read',iostat=ier)
+! if( ier /= 0 ) call exit_MPI(myrank,'error opening buffer_faces file')
+!
+! read(IIN,*) npoin2D_faces(icount_faces)
+! if(npoin2D_faces(icount_faces) > NGLOB2DMAX_XY) then
+! print*,'error ',myrank,' npoin2D_faces: ',npoin2D_faces(icount_faces),icount_faces
+! print*,'iregion_code:',iregion_code
+! call exit_MPI(myrank,'incorrect nb of points in face buffer')
+! endif
+!
+! do ipoin2D = 1,npoin2D_faces(icount_faces)
+! read(IIN,*) iboolfaces(ipoin2D,icount_faces),xdummy,ydummy,zdummy
+! enddo
+! close(IIN)
+!
+! endif
+! enddo
+!
+!
+!!---- read indirect addressing for each message for corners of the chunks
+!!---- a given slice can belong to at most one corner
+! icount_corners = 0
+! do imsg = 1,NCORNERSCHUNKS
+! ! if only two chunks then there is no second worker
+! if(myrank == iproc_master_corners(imsg) .or. &
+! myrank == iproc_worker1_corners(imsg) .or. &
+! (NCHUNKS /= 2 .and. myrank == iproc_worker2_corners(imsg))) then
+!
+! icount_corners = icount_corners + 1
+! if(icount_corners>1 .and. (NPROC_XI > 1 .or. NPROC_ETA > 1)) then
+! print*,'error ',myrank,'icount_corners:',icount_corners
+! print*,'iregion_code:',iregion_code
+! call exit_MPI(myrank,'more than one corner for this slice')
+! endif
+! if(icount_corners>4) call exit_MPI(myrank,'more than four corners for this slice')
+!
+! ! read file with 1D buffer for corner
+! if(myrank == iproc_master_corners(imsg)) then
+! write(filename,"('buffer_corners_chunks_master_msg',i6.6,'.txt')") imsg
+! else if(myrank == iproc_worker1_corners(imsg)) then
+! write(filename,"('buffer_corners_chunks_worker1_msg',i6.6,'.txt')") imsg
+! else if( NCHUNKS /= 2 .and. myrank == iproc_worker2_corners(imsg)) then
+! write(filename,"('buffer_corners_chunks_worker2_msg',i6.6,'.txt')") imsg
+! endif
+!
+! ! matching codes
+! open(unit=IIN,file=prname(1:len_trim(prname))//filename, &
+! status='old',action='read',iostat=ier)
+! if( ier /= 0 ) call exit_MPI(myrank,'error opening buffer_corners_chunks file')
+!
+! read(IIN,*) npoin1D_corner
+! if(npoin1D_corner /= NGLOB1D_RADIAL) then
+! print*,'error ',myrank,' npoin1D_corner: ',npoin1D_corner,'NGLOB1D_RADIAL:',NGLOB1D_RADIAL
+! print*,'iregion_code:',iregion_code
+! call exit_MPI(myrank,'incorrect nb of points in corner buffer')
+! endif
+! do ipoin1D = 1,npoin1D_corner
+! read(IIN,*) iboolcorner(ipoin1D,icount_corners),xdummy,ydummy,zdummy
+! enddo
+! close(IIN)
+!
+! endif
+!
+!
+! enddo
+!
+! endif
+!
+! end subroutine read_arrays_buffers_solver
+!
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/specfem3D_gpu_cuda_method_stubs.c
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/specfem3D_gpu_cuda_method_stubs.c 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/cuda/specfem3D_gpu_cuda_method_stubs.c 2012-08-11 02:22:07 UTC (rev 20565)
@@ -1,4 +1,4 @@
-/*
+/*
!=====================================================================
!
! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
@@ -34,8 +34,8 @@
typedef float realw;
+
-
//
// src/cuda/assemble_MPI_scalar_cuda.cu
//
@@ -43,12 +43,12 @@
void FC_FUNC_(transfer_boun_pot_from_device,
TRANSFER_BOUN_POT_FROM_DEVICE)(long* Mesh_pointer_f,
realw* send_potential_dot_dot_buffer,
- int* FORWARD_OR_ADJOINT){}
+ int* FORWARD_OR_ADJOINT){}
void FC_FUNC_(transfer_asmbl_pot_to_device,
TRANSFER_ASMBL_POT_TO_DEVICE)(long* Mesh_pointer,
realw* buffer_recv_scalar,
- int* FORWARD_OR_ADJOINT) {}
+ int* FORWARD_OR_ADJOINT) {}
//
@@ -59,13 +59,13 @@
TRANSFER_BOUN_ACCEL_FROM_DEVICE)(long* Mesh_pointer_f,
realw* send_accel_buffer,
int* IREGION,
- int* FORWARD_OR_ADJOINT){}
+ int* FORWARD_OR_ADJOINT){}
void FC_FUNC_(transfer_asmbl_accel_to_device,
TRANSFER_ASMBL_ACCEL_TO_DEVICE)(long* Mesh_pointer,
realw* buffer_recv_vector,
int* IREGION,
- int* FORWARD_OR_ADJOINT) {}
+ int* FORWARD_OR_ADJOINT) {}
//
@@ -73,58 +73,58 @@
//
void FC_FUNC_(pause_for_debug,
- PAUSE_FOR_DEBUG)() {}
+ PAUSE_FOR_DEBUG)() {}
void FC_FUNC_(output_free_device_memory,
- OUTPUT_FREE_DEVICE_MEMORY)(int* myrank) {}
+ OUTPUT_FREE_DEVICE_MEMORY)(int* myrank) {}
void FC_FUNC_(get_free_device_memory,
- get_FREE_DEVICE_MEMORY)(realw* free, realw* used, realw* total ) {}
+ get_FREE_DEVICE_MEMORY)(realw* free, realw* used, realw* total ) {}
void FC_FUNC_(check_max_norm_displ_gpu,
- CHECK_MAX_NORM_DISPL_GPU)(int* size, realw* displ,long* Mesh_pointer_f,int* announceID) {}
+ CHECK_MAX_NORM_DISPL_GPU)(int* size, realw* displ,long* Mesh_pointer_f,int* announceID) {}
void FC_FUNC_(check_max_norm_vector,
- CHECK_MAX_NORM_VECTOR)(int* size, realw* vector1, int* announceID) {}
+ CHECK_MAX_NORM_VECTOR)(int* size, realw* vector1, int* announceID) {}
void FC_FUNC_(check_max_norm_displ,
- CHECK_MAX_NORM_DISPL)(int* size, realw* displ, int* announceID) {}
+ CHECK_MAX_NORM_DISPL)(int* size, realw* displ, int* announceID) {}
void FC_FUNC_(check_max_norm_b_displ_gpu,
- CHECK_MAX_NORM_B_DISPL_GPU)(int* size, realw* b_displ,long* Mesh_pointer_f,int* announceID) {}
+ CHECK_MAX_NORM_B_DISPL_GPU)(int* size, realw* b_displ,long* Mesh_pointer_f,int* announceID) {}
void FC_FUNC_(check_max_norm_b_accel_gpu,
- CHECK_MAX_NORM_B_ACCEL_GPU)(int* size, realw* b_accel,long* Mesh_pointer_f,int* announceID) {}
+ CHECK_MAX_NORM_B_ACCEL_GPU)(int* size, realw* b_accel,long* Mesh_pointer_f,int* announceID) {}
void FC_FUNC_(check_max_norm_b_veloc_gpu,
- CHECK_MAX_NORM_B_VELOC_GPU)(int* size, realw* b_veloc,long* Mesh_pointer_f,int* announceID) {}
+ CHECK_MAX_NORM_B_VELOC_GPU)(int* size, realw* b_veloc,long* Mesh_pointer_f,int* announceID) {}
void FC_FUNC_(check_max_norm_b_displ,
- CHECK_MAX_NORM_B_DISPL)(int* size, realw* b_displ,int* announceID) {}
+ CHECK_MAX_NORM_B_DISPL)(int* size, realw* b_displ,int* announceID) {}
void FC_FUNC_(check_max_norm_b_accel,
- CHECK_MAX_NORM_B_ACCEL)(int* size, realw* b_accel,int* announceID) {}
+ CHECK_MAX_NORM_B_ACCEL)(int* size, realw* b_accel,int* announceID) {}
void FC_FUNC_(check_error_vectors,
- CHECK_ERROR_VECTORS)(int* sizef, realw* vector1,realw* vector2) {}
+ CHECK_ERROR_VECTORS)(int* sizef, realw* vector1,realw* vector2) {}
void FC_FUNC_(get_max_accel,
- GET_MAX_ACCEL)(int* itf,int* sizef,long* Mesh_pointer) {}
+ GET_MAX_ACCEL)(int* itf,int* sizef,long* Mesh_pointer) {}
void FC_FUNC_(check_norm_acoustic_from_device,
CHECK_NORM_ACOUSTIC_FROM_DEVICE)(realw* norm,
long* Mesh_pointer_f,
- int* SIMULATION_TYPE) {}
+ int* SIMULATION_TYPE) {}
void FC_FUNC_(check_norm_elastic_from_device,
CHECK_NORM_ELASTIC_FROM_DEVICE)(realw* norm,
long* Mesh_pointer_f,
- int* SIMULATION_TYPE) {}
+ int* SIMULATION_TYPE) {}
void FC_FUNC_(check_norm_strain_from_device,
CHECK_NORM_STRAIN_FROM_DEVICE)(realw* strain_norm,
realw* strain_norm2,
- long* Mesh_pointer_f) {}
+ long* Mesh_pointer_f) {}
//
@@ -134,12 +134,12 @@
void FC_FUNC_(compute_add_sources_el_cuda,
COMPUTE_ADD_SOURCES_EL_CUDA)(long* Mesh_pointer_f,
int* NSOURCESf,
- double* h_stf_pre_compute) {}
+ double* h_stf_pre_compute) {}
void FC_FUNC_(compute_add_sources_el_s3_cuda,
COMPUTE_ADD_SOURCES_EL_S3_CUDA)(long* Mesh_pointer_f,
int* NSOURCESf,
- double* h_stf_pre_compute) {}
+ double* h_stf_pre_compute) {}
void FC_FUNC_(add_sources_el_sim_type_2_or_3,
ADD_SOURCES_EL_SIM_TYPE_2_OR_3)(long* Mesh_pointer,
@@ -147,7 +147,7 @@
realw* h_adj_sourcearrays,
int* h_islice_selected_rec,
int* h_ispec_selected_rec,
- int* time_index) {}
+ int* time_index) {}
//
@@ -155,26 +155,26 @@
//
void FC_FUNC_(compute_coupling_fluid_cmb_cuda,
- COMPUTE_COUPLING_FLUID_CMB_CUDA)(long* Mesh_pointer_f) {}
+ COMPUTE_COUPLING_FLUID_CMB_CUDA)(long* Mesh_pointer_f) {}
void FC_FUNC_(compute_coupling_fluid_icb_cuda,
- COMPUTE_COUPLING_FLUID_ICB_CUDA)(long* Mesh_pointer_f) {}
+ COMPUTE_COUPLING_FLUID_ICB_CUDA)(long* Mesh_pointer_f) {}
void FC_FUNC_(compute_coupling_cmb_fluid_cuda,
COMPUTE_COUPLING_CMB_FLUID_CUDA)(long* Mesh_pointer_f,
double RHO_TOP_OC,
realw minus_g_cmb,
- int GRAVITY_VAL) {}
+ int GRAVITY_VAL) {}
void FC_FUNC_(compute_coupling_icb_fluid_cuda,
COMPUTE_COUPLING_ICB_FLUID_CUDA)(long* Mesh_pointer_f,
double RHO_BOTTOM_OC,
realw minus_g_icb,
- int GRAVITY_VAL) {}
+ int GRAVITY_VAL) {}
void FC_FUNC_(compute_coupling_ocean_cuda,
COMPUTE_COUPLING_OCEAN_CUDA)(long* Mesh_pointer_f,
- int* NCHUNKS_VAL) {}
+ int* NCHUNKS_VAL) {}
//
@@ -184,7 +184,7 @@
void FC_FUNC_(compute_forces_crust_mantle_cuda,
COMPUTE_FORCES_CRUST_MANTLE_CUDA)(long* Mesh_pointer_f,
realw* deltat,
- int* iphase) {}
+ int* iphase) {}
//
@@ -194,7 +194,7 @@
void FC_FUNC_(compute_forces_inner_core_cuda,
COMPUTE_FORCES_INNER_CORE_CUDA)(long* Mesh_pointer_f,
realw* deltat,
- int* iphase) {}
+ int* iphase) {}
//
@@ -205,7 +205,7 @@
COMPUTE_FORCES_OUTER_CORE_CUDA)(long* Mesh_pointer_f,
int* iphase,
realw* time_f,
- realw* b_time_f) {}
+ realw* b_time_f) {}
//
@@ -213,22 +213,22 @@
//
void FC_FUNC_(compute_kernels_cm_cuda,
- COMPUTE_KERNELS_CM_CUDA)(long* Mesh_pointer,realw* deltat_f) {}
+ COMPUTE_KERNELS_CM_CUDA)(long* Mesh_pointer,realw* deltat_f) {}
void FC_FUNC_(compute_kernels_ic_cuda,
- COMPUTE_KERNELS_IC_CUDA)(long* Mesh_pointer,realw* deltat_f) {}
+ COMPUTE_KERNELS_IC_CUDA)(long* Mesh_pointer,realw* deltat_f) {}
void FC_FUNC_(compute_kernels_oc_cuda,
- COMPUTE_KERNELS_OC_CUDA)(long* Mesh_pointer,realw* deltat_f) {}
+ COMPUTE_KERNELS_OC_CUDA)(long* Mesh_pointer,realw* deltat_f) {}
void FC_FUNC_(compute_kernels_strgth_noise_cu,
COMPUTE_KERNELS_STRGTH_NOISE_CU)(long* Mesh_pointer,
realw* h_noise_surface_movie,
- realw* deltat_f) {}
+ realw* deltat_f) {}
void FC_FUNC_(compute_kernels_hess_cuda,
COMPUTE_KERNELS_HESS_CUDA)(long* Mesh_pointer,
- realw* deltat_f) {}
+ realw* deltat_f) {}
//
@@ -238,7 +238,7 @@
void FC_FUNC_(compute_stacey_acoustic_cuda,
COMPUTE_STACEY_ACOUSTIC_CUDA)(long* Mesh_pointer_f,
realw* absorb_potential,
- int* itype) {}
+ int* itype) {}
//
@@ -248,7 +248,7 @@
void FC_FUNC_(compute_stacey_elastic_cuda,
COMPUTE_STACEY_ELASTIC_CUDA)(long* Mesh_pointer_f,
realw* absorb_field,
- int* itype) {}
+ int* itype) {}
//
@@ -256,10 +256,10 @@
//
void FC_FUNC_(initialize_cuda_device,
- INITIALIZE_CUDA_DEVICE)(int* myrank_f,int* ncuda_devices) {
+ INITIALIZE_CUDA_DEVICE)(int* myrank_f,int* ncuda_devices) {
fprintf(stderr,"ERROR: GPU_MODE enabled without GPU/CUDA Support. To enable GPU support, reconfigure with --with-cuda flag.\n");
exit(1);
-}
+}
//
@@ -273,7 +273,7 @@
realw* deltatover2_F,
realw* b_deltat_F,
realw* b_deltatsqover2_F,
- realw* b_deltatover2_F) {}
+ realw* b_deltatover2_F) {}
void FC_FUNC_(it_update_displacement_cm_cuda,
IT_UPDATE_DISPLACMENT_CM_CUDA)(long* Mesh_pointer_f,
@@ -282,7 +282,7 @@
realw* deltatover2_F,
realw* b_deltat_F,
realw* b_deltatsqover2_F,
- realw* b_deltatover2_F) {}
+ realw* b_deltatover2_F) {}
void FC_FUNC_(it_update_displacement_oc_cuda,
IT_UPDATE_DISPLACEMENT_OC_cuda)(long* Mesh_pointer_f,
@@ -291,7 +291,7 @@
realw* deltatover2_F,
realw* b_deltat_F,
realw* b_deltatsqover2_F,
- realw* b_deltatover2_F) {}
+ realw* b_deltatover2_F) {}
void FC_FUNC_(kernel_3_a_cuda,
KERNEL_3_A_CUDA)(long* Mesh_pointer,
@@ -299,49 +299,49 @@
int* SIMULATION_TYPE_f,
realw* b_deltatover2_F,
int* OCEANS,
- int* NCHUNKS_VAL) {}
+ int* NCHUNKS_VAL) {}
void FC_FUNC_(kernel_3_b_cuda,
KERNEL_3_B_CUDA)(long* Mesh_pointer,
realw* deltatover2_F,
int* SIMULATION_TYPE_f,
realw* b_deltatover2_F,
- int* OCEANS) {}
+ int* OCEANS) {}
void FC_FUNC_(kernel_3_outer_core_cuda,
KERNEL_3_OUTER_CORE_CUDA)(long* Mesh_pointer,
realw* deltatover2_F,
int* SIMULATION_TYPE_f,
- realw* b_deltatover2_F) {}
+ realw* b_deltatover2_F) {}
//
// src/cuda/noise_tomography_cuda.cu
//
-void FC_FUNC_(fortranflush,FORTRANFLUSH)(int* rank){}
+void FC_FUNC_(fortranflush,FORTRANFLUSH)(int* rank){}
-void FC_FUNC_(fortranprint,FORTRANPRINT)(int* id) {}
+void FC_FUNC_(fortranprint,FORTRANPRINT)(int* id) {}
-void FC_FUNC_(fortranprintf,FORTRANPRINTF)(realw* val) {}
+void FC_FUNC_(fortranprintf,FORTRANPRINTF)(realw* val) {}
-void FC_FUNC_(fortranprintd,FORTRANPRINTD)(double* val) {}
+void FC_FUNC_(fortranprintd,FORTRANPRINTD)(double* val) {}
-void FC_FUNC_(make_displ_rand,MAKE_DISPL_RAND)(long* Mesh_pointer_f,realw* h_displ) {}
+void FC_FUNC_(make_displ_rand,MAKE_DISPL_RAND)(long* Mesh_pointer_f,realw* h_displ) {}
void FC_FUNC_(noise_transfer_surface_to_host,
NOISE_TRANSFER_SURFACE_TO_HOST)(long* Mesh_pointer_f,
- realw* h_noise_surface_movie) {}
+ realw* h_noise_surface_movie) {}
void FC_FUNC_(noise_add_source_master_rec_cu,
NOISE_ADD_SOURCE_MASTER_REC_CU)(long* Mesh_pointer_f,
int* it_f,
int* irec_master_noise_f,
- int* islice_selected_rec) {}
+ int* islice_selected_rec) {}
void FC_FUNC_(noise_add_surface_movie_cuda,
NOISE_ADD_SURFACE_MOVIE_CUDA)(long* Mesh_pointer_f,
- realw* h_noise_surface_movie) {}
+ realw* h_noise_surface_movie) {}
//
@@ -383,7 +383,7 @@
int* SAVE_BOUNDARY_MESH_f,
int* USE_MESH_COLORING_GPU_f,
int* ANISOTROPIC_KL_f,
- int* APPROXIMATE_HESS_KL_f) {}
+ int* APPROXIMATE_HESS_KL_f) {}
void FC_FUNC_(prepare_fields_rotation_device,
PREPARE_FIELDS_ROTATION_DEVICE)(long* Mesh_pointer_f,
@@ -396,7 +396,7 @@
realw* b_A_array_rotation,
realw* b_B_array_rotation,
int* NSPEC_OUTER_CORE_ROTATION
- ) {}
+ ) {}
void FC_FUNC_(prepare_fields_gravity_device,
PREPARE_FIELDS_gravity_DEVICE)(long* Mesh_pointer_f,
@@ -407,7 +407,7 @@
realw* density_table,
realw* h_wgll_cube,
int* NRAD_GRAVITY
- ) {}
+ ) {}
void FC_FUNC_(prepare_fields_attenuat_device,
PREPARE_FIELDS_ATTENUAT_DEVICE)(long* Mesh_pointer_f,
@@ -427,7 +427,7 @@
realw* one_minus_sum_beta_inner_core,
realw* alphaval,realw* betaval,realw* gammaval,
realw* b_alphaval,realw* b_betaval,realw* b_gammaval
- ) {}
+ ) {}
void FC_FUNC_(prepare_fields_strain_device,
PREPARE_FIELDS_STRAIN_DEVICE)(long* Mesh_pointer_f,
@@ -455,7 +455,7 @@
realw* b_epsilondev_yz_inner_core,
realw* eps_trace_over_3_inner_core,
realw* b_eps_trace_over_3_inner_core
- ) {}
+ ) {}
void FC_FUNC_(prepare_fields_absorb_device,
PREPARE_FIELDS_ABSORB_DEVICE)(long* Mesh_pointer_f,
@@ -487,7 +487,7 @@
realw* jacobian2D_ymin_outer_core, realw* jacobian2D_ymax_outer_core,
realw* jacobian2D_bottom_outer_core,
realw* vp_outer_core
- ) {}
+ ) {}
void FC_FUNC_(prepare_mpi_buffers_device,
PREPARE_MPI_BUFFERS_DEVICE)(long* Mesh_pointer_f,
@@ -503,7 +503,7 @@
int* max_nibool_interfaces_outer_core,
int* nibool_interfaces_outer_core,
int* ibool_interfaces_outer_core
- ){}
+ ){}
void FC_FUNC_(prepare_fields_noise_device,
PREPARE_FIELDS_NOISE_DEVICE)(long* Mesh_pointer_f,
@@ -515,7 +515,7 @@
realw* normal_y_noise,
realw* normal_z_noise,
realw* mask_noise,
- realw* jacobian2D_top_crust_mantle) {}
+ realw* jacobian2D_top_crust_mantle) {}
void FC_FUNC_(prepare_crust_mantle_device,
PREPARE_CRUST_MANTLE_DEVICE)(long* Mesh_pointer_f,
@@ -549,7 +549,7 @@
int* NSPEC2D_TOP_CM,
int* NSPEC2D_BOTTOM_CM,
int* NCHUNKS_VAL
- ) {}
+ ) {}
void FC_FUNC_(prepare_outer_core_device,
PREPARE_OUTER_CORE_DEVICE)(long* Mesh_pointer_f,
@@ -572,7 +572,7 @@
int* nspec_inner,
int* NSPEC2D_TOP_OC,
int* NSPEC2D_BOTTOM_OC
- ) {}
+ ) {}
void FC_FUNC_(prepare_inner_core_device,
PREPARE_INNER_CORE_DEVICE)(long* Mesh_pointer_f,
@@ -591,15 +591,15 @@
int* phase_ispec_inner,
int* nspec_outer,
int* nspec_inner,
- int* NSPEC2D_TOP_IC) {}
+ int* NSPEC2D_TOP_IC) {}
void FC_FUNC_(prepare_oceans_device,
PREPARE_OCEANS_DEVICE)(long* Mesh_pointer_f,
- realw* h_rmass_ocean_load) {}
+ realw* h_rmass_ocean_load) {}
void FC_FUNC_(prepare_cleanup_device,
PREPARE_CLEANUP_DEVICE)(long* Mesh_pointer_f,
- int* NCHUNKS_VAL) {}
+ int* NCHUNKS_VAL) {}
//
@@ -607,82 +607,82 @@
//
void FC_FUNC_(transfer_fields_cm_to_device,
- TRANSFER_FIELDS_CM_TO_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_FIELDS_CM_TO_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_fields_ic_to_device,
- TRANSFER_FIELDS_IC_TO_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_FIELDS_IC_TO_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_fields_oc_to_device,
- TRANSFER_FIELDS_OC_TO_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_FIELDS_OC_TO_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_fields_cm_to_device,
TRANSFER_FIELDS_B_CM_TO_DEVICE)(int* size, realw* b_displ, realw* b_veloc, realw* b_accel,
- long* Mesh_pointer_f) {}
+ long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_fields_ic_to_device,
TRANSFER_FIELDS_B_IC_TO_DEVICE)(int* size, realw* b_displ, realw* b_veloc, realw* b_accel,
- long* Mesh_pointer_f) {}
+ long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_fields_oc_to_device,
TRANSFER_FIELDS_B_OC_TO_DEVICE)(int* size, realw* b_displ, realw* b_veloc, realw* b_accel,
- long* Mesh_pointer_f) {}
+ long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_fields_cm_from_device,
- TRANSFER_FIELDS_CM_FROM_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_FIELDS_CM_FROM_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_fields_ic_from_device,
- TRANSFER_FIELDS_IC_FROM_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_FIELDS_IC_FROM_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_fields_oc_from_device,
- TRANSFER_FIELDS_OC_FROM_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_FIELDS_OC_FROM_DEVICE)(int* size, realw* displ, realw* veloc, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_fields_cm_from_device,
TRANSFER_B_FIELDS_CM_FROM_DEVICE)(int* size, realw* b_displ, realw* b_veloc, realw* b_accel,
- long* Mesh_pointer_f) {}
+ long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_fields_ic_from_device,
TRANSFER_B_FIELDS_IC_FROM_DEVICE)(int* size, realw* b_displ, realw* b_veloc, realw* b_accel,
- long* Mesh_pointer_f) {}
+ long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_fields_oc_from_device,
TRANSFER_B_FIELDS_OC_FROM_DEVICE)(int* size, realw* b_displ, realw* b_veloc, realw* b_accel,
- long* Mesh_pointer_f) {}
+ long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_accel_cm_to_device,
- TRANSFER_ACCEL_CM_TO_DEVICE)(int* size, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_ACCEL_CM_TO_DEVICE)(int* size, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_displ_cm_from_device,
- TRANSFER_DISPL_CM_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
+ TRANSFER_DISPL_CM_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_displ_cm_from_device,
- TRANSFER_B_DISPL_CM_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
+ TRANSFER_B_DISPL_CM_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_displ_ic_from_device,
- TRANSFER_DISPL_IC_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
+ TRANSFER_DISPL_IC_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_displ_ic_from_device,
- TRANSFER_B_DISPL_IC_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
+ TRANSFER_B_DISPL_IC_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_displ_oc_from_device,
- TRANSFER_DISPL_OC_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
+ TRANSFER_DISPL_OC_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_displ_oc_from_device,
- TRANSFER_B_DISPL_OC_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
+ TRANSFER_B_DISPL_OC_FROM_DEVICE)(int* size, realw* displ, long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_veloc_cm_from_device,
- TRANSFER_DISPL_CM_FROM_DEVICE)(int* size, realw* veloc, long* Mesh_pointer_f) {}
+ TRANSFER_DISPL_CM_FROM_DEVICE)(int* size, realw* veloc, long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_accel_cm_from_device,
- TRANSFER_ACCEL_CM_FROM_DEVICE)(int* size, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_ACCEL_CM_FROM_DEVICE)(int* size, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_b_accel_cm_from_device,
- TRANSFER_B_ACCEL_CM_FROM_DEVICE)(int* size, realw* b_accel,long* Mesh_pointer_f) {}
+ TRANSFER_B_ACCEL_CM_FROM_DEVICE)(int* size, realw* b_accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_accel_ic_from_device,
- TRANSFER_ACCEL_IC_FROM_DEVICE)(int* size, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_ACCEL_IC_FROM_DEVICE)(int* size, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_accel_oc_from_device,
- TRANSFER_ACCEL_OC_FROM_DEVICE)(int* size, realw* accel,long* Mesh_pointer_f) {}
+ TRANSFER_ACCEL_OC_FROM_DEVICE)(int* size, realw* accel,long* Mesh_pointer_f) {}
void FC_FUNC_(transfer_strain_cm_from_device,
TRANSFER_STRAIN_CM_FROM_DEVICE)(long* Mesh_pointer,
@@ -691,7 +691,7 @@
realw* epsilondev_yy,
realw* epsilondev_xy,
realw* epsilondev_xz,
- realw* epsilondev_yz) {}
+ realw* epsilondev_yz) {}
void FC_FUNC_(transfer_b_strain_cm_to_device,
TRANSFER_B_STRAIN_CM_TO_DEVICE)(long* Mesh_pointer,
@@ -699,7 +699,7 @@
realw* epsilondev_yy,
realw* epsilondev_xy,
realw* epsilondev_xz,
- realw* epsilondev_yz) {}
+ realw* epsilondev_yz) {}
void FC_FUNC_(transfer_strain_ic_from_device,
TRANSFER_STRAIN_IC_FROM_DEVICE)(long* Mesh_pointer,
@@ -708,7 +708,7 @@
realw* epsilondev_yy,
realw* epsilondev_xy,
realw* epsilondev_xz,
- realw* epsilondev_yz) {}
+ realw* epsilondev_yz) {}
void FC_FUNC_(transfer_b_strain_ic_to_device,
TRANSFER_B_STRAIN_IC_TO_DEVICE)(long* Mesh_pointer,
@@ -716,17 +716,17 @@
realw* epsilondev_yy,
realw* epsilondev_xy,
realw* epsilondev_xz,
- realw* epsilondev_yz) {}
+ realw* epsilondev_yz) {}
void FC_FUNC_(transfer_rotation_from_device,
TRANSFER_ROTATION_FROM_DEVICE)(long* Mesh_pointer,
realw* A_array_rotation,
- realw* B_array_rotation) {}
+ realw* B_array_rotation) {}
void FC_FUNC_(transfer_b_rotation_to_device,
TRANSFER_B_ROTATION_TO_DEVICE)(long* Mesh_pointer,
realw* A_array_rotation,
- realw* B_array_rotation) {}
+ realw* B_array_rotation) {}
void FC_FUNC_(transfer_kernels_cm_to_host,
TRANSFER_KERNELS_CM_TO_HOST)(long* Mesh_pointer,
@@ -734,30 +734,30 @@
realw* h_alpha_kl,
realw* h_beta_kl,
realw* h_cijkl_kl,
- int* NSPEC) {}
+ int* NSPEC) {}
void FC_FUNC_(transfer_kernels_ic_to_host,
TRANSFER_KERNELS_IC_TO_HOST)(long* Mesh_pointer,
realw* h_rho_kl,
realw* h_alpha_kl,
realw* h_beta_kl,
- int* NSPEC) {}
+ int* NSPEC) {}
void FC_FUNC_(transfer_kernels_oc_to_host,
TRANSFER_KERNELS_OC_TO_HOST)(long* Mesh_pointer,
realw* h_rho_kl,
realw* h_alpha_kl,
- int* NSPEC) {}
+ int* NSPEC) {}
void FC_FUNC_(transfer_kernels_noise_to_host,
TRANSFER_KERNELS_NOISE_TO_HOST)(long* Mesh_pointer,
realw* h_Sigma_kl,
- int* NSPEC) {}
+ int* NSPEC) {}
void FC_FUNC_(transfer_kernels_hess_cm_tohost,
TRANSFER_KERNELS_HESS_CM_TOHOST)(long* Mesh_pointer,
realw* h_hess_kl,
- int* NSPEC) {}
+ int* NSPEC) {}
//
@@ -777,7 +777,7 @@
int* number_receiver_global,
int* ispec_selected_rec,
int* ispec_selected_source,
- int* ibool) {}
+ int* ibool) {}
void FC_FUNC_(transfer_station_ac_from_device,
TRANSFER_STATION_AC_FROM_DEVICE)(
@@ -792,5 +792,5 @@
int* ispec_selected_rec,
int* ispec_selected_source,
int* ibool,
- int* SIMULATION_TYPEf) {}
+ int* SIMULATION_TYPEf) {}
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/Makefile.in
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/Makefile.in 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/Makefile.in 2012-08-11 02:22:07 UTC (rev 20565)
@@ -166,7 +166,6 @@
$O/model_sea1d.o \
$O/model_sea99_s.mpi.o \
$O/moho_stretching.o \
- $O/read_arrays_buffers_mesher.mpi.o \
$O/save_arrays_solver.o \
$O/setup_color_perm.o \
$O/setup_inner_outer.o \
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_MPI_interfaces.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_MPI_interfaces.f90 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_MPI_interfaces.f90 2012-08-11 02:22:07 UTC (rev 20565)
@@ -30,20 +30,18 @@
subroutine create_MPI_interfaces(iregion_code)
implicit none
+
integer,intent(in):: iregion_code
! sets up arrays
call cmi_allocate_addressing(iregion_code)
- ! reads in arrays
- call cmi_read_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_read_buffers(iregion_code)
+ call cmi_get_buffers(iregion_code)
- ! sets up MPI interfaces
- call setup_MPI_interfaces(iregion_code)
-
end subroutine create_MPI_interfaces
!
@@ -59,53 +57,24 @@
NCHUNKS,myrank,NGLOB1D_RADIAL,NUMCORNERS_SHARED,NPROC_XI,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 :: NUM_FACES,NPROC_ONE_DIRECTION
integer :: ier
- ! define maximum size for message buffers
- ! use number of elements found in the mantle since it is the largest region
- NGLOB2DMAX_XY = max(NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE))
-
- ! initializes
- NCORNERSCHUNKS = 0
- NUM_FACES = 0
- NUM_MSG_TYPES = 0
-
- ! number of corners and faces shared between chunks and number of message types
- if(NCHUNKS == 1 .or. NCHUNKS == 2) then
- NCORNERSCHUNKS = 1
- NUM_FACES = 1
- NUM_MSG_TYPES = 1
- else if(NCHUNKS == 3) then
- NCORNERSCHUNKS = 1
- NUM_FACES = 1
- NUM_MSG_TYPES = 3
- else if(NCHUNKS == 6) then
- NCORNERSCHUNKS = 8
- NUM_FACES = 4
- NUM_MSG_TYPES = 3
- else
- call exit_MPI(myrank,'number of chunks must be either 1, 2, 3 or 6')
- endif
-
- ! if more than one chunk then same number of processors in each direction
- NPROC_ONE_DIRECTION = NPROC_XI
- ! total number of messages corresponding to these common faces
- NUMMSGS_FACES = NPROC_ONE_DIRECTION*NUM_FACES*NUM_MSG_TYPES
-
! 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
@@ -157,17 +126,6 @@
end select
! allocates arrays
- allocate(iprocfrom_faces(NUMMSGS_FACES), &
- iprocto_faces(NUMMSGS_FACES), &
- imsg_type(NUMMSGS_FACES),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating iproc faces arrays')
-
- ! communication pattern for corners between chunks
- allocate(iproc_master_corners(NCORNERSCHUNKS), &
- iproc_worker1_corners(NCORNERSCHUNKS), &
- iproc_worker2_corners(NCORNERSCHUNKS),stat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error allocating iproc corner arrays')
-
allocate(buffer_send_chunkcorn_scalar(NGLOB1D_RADIAL_CM), &
buffer_recv_chunkcorn_scalar(NGLOB1D_RADIAL_CM))
@@ -263,7 +221,7 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine cmi_read_addressing(iregion_code)
+ subroutine cmi_get_addressing(iregion_code)
use meshfem3D_par,only: &
myrank,LOCAL_PATH
@@ -281,12 +239,10 @@
case( IREGION_CRUST_MANTLE )
! crust mantle
ibool_crust_mantle(:,:,:,:) = -1
- call cmi_read_solver_data(myrank,IREGION_CRUST_MANTLE, &
- NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE, &
+ call cmi_read_solver_data(NSPEC_CRUST_MANTLE,NGLOB_CRUST_MANTLE, &
xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle,&
ibool_crust_mantle,idoubling_crust_mantle, &
- is_on_a_slice_edge_crust_mantle, &
- LOCAL_PATH)
+ is_on_a_slice_edge_crust_mantle)
! check that the number of points in this slice is correct
if(minval(ibool_crust_mantle(:,:,:,:)) /= 1 .or. &
@@ -296,12 +252,10 @@
case( IREGION_OUTER_CORE )
! outer core
ibool_outer_core(:,:,:,:) = -1
- call cmi_read_solver_data(myrank,IREGION_OUTER_CORE, &
- NSPEC_OUTER_CORE,NGLOB_OUTER_CORE, &
+ call cmi_read_solver_data(NSPEC_OUTER_CORE,NGLOB_OUTER_CORE, &
xstore_outer_core,ystore_outer_core,zstore_outer_core,&
ibool_outer_core,idoubling_outer_core, &
- is_on_a_slice_edge_outer_core, &
- LOCAL_PATH)
+ is_on_a_slice_edge_outer_core)
! check that the number of points in this slice is correct
if(minval(ibool_outer_core(:,:,:,:)) /= 1 .or. &
@@ -311,12 +265,10 @@
case( IREGION_INNER_CORE )
! inner core
ibool_inner_core(:,:,:,:) = -1
- call cmi_read_solver_data(myrank,IREGION_INNER_CORE, &
- NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
+ call cmi_read_solver_data(NSPEC_INNER_CORE,NGLOB_INNER_CORE, &
xstore_inner_core,ystore_inner_core,zstore_inner_core,&
ibool_inner_core,idoubling_inner_core, &
- is_on_a_slice_edge_inner_core, &
- LOCAL_PATH)
+ is_on_a_slice_edge_inner_core)
! 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) &
@@ -327,37 +279,48 @@
! synchronize processes
call sync_all()
- end subroutine cmi_read_addressing
+ end subroutine cmi_get_addressing
!
!-------------------------------------------------------------------------------------------------
!
- subroutine cmi_read_buffers(iregion_code)
+ subroutine cmi_get_buffers(iregion_code)
use meshfem3D_par,only: myrank,&
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB1D_RADIAL,NSPEC2D_BOTTOM, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NGLOB1D_RADIAL,NSPEC2D_BOTTOM, &
NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
NPROCTOT,NPROC_XI,NPROC_ETA,LOCAL_PATH,NCHUNKS,OUTPUT_FILES,IIN,INCLUDE_CENTRAL_CUBE, &
iproc_xi,iproc_eta,ichunk,addressing
+ use create_regions_mesh_par2,only: &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
+ normal_xmin,normal_xmax,normal_ymin,normal_ymax,normal_bottom,normal_top, &
+ jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax, &
+ jacobian2D_bottom,jacobian2D_top, &
+ rho_vp,rho_vs, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ ispec_is_tiso,tau_s,T_c_source,tau_e_store,Qmu_store
+
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
- integer njunk1,njunk2
- character(len=150) prname
+
! debug
logical,parameter :: DEBUG_FLAGS = .false.
character(len=150) :: filename
- ! read 2-D addressing for summation between slices with MPI
+ ! gets 2-D addressing for summation between slices with MPI
select case( iregion_code )
case( IREGION_CRUST_MANTLE )
@@ -366,21 +329,16 @@
write(IMAIN,*)
write(IMAIN,*) 'crust/mantle region:'
endif
- ! initializes
- npoin2D_xi_crust_mantle(:) = 0
- npoin2D_eta_crust_mantle(:) = 0
+ 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)
- call read_arrays_buffers_mesher(IREGION_CRUST_MANTLE,myrank,iboolleft_xi_crust_mantle, &
- iboolright_xi_crust_mantle,iboolleft_eta_crust_mantle,iboolright_eta_crust_mantle, &
- npoin2D_xi_crust_mantle,npoin2D_eta_crust_mantle, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- iboolfaces_crust_mantle,npoin2D_faces_crust_mantle, &
- iboolcorner_crust_mantle, &
- NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE), &
- NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_XY,NGLOB1D_RADIAL(IREGION_CRUST_MANTLE), &
- NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT,NPROC_XI,NPROC_ETA,LOCAL_PATH,NCHUNKS)
-
! 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
@@ -415,20 +373,16 @@
write(IMAIN,*)
write(IMAIN,*) 'outer core region:'
endif
- npoin2D_xi_outer_core(:) = 0
- npoin2D_eta_outer_core(:) = 0
+ 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)
- call read_arrays_buffers_mesher(IREGION_OUTER_CORE,myrank, &
- iboolleft_xi_outer_core,iboolright_xi_outer_core,iboolleft_eta_outer_core,iboolright_eta_outer_core, &
- npoin2D_xi_outer_core,npoin2D_eta_outer_core, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- iboolfaces_outer_core,npoin2D_faces_outer_core, &
- iboolcorner_outer_core, &
- NGLOB2DMAX_XMIN_XMAX(IREGION_OUTER_CORE), &
- NGLOB2DMAX_YMIN_YMAX(IREGION_OUTER_CORE),NGLOB2DMAX_XY,NGLOB1D_RADIAL(IREGION_OUTER_CORE), &
- NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT,NPROC_XI,NPROC_ETA,LOCAL_PATH,NCHUNKS)
-
! 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
@@ -461,44 +415,29 @@
write(IMAIN,*)
write(IMAIN,*) 'inner core region:'
endif
- npoin2D_xi_inner_core(:) = 0
- npoin2D_eta_inner_core(:) = 0
- call read_arrays_buffers_mesher(IREGION_INNER_CORE,myrank, &
- iboolleft_xi_inner_core,iboolright_xi_inner_core,iboolleft_eta_inner_core,iboolright_eta_inner_core, &
- npoin2D_xi_inner_core,npoin2D_eta_inner_core, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- iboolfaces_inner_core,npoin2D_faces_inner_core, &
- iboolcorner_inner_core, &
- NGLOB2DMAX_XMIN_XMAX(IREGION_INNER_CORE), &
- NGLOB2DMAX_YMIN_YMAX(IREGION_INNER_CORE),NGLOB2DMAX_XY,NGLOB1D_RADIAL(IREGION_INNER_CORE), &
- NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT,NPROC_XI,NPROC_ETA,LOCAL_PATH,NCHUNKS)
+ 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)
- ! read coupling arrays for inner core
- ! create name of database
- call create_name_database(prname,myrank,IREGION_INNER_CORE,LOCAL_PATH)
+ ! 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
- ! read info for vertical edges for central cube matching in inner core
- open(unit=IIN,file=prname(1:len_trim(prname))//'boundary.bin', &
- status='old',form='unformatted',action='read',iostat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error opening boundary.bin file')
+ 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(:)
- read(IIN) nspec2D_xmin_inner_core
- read(IIN) nspec2D_xmax_inner_core
- read(IIN) nspec2D_ymin_inner_core
- read(IIN) nspec2D_ymax_inner_core
- read(IIN) njunk1
- read(IIN) njunk2
-
- ! boundary parameters
- read(IIN) ibelm_xmin_inner_core
- read(IIN) ibelm_xmax_inner_core
- read(IIN) ibelm_ymin_inner_core
- read(IIN) ibelm_ymax_inner_core
- read(IIN) ibelm_bottom_inner_core
- read(IIN) ibelm_top_inner_core
- close(IIN)
-
! central cube buffers
if(INCLUDE_CENTRAL_CUBE) then
@@ -598,267 +537,156 @@
end select
- end subroutine cmi_read_buffers
+ end subroutine cmi_get_buffers
+
!
!-------------------------------------------------------------------------------------------------
!
+ subroutine cmi_read_solver_data(nspec,nglob, &
+ xstore_s,ystore_s,zstore_s, &
+ ibool_s,idoubling_s,is_on_a_slice_edge_s)
- subroutine cmi_save_MPI_interfaces(iregion_code)
use meshfem3D_par,only: &
- myrank,LOCAL_PATH
+ ibool,idoubling,is_on_a_slice_edge, &
+ xstore,ystore,zstore
- 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
+ include "constants.h"
- select case( iregion_code )
- case( IREGION_CRUST_MANTLE )
- ! crust mantle
- call cmi_save_solver_data(myrank,IREGION_CRUST_MANTLE,LOCAL_PATH, &
- num_interfaces_crust_mantle,max_nibool_interfaces_crust_mantle, &
- my_neighbours_crust_mantle,nibool_interfaces_crust_mantle, &
- ibool_interfaces_crust_mantle, &
- nspec_inner_crust_mantle,nspec_outer_crust_mantle, &
- num_phase_ispec_crust_mantle,phase_ispec_inner_crust_mantle, &
- num_colors_outer_crust_mantle,num_colors_inner_crust_mantle, &
- num_elem_colors_crust_mantle)
+ integer :: nspec,nglob
+ ! global mesh points
+ real(kind=CUSTOM_REAL), dimension(nglob) :: xstore_s,ystore_s,zstore_s
- case( IREGION_OUTER_CORE )
- ! outer core
- call cmi_save_solver_data(myrank,IREGION_OUTER_CORE,LOCAL_PATH, &
- num_interfaces_outer_core,max_nibool_interfaces_outer_core, &
- my_neighbours_outer_core,nibool_interfaces_outer_core, &
- ibool_interfaces_outer_core, &
- nspec_inner_outer_core,nspec_outer_outer_core, &
- num_phase_ispec_outer_core,phase_ispec_inner_outer_core, &
- num_colors_outer_outer_core,num_colors_inner_outer_core, &
- num_elem_colors_outer_core)
+ ! mesh indices
+ integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool_s
+ integer, dimension(nspec) :: idoubling_s
+ logical, dimension(nspec) :: is_on_a_slice_edge_s
- case( IREGION_INNER_CORE )
- ! inner core
- call cmi_save_solver_data(myrank,IREGION_INNER_CORE,LOCAL_PATH, &
- num_interfaces_inner_core,max_nibool_interfaces_inner_core, &
- my_neighbours_inner_core,nibool_interfaces_inner_core, &
- ibool_interfaces_inner_core, &
- nspec_inner_inner_core,nspec_outer_inner_core, &
- num_phase_ispec_inner_core,phase_ispec_inner_inner_core, &
- num_colors_outer_inner_core,num_colors_inner_inner_core, &
- num_elem_colors_inner_core)
+ ! local parameters
+ integer :: i,j,k,ispec,iglob
- end select
+ ! copy arrays
+ ibool_s(:,:,:,:) = ibool(:,:,:,:)
+ idoubling_s(:) = idoubling(:)
+ is_on_a_slice_edge_s(:) = is_on_a_slice_edge(:)
- end subroutine cmi_save_MPI_interfaces
+ ! 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_free_MPI_arrays(iregion_code)
+ 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
- use MPI_crust_mantle_par
- use MPI_outer_core_par
- use MPI_inner_core_par
- implicit none
- integer,intent(in):: iregion_code
-
- ! free memory
- 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)
-
- deallocate(phase_ispec_inner_crust_mantle)
- deallocate(num_elem_colors_crust_mantle)
-
- deallocate(xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle)
- deallocate(idoubling_crust_mantle,ibool_crust_mantle)
-
- deallocate(is_on_a_slice_edge_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)
-
- deallocate(phase_ispec_inner_outer_core)
- deallocate(num_elem_colors_outer_core)
-
- deallocate(xstore_outer_core,ystore_outer_core,zstore_outer_core)
- deallocate(idoubling_outer_core,ibool_outer_core)
-
- deallocate(is_on_a_slice_edge_outer_core)
-
- case( IREGION_INNER_CORE )
- ! inner core
- deallocate(ibelm_xmin_inner_core, &
- ibelm_xmax_inner_core)
- deallocate(ibelm_ymin_inner_core, &
- ibelm_ymax_inner_core)
- deallocate(ibelm_bottom_inner_core)
- deallocate(ibelm_top_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)
-
- deallocate(xstore_inner_core,ystore_inner_core,zstore_inner_core)
- deallocate(idoubling_inner_core,ibool_inner_core)
-
- deallocate(phase_ispec_inner_inner_core)
- deallocate(num_elem_colors_inner_core)
-
- deallocate(is_on_a_slice_edge_inner_core)
-
- end select
-
- end subroutine cmi_free_MPI_arrays
-
-!
-!-------------------------------------------------------------------------------------------------
-!
-
- subroutine cmi_read_solver_data(myrank,iregion_code, &
- nspec,nglob, &
- xstore,ystore,zstore, &
- ibool,idoubling,is_on_a_slice_edge, &
- LOCAL_PATH)
implicit none
- include "constants.h"
+ integer :: iregion_code
- integer :: iregion_code,myrank
+ integer :: NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
+ integer :: NGLOB1D_RADIAL
- integer :: nspec,nglob
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi_s,iboolright_xi_s
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta_s,iboolright_eta_s
- real(kind=CUSTOM_REAL), dimension(nglob) :: xstore,ystore,zstore
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- integer, dimension(nspec) :: idoubling
- logical, dimension(nspec) :: is_on_a_slice_edge
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_s,npoin2D_eta_s
- character(len=150) :: LOCAL_PATH
+ 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
- character(len=150) prname
- integer :: ier
+ integer :: icount_faces,imsg
- ! create the name for the database of the current slide and region
- call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
+ ! gets 2-D arrays
+ npoin2D_xi_s(:) = npoin2D_xi_all(:)
+ npoin2D_eta_s(:) = npoin2D_eta_all(:)
- open(unit=IIN,file=prname(1:len_trim(prname))//'solver_data_2.bin', &
- status='old',action='read',form='unformatted',iostat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error opening solver_data_2.bin')
+ ! 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(:)
- read(IIN) xstore
- read(IIN) ystore
- read(IIN) zstore
- read(IIN) ibool
- read(IIN) idoubling
- read(IIN) is_on_a_slice_edge
+ ! gets corner infos
+ iboolcorner_s(:,:) = iboolcorner(:,:)
- close(IIN)
+ ! gets face infos
+ npoin2D_faces_s(:) = npoin2D_faces(:)
+ iboolfaces_s(:,:) = iboolfaces(:,:)
- end subroutine cmi_read_solver_data
+ ! 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
- subroutine cmi_save_solver_data(myrank,iregion_code,LOCAL_PATH, &
- num_interfaces,max_nibool_interfaces, &
- my_neighbours,nibool_interfaces, &
- ibool_interfaces, &
- nspec_inner,nspec_outer, &
- num_phase_ispec,phase_ispec_inner, &
- num_colors_outer,num_colors_inner, &
- num_elem_colors)
- implicit none
-
- include "constants.h"
-
- integer :: iregion_code,myrank
-
- character(len=150) :: LOCAL_PATH
-
- ! MPI interfaces
- integer :: num_interfaces,max_nibool_interfaces
- integer, dimension(num_interfaces) :: my_neighbours
- integer, dimension(num_interfaces) :: nibool_interfaces
- integer, dimension(max_nibool_interfaces,num_interfaces) :: &
- ibool_interfaces
-
- ! inner/outer elements
- integer :: nspec_inner,nspec_outer
- integer :: num_phase_ispec
- integer,dimension(num_phase_ispec,2) :: phase_ispec_inner
-
- ! mesh coloring
- integer :: num_colors_outer,num_colors_inner
- integer, dimension(num_colors_outer + num_colors_inner) :: &
- num_elem_colors
-
- ! local parameters
- character(len=150) prname
- integer :: ier
-
- ! create the name for the database of the current slide and region
- call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
-
- open(unit=IOUT,file=prname(1:len_trim(prname))//'solver_data_mpi.bin', &
- status='unknown',action='write',form='unformatted',iostat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error opening solver_data_mpi.bin')
-
- ! MPI interfaces
- write(IOUT) num_interfaces
- if( num_interfaces > 0 ) then
- write(IOUT) max_nibool_interfaces
- write(IOUT) my_neighbours
- write(IOUT) nibool_interfaces
- write(IOUT) ibool_interfaces
+ ! 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
- ! inner/outer elements
- write(IOUT) nspec_inner,nspec_outer
- write(IOUT) num_phase_ispec
- if(num_phase_ispec > 0 ) write(IOUT) phase_ispec_inner
+ end subroutine cmi_read_buffer_data
- ! mesh coloring
- if( USE_MESH_COLORING_GPU ) then
- write(IOUT) num_colors_outer,num_colors_inner
- write(IOUT) num_elem_colors
- endif
-
- close(IOUT)
-
- end subroutine cmi_save_solver_data
-
-
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_chunk_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_chunk_buffers.f90 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_chunk_buffers.f90 2012-08-11 02:22:07 UTC (rev 20565)
@@ -28,68 +28,58 @@
! subroutine to create MPI buffers to assemble between chunks
subroutine create_chunk_buffers(iregion_code,nspec,ibool,idoubling, &
- xstore,ystore,zstore, &
- nglob_ori, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NPROC_XI,NPROC_ETA,NPROC,NPROCTOT, &
+ xstore,ystore,zstore,nglob_ori, &
NGLOB1D_RADIAL_CORNER,NGLOB1D_RADIAL_MAX, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- myrank,LOCAL_PATH,addressing, &
- ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax)
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX)
+ use meshfem3D_par,only: &
+ myrank,LOCAL_PATH,NCHUNKS,addressing, &
+ ichunk_slice,iproc_xi_slice,iproc_eta_slice, &
+ NPROC_XI,NPROC_ETA,NPROC,NPROCTOT
+
+ use create_MPI_interfaces_par,only: &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta, &
+ xyz1D_leftxi_lefteta,xyz1D_rightxi_lefteta, &
+ xyz1D_leftxi_righteta,xyz1D_rightxi_righteta, &
+ NUMMSGS_FACES,NCORNERSCHUNKS,NUM_MSG_TYPES, &
+ iprocfrom_faces,iprocto_faces,imsg_type, &
+ iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
+ npoin2D_faces,iboolfaces,iboolcorner
+
+ use create_regions_mesh_par2,only: &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax
+
implicit none
include "constants.h"
- integer iregion_code
- integer nspec
+ integer :: iregion_code
+ integer :: nspec
! array with the local to global mapping per slice
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+ integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ integer,dimension(nspec) :: idoubling
- integer idoubling(nspec)
-
! arrays with the mesh
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
- integer nglob_ori
+ integer :: nglob_ori
- integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
- integer NPROC,NPROC_XI,NPROC_ETA,NPROCTOT
-
- integer NGLOB1D_RADIAL_MAX
integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NGLOB1D_RADIAL_CORNER
- integer NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
+ integer :: NGLOB1D_RADIAL_MAX
+ integer :: NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
- integer myrank
- character(len=150) LOCAL_PATH
-
- integer addressing(NCHUNKS,0:NPROC_XI-1,0:NPROC_ETA-1)
-
- integer ichunk_slice(0:NPROCTOT-1)
- integer iproc_xi_slice(0:NPROCTOT-1)
- integer iproc_eta_slice(0:NPROCTOT-1)
-
- integer NCHUNKS
-
- ! boundary parameters per slice
- integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
- integer ibelm_xmin(NSPEC2DMAX_XMIN_XMAX),ibelm_xmax(NSPEC2DMAX_XMIN_XMAX)
- integer ibelm_ymin(NSPEC2DMAX_YMIN_YMAX),ibelm_ymax(NSPEC2DMAX_YMIN_YMAX)
-
! local parameters
- integer NGLOB1D_RADIAL
- integer nglob
- character(len=150) OUTPUT_FILES,ERR_MSG
+ integer :: nglob
+ integer :: NGLOB1D_RADIAL
+ character(len=150) :: OUTPUT_FILES,ERR_MSG
! mask for ibool to mark points already found
logical, dimension(:), allocatable :: mask_ibool
! array to store points selected for the chunk face buffer
- integer NGLOB2DMAX_XY
+ integer :: NGLOB2DMAX_XY
integer, dimension(:), allocatable :: ibool_selected
double precision, dimension(:), allocatable :: xstore_selected,ystore_selected,zstore_selected
! arrays for sorting routine
@@ -97,63 +87,49 @@
logical, dimension(:), allocatable :: ifseg
double precision, dimension(:), allocatable :: work
! pairs generated theoretically
+
! four sides for each of the three types of messages
- integer, dimension(:), allocatable :: iproc_sender,iproc_receiver,npoin2D_send,npoin2D_receive
+ integer, dimension(:), allocatable :: npoin2D_send,npoin2D_receive
+ integer :: ibool1D(NGLOB1D_RADIAL_MAX)
+ double precision,dimension(NGLOB1D_RADIAL_MAX) :: xread1D,yread1D,zread1D
+ integer :: ipoin1D
- ! 1D buffers to remove points belonging to corners
- integer ibool1D_leftxi_lefteta(NGLOB1D_RADIAL_MAX)
- integer ibool1D_rightxi_lefteta(NGLOB1D_RADIAL_MAX)
- integer ibool1D_leftxi_righteta(NGLOB1D_RADIAL_MAX)
- integer ibool1D_rightxi_righteta(NGLOB1D_RADIAL_MAX)
- integer ibool1D(NGLOB1D_RADIAL_MAX)
- double precision xread1D(NGLOB1D_RADIAL_MAX)
- double precision yread1D(NGLOB1D_RADIAL_MAX)
- double precision zread1D(NGLOB1D_RADIAL_MAX)
- double precision xdummy,ydummy,zdummy
- integer ipoin1D
-
! arrays to assemble the corners (3 processors for each corner)
integer, dimension(:,:), allocatable :: iprocscorners,itypecorner
- integer ichunk_send,iproc_xi_send,iproc_eta_send
- integer ichunk_receive,iproc_xi_receive,iproc_eta_receive
- integer iproc_loop,iproc_xi_loop,iproc_eta_loop
- integer iproc_xi_loop_inv,iproc_eta_loop_inv
- integer imember_corner
+ integer :: ichunk_send,iproc_xi_send,iproc_eta_send
+ integer :: ichunk_receive,iproc_xi_receive,iproc_eta_receive
+ integer :: iproc_loop,iproc_xi_loop,iproc_eta_loop
+ integer :: iproc_xi_loop_inv,iproc_eta_loop_inv
+ integer :: imember_corner
+ integer :: iproc_edge_send,iproc_edge_receive
+ integer :: iside,imode_comm,iedge,itype
- integer iproc_edge_send,iproc_edge_receive
- integer imsg_type,iside,imode_comm,iedge
+ integer :: npoin2D,npoin2D_send_local,npoin2D_receive_local
- integer npoin2D,npoin2D_send_local,npoin2D_receive_local
+ integer :: i,j,k,ispec,ispec2D,ipoin2D
+ integer :: icount_faces,icount_corners
- integer i,j,k,ispec,ispec2D,ipoin2D
-
! current message number
- integer imsg
+ integer :: imsg
! names of the data files for all the processors in MPI
- character(len=150) prname,filename_in,filename_out
+ character(len=150) :: prname,filename_out
! for addressing of the slices
- integer ichunk,iproc_xi,iproc_eta,iproc
+ integer :: ichunk,iproc_xi,iproc_eta,iproc
! this to avoid problem at compile time if less than six chunks
- integer addressing_big(NCHUNKS_MAX,0:NPROC_XI-1,0:NPROC_ETA-1)
+ integer :: addressing_big(NCHUNKS_MAX,0:NPROC_XI-1,0:NPROC_ETA-1)
- ! number of faces between chunks
- integer NUM_FACES,NUMMSGS_FACES
+ integer :: NUM_FACES
+ integer :: NPROC_ONE_DIRECTION
+ integer :: ier
- ! number of corners between chunks
- integer NCORNERSCHUNKS
+ logical,parameter :: DEBUG = .false.
- ! number of message types
- integer NUM_MSG_TYPES
-
- integer NPROC_ONE_DIRECTION
-
-! ************** subroutine starts here **************
-
+ ! user output
if(myrank == 0) then
write(IMAIN,*)
write(IMAIN,*) '----- creating chunk buffers -----'
@@ -169,17 +145,9 @@
! initializes counters
NUM_FACES = 0
NUM_MSG_TYPES = 0
- iproc_xi_send = 0
- iproc_xi_receive = 0
- iproc_eta_send = 0
- iproc_eta_receive = 0
- iproc_edge_send = 0
- iproc_edge_receive = 0
- iedge = 0
- ichunk_receive = 0
- ichunk_send = 0
+ NCORNERSCHUNKS = 0
-! number of corners and faces shared between chunks and number of message types
+ ! number of corners and faces shared between chunks and number of message types
if(NCHUNKS == 1 .or. NCHUNKS == 2) then
NCORNERSCHUNKS = 1
NUM_FACES = 1
@@ -196,101 +164,148 @@
call exit_MPI(myrank,'number of chunks must be either 1, 2, 3 or 6')
endif
-! if more than one chunk then same number of processors in each direction
+ ! if more than one chunk then same number of processors in each direction
NPROC_ONE_DIRECTION = NPROC_XI
-! total number of messages corresponding to these common faces
+ ! total number of messages corresponding to these common faces
NUMMSGS_FACES = NPROC_ONE_DIRECTION*NUM_FACES*NUM_MSG_TYPES
-! check that there is more than one chunk, otherwise nothing to do
- if(NCHUNKS == 1) return
+ ! user output
+ if(myrank == 0) then
+ write(IMAIN,*) 'There is a total of ',NUMMSGS_FACES,' messages to assemble faces between chunks'
+ write(IMAIN,*)
+ endif
-! same number of GLL points in each direction for several chunks
- if(NGLLY /= NGLLX) call exit_MPI(myrank,'must have NGLLY = NGLLX for several chunks')
+ ! allocates arrays needed for assembly
+ allocate(iprocfrom_faces(NUMMSGS_FACES), &
+ iprocto_faces(NUMMSGS_FACES), &
+ imsg_type(NUMMSGS_FACES),stat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating iproc faces arrays')
-! allocate arrays for faces
- allocate(iproc_sender(NUMMSGS_FACES))
- allocate(iproc_receiver(NUMMSGS_FACES))
- allocate(npoin2D_send(NUMMSGS_FACES))
- allocate(npoin2D_receive(NUMMSGS_FACES))
+ ! communication pattern for corners between chunks
+ allocate(iproc_master_corners(NCORNERSCHUNKS), &
+ iproc_worker1_corners(NCORNERSCHUNKS), &
+ iproc_worker2_corners(NCORNERSCHUNKS),stat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating iproc corner arrays')
-! allocate array for corners
- allocate(iprocscorners(3,NCORNERSCHUNKS))
- allocate(itypecorner(3,NCORNERSCHUNKS))
+ ! clear arrays allocated
+ iprocfrom_faces(:) = -1
+ iprocto_faces(:) = -1
+ imsg_type(:) = 0
+
+ iproc_master_corners(:) = -1
+ iproc_worker1_corners(:) = -1
+ iproc_worker2_corners(:) = -1
-! clear arrays allocated
- iproc_sender(:) = 0
- iproc_receiver(:) = 0
- npoin2D_send(:) = 0
- npoin2D_receive(:) = 0
- iprocscorners(:,:) = 0
- itypecorner(:,:) = 0
+ ! checks that there is more than one chunk, otherwise nothing to do
+ if(NCHUNKS == 1) then
+ ! user output
+ if(myrank == 0) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'only one chunk, no need to create chunk buffers'
+ write(IMAIN,*)
+ endif
- if(myrank == 0) then
- write(IMAIN,*) 'There is a total of ',NUMMSGS_FACES,' messages to assemble faces between chunks'
- write(IMAIN,*)
+ ! exit routine
+ return
endif
-! define maximum size for message buffers
+ ! checks same number of GLL points in each direction for several chunks
+ if(NGLLY /= NGLLX) call exit_MPI(myrank,'must have NGLLY = NGLLX for several chunks')
+
+ ! continues with routine
+
+ ! allocates temporary arrays
+ allocate(npoin2D_send(NUMMSGS_FACES), &
+ npoin2D_receive(NUMMSGS_FACES), &
+ stat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating npoin2D arrays')
+
+ ! define maximum size for message buffers
+ !
+ ! note: this local parameter is slightly different to "global" NGLOB2DMAX_XY parameter
+ ! since we only need the maximum for this current region
NGLOB2DMAX_XY = max(NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX)
-! allocate arrays for message buffers with maximum size
- allocate(ibool_selected(NGLOB2DMAX_XY))
- allocate(xstore_selected(NGLOB2DMAX_XY))
- allocate(ystore_selected(NGLOB2DMAX_XY))
- allocate(zstore_selected(NGLOB2DMAX_XY))
- allocate(ind(NGLOB2DMAX_XY))
- allocate(ninseg(NGLOB2DMAX_XY))
- allocate(iglob(NGLOB2DMAX_XY))
- allocate(locval(NGLOB2DMAX_XY))
- allocate(ifseg(NGLOB2DMAX_XY))
- allocate(iwork(NGLOB2DMAX_XY))
- allocate(work(NGLOB2DMAX_XY))
+ ! allocate arrays for message buffers with maximum size
+ allocate(ibool_selected(NGLOB2DMAX_XY), &
+ xstore_selected(NGLOB2DMAX_XY), &
+ ystore_selected(NGLOB2DMAX_XY), &
+ zstore_selected(NGLOB2DMAX_XY), &
+ ind(NGLOB2DMAX_XY), &
+ ninseg(NGLOB2DMAX_XY), &
+ iglob(NGLOB2DMAX_XY), &
+ locval(NGLOB2DMAX_XY), &
+ ifseg(NGLOB2DMAX_XY), &
+ iwork(NGLOB2DMAX_XY), &
+ work(NGLOB2DMAX_XY), &
+ stat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating temporary arrays in create_chunk_buffers')
+ ! allocate mask for ibool
+ allocate(mask_ibool(nglob_ori), &
+ stat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error allocating temporary mask in create_chunk_buffers')
-! allocate mask for ibool
- allocate(mask_ibool(nglob_ori))
+ ! file output
+ if( DEBUG ) then
+ if(myrank == 0) then
+ ! get the base pathname for output files
+ call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+ ! file to store the list of processors for each message for faces
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_faces.txt',status='unknown')
+ endif
+ endif
- imsg = 0
+ ! faces
+ npoin2D_faces(:) = 0
+ iboolfaces(:,:) = 0
- if(myrank == 0) then
+ ! initializes counters
+ npoin2D_send(:) = 0
+ npoin2D_receive(:) = 0
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
+ iproc_xi_send = 0
+ iproc_xi_receive = 0
+ iproc_eta_send = 0
+ iproc_eta_receive = 0
+ iproc_edge_send = 0
+ iproc_edge_receive = 0
-! file to store the list of processors for each message for faces
- open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_faces.txt',status='unknown')
+ iedge = 0
+ ichunk_receive = 0
+ ichunk_send = 0
- endif
-
-! create theoretical communication pattern
- do imsg_type = 1,NUM_MSG_TYPES
+ ! create theoretical communication pattern
+ imsg = 0
+ icount_faces = 0
+ do itype = 1,NUM_MSG_TYPES
do iside = 1,NUM_FACES
do iproc_loop = 0,NPROC_ONE_DIRECTION-1
-! create a new message
-! we know there can be no deadlock with this scheme
-! because the three types of messages are independent
+ ! create a new message
+ ! we know there can be no deadlock with this scheme
+ ! because the three types of messages are independent
imsg = imsg + 1
-! check that current message number is correct
+ ! check that current message number is correct
if(imsg > NUMMSGS_FACES) call exit_MPI(myrank,'incorrect message number')
if(myrank == 0) write(IMAIN,*) 'Generating message ',imsg,' for faces out of ',NUMMSGS_FACES
-! we know there is the same number of slices in both directions
+ ! we know there is the same number of slices in both directions
iproc_xi_loop = iproc_loop
iproc_eta_loop = iproc_loop
-! take care of local frame inversions between chunks
+ ! take care of local frame inversions between chunks
iproc_xi_loop_inv = NPROC_ONE_DIRECTION - iproc_loop - 1
iproc_eta_loop_inv = NPROC_ONE_DIRECTION - iproc_loop - 1
-! define the 12 different messages
+ ! define the 12 different messages
-! message type M1
- if(imsg_type == 1) then
+ ! message type M1
+ if(itype == 1) then
if(iside == 1) then
ichunk_send = CHUNK_AB
@@ -338,8 +353,8 @@
endif
-! message type M2
- if(imsg_type == 2) then
+ ! message type M2
+ if(itype == 2) then
if(iside == 1) then
ichunk_send = CHUNK_AB
@@ -387,8 +402,8 @@
endif
-! message type M3
- if(imsg_type == 3) then
+ ! message type M3
+ if(itype == 3) then
if(iside == 1) then
ichunk_send = CHUNK_AC
@@ -436,92 +451,89 @@
endif
+ ! store addressing generated
+ iprocfrom_faces(imsg) = addressing(ichunk_send,iproc_xi_send,iproc_eta_send)
+ iprocto_faces(imsg) = addressing(ichunk_receive,iproc_xi_receive,iproc_eta_receive)
-! store addressing generated
- iproc_sender(imsg) = addressing(ichunk_send,iproc_xi_send,iproc_eta_send)
- iproc_receiver(imsg) = addressing(ichunk_receive,iproc_xi_receive,iproc_eta_receive)
+ ! check that sender/receiver pair is ordered
+ if(iprocfrom_faces(imsg) > iprocto_faces(imsg)) &
+ call exit_MPI(myrank,'incorrect order in sender/receiver pair')
-! check that sender/receiver pair is ordered
- if(iproc_sender(imsg) > iproc_receiver(imsg)) call exit_MPI(myrank,'incorrect order in sender/receiver pair')
+ ! save message type and pair of processors in list of messages
+ imsg_type(imsg) = itype
-! save message type and pair of processors in list of messages
- if(myrank == 0) write(IOUT,*) imsg_type,iproc_sender(imsg),iproc_receiver(imsg)
+ ! debug file output
+ if( DEBUG ) then
+ if(myrank == 0) &
+ write(IOUT,*) imsg_type(imsg),iprocfrom_faces(imsg),iprocto_faces(imsg)
+ endif
-! loop on sender/receiver (1=sender 2=receiver)
+ ! checks array values bounds
+ if(iprocfrom_faces(imsg) < 0 &
+ .or. iprocto_faces(imsg) < 0 &
+ .or. iprocfrom_faces(imsg) > NPROCTOT-1 &
+ .or. iprocto_faces(imsg) > NPROCTOT-1) &
+ call exit_MPI(myrank,'incorrect chunk faces numbering')
+ ! checks types
+ if (imsg_type(imsg) < 1 .or. imsg_type(imsg) > 3) &
+ call exit_MPI(myrank,'incorrect message type labeling')
+
+ ! loop on sender/receiver (1=sender 2=receiver)
do imode_comm=1,2
-
+ ! selects mode
if(imode_comm == 1) then
- iproc = iproc_sender(imsg)
+ iproc = iprocfrom_faces(imsg)
iedge = iproc_edge_send
+
write(filename_out,"('buffer_faces_chunks_sender_msg',i6.6,'.txt')") imsg
+
else if(imode_comm == 2) then
- iproc = iproc_receiver(imsg)
+ iproc = iprocto_faces(imsg)
iedge = iproc_edge_receive
+
write(filename_out,"('buffer_faces_chunks_receiver_msg',i6.6,'.txt')") imsg
+
else
call exit_MPI(myrank,'incorrect communication mode')
endif
-! only do this if current processor is the right one for MPI version
+ ! only do this if current processor is the right one for MPI version
if(iproc == myrank) then
-! create the name of the database for each slice
- call create_name_database(prname,iproc,iregion_code,LOCAL_PATH)
+ ! debug file output
+ if( DEBUG ) then
+ ! create the name of the database for each slice
+ call create_name_database(prname,iproc,iregion_code,LOCAL_PATH)
+ ! open file for 2D buffer
+ open(unit=IOUT_BUFFERS,file=prname(1:len_trim(prname))//filename_out,status='unknown')
+ endif
-! open file for 2D buffer
- open(unit=IOUT_BUFFERS,file=prname(1:len_trim(prname))//filename_out,status='unknown')
-
-! determine chunk number and local slice coordinates using addressing
+ ! determine chunk number and local slice coordinates using addressing
ichunk = ichunk_slice(iproc)
iproc_xi = iproc_xi_slice(iproc)
iproc_eta = iproc_eta_slice(iproc)
-! problem if not on edges
+ ! problem if not on edges
if(iproc_xi /= 0 .and. iproc_xi /= NPROC_XI-1 .and. &
- iproc_eta /= 0 .and. iproc_eta /= NPROC_ETA-1) call exit_MPI(myrank,'slice not on any edge')
+ iproc_eta /= 0 .and. iproc_eta /= NPROC_ETA-1) &
+ call exit_MPI(myrank,'slice not on any edge')
nglob=nglob_ori
-! check that iboolmax=nglob
+ ! check that iboolmax=nglob
if(minval(ibool(:,:,:,1:nspec)) /= 1 .or. maxval(ibool(:,:,:,1:nspec)) /= nglob) &
call exit_MPI(myrank,ERR_MSG)
-! read 1D buffers to remove corner points
- open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt',status='old',action='read')
- do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,1)
- read(IIN,*) ibool1D_leftxi_lefteta(ipoin1D),xdummy,ydummy,zdummy
- enddo
- close(IIN)
-
- open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt',status='old',action='read')
- do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,2)
- read(IIN,*) ibool1D_rightxi_lefteta(ipoin1D),xdummy,ydummy,zdummy
- enddo
- close(IIN)
-
- open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt',status='old',action='read')
- do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,4)
- read(IIN,*) ibool1D_leftxi_righteta(ipoin1D),xdummy,ydummy,zdummy
- enddo
- close(IIN)
-
- open(unit=IIN,file=prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt',status='old',action='read')
- do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,3)
- read(IIN,*) ibool1D_rightxi_righteta(ipoin1D),xdummy,ydummy,zdummy
- enddo
- close(IIN)
-
-! erase logical mask
+ ! erase logical mask
mask_ibool(:) = .false.
npoin2D = 0
-! create all the points on each face (no duplicates, but not sorted)
+ ! create all the points on each face (no duplicates, but not sorted)
-! xmin
+ ! xmin
if(iedge == XI_MIN) then
-
-! mark corner points to remove them if needed
+ ! mark corner points to remove them if needed
if(iproc_eta == 0) then
do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,1)
mask_ibool(ibool1D_leftxi_lefteta(ipoin1D)) = .true.
@@ -537,7 +549,7 @@
do ispec2D=1,nspec2D_xmin
ispec=ibelm_xmin(ispec2D)
-! remove central cube for chunk buffers
+ ! remove central cube for chunk buffers
if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
@@ -547,10 +559,12 @@
do k=1,NGLLZ
do j=1,NGLLY
if(.not. mask_ibool(ibool(i,j,k,ispec))) then
-! mask and store points found
+ ! mask and store points found
mask_ibool(ibool(i,j,k,ispec)) = .true.
npoin2D = npoin2D + 1
- if(npoin2D > NGLOB2DMAX_XMIN_XMAX) call exit_MPI(myrank,'incorrect 2D point number in xmin')
+ if(npoin2D > NGLOB2DMAX_XMIN_XMAX) &
+ call exit_MPI(myrank,'incorrect 2D point number in xmin')
+
ibool_selected(npoin2D) = ibool(i,j,k,ispec)
xstore_selected(npoin2D) = xstore(i,j,k,ispec)
@@ -561,11 +575,9 @@
enddo
enddo
-! xmax
+ ! xmax
else if(iedge == XI_MAX) then
-
-! mark corner points to remove them if needed
-
+ ! mark corner points to remove them if needed
if(iproc_eta == 0) then
do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,2)
mask_ibool(ibool1D_rightxi_lefteta(ipoin1D)) = .true.
@@ -581,7 +593,7 @@
do ispec2D=1,nspec2D_xmax
ispec=ibelm_xmax(ispec2D)
-! remove central cube for chunk buffers
+ ! remove central cube for chunk buffers
if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
@@ -591,10 +603,12 @@
do k=1,NGLLZ
do j=1,NGLLY
if(.not. mask_ibool(ibool(i,j,k,ispec))) then
-! mask and store points found
+ ! mask and store points found
mask_ibool(ibool(i,j,k,ispec)) = .true.
npoin2D = npoin2D + 1
- if(npoin2D > NGLOB2DMAX_XMIN_XMAX) call exit_MPI(myrank,'incorrect 2D point number in xmax')
+ if(npoin2D > NGLOB2DMAX_XMIN_XMAX) &
+ call exit_MPI(myrank,'incorrect 2D point number in xmax')
+
ibool_selected(npoin2D) = ibool(i,j,k,ispec)
xstore_selected(npoin2D) = xstore(i,j,k,ispec)
@@ -605,11 +619,9 @@
enddo
enddo
-! ymin
+ ! ymin
else if(iedge == ETA_MIN) then
-
-! mark corner points to remove them if needed
-
+ ! mark corner points to remove them if needed
if(iproc_xi == 0) then
do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,1)
mask_ibool(ibool1D_leftxi_lefteta(ipoin1D)) = .true.
@@ -625,7 +637,7 @@
do ispec2D=1,nspec2D_ymin
ispec=ibelm_ymin(ispec2D)
-! remove central cube for chunk buffers
+ ! remove central cube for chunk buffers
if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
@@ -635,10 +647,12 @@
do k=1,NGLLZ
do i=1,NGLLX
if(.not. mask_ibool(ibool(i,j,k,ispec))) then
-! mask and store points found
+ ! mask and store points found
mask_ibool(ibool(i,j,k,ispec)) = .true.
npoin2D = npoin2D + 1
- if(npoin2D > NGLOB2DMAX_YMIN_YMAX) call exit_MPI(myrank,'incorrect 2D point number in ymin')
+ if(npoin2D > NGLOB2DMAX_YMIN_YMAX) &
+ call exit_MPI(myrank,'incorrect 2D point number in ymin')
+
ibool_selected(npoin2D) = ibool(i,j,k,ispec)
xstore_selected(npoin2D) = xstore(i,j,k,ispec)
@@ -649,11 +663,9 @@
enddo
enddo
-! ymax
+ ! ymax
else if(iedge == ETA_MAX) then
-
-! mark corner points to remove them if needed
-
+ ! mark corner points to remove them if needed
if(iproc_xi == 0) then
do ipoin1D = 1,NGLOB1D_RADIAL_CORNER(iregion_code,4)
mask_ibool(ibool1D_leftxi_righteta(ipoin1D)) = .true.
@@ -669,7 +681,7 @@
do ispec2D=1,nspec2D_ymax
ispec=ibelm_ymax(ispec2D)
-! remove central cube for chunk buffers
+ ! remove central cube for chunk buffers
if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
@@ -679,10 +691,12 @@
do k=1,NGLLZ
do i=1,NGLLX
if(.not. mask_ibool(ibool(i,j,k,ispec))) then
-! mask and store points found
+ ! mask and store points found
mask_ibool(ibool(i,j,k,ispec)) = .true.
npoin2D = npoin2D + 1
- if(npoin2D > NGLOB2DMAX_YMIN_YMAX) call exit_MPI(myrank,'incorrect 2D point number in ymax')
+ if(npoin2D > NGLOB2DMAX_YMIN_YMAX) &
+ call exit_MPI(myrank,'incorrect 2D point number in ymax')
+
ibool_selected(npoin2D) = ibool(i,j,k,ispec)
xstore_selected(npoin2D) = xstore(i,j,k,ispec)
@@ -698,96 +712,133 @@
call exit_MPI(myrank,'incorrect edge code')
endif
-! 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
+ ! 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(npoin2D,xstore_selected,ystore_selected,zstore_selected, &
ibool_selected,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
-! check that no duplicate has been detected
+ ! check that no duplicate has been detected
if(nglob /= npoin2D) call exit_MPI(myrank,'duplicates detected in buffer')
-! write list of selected points to output buffer
- write(IOUT_BUFFERS,*) npoin2D
+ ! write list of selected points to output buffer
+
+ ! adds face
+ icount_faces = icount_faces + 1
+ npoin2D_faces(icount_faces) = npoin2D
+
+ ! checks bounds
+ if(npoin2D_faces(icount_faces) > NGLOB2DMAX_XY) then
+ print*,'error ',myrank,' npoin2D_faces: ',npoin2D_faces(icount_faces),icount_faces
+ print*,'iregion_code:',iregion_code
+ call exit_MPI(myrank,'incorrect nb of points in face buffer')
+ endif
+
+ ! debug file output
+ if( DEBUG ) then
+ write(IOUT_BUFFERS,*) npoin2D
+ endif
+
+ ! stores face infos
do ipoin2D = 1,npoin2D
+ ! fills iboolfaces array
+ iboolfaces(ipoin2D,icount_faces) = ibool_selected(ipoin2D)
+
+ ! debug file output
+ if( DEBUG ) then
write(IOUT_BUFFERS,*) ibool_selected(ipoin2D), &
- xstore_selected(ipoin2D),ystore_selected(ipoin2D),zstore_selected(ipoin2D)
+ xstore_selected(ipoin2D),ystore_selected(ipoin2D),zstore_selected(ipoin2D)
+ endif
enddo
- close(IOUT_BUFFERS)
+ ! debug file output
+ if( DEBUG ) then
+ close(IOUT_BUFFERS)
+ endif
-! store result to compare number of points for sender and for receiver
+ ! store result to compare number of points for sender and for receiver
if(imode_comm == 1) then
npoin2D_send(imsg) = npoin2D
else
npoin2D_receive(imsg) = npoin2D
endif
-! end of section done only if right processor for MPI
+ ! end of section done only if right processor for MPI
endif
-! end of loop on sender/receiver
+ ! end of loop on sender/receiver
enddo
-! end of loops on all the messages
+ ! end of loops on all the messages
enddo
enddo
enddo
- if(myrank == 0) close(IOUT)
+ ! debug file output
+ if( DEBUG ) then
+ if(myrank == 0) close(IOUT)
+ endif
-! check that total number of messages is correct
+ ! check that total number of messages is correct
if(imsg /= NUMMSGS_FACES) call exit_MPI(myrank,'incorrect total number of messages')
!
!---- check that number of points detected is the same for sender and receiver
!
-! synchronize all the processes to make sure all the buffers are ready
+ ! synchronize all the processes to make sure all the buffers are ready
call sync_all()
-! gather information about all the messages on all processes
+ ! gather information about all the messages on all processes
do imsg = 1,NUMMSGS_FACES
-
-! gather number of points for sender
+ ! gather number of points for sender
npoin2D_send_local = npoin2D_send(imsg)
+ call bcast_iproc_i(npoin2D_send_local,iprocfrom_faces(imsg))
+ if(myrank /= iprocfrom_faces(imsg)) npoin2D_send(imsg) = npoin2D_send_local
- call bcast_iproc_i(npoin2D_send_local,iproc_sender(imsg))
-
- if(myrank /= iproc_sender(imsg)) npoin2D_send(imsg) = npoin2D_send_local
-
-! gather number of points for receiver
+ ! gather number of points for receiver
npoin2D_receive_local = npoin2D_receive(imsg)
-
- call bcast_iproc_i(npoin2D_receive_local,iproc_receiver(imsg))
-
- if(myrank /= iproc_receiver(imsg)) npoin2D_receive(imsg) = npoin2D_receive_local
-
+ call bcast_iproc_i(npoin2D_receive_local,iprocto_faces(imsg))
+ if(myrank /= iprocto_faces(imsg)) npoin2D_receive(imsg) = npoin2D_receive_local
enddo
-! check the number of points
+ ! check the number of points
do imsg = 1,NUMMSGS_FACES
if(npoin2D_send(imsg) /= npoin2D_receive(imsg)) &
call exit_MPI(myrank,'incorrect number of points for sender/receiver pair detected')
enddo
+
+ ! user output
if(myrank == 0) then
write(IMAIN,*)
write(IMAIN,*) 'all the messages for chunk faces have the right size'
write(IMAIN,*)
endif
+ call sync_all()
!
!---- generate the 8 message patterns sharing a corner of valence 3
!
-! to avoid problem at compile time, use bigger array with fixed dimension
+ ! allocate temporary array for corners
+ allocate(iprocscorners(3,NCORNERSCHUNKS), &
+ itypecorner(3,NCORNERSCHUNKS), &
+ stat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error allocating iproccorner arrays')
+
+ ! initializes corner arrays
+ iboolcorner(:,:) = 0
+ iprocscorners(:,:) = -1
+ itypecorner(:,:) = 0
+
+ ! to avoid problem at compile time, use bigger array with fixed dimension
addressing_big(:,:,:) = 0
addressing_big(1:NCHUNKS,:,:) = addressing(1:NCHUNKS,:,:)
ichunk = 1
iprocscorners(1,ichunk) = addressing_big(CHUNK_AB,0,NPROC_ETA-1)
iprocscorners(2,ichunk) = addressing_big(CHUNK_AC,NPROC_XI-1,NPROC_ETA-1)
-! this line is ok even for NCHUNKS = 2
+ ! this line is ok even for NCHUNKS = 2
iprocscorners(3,ichunk) = addressing_big(CHUNK_BC,NPROC_XI-1,0)
itypecorner(1,ichunk) = ILOWERUPPER
@@ -799,7 +850,7 @@
!! DK DK UGLY formally this is incorrect and should be changed in the future
!! DK DK UGLY in practice this trick works fine
-! this only if more than 3 chunks
+ ! this only if more than 3 chunks
if(NCHUNKS > 3) then
ichunk = 2
@@ -867,87 +918,153 @@
endif
-! file to store the list of processors for each message for corners
- if(myrank == 0) open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_corners.txt',status='unknown')
+ ! debug file output
+ if( DEBUG ) then
+ ! file to store the list of processors for each message for corners
+ if(myrank == 0) &
+ open(unit=IOUT,file=trim(OUTPUT_FILES)//'/list_messages_corners.txt',status='unknown')
+ endif
-! loop over all the messages to create the addressing
+ ! loop over all the messages to create the addressing
+ icount_corners = 0
do imsg = 1,NCORNERSCHUNKS
if(myrank == 0) write(IMAIN,*) 'Generating message ',imsg,' for corners out of ',NCORNERSCHUNKS
-! save triplet of processors in list of messages
- if(myrank == 0) write(IOUT,*) iprocscorners(1,imsg),iprocscorners(2,imsg),iprocscorners(3,imsg)
+ ! save triplet of processors in list of messages
+ iproc_master_corners(imsg) = iprocscorners(1,imsg)
+ iproc_worker1_corners(imsg) = iprocscorners(2,imsg)
+ iproc_worker2_corners(imsg) = iprocscorners(3,imsg)
-! loop on the three processors of a given corner
+ ! debug file output
+ if( DEBUG ) then
+ if(myrank == 0) &
+ write(IOUT,*) iprocscorners(1,imsg),iprocscorners(2,imsg),iprocscorners(3,imsg)
+ endif
+
+ ! checks bounds
+ if(iproc_master_corners(imsg) < 0 &
+ .or. iproc_worker1_corners(imsg) < 0 &
+ .or. iproc_worker2_corners(imsg) < 0 &
+ .or. iproc_master_corners(imsg) > NPROCTOT-1 &
+ .or. iproc_worker1_corners(imsg) > NPROCTOT-1 &
+ .or. iproc_worker2_corners(imsg) > NPROCTOT-1) &
+ call exit_MPI(myrank,'incorrect chunk corner numbering')
+
+
+ ! loop on the three processors of a given corner
do imember_corner = 1,3
- if(imember_corner == 1) then
- write(filename_out,"('buffer_corners_chunks_master_msg',i6.6,'.txt')") imsg
- else if(imember_corner == 2) then
- write(filename_out,"('buffer_corners_chunks_worker1_msg',i6.6,'.txt')") imsg
- else
- write(filename_out,"('buffer_corners_chunks_worker2_msg',i6.6,'.txt')") imsg
+ ! debug file output
+ if( DEBUG ) then
+ if(imember_corner == 1) then
+ write(filename_out,"('buffer_corners_chunks_master_msg',i6.6,'.txt')") imsg
+ else if(imember_corner == 2) then
+ write(filename_out,"('buffer_corners_chunks_worker1_msg',i6.6,'.txt')") imsg
+ else
+ write(filename_out,"('buffer_corners_chunks_worker2_msg',i6.6,'.txt')") imsg
+ endif
endif
-! only do this if current processor is the right one for MPI version
-! this line is ok even for NCHUNKS = 2
+ ! only do this if current processor is the right one for MPI version
+ ! this line is ok even for NCHUNKS = 2
if(iprocscorners(imember_corner,imsg) == myrank) then
-! pick the correct 1D buffer
-! this scheme works fine even if NPROC_XI = NPROC_ETA = 1
- if(itypecorner(imember_corner,imsg) == ILOWERLOWER) then
- filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt'
- NGLOB1D_RADIAL = NGLOB1D_RADIAL_CORNER(iregion_code,1)
- else if(itypecorner(imember_corner,imsg) == ILOWERUPPER) then
- filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt'
- NGLOB1D_RADIAL = NGLOB1D_RADIAL_CORNER(iregion_code,4)
- else if(itypecorner(imember_corner,imsg) == IUPPERLOWER) then
- filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt'
- NGLOB1D_RADIAL = NGLOB1D_RADIAL_CORNER(iregion_code,2)
- else if(itypecorner(imember_corner,imsg) == IUPPERUPPER) then
- filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt'
- NGLOB1D_RADIAL = NGLOB1D_RADIAL_CORNER(iregion_code,3)
- else
- call exit_MPI(myrank,'incorrect corner coordinates')
- endif
+ ! pick the correct 1D buffer
+ ! this scheme works fine even if NPROC_XI = NPROC_ETA = 1
+ if(itypecorner(imember_corner,imsg) == ILOWERLOWER) then
+ !filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt'
+ NGLOB1D_RADIAL = NGLOB1D_RADIAL_CORNER(iregion_code,1)
+ ibool1D(:) = ibool1D_leftxi_lefteta(:)
+ xread1D(:) = xyz1D_leftxi_lefteta(:,1)
+ yread1D(:) = xyz1D_leftxi_lefteta(:,2)
+ zread1D(:) = xyz1D_leftxi_lefteta(:,3)
-! read 1D buffer for corner
- open(unit=IIN,file=filename_in,status='old',action='read')
- do ipoin1D = 1,NGLOB1D_RADIAL
- read(IIN,*) ibool1D(ipoin1D), &
- xread1D(ipoin1D),yread1D(ipoin1D),zread1D(ipoin1D)
- enddo
- close(IIN)
+ else if(itypecorner(imember_corner,imsg) == ILOWERUPPER) then
+ !filename_in = prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt'
+ NGLOB1D_RADIAL = NGLOB1D_RADIAL_CORNER(iregion_code,4)
+ ibool1D(1:NGLOB1D_RADIAL) = ibool1D_leftxi_righteta(1:NGLOB1D_RADIAL)
+ xread1D(1:NGLOB1D_RADIAL) = xyz1D_leftxi_righteta(1:NGLOB1D_RADIAL,1)
+ yread1D(1:NGLOB1D_RADIAL) = xyz1D_leftxi_righteta(1:NGLOB1D_RADIAL,2)
+ zread1D(1:NGLOB1D_RADIAL) = xyz1D_leftxi_righteta(1:NGLOB1D_RADIAL,3)
-! sort array read based upon the coordinates of the points
-! to ensure conforming matching with other buffers from neighbors
- call sort_array_coordinates(NGLOB1D_RADIAL,xread1D,yread1D,zread1D, &
- ibool1D,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
+ else if(itypecorner(imember_corner,imsg) == IUPPERLOWER) then
+ !filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt'
+ NGLOB1D_RADIAL = NGLOB1D_RADIAL_CORNER(iregion_code,2)
+ ibool1D(1:NGLOB1D_RADIAL) = ibool1D_rightxi_lefteta(1:NGLOB1D_RADIAL)
+ xread1D(1:NGLOB1D_RADIAL) = xyz1D_rightxi_lefteta(1:NGLOB1D_RADIAL,1)
+ yread1D(1:NGLOB1D_RADIAL) = xyz1D_rightxi_lefteta(1:NGLOB1D_RADIAL,2)
+ zread1D(1:NGLOB1D_RADIAL) = xyz1D_rightxi_lefteta(1:NGLOB1D_RADIAL,3)
-! check that no duplicates have been found
- if(nglob /= NGLOB1D_RADIAL) call exit_MPI(myrank,'duplicates found for corners')
+ else if(itypecorner(imember_corner,imsg) == IUPPERUPPER) then
+ !filename_in = prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt'
+ NGLOB1D_RADIAL = NGLOB1D_RADIAL_CORNER(iregion_code,3)
+ ibool1D(1:NGLOB1D_RADIAL) = ibool1D_rightxi_righteta(1:NGLOB1D_RADIAL)
+ xread1D(1:NGLOB1D_RADIAL) = xyz1D_rightxi_righteta(1:NGLOB1D_RADIAL,1)
+ yread1D(1:NGLOB1D_RADIAL) = xyz1D_rightxi_righteta(1:NGLOB1D_RADIAL,2)
+ zread1D(1:NGLOB1D_RADIAL) = xyz1D_rightxi_righteta(1:NGLOB1D_RADIAL,3)
-! write file with 1D buffer for corner
- open(unit=IOUT_BUFFERS,file=prname(1:len_trim(prname))//filename_out,status='unknown')
- write(IOUT_BUFFERS,*) NGLOB1D_RADIAL
- do ipoin1D = 1,NGLOB1D_RADIAL
- write(IOUT_BUFFERS,*) ibool1D(ipoin1D), &
- xread1D(ipoin1D),yread1D(ipoin1D),zread1D(ipoin1D)
- enddo
- close(IOUT_BUFFERS)
+ else
+ call exit_MPI(myrank,'incorrect corner coordinates')
+ endif
-! end of section done only if right processor for MPI
- endif
+ ! sort array read based upon the coordinates of the points
+ ! to ensure conforming matching with other buffers from neighbors
+ call sort_array_coordinates(NGLOB1D_RADIAL,xread1D,yread1D,zread1D, &
+ ibool1D,iglob,locval,ifseg,nglob,ind,ninseg,iwork,work)
- enddo
+ ! check that no duplicates have been found
+ if(nglob /= NGLOB1D_RADIAL) then
+ print*,'error ',myrank,' npoin1D_corner: ',nglob,'NGLOB1D_RADIAL:',NGLOB1D_RADIAL
+ print*,'iregion_code:',iregion_code
+ call exit_MPI(myrank,'duplicates found for corners')
+ endif
+ ! adds corner info
+ icount_corners = icount_corners + 1
+
+ ! checks counter
+ if(icount_corners > 1 .and. (NPROC_XI > 1 .or. NPROC_ETA > 1)) then
+ print*,'error ',myrank,'icount_corners:',icount_corners
+ print*,'iregion_code:',iregion_code
+ call exit_MPI(myrank,'more than one corner for this slice')
+ endif
+ if(icount_corners > 4) call exit_MPI(myrank,'more than four corners for this slice')
+
+ ! debug file output
+ if( DEBUG ) then
+ ! write file with 1D buffer for corner
+ open(unit=IOUT_BUFFERS,file=prname(1:len_trim(prname))//filename_out,status='unknown')
+ write(IOUT_BUFFERS,*) NGLOB1D_RADIAL
+ endif
+
+ ! fills iboolcorner array
+ do ipoin1D = 1,NGLOB1D_RADIAL
+ iboolcorner(ipoin1D,icount_corners) = ibool1D(ipoin1D)
+
+ ! debug file output
+ if( DEBUG ) then
+ write(IOUT_BUFFERS,*) ibool1D(ipoin1D), &
+ xread1D(ipoin1D),yread1D(ipoin1D),zread1D(ipoin1D)
+ endif
+ enddo
+
+ ! debug file output
+ if( DEBUG ) then
+ close(IOUT_BUFFERS)
+ endif
+
+ ! end of section done only if right processor for MPI
+ endif
+ enddo
enddo
- if(myrank == 0) close(IOUT)
+ ! debug file output
+ if( DEBUG ) then
+ if(myrank == 0) close(IOUT)
+ endif
-! deallocate arrays
- deallocate(iproc_sender)
- deallocate(iproc_receiver)
+ ! deallocate arrays
deallocate(npoin2D_send)
deallocate(npoin2D_receive)
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_mass_matrices.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_mass_matrices.f90 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_mass_matrices.f90 2012-08-11 02:22:07 UTC (rev 20565)
@@ -27,8 +27,7 @@
subroutine create_mass_matrices(myrank,nspec,idoubling,ibool, &
iregion_code,xstore,ystore,zstore, &
- NSPEC2D_TOP,NSPEC2D_BOTTOM, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX)
+ NSPEC2D_TOP,NSPEC2D_BOTTOM)
! creates rmassx, rmassy, rmassz and rmass_ocean_load
@@ -38,7 +37,7 @@
OCEANS,TOPOGRAPHY,ibathy_topo
use meshfem3D_par,only: &
- DT,NCHUNKS,ABSORBING_CONDITIONS,ichunk,RHO_OCEANS
+ NCHUNKS,ABSORBING_CONDITIONS,RHO_OCEANS
use create_regions_mesh_par,only: &
wxgll,wygll,wzgll
@@ -47,13 +46,7 @@
xixstore,xiystore,xizstore,etaxstore,etaystore,etazstore, &
gammaxstore,gammaystore,gammazstore,rhostore,kappavstore, &
rmassx,rmassy,rmassz,rmass_ocean_load, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom,ibelm_top, &
- normal_xmin,normal_xmax,normal_ymin,normal_ymax, &
- jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax, &
- jacobian2D_bottom,jacobian2D_top, &
- rho_vp,rho_vs, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
- prname
+ ibelm_top,jacobian2D_top
implicit none
@@ -70,93 +63,24 @@
! Stacey conditions put back
integer :: NSPEC2D_TOP,NSPEC2D_BOTTOM
- integer :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
! local parameters
- double precision :: xval,yval,zval,rval,thetaval,phival,weight
+ double precision :: xval,yval,zval,rval,theta,phi,weight
double precision :: lat,lon
double precision :: elevation,height_oceans
real(kind=CUSTOM_REAL) :: xixl,xiyl,xizl,etaxl,etayl,etazl,gammaxl,gammayl,gammazl,jacobianl
- ! time scheme
- real(kind=CUSTOM_REAL) :: deltat,deltatover2
- ! absorbing boundaries
- integer, dimension(2,NSPEC2DMAX_YMIN_YMAX) :: nimin,nimax,nkmin_eta
- integer, dimension(2,NSPEC2DMAX_XMIN_XMAX) :: njmin,njmax,nkmin_xi
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLY) :: wgllwgll_xy
- real(kind=CUSTOM_REAL), dimension(NGLLX,NGLLZ) :: wgllwgll_xz
- real(kind=CUSTOM_REAL), dimension(NGLLY,NGLLZ) :: wgllwgll_yz
- real(kind=CUSTOM_REAL) :: tx,ty,tz,sn
- real(kind=CUSTOM_REAL) :: nx,ny,nz,vn
- integer :: ispec,i,j,k,iglob,ier
+ integer :: ispec,i,j,k,iglob
integer :: ix_oceans,iy_oceans,iz_oceans,ispec_oceans,ispec2D_top_crust
- integer :: ispec2D
! initializes matrices
!
- ! in the case of stacey boundary conditions, add C*deltat/2 contribution to the mass matrix
- ! on Stacey edges for the crust_mantle and outer_core regions but not for the inner_core region
- ! thus the mass matrix must be replaced by three mass matrices including the "C" damping matrix
- !
! if absorbing_conditions are not set or if NCHUNKS=6, only one mass matrix is needed
! for the sake of performance, only "rmassz" array will be filled and "rmassx" & "rmassy" will be obsolete
-
rmassx(:) = 0._CUSTOM_REAL
rmassy(:) = 0._CUSTOM_REAL
rmassz(:) = 0._CUSTOM_REAL
- ! use the non-dimensional time step to make the mass matrix correction
- if(CUSTOM_REAL == SIZE_REAL) then
- deltat = sngl(DT*dsqrt(PI*GRAV*RHOAV))
- else
- deltat = DT*dsqrt(PI*GRAV*RHOAV)
- endif
-
- ! distinguish between single and double precision for reals
- if(CUSTOM_REAL == SIZE_REAL) then
- do i=1,NGLLX
- do j=1,NGLLY
- wgllwgll_xy(i,j) = sngl(wxgll(i)*wygll(j))
- enddo
- enddo
-
- do i=1,NGLLX
- do k=1,NGLLZ
- wgllwgll_xz(i,k) = sngl(wxgll(i)*wzgll(k))
- enddo
- enddo
-
- do j=1,NGLLY
- do k=1,NGLLZ
- wgllwgll_yz(j,k) = sngl(wygll(j)*wzgll(k))
- enddo
- enddo
-
- deltatover2 = sngl(0.5d0*deltat)
-
- else ! double precision version
- do i=1,NGLLX
- do j=1,NGLLY
- wgllwgll_xy(i,j) = wxgll(i)*wygll(j)
- enddo
- enddo
-
- do i=1,NGLLX
- do k=1,NGLLZ
- wgllwgll_xz(i,k) = wxgll(i)*wzgll(k)
- enddo
- enddo
-
- do j=1,NGLLY
- do k=1,NGLLZ
- wgllwgll_yz(j,k) = wygll(j)*wzgll(k)
- enddo
- enddo
-
- deltatover2 = 0.5d0*deltat
-
- endif
-
do ispec=1,nspec
! suppress fictitious elements in central cube
@@ -248,18 +172,21 @@
zval = zstore(ix_oceans,iy_oceans,iz_oceans,ispec_oceans)
! map to latitude and longitude for bathymetry routine
- call xyz_2_rthetaphi_dble(xval,yval,zval,rval,thetaval,phival)
- call reduce(thetaval,phival)
+ ! slightly move points to avoid roundoff problem when exactly on the polar axis
+ call xyz_2_rthetaphi_dble(xval,yval,zval,rval,theta,phi)
+ theta = theta + 0.0000001d0
+ phi = phi + 0.0000001d0
+ call reduce(theta,phi)
! convert the geocentric colatitude to a geographic colatitude
if( .not. ASSUME_PERFECT_SPHERE) then
- thetaval = PI_OVER_TWO - &
- datan(1.006760466d0*dcos(thetaval)/dmax1(TINYVAL,dsin(thetaval)))
+ theta = PI_OVER_TWO - &
+ datan(1.006760466d0*dcos(theta)/dmax1(TINYVAL,dsin(theta)))
endif
! get geographic latitude and longitude in degrees
- lat = (PI_OVER_TWO-thetaval)*RADIANS_TO_DEGREES
- lon = phival * RADIANS_TO_DEGREES
+ lat = (PI_OVER_TWO-theta)*RADIANS_TO_DEGREES
+ lon = phi * RADIANS_TO_DEGREES
! compute elevation at current point
call get_topo_bathy(lat,lon,elevation,ibathy_topo)
@@ -299,344 +226,432 @@
endif
- ! add C*deltat/2 contribution to the mass matrices on Stacey edges
+ ! adds C*deltat/2 contribution to the mass matrices on Stacey edges
if(NCHUNKS /= 6 .and. ABSORBING_CONDITIONS) then
+ call create_mass_matrices_Stacey(myrank,nspec,ibool,iregion_code, &
+ NSPEC2D_BOTTOM)
+ endif
- ! read arrays for Stacey conditions
- open(unit=27,file=prname(1:len_trim(prname))//'stacey.bin', &
- status='old',form='unformatted',action='read',iostat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error opening stacey.bin in create_mass_matrices')
- read(27) nimin
- read(27) nimax
- read(27) njmin
- read(27) njmax
- read(27) nkmin_xi
- read(27) nkmin_eta
- close(27)
+ ! check that mass matrix is positive
+ ! note: in fictitious elements it is still zero
+ if(minval(rmassz(:)) < 0._CUSTOM_REAL) call exit_MPI(myrank,'negative rmassz matrix term')
- select case(iregion_code)
- case(IREGION_CRUST_MANTLE)
+ end subroutine create_mass_matrices
- rmassx(:) = rmassz(:)
- rmassy(:) = rmassz(:)
+!
+!-------------------------------------------------------------------------------------------------
+!
- ! xmin
- ! if two chunks exclude this face for one of them
- if(NCHUNKS == 1 .or. ichunk == CHUNK_AC) then
+ subroutine create_mass_matrices_Stacey(myrank,nspec,ibool,iregion_code, &
+ NSPEC2D_BOTTOM)
- do ispec2D=1,nspec2D_xmin
+! in the case of stacey boundary conditions, add C*deltat/2 contribution to the mass matrix
+! on Stacey edges for the crust_mantle and outer_core regions but not for the inner_core region
+! thus the mass matrix must be replaced by three mass matrices including the "C" damping matrix
- ispec=ibelm_xmin(ispec2D)
+ use constants
- ! exclude elements that are not on absorbing edges
- if(nkmin_xi(1,ispec2D) == 0 .or. njmin(1,ispec2D) == 0) cycle
+ use meshfem3D_par,only: &
+ DT,NCHUNKS,ichunk
- i=1
- do k=nkmin_xi(1,ispec2D),NGLLZ
- do j=njmin(1,ispec2D),njmax(1,ispec2D)
- iglob=ibool(i,j,k,ispec)
+ use create_regions_mesh_par,only: &
+ wxgll,wygll,wzgll
- nx = normal_xmin(1,j,k,ispec2D)
- ny = normal_xmin(2,j,k,ispec2D)
- nz = normal_xmin(3,j,k,ispec2D)
+ use create_regions_mesh_par2,only: &
+ rmassx,rmassy,rmassz, &
+ ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax,ibelm_bottom, &
+ normal_xmin,normal_xmax,normal_ymin,normal_ymax, &
+ jacobian2D_xmin,jacobian2D_xmax,jacobian2D_ymin,jacobian2D_ymax, &
+ jacobian2D_bottom, &
+ rho_vp,rho_vs, &
+ nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
+ nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta
- vn = deltatover2*(nx+ny+nz)
+ implicit none
- tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(deltatover2-vn*nx)
- ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(deltatover2-vn*ny)
- tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(deltatover2-vn*nz)
+ integer :: myrank
- weight = jacobian2D_xmin(j,k,ispec2D)*wgllwgll_yz(j,k)
+ integer :: nspec
+ integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassx(iglob) = rmassx(iglob) + sngl(tx*weight)
- rmassy(iglob) = rmassy(iglob) + sngl(ty*weight)
- rmassz(iglob) = rmassz(iglob) + sngl(tz*weight)
- else
- rmassx(iglob) = rmassx(iglob) + tx*weight
- rmassy(iglob) = rmassy(iglob) + ty*weight
- rmassz(iglob) = rmassz(iglob) + tz*weight
- endif
- enddo
- enddo
- enddo
+ integer :: iregion_code
- endif ! NCHUNKS == 1 .or. ichunk == CHUNK_AC
+ ! Stacey conditions
+ integer :: NSPEC2D_BOTTOM
- ! xmax
- ! if two chunks exclude this face for one of them
- if(NCHUNKS == 1 .or. ichunk == CHUNK_AB) then
+ ! local parameters
+ double precision :: weight
+ double precision, dimension(NGLLX,NGLLY) :: wgllwgll_xy
+ double precision, dimension(NGLLX,NGLLZ) :: wgllwgll_xz
+ double precision, dimension(NGLLY,NGLLZ) :: wgllwgll_yz
- do ispec2D=1,nspec2D_xmax
+ real(kind=CUSTOM_REAL) :: deltat,deltatover2
+ real(kind=CUSTOM_REAL) :: tx,ty,tz,sn
+ real(kind=CUSTOM_REAL) :: nx,ny,nz,vn
- ispec=ibelm_xmax(ispec2D)
+ integer :: ispec,i,j,k,iglob
+ integer :: ispec2D
- ! exclude elements that are not on absorbing edges
- if(nkmin_xi(2,ispec2D) == 0 .or. njmin(2,ispec2D) == 0) cycle
+ ! checks if we have absorbing boundary arrays
+ if( .not. allocated(nimin) ) call exit_MPI(myrank,'error stacey array not allocated')
- i=NGLLX
- do k=nkmin_xi(2,ispec2D),NGLLZ
- do j=njmin(2,ispec2D),njmax(2,ispec2D)
- iglob=ibool(i,j,k,ispec)
+ ! use the non-dimensional time step to make the mass matrix correction
+ if(CUSTOM_REAL == SIZE_REAL) then
+ deltat = sngl(DT*dsqrt(PI*GRAV*RHOAV))
+ deltatover2 = sngl(0.5d0*deltat)
+ else
+ deltat = DT*dsqrt(PI*GRAV*RHOAV)
+ deltatover2 = 0.5d0*deltat
+ endif
- nx = normal_xmax(1,j,k,ispec2D)
- ny = normal_xmax(2,j,k,ispec2D)
- nz = normal_xmax(3,j,k,ispec2D)
+ ! weights on surfaces
+ do i=1,NGLLX
+ do j=1,NGLLY
+ wgllwgll_xy(i,j) = wxgll(i)*wygll(j)
+ enddo
+ enddo
+ do i=1,NGLLX
+ do k=1,NGLLZ
+ wgllwgll_xz(i,k) = wxgll(i)*wzgll(k)
+ enddo
+ enddo
+ do j=1,NGLLY
+ do k=1,NGLLZ
+ wgllwgll_yz(j,k) = wygll(j)*wzgll(k)
+ enddo
+ enddo
- vn = deltatover2*(nx+ny+nz)
- tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(deltatover2-vn*nx)
- ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(deltatover2-vn*ny)
- tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(deltatover2-vn*nz)
+! ! read arrays for Stacey conditions
+! open(unit=27,file=prname(1:len_trim(prname))//'stacey.bin', &
+! status='old',form='unformatted',action='read',iostat=ier)
+! if( ier /= 0 ) call exit_mpi(myrank,'error opening stacey.bin in create_mass_matrices')
+! read(27) nimin
+! read(27) nimax
+! read(27) njmin
+! read(27) njmax
+! read(27) nkmin_xi
+! read(27) nkmin_eta
+! close(27)
- weight = jacobian2D_xmax(j,k,ispec2D)*wgllwgll_yz(j,k)
+ select case(iregion_code)
+ case(IREGION_CRUST_MANTLE)
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassx(iglob) = rmassx(iglob) + sngl(tx*weight)
- rmassy(iglob) = rmassy(iglob) + sngl(ty*weight)
- rmassz(iglob) = rmassz(iglob) + sngl(tz*weight)
- else
- rmassx(iglob) = rmassx(iglob) + tx*weight
- rmassy(iglob) = rmassy(iglob) + ty*weight
- rmassz(iglob) = rmassz(iglob) + tz*weight
- endif
- enddo
- enddo
- enddo
+ rmassx(:) = rmassz(:)
+ rmassy(:) = rmassz(:)
- endif ! NCHUNKS == 1 .or. ichunk == CHUNK_AB
+ ! xmin
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS == 1 .or. ichunk == CHUNK_AC) then
- ! ymin
- do ispec2D=1,nspec2D_ymin
+ do ispec2D=1,nspec2D_xmin
- ispec=ibelm_ymin(ispec2D)
+ ispec=ibelm_xmin(ispec2D)
- ! exclude elements that are not on absorbing edges
- if(nkmin_eta(1,ispec2D) == 0 .or. nimin(1,ispec2D) == 0) cycle
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_xi(1,ispec2D) == 0 .or. njmin(1,ispec2D) == 0) cycle
- j=1
- do k=nkmin_eta(1,ispec2D),NGLLZ
- do i=nimin(1,ispec2D),nimax(1,ispec2D)
- iglob=ibool(i,j,k,ispec)
+ i=1
+ do k=nkmin_xi(1,ispec2D),NGLLZ
+ do j=njmin(1,ispec2D),njmax(1,ispec2D)
+ iglob=ibool(i,j,k,ispec)
- nx = normal_ymin(1,i,k,ispec2D)
- ny = normal_ymin(2,i,k,ispec2D)
- nz = normal_ymin(3,i,k,ispec2D)
+ nx = normal_xmin(1,j,k,ispec2D)
+ ny = normal_xmin(2,j,k,ispec2D)
+ nz = normal_xmin(3,j,k,ispec2D)
- vn = deltatover2*(nx+ny+nz)
+ vn = deltatover2*(nx+ny+nz)
- tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(deltatover2-vn*nx)
- ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(deltatover2-vn*ny)
- tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(deltatover2-vn*nz)
+ tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(deltatover2-vn*nx)
+ ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(deltatover2-vn*ny)
+ tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(deltatover2-vn*nz)
- weight = jacobian2D_ymin(i,k,ispec2D)*wgllwgll_xz(i,k)
+ weight = jacobian2D_xmin(j,k,ispec2D)*wgllwgll_yz(j,k)
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassx(iglob) = rmassx(iglob) + sngl(tx*weight)
- rmassy(iglob) = rmassy(iglob) + sngl(ty*weight)
- rmassz(iglob) = rmassz(iglob) + sngl(tz*weight)
- else
- rmassx(iglob) = rmassx(iglob) + tx*weight
- rmassy(iglob) = rmassy(iglob) + ty*weight
- rmassz(iglob) = rmassz(iglob) + tz*weight
- endif
- enddo
- enddo
- enddo
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassx(iglob) = rmassx(iglob) + sngl(tx*weight)
+ rmassy(iglob) = rmassy(iglob) + sngl(ty*weight)
+ rmassz(iglob) = rmassz(iglob) + sngl(tz*weight)
+ else
+ rmassx(iglob) = rmassx(iglob) + tx*weight
+ rmassy(iglob) = rmassy(iglob) + ty*weight
+ rmassz(iglob) = rmassz(iglob) + tz*weight
+ endif
+ enddo
+ enddo
+ enddo
- ! ymax
- do ispec2D=1,nspec2D_ymax
+ endif ! NCHUNKS == 1 .or. ichunk == CHUNK_AC
- ispec=ibelm_ymax(ispec2D)
+ ! xmax
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS == 1 .or. ichunk == CHUNK_AB) then
- ! exclude elements that are not on absorbing edges
- if(nkmin_eta(2,ispec2D) == 0 .or. nimin(2,ispec2D) == 0) cycle
+ do ispec2D=1,nspec2D_xmax
- j=NGLLY
- do k=nkmin_eta(2,ispec2D),NGLLZ
- do i=nimin(2,ispec2D),nimax(2,ispec2D)
- iglob=ibool(i,j,k,ispec)
+ ispec=ibelm_xmax(ispec2D)
- nx = normal_ymax(1,i,k,ispec2D)
- ny = normal_ymax(2,i,k,ispec2D)
- nz = normal_ymax(3,i,k,ispec2D)
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_xi(2,ispec2D) == 0 .or. njmin(2,ispec2D) == 0) cycle
- vn = deltatover2*(nx+ny+nz)
+ i=NGLLX
+ do k=nkmin_xi(2,ispec2D),NGLLZ
+ do j=njmin(2,ispec2D),njmax(2,ispec2D)
+ iglob=ibool(i,j,k,ispec)
- tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(deltatover2-vn*nx)
- ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(deltatover2-vn*ny)
- tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(deltatover2-vn*nz)
+ nx = normal_xmax(1,j,k,ispec2D)
+ ny = normal_xmax(2,j,k,ispec2D)
+ nz = normal_xmax(3,j,k,ispec2D)
- weight = jacobian2D_ymax(i,k,ispec2D)*wgllwgll_xz(i,k)
+ vn = deltatover2*(nx+ny+nz)
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassx(iglob) = rmassx(iglob) + sngl(tx*weight)
- rmassy(iglob) = rmassy(iglob) + sngl(ty*weight)
- rmassz(iglob) = rmassz(iglob) + sngl(tz*weight)
- else
- rmassx(iglob) = rmassx(iglob) + tx*weight
- rmassy(iglob) = rmassy(iglob) + ty*weight
- rmassz(iglob) = rmassz(iglob) + tz*weight
- endif
- enddo
- enddo
- enddo
+ tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(deltatover2-vn*nx)
+ ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(deltatover2-vn*ny)
+ tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(deltatover2-vn*nz)
- ! check that mass matrix is positive
- if(minval(rmassx(:)) <= 0.) call exit_MPI(myrank,'negative rmassx matrix term')
- if(minval(rmassy(:)) <= 0.) call exit_MPI(myrank,'negative rmassy matrix term')
+ weight = jacobian2D_xmax(j,k,ispec2D)*wgllwgll_yz(j,k)
- case(IREGION_OUTER_CORE)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassx(iglob) = rmassx(iglob) + sngl(tx*weight)
+ rmassy(iglob) = rmassy(iglob) + sngl(ty*weight)
+ rmassz(iglob) = rmassz(iglob) + sngl(tz*weight)
+ else
+ rmassx(iglob) = rmassx(iglob) + tx*weight
+ rmassy(iglob) = rmassy(iglob) + ty*weight
+ rmassz(iglob) = rmassz(iglob) + tz*weight
+ endif
+ enddo
+ enddo
+ enddo
- ! xmin
- ! if two chunks exclude this face for one of them
- if(NCHUNKS == 1 .or. ichunk == CHUNK_AC) then
+ endif ! NCHUNKS == 1 .or. ichunk == CHUNK_AB
- do ispec2D=1,nspec2D_xmin
+ ! ymin
+ do ispec2D=1,nspec2D_ymin
- ispec=ibelm_xmin(ispec2D)
+ ispec=ibelm_ymin(ispec2D)
- ! exclude elements that are not on absorbing edges
- if(nkmin_xi(1,ispec2D) == 0 .or. njmin(1,ispec2D) == 0) cycle
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_eta(1,ispec2D) == 0 .or. nimin(1,ispec2D) == 0) cycle
- i=1
- do k=nkmin_xi(1,ispec2D),NGLLZ
- do j=njmin(1,ispec2D),njmax(1,ispec2D)
- iglob=ibool(i,j,k,ispec)
+ j=1
+ do k=nkmin_eta(1,ispec2D),NGLLZ
+ do i=nimin(1,ispec2D),nimax(1,ispec2D)
+ iglob=ibool(i,j,k,ispec)
- sn = deltatover2/rho_vp(i,j,k,ispec)
+ nx = normal_ymin(1,i,k,ispec2D)
+ ny = normal_ymin(2,i,k,ispec2D)
+ nz = normal_ymin(3,i,k,ispec2D)
- weight = jacobian2D_xmin(j,k,ispec2D)*wgllwgll_yz(j,k)
+ vn = deltatover2*(nx+ny+nz)
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
- else
- rmassz(iglob) = rmassz(iglob) + weight*sn
- endif
- enddo
- enddo
- enddo
+ tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(deltatover2-vn*nx)
+ ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(deltatover2-vn*ny)
+ tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(deltatover2-vn*nz)
- endif ! NCHUNKS == 1 .or. ichunk == CHUNK_AC
+ weight = jacobian2D_ymin(i,k,ispec2D)*wgllwgll_xz(i,k)
- ! xmax
- ! if two chunks exclude this face for one of them
- if(NCHUNKS == 1 .or. ichunk == CHUNK_AB) then
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassx(iglob) = rmassx(iglob) + sngl(tx*weight)
+ rmassy(iglob) = rmassy(iglob) + sngl(ty*weight)
+ rmassz(iglob) = rmassz(iglob) + sngl(tz*weight)
+ else
+ rmassx(iglob) = rmassx(iglob) + tx*weight
+ rmassy(iglob) = rmassy(iglob) + ty*weight
+ rmassz(iglob) = rmassz(iglob) + tz*weight
+ endif
+ enddo
+ enddo
+ enddo
- do ispec2D=1,nspec2D_xmax
+ ! ymax
+ do ispec2D=1,nspec2D_ymax
- ispec=ibelm_xmax(ispec2D)
+ ispec=ibelm_ymax(ispec2D)
- ! exclude elements that are not on absorbing edges
- if(nkmin_xi(2,ispec2D) == 0 .or. njmin(2,ispec2D) == 0) cycle
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_eta(2,ispec2D) == 0 .or. nimin(2,ispec2D) == 0) cycle
- i=NGLLX
- do k=nkmin_xi(2,ispec2D),NGLLZ
- do j=njmin(2,ispec2D),njmax(2,ispec2D)
- iglob=ibool(i,j,k,ispec)
+ j=NGLLY
+ do k=nkmin_eta(2,ispec2D),NGLLZ
+ do i=nimin(2,ispec2D),nimax(2,ispec2D)
+ iglob=ibool(i,j,k,ispec)
- sn = deltatover2/rho_vp(i,j,k,ispec)
+ nx = normal_ymax(1,i,k,ispec2D)
+ ny = normal_ymax(2,i,k,ispec2D)
+ nz = normal_ymax(3,i,k,ispec2D)
- weight = jacobian2D_xmax(j,k,ispec2D)*wgllwgll_yz(j,k)
+ vn = deltatover2*(nx+ny+nz)
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
- else
- rmassz(iglob) = rmassz(iglob) + weight*sn
- endif
- enddo
- enddo
- enddo
+ tx = rho_vp(i,j,k,ispec)*vn*nx + rho_vs(i,j,k,ispec)*(deltatover2-vn*nx)
+ ty = rho_vp(i,j,k,ispec)*vn*ny + rho_vs(i,j,k,ispec)*(deltatover2-vn*ny)
+ tz = rho_vp(i,j,k,ispec)*vn*nz + rho_vs(i,j,k,ispec)*(deltatover2-vn*nz)
- endif ! NCHUNKS == 1 .or. ichunk == CHUNK_AB
+ weight = jacobian2D_ymax(i,k,ispec2D)*wgllwgll_xz(i,k)
- ! ymin
- do ispec2D=1,nspec2D_ymin
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassx(iglob) = rmassx(iglob) + sngl(tx*weight)
+ rmassy(iglob) = rmassy(iglob) + sngl(ty*weight)
+ rmassz(iglob) = rmassz(iglob) + sngl(tz*weight)
+ else
+ rmassx(iglob) = rmassx(iglob) + tx*weight
+ rmassy(iglob) = rmassy(iglob) + ty*weight
+ rmassz(iglob) = rmassz(iglob) + tz*weight
+ endif
+ enddo
+ enddo
+ enddo
- ispec=ibelm_ymin(ispec2D)
+ ! check that mass matrix is positive
+ if(minval(rmassx(:)) <= 0.) call exit_MPI(myrank,'negative rmassx matrix term')
+ if(minval(rmassy(:)) <= 0.) call exit_MPI(myrank,'negative rmassy matrix term')
- ! exclude elements that are not on absorbing edges
- if(nkmin_eta(1,ispec2D) == 0 .or. nimin(1,ispec2D) == 0) cycle
+ case(IREGION_OUTER_CORE)
- j=1
- do k=nkmin_eta(1,ispec2D),NGLLZ
- do i=nimin(1,ispec2D),nimax(1,ispec2D)
- iglob=ibool(i,j,k,ispec)
+ ! xmin
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS == 1 .or. ichunk == CHUNK_AC) then
- sn = deltatover2/rho_vp(i,j,k,ispec)
+ do ispec2D=1,nspec2D_xmin
- weight = jacobian2D_ymin(i,k,ispec2D)*wgllwgll_xz(i,k)
+ ispec=ibelm_xmin(ispec2D)
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
- else
- rmassz(iglob) = rmassz(iglob) + weight*sn
- endif
- enddo
- enddo
- enddo
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_xi(1,ispec2D) == 0 .or. njmin(1,ispec2D) == 0) cycle
- ! ymax
- do ispec2D=1,nspec2D_ymax
+ i=1
+ do k=nkmin_xi(1,ispec2D),NGLLZ
+ do j=njmin(1,ispec2D),njmax(1,ispec2D)
+ iglob=ibool(i,j,k,ispec)
- ispec=ibelm_ymax(ispec2D)
+ sn = deltatover2/rho_vp(i,j,k,ispec)
- ! exclude elements that are not on absorbing edges
- if(nkmin_eta(2,ispec2D) == 0 .or. nimin(2,ispec2D) == 0) cycle
+ weight = jacobian2D_xmin(j,k,ispec2D)*wgllwgll_yz(j,k)
- j=NGLLY
- do k=nkmin_eta(2,ispec2D),NGLLZ
- do i=nimin(2,ispec2D),nimax(2,ispec2D)
- iglob=ibool(i,j,k,ispec)
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
+ else
+ rmassz(iglob) = rmassz(iglob) + weight*sn
+ endif
+ enddo
+ enddo
+ enddo
- sn = deltatover2/rho_vp(i,j,k,ispec)
+ endif ! NCHUNKS == 1 .or. ichunk == CHUNK_AC
- weight = jacobian2D_ymax(i,k,ispec2D)*wgllwgll_xz(i,k)
+ ! xmax
+ ! if two chunks exclude this face for one of them
+ if(NCHUNKS == 1 .or. ichunk == CHUNK_AB) then
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
- else
- rmassz(iglob) = rmassz(iglob) + weight*sn
- endif
- enddo
- enddo
- enddo
+ do ispec2D=1,nspec2D_xmax
- ! bottom (zmin)
- do ispec2D=1,NSPEC2D_BOTTOM
+ ispec=ibelm_xmax(ispec2D)
- ispec=ibelm_bottom(ispec2D)
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_xi(2,ispec2D) == 0 .or. njmin(2,ispec2D) == 0) cycle
- k=1
- do j=1,NGLLY
- do i=1,NGLLX
- iglob=ibool(i,j,k,ispec)
+ i=NGLLX
+ do k=nkmin_xi(2,ispec2D),NGLLZ
+ do j=njmin(2,ispec2D),njmax(2,ispec2D)
+ iglob=ibool(i,j,k,ispec)
- sn = deltatover2/rho_vp(i,j,k,ispec)
+ sn = deltatover2/rho_vp(i,j,k,ispec)
- weight = jacobian2D_bottom(i,j,ispec2D)*wgllwgll_xy(i,j)
+ weight = jacobian2D_xmax(j,k,ispec2D)*wgllwgll_yz(j,k)
- if(CUSTOM_REAL == SIZE_REAL) then
- rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
- else
- rmassz(iglob) = rmassz(iglob) + weight*sn
- endif
- enddo
- enddo
- enddo
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
+ else
+ rmassz(iglob) = rmassz(iglob) + weight*sn
+ endif
+ enddo
+ enddo
+ enddo
- case( IREGION_INNER_CORE )
- continue
+ endif ! NCHUNKS == 1 .or. ichunk == CHUNK_AB
- case default
- call exit_MPI(myrank,'wrong region code')
+ ! ymin
+ do ispec2D=1,nspec2D_ymin
- end select
+ ispec=ibelm_ymin(ispec2D)
- endif
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_eta(1,ispec2D) == 0 .or. nimin(1,ispec2D) == 0) cycle
- ! check that mass matrix is positive
- ! note: in fictitious elements it is still zero
- if(minval(rmassz(:)) < 0._CUSTOM_REAL) call exit_MPI(myrank,'negative rmassz matrix term')
+ j=1
+ do k=nkmin_eta(1,ispec2D),NGLLZ
+ do i=nimin(1,ispec2D),nimax(1,ispec2D)
+ iglob=ibool(i,j,k,ispec)
- end subroutine create_mass_matrices
+ sn = deltatover2/rho_vp(i,j,k,ispec)
+
+ weight = jacobian2D_ymin(i,k,ispec2D)*wgllwgll_xz(i,k)
+
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
+ else
+ rmassz(iglob) = rmassz(iglob) + weight*sn
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! ymax
+ do ispec2D=1,nspec2D_ymax
+
+ ispec=ibelm_ymax(ispec2D)
+
+ ! exclude elements that are not on absorbing edges
+ if(nkmin_eta(2,ispec2D) == 0 .or. nimin(2,ispec2D) == 0) cycle
+
+ j=NGLLY
+ do k=nkmin_eta(2,ispec2D),NGLLZ
+ do i=nimin(2,ispec2D),nimax(2,ispec2D)
+ iglob=ibool(i,j,k,ispec)
+
+ sn = deltatover2/rho_vp(i,j,k,ispec)
+
+ weight = jacobian2D_ymax(i,k,ispec2D)*wgllwgll_xz(i,k)
+
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
+ else
+ rmassz(iglob) = rmassz(iglob) + weight*sn
+ endif
+ enddo
+ enddo
+ enddo
+
+ ! bottom (zmin)
+ do ispec2D=1,NSPEC2D_BOTTOM
+
+ ispec=ibelm_bottom(ispec2D)
+
+ k=1
+ do j=1,NGLLY
+ do i=1,NGLLX
+ iglob=ibool(i,j,k,ispec)
+
+ sn = deltatover2/rho_vp(i,j,k,ispec)
+
+ weight = jacobian2D_bottom(i,j,ispec2D)*wgllwgll_xy(i,j)
+
+ if(CUSTOM_REAL == SIZE_REAL) then
+ rmassz(iglob) = rmassz(iglob) + sngl(weight*sn)
+ else
+ rmassz(iglob) = rmassz(iglob) + weight*sn
+ endif
+ enddo
+ enddo
+ enddo
+
+ case( IREGION_INNER_CORE )
+ continue
+
+ case default
+ call exit_MPI(myrank,'wrong region code')
+
+ end select
+
+ end subroutine create_mass_matrices_Stacey
+
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_meshes.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_meshes.f90 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_meshes.f90 2012-08-11 02:22:07 UTC (rev 20565)
@@ -32,14 +32,6 @@
implicit none
! local parameters
- ! parameters needed to store the radii of the grid points
- ! in the spherically symmetric Earth
- integer, dimension(:), allocatable :: idoubling
- integer, dimension(:,:,:,:), allocatable :: ibool
- ! arrays with the mesh in double precision
- double precision, dimension(:,:,:,:), allocatable :: xstore,ystore,zstore
- ! this for non blocking MPI
- logical, dimension(:), allocatable :: is_on_a_slice_edge
integer :: ipass
integer :: ier
@@ -100,13 +92,10 @@
! create all the regions of the mesh
! perform two passes in this part to be able to save memory
do ipass = 1,2
- call create_regions_mesh(iregion_code,ibool,idoubling,is_on_a_slice_edge, &
- xstore,ystore,zstore, &
- NSPEC(iregion_code), &
- NGLOB(iregion_code),npointot, &
+ 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), &
- NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_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)
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regions_mesh.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regions_mesh.f90 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/create_regions_mesh.f90 2012-08-11 02:22:07 UTC (rev 20565)
@@ -27,13 +27,10 @@
- subroutine create_regions_mesh(iregion_code,ibool,idoubling,is_on_a_slice_edge, &
- xstore,ystore,zstore, &
- nspec, &
- nglob_theor,npointot, &
+ subroutine create_regions_mesh(iregion_code, &
+ nspec,nglob_theor,npointot, &
NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
NSPEC2D_BOTTOM,NSPEC2D_TOP, &
offset_proc_xi,offset_proc_eta, &
ipass)
@@ -41,20 +38,24 @@
! creates the different regions of the mesh
use meshfem3D_par,only: &
+ ibool,idoubling,is_on_a_slice_edge, &
+ xstore,ystore,zstore, &
IMAIN,volume_total,addressing,ichunk_slice,iproc_xi_slice,iproc_eta_slice, &
myrank,LOCAL_PATH, &
IREGION_CRUST_MANTLE,IREGION_OUTER_CORE,IREGION_INNER_CORE,IFLAG_IN_FICTITIOUS_CUBE, &
NPROC,NPROCTOT,NPROC_XI,NPROC_ETA,NCHUNKS, &
SAVE_MESH_FILES,ABSORBING_CONDITIONS, &
- R_CENTRAL_CUBE,RICB,RHO_OCEANS,RCMB, &
- MAX_NUMBER_OF_MESH_LAYERS,MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR,NB_SQUARE_CORNERS, &
- NGLOB1D_RADIAL_CORNER
+ R_CENTRAL_CUBE,RICB,RCMB, &
+ MAX_NUMBER_OF_MESH_LAYERS,MAX_NUM_REGIONS,NB_SQUARE_CORNERS, &
+ NGLOB1D_RADIAL_CORNER, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
use meshfem3D_models_par,only: &
- ATTENUATION,ANISOTROPIC_INNER_CORE,ANISOTROPIC_3D_MANTLE, &
SAVE_BOUNDARY_MESH,SUPPRESS_CRUSTAL_MESH,REGIONAL_MOHO_MESH, &
- OCEANS,TRANSVERSE_ISOTROPY,HETEROGEN_3D_MANTLE
+ OCEANS
+ use create_MPI_interfaces_par
+
use create_regions_mesh_par
use create_regions_mesh_par2
@@ -65,21 +66,10 @@
! correct number of spectral elements in each block depending on chunk type
integer :: nspec
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- integer, dimension(nspec) :: idoubling
-
- ! this for non blocking MPI
- logical, dimension(nspec) :: is_on_a_slice_edge
-
- ! arrays with the mesh in double precision
- double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
-
integer :: nglob_theor,npointot
integer :: NEX_PER_PROC_XI,NEX_PER_PROC_ETA
integer :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
- integer :: NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
integer :: NSPEC2D_BOTTOM,NSPEC2D_TOP
integer :: offset_proc_xi,offset_proc_eta
@@ -90,8 +80,6 @@
! local parameters
integer :: ier
integer :: nglob
- ! saved for second call
- integer, save :: npoin2D_xi,npoin2D_eta
! check area and volume of the final mesh
double precision :: area_local_bottom,area_local_top
double precision :: volume_local
@@ -116,10 +104,9 @@
if( myrank == 0) then
write(IMAIN,*) ' ...allocating arrays '
endif
- call crm_allocate_arrays(iregion_code,nspec, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- ipass)
+ call crm_allocate_arrays(iregion_code,nspec,ipass, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
+ NSPEC2D_BOTTOM,NSPEC2D_TOP)
! initialize number of layers
@@ -127,9 +114,7 @@
if( myrank == 0) then
write(IMAIN,*) ' ...setting up layers '
endif
- call crm_setup_layers(iregion_code,nspec,ipass, &
- xstore,ystore,zstore,ibool,idoubling, &
- NEX_PER_PROC_ETA,is_on_a_slice_edge)
+ call crm_setup_layers(iregion_code,nspec,ipass,NEX_PER_PROC_ETA)
! creates mesh elements
call sync_all()
@@ -137,10 +122,8 @@
write(IMAIN,*) ' ...creating mesh elements '
endif
call crm_create_elements(iregion_code,nspec,ipass, &
- xstore,ystore,zstore,idoubling, &
- NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- is_on_a_slice_edge, &
- offset_proc_xi,offset_proc_eta)
+ NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ offset_proc_xi,offset_proc_eta)
! only create global addressing and the MPI buffers in the first pass
@@ -151,8 +134,7 @@
if( myrank == 0) then
write(IMAIN,*) ' ...creating global addressing'
endif
- call crm_setup_indexing(ibool,xstore,ystore,zstore, &
- nspec,nglob_theor,npointot)
+ call crm_setup_indexing(nspec,nglob_theor,npointot)
! create MPI buffers
@@ -160,17 +142,13 @@
if( myrank == 0) then
write(IMAIN,*) ' ...creating MPI buffers'
endif
- call crm_setup_mpi_buffers(npointot,nspec,ibool,idoubling, &
- xstore,ystore,zstore,iregion_code, &
- npoin2D_xi,npoin2D_eta)
+ call crm_setup_mpi_buffers(npointot,nspec,iregion_code)
- ! Stacey
+ ! sets up Stacey absorbing boundary indices
if(NCHUNKS /= 6) then
call get_absorb(myrank,prname,iboun,nspec,nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM)
-
- deallocate(nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta)
endif
! only create mass matrix and save all the final arrays in the second pass
@@ -199,27 +177,48 @@
if( myrank == 0) then
write(IMAIN,*) ' ...creating chunk buffers'
endif
- if(NCHUNKS > 1) then
- call create_chunk_buffers(iregion_code,nspec,ibool,idoubling, &
- xstore,ystore,zstore, &
- nglob_theor, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NPROC_XI,NPROC_ETA, &
- NPROC,NPROCTOT, &
- NGLOB1D_RADIAL_CORNER,maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:)), &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
- myrank,LOCAL_PATH,addressing, &
- ichunk_slice,iproc_xi_slice,iproc_eta_slice,NCHUNKS, &
- nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax, &
- ibelm_xmin,ibelm_xmax,ibelm_ymin,ibelm_ymax)
- else
- if(myrank == 0) then
- write(IMAIN,*)
- write(IMAIN,*) 'only one chunk, no need to create chunk buffers'
- write(IMAIN,*)
- endif
+ call create_chunk_buffers(iregion_code,nspec,ibool,idoubling, &
+ xstore,ystore,zstore,nglob_theor, &
+ NGLOB1D_RADIAL_CORNER,NGLOB1D_RADIAL_MAX, &
+ NGLOB2DMAX_XMIN_XMAX(iregion_code),NGLOB2DMAX_YMIN_YMAX(iregion_code))
+
+ ! only deallocates after second pass
+ deallocate(ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta, &
+ xyz1D_leftxi_lefteta,xyz1D_rightxi_lefteta, &
+ xyz1D_leftxi_righteta,xyz1D_rightxi_righteta)
+
+ ! setup mpi communication interfaces
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...preparing MPI interfaces'
endif
+ ! creates MPI interface arrays
+ call create_MPI_interfaces(iregion_code)
+ ! sets up MPI interface arrays
+ call setup_MPI_interfaces(iregion_code)
+
+ ! only deallocates after second pass
+ deallocate(iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta)
+ deallocate(iboolfaces)
+ deallocate(iboolcorner)
+
+ ! sets up inner/outer element arrays
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...element inner/outer separation '
+ endif
+ call setup_inner_outer(iregion_code)
+
+ ! sets up mesh coloring
+ call sync_all()
+ if( myrank == 0) then
+ write(IMAIN,*) ' ...element mesh coloring '
+ endif
+ call setup_color_perm(iregion_code)
+
+
!uncomment: adds model smoothing for point profile models
! if( THREE_D_MODEL == THREE_D_MODEL_PPM ) then
! call smooth_model(myrank, nproc_xi,nproc_eta,&
@@ -232,6 +231,7 @@
! nspec,HETEROGEN_3D_MANTLE, &
! NEX_XI,NCHUNKS,ABSORBING_CONDITIONS )
+
! creates mass matrix
call sync_all()
if( myrank == 0) then
@@ -282,50 +282,30 @@
! creating mass matrices in this slice (will be fully assembled in the solver)
call create_mass_matrices(myrank,nspec,idoubling,ibool, &
iregion_code,xstore,ystore,zstore, &
- NSPEC2D_TOP,NSPEC2D_BOTTOM, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX)
+ NSPEC2D_TOP,NSPEC2D_BOTTOM)
! save the binary files
call sync_all()
if( myrank == 0) then
write(IMAIN,*) ' ...saving binary files'
endif
+ ! saves mesh and model parameters
call save_arrays_solver(myrank,nspec,nglob,idoubling,ibool, &
iregion_code,xstore,ystore,zstore, &
is_on_a_slice_edge, &
NSPEC2D_TOP,NSPEC2D_BOTTOM)
- deallocate(rmassx,rmassy,rmassz)
- deallocate(rmass_ocean_load)
-
- ! setup mpi communication interfaces
- call sync_all()
- if( myrank == 0) then
- write(IMAIN,*) ' ...preparing MPI interfaces'
- endif
- call create_MPI_interfaces(iregion_code)
-
- ! sets up inner/outer element arrays
- call sync_all()
- if( myrank == 0) then
- write(IMAIN,*) ' ...element inner/outer separation '
- endif
- call setup_inner_outer(iregion_code)
-
- ! sets up mesh coloring
- call sync_all()
- if( myrank == 0) then
- write(IMAIN,*) ' ...element mesh coloring '
- endif
- call setup_color_perm(iregion_code)
-
! saves MPI interface infos
- call cmi_save_MPI_interfaces(iregion_code)
+ call save_arrays_solver_MPI(iregion_code)
! frees memory
- call cmi_free_MPI_arrays(iregion_code)
+ deallocate(rmassx,rmassy,rmassz)
+ deallocate(rmass_ocean_load)
+ ! Stacey
+ if( NCHUNKS /= 6 ) deallocate(nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta)
+ ! frees MPI arrays memory
+ call crm_free_MPI_arrays(iregion_code)
-
! boundary mesh
if (SAVE_BOUNDARY_MESH .and. iregion_code == IREGION_CRUST_MANTLE) then
! user output
@@ -355,8 +335,7 @@
if( myrank == 0) then
write(IMAIN,*) ' ...saving AVS mesh files'
endif
- call crm_save_mesh_files(nspec,npointot,iregion_code,ibool,idoubling, &
- xstore,ystore,zstore)
+ call crm_save_mesh_files(nspec,npointot,iregion_code)
endif
case default
@@ -397,7 +376,6 @@
deallocate(ibelm_670_top,ibelm_670_bot)
deallocate(normal_moho,normal_400,normal_670)
-
! user output
if(myrank == 0 ) write(IMAIN,*)
@@ -407,28 +385,31 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine crm_allocate_arrays(iregion_code,nspec, &
+ subroutine crm_allocate_arrays(iregion_code,nspec,ipass, &
NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX, &
- NSPEC2D_BOTTOM,NSPEC2D_TOP, &
- ipass)
+ NSPEC2D_BOTTOM,NSPEC2D_TOP)
use meshfem3D_par,only: &
NGLLX,NGLLY,NGLLZ,NDIM, &
IREGION_CRUST_MANTLE,IREGION_OUTER_CORE,IREGION_INNER_CORE, &
- NCHUNKS
+ NCHUNKS,NUMCORNERS_SHARED,NUMFACES_SHARED, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX, &
+ NGLOB1D_RADIAL,NGLOB1D_RADIAL_CORNER
use meshfem3D_models_par,only: &
ATTENUATION,ATTENUATION_3D,ANISOTROPIC_INNER_CORE,ANISOTROPIC_3D_MANTLE, &
SAVE_BOUNDARY_MESH,AM_V
use create_regions_mesh_par2
+ use create_MPI_interfaces_par
implicit none
integer,intent(in) :: iregion_code,nspec
+ integer,intent(in) :: ipass
+
integer,intent(in) :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX
integer,intent(in) :: NSPEC2D_BOTTOM,NSPEC2D_TOP
- integer,intent(in) :: ipass
! local parameters
integer :: ier
@@ -557,6 +538,44 @@
iMPIcut_eta(2,nspec),stat=ier)
if(ier /= 0) stop 'error in allocate 15'
+ ! MPI buffer indices
+ !
+ ! define maximum size for message buffers
+ ! use number of elements found in the mantle since it is the largest region
+ NGLOB2DMAX_XY = max(NGLOB2DMAX_XMIN_XMAX(IREGION_CRUST_MANTLE),NGLOB2DMAX_YMIN_YMAX(IREGION_CRUST_MANTLE))
+ ! 1-D buffers
+ NGLOB1D_RADIAL_MAX = maxval(NGLOB1D_RADIAL_CORNER(iregion_code,:))
+
+ if( ipass == 1 ) then
+ allocate(iboolleft_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)), &
+ iboolright_xi(NGLOB2DMAX_XMIN_XMAX(iregion_code)), &
+ iboolleft_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)), &
+ iboolright_eta(NGLOB2DMAX_YMIN_YMAX(iregion_code)), &
+ stat=ier)
+ if(ier /= 0) stop 'error in allocate 15b'
+
+ allocate(ibool1D_leftxi_lefteta(NGLOB1D_RADIAL_MAX), &
+ ibool1D_rightxi_lefteta(NGLOB1D_RADIAL_MAX), &
+ ibool1D_leftxi_righteta(NGLOB1D_RADIAL_MAX), &
+ ibool1D_rightxi_righteta(NGLOB1D_RADIAL_MAX), &
+ stat=ier)
+ if(ier /= 0) stop 'error in allocate 15c'
+
+ allocate(xyz1D_leftxi_lefteta(NGLOB1D_RADIAL_MAX,NDIM), &
+ xyz1D_rightxi_lefteta(NGLOB1D_RADIAL_MAX,NDIM), &
+ xyz1D_leftxi_righteta(NGLOB1D_RADIAL_MAX,NDIM), &
+ xyz1D_rightxi_righteta(NGLOB1D_RADIAL_MAX,NDIM), &
+ stat=ier)
+ if(ier /= 0) stop 'error in allocate 15c'
+
+ allocate(iboolcorner(NGLOB1D_RADIAL(iregion_code),NUMCORNERS_SHARED), &
+ iboolfaces(NGLOB2DMAX_XY,NUMFACES_SHARED), &
+ stat=ier)
+ if(ier /= 0) stop 'error in allocate 15b'
+
+ endif
+
+
! store and save the final arrays only in the second pass
! therefore in the first pass some arrays can be allocated with a dummy size
if(ipass == 1) then
@@ -603,10 +622,11 @@
!
subroutine crm_setup_layers(iregion_code,nspec,ipass, &
- xstore,ystore,zstore,ibool,idoubling, &
- NEX_PER_PROC_ETA,is_on_a_slice_edge)
+ NEX_PER_PROC_ETA)
use meshfem3D_par,only: &
+ ibool,idoubling,is_on_a_slice_edge, &
+ xstore,ystore,zstore, &
myrank,NGLLX,NGLLY,NGLLZ, &
IREGION_CRUST_MANTLE,IREGION_OUTER_CORE,IREGION_INNER_CORE, &
R670,RMOHO,R400,RMIDDLE_CRUST,MAX_NUMBER_OF_MESH_LAYERS, &
@@ -622,18 +642,6 @@
integer,intent(in) :: iregion_code,nspec
integer,intent(in) :: ipass
-
- ! arrays with the mesh in double precision
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- integer, dimension(nspec) :: idoubling
-
- ! this for non blocking MPI
- logical, dimension(nspec) :: is_on_a_slice_edge
-
integer :: NEX_PER_PROC_ETA
! local parameters
@@ -704,19 +712,19 @@
!
subroutine crm_create_elements(iregion_code,nspec,ipass, &
- xstore,ystore,zstore,idoubling, &
- NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
- is_on_a_slice_edge, &
- offset_proc_xi,offset_proc_eta)
+ NEX_PER_PROC_XI,NEX_PER_PROC_ETA, &
+ offset_proc_xi,offset_proc_eta)
! creates the different regions of the mesh
use meshfem3D_par,only: &
+ ibool,idoubling,is_on_a_slice_edge, &
+ xstore,ystore,zstore, &
IMAIN,myrank, &
IREGION_CRUST_MANTLE,IREGION_OUTER_CORE,IREGION_INNER_CORE,IFLAG_IN_FICTITIOUS_CUBE, &
NPROC_XI,NPROC_ETA,NCHUNKS, &
INCLUDE_CENTRAL_CUBE,R_CENTRAL_CUBE, &
- MAX_NUMBER_OF_MESH_LAYERS,MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR,NB_SQUARE_CORNERS, &
+ MAX_NUMBER_OF_MESH_LAYERS,MAX_NUM_REGIONS,NB_SQUARE_CORNERS, &
rmins,rmaxs,iproc_xi,iproc_eta,ichunk,NEX_XI, &
rotation_matrix,ANGULAR_WIDTH_XI_RAD,ANGULAR_WIDTH_ETA_RAD, &
ratio_sampling_array,doubling_index,this_region_has_a_doubling, &
@@ -735,16 +743,6 @@
integer,intent(in) :: iregion_code,nspec
integer,intent(in) :: ipass
- ! arrays with the mesh in double precision
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
-
- integer, dimension(nspec) :: idoubling
-
- ! this for non blocking MPI
- logical, dimension(nspec) :: is_on_a_slice_edge
-
integer :: NEX_PER_PROC_XI,NEX_PER_PROC_ETA
integer :: offset_proc_xi,offset_proc_eta
@@ -947,14 +945,15 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine crm_setup_indexing(ibool,xstore,ystore,zstore, &
- nspec,nglob_theor,npointot)
+ subroutine crm_setup_indexing(nspec,nglob_theor,npointot)
! creates global indexing array ibool
use constants,only: NGLLX,NGLLY,NGLLZ,ZERO
- use meshfem3d_par,only: myrank
+ use meshfem3d_par,only: &
+ ibool,xstore,ystore,zstore, &
+ myrank
use create_regions_mesh_par2
@@ -963,10 +962,6 @@
! number of spectral elements in each block
integer,intent(in) :: nspec,npointot,nglob_theor
- ! arrays with the mesh
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
-
! local parameters
! variables for creating array ibool
double precision, dimension(:), allocatable :: xp,yp,zp
@@ -1037,31 +1032,27 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine crm_setup_mpi_buffers(npointot,nspec,ibool,idoubling, &
- xstore,ystore,zstore,iregion_code, &
- npoin2D_xi,npoin2D_eta)
+ subroutine crm_setup_mpi_buffers(npointot,nspec,iregion_code)
! sets up MPI cutplane arrays
use meshfem3d_par,only: &
+ ibool,idoubling, &
+ xstore,ystore,zstore, &
myrank,NGLLX,NGLLY,NGLLZ, &
NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER, &
- NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE
+ NSPEC2D_XI_FACE,NSPEC2D_ETA_FACE, &
+ NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX
+ use create_MPI_interfaces_par
use create_regions_mesh_par2
+
implicit none
! number of spectral elements in each block
integer,intent(in) :: nspec,npointot
- ! arrays with the mesh
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- integer, dimension(nspec) :: idoubling
-
- double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
-
integer,intent(in) :: iregion_code
- integer :: npoin2D_xi,npoin2D_eta
! local parameters
logical, dimension(:), allocatable :: mask_ibool
@@ -1073,17 +1064,36 @@
stat=ier)
if(ier /= 0) stop 'error in allocate 20b'
+ ! initializes
+ npoin2D_xi_all(:) = 0
+ npoin2D_eta_all(:) = 0
+ iboolleft_xi(:) = 0
+ iboolleft_eta(:) = 0
+ iboolright_xi(:) = 0
+ iboolright_eta(:) = 0
+
+ ! gets MPI buffer indices
call get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, &
xstore,ystore,zstore,mask_ibool,npointot, &
- NSPEC2D_ETA_FACE,iregion_code,npoin2D_xi)
+ NSPEC2D_ETA_FACE,iregion_code,npoin2D_xi, &
+ iboolleft_xi,iboolright_xi, &
+ npoin2D_xi_all,NGLOB2DMAX_XMIN_XMAX(iregion_code))
call get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, &
xstore,ystore,zstore,mask_ibool,npointot, &
- NSPEC2D_XI_FACE,iregion_code,npoin2D_eta)
+ NSPEC2D_XI_FACE,iregion_code,npoin2D_eta, &
+ iboolleft_eta,iboolright_eta, &
+ npoin2D_eta_all,NGLOB2DMAX_YMIN_YMAX(iregion_code))
- call get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool,idoubling, &
+ call get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta, &
+ ibool,idoubling, &
xstore,ystore,zstore,mask_ibool,npointot, &
- NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion_code)
+ NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion_code, &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta, &
+ xyz1D_leftxi_lefteta,xyz1D_rightxi_lefteta, &
+ xyz1D_leftxi_righteta,xyz1D_rightxi_righteta, &
+ NGLOB1D_RADIAL_MAX)
deallocate(mask_ibool)
@@ -1142,10 +1152,11 @@
!-------------------------------------------------------------------------------------------------
!
- subroutine crm_save_mesh_files(nspec,npointot,iregion_code,ibool,idoubling, &
- xstore,ystore,zstore)
+ subroutine crm_save_mesh_files(nspec,npointot,iregion_code)
use meshfem3d_par,only: &
+ ibool,idoubling, &
+ xstore,ystore,zstore, &
myrank,NGLLX,NGLLY,NGLLZ, &
RICB,RCMB,RTOPDDOUBLEPRIME,R600,R670,R220,R771,R400,R120,R80,RMOHO, &
RMIDDLE_CRUST,ROCEAN
@@ -1160,12 +1171,6 @@
! number of spectral elements in each block
integer,intent(in) :: nspec,npointot,iregion_code
- ! arrays with the mesh
- integer, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
- integer, dimension(nspec) :: idoubling
-
- double precision, dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
-
! local parameters
! arrays used for AVS or DX files
integer, dimension(:), allocatable :: num_ibool_AVS_DX
@@ -1210,3 +1215,87 @@
deallocate(num_ibool_AVS_DX,mask_ibool)
end subroutine crm_save_mesh_files
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine crm_free_MPI_arrays(iregion_code)
+
+ 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
+
+ ! free memory
+ 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)
+
+ deallocate(phase_ispec_inner_crust_mantle)
+ deallocate(num_elem_colors_crust_mantle)
+
+ deallocate(xstore_crust_mantle,ystore_crust_mantle,zstore_crust_mantle)
+ deallocate(idoubling_crust_mantle,ibool_crust_mantle)
+
+ deallocate(is_on_a_slice_edge_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)
+
+ deallocate(phase_ispec_inner_outer_core)
+ deallocate(num_elem_colors_outer_core)
+
+ deallocate(xstore_outer_core,ystore_outer_core,zstore_outer_core)
+ deallocate(idoubling_outer_core,ibool_outer_core)
+
+ deallocate(is_on_a_slice_edge_outer_core)
+
+ case( IREGION_INNER_CORE )
+ ! inner core
+ deallocate(ibelm_xmin_inner_core, &
+ ibelm_xmax_inner_core)
+ deallocate(ibelm_ymin_inner_core, &
+ ibelm_ymax_inner_core)
+ deallocate(ibelm_bottom_inner_core)
+ deallocate(ibelm_top_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)
+
+ deallocate(xstore_inner_core,ystore_inner_core,zstore_inner_core)
+ deallocate(idoubling_inner_core,ibool_inner_core)
+
+ deallocate(phase_ispec_inner_inner_core)
+ deallocate(num_elem_colors_inner_core)
+
+ deallocate(is_on_a_slice_edge_inner_core)
+
+ end select
+
+ end subroutine crm_free_MPI_arrays
+
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_1D_buffers.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_1D_buffers.f90 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_1D_buffers.f90 2012-08-11 02:22:07 UTC (rev 20565)
@@ -25,9 +25,15 @@
!
!=====================================================================
- subroutine get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta,ibool, &
- idoubling,xstore,ystore,zstore,mask_ibool,npointot, &
- NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion)
+ subroutine get_MPI_1D_buffers(myrank,prname,nspec,iMPIcut_xi,iMPIcut_eta, &
+ ibool,idoubling, &
+ xstore,ystore,zstore,mask_ibool,npointot, &
+ NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER,iregion, &
+ ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta, &
+ xyz1D_leftxi_lefteta,xyz1D_rightxi_lefteta, &
+ xyz1D_leftxi_righteta,xyz1D_rightxi_righteta, &
+ NGLOB1D_RADIAL_MAX)
! routine to create the MPI 1D chunk buffers for edges
@@ -35,33 +41,40 @@
include "constants.h"
- integer nspec,myrank,iregion
- integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
+ integer :: nspec,myrank
- logical iMPIcut_xi(2,nspec)
- logical iMPIcut_eta(2,nspec)
+ logical,dimension(2,nspec) :: iMPIcut_xi,iMPIcut_eta
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+ integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+ integer,dimension(nspec) :: idoubling
- integer idoubling(nspec)
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+ ! logical mask used to create arrays ibool1D
+ integer :: npointot
+ logical,dimension(npointot) :: mask_ibool
-! logical mask used to create arrays ibool1D
- integer npointot
- logical mask_ibool(npointot)
+ integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_CORNERS) :: NSPEC1D_RADIAL_CORNER,NGLOB1D_RADIAL_CORNER
+ integer :: iregion
-! global element numbering
- integer ispec
+ integer :: NGLOB1D_RADIAL_MAX
+ integer,dimension(NGLOB1D_RADIAL_MAX) :: ibool1D_leftxi_lefteta,ibool1D_rightxi_lefteta, &
+ ibool1D_leftxi_righteta,ibool1D_rightxi_righteta
+ double precision,dimension(NGLOB1D_RADIAL_MAX,NDIM) :: xyz1D_leftxi_lefteta,xyz1D_rightxi_lefteta, &
+ xyz1D_leftxi_righteta,xyz1D_rightxi_righteta
-! MPI 1D buffer element numbering
- integer ispeccount,npoin1D,ix,iy,iz
+ ! processor identification
+ character(len=150) :: prname
-! processor identification
- character(len=150) prname
+ ! local parameters
+ ! global element numbering
+ integer :: ispec
+ ! MPI 1D buffer element numbering
+ integer :: ispeccount,npoin1D,ix,iy,iz
+ ! debug file output
+ logical,parameter :: DEBUG = .false.
+
! write the MPI buffers for the left and right edges of the slice
! and the position of the points to check that the buffers are fine
@@ -71,25 +84,28 @@
! determine if the element falls on the left MPI cut plane
-! global point number and coordinates left MPI 1D buffer
- open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt',status='unknown')
+ if( DEBUG ) then
+ ! global point number and coordinates left MPI 1D buffer
+ open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_leftxi_lefteta.txt',status='unknown')
+ endif
-! erase the logical mask used to mark points already found
+ ! erase the logical mask used to mark points already found
mask_ibool(:) = .false.
-! nb of global points shared with the other slice
+ ! nb of global points shared with the other slice
npoin1D = 0
+ ibool1D_leftxi_lefteta(:) = 0
-! nb of elements in this 1D buffer
+ ! nb of elements in this 1D buffer
ispeccount=0
-
do ispec=1,nspec
! remove central cube for chunk buffers
if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
- ! corner detection here
+
+ ! corner detection here
if(iMPIcut_xi(1,ispec) .and. iMPIcut_eta(1,ispec)) then
ispeccount=ispeccount+1
! loop on all the points
@@ -98,39 +114,53 @@
do iz=1,NGLLZ
! select point, if not already selected
if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin1D = npoin1D + 1
+ ! adds this point
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin1D = npoin1D + 1
+
+ ! fills buffer array
+ ibool1D_leftxi_lefteta(npoin1D) = ibool(ix,iy,iz,ispec)
+ xyz1D_leftxi_lefteta(npoin1D,1) = xstore(ix,iy,iz,ispec)
+ xyz1D_leftxi_lefteta(npoin1D,2) = ystore(ix,iy,iz,ispec)
+ xyz1D_leftxi_lefteta(npoin1D,3) = zstore(ix,iy,iz,ispec)
+
+ ! debug file output
+ if( DEBUG ) then
write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
- ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
endif
enddo
endif
enddo
-! put flag to indicate end of the list of points
- write(10,*) '0 0 0. 0. 0.'
+ if( DEBUG ) then
+ ! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+ ! write total number of points
+ write(10,*) npoin1D
+ close(10)
+ endif
-! write total number of points
- write(10,*) npoin1D
-
- close(10)
-
-! compare number of edge elements detected to analytical value
+ ! compare number of edge elements detected to analytical value
if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,1) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,1)) &
call exit_MPI(myrank,'error MPI 1D buffer detection in xi=left')
! determine if the element falls on the right MPI cut plane
-! global point number and coordinates right MPI 1D buffer
- open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt',status='unknown')
+ if( DEBUG ) then
+ ! global point number and coordinates right MPI 1D buffer
+ open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_rightxi_lefteta.txt',status='unknown')
+ endif
-! erase the logical mask used to mark points already found
+ ! erase the logical mask used to mark points already found
mask_ibool(:) = .false.
-! nb of global points shared with the other slice
+ ! nb of global points shared with the other slice
npoin1D = 0
+ ibool1D_rightxi_lefteta(:) = 0
-! nb of elements in this 1D buffer
+ ! nb of elements in this 1D buffer
ispeccount=0
do ispec=1,nspec
! remove central cube for chunk buffers
@@ -138,7 +168,8 @@
idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
- ! corner detection here
+
+ ! corner detection here
if(iMPIcut_xi(2,ispec) .and. iMPIcut_eta(1,ispec)) then
ispeccount=ispeccount+1
! loop on all the points
@@ -147,24 +178,34 @@
do iz=1,NGLLZ
! select point, if not already selected
if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin1D = npoin1D + 1
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin1D = npoin1D + 1
+
+ ! fills buffer array
+ ibool1D_rightxi_lefteta(npoin1D) = ibool(ix,iy,iz,ispec)
+ xyz1D_rightxi_lefteta(npoin1D,1) = xstore(ix,iy,iz,ispec)
+ xyz1D_rightxi_lefteta(npoin1D,2) = ystore(ix,iy,iz,ispec)
+ xyz1D_rightxi_lefteta(npoin1D,3) = zstore(ix,iy,iz,ispec)
+
+ ! debug file output
+ if( DEBUG ) then
write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
- ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
endif
enddo
endif
enddo
-! put flag to indicate end of the list of points
- write(10,*) '0 0 0. 0. 0.'
+ if( DEBUG ) then
+ ! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+ ! write total number of points
+ write(10,*) npoin1D
+ close(10)
+ endif
-! write total number of points
- write(10,*) npoin1D
-
- close(10)
-
-! compare number of edge elements and points detected to analytical value
+ ! compare number of edge elements and points detected to analytical value
if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,2) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,2)) &
call exit_MPI(myrank,'error MPI 1D buffer detection in xi=right')
@@ -174,111 +215,132 @@
! determine if the element falls on the left MPI cut plane
-! global point number and coordinates left MPI 1D buffer
- open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt',status='unknown')
+ if( DEBUG ) then
+ ! global point number and coordinates left MPI 1D buffer
+ open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_leftxi_righteta.txt',status='unknown')
+ endif
-! erase the logical mask used to mark points already found
+ ! erase the logical mask used to mark points already found
mask_ibool(:) = .false.
-! nb of global points shared with the other slice
+ ! nb of global points shared with the other slice
npoin1D = 0
+ ibool1D_leftxi_righteta(:) = 0
-! nb of elements in this 1D buffer
+ ! nb of elements in this 1D buffer
ispeccount=0
-
do ispec=1,nspec
-! remove central cube for chunk buffers
- if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
+ ! remove central cube for chunk buffers
+ if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
-! corner detection here
- if(iMPIcut_xi(1,ispec) .and. iMPIcut_eta(2,ispec)) then
+ ! corner detection here
+ if(iMPIcut_xi(1,ispec) .and. iMPIcut_eta(2,ispec)) then
- ispeccount=ispeccount+1
+ ispeccount=ispeccount+1
-! loop on all the points
- ix = 1
- iy = NGLLY
- do iz=1,NGLLZ
-
+ ! loop on all the points
+ ix = 1
+ iy = NGLLY
+ do iz=1,NGLLZ
! select point, if not already selected
if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin1D = npoin1D + 1
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin1D = npoin1D + 1
+
+ ! fills buffer array
+ ibool1D_leftxi_righteta(npoin1D) = ibool(ix,iy,iz,ispec)
+ xyz1D_leftxi_righteta(npoin1D,1) = xstore(ix,iy,iz,ispec)
+ xyz1D_leftxi_righteta(npoin1D,2) = ystore(ix,iy,iz,ispec)
+ xyz1D_leftxi_righteta(npoin1D,3) = zstore(ix,iy,iz,ispec)
+
+ ! debug file output
+ if( DEBUG ) then
write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
- ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
endif
enddo
endif
enddo
-! put flag to indicate end of the list of points
- write(10,*) '0 0 0. 0. 0.'
+ if( DEBUG ) then
+ ! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+ ! write total number of points
+ write(10,*) npoin1D
+ close(10)
+ endif
-! write total number of points
- write(10,*) npoin1D
-
- close(10)
-
-! compare number of edge elements detected to analytical value
+ ! compare number of edge elements detected to analytical value
if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,4) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,4)) &
call exit_MPI(myrank,'error MPI 1D buffer detection in xi=left')
! determine if the element falls on the right MPI cut plane
-! global point number and coordinates right MPI 1D buffer
- open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt',status='unknown')
+ if( DEBUG ) then
+ ! global point number and coordinates right MPI 1D buffer
+ open(unit=10,file=prname(1:len_trim(prname))//'ibool1D_rightxi_righteta.txt',status='unknown')
+ endif
-! erase the logical mask used to mark points already found
+ ! erase the logical mask used to mark points already found
mask_ibool(:) = .false.
-! nb of global points shared with the other slice
+ ! nb of global points shared with the other slice
npoin1D = 0
+ ibool1D_rightxi_righteta(:) = 0
-! nb of elements in this 1D buffer
+ ! nb of elements in this 1D buffer
ispeccount=0
-
do ispec=1,nspec
+ ! remove central cube for chunk buffers
+ if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
+ idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
-! remove central cube for chunk buffers
- if(idoubling(ispec) == IFLAG_MIDDLE_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_BOTTOM_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_TOP_CENTRAL_CUBE .or. &
- idoubling(ispec) == IFLAG_IN_FICTITIOUS_CUBE) cycle
+ ! corner detection here
+ if(iMPIcut_xi(2,ispec) .and. iMPIcut_eta(2,ispec)) then
-! corner detection here
- if(iMPIcut_xi(2,ispec) .and. iMPIcut_eta(2,ispec)) then
+ ispeccount=ispeccount+1
- ispeccount=ispeccount+1
+ ! loop on all the points
+ ix = NGLLX
+ iy = NGLLY
+ do iz=1,NGLLZ
+ ! select point, if not already selected
+ if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin1D = npoin1D + 1
-! loop on all the points
- ix = NGLLX
- iy = NGLLY
- do iz=1,NGLLZ
+ ! fills buffer array
+ ibool1D_rightxi_righteta(npoin1D) = ibool(ix,iy,iz,ispec)
+ xyz1D_rightxi_righteta(npoin1D,1) = xstore(ix,iy,iz,ispec)
+ xyz1D_rightxi_righteta(npoin1D,2) = ystore(ix,iy,iz,ispec)
+ xyz1D_rightxi_righteta(npoin1D,3) = zstore(ix,iy,iz,ispec)
- ! select point, if not already selected
- if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin1D = npoin1D + 1
+ ! debug file output
+ if( DEBUG ) then
write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
- ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
endif
enddo
endif
enddo
-! put flag to indicate end of the list of points
- write(10,*) '0 0 0. 0. 0.'
+ if( DEBUG ) then
+ ! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+ ! write total number of points
+ write(10,*) npoin1D
+ close(10)
+ endif
-! write total number of points
- write(10,*) npoin1D
-
- close(10)
-
-! compare number of edge elements and points detected to analytical value
+ ! compare number of edge elements and points detected to analytical value
if(ispeccount /= NSPEC1D_RADIAL_CORNER(iregion,3) .or. npoin1D /= NGLOB1D_RADIAL_CORNER(iregion,3)) &
call exit_MPI(myrank,'error MPI 1D buffer detection in xi=right')
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_cutplanes_eta.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_cutplanes_eta.f90 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_cutplanes_eta.f90 2012-08-11 02:22:07 UTC (rev 20565)
@@ -26,8 +26,10 @@
!=====================================================================
subroutine get_MPI_cutplanes_eta(myrank,prname,nspec,iMPIcut_eta,ibool, &
- xstore,ystore,zstore,mask_ibool,npointot, &
- NSPEC2D_XI_FACE,iregion,npoin2D_eta)
+ xstore,ystore,zstore,mask_ibool,npointot, &
+ NSPEC2D_XI_FACE,iregion,npoin2D_eta, &
+ iboolleft_eta,iboolright_eta, &
+ npoin2D_eta_all,NGLOB2DMAX_YMIN_YMAX)
! this routine detects cut planes along eta
! In principle the left cut plane of the first slice
@@ -38,36 +40,46 @@
include "constants.h"
- integer nspec,myrank,iregion
+ integer :: nspec,myrank
+
+ logical,dimension(2,nspec) :: iMPIcut_eta
+
+ integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
+
+ ! logical mask used to create arrays iboolleft_eta and iboolright_eta
+ integer :: npointot
+ logical,dimension(npointot) :: mask_ibool
+
integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_XI_FACE
+ integer :: iregion
+ integer :: npoin2D_eta
- logical iMPIcut_eta(2,nspec)
+ integer :: NGLOB2DMAX_YMIN_YMAX
+ integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_eta_all
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+ ! processor identification
+ character(len=150) :: prname
-! logical mask used to create arrays iboolleft_eta and iboolright_eta
- integer npointot
- logical mask_ibool(npointot)
+ ! local parameters
+ ! global element numbering
+ integer :: ispec
-! global element numbering
- integer ispec
+ ! MPI cut-plane element numbering
+ integer :: ispecc1,ispecc2,ix,iy,iz
+ integer :: nspec2Dtheor
-! MPI cut-plane element numbering
- integer ispecc1,ispecc2,npoin2D_eta,ix,iy,iz
- integer nspec2Dtheor
+ ! debug: file output
+ logical,parameter :: DEBUG = .false.
-! processor identification
- character(len=150) prname
+ ! theoretical number of surface elements in the buffers
+ ! cut planes along eta=constant correspond to XI faces
+ nspec2Dtheor = NSPEC2D_XI_FACE(iregion,1)
-! theoretical number of surface elements in the buffers
-! cut planes along eta=constant correspond to XI faces
- nspec2Dtheor = NSPEC2D_XI_FACE(iregion,1)
-
! write the MPI buffers for the left and right edges of the slice
! and the position of the points to check that the buffers are fine
@@ -75,18 +87,22 @@
! determine if the element falls on the left MPI cut plane
!
-! global point number and coordinates left MPI cut-plane
- open(unit=10,file=prname(1:len_trim(prname))//'iboolleft_eta.txt',status='unknown')
+ if( DEBUG ) then
+ ! global point number and coordinates left MPI cut-plane
+ open(unit=10,file=prname(1:len_trim(prname))//'iboolleft_eta.txt', &
+ status='unknown')
+ endif
-! erase the logical mask used to mark points already found
+ ! erase the logical mask used to mark points already found
mask_ibool(:) = .false.
-! nb of global points shared with the other slice
+ ! nb of global points shared with the other slice
+ iboolleft_eta(:) = 0
npoin2D_eta = 0
+ npoin2D_eta_all(1) = 1
-! nb of elements in this cut-plane
+ ! nb of elements in this cut-plane
ispecc1=0
-
do ispec=1,nspec
if(iMPIcut_eta(1,ispec)) then
ispecc1=ispecc1+1
@@ -96,44 +112,63 @@
do iz=1,NGLLZ
! select point, if not already selected
if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin2D_eta = npoin2D_eta + 1
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_eta = npoin2D_eta + 1
+
+ ! fills buffer arrays
+ iboolleft_eta(npoin2D_eta) = ibool(ix,iy,iz,ispec)
+
+ npoin2D_eta_all(1) = npoin2D_eta_all(1) + 1
+
+ ! debug file output
+ if( DEBUG ) then
write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
- ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
endif
enddo
enddo
endif
enddo
-! put flag to indicate end of the list of points
- write(10,*) '0 0 0. 0. 0.'
+ if( DEBUG ) then
+ ! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+ ! write total number of points
+ write(10,*) npoin2D_eta
+ close(10)
+ endif
-! write total number of points
- write(10,*) npoin2D_eta
-
- close(10)
-
! compare number of surface elements detected to analytical value
if(ispecc1 /= nspec2Dtheor) call exit_MPI(myrank,'error MPI cut-planes detection in eta=left')
+ ! subtract the line that contains the flag after the last point
+ npoin2D_eta_all(1) = npoin2D_eta_all(1) - 1
+ if(npoin2D_eta_all(1) > NGLOB2DMAX_YMIN_YMAX .or. npoin2D_eta_all(1) /= npoin2D_eta) &
+ call exit_MPI(myrank,'incorrect iboolleft_eta read')
+
+
!
! determine if the element falls on the right MPI cut plane
!
- nspec2Dtheor = NSPEC2D_XI_FACE(iregion,2)
+ nspec2Dtheor = NSPEC2D_XI_FACE(iregion,2)
-! global point number and coordinates right MPI cut-plane
- open(unit=10,file=prname(1:len_trim(prname))//'iboolright_eta.txt',status='unknown')
+ if( DEBUG ) then
+ ! global point number and coordinates right MPI cut-plane
+ open(unit=10,file=prname(1:len_trim(prname))//'iboolright_eta.txt', &
+ status='unknown')
+ endif
-! erase the logical mask used to mark points already found
+ ! erase the logical mask used to mark points already found
mask_ibool(:) = .false.
-! nb of global points shared with the other slice
+ ! nb of global points shared with the other slice
+ iboolright_eta(:) = 0
npoin2D_eta = 0
+ npoin2D_eta_all(2) = 1
-! nb of elements in this cut-plane
+ ! nb of elements in this cut-plane
ispecc2=0
-
do ispec=1,nspec
if(iMPIcut_eta(2,ispec)) then
ispecc2=ispecc2+1
@@ -143,26 +178,41 @@
do iz=1,NGLLZ
! select point, if not already selected
if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin2D_eta = npoin2D_eta + 1
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_eta = npoin2D_eta + 1
+
+ ! fills buffer arrays
+ iboolright_eta(npoin2D_eta) = ibool(ix,iy,iz,ispec)
+
+ npoin2D_eta_all(2) = npoin2D_eta_all(2) + 1
+
+ ! debug file output
+ if( DEBUG ) then
write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
- ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
endif
enddo
enddo
endif
enddo
-! put flag to indicate end of the list of points
- write(10,*) '0 0 0. 0. 0.'
+ if( DEBUG ) then
+ ! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+ ! write total number of points
+ write(10,*) npoin2D_eta
+ close(10)
+ endif
-! write total number of points
- write(10,*) npoin2D_eta
+ ! compare number of surface elements detected to analytical value
+ if(ispecc2 /= nspec2Dtheor) call exit_MPI(myrank,'error MPI cut-planes detection in eta=right')
- close(10)
+ ! subtract the line that contains the flag after the last point
+ npoin2D_eta_all(2) = npoin2D_eta_all(2) - 1
+ if(npoin2D_eta_all(2) > NGLOB2DMAX_YMIN_YMAX .or. npoin2D_eta_all(2) /= npoin2D_eta) &
+ call exit_MPI(myrank,'incorrect iboolright_eta read')
-! compare number of surface elements detected to analytical value
- if(ispecc2 /= nspec2Dtheor) call exit_MPI(myrank,'error MPI cut-planes detection in eta=right')
end subroutine get_MPI_cutplanes_eta
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_cutplanes_xi.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_cutplanes_xi.f90 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_MPI_cutplanes_xi.f90 2012-08-11 02:22:07 UTC (rev 20565)
@@ -26,8 +26,10 @@
!=====================================================================
subroutine get_MPI_cutplanes_xi(myrank,prname,nspec,iMPIcut_xi,ibool, &
- xstore,ystore,zstore,mask_ibool,npointot, &
- NSPEC2D_ETA_FACE,iregion,npoin2D_xi)
+ xstore,ystore,zstore,mask_ibool,npointot, &
+ NSPEC2D_ETA_FACE,iregion,npoin2D_xi, &
+ iboolleft_xi,iboolright_xi, &
+ npoin2D_xi_all,NGLOB2DMAX_XMIN_XMAX)
! this routine detects cut planes along xi
! In principle the left cut plane of the first slice
@@ -38,35 +40,48 @@
include "constants.h"
- integer nspec,myrank,iregion
+ integer :: nspec,myrank
+
+ logical,dimension(2,nspec) :: iMPIcut_xi
+
+ integer,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: ibool
+
+ double precision,dimension(NGLLX,NGLLY,NGLLZ,nspec) :: xstore,ystore,zstore
+
+ ! logical mask used to create arrays iboolleft_xi and iboolright_xi
+ integer :: npointot
+ logical,dimension(npointot) :: mask_ibool
+
integer, dimension(MAX_NUM_REGIONS,NB_SQUARE_EDGES_ONEDIR) :: NSPEC2D_ETA_FACE
- logical iMPIcut_xi(2,nspec)
+ integer :: iregion
+ integer :: npoin2D_xi
- integer ibool(NGLLX,NGLLY,NGLLZ,nspec)
+ integer :: NGLOB2DMAX_XMIN_XMAX
+ integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
- double precision xstore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision ystore(NGLLX,NGLLY,NGLLZ,nspec)
- double precision zstore(NGLLX,NGLLY,NGLLZ,nspec)
+ integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi_all
-! logical mask used to create arrays iboolleft_xi and iboolright_xi
- integer npointot
- logical mask_ibool(npointot)
+ ! processor identification
+ character(len=150) :: prname
-! global element numbering
- integer ispec
+ ! local parameters
+ ! global element numbering
+ integer :: ispec
+ ! MPI cut-plane element numbering
+ integer :: ispecc1,ispecc2,ix,iy,iz
+ integer :: nspec2Dtheor
+ integer :: ier
-! MPI cut-plane element numbering
- integer ispecc1,ispecc2,npoin2D_xi,ix,iy,iz
- integer nspec2Dtheor
- integer ier
+ character(len=150) :: errmsg
-! processor identification
- character(len=150) prname,errmsg
+ ! debug: file output
+ logical,parameter :: DEBUG = .false.
-! theoretical number of surface elements in the buffers
-! cut planes along xi=constant correspond to ETA faces
- nspec2Dtheor = NSPEC2D_ETA_FACE(iregion,1)
+ ! theoretical number of surface elements in the buffers
+ ! cut planes along xi=constant correspond to ETA faces
+ nspec2Dtheor = NSPEC2D_ETA_FACE(iregion,1)
+
! write the MPI buffers for the left and right edges of the slice
! and the position of the points to check that the buffers are fine
@@ -74,29 +89,34 @@
! determine if the element falls on the left MPI cut plane
!
-! global point number and coordinates left MPI cut-plane
- open(unit=10,file=prname(1:len_trim(prname))//'iboolleft_xi.txt', &
- status='unknown',iostat=ier)
- if( ier /= 0 ) then
- if( myrank == 0 ) then
- write(IMAIN,*)
- write(IMAIN,*) 'error creating file: '
- write(IMAIN,*) prname(1:len_trim(prname))//'iboolleft_xi.txt'
- write(IMAIN,*)
- write(IMAIN,*) 'please make sure that the directory specified in Par_file as LOCAL_PATH exists'
- write(IMAIN,*)
+ if( DEBUG ) then
+ ! global point number and coordinates left MPI cut-plane
+ open(unit=10,file=prname(1:len_trim(prname))//'iboolleft_xi.txt', &
+ status='unknown',iostat=ier)
+
+ if( ier /= 0 ) then
+ if( myrank == 0 ) then
+ write(IMAIN,*)
+ write(IMAIN,*) 'error creating file: '
+ write(IMAIN,*) prname(1:len_trim(prname))//'iboolleft_xi.txt'
+ write(IMAIN,*)
+ write(IMAIN,*) 'please make sure that the directory specified in Par_file as LOCAL_PATH exists'
+ write(IMAIN,*)
+ endif
+ call exit_mpi(myrank,'error creating iboolleft_xi.txt, please check your Par_file LOCAL_PATH setting')
endif
- call exit_mpi(myrank,'error creating iboolleft_xi.txt, please check your Par_file LOCAL_PATH setting')
endif
-! erase the logical mask used to mark points already found
+
+ ! erase the logical mask used to mark points already found
mask_ibool(:) = .false.
-! nb of global points shared with the other slice
+ ! nb of global points shared with the other slice
+ iboolleft_xi(:) = 0
npoin2D_xi = 0
+ npoin2D_xi_all(1) = 1
-! nb of elements in this cut-plane
+ ! nb of elements in this cut-plane
ispecc1=0
-
do ispec=1,nspec
if(iMPIcut_xi(1,ispec)) then
ispecc1=ispecc1+1
@@ -106,48 +126,67 @@
do iz=1,NGLLZ
! select point, if not already selected
if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin2D_xi = npoin2D_xi + 1
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_xi = npoin2D_xi + 1
+
+ ! fills buffer arrays
+ iboolleft_xi(npoin2D_xi) = ibool(ix,iy,iz,ispec)
+
+ npoin2D_xi_all(1) = npoin2D_xi_all(1) + 1
+
+ ! debug file output
+ if( DEBUG ) then
write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
- ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
endif
enddo
enddo
endif
enddo
-! put flag to indicate end of the list of points
- write(10,*) '0 0 0. 0. 0.'
+ if( DEBUG ) then
+ ! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+ ! write total number of points
+ write(10,*) npoin2D_xi
+ close(10)
+ endif
-! write total number of points
- write(10,*) npoin2D_xi
-
- close(10)
-
-! compare number of surface elements detected to analytical value
+ ! compare number of surface elements detected to analytical value
if(ispecc1 /= nspec2Dtheor) then
write(errmsg,*) 'error MPI cut-planes detection in xi=left T=',nspec2Dtheor,' C=',ispecc1
call exit_MPI(myrank,errmsg)
endif
+
+ ! subtract the line that contains the flag after the last point
+ npoin2D_xi_all(1) = npoin2D_xi_all(1) - 1
+ if(npoin2D_xi_all(1) > NGLOB2DMAX_XMIN_XMAX .or. npoin2D_xi_all(1) /= npoin2D_xi) &
+ call exit_MPI(myrank,'incorrect iboolleft_xi read')
+
+
!
! determine if the element falls on the right MPI cut plane
!
- nspec2Dtheor = NSPEC2D_ETA_FACE(iregion,2)
+ nspec2Dtheor = NSPEC2D_ETA_FACE(iregion,2)
-! global point number and coordinates right MPI cut-plane
- open(unit=10,file=prname(1:len_trim(prname))//'iboolright_xi.txt', &
- status='unknown',iostat=ier)
- if( ier /= 0 ) call exit_mpi(myrank,'error creating iboolright_xi.txt for this process')
+ if( DEBUG ) then
+ ! global point number and coordinates right MPI cut-plane
+ open(unit=10,file=prname(1:len_trim(prname))//'iboolright_xi.txt', &
+ status='unknown',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error creating iboolright_xi.txt for this process')
+ endif
-! erase the logical mask used to mark points already found
+ ! erase the logical mask used to mark points already found
mask_ibool(:) = .false.
-! nb of global points shared with the other slice
+ ! nb of global points shared with the other slice
+ iboolright_xi(:) = 0
npoin2D_xi = 0
+ npoin2D_xi_all(2) = 1
-! nb of elements in this cut-plane
+ ! nb of elements in this cut-plane
ispecc2=0
-
do ispec=1,nspec
if(iMPIcut_xi(2,ispec)) then
ispecc2=ispecc2+1
@@ -157,29 +196,43 @@
do iz=1,NGLLZ
! select point, if not already selected
if(.not. mask_ibool(ibool(ix,iy,iz,ispec))) then
- mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
- npoin2D_xi = npoin2D_xi + 1
+ mask_ibool(ibool(ix,iy,iz,ispec)) = .true.
+ npoin2D_xi = npoin2D_xi + 1
+
+ ! fills buffer arrays
+ iboolright_xi(npoin2D_xi) = ibool(ix,iy,iz,ispec)
+
+ npoin2D_xi_all(2) = npoin2D_xi_all(2) + 1
+
+ ! debug file output
+ if( DEBUG ) then
write(10,*) ibool(ix,iy,iz,ispec), xstore(ix,iy,iz,ispec), &
- ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ ystore(ix,iy,iz,ispec),zstore(ix,iy,iz,ispec)
+ endif
endif
enddo
enddo
endif
enddo
-! put flag to indicate end of the list of points
- write(10,*) '0 0 0. 0. 0.'
+ if( DEBUG ) then
+ ! put flag to indicate end of the list of points
+ write(10,*) '0 0 0. 0. 0.'
+ ! write total number of points
+ write(10,*) npoin2D_xi
+ close(10)
+ endif
-! write total number of points
- write(10,*) npoin2D_xi
-
- close(10)
-
-! compare number of surface elements detected to analytical value
+ ! compare number of surface elements detected to analytical value
if(ispecc2 /= nspec2Dtheor) then
write(errmsg,*) 'error MPI cut-planes detection in xi=right T=',nspec2Dtheor,' C=',ispecc2
call exit_MPI(myrank,errmsg)
endif
+ ! subtract the line that contains the flag after the last point
+ npoin2D_xi_all(2) = npoin2D_xi_all(2) - 1
+ if(npoin2D_xi_all(2) > NGLOB2DMAX_XMIN_XMAX .or. npoin2D_xi_all(2) /= npoin2D_xi) &
+ call exit_MPI(myrank,'incorrect iboolright_xi read')
+
end subroutine get_MPI_cutplanes_xi
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_absorb.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_absorb.f90 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/get_absorb.f90 2012-08-11 02:22:07 UTC (rev 20565)
@@ -26,8 +26,8 @@
!=====================================================================
subroutine get_absorb(myrank,prname,iboun,nspec, &
- nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
- NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM)
+ nimin,nimax,njmin,njmax,nkmin_xi,nkmin_eta, &
+ NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM)
! Stacey, define flags for absorbing boundaries
@@ -35,26 +35,29 @@
include "constants.h"
- integer nspec,myrank
+ integer :: nspec,myrank
- integer NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM
+ integer :: NSPEC2DMAX_XMIN_XMAX,NSPEC2DMAX_YMIN_YMAX,NSPEC2D_BOTTOM
- integer nimin(2,NSPEC2DMAX_YMIN_YMAX),nimax(2,NSPEC2DMAX_YMIN_YMAX)
- integer njmin(2,NSPEC2DMAX_XMIN_XMAX),njmax(2,NSPEC2DMAX_XMIN_XMAX)
- integer nkmin_xi(2,NSPEC2DMAX_XMIN_XMAX),nkmin_eta(2,NSPEC2DMAX_YMIN_YMAX)
+ integer,dimension(2,NSPEC2DMAX_YMIN_YMAX) :: nimin,nimax
+ integer,dimension(2,NSPEC2DMAX_XMIN_XMAX) :: njmin,njmax
+ integer,dimension(2,NSPEC2DMAX_XMIN_XMAX) :: nkmin_xi
+ integer,dimension(2,NSPEC2DMAX_YMIN_YMAX) :: nkmin_eta
- logical iboun(6,nspec)
+ logical :: iboun(6,nspec)
-! global element numbering
- integer ispecg
+ ! global element numbering
+ integer :: ispecg
-! counters to keep track of the number of elements on each of the
-! five absorbing boundaries
- integer ispecb1,ispecb2,ispecb3,ispecb4,ispecb5
+ ! counters to keep track of the number of elements on each of the
+ ! five absorbing boundaries
+ integer :: ispecb1,ispecb2,ispecb3,ispecb4,ispecb5
+ integer :: ier
-! processor identification
- character(len=150) prname
+ ! processor identification
+ character(len=150) :: prname
+ ! initializes
ispecb1=0
ispecb2=0
ispecb3=0
@@ -63,82 +66,85 @@
do ispecg=1,nspec
-! determine if the element falls on an absorbing boundary
+ ! determine if the element falls on an absorbing boundary
- if(iboun(1,ispecg)) then
+ if(iboun(1,ispecg)) then
-! on boundary 1: xmin
- ispecb1=ispecb1+1
+ ! on boundary 1: xmin
+ ispecb1=ispecb1+1
-! this is useful even if it is constant because it can be zero inside the slices
- njmin(1,ispecb1)=1
- njmax(1,ispecb1)=NGLLY
+ ! this is useful even if it is constant because it can be zero inside the slices
+ njmin(1,ispecb1)=1
+ njmax(1,ispecb1)=NGLLY
-! check for ovelap with other boundaries
- nkmin_xi(1,ispecb1)=1
- if(iboun(5,ispecg)) nkmin_xi(1,ispecb1)=2
- endif
+ ! check for ovelap with other boundaries
+ nkmin_xi(1,ispecb1)=1
+ if(iboun(5,ispecg)) nkmin_xi(1,ispecb1)=2
+ endif
- if(iboun(2,ispecg)) then
+ if(iboun(2,ispecg)) then
-! on boundary 2: xmax
- ispecb2=ispecb2+1
+ ! on boundary 2: xmax
+ ispecb2=ispecb2+1
-! this is useful even if it is constant because it can be zero inside the slices
- njmin(2,ispecb2)=1
- njmax(2,ispecb2)=NGLLY
+ ! this is useful even if it is constant because it can be zero inside the slices
+ njmin(2,ispecb2)=1
+ njmax(2,ispecb2)=NGLLY
-! check for ovelap with other boundaries
- nkmin_xi(2,ispecb2)=1
- if(iboun(5,ispecg)) nkmin_xi(2,ispecb2)=2
- endif
+ ! check for ovelap with other boundaries
+ nkmin_xi(2,ispecb2)=1
+ if(iboun(5,ispecg)) nkmin_xi(2,ispecb2)=2
+ endif
- if(iboun(3,ispecg)) then
+ if(iboun(3,ispecg)) then
-! on boundary 3: ymin
- ispecb3=ispecb3+1
+ ! on boundary 3: ymin
+ ispecb3=ispecb3+1
-! check for ovelap with other boundaries
- nimin(1,ispecb3)=1
- if(iboun(1,ispecg)) nimin(1,ispecb3)=2
- nimax(1,ispecb3)=NGLLX
- if(iboun(2,ispecg)) nimax(1,ispecb3)=NGLLX-1
- nkmin_eta(1,ispecb3)=1
- if(iboun(5,ispecg)) nkmin_eta(1,ispecb3)=2
- endif
+ ! check for ovelap with other boundaries
+ nimin(1,ispecb3)=1
+ if(iboun(1,ispecg)) nimin(1,ispecb3)=2
+ nimax(1,ispecb3)=NGLLX
+ if(iboun(2,ispecg)) nimax(1,ispecb3)=NGLLX-1
+ nkmin_eta(1,ispecb3)=1
+ if(iboun(5,ispecg)) nkmin_eta(1,ispecb3)=2
+ endif
- if(iboun(4,ispecg)) then
+ if(iboun(4,ispecg)) then
-! on boundary 4: ymax
- ispecb4=ispecb4+1
+ ! on boundary 4: ymax
+ ispecb4=ispecb4+1
-! check for ovelap with other boundaries
- nimin(2,ispecb4)=1
- if(iboun(1,ispecg)) nimin(2,ispecb4)=2
- nimax(2,ispecb4)=NGLLX
- if(iboun(2,ispecg)) nimax(2,ispecb4)=NGLLX-1
- nkmin_eta(2,ispecb4)=1
- if(iboun(5,ispecg)) nkmin_eta(2,ispecb4)=2
- endif
+ ! check for ovelap with other boundaries
+ nimin(2,ispecb4)=1
+ if(iboun(1,ispecg)) nimin(2,ispecb4)=2
+ nimax(2,ispecb4)=NGLLX
+ if(iboun(2,ispecg)) nimax(2,ispecb4)=NGLLX-1
+ nkmin_eta(2,ispecb4)=1
+ if(iboun(5,ispecg)) nkmin_eta(2,ispecb4)=2
+ endif
-! on boundary 5: bottom
- if(iboun(5,ispecg)) ispecb5=ispecb5+1
+ ! on boundary 5: bottom
+ if(iboun(5,ispecg)) ispecb5=ispecb5+1
enddo
-! check theoretical value of elements at the bottom
+ ! check theoretical value of elements at the bottom
if(ispecb5 /= NSPEC2D_BOTTOM) &
call exit_MPI(myrank,'ispecb5 should equal NSPEC2D_BOTTOM in absorbing boundary detection')
-! save these temporary arrays for the solver for Stacey conditions
+ ! save these temporary arrays for the solver for Stacey conditions
open(unit=27,file=prname(1:len_trim(prname))//'stacey.bin', &
- status='unknown',form='unformatted',action='write')
+ status='unknown',form='unformatted',action='write',iostat=ier)
+ if( ier /= 0 ) call exit_MPI(myrank,'error opening stacey.bin file')
+
write(27) nimin
write(27) nimax
write(27) njmin
write(27) njmax
write(27) nkmin_xi
write(27) nkmin_eta
+
close(27)
end subroutine get_absorb
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/meshfem3D_par.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/meshfem3D_par.f90 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/meshfem3D_par.f90 2012-08-11 02:22:07 UTC (rev 20565)
@@ -267,36 +267,35 @@
implicit none
! correct number of spectral elements in each block depending on chunk type
- integer npointot
+ integer :: npointot
! proc numbers for MPI
- integer myrank,sizeprocs
+ integer :: myrank,sizeprocs
! check area and volume of the final mesh
- double precision volume_total
+ double precision :: volume_total
! for loop on all the slices
- integer iregion_code
- integer iproc_xi,iproc_eta,ichunk
+ 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
- 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
+ integer :: numelem_crust_mantle,numelem_outer_core,numelem_inner_core
+ integer :: numelem_total
! timer MPI
- double precision time_start,tCPU
+ 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, &
+ 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, &
@@ -306,24 +305,25 @@
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, &
+ 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, &
+ logical :: MOVIE_SURFACE,MOVIE_VOLUME,MOVIE_COARSE, &
RECEIVERS_CAN_BE_BURIED,PRINT_SOURCE_TIME_FUNCTION, &
SAVE_MESH_FILES,ABSORBING_CONDITIONS,INCLUDE_CENTRAL_CUBE,INFLATE_CENTRAL_CUBE,SAVE_FORWARD, &
OUTPUT_SEISMOS_ASCII_TEXT,OUTPUT_SEISMOS_SAC_ALPHANUM,OUTPUT_SEISMOS_SAC_BINARY, &
ROTATE_SEISMOGRAMS_RT,WRITE_SEISMOGRAMS_BY_MASTER,&
SAVE_ALL_SEISMOS_IN_ONE_FILE,USE_BINARY_FOR_LARGE_FILE
- character(len=150) :: OUTPUT_FILES,LOCAL_PATH,LOCAL_TMP_PATH,MODEL
+ 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
+ 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, &
@@ -369,6 +369,16 @@
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
+
end module meshfem3D_par
!
@@ -444,6 +454,9 @@
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
@@ -464,9 +477,6 @@
real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: rho_vp,rho_vs
- ! number of elements on the boundaries
- integer nspec2D_xmin,nspec2D_xmax,nspec2D_ymin,nspec2D_ymax
-
! attenuation
double precision, dimension(:,:,:,:), allocatable :: Qmu_store
double precision, dimension(:,:,:,:,:), allocatable :: tau_e_store
@@ -475,7 +485,7 @@
logical :: USE_ONE_LAYER_SB
- integer NUMBER_OF_MESH_LAYERS,layer_shift,cpt, &
+ integer :: NUMBER_OF_MESH_LAYERS,layer_shift,cpt, &
first_layer_aniso,last_layer_aniso,FIRST_ELT_NON_ANISO
double precision, dimension(:,:), allocatable :: stretch_tab
@@ -483,14 +493,14 @@
integer :: nb_layer_above_aniso,FIRST_ELT_ABOVE_ANISO
! Boundary Mesh
- integer NSPEC2D_MOHO,NSPEC2D_400,NSPEC2D_670,nex_eta_moho
+ 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, &
+ 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
+ double precision :: r_moho,r_400,r_670
! flags for transverse isotropic elements
logical, dimension(:), allocatable :: ispec_is_tiso
@@ -508,13 +518,13 @@
use constants,only: &
CUSTOM_REAL,NDIM,IMAIN, &
- IREGION_CRUST_MANTLE,IREGION_OUTER_CORE,IREGION_INNER_CORE
+ 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
- integer :: NGLOB2DMAX_XY
! number of faces between chunks
integer :: NUMMSGS_FACES
@@ -535,6 +545,28 @@
! 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
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/moho_stretching.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/moho_stretching.f90 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/moho_stretching.f90 2012-08-11 02:22:07 UTC (rev 20565)
@@ -228,11 +228,8 @@
PI_OVER_TWO,RADIANS_TO_DEGREES,TINYVAL,SMALLVAL,ONE,HONOR_DEEP_MOHO
use meshfem3D_par,only: &
- RMOHO_FICTITIOUS_IN_MESHER,R220,RMIDDLE_CRUST
+ R220
- use meshfem3D_models_par,only: &
- TOPOGRAPHY
-
implicit none
integer :: myrank
Deleted: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/read_arrays_buffers_mesher.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/read_arrays_buffers_mesher.f90 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/read_arrays_buffers_mesher.f90 2012-08-11 02:22:07 UTC (rev 20565)
@@ -1,337 +0,0 @@
-!=====================================================================
-!
-! S p e c f e m 3 D G l o b e V e r s i o n 5 . 1
-! --------------------------------------------------
-!
-! Main authors: Dimitri Komatitsch and Jeroen Tromp
-! Princeton University, USA
-! and University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
- subroutine read_arrays_buffers_mesher(iregion_code,myrank, &
- iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta, &
- npoin2D_xi,npoin2D_eta, &
- iprocfrom_faces,iprocto_faces,imsg_type, &
- iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
- iboolfaces,npoin2D_faces,iboolcorner, &
- NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NGLOB1D_RADIAL, &
- NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT,NPROC_XI,NPROC_ETA,LOCAL_PATH,NCHUNKS)
-
- implicit none
-
-! standard include of the MPI library
- include 'mpif.h'
-
- include "constants.h"
-
- integer iregion_code,myrank,NCHUNKS,ier
-
- integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi,npoin2D_eta
- integer NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NGLOB1D_RADIAL
- integer NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT,NPROC_XI,NPROC_ETA
-
- integer npoin2D_faces(NUMFACES_SHARED)
-
- character(len=150) LOCAL_PATH
-
- integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces
- integer, dimension(NGLOB1D_RADIAL,NUMCORNERS_SHARED) :: iboolcorner
- integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
- integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
-
- integer, dimension(NUMMSGS_FACES) :: iprocfrom_faces,iprocto_faces,imsg_type
-
-! allocate array for messages for corners
- integer, dimension(NCORNERSCHUNKS) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
-
- integer npoin2D_xi_mesher,npoin2D_eta_mesher
- integer npoin1D_corner
-
- integer imsg,icount_faces,icount_corners
- integer ipoin1D,ipoin2D
-
- double precision xdummy,ydummy,zdummy
-
-! processor identification
- character(len=150) OUTPUT_FILES,prname,filename
-
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-! get the base pathname for output files
- call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-
-! create the name for the database of the current slide and region
- call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
-
-! read 2-D addressing for summation between slices along xi with MPI
-
-! read iboolleft_xi of this slice
- open(unit=IIN,file=prname(1:len_trim(prname))//'iboolleft_xi.txt', &
- status='old',action='read',iostat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error opening iboolleft_xi file')
-
- npoin2D_xi(1) = 1
- 350 continue
- read(IIN,*) iboolleft_xi(npoin2D_xi(1)),xdummy,ydummy,zdummy
- if(iboolleft_xi(npoin2D_xi(1)) > 0) then
- npoin2D_xi(1) = npoin2D_xi(1) + 1
- goto 350
- endif
-! subtract the line that contains the flag after the last point
- npoin2D_xi(1) = npoin2D_xi(1) - 1
-! read nb of points given by the mesher
- read(IIN,*) npoin2D_xi_mesher
- if(npoin2D_xi(1) > NGLOB2DMAX_XMIN_XMAX .or. npoin2D_xi(1) /= npoin2D_xi_mesher) &
- call exit_MPI(myrank,'incorrect iboolleft_xi read')
- close(IIN)
-
-! read iboolright_xi of this slice
- open(unit=IIN,file=prname(1:len_trim(prname))//'iboolright_xi.txt', &
- status='old',action='read',iostat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error opening iboolright_xi file')
-
- npoin2D_xi(2) = 1
- 360 continue
- read(IIN,*) iboolright_xi(npoin2D_xi(2)),xdummy,ydummy,zdummy
- if(iboolright_xi(npoin2D_xi(2)) > 0) then
- npoin2D_xi(2) = npoin2D_xi(2) + 1
- goto 360
- endif
-! subtract the line that contains the flag after the last point
- npoin2D_xi(2) = npoin2D_xi(2) - 1
-! read nb of points given by the mesher
- read(IIN,*) npoin2D_xi_mesher
- if(npoin2D_xi(2) > NGLOB2DMAX_XMIN_XMAX .or. npoin2D_xi(2) /= npoin2D_xi_mesher) &
- call exit_MPI(myrank,'incorrect iboolright_xi read')
- close(IIN)
-
- if(myrank == 0) then
- write(IMAIN,*) ' #max of points in MPI buffers along xi npoin2D_xi = ', &
- maxval(npoin2D_xi(:))
- write(IMAIN,*) ' #max of array elements transferred npoin2D_xi*NDIM = ', &
- maxval(npoin2D_xi(:))*NDIM
- write(IMAIN,*)
- endif
-
-! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-! read 2-D addressing for summation between slices along eta with MPI
-
-! read iboolleft_eta of this slice
- open(unit=IIN,file=prname(1:len_trim(prname))//'iboolleft_eta.txt', &
- status='old',action='read',iostat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error opening iboolleft_eta file')
-
- npoin2D_eta(1) = 1
- 370 continue
- read(IIN,*) iboolleft_eta(npoin2D_eta(1)),xdummy,ydummy,zdummy
- if(iboolleft_eta(npoin2D_eta(1)) > 0) then
- npoin2D_eta(1) = npoin2D_eta(1) + 1
- goto 370
- endif
-! subtract the line that contains the flag after the last point
- npoin2D_eta(1) = npoin2D_eta(1) - 1
-! read nb of points given by the mesher
- read(IIN,*) npoin2D_eta_mesher
- if(npoin2D_eta(1) > NGLOB2DMAX_YMIN_YMAX .or. npoin2D_eta(1) /= npoin2D_eta_mesher) &
- call exit_MPI(myrank,'incorrect iboolleft_eta read')
- close(IIN)
-
-! read iboolright_eta of this slice
- open(unit=IIN,file=prname(1:len_trim(prname))//'iboolright_eta.txt', &
- status='old',action='read',iostat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error opening iboolright_eta file')
-
- npoin2D_eta(2) = 1
- 380 continue
- read(IIN,*) iboolright_eta(npoin2D_eta(2)),xdummy,ydummy,zdummy
- if(iboolright_eta(npoin2D_eta(2)) > 0) then
- npoin2D_eta(2) = npoin2D_eta(2) + 1
- goto 380
- endif
-! subtract the line that contains the flag after the last point
- npoin2D_eta(2) = npoin2D_eta(2) - 1
-! read nb of points given by the mesher
- read(IIN,*) npoin2D_eta_mesher
- if(npoin2D_eta(2) > NGLOB2DMAX_YMIN_YMAX .or. npoin2D_eta(2) /= npoin2D_eta_mesher) &
- call exit_MPI(myrank,'incorrect iboolright_eta read')
- close(IIN)
-
- if(myrank == 0) then
- write(IMAIN,*) ' #max of points in MPI buffers along eta npoin2D_eta = ', &
- maxval(npoin2D_eta(:))
- write(IMAIN,*) ' #max of array elements transferred npoin2D_eta*NDIM = ', &
- maxval(npoin2D_eta(:))*NDIM
- write(IMAIN,*)
- endif
-
-
-!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-
-! read chunk messages only if more than one chunk
- if(NCHUNKS /= 1) then
-
-! read messages to assemble between chunks with MPI
-
- if(myrank == 0) then
-
- ! file with the list of processors for each message for faces
- open(unit=IIN,file=trim(OUTPUT_FILES)//'/list_messages_faces.txt', &
- status='old',action='read',iostat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error opening list_messages_faces file')
-
- do imsg = 1,NUMMSGS_FACES
- read(IIN,*) imsg_type(imsg),iprocfrom_faces(imsg),iprocto_faces(imsg)
- if (iprocfrom_faces(imsg) < 0 &
- .or. iprocto_faces(imsg) < 0 &
- .or. iprocfrom_faces(imsg) > NPROCTOT-1 &
- .or. iprocto_faces(imsg) > NPROCTOT-1) &
- call exit_MPI(myrank,'incorrect chunk faces numbering')
- if (imsg_type(imsg) < 1 .or. imsg_type(imsg) > 3) &
- call exit_MPI(myrank,'incorrect message type labeling')
- enddo
- close(IIN)
-
- ! file with the list of processors for each message for corners
- open(unit=IIN,file=trim(OUTPUT_FILES)//'/list_messages_corners.txt', &
- status='old',action='read',iostat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error opening list_messages_corners file')
-
- do imsg = 1,NCORNERSCHUNKS
- read(IIN,*) iproc_master_corners(imsg),iproc_worker1_corners(imsg), &
- iproc_worker2_corners(imsg)
- if (iproc_master_corners(imsg) < 0 &
- .or. iproc_worker1_corners(imsg) < 0 &
- .or. iproc_worker2_corners(imsg) < 0 &
- .or. iproc_master_corners(imsg) > NPROCTOT-1 &
- .or. iproc_worker1_corners(imsg) > NPROCTOT-1 &
- .or. iproc_worker2_corners(imsg) > NPROCTOT-1) &
- call exit_MPI(myrank,'incorrect chunk corner numbering')
- enddo
- close(IIN)
-
- endif
-
-! broadcast the information read on the master to the nodes
- call MPI_BCAST(imsg_type,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(iprocfrom_faces,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(iprocto_faces,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-
- call MPI_BCAST(iproc_master_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(iproc_worker1_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- call MPI_BCAST(iproc_worker2_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error mpi broadcast')
-
-
-!---- read 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
-
- ! read file with 2D buffer for faces
- if(myrank == iprocfrom_faces(imsg)) then
- write(filename,"('buffer_faces_chunks_sender_msg',i6.6,'.txt')") imsg
- else if(myrank == iprocto_faces(imsg)) then
- write(filename,"('buffer_faces_chunks_receiver_msg',i6.6,'.txt')") imsg
- endif
-
- open(unit=IIN,file=prname(1:len_trim(prname))//filename,status='old',action='read',iostat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error opening buffer_faces file')
-
- read(IIN,*) npoin2D_faces(icount_faces)
- if(npoin2D_faces(icount_faces) > NGLOB2DMAX_XY) then
- print*,'error ',myrank,' npoin2D_faces: ',npoin2D_faces(icount_faces),icount_faces
- print*,'iregion_code:',iregion_code
- call exit_MPI(myrank,'incorrect nb of points in face buffer')
- endif
-
- do ipoin2D = 1,npoin2D_faces(icount_faces)
- read(IIN,*) iboolfaces(ipoin2D,icount_faces),xdummy,ydummy,zdummy
- enddo
- close(IIN)
-
- endif
- enddo
-
-
-!---- read indirect addressing for each message for corners of the chunks
-!---- a given slice can belong to at most one corner
- icount_corners = 0
- do imsg = 1,NCORNERSCHUNKS
- ! if only two chunks then there is no second worker
- if(myrank == iproc_master_corners(imsg) .or. &
- myrank == iproc_worker1_corners(imsg) .or. &
- (NCHUNKS /= 2 .and. myrank == iproc_worker2_corners(imsg))) then
-
- icount_corners = icount_corners + 1
- if(icount_corners>1 .and. (NPROC_XI > 1 .or. NPROC_ETA > 1)) then
- print*,'error ',myrank,'icount_corners:',icount_corners
- print*,'iregion_code:',iregion_code
- call exit_MPI(myrank,'more than one corner for this slice')
- endif
- if(icount_corners>4) call exit_MPI(myrank,'more than four corners for this slice')
-
- ! read file with 1D buffer for corner
- if(myrank == iproc_master_corners(imsg)) then
- write(filename,"('buffer_corners_chunks_master_msg',i6.6,'.txt')") imsg
- else if(myrank == iproc_worker1_corners(imsg)) then
- write(filename,"('buffer_corners_chunks_worker1_msg',i6.6,'.txt')") imsg
- else if( NCHUNKS /= 2 .and. myrank == iproc_worker2_corners(imsg)) then
- write(filename,"('buffer_corners_chunks_worker2_msg',i6.6,'.txt')") imsg
- endif
-
- ! matching codes
- open(unit=IIN,file=prname(1:len_trim(prname))//filename, &
- status='old',action='read',iostat=ier)
- if( ier /= 0 ) call exit_MPI(myrank,'error opening buffer_corners_chunks file')
-
- read(IIN,*) npoin1D_corner
- if(npoin1D_corner /= NGLOB1D_RADIAL) then
- print*,'error ',myrank,' npoin1D_corner: ',npoin1D_corner,'NGLOB1D_RADIAL:',NGLOB1D_RADIAL
- print*,'iregion_code:',iregion_code
- call exit_MPI(myrank,'incorrect nb of points in corner buffer')
- endif
- do ipoin1D = 1,npoin1D_corner
- read(IIN,*) iboolcorner(ipoin1D,icount_corners),xdummy,ydummy,zdummy
- enddo
- close(IIN)
-
- endif
-
-
- enddo
-
- endif
-
- end subroutine read_arrays_buffers_mesher
-
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver.f90 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/save_arrays_solver.f90 2012-08-11 02:22:07 UTC (rev 20565)
@@ -396,3 +396,137 @@
endif ! SAVE_MESH_FILES
end subroutine save_arrays_solver
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+
+ subroutine save_arrays_solver_MPI(iregion_code)
+
+ use meshfem3D_par,only: &
+ myrank,LOCAL_PATH, &
+ IREGION_CRUST_MANTLE,IREGION_OUTER_CORE,IREGION_INNER_CORE
+
+! 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
+
+ select case( iregion_code )
+ case( IREGION_CRUST_MANTLE )
+ ! crust mantle
+ call save_MPI_arrays(myrank,IREGION_CRUST_MANTLE,LOCAL_PATH, &
+ num_interfaces_crust_mantle,max_nibool_interfaces_crust_mantle, &
+ my_neighbours_crust_mantle,nibool_interfaces_crust_mantle, &
+ ibool_interfaces_crust_mantle, &
+ nspec_inner_crust_mantle,nspec_outer_crust_mantle, &
+ num_phase_ispec_crust_mantle,phase_ispec_inner_crust_mantle, &
+ num_colors_outer_crust_mantle,num_colors_inner_crust_mantle, &
+ num_elem_colors_crust_mantle)
+
+
+ case( IREGION_OUTER_CORE )
+ ! outer core
+ call save_MPI_arrays(myrank,IREGION_OUTER_CORE,LOCAL_PATH, &
+ num_interfaces_outer_core,max_nibool_interfaces_outer_core, &
+ my_neighbours_outer_core,nibool_interfaces_outer_core, &
+ ibool_interfaces_outer_core, &
+ nspec_inner_outer_core,nspec_outer_outer_core, &
+ num_phase_ispec_outer_core,phase_ispec_inner_outer_core, &
+ num_colors_outer_outer_core,num_colors_inner_outer_core, &
+ num_elem_colors_outer_core)
+
+ case( IREGION_INNER_CORE )
+ ! inner core
+ call save_MPI_arrays(myrank,IREGION_INNER_CORE,LOCAL_PATH, &
+ num_interfaces_inner_core,max_nibool_interfaces_inner_core, &
+ my_neighbours_inner_core,nibool_interfaces_inner_core, &
+ ibool_interfaces_inner_core, &
+ nspec_inner_inner_core,nspec_outer_inner_core, &
+ num_phase_ispec_inner_core,phase_ispec_inner_inner_core, &
+ num_colors_outer_inner_core,num_colors_inner_inner_core, &
+ num_elem_colors_inner_core)
+
+ end select
+
+ end subroutine save_arrays_solver_MPI
+
+
+!
+!-------------------------------------------------------------------------------------------------
+!
+
+ subroutine save_MPI_arrays(myrank,iregion_code,LOCAL_PATH, &
+ num_interfaces,max_nibool_interfaces, &
+ my_neighbours,nibool_interfaces, &
+ ibool_interfaces, &
+ nspec_inner,nspec_outer, &
+ num_phase_ispec,phase_ispec_inner, &
+ num_colors_outer,num_colors_inner, &
+ num_elem_colors)
+ implicit none
+
+ include "constants.h"
+
+ integer :: iregion_code,myrank
+
+ character(len=150) :: LOCAL_PATH
+
+ ! MPI interfaces
+ integer :: num_interfaces,max_nibool_interfaces
+ integer, dimension(num_interfaces) :: my_neighbours
+ integer, dimension(num_interfaces) :: nibool_interfaces
+ integer, dimension(max_nibool_interfaces,num_interfaces) :: &
+ ibool_interfaces
+
+ ! inner/outer elements
+ integer :: nspec_inner,nspec_outer
+ integer :: num_phase_ispec
+ integer,dimension(num_phase_ispec,2) :: phase_ispec_inner
+
+ ! mesh coloring
+ integer :: num_colors_outer,num_colors_inner
+ integer, dimension(num_colors_outer + num_colors_inner) :: &
+ num_elem_colors
+
+ ! local parameters
+ character(len=150) :: prname
+ integer :: ier
+
+ ! create the name for the database of the current slide and region
+ call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
+
+ open(unit=IOUT,file=prname(1:len_trim(prname))//'solver_data_mpi.bin', &
+ status='unknown',action='write',form='unformatted',iostat=ier)
+ if( ier /= 0 ) call exit_mpi(myrank,'error opening solver_data_mpi.bin')
+
+ ! MPI interfaces
+ write(IOUT) num_interfaces
+ if( num_interfaces > 0 ) then
+ write(IOUT) max_nibool_interfaces
+ write(IOUT) my_neighbours
+ write(IOUT) nibool_interfaces
+ write(IOUT) ibool_interfaces
+ endif
+
+ ! inner/outer elements
+ write(IOUT) nspec_inner,nspec_outer
+ write(IOUT) num_phase_ispec
+ if(num_phase_ispec > 0 ) write(IOUT) phase_ispec_inner
+
+ ! mesh coloring
+ if( USE_MESH_COLORING_GPU ) then
+ write(IOUT) num_colors_outer,num_colors_inner
+ write(IOUT) num_elem_colors
+ endif
+
+ close(IOUT)
+
+ end subroutine save_MPI_arrays
+
Modified: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/setup_color_perm.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/setup_color_perm.f90 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/meshfem3D/setup_color_perm.f90 2012-08-11 02:22:07 UTC (rev 20565)
@@ -600,19 +600,19 @@
! local parameters
! added for sorting
integer, dimension(:,:,:,:), allocatable :: temp_array_int
- real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: temp_array_real
+! real(kind=CUSTOM_REAL), dimension(:,:,:,:), allocatable :: temp_array_real
logical, dimension(:), allocatable :: temp_array_logical_1D
integer, dimension(:), allocatable :: temp_perm_global
logical, dimension(:), allocatable :: mask_global
integer :: icolor,icounter,ispec,ielem,ier,i
- integer :: iface,old_ispec,new_ispec
-
+ integer :: new_ispec
+! integer :: iface,old_ispec
character(len=256) :: filename
+ character(len=150) :: prname
logical,parameter :: DEBUG = .true.
- character(len=150) :: prname
! sorts array according to permutation
allocate(temp_perm_global(nspec),stat=ier)
Deleted: seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_arrays_buffers_solver.f90
===================================================================
--- seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_arrays_buffers_solver.f90 2012-08-09 13:46:38 UTC (rev 20564)
+++ seismo/3D/SPECFEM3D_GLOBE/branches/SPECFEM3D_GLOBE_SUNFLOWER/src/specfem3D/read_arrays_buffers_solver.f90 2012-08-11 02:22:07 UTC (rev 20565)
@@ -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 University of Pau / CNRS / INRIA, France
-! (c) Princeton University / California Institute of Technology and University of Pau / CNRS / INRIA
-! April 2011
-!
-! This program is free software; you can redistribute it and/or modify
-! it under the terms of the GNU General Public License as published by
-! the Free Software Foundation; either version 2 of the License, or
-! (at your option) any later version.
-!
-! This program is distributed in the hope that it will be useful,
-! but WITHOUT ANY WARRANTY; without even the implied warranty of
-! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-! GNU General Public License for more details.
-!
-! You should have received a copy of the GNU General Public License along
-! with this program; if not, write to the Free Software Foundation, Inc.,
-! 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-!
-!=====================================================================
-
-!daniel: obsolete...
-!
-! subroutine read_arrays_buffers_solver(iregion_code,myrank, &
-! iboolleft_xi,iboolright_xi,iboolleft_eta,iboolright_eta, &
-! npoin2D_xi,npoin2D_eta, &
-! iprocfrom_faces,iprocto_faces,imsg_type, &
-! iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners, &
-! iboolfaces,npoin2D_faces,iboolcorner, &
-! NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NGLOB1D_RADIAL, &
-! NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT,NPROC_XI,NPROC_ETA,LOCAL_PATH,NCHUNKS)
-!
-! implicit none
-!
-!! standard include of the MPI library
-! include 'mpif.h'
-!
-! include "constants.h"
-!
-! integer iregion_code,myrank,NCHUNKS,ier
-!
-! integer, dimension(NB_SQUARE_EDGES_ONEDIR) :: npoin2D_xi,npoin2D_eta
-! integer NGLOB2DMAX_XMIN_XMAX,NGLOB2DMAX_YMIN_YMAX,NGLOB2DMAX_XY,NGLOB1D_RADIAL
-! integer NUMMSGS_FACES,NCORNERSCHUNKS,NPROCTOT,NPROC_XI,NPROC_ETA
-!
-! integer npoin2D_faces(NUMFACES_SHARED)
-!
-! character(len=150) LOCAL_PATH
-!
-! integer, dimension(NGLOB2DMAX_XY,NUMFACES_SHARED) :: iboolfaces
-! integer, dimension(NGLOB1D_RADIAL,NUMCORNERS_SHARED) :: iboolcorner
-! integer, dimension(NGLOB2DMAX_XMIN_XMAX) :: iboolleft_xi,iboolright_xi
-! integer, dimension(NGLOB2DMAX_YMIN_YMAX) :: iboolleft_eta,iboolright_eta
-!
-! integer, dimension(NUMMSGS_FACES) :: iprocfrom_faces,iprocto_faces,imsg_type
-!
-!! allocate array for messages for corners
-! integer, dimension(NCORNERSCHUNKS) :: iproc_master_corners,iproc_worker1_corners,iproc_worker2_corners
-!
-! integer npoin2D_xi_mesher,npoin2D_eta_mesher
-! integer npoin1D_corner
-!
-! integer imsg,icount_faces,icount_corners
-! integer ipoin1D,ipoin2D
-!
-! double precision xdummy,ydummy,zdummy
-!
-!! processor identification
-! character(len=150) OUTPUT_FILES,prname,filename
-!
-!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-!
-!! get the base pathname for output files
-! call get_value_string(OUTPUT_FILES, 'OUTPUT_FILES', 'OUTPUT_FILES')
-!
-!! create the name for the database of the current slide and region
-! call create_name_database(prname,myrank,iregion_code,LOCAL_PATH)
-!
-!! read 2-D addressing for summation between slices along xi with MPI
-!
-!! read iboolleft_xi of this slice
-! open(unit=IIN,file=prname(1:len_trim(prname))//'iboolleft_xi.txt', &
-! status='old',action='read',iostat=ier)
-! if( ier /= 0 ) call exit_MPI(myrank,'error opening iboolleft_xi file')
-!
-! npoin2D_xi(1) = 1
-! 350 continue
-! read(IIN,*) iboolleft_xi(npoin2D_xi(1)),xdummy,ydummy,zdummy
-! if(iboolleft_xi(npoin2D_xi(1)) > 0) then
-! npoin2D_xi(1) = npoin2D_xi(1) + 1
-! goto 350
-! endif
-!! subtract the line that contains the flag after the last point
-! npoin2D_xi(1) = npoin2D_xi(1) - 1
-!! read nb of points given by the mesher
-! read(IIN,*) npoin2D_xi_mesher
-! if(npoin2D_xi(1) > NGLOB2DMAX_XMIN_XMAX .or. npoin2D_xi(1) /= npoin2D_xi_mesher) &
-! call exit_MPI(myrank,'incorrect iboolleft_xi read')
-! close(IIN)
-!
-!! read iboolright_xi of this slice
-! open(unit=IIN,file=prname(1:len_trim(prname))//'iboolright_xi.txt', &
-! status='old',action='read',iostat=ier)
-! if( ier /= 0 ) call exit_MPI(myrank,'error opening iboolright_xi file')
-!
-! npoin2D_xi(2) = 1
-! 360 continue
-! read(IIN,*) iboolright_xi(npoin2D_xi(2)),xdummy,ydummy,zdummy
-! if(iboolright_xi(npoin2D_xi(2)) > 0) then
-! npoin2D_xi(2) = npoin2D_xi(2) + 1
-! goto 360
-! endif
-!! subtract the line that contains the flag after the last point
-! npoin2D_xi(2) = npoin2D_xi(2) - 1
-!! read nb of points given by the mesher
-! read(IIN,*) npoin2D_xi_mesher
-! if(npoin2D_xi(2) > NGLOB2DMAX_XMIN_XMAX .or. npoin2D_xi(2) /= npoin2D_xi_mesher) &
-! call exit_MPI(myrank,'incorrect iboolright_xi read')
-! close(IIN)
-!
-! if(myrank == 0) then
-! write(IMAIN,*) ' #max of points in MPI buffers along xi npoin2D_xi = ', &
-! maxval(npoin2D_xi(:))
-! write(IMAIN,*) ' #max of array elements transferred npoin2D_xi*NDIM = ', &
-! maxval(npoin2D_xi(:))*NDIM
-! write(IMAIN,*)
-! endif
-!
-!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-!
-!! read 2-D addressing for summation between slices along eta with MPI
-!
-!! read iboolleft_eta of this slice
-! open(unit=IIN,file=prname(1:len_trim(prname))//'iboolleft_eta.txt', &
-! status='old',action='read',iostat=ier)
-! if( ier /= 0 ) call exit_MPI(myrank,'error opening iboolleft_eta file')
-!
-! npoin2D_eta(1) = 1
-! 370 continue
-! read(IIN,*) iboolleft_eta(npoin2D_eta(1)),xdummy,ydummy,zdummy
-! if(iboolleft_eta(npoin2D_eta(1)) > 0) then
-! npoin2D_eta(1) = npoin2D_eta(1) + 1
-! goto 370
-! endif
-!! subtract the line that contains the flag after the last point
-! npoin2D_eta(1) = npoin2D_eta(1) - 1
-!! read nb of points given by the mesher
-! read(IIN,*) npoin2D_eta_mesher
-! if(npoin2D_eta(1) > NGLOB2DMAX_YMIN_YMAX .or. npoin2D_eta(1) /= npoin2D_eta_mesher) &
-! call exit_MPI(myrank,'incorrect iboolleft_eta read')
-! close(IIN)
-!
-!! read iboolright_eta of this slice
-! open(unit=IIN,file=prname(1:len_trim(prname))//'iboolright_eta.txt', &
-! status='old',action='read',iostat=ier)
-! if( ier /= 0 ) call exit_MPI(myrank,'error opening iboolright_eta file')
-!
-! npoin2D_eta(2) = 1
-! 380 continue
-! read(IIN,*) iboolright_eta(npoin2D_eta(2)),xdummy,ydummy,zdummy
-! if(iboolright_eta(npoin2D_eta(2)) > 0) then
-! npoin2D_eta(2) = npoin2D_eta(2) + 1
-! goto 380
-! endif
-!! subtract the line that contains the flag after the last point
-! npoin2D_eta(2) = npoin2D_eta(2) - 1
-!! read nb of points given by the mesher
-! read(IIN,*) npoin2D_eta_mesher
-! if(npoin2D_eta(2) > NGLOB2DMAX_YMIN_YMAX .or. npoin2D_eta(2) /= npoin2D_eta_mesher) &
-! call exit_MPI(myrank,'incorrect iboolright_eta read')
-! close(IIN)
-!
-! if(myrank == 0) then
-! write(IMAIN,*) ' #max of points in MPI buffers along eta npoin2D_eta = ', &
-! maxval(npoin2D_eta(:))
-! write(IMAIN,*) ' #max of array elements transferred npoin2D_eta*NDIM = ', &
-! maxval(npoin2D_eta(:))*NDIM
-! write(IMAIN,*)
-! endif
-!
-!
-!!! $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
-!
-!! read chunk messages only if more than one chunk
-! if(NCHUNKS /= 1) then
-!
-!! read messages to assemble between chunks with MPI
-!
-! if(myrank == 0) then
-!
-! ! file with the list of processors for each message for faces
-! open(unit=IIN,file=trim(OUTPUT_FILES)//'/list_messages_faces.txt', &
-! status='old',action='read',iostat=ier)
-! if( ier /= 0 ) call exit_MPI(myrank,'error opening list_messages_faces file')
-!
-! do imsg = 1,NUMMSGS_FACES
-! read(IIN,*) imsg_type(imsg),iprocfrom_faces(imsg),iprocto_faces(imsg)
-! if (iprocfrom_faces(imsg) < 0 &
-! .or. iprocto_faces(imsg) < 0 &
-! .or. iprocfrom_faces(imsg) > NPROCTOT-1 &
-! .or. iprocto_faces(imsg) > NPROCTOT-1) &
-! call exit_MPI(myrank,'incorrect chunk faces numbering')
-! if (imsg_type(imsg) < 1 .or. imsg_type(imsg) > 3) &
-! call exit_MPI(myrank,'incorrect message type labeling')
-! enddo
-! close(IIN)
-!
-! ! file with the list of processors for each message for corners
-! open(unit=IIN,file=trim(OUTPUT_FILES)//'/list_messages_corners.txt', &
-! status='old',action='read',iostat=ier)
-! if( ier /= 0 ) call exit_MPI(myrank,'error opening list_messages_corners file')
-!
-! do imsg = 1,NCORNERSCHUNKS
-! read(IIN,*) iproc_master_corners(imsg),iproc_worker1_corners(imsg), &
-! iproc_worker2_corners(imsg)
-! if (iproc_master_corners(imsg) < 0 &
-! .or. iproc_worker1_corners(imsg) < 0 &
-! .or. iproc_worker2_corners(imsg) < 0 &
-! .or. iproc_master_corners(imsg) > NPROCTOT-1 &
-! .or. iproc_worker1_corners(imsg) > NPROCTOT-1 &
-! .or. iproc_worker2_corners(imsg) > NPROCTOT-1) &
-! call exit_MPI(myrank,'incorrect chunk corner numbering')
-! enddo
-! close(IIN)
-!
-! endif
-!
-!! broadcast the information read on the master to the nodes
-! call MPI_BCAST(imsg_type,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-! call MPI_BCAST(iprocfrom_faces,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-! call MPI_BCAST(iprocto_faces,NUMMSGS_FACES,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-!
-! call MPI_BCAST(iproc_master_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-! call MPI_BCAST(iproc_worker1_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-! call MPI_BCAST(iproc_worker2_corners,NCORNERSCHUNKS,MPI_INTEGER,0,MPI_COMM_WORLD,ier)
-! if( ier /= 0 ) call exit_MPI(myrank,'error mpi broadcast')
-!
-!
-!!---- read 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
-!
-! ! read file with 2D buffer for faces
-! if(myrank == iprocfrom_faces(imsg)) then
-! write(filename,"('buffer_faces_chunks_sender_msg',i6.6,'.txt')") imsg
-! else if(myrank == iprocto_faces(imsg)) then
-! write(filename,"('buffer_faces_chunks_receiver_msg',i6.6,'.txt')") imsg
-! endif
-!
-! open(unit=IIN,file=prname(1:len_trim(prname))//filename,status='old',action='read',iostat=ier)
-! if( ier /= 0 ) call exit_MPI(myrank,'error opening buffer_faces file')
-!
-! read(IIN,*) npoin2D_faces(icount_faces)
-! if(npoin2D_faces(icount_faces) > NGLOB2DMAX_XY) then
-! print*,'error ',myrank,' npoin2D_faces: ',npoin2D_faces(icount_faces),icount_faces
-! print*,'iregion_code:',iregion_code
-! call exit_MPI(myrank,'incorrect nb of points in face buffer')
-! endif
-!
-! do ipoin2D = 1,npoin2D_faces(icount_faces)
-! read(IIN,*) iboolfaces(ipoin2D,icount_faces),xdummy,ydummy,zdummy
-! enddo
-! close(IIN)
-!
-! endif
-! enddo
-!
-!
-!!---- read indirect addressing for each message for corners of the chunks
-!!---- a given slice can belong to at most one corner
-! icount_corners = 0
-! do imsg = 1,NCORNERSCHUNKS
-! ! if only two chunks then there is no second worker
-! if(myrank == iproc_master_corners(imsg) .or. &
-! myrank == iproc_worker1_corners(imsg) .or. &
-! (NCHUNKS /= 2 .and. myrank == iproc_worker2_corners(imsg))) then
-!
-! icount_corners = icount_corners + 1
-! if(icount_corners>1 .and. (NPROC_XI > 1 .or. NPROC_ETA > 1)) then
-! print*,'error ',myrank,'icount_corners:',icount_corners
-! print*,'iregion_code:',iregion_code
-! call exit_MPI(myrank,'more than one corner for this slice')
-! endif
-! if(icount_corners>4) call exit_MPI(myrank,'more than four corners for this slice')
-!
-! ! read file with 1D buffer for corner
-! if(myrank == iproc_master_corners(imsg)) then
-! write(filename,"('buffer_corners_chunks_master_msg',i6.6,'.txt')") imsg
-! else if(myrank == iproc_worker1_corners(imsg)) then
-! write(filename,"('buffer_corners_chunks_worker1_msg',i6.6,'.txt')") imsg
-! else if( NCHUNKS /= 2 .and. myrank == iproc_worker2_corners(imsg)) then
-! write(filename,"('buffer_corners_chunks_worker2_msg',i6.6,'.txt')") imsg
-! endif
-!
-! ! matching codes
-! open(unit=IIN,file=prname(1:len_trim(prname))//filename, &
-! status='old',action='read',iostat=ier)
-! if( ier /= 0 ) call exit_MPI(myrank,'error opening buffer_corners_chunks file')
-!
-! read(IIN,*) npoin1D_corner
-! if(npoin1D_corner /= NGLOB1D_RADIAL) then
-! print*,'error ',myrank,' npoin1D_corner: ',npoin1D_corner,'NGLOB1D_RADIAL:',NGLOB1D_RADIAL
-! print*,'iregion_code:',iregion_code
-! call exit_MPI(myrank,'incorrect nb of points in corner buffer')
-! endif
-! do ipoin1D = 1,npoin1D_corner
-! read(IIN,*) iboolcorner(ipoin1D,icount_corners),xdummy,ydummy,zdummy
-! enddo
-! close(IIN)
-!
-! endif
-!
-!
-! enddo
-!
-! endif
-!
-! end subroutine read_arrays_buffers_solver
-!
More information about the CIG-COMMITS
mailing list