[cig-commits] r12495 - seismo/2D/SPECFEM2D/trunk
dkomati1 at geodynamics.org
dkomati1 at geodynamics.org
Tue Jul 29 18:32:29 PDT 2008
Author: dkomati1
Date: 2008-07-29 18:32:28 -0700 (Tue, 29 Jul 2008)
New Revision: 12495
Modified:
seismo/2D/SPECFEM2D/trunk/checkgrid.F90
seismo/2D/SPECFEM2D/trunk/constants.h
seismo/2D/SPECFEM2D/trunk/createnum_fast.f90
seismo/2D/SPECFEM2D/trunk/createnum_slow.f90
seismo/2D/SPECFEM2D/trunk/gmat01.f90
seismo/2D/SPECFEM2D/trunk/locate_receivers.F90
seismo/2D/SPECFEM2D/trunk/locate_source_force.F90
seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.F90
seismo/2D/SPECFEM2D/trunk/meshfem2D.F90
seismo/2D/SPECFEM2D/trunk/plotpost.F90
seismo/2D/SPECFEM2D/trunk/specfem2D.F90
Log:
fixed the if(myrank == 0) bug in MPI: all the processors used to print to the screen.
also improved several other details in the process.
Modified: seismo/2D/SPECFEM2D/trunk/checkgrid.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/checkgrid.F90 2008-07-30 00:05:50 UTC (rev 12494)
+++ seismo/2D/SPECFEM2D/trunk/checkgrid.F90 2008-07-30 01:32:28 UTC (rev 12495)
@@ -163,7 +163,7 @@
if(NGLLX > NGLLX_MAX_STABILITY) then
call exit_MPI('cannot estimate the stability condition for that degree')
- end if
+ endif
! define color palette in random order
@@ -1575,10 +1575,11 @@
ratio_page = min(rpercentz*sizez/(zmax-zmin),rpercentx*sizex/(xmax-xmin)) / 100.d0
- if ( myrank == 0 ) then
- print *
- print *,'Creating PostScript file with stability condition'
+ if (myrank == 0) then
+ write(IOUT,*)
+ write(IOUT,*) 'Creating PostScript file with stability condition'
+
!
!---- open PostScript file
!
@@ -1683,14 +1684,14 @@
write(24,*) '0 setgray'
num_ispec = 0
- end if
+ endif
do ispec = 1, nspec
if ( myrank == 0 ) then
num_ispec = num_ispec + 1
write(24,*) '% elem ',num_ispec
- end if
+ endif
do i=1,pointsdisp
do j=1,pointsdisp
@@ -1716,7 +1717,7 @@
else
coorg_send(1,(ispec-1)*5+1) = x1
coorg_send(2,(ispec-1)*5+1) = z1
- end if
+ endif
! draw straight lines if elements have 4 nodes
@@ -1730,7 +1731,7 @@
else
coorg_send(1,(ispec-1)*5+2) = x2
coorg_send(2,(ispec-1)*5+2) = z2
- end if
+ endif
ir=pointsdisp
is=pointsdisp
@@ -1743,7 +1744,7 @@
else
coorg_send(1,(ispec-1)*5+3) = x2
coorg_send(2,(ispec-1)*5+3) = z2
- end if
+ endif
is=pointsdisp
ir=1
@@ -1756,7 +1757,7 @@
else
coorg_send(1,(ispec-1)*5+4) = x2
coorg_send(2,(ispec-1)*5+4) = z2
- end if
+ endif
ir=1
is=2
@@ -1770,7 +1771,7 @@
else
coorg_send(1,(ispec-1)*5+5) = x2
coorg_send(2,(ispec-1)*5+5) = z2
- end if
+ endif
material = kmato(ispec)
@@ -1832,14 +1833,14 @@
write(24,*) '1 0 0 RG GF 0 setgray ST'
else
RGB_send(ispec) = 1
- end if
+ endif
else
! do not color the elements if below the threshold
if ( myrank == 0 ) then
write(24,*) 'ST'
else
RGB_send(ispec) = 0
- end if
+ endif
endif
enddo ! end of loop on all the spectral elements
@@ -1868,19 +1869,19 @@
write(24,*) '1 0 0 RG GF 0 setgray ST'
else
write(24,*) 'ST'
- end if
- end do
+ endif
+ enddo
deallocate(coorg_recv)
deallocate(RGB_recv)
- end do
+ enddo
else
call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
call MPI_SEND (coorg_send, nspec*5*2, MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
call MPI_SEND (RGB_send, nspec, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
- end if
+ endif
#endif
@@ -1891,17 +1892,18 @@
close(24)
- print *,'End of creation of PostScript file with stability condition'
- end if
+ write(IOUT,*) 'End of creation of PostScript file with stability condition'
+ endif
!
!--------------------------------------------------------------------------------
!
- if ( myrank == 0 ) then
- print *
- print *,'Creating PostScript file with mesh dispersion'
+ if (myrank == 0) then
+ write(IOUT,*)
+ write(IOUT,*) 'Creating PostScript file with mesh dispersion'
+
!
!---- open PostScript file
!
@@ -2014,13 +2016,13 @@
write(24,*) '0 setgray'
num_ispec = 0
- end if
+ endif
do ispec = 1, nspec
if ( myrank == 0 ) then
num_ispec = num_ispec + 1
write(24,*) '% elem ',num_ispec
- end if
+ endif
do i=1,pointsdisp
do j=1,pointsdisp
@@ -2046,7 +2048,7 @@
else
coorg_send(1,(ispec-1)*5+1) = x1
coorg_send(2,(ispec-1)*5+1) = z1
- end if
+ endif
! draw straight lines if elements have 4 nodes
@@ -2060,7 +2062,7 @@
else
coorg_send(1,(ispec-1)*5+2) = x2
coorg_send(2,(ispec-1)*5+2) = z2
- end if
+ endif
ir=pointsdisp
is=pointsdisp
@@ -2073,7 +2075,7 @@
else
coorg_send(1,(ispec-1)*5+3) = x2
coorg_send(2,(ispec-1)*5+3) = z2
- end if
+ endif
is=pointsdisp
ir=1
@@ -2086,7 +2088,7 @@
else
coorg_send(1,(ispec-1)*5+4) = x2
coorg_send(2,(ispec-1)*5+4) = z2
- end if
+ endif
ir=1
is=2
@@ -2100,7 +2102,7 @@
else
coorg_send(1,(ispec-1)*5+5) = x2
coorg_send(2,(ispec-1)*5+5) = z2
- end if
+ endif
material = kmato(ispec)
@@ -2168,7 +2170,7 @@
write(24,*) '1 0 0 RG GF 0 setgray ST'
else
RGB_send(ispec) = 1
- end if
+ endif
! display bad elements that are below 120% of the threshold in blue
else if(lambdaS_local <= 1.20 * lambdaSmin) then
@@ -2176,7 +2178,7 @@
write(24,*) '0 0 1 RG GF 0 setgray ST'
else
RGB_send(ispec) = 3
- end if
+ endif
else
! do not color the elements if not close to the threshold
@@ -2184,7 +2186,7 @@
write(24,*) 'ST'
else
RGB_send(ispec) = 0
- end if
+ endif
endif
else
@@ -2193,7 +2195,7 @@
write(24,*) 'ST'
else
RGB_send(ispec) = 0
- end if
+ endif
endif
! display mesh dispersion for P waves if there is no elastic element in the mesh
@@ -2207,7 +2209,7 @@
write(24,*) '1 0 0 RG GF 0 setgray ST'
else
RGB_send(ispec) = 1
- end if
+ endif
! display bad elements that are below 120% of the threshold in blue
else if(lambdaP_local <= 1.20 * lambdaPmin) then
@@ -2215,7 +2217,7 @@
write(24,*) '0 0 1 RG GF 0 setgray ST'
else
RGB_send(ispec) = 3
- end if
+ endif
else
! do not color the elements if not close to the threshold
@@ -2223,7 +2225,7 @@
write(24,*) 'ST'
else
RGB_send(ispec) = 0
- end if
+ endif
endif
endif
@@ -2252,26 +2254,26 @@
write(24,*) 'CO'
if ( RGB_recv(ispec) == 1) then
write(24,*) '1 0 0 RG GF 0 setgray ST'
- end if
+ endif
if ( RGB_recv(ispec) == 3) then
write(24,*) '0 0 1 RG GF 0 setgray ST'
- end if
+ endif
if ( RGB_recv(ispec) == 0) then
write(24,*) 'ST'
- end if
+ endif
- end do
+ enddo
deallocate(coorg_recv)
deallocate(RGB_recv)
- end do
+ enddo
else
call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
call MPI_SEND (coorg_send, nspec*5*2, MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
call MPI_SEND (RGB_send, nspec, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
- end if
+ endif
#endif
if ( myrank == 0 ) then
@@ -2281,17 +2283,19 @@
close(24)
- print *,'End of creation of PostScript file with mesh dispersion'
- end if
+ write(IOUT,*) 'End of creation of PostScript file with mesh dispersion'
+ endif
+
!
!--------------------------------------------------------------------------------
!
- if ( myrank == 0 ) then
- print *
- print *,'Creating PostScript file with velocity model'
+ if (myrank == 0) then
+ write(IOUT,*)
+ write(IOUT,*) 'Creating PostScript file with velocity model'
+
!
!---- open PostScript file
!
@@ -2396,13 +2400,13 @@
write(24,*) '0 setgray'
num_ispec = 0
-end if
+endif
do ispec = 1, UPPER_LIMIT_DISPLAY
if ( myrank == 0 ) then
num_ispec = num_ispec + 1
write(24,*) '% elem ',num_ispec
- end if
+ endif
do i=1,pointsdisp
do j=1,pointsdisp
xinterp(i,j) = 0.d0
@@ -2427,7 +2431,7 @@
else
coorg_send(1,(ispec-1)*5+1) = x1
coorg_send(2,(ispec-1)*5+1) = z1
- end if
+ endif
! draw straight lines if elements have 4 nodes
@@ -2441,7 +2445,7 @@
else
coorg_send(1,(ispec-1)*5+2) = x2
coorg_send(2,(ispec-1)*5+2) = z2
- end if
+ endif
ir=pointsdisp
is=pointsdisp
@@ -2454,7 +2458,7 @@
else
coorg_send(1,(ispec-1)*5+3) = x2
coorg_send(2,(ispec-1)*5+3) = z2
- end if
+ endif
is=pointsdisp
ir=1
@@ -2467,7 +2471,7 @@
else
coorg_send(1,(ispec-1)*5+4) = x2
coorg_send(2,(ispec-1)*5+4) = z2
- end if
+ endif
ir=1
is=2
@@ -2481,7 +2485,7 @@
else
coorg_send(1,(ispec-1)*5+5) = x2
coorg_send(2,(ispec-1)*5+5) = z2
- end if
+ endif
if((vpmax-vpmin)/vpmin > 0.02d0) then
if(assign_external_model) then
@@ -2511,7 +2515,7 @@
write(24,*) sngl(x1),' setgray GF 0 setgray ST'
else
greyscale_send(ispec) = sngl(x1)
- end if
+ endif
enddo ! end of loop on all the spectral elements
#ifdef USE_MPI
@@ -2536,33 +2540,36 @@
write(24,*) 'CO'
write(24,*) greyscale_recv(ispec), ' setgray GF 0 setgray ST'
- end do
+ enddo
deallocate(coorg_recv)
deallocate(greyscale_recv)
- end do
+ enddo
else
call MPI_SEND (UPPER_LIMIT_DISPLAY, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
call MPI_SEND (coorg_send, UPPER_LIMIT_DISPLAY*5*2, MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
call MPI_SEND (greyscale_send, UPPER_LIMIT_DISPLAY, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
- end if
+ endif
#endif
- if ( myrank == 0 ) then
+ if (myrank == 0) then
+
write(24,*) '%'
write(24,*) 'grestore'
write(24,*) 'showpage'
close(24)
- print *,'End of creation of PostScript file with velocity model'
+ write(IOUT,*) 'End of creation of PostScript file with velocity model'
- end if
+ endif
- if ( myrank == 0 ) then
- print *
- print *,'Creating PostScript file with mesh partitioning'
+ if (myrank == 0) then
+
+ write(IOUT,*)
+ write(IOUT,*) 'Creating PostScript file with mesh partitioning'
+
!
!---- open PostScript file
!
@@ -2641,7 +2648,7 @@
write(24,*) '24.35 CM 18.9 CM MV'
write(24,*) usoffset,' CM 2 div neg 0 MR'
write(24,*) 'currentpoint gsave translate -90 rotate 0 0 moveto'
- write(24,*) '(Mesh stability condition \(red = bad\)) show'
+ write(24,*) '(Mesh partitioning) show'
write(24,*) 'grestore'
write(24,*) '25.35 CM 18.9 CM MV'
write(24,*) usoffset,' CM 2 div neg 0 MR'
@@ -2667,14 +2674,14 @@
write(24,*) '0 setgray'
num_ispec = 0
- end if
+ endif
do ispec = 1, UPPER_LIMIT_DISPLAY
if ( myrank == 0 ) then
num_ispec = num_ispec + 1
write(24,*) '% elem ',num_ispec
- end if
+ endif
do i=1,pointsdisp
do j=1,pointsdisp
@@ -2700,7 +2707,7 @@
else
coorg_send(1,(ispec-1)*5+1) = x1
coorg_send(2,(ispec-1)*5+1) = z1
- end if
+ endif
! draw straight lines if elements have 4 nodes
@@ -2714,7 +2721,7 @@
else
coorg_send(1,(ispec-1)*5+2) = x2
coorg_send(2,(ispec-1)*5+2) = z2
- end if
+ endif
ir=pointsdisp
is=pointsdisp
@@ -2727,7 +2734,7 @@
else
coorg_send(1,(ispec-1)*5+3) = x2
coorg_send(2,(ispec-1)*5+3) = z2
- end if
+ endif
is=pointsdisp
ir=1
@@ -2740,7 +2747,7 @@
else
coorg_send(1,(ispec-1)*5+4) = x2
coorg_send(2,(ispec-1)*5+4) = z2
- end if
+ endif
ir=1
is=2
@@ -2754,11 +2761,11 @@
else
coorg_send(1,(ispec-1)*5+5) = x2
coorg_send(2,(ispec-1)*5+5) = z2
- end if
+ endif
if ( myrank == 0 ) then
write(24,*) red(1), green(1), blue(1), 'RG GF 0 setgray ST'
- end if
+ endif
enddo ! end of loop on all the spectral elements
@@ -2787,27 +2794,28 @@
write(24,*) red(icol), green(icol), blue(icol), ' RG GF 0 setgray ST'
- end do
+ enddo
deallocate(coorg_recv)
- end do
+ enddo
else
call MPI_SEND (UPPER_LIMIT_DISPLAY, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
call MPI_SEND (coorg_send, UPPER_LIMIT_DISPLAY*5*2, MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
- end if
+ endif
#endif
- if ( myrank == 0 ) then
- write(24,*) '%'
- write(24,*) 'grestore'
- write(24,*) 'showpage'
+ if (myrank == 0) then
+ write(24,*) '%'
+ write(24,*) 'grestore'
+ write(24,*) 'showpage'
- close(24)
+ close(24)
- print *,'End of creation of PostScript file with partitioning'
- end if
+ write(IOUT,*) 'End of creation of PostScript file with partitioning'
+ write(IOUT,*)
+ endif
10 format('%!PS-Adobe-2.0',/,'%%',/,'%% Title: ',a50,/,'%% Created by: Specfem2D',/,'%% Author: Dimitri Komatitsch',/,'%%')
Modified: seismo/2D/SPECFEM2D/trunk/constants.h
===================================================================
--- seismo/2D/SPECFEM2D/trunk/constants.h 2008-07-30 00:05:50 UTC (rev 12494)
+++ seismo/2D/SPECFEM2D/trunk/constants.h 2008-07-30 01:32:28 UTC (rev 12495)
@@ -9,7 +9,7 @@
! DO NOT forget to change precision_mpi.h accordingly
!
integer, parameter :: CUSTOM_REAL = SIZE_DOUBLE
-! integer, parameter :: CUSTOM_REAL = SIZE_REAL
+! integer, parameter :: CUSTOM_REAL = SIZE_REAL
! polynomial degree
integer, parameter :: NGLLX = 5
Modified: seismo/2D/SPECFEM2D/trunk/createnum_fast.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/createnum_fast.f90 2008-07-30 00:05:50 UTC (rev 12494)
+++ seismo/2D/SPECFEM2D/trunk/createnum_fast.f90 2008-07-30 01:32:28 UTC (rev 12495)
@@ -40,7 +40,7 @@
!
!========================================================================
- subroutine createnum_fast(knods,ibool,shape,coorg,npoin,npgeo,nspec,ngnod)
+ subroutine createnum_fast(knods,ibool,shape,coorg,npoin,npgeo,nspec,ngnod,myrank,ipass)
! equivalent de la routine "createnum_slow" mais algorithme plus rapide
@@ -48,7 +48,7 @@
include "constants.h"
- integer npoin,npgeo,nspec,ngnod
+ integer npoin,npgeo,nspec,ngnod,myrank,ipass
integer knods(ngnod,nspec),ibool(NGLLX,NGLLZ,nspec)
double precision shape(ngnod,NGLLX,NGLLX)
double precision coorg(NDIM,npgeo)
@@ -68,10 +68,12 @@
!---- create global mesh numbering
- write(IOUT,*)
- write(IOUT,*)
- write(IOUT,*) 'Generating global mesh numbering (fast version)...'
- write(IOUT,*)
+ if(myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*)
+ write(IOUT,*) 'Generating global mesh numbering (fast version)...'
+ write(IOUT,*)
+ endif
nxyz = NGLLX*NGLLZ
ntot = nxyz*nspec
@@ -202,7 +204,7 @@
! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-! recuperer resultat a mon format
+! get result in my format
do ispec=1,nspec
ieoff = nxyz*(ispec - 1)
ilocnum = 0
@@ -224,15 +226,15 @@
deallocate(work)
deallocate(iwork)
-! verification de la coherence de la numerotation generee
- if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) then
- call exit_MPI('Error while generating global numbering')
+! check the numbering obtained
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) call exit_MPI('Error while generating global numbering')
+
+ if(myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Total number of points of the global mesh: ',npoin
+ write(IOUT,*)
endif
- write(IOUT,*)
- write(IOUT,*) 'Total number of points of the global mesh: ',npoin
- write(IOUT,*)
-
end subroutine createnum_fast
Modified: seismo/2D/SPECFEM2D/trunk/createnum_slow.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/createnum_slow.f90 2008-07-30 00:05:50 UTC (rev 12494)
+++ seismo/2D/SPECFEM2D/trunk/createnum_slow.f90 2008-07-30 01:32:28 UTC (rev 12495)
@@ -40,7 +40,7 @@
!
!========================================================================
- subroutine createnum_slow(knods,ibool,npoin,nspec,ngnod)
+ subroutine createnum_slow(knods,ibool,npoin,nspec,ngnod,myrank,ipass)
! generate the global numbering
@@ -48,7 +48,7 @@
include "constants.h"
- integer npoin,nspec,ngnod
+ integer npoin,nspec,ngnod,myrank,ipass
integer knods(ngnod,nspec),ibool(NGLLX,NGLLZ,nspec)
@@ -61,9 +61,11 @@
!---- create global mesh numbering
- write(IOUT,*)
- write(IOUT,*) 'Generating global mesh numbering (slow version)...'
- write(IOUT,*)
+ if(myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Generating global mesh numbering (slow version)...'
+ write(IOUT,*)
+ endif
npoin = 0
npedge = 0
@@ -268,14 +270,10 @@
endif
! verifier que le point de depart n'existe pas deja
- if(ibool(iloc,jloc,numelem) /= 0) then
- call exit_MPI('point genere deux fois')
- endif
+ if(ibool(iloc,jloc,numelem) /= 0) call exit_MPI('point generated twice')
! verifier que le point d'arrivee existe bien deja
- if(ibool(i2,j2,num2) == 0) then
- call exit_MPI('point inconnu dans le maillage')
- endif
+ if(ibool(i2,j2,num2) == 0) call exit_MPI('unknown point in the mesh')
! affecter le meme numero
ibool(iloc,jloc,numelem) = ibool(i2,j2,num2)
@@ -309,17 +307,16 @@
enddo
! verification de la coherence de la numerotation generee
- if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) then
- call exit_MPI('Error while generating global numbering')
+ if(minval(ibool) /= 1 .or. maxval(ibool) /= npoin) call exit_MPI('Error while generating global numbering')
+
+ if(myrank == 0 .and. ipass == 1) then
+ write(IOUT,*) 'Total number of points of the global mesh: ',npoin,' distributed as follows:'
+ write(IOUT,*)
+ write(IOUT,*) 'Number of interior points: ',npoin-npedge-npcorn
+ write(IOUT,*) 'Number of edge points (without corners): ',npedge
+ write(IOUT,*) 'Number of corner points: ',npcorn
+ write(IOUT,*)
endif
- write(IOUT,*) 'Total number of points of the global mesh: ',npoin
- write(IOUT,*) 'distributed as follows:'
- write(IOUT,*)
- write(IOUT,*) 'Number of interior points: ',npoin-npedge-npcorn
- write(IOUT,*) 'Number of edge points (without corners): ',npedge
- write(IOUT,*) 'Number of corner points: ',npcorn
- write(IOUT,*)
-
end subroutine createnum_slow
Modified: seismo/2D/SPECFEM2D/trunk/gmat01.f90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/gmat01.f90 2008-07-30 00:05:50 UTC (rev 12494)
+++ seismo/2D/SPECFEM2D/trunk/gmat01.f90 2008-07-30 01:32:28 UTC (rev 12495)
@@ -40,7 +40,7 @@
!
!========================================================================
- subroutine gmat01(density_array,elastcoef,numat)
+ subroutine gmat01(density_array,elastcoef,numat,myrank,ipass)
! read properties of a 2D isotropic or anisotropic linear elastic element
@@ -51,7 +51,7 @@
character(len=80) datlin
double precision lambdaplus2mu,kappa
- integer numat
+ integer numat,myrank,ipass
double precision density_array(numat),elastcoef(4,numat)
integer in,n,indic
@@ -65,12 +65,12 @@
density_array(:) = zero
elastcoef(:,:) = zero
- write(iout,100) numat
+ if(myrank == 0 .and. ipass == 1) write(IOUT,100) numat
- read(iin ,"(a80)") datlin
+ read(IIN,"(a80)") datlin
do in = 1,numat
- read(iin ,*) n,indic,density,val1,val2,val3,val4
+ read(IIN,*) n,indic,density,val1,val2,val3,val4
if(n<1 .or. n>numat) call exit_MPI('Wrong material set number')
@@ -132,18 +132,20 @@
density_array(n) = density
!
-!---- check the input
+!---- check what has been read
!
+ if(myrank == 0 .and. ipass == 1) then
if(indic == 1) then
! material can be acoustic (fluid) or elastic (solid)
if(elastcoef(2,n) > TINYVAL) then
- write(iout,200) n,cp,cs,density,poisson,lambda,mu,kappa,young
+ write(IOUT,200) n,cp,cs,density,poisson,lambda,mu,kappa,young
else
- write(iout,300) n,cp,density,kappa
+ write(IOUT,300) n,cp,density,kappa
endif
else
- write(iout,400) n,c11,c13,c33,c44,density,sqrt(c33/density),sqrt(c11/density),sqrt(c44/density),sqrt(c44/density)
+ write(IOUT,400) n,c11,c13,c33,c44,density,sqrt(c33/density),sqrt(c11/density),sqrt(c44/density),sqrt(c44/density)
endif
+ endif
enddo
Modified: seismo/2D/SPECFEM2D/trunk/locate_receivers.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/locate_receivers.F90 2008-07-30 00:05:50 UTC (rev 12494)
+++ seismo/2D/SPECFEM2D/trunk/locate_receivers.F90 2008-07-30 01:32:28 UTC (rev 12495)
@@ -46,7 +46,7 @@
subroutine locate_receivers(ibool,coord,nspec,npoin,xigll,zigll,nrec,nrecloc,recloc,which_proc_receiver,nproc,myrank, &
st_xval,st_zval,ispec_selected_rec, &
- xi_receiver,gamma_receiver,station_name,network_name,x_source,z_source,coorg,knods,ngnod,npgeo)
+ xi_receiver,gamma_receiver,station_name,network_name,x_source,z_source,coorg,knods,ngnod,npgeo,ipass)
implicit none
@@ -55,7 +55,7 @@
include "mpif.h"
#endif
- integer nrec,nspec,npoin,ngnod,npgeo
+ integer nrec,nspec,npoin,ngnod,npgeo,ipass
integer, intent(in) :: nproc, myrank
integer knods(ngnod,nspec)
@@ -105,7 +105,7 @@
! **************
- if (myrank == 0) then
+ if (myrank == 0 .and. ipass == 1) then
write(IOUT,*)
write(IOUT,*) '********************'
write(IOUT,*) ' locating receivers'
@@ -228,8 +228,8 @@
do irec = 1, nrec
which_proc_receiver(irec:irec) = minloc(gather_final_distance(irec,:)) - 1
- end do
-end if
+ enddo
+endif
call MPI_BCAST(which_proc_receiver(1),nrec,MPI_INTEGER,0,MPI_COMM_WORLD,ierror)
@@ -250,13 +250,11 @@
if ( which_proc_receiver(irec) == myrank ) then
nrecloc = nrecloc + 1
recloc(nrecloc) = irec
- end if
+ endif
+enddo
-end do
+if (myrank == 0 .and. ipass == 1) then
-
-if ( myrank == 0 ) then
-
do irec = 1, nrec
write(IOUT,*)
write(IOUT,*) 'Station # ',irec,' ',station_name(irec),network_name(irec)
@@ -273,19 +271,14 @@
gather_gamma_receiver(irec,which_proc_receiver(irec)+1)
write(IOUT,*)
- end do
+ enddo
-
-! display maximum error for all the receivers
- !write(IOUT,*) 'maximum error in location of all the receivers: ',sngl(maxval(final_distance(:))),' m'
-
write(IOUT,*)
write(IOUT,*) 'end of receiver detection'
write(IOUT,*)
-end if
+endif
-
! deallocate arrays
deallocate(final_distance)
@@ -293,6 +286,5 @@
call MPI_BARRIER(MPI_COMM_WORLD,ierror)
#endif
-
end subroutine locate_receivers
Modified: seismo/2D/SPECFEM2D/trunk/locate_source_force.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/locate_source_force.F90 2008-07-30 00:05:50 UTC (rev 12494)
+++ seismo/2D/SPECFEM2D/trunk/locate_source_force.F90 2008-07-30 01:32:28 UTC (rev 12495)
@@ -41,7 +41,7 @@
!========================================================================
subroutine locate_source_force(coord,ibool,npoin,nspec,x_source,z_source,ix_source,iz_source, &
- ispec_source,iglob_source,is_proc_source,nb_proc_source)
+ ispec_source,iglob_source,is_proc_source,nb_proc_source,ipass)
!
!----- calculer la position reelle de la source
@@ -54,7 +54,7 @@
include "mpif.h"
#endif
- integer npoin,nspec
+ integer npoin,nspec,ipass
integer ibool(NGLLX,NGLLZ,nspec)
double precision x_source,z_source
@@ -121,7 +121,7 @@
#endif
! check if this process contains the source
- if ( dist_glob == distminmax ) is_proc_source = 1
+ if (dist_glob == distminmax) is_proc_source = 1
#ifdef USE_MPI
! determining the number of processes that contain the source (useful when the source is located on an interface)
@@ -129,24 +129,19 @@
#else
nb_proc_source = is_proc_source
-
#endif
- if ( nb_proc_source < 1 ) then
- call exit_MPI('error locating force source')
- end if
+ if (nb_proc_source < 1) call exit_MPI('error locating force source')
- if ( is_proc_source == 1 ) then
- write(iout,200)
-
- write(iout,"(1x,f12.3,1x,f12.3,1x,f12.3,1x,f12.3,f12.3,1x,i5.5)") x_source,z_source, &
+ if (is_proc_source == 1 .and. ipass == 1) then
+ write(IOUT,200)
+ write(IOUT,"(1x,f12.3,1x,f12.3,1x,f12.3,1x,f12.3,f12.3,1x,i5.5)") x_source,z_source, &
coord(1,iglob_source),coord(2,iglob_source),distmin,nb_proc_source
- write(iout,*)
- write(iout,*)
- write(iout,"('Maximum distance between asked and real =',f12.3)") distminmax
+ write(IOUT,*)
+ write(IOUT,*)
+ write(IOUT,"('Maximum distance between asked and real =',f12.3)") distminmax
+ endif
- end if
-
#ifdef USE_MPI
call MPI_BARRIER(MPI_COMM_WORLD,ierror)
#endif
Modified: seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.F90 2008-07-30 00:05:50 UTC (rev 12494)
+++ seismo/2D/SPECFEM2D/trunk/locate_source_moment_tensor.F90 2008-07-30 01:32:28 UTC (rev 12495)
@@ -45,7 +45,7 @@
!----
subroutine locate_source_moment_tensor(ibool,coord,nspec,npoin,xigll,zigll,x_source,z_source, &
- ispec_selected_source,is_proc_source,nb_proc_source,nproc,myrank,xi_source,gamma_source,coorg,knods,ngnod,npgeo)
+ ispec_selected_source,is_proc_source,nb_proc_source,nproc,myrank,xi_source,gamma_source,coorg,knods,ngnod,npgeo,ipass)
implicit none
@@ -54,7 +54,7 @@
include "mpif.h"
#endif
- integer nspec,npoin,ngnod,npgeo
+ integer nspec,npoin,ngnod,npgeo,ipass
integer knods(ngnod,nspec)
double precision coorg(NDIM,npgeo)
@@ -90,13 +90,13 @@
! **************
- if ( myrank == 0 .or. nproc == 1 ) then
+ if ((myrank == 0 .or. nproc == 1) .and. ipass == 1) then
write(IOUT,*)
write(IOUT,*) '*******************************'
write(IOUT,*) ' locating moment-tensor source'
write(IOUT,*) '*******************************'
write(IOUT,*)
- end if
+ endif
! set distance to huge initial value
distmin = HUGEVAL
@@ -158,10 +158,10 @@
if ( myrank /= locate_is_proc_source(1) ) then
is_proc_source = 0
- end if
+ endif
nb_proc_source = 1
- end if
+ endif
#endif
@@ -214,7 +214,7 @@
! compute final distance between asked and found
final_distance = sqrt((x_source-x)**2 + (z_source-z)**2)
- if ( is_proc_source == 1 ) then
+ if (is_proc_source == 1 .and. ipass == 1) then
write(IOUT,*)
write(IOUT,*) 'Moment-tensor source:'
@@ -230,7 +230,7 @@
write(IOUT,*)
write(IOUT,*) 'end of moment-tensor source detection'
write(IOUT,*)
- end if
+ endif
#ifdef USE_MPI
call MPI_BARRIER(MPI_COMM_WORLD,ierror)
Modified: seismo/2D/SPECFEM2D/trunk/meshfem2D.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/meshfem2D.F90 2008-07-30 00:05:50 UTC (rev 12494)
+++ seismo/2D/SPECFEM2D/trunk/meshfem2D.F90 2008-07-30 01:32:28 UTC (rev 12495)
@@ -274,7 +274,7 @@
else
do i = 1, 5
metis_options = iachar(partitioning_strategy(i:i)) - iachar('0')
- end do
+ enddo
endif
case(3)
@@ -382,8 +382,8 @@
elmnts(num_elmnt*ngnod+2) = j*(nxread+1) + (i-1) + 1
elmnts(num_elmnt*ngnod+3) = j*(nxread+1) + (i-1)
num_elmnt = num_elmnt + 1
- end do
- end do
+ enddo
+ enddo
else
num_elmnt = 0
do j = 1, nzread
@@ -398,8 +398,8 @@
elmnts(num_elmnt*ngnod+7) = (nxread+1)*(nzread+1) + nxread*(nzread+1) + (j-1)*(nxread*2+1) + (i-1)*2
elmnts(num_elmnt*ngnod+8) = (nxread+1)*(nzread+1) + nxread*(nzread+1) + (j-1)*(nxread*2+1) + (i-1)*2 + 1
num_elmnt = num_elmnt + 1
- end do
- end do
+ enddo
+ enddo
endif
endif
@@ -765,8 +765,8 @@
nodes_coords(1, num_node) = x(i,j)
nodes_coords(2, num_node) = z(i,j)
- end do
- end do
+ enddo
+ enddo
else
do j = 0, nz
@@ -775,8 +775,8 @@
nodes_coords(1, num_node) = x(i,j)
nodes_coords(2, num_node) = z(i,j)
- end do
- end do
+ enddo
+ enddo
endif
else
@@ -821,7 +821,7 @@
acoustic_surface(3,nelem_acoustic_surface) = elmnts(3+ngnod*((j-1)*nxread+i-1))
acoustic_surface(4,nelem_acoustic_surface) = elmnts(2+ngnod*((j-1)*nxread+i-1))
endif
- end do
+ enddo
endif
@@ -870,8 +870,8 @@
abs_surface(3,nelemabs) = elmnts(0+ngnod*(inumelem-1))
abs_surface(4,nelemabs) = elmnts(3+ngnod*(inumelem-1))
endif
- end do
- end do
+ enddo
+ enddo
endif
endif
@@ -959,7 +959,7 @@
allocate(elmnts_bis(0:ESIZE*nelmnts-1))
do i = 0, nelmnts-1
elmnts_bis(i*esize:i*esize+esize-1) = elmnts(i*ngnod:i*ngnod+esize-1)
- end do
+ enddo
if ( nproc > 1 ) then
call mesh2dual_ncommonnodes(nelmnts, (nxread+1)*(nzread+1), elmnts_bis, xadj, adjncy, nnodes_elmnts, nodes_elmnts,1)
@@ -989,7 +989,7 @@
do iproc = 0, nproc-2
part(iproc*floor(real(nelmnts)/real(nproc)):(iproc+1)*floor(real(nelmnts)/real(nproc))-1) = iproc
- end do
+ enddo
part(floor(real(nelmnts)/real(nproc))*(nproc-1):nelmnts-1) = nproc - 1
case(2)
@@ -1041,7 +1041,7 @@
nodes_elmnts(elmnts(i)*nsize+nnodes_elmnts(elmnts(i))) = i/ngnod
nnodes_elmnts(elmnts(i)) = nnodes_elmnts(elmnts(i)) + 1
- end do
+ enddo
else
if ( nproc < 2 ) then
allocate(nnodes_elmnts(0:nnodes-1))
@@ -1052,13 +1052,12 @@
nodes_elmnts(elmnts(i)*nsize+nnodes_elmnts(elmnts(i))) = i/ngnod
nnodes_elmnts(elmnts(i)) = nnodes_elmnts(elmnts(i)) + 1
- end do
+ enddo
endif
endif
-
! local number of each node for each partition
call Construct_glob2loc_nodes(nelmnts, nnodes, nnodes_elmnts, nodes_elmnts, part, nproc, &
glob2loc_nodes_nparts, glob2loc_nodes_parts, glob2loc_nodes)
@@ -1072,10 +1071,8 @@
call Construct_interfaces(nelmnts, nproc, part, elmnts, xadj, adjncy, tab_interfaces, &
tab_size_interfaces, ninterfaces, nb_materials, cs, num_material)
endif
- print *, '04'
allocate(my_interfaces(0:ninterfaces-1))
allocate(my_nb_interfaces(0:ninterfaces-1))
- print *, '05'
endif
! setting absorbing boundaries by elements instead of edges
@@ -1086,7 +1083,6 @@
nedges_coupled, edges_coupled, nb_materials, cs, num_material, &
nelmnts, &
elmnts, ngnod)
- print *, 'nelemabs_merge', nelemabs_merge
endif
! *** generate the databases for the solver
@@ -1208,7 +1204,6 @@
else
write(15,*) 'Interfaces:'
write(15,*) 0, 0
-
endif
@@ -1230,7 +1225,7 @@
write(15,*) 'List of acoustic elastic coupled edges:'
call write_fluidsolid_edges_database(15, nedges_coupled, nedges_coupled_loc, &
edges_coupled, glob2loc_elmnts, part, iproc, 2)
- end do
+ enddo
! print position of the source
@@ -1290,11 +1285,17 @@
enddo
close(15)
+
endif
print *
+ if (nproc == 1) then
+ print *,'This will be a serial simulation'
+ else
+ print *,'This will be a parallel simulation on ',nproc,' processors'
+ endif
+ print *
-
end program meshfem2D
! *******************
Modified: seismo/2D/SPECFEM2D/trunk/plotpost.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/plotpost.F90 2008-07-30 00:05:50 UTC (rev 12494)
+++ seismo/2D/SPECFEM2D/trunk/plotpost.F90 2008-07-30 01:32:28 UTC (rev 12495)
@@ -68,8 +68,7 @@
coorg_send_ps_free_surface,coorg_recv_ps_free_surface, &
d1_coorg_send_ps_vector_field,d1_coorg_recv_ps_vector_field, &
d2_coorg_send_ps_vector_field,d2_coorg_recv_ps_vector_field, &
- coorg_send_ps_vector_field,coorg_recv_ps_vector_field &
-)
+ coorg_send_ps_vector_field,coorg_recv_ps_vector_field)
!
! PostScript display routine
@@ -150,10 +149,6 @@
double precision, dimension(:,:), allocatable :: coorg_send
double precision, dimension(:,:), allocatable :: coorg_recv
- integer, dimension(:), allocatable :: color_send
- integer, dimension(:), allocatable :: color_recv
- double precision, dimension(:,:), allocatable :: RGB_send
- double precision, dimension(:,:), allocatable :: RGB_recv
integer :: nspec_recv
integer :: buffer_offset, RGB_offset
@@ -1626,10 +1621,6 @@
!
if(modelvect) then
- if ( myrank /= 0 ) then
- !allocate(coorg_send(2,nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4))
- !allocate(RGB_send(1,nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)))
- endif
buffer_offset = 0
RGB_offset = 0
@@ -1733,8 +1724,6 @@
do iproc = 1, nproc-1
call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
- !allocate(coorg_recv(2,nspec_recv*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4))
- !allocate(RGB_recv(1,nspec_recv*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)))
call MPI_RECV (coorg_recv_ps_velocity_model(1,1), &
2*nspec_recv*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4, &
MPI_DOUBLE_PRECISION, iproc, 42, MPI_COMM_WORLD, request_mpi_status, ier)
@@ -1764,9 +1753,6 @@
enddo
enddo
- !deallocate(coorg_recv)
- !deallocate(RGB_recv)
-
enddo
else
call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 42, MPI_COMM_WORLD, ier)
@@ -1774,10 +1760,6 @@
MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
call MPI_SEND (RGB_send_ps_velocity_model(1,1), nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp), &
MPI_DOUBLE_PRECISION, 0, 42, MPI_COMM_WORLD, ier)
-
- !deallocate(coorg_send)
- !deallocate(RGB_send)
-
endif
@@ -1796,47 +1778,12 @@
write(24,*) '%'
endif
- if ( myrank /= 0 ) then
-
- if ( ngnod == 4 ) then
- if ( numbers == 1 ) then
- !allocate(coorg_send(2,nspec*5))
- if ( colors == 1 ) then
- !allocate(color_send(2*nspec))
- else
- !allocate(color_send(1*nspec))
- endif
- else
- !allocate(coorg_send(2,nspec*6))
- if ( colors == 1 ) then
- !allocate(color_send(1*nspec))
- endif
- endif
- else
- if ( numbers == 1 ) then
- !allocate(coorg_send(2,nspec*((pointsdisp-1)*3+max(0,pointsdisp-2)+1+1)))
- if ( colors == 1 ) then
- !allocate(color_send(2*nspec))
- else
- !allocate(color_send(1*nspec))
- endif
- else
- !allocate(coorg_send(2,nspec*((pointsdisp-1)*3+max(0,pointsdisp-2)+1)))
- if ( colors == 1 ) then
- !allocate(color_send(1*nspec))
- endif
- endif
- endif
-
- endif
buffer_offset = 0
RGB_offset = 0
do ispec=1,nspec
- if ( myrank == 0 ) then
- write(24,*) '% elem ',ispec
- endif
+ if ( myrank == 0 ) write(24,*) '% elem ',ispec
do i=1,pointsdisp
do j=1,pointsdisp
@@ -2077,10 +2024,6 @@
nb_color_per_elem = nb_color_per_elem + 1
endif
- !allocate(coorg_recv(2,nspec_recv*nb_coorg_per_elem))
- if ( nb_color_per_elem > 0 ) then
- !allocate(color_recv(nspec_recv*nb_color_per_elem))
- endif
call MPI_RECV (coorg_recv_ps_element_mesh(1,1), 2*nspec_recv*nb_coorg_per_elem, &
MPI_DOUBLE_PRECISION, iproc, 43, MPI_COMM_WORLD, request_mpi_status, ier)
call MPI_RECV (color_recv_ps_element_mesh(1), nspec_recv*nb_coorg_per_elem, &
@@ -2135,7 +2078,7 @@
else
RGB_offset = RGB_offset + 1
write(24,679) red(color_recv_ps_element_mesh(RGB_offset)),&
- green(color_recv_ps_element_mesh(RGB_offset)),&
+ green(color_recv_ps_element_mesh(RGB_offset)),&
blue(color_recv_ps_element_mesh(RGB_offset))
endif
endif
@@ -2156,9 +2099,6 @@
enddo
- !deallocate(coorg_recv)
- !deallocate(color_recv)
-
enddo
else
call MPI_SEND (nspec, 1, MPI_INTEGER, 0, 43, MPI_COMM_WORLD, ier)
@@ -2185,9 +2125,6 @@
MPI_INTEGER, 0, 43, MPI_COMM_WORLD, ier)
endif
- !deallocate(coorg_send)
- !deallocate(color_send)
-
endif
#endif
@@ -2214,9 +2151,6 @@
write(24,*) '% 0.02 CM setlinewidth'
endif
- if ( myrank /= 0 .and. anyabs ) then
- !allocate(coorg_send(4,4*nelemabs))
- endif
buffer_offset = 0
if ( anyabs ) then
@@ -2273,7 +2207,6 @@
do iproc = 1, nproc-1
call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 44, MPI_COMM_WORLD, request_mpi_status, ier)
if ( nspec_recv > 0 ) then
- !allocate(coorg_recv(4,nspec_recv))
call MPI_RECV (coorg_recv_ps_abs(1,1), 4*nspec_recv, &
MPI_DOUBLE_PRECISION, iproc, 44, MPI_COMM_WORLD, request_mpi_status, ier)
@@ -2283,7 +2216,6 @@
write(24,602) coorg_recv_ps_abs(1,buffer_offset), coorg_recv_ps_abs(2,buffer_offset), &
coorg_recv_ps_abs(3,buffer_offset), coorg_recv_ps_abs(4,buffer_offset)
enddo
- !deallocate(coorg_recv)
endif
enddo
else
@@ -2291,7 +2223,6 @@
if ( buffer_offset > 0 ) then
call MPI_SEND (coorg_send_ps_abs(1,1), 4*buffer_offset, &
MPI_DOUBLE_PRECISION, 0, 44, MPI_COMM_WORLD, ier)
- !deallocate(coorg_send)
endif
endif
@@ -2299,8 +2230,8 @@
#endif
if ( myrank == 0 ) then
- write(24,*) '0 setgray'
- write(24,*) '0.01 CM setlinewidth'
+ write(24,*) '0 setgray'
+ write(24,*) '0.01 CM setlinewidth'
endif
endif
@@ -2322,9 +2253,6 @@
write(24,*) '% 0.02 CM setlinewidth'
endif
- if ( myrank /= 0 .and. nelem_acoustic_surface > 0 ) then
- !allocate(coorg_send(4,4*nelem_acoustic_surface))
- endif
buffer_offset = 0
if ( nelem_acoustic_surface > 0 ) then
@@ -2358,7 +2286,6 @@
do iproc = 1, nproc-1
call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 44, MPI_COMM_WORLD, request_mpi_status, ier)
if ( nspec_recv > 0 ) then
- !allocate(coorg_recv(4,nspec_recv))
call MPI_RECV (coorg_recv_ps_free_surface(1,1), 4*nspec_recv, &
MPI_DOUBLE_PRECISION, iproc, 44, MPI_COMM_WORLD, request_mpi_status, ier)
@@ -2368,7 +2295,6 @@
write(24,602) coorg_recv_ps_free_surface(1,buffer_offset), coorg_recv_ps_free_surface(2,buffer_offset), &
coorg_recv_ps_free_surface(3,buffer_offset), coorg_recv_ps_free_surface(4,buffer_offset)
enddo
- !deallocate(coorg_recv)
endif
enddo
else
@@ -2376,7 +2302,6 @@
if ( buffer_offset > 0 ) then
call MPI_SEND (coorg_send_ps_free_surface(1,1), 4*buffer_offset, &
MPI_DOUBLE_PRECISION, 0, 44, MPI_COMM_WORLD, ier)
- !deallocate(coorg_send)
endif
endif
@@ -2419,9 +2344,7 @@
iedge = fluid_solid_acoustic_iedge(inum)
! use pink color
- if ( myrank == 0 ) then
- write(24,*) '1 0.75 0.8 RG'
- endif
+ if ( myrank == 0 ) write(24,*) '1 0.75 0.8 RG'
if(iedge == ITOP) then
ideb = 3
@@ -2531,16 +2454,16 @@
pointsdisp_loop = pointsdisp
endif
- if ( myrank /= 0 ) then
- !allocate(coorg_send(8,nspec*pointsdisp_loop*pointsdisp_loop))
-
- endif
buffer_offset = 0
do ispec=1,nspec
! interpolation on a uniform grid
- if(mod(ispec,1000) == 0) write(IOUT,*) 'Interpolation uniform grid element ',ispec, myrank
+#ifdef USE_MPI
+ if(myrank == 0 .and. mod(ispec,1000) == 0) write(IOUT,*) 'Interpolation uniform grid element ',ispec,' on processor 0'
+#else
+ if(mod(ispec,1000) == 0) write(IOUT,*) 'Interpolation uniform grid element ',ispec
+#endif
do i=1,pointsdisp_loop
do j=1,pointsdisp_loop
@@ -2605,7 +2528,6 @@
write(postscript_line,700) xb,zb,xa,za,x2,z2,x1,z1
! suppress useless white spaces to make PostScript file smaller
-
! suppress leading white spaces again, if any
postscript_line = adjustl(postscript_line)
@@ -2648,7 +2570,6 @@
do iproc = 1, nproc-1
call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 46, MPI_COMM_WORLD, request_mpi_status, ier)
if ( nspec_recv > 0 ) then
- !allocate(coorg_recv(8,nspec_recv))
call MPI_RECV (coorg_recv_ps_vector_field(1,1), 8*nspec_recv, &
MPI_DOUBLE_PRECISION, iproc, 46, MPI_COMM_WORLD, request_mpi_status, ier)
@@ -2660,8 +2581,8 @@
coorg_recv_ps_vector_field(3,buffer_offset), coorg_recv_ps_vector_field(4,buffer_offset), &
coorg_recv_ps_vector_field(5,buffer_offset), coorg_recv_ps_vector_field(6,buffer_offset), &
coorg_recv_ps_vector_field(7,buffer_offset), coorg_recv_ps_vector_field(8,buffer_offset)
- ! suppress useless white spaces to make PostScript file smaller
+ ! suppress useless white spaces to make PostScript file smaller
! suppress leading white spaces again, if any
postscript_line = adjustl(postscript_line)
@@ -2680,7 +2601,6 @@
ch2(index_char) = ch1(line_length)
write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
enddo
- !deallocate(coorg_recv)
endif
enddo
else
@@ -2688,7 +2608,6 @@
if ( buffer_offset > 0 ) then
call MPI_SEND (coorg_send_ps_vector_field(1,1), 8*buffer_offset, &
MPI_DOUBLE_PRECISION, 0, 46, MPI_COMM_WORLD, ier)
- !deallocate(coorg_send)
endif
endif
@@ -2699,10 +2618,6 @@
! draw the vectors at the nodes of the mesh if we do not interpolate the display on a regular grid
else
- if ( myrank /= 0 ) then
- !allocate(coorg_send(8,npoin))
-
- endif
buffer_offset = 0
do ipoin=1,npoin
@@ -2747,7 +2662,6 @@
write(postscript_line,700) xb,zb,xa,za,x2,z2,x1,z1
! suppress useless white spaces to make PostScript file smaller
-
! suppress leading white spaces again, if any
postscript_line = adjustl(postscript_line)
@@ -2787,7 +2701,6 @@
do iproc = 1, nproc-1
call MPI_RECV (nspec_recv, 1, MPI_INTEGER, iproc, 47, MPI_COMM_WORLD, request_mpi_status, ier)
if ( nspec_recv > 0 ) then
- !allocate(coorg_recv(8,nspec_recv))
call MPI_RECV (coorg_recv_ps_vector_field(1,1), 8*nspec_recv, &
MPI_DOUBLE_PRECISION, iproc, 47, MPI_COMM_WORLD, request_mpi_status, ier)
@@ -2799,8 +2712,8 @@
coorg_recv_ps_vector_field(3,buffer_offset), coorg_recv_ps_vector_field(4,buffer_offset), &
coorg_recv_ps_vector_field(5,buffer_offset), coorg_recv_ps_vector_field(6,buffer_offset), &
coorg_recv_ps_vector_field(7,buffer_offset), coorg_recv_ps_vector_field(8,buffer_offset)
- ! suppress useless white spaces to make PostScript file smaller
+ ! suppress useless white spaces to make PostScript file smaller
! suppress leading white spaces again, if any
postscript_line = adjustl(postscript_line)
@@ -2819,7 +2732,6 @@
ch2(index_char) = ch1(line_length)
write(24,"(100(a1))") (ch2(ii), ii=1,index_char)
enddo
- !deallocate(coorg_recv)
endif
enddo
else
@@ -2827,13 +2739,11 @@
if ( buffer_offset > 0 ) then
call MPI_SEND (coorg_send_ps_vector_field(1,1), 8*buffer_offset, &
MPI_DOUBLE_PRECISION, 0, 47, MPI_COMM_WORLD, ier)
- !deallocate(coorg_send)
endif
endif
#endif
-
endif
if ( myrank == 0 ) then
Modified: seismo/2D/SPECFEM2D/trunk/specfem2D.F90
===================================================================
--- seismo/2D/SPECFEM2D/trunk/specfem2D.F90 2008-07-30 00:05:50 UTC (rev 12494)
+++ seismo/2D/SPECFEM2D/trunk/specfem2D.F90 2008-07-30 01:32:28 UTC (rev 12495)
@@ -454,11 +454,18 @@
else
NUMBER_OF_PASSES = 1
endif
-
#endif
! determine if we write to file instead of standard output
- if(IOUT /= ISTANDARD_OUTPUT) open(IOUT,file='simulation_results.txt',status='unknown')
+ if(IOUT /= ISTANDARD_OUTPUT) then
+#ifdef USE_MPI
+ write(prname,240) myrank
+ 240 format('simulation_results',i5.5,'.txt')
+#else
+ prname = 'simulation_results.txt'
+#endif
+ open(IOUT,file=prname,status='unknown',action='write')
+ endif
! reduction of cache misses inner/outer in two passes
do ipass = 1,NUMBER_OF_PASSES
@@ -480,9 +487,9 @@
!
!---- print the date, time and start-up banner
!
- if (myrank == 0) call datim(simulation_title)
+ if (myrank == 0 .and. ipass == 1) call datim(simulation_title)
- if (myrank == 0) then
+ if (myrank == 0 .and. ipass == 1) then
write(IOUT,*)
write(IOUT,*)
write(IOUT,*) '*********************'
@@ -528,16 +535,18 @@
read(IIN,*) assign_external_model,outputgrid,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON
!---- check parameters read
- write(IOUT,200) npgeo,NDIM
- write(IOUT,600) NTSTEP_BETWEEN_OUTPUT_INFO,colors,numbers
- write(IOUT,700) seismotype,anglerec
- write(IOUT,750) initialfield,add_Bielak_conditions,assign_external_model,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON,outputgrid
- write(IOUT,800) imagetype,100.d0*cutsnaps,subsamp
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,200) npgeo,NDIM
+ write(IOUT,600) NTSTEP_BETWEEN_OUTPUT_INFO,colors,numbers
+ write(IOUT,700) seismotype,anglerec
+ write(IOUT,750) initialfield,add_Bielak_conditions,assign_external_model,TURN_ANISOTROPY_ON,TURN_ATTENUATION_ON,outputgrid
+ write(IOUT,800) imagetype,100.d0*cutsnaps,subsamp
+ endif
!---- read time step
read(IIN,"(a80)") datlin
read(IIN,*) NSTEP,deltat
- if (myrank == 0) write(IOUT,703) NSTEP,deltat,NSTEP*deltat
+ if (myrank == 0 .and. ipass == 1) write(IOUT,703) NSTEP,deltat,NSTEP*deltat
NTSTEP_BETWEEN_OUTPUT_SEISMO = min(NSTEP,NTSTEP_BETWEEN_OUTPUT_INFO)
@@ -662,8 +671,10 @@
!
!---- print element group main parameters
!
- write(IOUT,107)
- write(IOUT,207) nspec,ngnod,NGLLX,NGLLZ,NGLLX*NGLLZ,pointsdisp,numat,nelemabs
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,107)
+ write(IOUT,207) nspec,ngnod,NGLLX,NGLLZ,NGLLX*NGLLZ,pointsdisp,numat,nelemabs
+ endif
! set up Gauss-Lobatto-Legendre derivation matrices
call define_derivation_matrices(xigll,zigll,wxgll,wzgll,hprime_xx,hprime_zz,hprimewgll_xx,hprimewgll_zz)
@@ -671,7 +682,7 @@
!
!---- read the material properties
!
- call gmat01(density,elastcoef,numat)
+ call gmat01(density,elastcoef,numat,myrank,ipass)
!
!---- read spectral macrobloc data
@@ -777,7 +788,6 @@
!
!---- read absorbing boundary data
!
-
read(IIN,"(a80)") datlin
if(anyabs) then
do inum = 1,nelemabs
@@ -796,8 +806,10 @@
codeabs(ITOP,inum) = codeabsread(3)
codeabs(ILEFT,inum) = codeabsread(4)
enddo
- write(IOUT,*)
- write(IOUT,*) 'Number of absorbing elements: ',nelemabs
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Number of absorbing elements: ',nelemabs
+ endif
endif
!
@@ -813,11 +825,15 @@
if(ipass == 1) allocate(acoustic_surface(5,nelem_acoustic_surface))
call construct_acoustic_surface ( nspec, ngnod, knods, nelem_acoustic_surface, &
acoustic_edges, acoustic_surface)
- write(IOUT,*)
- write(IOUT,*) 'Number of free surface elements: ',nelem_acoustic_surface
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Number of free surface elements: ',nelem_acoustic_surface
+ endif
else
- if(ipass == 1) allocate(acoustic_edges(4,1))
- if(ipass == 1) allocate(acoustic_surface(5,1))
+ if(ipass == 1) then
+ allocate(acoustic_edges(4,1))
+ allocate(acoustic_surface(5,1))
+ endif
endif
!
@@ -872,9 +888,9 @@
! "slow and clean" or "quick and dirty" version
if(FAST_NUMBERING) then
- call createnum_fast(knods,ibool,shape2D,coorg,npoin,npgeo,nspec,ngnod)
+ call createnum_fast(knods,ibool,shape2D,coorg,npoin,npgeo,nspec,ngnod,myrank,ipass)
else
- call createnum_slow(knods,ibool,npoin,nspec,ngnod)
+ call createnum_slow(knods,ibool,npoin,nspec,ngnod,myrank,ipass)
endif
! create a new indirect addressing array to reduce cache misses in memory access in the solver
@@ -984,7 +1000,7 @@
enddo
close(IIN)
- if (myrank == 0) then
+ if (myrank == 0 .and. ipass == 1) then
write(IOUT,*)
write(IOUT,*) 'Total number of receivers = ',nrec
write(IOUT,*)
@@ -1061,7 +1077,7 @@
!
!--- save the grid of points in a file
!
- if(outputgrid) then
+ if(outputgrid .and. myrank == 0 .and. ipass == 1) then
write(IOUT,*)
write(IOUT,*) 'Saving the grid in a text file...'
write(IOUT,*)
@@ -1077,15 +1093,17 @@
!
!----- plot the GLL mesh in a Gnuplot file
!
- if(gnuplot) call plotgll(knods,ibool,coorg,coord,npoin,npgeo,ngnod,nspec)
+ if(gnuplot .and. myrank == 0 .and. ipass == 1) call plotgll(knods,ibool,coorg,coord,npoin,npgeo,ngnod,nspec)
!
!---- assign external velocity and density model if needed
!
if(assign_external_model) then
- write(IOUT,*)
- write(IOUT,*) 'Assigning external velocity and density model...'
- write(IOUT,*)
+ if (myrank == 0 .and. ipass == 1) then
+ write(IOUT,*)
+ write(IOUT,*) 'Assigning external velocity and density model...'
+ write(IOUT,*)
+ endif
if(TURN_ANISOTROPY_ON .or. TURN_ATTENUATION_ON) &
call exit_MPI('cannot have anisotropy nor attenuation if external model in current version')
any_acoustic = .false.
@@ -1150,7 +1168,7 @@
! collocated force source
call locate_source_force(coord,ibool,npoin,nspec,x_source,z_source, &
- ix_source,iz_source,ispec_selected_source,iglob_source,is_proc_source,nb_proc_source)
+ ix_source,iz_source,ispec_selected_source,iglob_source,is_proc_source,nb_proc_source,ipass)
! get density at the source in order to implement collocated force with the right
! amplitude later
@@ -1180,7 +1198,7 @@
else if(source_type == 2) then
! moment-tensor source
call locate_source_moment_tensor(ibool,coord,nspec,npoin,xigll,zigll,x_source,z_source, &
- ispec_selected_source,is_proc_source,nb_proc_source,nproc,myrank,xi_source,gamma_source,coorg,knods,ngnod,npgeo)
+ ispec_selected_source,is_proc_source,nb_proc_source,nproc,myrank,xi_source,gamma_source,coorg,knods,ngnod,npgeo,ipass)
! compute source array for moment-tensor source
call compute_arrays_source(ispec_selected_source,xi_source,gamma_source,sourcearray, &
@@ -1193,7 +1211,7 @@
! locate receivers in the mesh
call locate_receivers(ibool,coord,nspec,npoin,xigll,zigll,nrec,nrecloc,recloc,which_proc_receiver,nproc,myrank,&
st_xval,st_zval,ispec_selected_rec, &
- xi_receiver,gamma_receiver,station_name,network_name,x_source,z_source,coorg,knods,ngnod,npgeo)
+ xi_receiver,gamma_receiver,station_name,network_name,x_source,z_source,coorg,knods,ngnod,npgeo,ipass)
! allocate seismogram arrays
if(ipass == 1) then
@@ -1328,8 +1346,10 @@
nspec_outer = count(mask_ispec_inner_outer)
nspec_inner = nspec - nspec_outer
- if(ipass == 1) allocate(ispec_outer_to_glob(nspec_outer))
- if(ipass == 1) allocate(ispec_inner_to_glob(nspec_inner))
+ if(ipass == 1) then
+ allocate(ispec_outer_to_glob(nspec_outer))
+ allocate(ispec_inner_to_glob(nspec_inner))
+ endif
! building of corresponding arrays between inner/outer elements and their global number
if(ipass == 1) then
@@ -1551,6 +1571,10 @@
enddo ! end of further reduction of cache misses inner/outer in two passes
+!---
+!--- end of section performed in two passes
+!---
+
! fill mass matrix with fictitious non-zero values to make sure it can be inverted globally
if(any_elastic) where(rmass_inverse_elastic <= 0._CUSTOM_REAL) rmass_inverse_elastic = 1._CUSTOM_REAL
if(any_acoustic) where(rmass_inverse_acoustic <= 0._CUSTOM_REAL) rmass_inverse_acoustic = 1._CUSTOM_REAL
@@ -2501,7 +2525,7 @@
d2_coorg_send_ps_velocity_model=nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)*4
d1_RGB_send_ps_velocity_model=1
d2_RGB_send_ps_velocity_model=nspec*((NGLLX-subsamp)/subsamp)*((NGLLX-subsamp)/subsamp)
-
+
allocate(coorg_send_ps_velocity_model(d1_coorg_send_ps_velocity_model,d2_coorg_send_ps_velocity_model))
allocate(RGB_send_ps_velocity_model(d1_RGB_send_ps_velocity_model,d2_RGB_send_ps_velocity_model))
@@ -3198,11 +3222,11 @@
ihours = int_tCPU / 3600
iminutes = (int_tCPU - 3600*ihours) / 60
iseconds = int_tCPU - 3600*ihours - 60*iminutes
- if ( myrank == 0 ) then
- write(*,*) 'Elapsed time in seconds = ',tCPU
- write(*,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
- write(*,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
- write(*,*)
+ if (myrank == 0) then
+ write(IOUT,*) 'Elapsed time in seconds = ',tCPU
+ write(IOUT,"(' Elapsed time in hh:mm:ss = ',i4,' h ',i2.2,' m ',i2.2,' s')") ihours,iminutes,iseconds
+ write(IOUT,*) 'Mean elapsed time per time step in seconds = ',tCPU/dble(it)
+ write(IOUT,*)
endif
endif
@@ -3230,7 +3254,7 @@
deallocate(t0z_bot)
!---- close energy file and create a gnuplot script to display it
- if(OUTPUT_ENERGY) then
+ if(OUTPUT_ENERGY .and. myrank == 0) then
close(IENERGY)
open(unit=IENERGY,file='plotenergy',status='unknown')
write(IENERGY,*) 'set term postscript landscape color solid "Helvetica" 22'
@@ -3326,5 +3350,5 @@
'Mzz. . . . . . . . . . . . . . . . . . =',1pe20.10,/5x, &
'Mxz. . . . . . . . . . . . . . . . . . =',1pe20.10)
-end program specfem2D
+ end program specfem2D
More information about the cig-commits
mailing list