zhangyiss/DSurfTomo
1
0
Fork 0
mirror of https://github.com/HongjianFang/DSurfTomo.git synced 2025-10-20 10:58:09 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

incorporating random projections based inversion using Poisson Voronoi cells

Browse Source
This commit is contained in:
Hongjian
2020-04-16 20:47:03 -04:00
parent 82ebf4283d
commit 9aead30bf2
19 changed files with 3883 additions and 42 deletions
Download Patch File Download Diff File Expand all files Collapse all files

10
src/Makefile
View File

@@ -1,17 +1,19 @@
CMD = DSurfTomo
FC = gfortran
FFLAGS = -O3 -ffixed-line-length-none -ffloat-store\
-W -fbounds-check -m64 -mcmodel=medium
-fbounds-check -m64 -mcmodel=medium
F90SRCS = lsmrDataModule.f90 lsmrblasInterface.f90\
lsmrblas.f90 lsmrModule.f90 delsph.f90\
aprod.f90 gaussian.f90 main.f90
FSRCS = surfdisp96.f
OBJS = $(F90SRCS:%.f90=%.o) $(FSRCS:%.f=%.o) CalSurfG.o
aprod.f90 gaussian.f90 voronoiproj.f90
FSRCS = surfdisp96.f slarnv.f slaruv.f
OBJS = $(F90SRCS:%.f90=%.o) $(FSRCS:%.f=%.o) CalSurfG.o main.o
all:$(CMD)
$(CMD):$(OBJS)
$(FC) -fopenmp $^ -o $@
CalSurfG.o:CalSurfG.f90
$(FC) -fopenmp $(FFLAGS) -c $< -o $@
main.o:main.f90
$(FC) -fopenmp $(FFLAGS) -c $< -o $@
%.o: %.f90
$(FC) $(FFLAGS) -c $(@F:.o=.f90) -o $@
%.o: %.f

109
src/main.f90
View File

@@ -20,6 +20,7 @@
program SurfTomo
use lsmrModule, only:lsmr
use lsmrblasInterface, only : dnrm2
use omp_lib
implicit none
! VARIABLE DEFINE
@@ -63,7 +64,8 @@ program SurfTomo
integer,dimension(:,:),allocatable::periods
real,dimension(:),allocatable::rw
integer,dimension(:),allocatable::iw,col
real,dimension(:),allocatable::dv,norm
real,dimension(:),allocatable::dv,norm,dvsub,dvstd,dvall
! real,dimension(:),allocatable::dvall
real,dimension(:,:,:),allocatable::vsf
real,dimension(:,:,:),allocatable::vsftrue
character strf
@@ -100,6 +102,9 @@ program SurfTomo
real maxnorm
real threshold0
!For Poisson Voronoi inverison
integer iproj,vorotomo,ncells,nrealizations,idx
real hvratio
! OPEN FILES FIRST TO OUTPUT THE PROCESS
nout=36
@@ -107,9 +112,11 @@ program SurfTomo
! OUTPUT PROGRAM INFOMATION
write(*,*)
write(*,*),' DSurfTomo (v1.3)'
write(*,*),'PLEASE contact Hongjain Fang &
(fanghj@mail.ustc.edu.cn) if you find any bug'
write(*,*) ' DSurfTomo (v2.0)'
!write(*,*) 'PLEASE contact Hongjain Fang &
! (fanghj@mail.ustc.edu.cn) if you find any bug'
write(*,*) 'For bug report, PLEASE contact Hongjain Fang &
(fanghj1990@gmail.com)'
write(*,*)
! READ INPUT FILE
@@ -151,8 +158,8 @@ program SurfTomo
write(logfile,'(a,a)')trim(inputfile),'.log'
open(66,file=logfile)
write(66,*)
write(66,*),' S U R F T O M O'
write(66,*),'PLEASE contact Hongjain Fang &
write(66,*)' S U R F T O M O'
write(66,*)'PLEASE contact Hongjain Fang &
(fanghj@mail.ustc.edu.cn) if you find any bug'
write(66,*)
write(66,*) 'model origin:latitude,longitue'
@@ -204,6 +211,8 @@ program SurfTomo
read(10,*)ifsyn
read(10,*)noiselevel
read(10,*) threshold0
read(10,*) vorotomo,ncells,nrealizations!,hvratio
close(10)
nrc=nsrc
kmax=kmaxRc+kmaxRg+kmaxLc+kmaxLg
@@ -281,7 +290,8 @@ program SurfTomo
allocate(depz(nz), stat=checkstat)
maxnar = spfra*dall*nx*ny*nz!sparsity fraction
maxvp = (nx-2)*(ny-2)*(nz-1)
allocate(dv(maxvp), stat=checkstat)
allocate(dv(maxvp),dvsub(maxvp),dvstd(maxvp),dvall(maxvp*nrealizations), stat=checkstat)
! allocate(dvall(maxvp*nrealizations),stats=checkstat)
allocate(norm(maxvp), stat=checkstat)
allocate(vsf(nx,ny,nz), stat=checkstat)
allocate(vsftrue(nx,ny,nz), stat=checkstat)
@@ -302,7 +312,7 @@ program SurfTomo
stat=checkstat)
! MEASUREMENTS STATISTICS AND READ INITIAL MODEL
write(*,'(a,i7)') 'Number of all measurements',dall
write(*,'(a,i7)') ' Number of all measurements',dall
open(10,file='MOD',status='old')
read(10,*) (depz(i),i=1,nz)
@@ -317,7 +327,7 @@ program SurfTomo
! CHECKERBOARD TEST
if (ifsyn == 1) then
write(*,*) 'Checkerboard Resolution Test Begin'
write(*,*) 'Synthetic Test Begin'
vsftrue = vsf
open(11,file='MOD.true',status='old')
@@ -397,6 +407,36 @@ program SurfTomo
! ADDING REGULARIZATION TERM
if (vorotomo /= 0) then
hvratio = dvxd*(nx-3)*111.19/depz(nz-1)
dv = 0
dvstd = 0
leniw = 2*nar+1
lenrw = nar
iw(1)=nar
iw(nar+2:2*nar+1) = col(1:nar)
!$omp parallel &
!$omp default(private) &
!$omp shared(leniw,lenrw,iw,rw,cbst,goxd,gozd,dvxd,dvzd,depz,maxvp) &
!$omp shared(nx,ny,nz,dall,ncells,hvratio,damp,nrealizations,dvall)
!$omp do
do iproj = 1,nrealizations
call voronoiproj(leniw,lenrw,iw,rw,cbst,goxd,dvxd,gozd,dvzd,depz,&
nx,ny,nz,dall,ncells,hvratio,damp,iproj,dvsub)
dvall((iproj-1)*maxvp+1:iproj*maxvp) = dvsub(1:maxvp)
enddo
!$omp end do
!$omp end parallel
do iproj = 1,nrealizations
dvsub = dvall((iproj-1)*maxvp+1:iproj*maxvp)!:,iproj)
dv = dv+dvsub
dvstd = dvstd+dvsub**2
enddo
dv = dv/nrealizations
dvstd = sqrt(dvstd/nrealizations-dv**2)
else
weight=weight0
nar_tmp=nar
nars=0
@@ -472,11 +512,13 @@ program SurfTomo
atol, btol, conlim, itnlim, localSize, nout,&
dv, istop, itn, anorm, acond, rnorm, arnorm, xnorm)
endif ! end vorotomo
mean = sum(cbst(1:dall))/dall
std_devs = sqrt(sum(cbst(1:dall)**2)/dall - mean**2)
write(*,'(i2,a)'),iter,'th iteration...'
write(*,'(a,f7.3)'),'weight is:',weight
write(*,'(a,f8.1,a,f8.2,a,f8.3)'),'mean,std_devs and rms of &
write(*,'(i2,a)')iter,'th iteration...'
! write(*,'(a,f7.3)')'weight is:',weight
write(*,'(a,f8.1,a,f8.2,a,f8.3)')' mean,std_devs and rms of &
residual after weighting: ',mean*1000,'ms ',1000*std_devs,'ms ',&
dnrm2(dall,cbst,1)/sqrt(real(dall))
@@ -486,17 +528,17 @@ program SurfTomo
mean = sum(cbst(1:dall))/dall
std_devs = sqrt(sum(cbst(1:dall)**2)/dall - mean**2)
write(*,'(a,f8.1,a,f8.2,a,f8.3)'),'residual before weighting: ',mean*1000,'ms ',1000*std_devs,'ms ',&
write(*,'(a,f8.1,a,f8.2,a,f8.3)')' residual before weighting: ',mean*1000,'ms ',1000*std_devs,'ms ',&
dnrm2(dall,cbst,1)/sqrt(real(dall))
write(66,'(i2,a)'),iter,'th iteration...'
write(66,'(a,f7.3)'),'weight is:',weight
write(66,'(a,f8.1,a,f8.2,a,f8.3)'),'mean,std_devs and rms of &
write(66,'(i2,a)')iter,'th iteration...'
! write(66,'(a,f7.3)')'weight is:',weight
write(66,'(a,f8.1,a,f8.2,a,f8.3)')'mean,std_devs and rms of &
residual: ',mean*1000,'ms ',1000*std_devs,'ms ',&
dnrm2(dall,cbst,1)/sqrt(real(dall))
write(*,'(a,2f7.4)'),'min and max velocity variation ',&
write(*,'(a,2f7.4)')' min and max velocity variation ',&
minval(dv),maxval(dv)
write(66,'(a,2f7.4)'),'min and max velocity variation ',&
write(66,'(a,2f7.4)')'min and max velocity variation ',&
minval(dv),maxval(dv)
do k=1,nz-1
@@ -531,8 +573,8 @@ program SurfTomo
! OUTPUT THE VELOCITY MODEL
write(*,*),'Program finishes successfully'
write(66,*),'Program finishes successfully'
write(*,*)'Program finishes successfully'
write(66,*)'Program finishes successfully'
if(ifsyn == 1) then
open(65,file='Vs_model.real')
@@ -548,13 +590,13 @@ program SurfTomo
enddo
close(65)
close(63)
write(*,*),'Output True velocity model &
write(*,*)'Output True velocity model &
to Vs_model.real'
write(*,*),'Output inverted shear velocity model &
write(*,*)'Output inverted shear velocity model &
to ',outsyn
write(66,*),'Output True velocity model &
write(66,*)'Output True velocity model &
to Vs_model.real'
write(66,*),'Output inverted shear velocity model &
write(66,*)'Output inverted shear velocity model &
to ',outsyn
else
write(outmodel,'(a,a)') trim(inputfile),'Measure.dat'
@@ -567,10 +609,23 @@ program SurfTomo
enddo
enddo
close(64)
write(*,*),'Output inverted shear velocity model &
write(*,*)'Output inverted shear velocity model &
to ',outmodel
write(66,*),'Output inverted shear velocity model &
write(66,*)'Output inverted shear velocity model &
to ',outmodel
write(outmodel,'(a,a)') trim(inputfile),'Measure_std.dat'
open(64,file=outmodel)
do k=1,nz-1
do j=1,ny-2
do i=1,nx-2
idx = (k-1)*(nx-2)*(ny-2)+(j-1)*(nx-2)+i
write(64,'(5f9.3)') gozd+(j-1)*dvzd,goxd-(i-1)*dvxd,depz(k),dvstd(idx)
enddo
enddo
enddo
close(64)
endif
close(40)
@@ -588,7 +643,7 @@ program SurfTomo
deallocate(rw)
deallocate(iw,col)
deallocate(cbst,wt,dtres,datweight)
deallocate(dv)
deallocate(dv,dvsub,dvstd,dvall)
deallocate(norm)
deallocate(vsf)
deallocate(vsftrue)

178
src/slarnv.f Normal file
View File

@@ -0,0 +1,178 @@
*> \brief \b SLARNV returns a vector of random numbers from a uniform or normal distribution.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLARNV + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slarnv.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slarnv.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slarnv.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLARNV( IDIST, ISEED, N, X )
*
* .. Scalar Arguments ..
* INTEGER IDIST, N
* ..
* .. Array Arguments ..
* INTEGER ISEED( 4 )
* REAL X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLARNV returns a vector of n random real numbers from a uniform or
*> normal distribution.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] IDIST
*> \verbatim
*> IDIST is INTEGER
*> Specifies the distribution of the random numbers:
*> = 1: uniform (0,1)
*> = 2: uniform (-1,1)
*> = 3: normal (0,1)
*> \endverbatim
*>
*> \param[in,out] ISEED
*> \verbatim
*> ISEED is INTEGER array, dimension (4)
*> On entry, the seed of the random number generator; the array
*> elements must be between 0 and 4095, and ISEED(4) must be
*> odd.
*> On exit, the seed is updated.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of random numbers to be generated.
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*> X is REAL array, dimension (N)
*> The generated random numbers.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> This routine calls the auxiliary routine SLARUV to generate random
*> real numbers from a uniform (0,1) distribution, in batches of up to
*> 128 using vectorisable code. The Box-Muller method is used to
*> transform numbers from a uniform to a normal distribution.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE SLARNV( IDIST, ISEED, N, X )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
INTEGER IDIST, N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE, TWO
PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0 )
INTEGER LV
PARAMETER ( LV = 128 )
REAL TWOPI
PARAMETER ( TWOPI = 6.2831853071795864769252867663E+0 )
* ..
* .. Local Scalars ..
INTEGER I, IL, IL2, IV
* ..
* .. Local Arrays ..
REAL U( LV )
* ..
* .. Intrinsic Functions ..
INTRINSIC COS, LOG, MIN, SQRT
* ..
* .. External Subroutines ..
EXTERNAL SLARUV
* ..
* .. Executable Statements ..
*
DO 40 IV = 1, N, LV / 2
IL = MIN( LV / 2, N-IV+1 )
IF( IDIST.EQ.3 ) THEN
IL2 = 2*IL
ELSE
IL2 = IL
END IF
*
* Call SLARUV to generate IL2 numbers from a uniform (0,1)
* distribution (IL2 <= LV)
*
CALL SLARUV( ISEED, IL2, U )
*
IF( IDIST.EQ.1 ) THEN
*
* Copy generated numbers
*
DO 10 I = 1, IL
X( IV+I-1 ) = U( I )
10 CONTINUE
ELSE IF( IDIST.EQ.2 ) THEN
*
* Convert generated numbers to uniform (-1,1) distribution
*
DO 20 I = 1, IL
X( IV+I-1 ) = TWO*U( I ) - ONE
20 CONTINUE
ELSE IF( IDIST.EQ.3 ) THEN
*
* Convert generated numbers to normal (0,1) distribution
*
DO 30 I = 1, IL
X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )*
$ COS( TWOPI*U( 2*I ) )
30 CONTINUE
END IF
40 CONTINUE
RETURN
*
* End of SLARNV
*
END

447
src/slaruv.f Normal file
View File

@@ -0,0 +1,447 @@
*> \brief \b SLARUV returns a vector of n random real numbers from a uniform distribution.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SLARUV + dependencies
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slaruv.f">
*> [TGZ]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slaruv.f">
*> [ZIP]</a>
*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slaruv.f">
*> [TXT]</a>
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE SLARUV( ISEED, N, X )
*
* .. Scalar Arguments ..
* INTEGER N
* ..
* .. Array Arguments ..
* INTEGER ISEED( 4 )
* REAL X( N )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SLARUV returns a vector of n random real numbers from a uniform (0,1)
*> distribution (n <= 128).
*>
*> This is an auxiliary routine called by SLARNV and CLARNV.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in,out] ISEED
*> \verbatim
*> ISEED is INTEGER array, dimension (4)
*> On entry, the seed of the random number generator; the array
*> elements must be between 0 and 4095, and ISEED(4) must be
*> odd.
*> On exit, the seed is updated.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of random numbers to be generated. N <= 128.
*> \endverbatim
*>
*> \param[out] X
*> \verbatim
*> X is REAL array, dimension (N)
*> The generated random numbers.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup OTHERauxiliary
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> This routine uses a multiplicative congruential method with modulus
*> 2**48 and multiplier 33952834046453 (see G.S.Fishman,
*> 'Multiplicative congruential random number generators with modulus
*> 2**b: an exhaustive analysis for b = 32 and a partial analysis for
*> b = 48', Math. Comp. 189, pp 331-344, 1990).
*>
*> 48-bit integers are stored in 4 integer array elements with 12 bits
*> per element. Hence the routine is portable across machines with
*> integers of 32 bits or more.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE SLARUV( ISEED, N, X )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
INTEGER N
* ..
* .. Array Arguments ..
INTEGER ISEED( 4 )
REAL X( N )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ONE
PARAMETER ( ONE = 1.0E0 )
INTEGER LV, IPW2
REAL R
PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 )
* ..
* .. Local Scalars ..
INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J
* ..
* .. Local Arrays ..
INTEGER MM( LV, 4 )
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN, MOD, REAL
* ..
* .. Data statements ..
DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508,
$ 2549 /
DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754,
$ 1145 /
DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766,
$ 2253 /
DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572,
$ 305 /
DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893,
$ 3301 /
DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307,
$ 1065 /
DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297,
$ 3133 /
DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966,
$ 2913 /
DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758,
$ 3285 /
DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598,
$ 1241 /
DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406,
$ 1197 /
DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922,
$ 3729 /
DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038,
$ 2501 /
DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934,
$ 1673 /
DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091,
$ 541 /
DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451,
$ 2753 /
DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580,
$ 949 /
DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958,
$ 2361 /
DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055,
$ 1165 /
DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507,
$ 4081 /
DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078,
$ 2725 /
DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273,
$ 3305 /
DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17,
$ 3069 /
DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854,
$ 3617 /
DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916,
$ 3733 /
DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971,
$ 409 /
DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889,
$ 2157 /
DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831,
$ 1361 /
DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621,
$ 3973 /
DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541,
$ 1865 /
DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893,
$ 2525 /
DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736,
$ 1409 /
DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992,
$ 3445 /
DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787,
$ 3577 /
DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125,
$ 77 /
DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364,
$ 3761 /
DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460,
$ 2149 /
DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257,
$ 1449 /
DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574,
$ 3005 /
DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912,
$ 225 /
DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216,
$ 85 /
DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248,
$ 3673 /
DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401,
$ 3117 /
DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124,
$ 3089 /
DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762,
$ 1349 /
DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149,
$ 2057 /
DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245,
$ 413 /
DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166,
$ 65 /
DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466,
$ 1845 /
DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018,
$ 697 /
DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399,
$ 3085 /
DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190,
$ 3441 /
DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879,
$ 1573 /
DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153,
$ 3689 /
DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320,
$ 2941 /
DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18,
$ 929 /
DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712,
$ 533 /
DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159,
$ 2841 /
DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318,
$ 4077 /
DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091,
$ 721 /
DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443,
$ 2821 /
DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510,
$ 2249 /
DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449,
$ 2397 /
DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956,
$ 2817 /
DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201,
$ 245 /
DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137,
$ 1913 /
DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399,
$ 1997 /
DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321,
$ 3121 /
DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271,
$ 997 /
DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667,
$ 1833 /
DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703,
$ 2877 /
DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629,
$ 1633 /
DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365,
$ 981 /
DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431,
$ 2009 /
DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113,
$ 941 /
DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922,
$ 2449 /
DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554,
$ 197 /
DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184,
$ 2441 /
DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099,
$ 285 /
DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228,
$ 1473 /
DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012,
$ 2741 /
DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921,
$ 3129 /
DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452,
$ 909 /
DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901,
$ 2801 /
DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572,
$ 421 /
DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309,
$ 4073 /
DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171,
$ 2813 /
DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817,
$ 2337 /
DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039,
$ 1429 /
DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696,
$ 1177 /
DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256,
$ 1901 /
DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715,
$ 81 /
DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077,
$ 1669 /
DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019,
$ 2633 /
DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497,
$ 2269 /
DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101,
$ 129 /
DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717,
$ 1141 /
DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51,
$ 249 /
DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981,
$ 3917 /
DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978,
$ 2481 /
DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813,
$ 3941 /
DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881,
$ 2217 /
DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76,
$ 2749 /
DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846,
$ 3041 /
DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694,
$ 1877 /
DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682,
$ 345 /
DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124,
$ 2861 /
DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660,
$ 1809 /
DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997,
$ 3141 /
DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479,
$ 2825 /
DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141,
$ 157 /
DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886,
$ 2881 /
DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514,
$ 3637 /
DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301,
$ 1465 /
DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604,
$ 2829 /
DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888,
$ 2161 /
DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836,
$ 3365 /
DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990,
$ 361 /
DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058,
$ 2685 /
DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692,
$ 3745 /
DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194,
$ 2325 /
DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20,
$ 3609 /
DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285,
$ 3821 /
DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046,
$ 3537 /
DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107,
$ 517 /
DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508,
$ 3017 /
DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525,
$ 2141 /
DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801,
$ 1537 /
* ..
* .. Executable Statements ..
*
I1 = ISEED( 1 )
I2 = ISEED( 2 )
I3 = ISEED( 3 )
I4 = ISEED( 4 )
*
DO 10 I = 1, MIN( N, LV )
*
20 CONTINUE
*
* Multiply the seed by i-th power of the multiplier modulo 2**48
*
IT4 = I4*MM( I, 4 )
IT3 = IT4 / IPW2
IT4 = IT4 - IPW2*IT3
IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 )
IT2 = IT3 / IPW2
IT3 = IT3 - IPW2*IT2
IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 )
IT1 = IT2 / IPW2
IT2 = IT2 - IPW2*IT1
IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) +
$ I4*MM( I, 1 )
IT1 = MOD( IT1, IPW2 )
*
* Convert 48-bit integer to a real number in the interval (0,1)
*
X( I ) = R*( REAL( IT1 )+R*( REAL( IT2 )+R*( REAL( IT3 )+R*
$ REAL( IT4 ) ) ) )
*
IF (X( I ).EQ.1.0) THEN
* If a real number has n bits of precision, and the first
* n bits of the 48-bit integer above happen to be all 1 (which
* will occur about once every 2**n calls), then X( I ) will
* be rounded to exactly 1.0. In IEEE single precision arithmetic,
* this will happen relatively often since n = 24.
* Since X( I ) is not supposed to return exactly 0.0 or 1.0,
* the statistically correct thing to do in this situation is
* simply to iterate again.
* N.B. the case X( I ) = 0.0 should not be possible.
I1 = I1 + 2
I2 = I2 + 2
I3 = I3 + 2
I4 = I4 + 2
GOTO 20
END IF
*
10 CONTINUE
*
* Return final value of seed
*
ISEED( 1 ) = IT1
ISEED( 2 ) = IT2
ISEED( 3 ) = IT3
ISEED( 4 ) = IT4
RETURN
*
* End of SLARUV
*
END

175
src/voronoiproj.f90 Normal file
View File

@@ -0,0 +1,175 @@
subroutine voronoiproj(leniw,lenrw,iw,rw,dres,goxd,dvxd,gozd,dvzd,depz,&
nx,ny,nz,nd,ncells,hvratio,damp,iproj,dv)
use lsmrModule, only:lsmr
implicit none
integer leniw,lenrw
integer nx,ny,nz
integer iw(leniw)
real depz(nz)
real rw(lenrw)
integer ncells
real dv(*),dres(*)
real goxd,gozd,dvxd,dvzd
real damp
real hvratio,cmb
integer ndim,nd
integer iproj
real,parameter:: radius = 6371.0,ftol = 0.1,pi = 3.141592654
integer ii,ix,iy,iz
real,dimension(:),allocatable:: grow,gcol,subrow,dis,dws,xunknown
real,dimension(:),allocatable:: lat,lon,rad,theta,phi,rrad,xpts,ypts,zpts
real,dimension(:),allocatable :: rw_p,rwgp,norm
integer,dimension(:),allocatable:: iw_p,row,col,iwgp,colgp
integer idx
integer maxnar,nzid
integer iseed(4)
real xs,ys,zs
real atol,btol
real conlim
integer istop
integer itnlim
real acond
real anorm
real arnorm
real rnorm
real xnorm
integer localSize,nout,itn
integer leniw_p,lenrw_p,leniwgp,lenrwgp
allocate(lat(nx-2),lon(ny-2),rad(nz-1))
ndim = (nx-2)*(ny-2)*(nz-1)
do ii = 1,nx-2
lat(ii) = (goxd-(ii-1)*dvxd)*pi/180
enddo
do ii = 1,ny-2
lon(ii) = (gozd+(ii-1)*dvzd)*pi/180
enddo
!cmb = radius - depz(nz-1)*hvratio
do ii = 1,nz-1
rad(ii) = radius-depz(ii)*hvratio
!rad(ii) = cmb+depz(ii)*hvratio
enddo
allocate(theta(ncells),phi(ncells),rrad(ncells),dws(ncells),norm(ncells))
allocate(xpts(ncells),ypts(ncells),zpts(ncells),dis(ncells),xunknown(ncells))
allocate(rw_p(ndim))
allocate(iw_p(2*ndim+1),row(ndim),col(ndim))
iseed(1:3) = (/38,62,346/)
iseed(4) = 2*iproj+1
call slarnv(1,iseed,ncells,theta)
theta = (gozd+theta*(ny-3)*dvzd)*pi/180
call slarnv(1,iseed,ncells,phi)
phi = pi/2-(goxd-phi*(nx-3)*dvxd)*pi/180
call slarnv(1,iseed,ncells,rrad)
rrad = radius-rrad*depz(nz-1)*hvratio
xpts = rrad*sin(phi)*cos(theta)
ypts = rrad*sin(phi)*sin(theta)
zpts = rrad*cos(phi)
idx = 0
do iz = 1,nz-1
do iy = 1,ny-2
do ix = 1,nx-2
xs = rrad(iz)*sin(pi/2-lat(ix))*cos(lon(iy))
ys = rrad(iz)*sin(pi/2-lat(ix))*sin(lon(iy))
zs = rrad(iz)*cos(pi/2-lat(ix))
dis = (xpts-xs)**2+(ypts-ys)**2+(zpts-zs)**2
idx = idx+1
col(idx) = (iz-1)*(nx-2)*(ny-2)+(iy-1)*(nx-2)+ix
row(idx) = minloc(dis,1)
enddo
enddo
enddo
rw_p = 1.0
leniw_p = 2*ndim+1
lenrw_p = ndim
iw_p(1) = ndim
iw_p(2:ndim+1) = row
iw_p(ndim+2:2*ndim+1) = col
allocate(grow(ndim),gcol(nd),subrow(ncells))
maxnar = int(0.6*nd*ncells)
allocate(iwgp(maxnar*2+1),colgp(maxnar),rwgp(maxnar))
nzid = 0
do ii = 1,nd
grow = 0
gcol = 0
gcol(ii) = 1.0
call aprod(2,nd,ndim,grow,gcol,leniw,lenrw,iw,rw)
subrow = 0
call aprod(1,ncells,ndim,grow,subrow,leniw_p,lenrw_p,iw_p,rw_p)
do ix = 1,ncells
if(abs(subrow(ix))>ftol) then
nzid = nzid+1
rwgp(nzid) = subrow(ix)
iwgp(1+nzid) = ii
colgp(nzid) = ix
endif
enddo
enddo
leniwgp = nzid*2+1
lenrwgp = nzid
iwgp(1) = lenrwgp
iwgp(nzid+2:nzid*2+1) = colgp(1:nzid)
dws = 0
!do ii=1,nzid
!dws(iwgp(1+ii+nzid)) = dws(iwgp(1+ii+nzid))+abs(rwgp(ii))
!enddo
norm = 0
do ii=1,nzid
norm(iwgp(1+ii+nzid)) = norm(iwgp(1+ii+nzid))+rwgp(ii)**2
enddo
do ii =1,ncells
norm(ii) = sqrt(norm(ii)/nd+0.01)
enddo
do ii =1,nzid
rwgp(ii) = rwgp(ii)/norm(iwgp(1+ii+nzid))
enddo
conlim = 50
itnlim = 100
atol = 1e-2
btol = 1e-3
istop = 0
anorm = 0.0
acond = 0.0
arnorm = 0.0
xnorm = 0.0
localSize = int(ncells/4)
!damp = dampvel
! using lsmr to solve for the projection coefficients
!print*, 'LSMR beginning ...'
nout = -1
!nout = 36
!open(nout,file='lsmrout_sub.txt')
call LSMR(nd, ncells, leniwgp, lenrwgp,iwgp,rwgp,dres,damp,&
atol, btol, conlim, itnlim, localSize,nout,&
xunknown, istop, itn, anorm, acond,rnorm, arnorm, xnorm)
!close(nout)
do ii = 1,ncells
xunknown(ii) = xunknown(ii)/norm(ii)
enddo
dv(1:ndim) = 0
call aprod(2,ncells,ndim,dv,xunknown,leniw_p,lenrw_p,iw_p,rw_p)
deallocate(grow,gcol,subrow)
deallocate(theta,phi,rrad,dws,norm)
deallocate(xpts,ypts,zpts,dis,xunknown)
deallocate(iw_p,rw_p,row,col)
deallocate(lat,lon,rad)
deallocate(iwgp,colgp,rwgp)
end subroutine